/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.filter.basic

/-!
# N-ary maps of filter

This file defines the binary and ternary maps of filters. This is mostly useful to define pointwise
operations on filters.

## Main declarations

* `filter.map₂`: Binary map of filters.
* `filter.map₃`: Ternary map of filters.

## Notes

This file is very similar to the n-ary section of `data.set.basic`. Please keep them in sync.
-/

open function set

namespace filter
variables {α α' β β' γ γ' δ δ' ε ε' : Type*} {m : α → β → γ} {f f₁ f₂ : filter α}
  {g g₁ g₂ : filter β} {h h₁ h₂ : filter γ} {s s₁ s₂ : set α} {t t₁ t₂ : set β} {u : set γ}
  {v : set δ} {a : α} {b : β} {c : γ}

/-- The image of a binary function `m : α → β → γ` as a function `filter α → filter β → filter γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`. -/
def map₂ (m : α → β → γ) (f : filter α) (g : filter β) : filter γ :=
{ sets := {s | ∃ u v, u ∈ f ∧ v ∈ g ∧ image2 m u v ⊆ s},
  univ_sets := ⟨univ, univ, univ_sets _, univ_sets _, subset_univ _⟩,
  sets_of_superset := λ s t hs hst,
    Exists₂.imp (λ u v, and.imp_right $ and.imp_right $ λ h, subset.trans h hst) hs,
  inter_sets := λ s t,
  begin
    simp only [exists_prop, mem_set_of_eq, subset_inter_iff],
    rintro ⟨s₁, s₂, hs₁, hs₂, hs⟩ ⟨t₁, t₂, ht₁, ht₂, ht⟩,
    exact ⟨s₁ ∩ t₁, s₂ ∩ t₂, inter_sets f hs₁ ht₁, inter_sets g hs₂ ht₂,
      (image2_subset (inter_subset_left _ _) $ inter_subset_left _ _).trans hs,
      (image2_subset (inter_subset_right _ _) $ inter_subset_right _ _).trans ht⟩,
  end }

@[simp] lemma mem_map₂_iff : u ∈ map₂ m f g ↔ ∃ s t, s ∈ f ∧ t ∈ g ∧ image2 m s t ⊆ u := iff.rfl

lemma image2_mem_map₂ (hs : s ∈ f) (ht : t ∈ g) : image2 m s t ∈ map₂ m f g :=
⟨_, _, hs, ht, subset.rfl⟩

-- lemma image2_mem_map₂_iff (hm : injective2 m) : image2 m s t ∈ map₂ m f g ↔ s ∈ f ∧ t ∈ g :=
-- ⟨by { rintro ⟨u, v, hu, hv, h⟩, rw image2_subset_image2_iff hm at h,
--   exact ⟨mem_of_superset hu h.1, mem_of_superset hv h.2⟩ }, λ h, image2_mem_map₂ h.1 h.2⟩

lemma map₂_mono (hf : f₁ ≤ f₂) (hg : g₁ ≤ g₂) : map₂ m f₁ g₁ ≤ map₂ m f₂ g₂ :=
λ _ ⟨s, t, hs, ht, hst⟩, ⟨s, t, hf hs, hg ht, hst⟩

lemma map₂_mono_left (h : g₁ ≤ g₂) : map₂ m f g₁ ≤ map₂ m f g₂ := map₂_mono subset.rfl h
lemma map₂_mono_right (h : f₁ ≤ f₂) : map₂ m f₁ g ≤ map₂ m f₂ g := map₂_mono h subset.rfl

@[simp] lemma le_map₂_iff {h : filter γ} :
  h ≤ map₂ m f g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → image2 m s t ∈ h :=
⟨λ H s hs t ht, H $ image2_mem_map₂ hs ht, λ H u ⟨s, t, hs, ht, hu⟩, mem_of_superset (H hs ht) hu⟩

@[simp] lemma map₂_bot_left : map₂ m ⊥ g = ⊥ :=
empty_mem_iff_bot.1 ⟨∅, univ, trivial, univ_mem, (image2_empty_left).subset⟩

@[simp] lemma map₂_bot_right : map₂ m f ⊥ = ⊥ :=
empty_mem_iff_bot.1 ⟨univ, ∅, univ_mem, trivial, (image2_empty_right).subset⟩

@[simp] lemma map₂_eq_bot_iff : map₂ m f g = ⊥ ↔ f = ⊥ ∨ g = ⊥ :=
begin
  simp only [←empty_mem_iff_bot, mem_map₂_iff, subset_empty_iff, image2_eq_empty_iff],
  split,
  { rintro ⟨s, t, hs, ht, rfl | rfl⟩,
    { exact or.inl hs },
    { exact or.inr ht } },
  { rintro (h | h),
    { exact ⟨_, _, h, univ_mem, or.inl rfl⟩ },
    { exact ⟨_, _, univ_mem, h, or.inr rfl⟩ } }
end

@[simp] lemma map₂_ne_bot_iff : (map₂ m f g).ne_bot ↔ f.ne_bot ∧ g.ne_bot :=
by { simp_rw ne_bot_iff, exact map₂_eq_bot_iff.not.trans not_or_distrib }

lemma ne_bot.map₂ (hf : f.ne_bot) (hg : g.ne_bot) : (map₂ m f g).ne_bot :=
map₂_ne_bot_iff.2 ⟨hf, hg⟩

lemma map₂_sup_left : map₂ m (f₁ ⊔ f₂) g = map₂ m f₁ g ⊔ map₂ m f₂ g :=
begin
  ext u,
  split,
  { rintro ⟨s, t, ⟨h₁, h₂⟩, ht, hu⟩,
    exact ⟨mem_of_superset (image2_mem_map₂ h₁ ht) hu,
      mem_of_superset (image2_mem_map₂ h₂ ht) hu⟩ },
  { rintro ⟨⟨s₁, t₁, hs₁, ht₁, hu₁⟩, s₂, t₂, hs₂, ht₂, hu₂⟩,
    refine ⟨s₁ ∪ s₂, t₁ ∩ t₂, union_mem_sup hs₁ hs₂, inter_mem ht₁ ht₂, _⟩,
    rw image2_union_left,
    exact union_subset ((image2_subset_left $ inter_subset_left _ _).trans hu₁)
      ((image2_subset_left $ inter_subset_right _ _).trans hu₂) }
end

lemma map₂_sup_right : map₂ m f (g₁ ⊔ g₂) = map₂ m f g₁ ⊔ map₂ m f g₂ :=
begin
  ext u,
  split,
  { rintro ⟨s, t, hs, ⟨h₁, h₂⟩, hu⟩,
    exact ⟨mem_of_superset (image2_mem_map₂ hs h₁) hu,
      mem_of_superset (image2_mem_map₂ hs h₂) hu⟩ },
  { rintro ⟨⟨s₁, t₁, hs₁, ht₁, hu₁⟩, s₂, t₂, hs₂, ht₂, hu₂⟩,
    refine ⟨s₁ ∩ s₂, t₁ ∪ t₂, inter_mem hs₁ hs₂, union_mem_sup ht₁ ht₂, _⟩,
    rw image2_union_right,
    exact union_subset ((image2_subset_right $ inter_subset_left _ _).trans hu₁)
      ((image2_subset_right $ inter_subset_right _ _).trans hu₂) }
end

lemma map₂_inf_subset_left : map₂ m (f₁ ⊓ f₂) g ≤ map₂ m f₁ g ⊓ map₂ m f₂ g :=
le_inf (map₂_mono_right inf_le_left) (map₂_mono_right inf_le_right)

lemma map₂_inf_subset_right : map₂ m f (g₁ ⊓ g₂) ≤ map₂ m f g₁ ⊓ map₂ m f g₂ :=
le_inf (map₂_mono_left inf_le_left) (map₂_mono_left inf_le_right)

@[simp] lemma map₂_pure_left : map₂ m (pure a) g = g.map (λ b, m a b) :=
filter.ext $ λ u, ⟨λ ⟨s, t, hs, ht, hu⟩,
  mem_of_superset (image_mem_map ht) ((image_subset_image2_right $ mem_pure.1 hs).trans hu),
    λ h, ⟨{a}, _, singleton_mem_pure, h, by rw [image2_singleton_left, image_subset_iff]⟩⟩

@[simp] lemma map₂_pure_right : map₂ m f (pure b) = f.map (λ a, m a b) :=
filter.ext $ λ u, ⟨λ ⟨s, t, hs, ht, hu⟩,
  mem_of_superset (image_mem_map hs) ((image_subset_image2_left $ mem_pure.1 ht).trans hu),
    λ h, ⟨_, {b}, h, singleton_mem_pure, by rw [image2_singleton_right, image_subset_iff]⟩⟩

lemma map₂_pure : map₂ m (pure a) (pure b) = pure (m a b) := by rw [map₂_pure_right, map_pure]

lemma map₂_swap (m : α → β → γ) (f : filter α) (g : filter β) :
  map₂ m f g = map₂ (λ a b, m b a) g f :=
by { ext u, split; rintro ⟨s, t, hs, ht, hu⟩; refine ⟨t, s, ht, hs, by rwa image2_swap⟩ }

@[simp] lemma map₂_left (h : g.ne_bot) : map₂ (λ x y, x) f g = f :=
begin
  ext u,
  refine ⟨_, λ hu, ⟨_, _, hu, univ_mem, (image2_left $ h.nonempty_of_mem univ_mem).subset⟩⟩,
  rintro ⟨s, t, hs, ht, hu⟩,
  rw image2_left (h.nonempty_of_mem ht) at hu,
  exact mem_of_superset hs hu,
end

@[simp] lemma map₂_right (h : f.ne_bot) : map₂ (λ x y, y) f g = g := by rw [map₂_swap, map₂_left h]

/-- The image of a ternary function `m : α → β → γ → δ` as a function
`filter α → filter β → filter γ → filter δ`. Mathematically this should be thought of as the image
of the corresponding function `α × β × γ → δ`. -/
def map₃ (m : α → β → γ → δ) (f : filter α) (g : filter β) (h : filter γ) : filter δ :=
{ sets := {s | ∃ u v w, u ∈ f ∧ v ∈ g ∧ w ∈ h ∧ image3 m u v w ⊆ s},
  univ_sets := ⟨univ, univ, univ, univ_sets _, univ_sets _, univ_sets _, subset_univ _⟩,
  sets_of_superset := λ s t hs hst, Exists₃.imp
    (λ u v w, and.imp_right $ and.imp_right $ and.imp_right $ λ h, subset.trans h hst) hs,
  inter_sets := λ s t,
  begin
    simp only [exists_prop, mem_set_of_eq, subset_inter_iff],
    rintro ⟨s₁, s₂, s₃, hs₁, hs₂, hs₃, hs⟩ ⟨t₁, t₂, t₃, ht₁, ht₂, ht₃, ht⟩,
    exact ⟨s₁ ∩ t₁, s₂ ∩ t₂, s₃ ∩ t₃, inter_mem hs₁ ht₁, inter_mem hs₂ ht₂, inter_mem hs₃ ht₃,
      (image3_mono (inter_subset_left _ _) (inter_subset_left _ _) $ inter_subset_left _ _).trans
        hs,
      (image3_mono (inter_subset_right _ _) (inter_subset_right _ _) $ inter_subset_right _ _).trans
        ht⟩,
  end }

lemma map₂_map₂_left (m : δ → γ → ε) (n : α → β → δ) :
  map₂ m (map₂ n f g) h = map₃ (λ a b c, m (n a b) c) f g h :=
begin
  ext w,
  split,
  { rintro ⟨s, t, ⟨u, v, hu, hv, hs⟩, ht, hw⟩,
    refine ⟨u, v, t, hu, hv, ht, _⟩,
    rw ←image2_image2_left,
    exact (image2_subset_right hs).trans hw },
  { rintro ⟨s, t, u, hs, ht, hu, hw⟩,
    exact ⟨_, u, image2_mem_map₂ hs ht, hu, by rwa image2_image2_left⟩ }
end

lemma map₂_map₂_right (m : α → δ → ε) (n : β → γ → δ) :
  map₂ m f (map₂ n g h) = map₃ (λ a b c, m a (n b c)) f g h :=
begin
  ext w,
  split,
  { rintro ⟨s, t, hs, ⟨u, v, hu, hv, ht⟩, hw⟩,
    refine ⟨s, u, v, hs, hu, hv, _⟩,
    rw ←image2_image2_right,
    exact (image2_subset_left ht).trans hw },
  { rintro ⟨s, t, u, hs, ht, hu, hw⟩,
    exact ⟨s, _, hs, image2_mem_map₂ ht hu, by rwa image2_image2_right⟩ }
end

lemma map_map₂ (m : α → β → γ) (n : γ → δ) : (map₂ m f g).map n = map₂ (λ a b, n (m a b)) f g :=
filter.ext $ λ u, exists₂_congr $ λ s t, by rw [←image_subset_iff, image_image2]

lemma map₂_map_left (m : γ → β → δ) (n : α → γ) :
  map₂ m (f.map n) g = map₂ (λ a b, m (n a) b) f g :=
begin
  ext u,
  split,
  { rintro ⟨s, t, hs, ht, hu⟩,
    refine ⟨_, t, hs, ht, _⟩,
    rw ←image2_image_left,
    exact (image2_subset_right $ image_preimage_subset _ _).trans hu },
  { rintro ⟨s, t, hs, ht, hu⟩,
    exact ⟨_, t, image_mem_map hs, ht, by rwa image2_image_left⟩ }
end

lemma map₂_map_right (m : α → γ → δ) (n : β → γ) :
  map₂ m f (g.map n) = map₂ (λ a b, m a (n b)) f g :=
by rw [map₂_swap, map₂_map_left, map₂_swap]

/-!
### Algebraic replacement rules

A collection of lemmas to transfer associativity, commutativity, distributivity, ... of operations
to the associativity, commutativity, distributivity, ... of `filter.map₂` of those operations.

The proof pattern is `map₂_lemma operation_lemma`. For example, `map₂_comm mul_comm` proves that
`map₂ (*) f g = map₂ (*) g f` in a `comm_semigroup`.
-/

lemma map₂_assoc {m : δ → γ → ε} {n : α → β → δ} {m' : α → ε' → ε} {n' : β → γ → ε'}
  {h : filter γ} (h_assoc : ∀ a b c, m (n a b) c = m' a (n' b c)) :
  map₂ m (map₂ n f g) h = map₂ m' f (map₂ n' g h) :=
by simp only [map₂_map₂_left, map₂_map₂_right, h_assoc]

lemma map₂_comm {n : β → α → γ} (h_comm : ∀ a b, m a b = n b a) : map₂ m f g = map₂ n g f :=
(map₂_swap _ _ _).trans $ by simp_rw h_comm

lemma map₂_left_comm {m : α → δ → ε} {n : β → γ → δ} {m' : α → γ → δ'} {n' : β → δ' → ε}
  (h_left_comm : ∀ a b c, m a (n b c) = n' b (m' a c)) :
  map₂ m f (map₂ n g h) = map₂ n' g (map₂ m' f h) :=
by { rw [map₂_swap m', map₂_swap m], exact map₂_assoc (λ _ _ _, h_left_comm _ _ _) }

lemma map₂_right_comm {m : δ → γ → ε} {n : α → β → δ} {m' : α → γ → δ'} {n' : δ' → β → ε}
  (h_right_comm : ∀ a b c, m (n a b) c = n' (m' a c) b) :
  map₂ m (map₂ n f g) h = map₂ n' (map₂ m' f h) g :=
by { rw [map₂_swap n, map₂_swap n'], exact map₂_assoc (λ _ _ _, h_right_comm _ _ _) }

lemma map_map₂_distrib {n : γ → δ} {m' : α' → β' → δ} {n₁ : α → α'} {n₂ : β → β'}
  (h_distrib : ∀ a b, n (m a b) = m' (n₁ a) (n₂ b)) :
  (map₂ m f g).map n = map₂ m' (f.map n₁) (g.map n₂) :=
by simp_rw [map_map₂, map₂_map_left, map₂_map_right, h_distrib]

/-- Symmetric of `filter.map₂_map_left_comm`. -/
lemma map_map₂_distrib_left {n : γ → δ} {m' : α' → β → δ} {n' : α → α'}
  (h_distrib : ∀ a b, n (m a b) = m' (n' a) b) :
  (map₂ m f g).map n = map₂ m' (f.map n') g :=
map_map₂_distrib h_distrib

/-- Symmetric of `filter.map_map₂_right_comm`. -/
lemma map_map₂_distrib_right {n : γ → δ} {m' : α → β' → δ} {n' : β → β'}
  (h_distrib : ∀ a b, n (m a b) = m' a (n' b)) :
  (map₂ m f g).map n = map₂ m' f (g.map n') :=
map_map₂_distrib h_distrib

/-- Symmetric of `filter.map_map₂_distrib_left`. -/
lemma map₂_map_left_comm {m : α' → β → γ} {n : α → α'} {m' : α → β → δ} {n' : δ → γ}
  (h_left_comm : ∀ a b, m (n a) b = n' (m' a b)) :
  map₂ m (f.map n) g = (map₂ m' f g).map n' :=
(map_map₂_distrib_left $ λ a b, (h_left_comm a b).symm).symm

/-- Symmetric of `filter.map_map₂_distrib_right`. -/

lemma map_map₂_antidistrib {n : γ → δ} {m' : β' → α' → δ} {n₁ : β → β'} {n₂ : α → α'}
  (h_antidistrib : ∀ a b, n (m a b) = m' (n₁ b) (n₂ a)) :
  (map₂ m f g).map n = map₂ m' (g.map n₁) (f.map n₂) :=
by { rw map₂_swap m, exact map_map₂_distrib (λ _ _, h_antidistrib _ _) }

/-- Symmetric of `filter.map₂_map_left_anticomm`. -/
lemma map_map₂_antidistrib_left {n : γ → δ} {m' : β' → α → δ} {n' : β → β'}
  (h_antidistrib : ∀ a b, n (m a b) = m' (n' b) a) :
  (map₂ m f g).map n = map₂ m' (g.map n') f :=
map_map₂_antidistrib h_antidistrib

/-- Symmetric of `filter.map_map₂_right_anticomm`. -/
lemma map_map₂_antidistrib_right {n : γ → δ} {m' : β → α' → δ} {n' : α → α'}
  (h_antidistrib : ∀ a b, n (m a b) = m' b (n' a)) :
  (map₂ m f g).map n = map₂ m' g (f.map n') :=
map_map₂_antidistrib h_antidistrib

/-- Symmetric of `filter.map_map₂_antidistrib_left`. -/
lemma map₂_map_left_anticomm {m : α' → β → γ} {n : α → α'} {m' : β → α → δ} {n' : δ → γ}
  (h_left_anticomm : ∀ a b, m (n a) b = n' (m' b a)) :
  map₂ m (f.map n) g = (map₂ m' g f).map n' :=
(map_map₂_antidistrib_left $ λ a b, (h_left_anticomm b a).symm).symm

/-- Symmetric of `filter.map_map₂_antidistrib_right`. -/
lemma map_map₂_right_anticomm {m : α → β' → γ} {n : β → β'} {m' : β → α → δ} {n' : δ → γ}
  (h_right_anticomm : ∀ a b, m a (n b) = n' (m' b a)) :
  map₂ m f (g.map n) = (map₂ m' g f).map n' :=
(map_map₂_antidistrib_right $ λ a b, (h_right_anticomm b a).symm).symm

end filter


/-
Copyright (c) 2021 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving, Simon Hudon
-/
import LSpec.SlimCheck.Control.Random

/-!
# `Gen` Monad
This monad is used to formulate randomized computations with a parameter
to specify the desired size of the result.
This is a port of the Haskell QuickCheck library.
## Main definitions
  * `Gen` monad
## Tags
random testing
## References
  * https://hackage.haskell.org/package/QuickCheck
-/

namespace SlimCheck

open Random

/-- Monad to generate random examples to test properties with.
It has a `Nat` parameter so that the caller can decide on the
size of the examples. -/
abbrev Gen (α : Type u) := ReaderT (ULift Nat) Rand α

namespace Gen

/-- Lift `Random.random` to the `Gen` monad. -/
def chooseAny (α : Type u) [Random α] [DefaultRange α] : Gen α :=
  λ _ => rand α

/-- Lift `BoundedRandom.randomR` to the `Gen` monad. -/
def choose (α : Type u) [Random α] (lo hi : α) : Gen α :=
  λ _ => randBound α lo hi

/-- Generate a `Nat` example between `x` and `y` (exclusively). -/
def chooseNatLt (lo hi : Nat) : Gen Nat :=
  choose Nat (lo.succ) hi

/-- Get access to the size parameter of the `Gen` monad. -/
def getSize : Gen Nat :=
  return (← read).down

/-- Apply a function to the size parameter. -/
def resize (f : Nat → Nat) (x : Gen α) : Gen α :=
  withReader (ULift.up ∘ f ∘ ULift.down) x

/-- Create an `Array` of examples using `x`. The size is controlled
by the size parameter of `Gen`. -/
def arrayOf (x : Gen α) : Gen (Array α) := do
  let sz ← choose Nat 0 (← getSize)
  let mut res := #[]
  for _ in [0:sz] do
    res := res.push (← x)
  pure res

/-- Create an `List` of examples using `x`. The size is controlled
by the size parameter of `Gen`. -/
def listOf (x : Gen α) : Gen (List α) :=
  arrayOf x >>= pure ∘ Array.toList

/-- Given a list of example generators, choose one to create an example. -/
def oneOf [Inhabited α] (xs : Array (Gen α)) : Gen α := do
  let x ← chooseNatLt 0 xs.size
  xs.get! x

/-- Given a list of examples, choose one to create an example. -/
def elements [Inhabited α] (xs : List α) : Gen α := do
  let x ← chooseNatLt 0 xs.length
  pure $ xs.get! x

open List in
/-- Generate a random permutation of a given list. -/
def permutationOf : (xs : List α) → Gen (List α)
| [] => pure []
| x::xs => do
  let ys ← permutationOf xs
  let n ← choose Nat 0 ys.length
  pure $ ys.take n ++ [x] ++ ys.drop n

/-- Given two generators produces a tuple consisting out of the result of both -/
def prodOf {α β : Type u} (x : Gen α) (y : Gen β) : Gen (α × β) := do
  pure (←x, ←y)

end Gen

/-- Execute a `Gen` inside the `IO` monad using `size` as the example size-/
def Gen.run (x : Gen α) (size : Nat) : BaseIO α :=
  IO.runRand $ ReaderT.run x ⟨size⟩

end SlimCheck


import tactic

noncomputable theory
open_locale classical

@[protect_proj]
class subset (A : Type*) (B : out_param $ Type*) :=
(mem : B → A → Prop)

namespace subset
-- The following allows us to use the symbol `∈`
instance {A : Type*} {B : Type*} [subset A B] : has_mem B A := ⟨subset.mem⟩

-- This says that two "subset"s are equivalent (written `≈`, type with \approx) when
-- they have the same points.
instance {A : Type*} {B : Type*} [subset A B] : has_equiv A := ⟨λ X Y, ∀ t, t ∈ X ↔ t ∈ Y⟩
@[simp] lemma equiv_iff {A : Type*} {B : Type*} [subset A B] (X Y : A) : X ≈ Y ↔ ∀ t, t ∈ X ↔ t ∈ Y := iff.rfl

-- A "subset" can always be considered as an actual subset, in Lean this is `set B`
instance {A : Type*} {B : Type*} [subset A B] : has_coe_t A (set B) := ⟨λ x p, p ∈ x⟩

@[simp] lemma mem_pts  {A : Type*} {B : Type*} [subset A B] (a : A) (P : B) : P ∈ (a : set B) ↔ P ∈ a
:= iff.rfl

end subset

@[simp] def pts {A : Type*} {B : Type*} [subset A B] : A → set B := λ a, {x : B | x ∈ a}

notation p `xor` q := (p ∧ ¬ q) ∨ (q ∧ ¬ p)
def xor3 (p q r : Prop) : Prop := (p ∧ ¬ q ∧ ¬ r) ∨ (¬ p ∧ q ∧ ¬ r) ∨ (¬ p ∧ ¬ q ∧ r)

class PreHilbertPlane (Point : Type*) :=
	(Line : Type*)
  (belongs : Point → Line → Prop)
	(between : Point → Point → Point → Prop)

  (notation A `∈` ℓ := belongs A ℓ)

	-- I1: there is a unique line passing through two distinct points.
	(I1 {A B : Point} (h : A ≠ B) : ∃! (ℓ : Line) , A ∈ ℓ ∧ B ∈ ℓ)

	-- I2: any line contains at least two points.
	(I2 (ℓ : Line) : ∃ A B : Point, A ≠ B ∧ A ∈ ℓ ∧ B ∈ ℓ)

	-- I3: there exists 3 non-collinear points.
	(I3 : ∃ A B C : Point, (A ≠ B ∧ A ≠ C ∧ B ≠ C ∧ (∀ ℓ : Line, (A ∈ ℓ ∧ B ∈ ℓ) → (¬ (C ∈ ℓ) ))))

namespace PreHilbertPlane
variables {Ω : Type*} [PreHilbertPlane Ω]

-- From here on, we can use the symbol `∈` for Lines
instance : subset (Line Ω) Ω := {mem := belongs}

notation A `*` B `*` C := PreHilbertPlane.between A B C

def collinear_triple (A B C : Ω) : Prop := ∃ {ℓ : Line Ω}, A ∈ ℓ ∧ B ∈ ℓ ∧ C ∈ ℓ
@[simp] lemma collinear_triple_iff {A B C : Ω} :
	collinear_triple A B C ↔ ∃ ℓ : Line Ω, A ∈ ℓ ∧ B ∈ ℓ ∧ C ∈ ℓ := iff.rfl

def collinear (S : set Ω) : Prop := ∃ {ℓ : Line Ω}, ∀ {P}, P ∈ S → P ∈ ℓ

@[simp]
lemma collinear_def (A B C : Ω) : collinear_triple A B C ↔ collinear ({A, B, C} : set Ω) :=
begin
	split;
	{
		intro h,
		obtain ⟨ℓ, hℓ⟩ := h,
		use ℓ,
		finish,
	},
end

def intersect (r s : Line Ω) : Prop := ∃ A, A ∈ r ∧ A ∈ s

def parallel (r s : Line Ω) : Prop := (r = s) ∨ (¬ intersect r s)
notation r `||` s := parallel r s

end PreHilbertPlane

open PreHilbertPlane

/--
Next we introduce the notion of a Segment. A segment is the giving two points, A and B.
We will use the notation A⬝B to denote the segment denoted by A and B. The segment A⬝B consists
of all the points X such that A * X * B, together with A and B.
-/
structure Segment (Point : Type*) :=
	(A : Point) (B : Point)

infix `⬝`:100 := Segment.mk

namespace Segment

variables {Ω : Type*} [PreHilbertPlane Ω]

-- Declare when P ∈ A⬝B
instance : subset (Segment Ω) Ω := { mem := λ P S, P = S.A ∨ P = S.B ∨ S.A * P * S.B}
@[simp] lemma mem_pts (S : Segment Ω) (P : Ω) : P ∈ S ↔ P = S.A ∨ P = S.B ∨ S.A * P * S.B := iff.rfl

end Segment

structure Ray (Point : Type*):=
	(origin : Point) (target : Point)
notation A `=>` B := Ray.mk A B

namespace Ray
variables {Ω : Type*} [PreHilbertPlane Ω]

instance : subset (Ray Ω) Ω := { mem := λ P r, P = r.origin ∨ (collinear_triple r.origin P r.target ∧ ¬ r.origin ∈ pts (P⬝r.target)) }

def nondegenerate (r : Ray Ω) := r.origin ≠ r.target

end Ray

structure Angle (Point : Type*) :=
	(A : Point) (x : Point)	(B : Point)
notation `∟`:100 := Angle.mk

namespace Angle
variables {Ω : Type*} [PreHilbertPlane Ω]

def nondegenerate (a : Angle Ω) := ¬ collinear_triple a.A a.x a.B

end Angle

namespace HilbertPlane
variables {Ω : Type*} [PreHilbertPlane Ω]
variables {A B : Ω}
variables {r s : Line Ω}

lemma I11 (h: A ≠ B) : ∃ (ℓ : Line Ω), A ∈ ℓ ∧ B ∈ ℓ := exists_of_exists_unique (I1 h)

lemma I12 (h: A ≠ B) (hAr: A ∈ r) (hBr : B ∈ r) (hAs : A ∈ s) (hBs : B ∈ s) : r = s :=
begin
    apply (unique_of_exists_unique (I1 h));
    tauto,
end

lemma there_are_two_points : ∃ A B : Ω, (A ≠ B) :=
begin
    rcases I3 with ⟨A, ⟨B, ⟨C, ⟨h1, h2⟩⟩⟩⟩,
    use [A, B],
		exact _inst_1,
end

def line_through_aux (A B : Ω) : {ℓ : Line Ω // A ∈ ℓ ∧ B ∈ ℓ} :=
begin
    apply classical.indefinite_description,
    by_cases h : A = B,
    {
        subst h,
        have h1 : ∃ C D : Ω, C ≠ D := there_are_two_points,
        obtain ⟨C, D, hC⟩ := h1,
        by_cases h1 : A = C,
        {
            subst h1,
            obtain ⟨ℓ, hAℓ, _⟩ := I11 hC,
            exact ⟨ℓ, hAℓ, hAℓ⟩,
        },
        {
            obtain ⟨ℓ, hAℓ, _⟩ := I11 h1,
            exact ⟨ℓ, hAℓ, hAℓ⟩,
        },
    },
    exact I11 h,
end

def same_side  (ℓ : Line Ω) (A B: Ω) := (A ∈ ℓ ∧ B ∈ ℓ) ∨ ( pts (A⬝B) ∩ ℓ = ∅)
def line_through (A B : Ω) : Line Ω := (line_through_aux A B).1

end HilbertPlane

open HilbertPlane

class HilbertPlane (Point : Type*) extends PreHilbertPlane Point :=
	/- Betweenness is symmetric -/
	(B11 {A B C : Point} : (A * B * C) → (C * B * A))
	/- If A * B * C then the three points are distinct and collinear. -/
	(B12 {A B C : Point} : (A * B * C) → (A ≠ B ∧ A ≠ C ∧ B ≠ C ∧ collinear_triple A B C))
	/- Given two distinct points A, B, there is a third point C such that A * B * C.-/
	(B2 {A B : Point} (h: A ≠ B) : ∃ C, A * B * C)
	/- Given 3 distinct collinear points A B C, exactly one of them is between the other two.-/
	(B3 {A B C : Point} (h: collinear_triple A B C) :
		xor3 (A * B * C) ( B * A * C ) (A * C * B))

	(B4 {A B C D : Point} {ℓ : Line} -- Pasch
		(hnc: ¬ collinear_triple A B C)
		(hnAl: ¬ (A ∈ ℓ)) (hnBl: ¬ B ∈ ℓ) (hnCl: ¬ C ∈ ℓ)
		(hDl: D ∈ ℓ) (hADB: A * D * B) :
    (∃ E ,  E ∈ ℓ ∧ (A * E * C)) xor (∃ E, E ∈ ℓ ∧ (B * E * C)))

	(seg_cong : Segment Point → Segment Point → Prop)
	(notation X `≅`:50 Y := seg_cong X Y)
	(ang_cong : Angle Point → Angle Point → Prop)
	(notation X `≃`:50 Y := ang_cong X Y)

	/- Given a segment AB and a ray C->D, there is a unique point E on C->D such that
		AB ≅ CE. -/
	(C1 (S : Segment Point) (r : Ray Point) :
		∃! E, (E ∈ pts r) ∧ ((S.A⬝S.B) ≅ (r.origin⬝E)))
	/- Congruence of segments is reverse-transitive -/
	(C21 (S T U): (S ≅ T) → (S ≅ U) → (T ≅ U))
	/- Congruence of segments is reflexive.
	Note that this together with C21 implies symmetry of congruence. -/
	(C22 (S) : S ≅ S)
	/- Congruence of segments respects the notion of sum of segments -/
	(C3 (A B C D E F) : (A * B * C) → (D * E * F) →
		((A⬝B) ≅ (D⬝E)) → ((B⬝C) ≅ (E⬝F)) → ((A⬝C) ≅ (D⬝F)))
	/- Given a nondegenerate angle α, a segment AB, and a point s,
	construct a point E on the same side as s, such that ∟EAB ≃ α. -/
	(C4 (α : Angle Point) (S : Ray Point) (s : Point)
		(hα : α.nondegenerate) (hs : ¬ collinear_triple s S.origin S.target) :
		∃! ℓ : Line, ∃ E : Point, E ∈ ℓ ∧ S.origin ∈ ℓ ∧ (∟ E S.origin S.target ≃ α)
		∧ same_side (line_through S.origin S.target) E s)
	/- Congruence of angles is reverse-transitive.-/
	(C5 (α β γ : Angle Point) : α ≃ β → α ≃ γ → β ≃ γ)
	/- Given triangles T and T', if they have two sides and their middle angle
	congruent, then the third sides and the other two angles are also congruent.-/
	(C6 (A B C A' B' C') : (A⬝B ≅ A'⬝B') → (A⬝C ≅ A'⬝C') → (∟ B A C ≃ ∟ B' A' C') →
		(B⬝C ≅ B'⬝C') ∧ (∟ A B C ≃ ∟ A' B' C') ∧ (∟ A C B ≃ ∟ A' C' B'))

class EuclideanPlane (Point : Type*) extends HilbertPlane Point :=
	(parallel_postulate {ℓ r s : Line} :
		(intersect r s) → (r || ℓ) → (s || ℓ) → (r = s))

namespace HilbertPlane

notation X `≅`:50 Y:50 := HilbertPlane.seg_cong X Y
notation X `≅`:50 Y:50 := HilbertPlane.ang_cong X Y

end HilbertPlane

structure Triangle (Point : Type*) :=
	(A : Point) (B : Point)	(C : Point)
notation `▵`:100 := Triangle.mk

namespace Triangle
variables {Ω : Type*} [HilbertPlane Ω]

instance : subset (Triangle Ω) Ω :=
{mem := λ P T, P ∈ T.A⬝T.B ∨ P ∈ T.B⬝T.C ∨ P ∈ T.A⬝T.C}

def nondegenerate (T : Triangle Ω) := ¬ collinear_triple T.A T.B T.C

def is_similar (T R : Triangle Ω) : Prop :=
	(∟ T.B T.A T.C ≅ ∟ R.B R.A R.C)
∧ (∟ T.A T.C T.B ≅ ∟ R.A R.C R.B)
∧ (∟ T.C T.B T.A ≅ ∟ R.C R.B R.A)

def is_congruent (T R : Triangle Ω) : Prop :=
	is_similar T R ∧ (T.A⬝T.B ≅ R.A⬝R.B) ∧ (T.A⬝T.C ≅ R.A⬝R.C) ∧ (T.B⬝T.C ≅ R.B⬝R.C)

end Triangle


/-
Copyright (c) 2022 Asta H. From. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Asta H. From
-/

import Aesop

set_option aesop.check.script true

--- Decidable

attribute [aesop unsafe [50% constructors, 50% cases]] Decidable
attribute [aesop safe apply] instDecidableAnd

--- Mem

attribute [aesop safe (cases (patterns := [List.Mem _ []]))] List.Mem
attribute [aesop unsafe 50% constructors] List.Mem
attribute [aesop unsafe 50% (cases (patterns := [List.Mem _ (_ :: _)]))] List.Mem

theorem Mem.map {x : α} {xs : List α} (f : α → β) (h : x ∈ xs) : f x ∈ xs.map f := by
  induction h <;> aesop

theorem Mem.split [DecidableEq α] {xs : List α} {v : α} (h : v ∈ xs)
  : ∃ l r, xs = l ++ v :: r := by
  induction xs
  case nil =>
    aesop
  case cons x xs ih =>
    have dec : Decidable (x = v) := inferInstance
    cases dec
    case isFalse no =>
      let ⟨l, r, eq⟩ : ∃ l r, xs = l ++ v :: r := by aesop
      rw [eq]
      exact ⟨x :: l, r, rfl⟩
    case isTrue yes =>
      rw [yes]
      exact ⟨[], xs, rfl⟩

--- All

@[aesop safe [constructors, (cases (patterns := [All _ [], All _ (_ :: _)]))]]
inductive All (P : α → Prop) : List α → Prop
  | nil : All P []
  | cons {x xs} : P x → All P xs → All P (x :: xs)

namespace All

@[simp]
theorem split_cons (P : α → Prop) (x : α) (xs : List α)
  : All P (x :: xs) ↔ (P x ∧ All P xs) := by
  aesop

theorem mem (P : α → Prop) (xs : List α)
  : All P xs ↔ ∀ a : α, a ∈ xs → P a := by
  induction xs <;> aesop

theorem weaken (P Q : α → Prop) (wk : ∀ x, P x → Q x) (xs : List α) (h : All P xs)
  : All Q xs := by
  induction h <;> aesop

-- TODO: the trace.aesop.proof does not work here
theorem in_self (xs : List α) : All (· ∈ xs) xs := by
  induction xs <;> aesop (add unsafe apply weaken)

theorem map (P : β → Prop) (f : α → β) (xs : List α)
  : All P (xs.map f) ↔ All (fun x => P (f x)) xs := by
  induction xs <;> aesop

end All

--- Any

@[aesop safe (cases (patterns := [Any _ []])),
  aesop unsafe [50% constructors, 50% (cases (patterns := [Any _ (_ :: _ )]))]]
inductive Any (P : α → Prop) : List α → Prop
  | here {x xs} : P x → Any P (x :: xs)
  | there {x xs} : Any P xs → Any P (x :: xs)

namespace Any

@[simp]
theorem cons (P : α → Prop) (x : α) (xs : List α)
  : Any P (x :: xs) ↔ (P x ∨ Any P xs) := by
  aesop

theorem mem (P : α → Prop) (xs : List α)
  : Any P xs ↔ ∃ a : α, P a ∧ a ∈ xs := by
  apply Iff.intro
  case mp =>
    intro AnyPxs
    induction AnyPxs <;> aesop
  case mpr =>
    intro ⟨a, Pa, Ea⟩
    induction Ea <;> aesop
termination_by _ => List.length xs

theorem map (P : β → Prop) (f : α → β) (xs : List α)
  : Any P (xs.map f) ↔ Any (fun x => P (f x)) xs := by
  induction xs <;> aesop

instance instDecidablePred (P : α → Prop) [d : DecidablePred P]
  : DecidablePred (Any P) := by
  intro xs
  match xs with
  | [] => aesop
  | x :: xs =>
    have ih : Decidable (Any P xs) := instDecidablePred P xs
    cases d x <;> aesop

end Any

--- Common

@[simp]
def Common (xs ys : List α) : Prop :=
  Any (· ∈ ys) xs

namespace Common

theorem mem {xs ys : List α} (h : Common xs ys)
  : ∃ a : α, a ∈ xs ∧ a ∈ ys := by
  induction h <;> aesop

theorem sym {xs ys : List α} (h : Common xs ys)
  : Common ys xs := by
  have other : ∃ a, a ∈ ys ∧ a ∈ xs := Iff.mp (Any.mem (· ∈ ys) xs) h
  apply Iff.mpr (Any.mem (· ∈ xs) ys)
  aesop

instance instDecidable [DecidableEq α] (xs ys : List α)
  : Decidable (Common xs ys) := by
  apply Any.instDecidablePred

end Common

--- List Permutations

-- From https://github.com/agda/agda-stdlib/blob/master/src/Data/List/Relation/Binary/Permutation/Propositional.agda
@[aesop unsafe [50% constructors, 25% (cases (patterns := [Perm (_ :: _) (_ :: _ )]))]]
inductive Perm : (xs ys : List α) → Type
  | refl {xs} : Perm xs xs
  | prep {xs ys} x : Perm xs ys → Perm (x :: xs) (x :: ys)
  | swap {xs ys} x y : Perm xs ys → Perm (x :: y :: xs) (y :: x :: ys)
  | tran {xs ys zs} : Perm xs ys → Perm ys zs → Perm xs zs

infix:45 " ↭ " => Perm

namespace Perm

theorem sym {xs ys : List α} (perm : xs ↭ ys)
  : ys ↭ xs := by
  induction perm <;> aesop

theorem shift (v : α) (xs ys : List α)
  : xs ++ v :: ys ↭ v :: xs ++ ys := by
  induction xs
  . aesop
  . -- TODO need to make all hyps accessible in initial goal
    -- BUG in on_goal: wrong position
    set_option aesop.check.script false in
    aesop

theorem map {xs ys : List α} (f : α → β) (perm : xs ↭ ys)
  : xs.map f ↭ ys.map f := by
  induction perm <;> aesop

theorem all {xs ys : List α} (perm : xs ↭ ys) (P : α → Prop)
  : All P xs → All P ys := by
  induction perm <;> aesop

theorem any {xs ys : List α} (perm : xs ↭ ys) (P : α → Prop)
  : Any P xs → Any P ys := by
  induction perm <;> aesop

end Perm

--- Syntax

inductive Form (Φ : Type)
| pro : Φ → Form Φ
| fls : Form Φ
| imp (φ ψ : Form Φ) : Form Φ

prefix:80 "♩" => Form.pro
notation "⊥" => Form.fls
infixr:75 " ⇒ " => Form.imp

--- Semantics

@[simp]
def Val (i : Φ → Prop) : Form Φ → Prop
  | ♩n => i n
  | ⊥ => false
  | φ ⇒ ψ => Val i φ → Val i ψ

instance Val.instDecidable (i : Φ → Prop) [d : DecidablePred i] (φ : Form Φ)
  : Decidable (Val i φ) := by
  match φ with
  | ♩n => aesop
  | ⊥ => aesop
  | φ ⇒ ψ =>
    have ihφ : Decidable (Val i φ) := instDecidable i φ
    have ihψ : Decidable (Val i ψ) := instDecidable i ψ
    aesop

abbrev Valid (φ : Form Φ) : Prop := ∀ i, DecidablePred i → Val i φ

@[simp]
def SC (i : Φ → Prop) (Γ Δ : List (Form Φ)) : Prop :=
  All (Val i) Γ → Any (Val i) Δ

namespace SC

theorem all {i : Φ → Prop} {Γ Γ' Δ : List (Form Φ)} (perm : Γ' ↭ Γ) (h : SC i Γ Δ)
  : SC i Γ' Δ := by aesop (add unsafe apply Perm.all)

theorem any {i : Φ → Prop} {Γ Δ Δ' : List (Form Φ)} (perm : Δ ↭ Δ') (h : SC i Γ Δ)
  : SC i Γ Δ' := by aesop (add unsafe apply Perm.any)

end SC

--- Prover

@[simp]
def sum : List Nat → Nat
  | [] => 0
  | x :: xs => sum xs + x

@[simp]
def Cal (l r : List Φ) : (Γ Δ : List (Form Φ)) → Prop
  | [], [] => Common l r
  | ⊥ :: _, [] => true
  | Γ, ⊥ :: Δ => Cal l r Γ Δ
  | ♩n :: Γ, [] => Cal (n :: l) r Γ []
  | Γ, ♩n :: Δ => Cal l (n :: r) Γ Δ
  | φ ⇒ ψ :: Γ, [] => Cal l r Γ [φ] ∧ Cal l r (ψ :: Γ) []
  | Γ, φ ⇒ ψ :: Δ => Cal l r (φ :: Γ) (ψ :: Δ)
termination_by _ Γ Δ => sum (Γ.map sizeOf) + sum (Δ.map sizeOf)
decreasing_by simp_wf <;> simp_arith

instance Cal.instDecidable [DecidableEq Φ] (l r : List Φ) (Γ Δ : List (Form Φ))
  : Decidable (Cal l r Γ Δ) := by
  match Γ, Δ with
  | [], [] => apply Common.instDecidable l r
  | ⊥ :: Γ, [] => aesop
  | Γ, ⊥ :: Δ =>
    have ih : Decidable (Cal l r Γ Δ) := instDecidable l r Γ Δ
    aesop
  | ♩n :: Γ, [] =>
    have ih : Decidable (Cal (n :: l) r Γ []) := instDecidable (n :: l) r Γ []
    aesop
  | Γ, ♩n :: Δ =>
    have ih : Decidable (Cal l (n :: r) Γ Δ) := instDecidable l (n :: r) Γ Δ
    aesop
  | φ ⇒ ψ :: Γ, [] =>
    have ih₁ : Decidable (Cal l r Γ [φ]) := instDecidable l r Γ [φ]
    have ih₂ : Decidable (Cal l r (ψ :: Γ) []) := instDecidable l r (ψ :: Γ) []
    aesop
  | Γ, φ ⇒ ψ :: Δ =>
    have ih : Decidable (Cal l r (φ :: Γ) (ψ :: Δ)) := instDecidable l r (φ :: Γ) (ψ :: Δ)
    aesop
termination_by _ => sum (Γ.map sizeOf) + sum (Δ.map sizeOf)
decreasing_by simp_wf <;> simp_arith

abbrev Prove (φ : Form Φ) : Prop := Cal [] [] [] [φ]

example : Prove (⊥ ⇒ ♩0) := by simp
example : Prove (♩0 ⇒ ♩0) := by simp
example : Prove (♩0 ⇒ ♩1 ⇒ ♩0) := by simp
example : ¬ Prove (♩0 ⇒ ♩1) := by simp

--- Soundness and Completeness

@[simp]
def SC' (i : Φ → Prop) (l r : List Φ) (Γ Δ : List (Form Φ)) : Prop :=
  SC i (Γ ++ l.map (♩·)) (Δ ++ r.map (♩·))

theorem Cal_sound_complete [DecidableEq Φ]
  (l r : List Φ) (Γ Δ : List (Form Φ))
  : Cal l r Γ Δ ↔ ∀ i : Φ → Prop, DecidablePred i → SC' i l r Γ Δ := by
  match Γ, Δ with
  | [], [] =>
    apply Iff.intro
    case mp =>
      intro h i _ A
      let ⟨a, al, ar⟩ : ∃ a, a ∈ l ∧ a ∈ r := Common.mem h
      have ml : ♩a ∈ l.map (♩·) := Mem.map (♩·) al
      have Va : Val i (♩a) := Iff.mp (All.mem (Val i) (l.map (♩·))) A (♩a) ml
      have mr : ♩a ∈ r.map (♩·) := Mem.map (♩·) ar
      apply Iff.mpr (Any.mem (Val i) _) ⟨♩a, ⟨Va, mr⟩⟩
    case mpr =>
      intro h
      let i a := a ∈ l
      have dec : DecidablePred i := inferInstance
      have h' : All (Val i) (l.map (♩·)) → Any (Val i) (r.map (♩·)) := h i dec
      have All_l : All (Val i) (l.map (♩·)) := Iff.mpr (All.map (Val i) (♩·) l) (All.in_self l)
      have Any_r : Any (Val (· ∈ l)) (r.map (♩·)) := h' All_l
      have Any_r' : Any (fun n => Val (· ∈ l) (♩n)) r := Iff.mp (Any.map (Val i) (♩·) r) Any_r
      apply Common.sym Any_r'
  | ⊥ :: Γ, [] =>
    simp
  | Γ, ⊥ :: Δ =>
    have ih : Cal l r Γ Δ ↔ ∀ i, DecidablePred i → SC' i l r Γ Δ :=
      Cal_sound_complete l r Γ Δ
    aesop
  | ♩n :: Γ, [] =>
    have ih : Cal (n :: l) r Γ [] ↔ ∀ i, DecidablePred i → SC' i (n :: l) r Γ [] :=
      Cal_sound_complete (n :: l) r Γ []
    have perm : (Γ ++ ♩n :: l.map (♩·)) ↭ (♩n :: Γ ++ l.map (♩·)) := Perm.shift (♩n) Γ _
    apply Iff.intro
    case mp =>
      intro h i dec
      have ihr : SC' i (n :: l) r Γ [] := Iff.mp ih h i dec
      apply SC.all (Perm.sym perm) ihr
    case mpr =>
      intro h
      have hSC : ∀ i, DecidablePred i → SC' i (n :: l) r Γ [] := by
        intro i dec
        apply SC.all perm (h i dec)
      apply Iff.mpr ih hSC
  | Γ, ♩n :: Δ =>
    have ih : Cal l (n :: r) Γ Δ ↔ ∀ i, DecidablePred i → SC' i l (n :: r) Γ Δ :=
      Cal_sound_complete l (n :: r) Γ Δ
    have perm : (Δ ++ ♩n :: r.map (♩·)) ↭ (♩n :: Δ ++ r.map (♩·)) := Perm.shift (♩n) Δ _
    apply Iff.intro
    case mp =>
      intro h i dec
      simp at h
      have ihr : SC' i l (n :: r) Γ Δ := Iff.mp ih h i dec
      apply SC.any perm ihr
    case mpr =>
      intro h
      have hSC : ∀ i, DecidablePred i → SC' i l (n :: r) Γ Δ := by
        intro i dec
        apply SC.any (Perm.sym perm) (h i dec)
      simp [Iff.mpr ih hSC]
  | φ ⇒ ψ :: Γ, [] =>
    have ih₁ : Cal l r Γ [φ] ↔ ∀ i, DecidablePred i → SC' i l r Γ [φ] :=
      Cal_sound_complete l r Γ [φ]
    have ih₂ : Cal l r (ψ :: Γ) [] ↔ ∀ i, DecidablePred i → SC' i l r (ψ :: Γ) [] :=
      Cal_sound_complete l r (ψ :: Γ) []
    apply Iff.intro
    case mp =>
      intro h i dec
      simp at h
      have ih₁' : SC' i l r Γ [φ] := Iff.mp ih₁ h.left i dec
      cases (Val.instDecidable i φ) <;> simp_all
    case mpr =>
      intro h
      simp
      apply And.intro
      case left =>
        apply Iff.mpr ih₁
        intro i dec
        cases (Val.instDecidable i φ) <;> simp_all
      case right =>
        apply Iff.mpr ih₂
        intro i dec
        cases (Val.instDecidable i φ) <;> simp_all
  | Γ, φ ⇒ ψ :: Δ =>
    have ih : Cal l r (φ :: Γ) (ψ :: Δ) ↔ ∀ i, DecidablePred i →
      SC' i l r (φ :: Γ) (ψ :: Δ) :=
      Cal_sound_complete l r (φ :: Γ) (ψ :: Δ)
    apply Iff.intro
    case mp =>
      intro h i dec
      cases (Val.instDecidable i φ) <;> simp_all
    case mpr =>
      intro h
      simp
      apply Iff.mpr ih
      intro i dec
      cases (Val.instDecidable i φ)
      case isFalse no =>
        simp_all
      case isTrue yes =>
        intro AllφΓ
        have AllΓ : All (Val i) (Γ ++ l.map (♩·)) := by simp_all
        have AnyφψΔ : Any (Val i) (φ ⇒ ψ :: Δ ++ r.map (♩·)) := h i dec AllΓ
        simp_all
termination_by _ => sum (Γ.map sizeOf) + sum (Δ.map sizeOf)
decreasing_by simp_wf <;> simp_arith

theorem Prove_sound_complete [DecidableEq Φ] (φ : Form Φ)
  : Prove φ ↔ Valid φ := by
  have h : Prove φ ↔ ∀ i : Φ → Prop, DecidablePred i → SC' i [] [] [] [φ]  :=
    Cal_sound_complete [] [] [] [φ]
  apply Iff.intro
  case mp =>
    intro Pφ i dec
    have h' : Any (Val i) (φ :: [].map (♩·)) := Iff.mp h Pφ i dec All.nil
    aesop
  case mpr =>
    aesop

--- Proof System

inductive Proof : (Γ Δ : List (Form Φ)) → Prop
  | basic Γ Δ n : Proof (♩n :: Γ) (♩n :: Δ)
  | fls_l Γ Δ : Proof (⊥ :: Γ) Δ
  | imp_l Γ Δ φ ψ : Proof Γ (φ :: Δ) → Proof (ψ :: Γ) Δ → Proof (φ ⇒ ψ :: Γ) Δ
  | imp_r Γ Δ φ ψ: Proof (φ :: Γ) (ψ :: Δ) → Proof Γ (φ ⇒ ψ :: Δ)
  | per_l Γ Γ' Δ : Proof Γ Δ → Γ' ↭ Γ → Proof Γ' Δ
  | per_r Γ Δ Δ' : Proof Γ Δ → Δ ↭ Δ' → Proof Γ Δ'

attribute [aesop safe apply] Proof.basic Proof.fls_l
attribute [aesop unsafe 50% apply] Proof.imp_l Proof.imp_r
attribute [aesop unsafe 20% apply] Proof.per_l Proof.per_r

namespace Proof

theorem weaken (Γ Δ : List (Form Φ)) (prf : Proof Γ Δ) (δ : Form Φ)
  : Proof Γ (δ :: Δ) := by
  induction prf with
  | imp_r Γ Δ φ ψ =>
    have ih' : Proof (φ :: Γ) (ψ :: δ :: Δ) := by aesop
    aesop
  | _ =>
    -- TODO No "Try this:" output??
    set_option aesop.check.script false in
    aesop? (options := { maxRuleApplications := 250 })

--- Soundness

theorem sound (i : Φ → Prop) [DecidablePred i] (prf : Proof Γ Δ) : SC i Γ Δ := by
  induction prf with
  | imp_r Γ Δ φ ψ _ ih =>
    have d : Decidable (Val i φ) := inferInstance
    aesop
  | _ => aesop (add unsafe apply [Perm.all, Perm.any])

end Proof

@[simp]
def Proof' (l r : List Φ) (Γ Δ : List (Form Φ)) : Prop :=
  Proof (Γ ++ l.map (♩·)) (Δ ++ r.map (♩·))

theorem Cal_Proof [DecidableEq Φ]
  (l r : List Φ) (Γ Δ : List (Form Φ)) (h : Cal l r Γ Δ)
  : Proof' l r Γ Δ := by
  match Γ, Δ with
  | [], [] =>
    let ⟨a, al, ar⟩ : ∃ a, a ∈ l ∧ a ∈ r := Common.mem h
    let ⟨ll, lr, leq⟩ : ∃ ll lr, l = ll ++ a :: lr := Mem.split al
    let ⟨rl, rr, req⟩ : ∃ rl rr, r = rl ++ a :: rr := Mem.split ar
    rw [leq, req]
    have p : Proof' (a :: ll ++ lr) (a :: rl ++ rr) [] [] := by apply Proof.basic
    have p' : Proof' (ll ++ a :: lr) (a :: rl ++ rr) [] [] := by
      aesop (add unsafe apply [Perm.map, Perm.shift])
    aesop (add unsafe apply [Perm.map, Perm.shift, Perm.sym])
  | ⊥ :: Γ, [] =>
    aesop
  | Γ, ⊥ :: Δ =>
    simp at h
    have ih : Proof' l r Γ Δ := Cal_Proof l r Γ Δ h
    apply Proof.weaken _ _ ih ⊥
  | ♩n :: Γ, [] =>
    have ih : Proof' (n :: l) r Γ [] := Cal_Proof (n :: l) r Γ [] h
    apply Proof.per_l _ _ _ ih
    aesop (add unsafe apply [Perm.shift, Perm.sym])
  | Γ, ♩n :: Δ =>
    simp at h
    have ih : Proof' l (n :: r) Γ Δ := Cal_Proof l (n :: r) Γ Δ h
    aesop (add unsafe apply [Perm.shift])
  | φ ⇒ ψ :: Γ, [] =>
    simp at h
    have ih₁ : Proof' l r Γ [φ] := Cal_Proof l r Γ [φ] h.left
    have ih₂ : Proof' l r (ψ :: Γ) [] := Cal_Proof l r (ψ :: Γ) [] h.right
    aesop
  | Γ, φ ⇒ ψ :: Δ =>
    simp at h
    have ih : Proof' l r (φ :: Γ) (ψ :: Δ) := Cal_Proof l r (φ :: Γ) (ψ :: Δ) h
    aesop
termination_by _ => sum (Γ.map sizeOf) + sum (Δ.map sizeOf)
decreasing_by simp_wf <;> simp_arith

theorem Proof_sound_complete [DecidableEq Φ] (φ : Form Φ)
  : Proof [] [φ] ↔ Valid φ := by
  apply Iff.intro
  case mp =>
    intro prf i dec
    have h : Any (Val i) [φ] := Proof.sound i prf All.nil
    aesop
  case mpr =>
    intro h
    have c : Prove φ := Iff.mpr (Prove_sound_complete φ) h
    have prf : Proof' [] [] [] [φ] := Cal_Proof [] [] [] [φ] c
    exact prf


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.bool.set
import data.nat.basic
import order.bounds

/-!
# Theory of complete lattices

## Main definitions

* `Sup` and `Inf` are the supremum and the infimum of a set;
* `supr (f : ι → α)` and `infi (f : ι → α)` are indexed supremum and infimum of a function,
  defined as `Sup` and `Inf` of the range of this function;
* `class complete_lattice`: a bounded lattice such that `Sup s` is always the least upper boundary
  of `s` and `Inf s` is always the greatest lower boundary of `s`;
* `class complete_linear_order`: a linear ordered complete lattice.

## Naming conventions

In lemma names,
* `Sup` is called `Sup`
* `Inf` is called `Inf`
* `⨆ i, s i` is called `supr`
* `⨅ i, s i` is called `infi`
* `⨆ i j, s i j` is called `supr₂`. This is a `supr` inside a `supr`.
* `⨅ i j, s i j` is called `infi₂`. This is an `infi` inside an `infi`.
* `⨆ i ∈ s, t i` is called `bsupr` for "bounded `supr`". This is the special case of `supr₂`
  where `j : i ∈ s`.
* `⨅ i ∈ s, t i` is called `binfi` for "bounded `infi`". This is the special case of `infi₂`
  where `j : i ∈ s`.

## Notation

* `⨆ i, f i` : `supr f`, the supremum of the range of `f`;
* `⨅ i, f i` : `infi f`, the infimum of the range of `f`.
-/

set_option old_structure_cmd true
open set function

variables {α β β₂ : Type*} {ι ι' : Sort*} {κ : ι → Sort*} {κ' : ι' → Sort*}

/-- class for the `Sup` operator -/
class has_Sup (α : Type*) := (Sup : set α → α)
/-- class for the `Inf` operator -/
class has_Inf (α : Type*) := (Inf : set α → α)

export has_Sup (Sup) has_Inf (Inf)

/-- Supremum of a set -/
add_decl_doc has_Sup.Sup
/-- Infimum of a set -/
add_decl_doc has_Inf.Inf

/-- Indexed supremum -/
def supr [has_Sup α] {ι} (s : ι → α) : α := Sup (range s)
/-- Indexed infimum -/
def infi [has_Inf α] {ι} (s : ι → α) : α := Inf (range s)

@[priority 50] instance has_Inf_to_nonempty (α) [has_Inf α] : nonempty α := ⟨Inf ∅⟩
@[priority 50] instance has_Sup_to_nonempty (α) [has_Sup α] : nonempty α := ⟨Sup ∅⟩

notation `⨆` binders `, ` r:(scoped f, supr f) := r
notation `⨅` binders `, ` r:(scoped f, infi f) := r

instance (α) [has_Inf α] : has_Sup (order_dual α) := ⟨(Inf : set α → α)⟩
instance (α) [has_Sup α] : has_Inf (order_dual α) := ⟨(Sup : set α → α)⟩

/--
Note that we rarely use `complete_semilattice_Sup`
(in fact, any such object is always a `complete_lattice`, so it's usually best to start there).

Nevertheless it is sometimes a useful intermediate step in constructions.
-/
@[ancestor partial_order has_Sup]
class complete_semilattice_Sup (α : Type*) extends partial_order α, has_Sup α :=
(le_Sup : ∀s, ∀a∈s, a ≤ Sup s)
(Sup_le : ∀s a, (∀b∈s, b ≤ a) → Sup s ≤ a)

section
variables [complete_semilattice_Sup α] {s t : set α} {a b : α}

@[ematch] theorem le_Sup : a ∈ s → a ≤ Sup s := complete_semilattice_Sup.le_Sup s a

theorem Sup_le : (∀b∈s, b ≤ a) → Sup s ≤ a := complete_semilattice_Sup.Sup_le s a

lemma is_lub_Sup (s : set α) : is_lub s (Sup s) := ⟨λ x, le_Sup, λ x, Sup_le⟩

lemma is_lub.Sup_eq (h : is_lub s a) : Sup s = a := (is_lub_Sup s).unique h

theorem le_Sup_of_le (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_Sup hb)

theorem Sup_le_Sup (h : s ⊆ t) : Sup s ≤ Sup t :=
(is_lub_Sup s).mono (is_lub_Sup t) h

@[simp] theorem Sup_le_iff : Sup s ≤ a ↔ ∀b ∈ s, b ≤ a :=
is_lub_le_iff (is_lub_Sup s)

lemma le_Sup_iff : a ≤ Sup s ↔ ∀ b ∈ upper_bounds s, a ≤ b :=
⟨λ h b hb, le_trans h (Sup_le hb), λ hb, hb _ (λ x, le_Sup)⟩

lemma le_supr_iff {s : ι → α} : a ≤ supr s ↔ ∀ b, (∀ i, s i ≤ b) → a ≤ b :=
by simp [supr, le_Sup_iff, upper_bounds]

theorem Sup_le_Sup_of_forall_exists_le (h : ∀ x ∈ s, ∃ y ∈ t, x ≤ y) : Sup s ≤ Sup t :=
le_Sup_iff.2 $ λ b hb, Sup_le $ λ a ha, let ⟨c, hct, hac⟩ := h a ha in hac.trans (hb hct)

-- We will generalize this to conditionally complete lattices in `cSup_singleton`.
theorem Sup_singleton {a : α} : Sup {a} = a :=
is_lub_singleton.Sup_eq

end

/--
Note that we rarely use `complete_semilattice_Inf`
(in fact, any such object is always a `complete_lattice`, so it's usually best to start there).

Nevertheless it is sometimes a useful intermediate step in constructions.
-/
@[ancestor partial_order has_Inf]
class complete_semilattice_Inf (α : Type*) extends partial_order α, has_Inf α :=
(Inf_le : ∀s, ∀a∈s, Inf s ≤ a)
(le_Inf : ∀s a, (∀b∈s, a ≤ b) → a ≤ Inf s)

section
variables [complete_semilattice_Inf α] {s t : set α} {a b : α}

@[ematch] theorem Inf_le : a ∈ s → Inf s ≤ a := complete_semilattice_Inf.Inf_le s a

theorem le_Inf : (∀b∈s, a ≤ b) → a ≤ Inf s := complete_semilattice_Inf.le_Inf s a

lemma is_glb_Inf (s : set α) : is_glb s (Inf s) := ⟨λ a, Inf_le, λ a, le_Inf⟩

lemma is_glb.Inf_eq (h : is_glb s a) : Inf s = a := (is_glb_Inf s).unique h

theorem Inf_le_of_le (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (Inf_le hb) h

theorem Inf_le_Inf (h : s ⊆ t) : Inf t ≤ Inf s :=
(is_glb_Inf s).mono (is_glb_Inf t) h

@[simp] theorem le_Inf_iff : a ≤ Inf s ↔ (∀b ∈ s, a ≤ b) :=
le_is_glb_iff (is_glb_Inf s)

lemma Inf_le_iff :
  Inf s ≤ a ↔ (∀ b ∈ lower_bounds s, b ≤ a) :=
⟨λ h b hb, le_trans (le_Inf hb) h, λ hb, hb _ (λ x, Inf_le)⟩

lemma infi_le_iff {s : ι → α} : infi s ≤ a ↔ (∀ b, (∀ i, b ≤ s i) → b ≤ a) :=
by simp [infi, Inf_le_iff, lower_bounds]

theorem Inf_le_Inf_of_forall_exists_le (h : ∀ x ∈ s, ∃ y ∈ t, y ≤ x) : Inf t ≤ Inf s :=
le_of_forall_le begin
  simp only [le_Inf_iff],
  introv h₀ h₁,
  rcases h _ h₁ with ⟨y,hy,hy'⟩,
  solve_by_elim [le_trans _ hy']
end

-- We will generalize this to conditionally complete lattices in `cInf_singleton`.
theorem Inf_singleton {a : α} : Inf {a} = a :=
is_glb_singleton.Inf_eq

end

/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
@[protect_proj, ancestor lattice complete_semilattice_Sup complete_semilattice_Inf has_top has_bot]
class complete_lattice (α : Type*) extends
  lattice α, complete_semilattice_Sup α, complete_semilattice_Inf α, has_top α, has_bot α :=
(le_top : ∀ x : α, x ≤ ⊤)
(bot_le : ∀ x : α, ⊥ ≤ x)

@[priority 100]  -- see Note [lower instance priority]
instance complete_lattice.to_bounded_order [h : complete_lattice α] : bounded_order α :=
{ ..h }

/-- Create a `complete_lattice` from a `partial_order` and `Inf` function
that returns the greatest lower bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Sup, bot, top
  ..complete_lattice_of_Inf my_T _ }
```
-/
def complete_lattice_of_Inf (α : Type*) [H1 : partial_order α]
  [H2 : has_Inf α] (is_glb_Inf : ∀ s : set α, is_glb s (Inf s)) :
  complete_lattice α :=
{ bot := Inf univ,
  bot_le := λ x, (is_glb_Inf univ).1 trivial,
  top := Inf ∅,
  le_top := λ a, (is_glb_Inf ∅).2 $ by simp,
  sup := λ a b, Inf {x | a ≤ x ∧ b ≤ x},
  inf := λ a b, Inf {a, b},
  le_inf := λ a b c hab hac, by { apply (is_glb_Inf _).2, simp [*] },
  inf_le_right := λ a b, (is_glb_Inf _).1 $ mem_insert_of_mem _ $ mem_singleton _,
  inf_le_left := λ a b, (is_glb_Inf _).1 $ mem_insert _ _,
  sup_le := λ a b c hac hbc, (is_glb_Inf _).1 $ by simp [*],
  le_sup_left := λ a b, (is_glb_Inf _).2 $ λ x, and.left,
  le_sup_right := λ a b, (is_glb_Inf _).2 $ λ x, and.right,
  le_Inf := λ s a ha, (is_glb_Inf s).2 ha,
  Inf_le := λ s a ha, (is_glb_Inf s).1 ha,
  Sup := λ s, Inf (upper_bounds s),
  le_Sup := λ s a ha, (is_glb_Inf (upper_bounds s)).2 $ λ b hb, hb ha,
  Sup_le := λ s a ha, (is_glb_Inf (upper_bounds s)).1 ha,
  .. H1, .. H2 }

/--
Any `complete_semilattice_Inf` is in fact a `complete_lattice`.

Note that this construction has bad definitional properties:
see the doc-string on `complete_lattice_of_Inf`.
-/
def complete_lattice_of_complete_semilattice_Inf (α : Type*) [complete_semilattice_Inf α] :
  complete_lattice α :=
complete_lattice_of_Inf α (λ s, is_glb_Inf s)

/-- Create a `complete_lattice` from a `partial_order` and `Sup` function
that returns the least upper bound of a set. Usually this constructor provides
poor definitional equalities.  If other fields are known explicitly, they should be
provided; for example, if `inf` is known explicitly, construct the `complete_lattice`
instance as
```
instance : complete_lattice my_T :=
{ inf := better_inf,
  le_inf := ...,
  inf_le_right := ...,
  inf_le_left := ...
  -- don't care to fix sup, Inf, bot, top
  ..complete_lattice_of_Sup my_T _ }
```
-/
def complete_lattice_of_Sup (α : Type*) [H1 : partial_order α]
  [H2 : has_Sup α] (is_lub_Sup : ∀ s : set α, is_lub s (Sup s)) :
  complete_lattice α :=
{ top := Sup univ,
  le_top := λ x, (is_lub_Sup univ).1 trivial,
  bot := Sup ∅,
  bot_le := λ x, (is_lub_Sup ∅).2 $ by simp,
  sup := λ a b, Sup {a, b},
  sup_le := λ a b c hac hbc, (is_lub_Sup _).2 (by simp [*]),
  le_sup_left := λ a b, (is_lub_Sup _).1 $ mem_insert _ _,
  le_sup_right := λ a b, (is_lub_Sup _).1 $ mem_insert_of_mem _ $ mem_singleton _,
  inf := λ a b, Sup {x | x ≤ a ∧ x ≤ b},
  le_inf := λ a b c hab hac, (is_lub_Sup _).1 $ by simp [*],
  inf_le_left := λ a b, (is_lub_Sup _).2 (λ x, and.left),
  inf_le_right := λ a b, (is_lub_Sup _).2 (λ x, and.right),
  Inf := λ s, Sup (lower_bounds s),
  Sup_le := λ s a ha, (is_lub_Sup s).2 ha,
  le_Sup := λ s a ha, (is_lub_Sup s).1 ha,
  Inf_le := λ s a ha, (is_lub_Sup (lower_bounds s)).2 (λ b hb, hb ha),
  le_Inf := λ s a ha, (is_lub_Sup (lower_bounds s)).1 ha,
  .. H1, .. H2 }

/--
Any `complete_semilattice_Sup` is in fact a `complete_lattice`.

Note that this construction has bad definitional properties:
see the doc-string on `complete_lattice_of_Sup`.
-/
def complete_lattice_of_complete_semilattice_Sup (α : Type*) [complete_semilattice_Sup α] :
  complete_lattice α :=
complete_lattice_of_Sup α (λ s, is_lub_Sup s)

/-- A complete linear order is a linear order whose lattice structure is complete. -/
class complete_linear_order (α : Type*) extends complete_lattice α,
  linear_order α renaming max → sup min → inf

namespace order_dual
variable (α)

instance [complete_lattice α] : complete_lattice (order_dual α) :=
{ le_Sup := @complete_lattice.Inf_le α _,
  Sup_le := @complete_lattice.le_Inf α _,
  Inf_le := @complete_lattice.le_Sup α _,
  le_Inf := @complete_lattice.Sup_le α _,
  .. order_dual.lattice α, ..order_dual.has_Sup α, ..order_dual.has_Inf α,
  .. order_dual.bounded_order α }

instance [complete_linear_order α] : complete_linear_order (order_dual α) :=
{ .. order_dual.complete_lattice α, .. order_dual.linear_order α }

end order_dual

section
variables [complete_lattice α] {s t : set α} {a b : α}

theorem Inf_le_Sup (hs : s.nonempty) : Inf s ≤ Sup s :=
is_glb_le_is_lub (is_glb_Inf s) (is_lub_Sup s) hs

theorem Sup_union {s t : set α} : Sup (s ∪ t) = Sup s ⊔ Sup t :=
((is_lub_Sup s).union (is_lub_Sup t)).Sup_eq

theorem Sup_inter_le {s t : set α} : Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
Sup_le $ λ b hb, le_inf (le_Sup hb.1) (le_Sup hb.2)
/-
  Sup_le (λ a ⟨a_s, a_t⟩, le_inf (le_Sup a_s) (le_Sup a_t))
-/

theorem Inf_union {s t : set α} : Inf (s ∪ t) = Inf s ⊓ Inf t :=
((is_glb_Inf s).union (is_glb_Inf t)).Inf_eq

theorem le_Inf_inter {s t : set α} : Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
@Sup_inter_le (order_dual α) _ _ _

@[simp] theorem Sup_empty : Sup ∅ = (⊥ : α) :=
(@is_lub_empty α _ _).Sup_eq

@[simp] theorem Inf_empty : Inf ∅ = (⊤ : α) :=
(@is_glb_empty α _ _).Inf_eq

@[simp] theorem Sup_univ : Sup univ = (⊤ : α) :=
(@is_lub_univ α _ _).Sup_eq

@[simp] theorem Inf_univ : Inf univ = (⊥ : α) :=
(@is_glb_univ α _ _).Inf_eq

-- TODO(Jeremy): get this automatically
@[simp] theorem Sup_insert {a : α} {s : set α} : Sup (insert a s) = a ⊔ Sup s :=
((is_lub_Sup s).insert a).Sup_eq

@[simp] theorem Inf_insert {a : α} {s : set α} : Inf (insert a s) = a ⊓ Inf s :=
((is_glb_Inf s).insert a).Inf_eq

theorem Sup_le_Sup_of_subset_insert_bot (h : s ⊆ insert ⊥ t) : Sup s ≤ Sup t :=
le_trans (Sup_le_Sup h) (le_of_eq (trans Sup_insert bot_sup_eq))

theorem Inf_le_Inf_of_subset_insert_top (h : s ⊆ insert ⊤ t) : Inf t ≤ Inf s :=
le_trans (le_of_eq (trans top_inf_eq.symm Inf_insert.symm)) (Inf_le_Inf h)

theorem Sup_pair {a b : α} : Sup {a, b} = a ⊔ b :=
(@is_lub_pair α _ a b).Sup_eq

theorem Inf_pair {a b : α} : Inf {a, b} = a ⊓ b :=
(@is_glb_pair α _ a b).Inf_eq

@[simp] theorem Inf_eq_top : Inf s = ⊤ ↔ (∀a∈s, a = ⊤) :=
iff.intro
  (λ h a ha, top_unique $ h ▸ Inf_le ha)
  (λ h, top_unique $ le_Inf $ λ a ha, top_le_iff.2 $ h a ha)

lemma eq_singleton_top_of_Inf_eq_top_of_nonempty {s : set α}
  (h_inf : Inf s = ⊤) (hne : s.nonempty) : s = {⊤} :=
by { rw set.eq_singleton_iff_nonempty_unique_mem, rw Inf_eq_top at h_inf, exact ⟨hne, h_inf⟩, }

@[simp] theorem Sup_eq_bot : Sup s = ⊥ ↔ (∀a∈s, a = ⊥) :=
@Inf_eq_top (order_dual α) _ _

lemma eq_singleton_bot_of_Sup_eq_bot_of_nonempty {s : set α}
  (h_sup : Sup s = ⊥) (hne : s.nonempty) : s = {⊥} :=
by { rw set.eq_singleton_iff_nonempty_unique_mem, rw Sup_eq_bot at h_sup, exact ⟨hne, h_sup⟩, }

/--Introduction rule to prove that `b` is the supremum of `s`: it suffices to check that `b`
is larger than all elements of `s`, and that this is not the case of any `w < b`.
See `cSup_eq_of_forall_le_of_forall_lt_exists_gt` for a version in conditionally complete
lattices. -/
theorem Sup_eq_of_forall_le_of_forall_lt_exists_gt (_ : ∀a∈s, a ≤ b)
  (H : ∀w, w < b → (∃a∈s, w < a)) : Sup s = b :=
have h : (Sup s < b) ∨ (Sup s = b) := lt_or_eq_of_le (Sup_le ‹∀a∈s, a ≤ b›),
have ¬(Sup s < b) :=
  assume : Sup s < b,
  let ⟨a, _, _⟩ := (H (Sup s) ‹Sup s < b›) in  /- a ∈ s, Sup s < a-/
  have Sup s < Sup s := lt_of_lt_of_le ‹Sup s < a› (le_Sup ‹a ∈ s›),
  show false, from lt_irrefl _ this,
show Sup s = b, from or.resolve_left h this

/--Introduction rule to prove that `b` is the infimum of `s`: it suffices to check that `b`
is smaller than all elements of `s`, and that this is not the case of any `w > b`.
See `cInf_eq_of_forall_ge_of_forall_gt_exists_lt` for a version in conditionally complete
lattices. -/
theorem Inf_eq_of_forall_ge_of_forall_gt_exists_lt (_ : ∀a∈s, b ≤ a)
  (H : ∀w, b < w → (∃a∈s, a < w)) : Inf s = b :=
@Sup_eq_of_forall_le_of_forall_lt_exists_gt (order_dual α) _ _ ‹_› ‹_› ‹_›

end

section complete_linear_order
variables [complete_linear_order α] {s t : set α} {a b : α}

lemma Inf_lt_iff : Inf s < b ↔ ∃ a ∈ s, a < b := is_glb_lt_iff $ is_glb_Inf s
lemma lt_Sup_iff : b < Sup s ↔ ∃ a ∈ s, b < a := lt_is_lub_iff $ is_lub_Sup s

lemma Sup_eq_top : Sup s = ⊤ ↔ (∀b<⊤, ∃a∈s, b < a) :=
iff.intro
  (λ (h : Sup s = ⊤) b hb, by rwa [←h, lt_Sup_iff] at hb)
  (λ h, top_unique $ le_of_not_gt $ λ h',
    let ⟨a, ha, h⟩ := h _ h' in
    lt_irrefl a $ lt_of_le_of_lt (le_Sup ha) h)

lemma Inf_eq_bot : Inf s = ⊥ ↔ (∀b>⊥, ∃a∈s, a < b) :=
@Sup_eq_top (order_dual α) _ _

lemma lt_supr_iff {f : ι → α} : a < supr f ↔ ∃ i, a < f i := lt_Sup_iff.trans exists_range_iff
lemma infi_lt_iff {f : ι → α} : infi f < a ↔ ∃ i, f i < a := Inf_lt_iff.trans exists_range_iff

end complete_linear_order

/-
### supr & infi
-/

section has_Sup
variables [has_Sup α] {f g : ι → α}

lemma Sup_range : Sup (range f) = supr f := rfl
lemma Sup_eq_supr' (s : set α) : Sup s = ⨆ a : s, a := by rw [supr, subtype.range_coe]

lemma supr_congr (h : ∀ i, f i = g i) : (⨆ i, f i) = ⨆ i, g i := congr_arg _ $ funext h

lemma function.surjective.supr_comp {f : ι → ι'} (hf : surjective f) (g : ι' → α) :
  (⨆ x, g (f x)) = ⨆ y, g y :=
by simp only [supr, hf.range_comp]

protected lemma function.surjective.supr_congr {g : ι' → α} (h : ι → ι') (h1 : surjective h)
  (h2 : ∀ x, g (h x) = f x) :
  (⨆ x, f x) = ⨆ y, g y :=
by { convert h1.supr_comp g, exact (funext h2).symm }

@[congr] lemma supr_congr_Prop {p q : Prop} {f₁ : p → α} {f₂ : q → α} (pq : p ↔ q)
  (f : ∀ x, f₁ (pq.mpr x) = f₂ x) : supr f₁ = supr f₂ :=
begin
  have := propext pq, subst this,
  congr' with x,
  apply f
end

lemma supr_range' (g : β → α) (f : ι → β) : (⨆ b : range f, g b) = ⨆ i, g (f i) :=
by rw [supr, supr, ← image_eq_range, ← range_comp]

lemma Sup_image' {s : set β} {f : β → α} : Sup (f '' s) = ⨆ a : s, f a :=
by rw [supr, image_eq_range]

end has_Sup

section has_Inf
variables [has_Inf α] {f g : ι → α}

lemma Inf_range : Inf (range f) = infi f := rfl
lemma Inf_eq_infi' (s : set α) : Inf s = ⨅ a : s, a := @Sup_eq_supr' (order_dual α) _ _

lemma infi_congr (h : ∀ i, f i = g i) : (⨅ i, f i) = ⨅ i, g i := congr_arg _ $ funext h

lemma function.surjective.infi_comp {f : ι → ι'} (hf : surjective f) (g : ι' → α) :
  (⨅ x, g (f x)) = ⨅ y, g y :=
@function.surjective.supr_comp (order_dual α) _ _  _ f hf g

lemma function.surjective.infi_congr {g : ι' → α} (h : ι → ι') (h1 : surjective h)
  (h2 : ∀ x, g (h x) = f x) : (⨅ x, f x) = ⨅ y, g y :=
@function.surjective.supr_congr (order_dual α) _ _ _ _ _ h h1 h2

@[congr]lemma infi_congr_Prop {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀ x, f₁ (pq.mpr x) = f₂ x) : infi f₁ = infi f₂ :=
@supr_congr_Prop (order_dual α) _ p q f₁ f₂ pq f

lemma infi_range' (g : β → α) (f : ι → β) : (⨅ b : range f, g b) = ⨅ i, g (f i) :=
@supr_range' (order_dual α) _ _ _ _ _

lemma Inf_image' {s : set β} {f : β → α} : Inf (f '' s) = (⨅ a : s, f a) :=
@Sup_image' (order_dual α) _ _ _ _

end has_Inf

section
variables [complete_lattice α] {f g s t : ι → α} {a b : α}

-- TODO: this declaration gives error when starting smt state
--@[ematch]
lemma le_supr (f : ι → α) (i : ι) : f i ≤ supr f := le_Sup ⟨i, rfl⟩
lemma infi_le (f : ι → α) (i : ι) : infi f ≤ f i := Inf_le ⟨i, rfl⟩

@[ematch] lemma le_supr' (f : ι → α) (i : ι) : (: f i ≤ supr f :) := le_Sup ⟨i, rfl⟩
@[ematch] lemma infi_le' (f : ι → α) (i : ι) : (: infi f ≤ f i :) := Inf_le ⟨i, rfl⟩

/- TODO: this version would be more powerful, but, alas, the pattern matcher
   doesn't accept it.
@[ematch] lemma le_supr' (f : ι → α) (i : ι) : (: f i :) ≤ (: supr f :) :=
le_Sup ⟨i, rfl⟩
-/

lemma is_lub_supr : is_lub (range f) (⨆ j, f j) := is_lub_Sup _
lemma is_glb_infi : is_glb (range f) (⨅ j, f j) := is_glb_Inf _

lemma is_lub.supr_eq (h : is_lub (range f) a) : (⨆ j, f j) = a := h.Sup_eq
lemma is_glb.infi_eq (h : is_glb (range f) a) : (⨅ j, f j) = a := h.Inf_eq

lemma le_supr_of_le (i : ι) (h : a ≤ f i) : a ≤ supr f := h.trans $ le_supr _ i
lemma infi_le_of_le (i : ι) (h : f i ≤ a) : infi f ≤ a := (infi_le _ i).trans h

lemma le_supr₂ {f : Π i, κ i → α} (i : ι) (j : κ i) : f i j ≤ ⨆ i j, f i j :=
le_supr_of_le i $ le_supr (f i) j

lemma infi₂_le {f : Π i, κ i → α} (i : ι) (j : κ i) : (⨅ i j, f i j) ≤ f i j :=
infi_le_of_le i $ infi_le (f i) j

lemma le_supr₂_of_le {f : Π i, κ i → α} (i : ι) (j : κ i) (h : a ≤ f i j) : a ≤ ⨆ i j, f i j :=
h.trans $ le_supr₂ i j

lemma infi₂_le_of_le {f : Π i, κ i → α} (i : ι) (j : κ i) (h : f i j ≤ a) : (⨅ i j, f i j) ≤ a :=
(infi₂_le i j).trans h

lemma supr_le (h : ∀ i, f i ≤ a) : supr f ≤ a := Sup_le $ λ b ⟨i, eq⟩, eq ▸ h i
lemma le_infi (h : ∀ i, a ≤ f i) : a ≤ infi f := le_Inf $ λ b ⟨i, eq⟩, eq ▸ h i

lemma supr₂_le {f : Π i, κ i → α} (h : ∀ i j, f i j ≤ a) : (⨆ i j, f i j) ≤ a :=
supr_le $ λ i, supr_le $ h i

lemma le_infi₂ {f : Π i, κ i → α} (h : ∀ i j, a ≤ f i j) : a ≤ ⨅ i j, f i j :=
le_infi $ λ i, le_infi $ h i

lemma supr₂_le_supr (κ : ι → Sort*) (f : ι → α) : (⨆ i (j : κ i), f i) ≤ ⨆ i, f i :=
supr₂_le $ λ i j, le_supr f i

lemma infi_le_infi₂ (κ : ι → Sort*) (f : ι → α) : (⨅ i, f i) ≤ ⨅ i (j : κ i), f i :=
le_infi₂ $ λ i j, infi_le f i

lemma supr_mono (h : ∀ i, f i ≤ g i) : supr f ≤ supr g := supr_le $ λ i, le_supr_of_le i $ h i
lemma infi_mono (h : ∀ i, f i ≤ g i) : infi f ≤ infi g := le_infi $ λ i, infi_le_of_le i $ h i

lemma supr₂_mono {f g : Π i, κ i → α} (h : ∀ i j, f i j ≤ g i j) : (⨆ i j, f i j) ≤ ⨆ i j, g i j :=
supr_mono $ λ i, supr_mono $ h i

lemma infi₂_mono {f g : Π i, κ i → α} (h : ∀ i j, f i j ≤ g i j) : (⨅ i j, f i j) ≤ ⨅ i j, g i j :=
infi_mono $ λ i, infi_mono $ h i

lemma supr_mono' {g : ι' → α} (h : ∀ i, ∃ i', f i ≤ g i') : supr f ≤ supr g :=
supr_le $ λ i, exists.elim (h i) le_supr_of_le

lemma infi_mono' {g : ι' → α} (h : ∀ i', ∃ i, f i ≤ g i') : infi f ≤ infi g :=
le_infi $ λ i', exists.elim (h i') infi_le_of_le

lemma supr₂_mono' {f : Π i, κ i → α} {g : Π i', κ' i' → α} (h : ∀ i j, ∃ i' j', f i j ≤ g i' j') :
  (⨆ i j, f i j) ≤ ⨆ i j, g i j :=
supr₂_le $ λ i j, let ⟨i', j', h⟩ := h i j in le_supr₂_of_le i' j' h

lemma infi₂_mono' {f : Π i, κ i → α} {g : Π i', κ' i' → α} (h : ∀ i j, ∃ i' j', f i' j' ≤ g i j) :
  (⨅ i j, f i j) ≤ ⨅ i j, g i j :=
le_infi₂ $ λ i j, let ⟨i', j', h⟩ := h i j in infi₂_le_of_le i' j' h

lemma supr_const_mono (h : ι → ι') : (⨆ i : ι, a) ≤ ⨆ j : ι', a := supr_le $ le_supr _ ∘ h
lemma infi_const_mono (h : ι' → ι) : (⨅ i : ι, a) ≤ ⨅ j : ι', a := le_infi $ infi_le _ ∘ h

lemma bsupr_mono {p q : ι → Prop} (hpq : ∀ i, p i → q i) :
  (⨆ i (h : p i), f i) ≤ ⨆ i (h : q i), f i :=
supr_mono $ λ i, supr_const_mono (hpq i)

lemma binfi_mono {p q : ι → Prop} (hpq : ∀ i, p i → q i) :
  (⨅ i (h : q i), f i) ≤ ⨅ i (h : p i), f i :=
infi_mono $ λ i, infi_const_mono (hpq i)

@[simp] lemma supr_le_iff : supr f ≤ a ↔ ∀ i, f i ≤ a :=
(is_lub_le_iff is_lub_supr).trans forall_range_iff

@[simp] lemma le_infi_iff : a ≤ infi f ↔ ∀ i, a ≤ f i :=
(le_is_glb_iff is_glb_infi).trans forall_range_iff

@[simp] lemma supr₂_le_iff {f : Π i, κ i → α} : (⨆ i j, f i j) ≤ a ↔ ∀ i j, f i j ≤ a :=
by simp_rw supr_le_iff

@[simp] lemma le_infi₂_iff {f : Π i, κ i → α} : a ≤ (⨅ i j, f i j) ↔ ∀ i j, a ≤ f i j :=
by simp_rw le_infi_iff

lemma supr_lt_iff : supr f < a ↔ ∃ b, b < a ∧ ∀ i, f i ≤ b :=
⟨λ h, ⟨supr f, h, le_supr f⟩, λ ⟨b, h, hb⟩, (supr_le hb).trans_lt h⟩

lemma lt_infi_iff : a < infi f ↔ ∃ b, a < b ∧ ∀ i, b ≤ f i :=
⟨λ h, ⟨infi f, h, infi_le f⟩, λ ⟨b, h, hb⟩, h.trans_le $ le_infi hb⟩

lemma Sup_eq_supr {s : set α} : Sup s = ⨆ a ∈ s, a :=
le_antisymm (Sup_le le_supr₂) (supr₂_le $ λ b, le_Sup)

lemma Inf_eq_infi {s : set α} : Inf s = ⨅ a ∈ s, a :=
@Sup_eq_supr (order_dual α) _ _

lemma Sup_sUnion (s : set (set α)) :  Sup (⋃₀ s) = ⨆ t ∈ s, Sup t :=
begin
  apply le_antisymm,
  { apply Sup_le (λ b hb, _),
    rcases hb with ⟨t, ts, bt⟩,
    apply le_trans _ (le_supr _ t),
    exact le_trans (le_Sup bt) (le_supr _ ts), },
  { apply supr_le (λ t, _),
    exact supr_le (λ ts, Sup_le_Sup (λ x xt, ⟨t, ts, xt⟩)) }
end

lemma Inf_sUnion (s : set (set α)) :  Inf (⋃₀ s) = ⨅ t ∈ s, Inf t := @Sup_sUnion (order_dual α) _ _

lemma monotone.le_map_supr [complete_lattice β] {f : α → β} (hf : monotone f) :
  (⨆ i, f (s i)) ≤ f (supr s) :=
supr_le $ λ i, hf $ le_supr _ _

lemma monotone.le_map_supr₂ [complete_lattice β] {f : α → β} (hf : monotone f) (s : Π i, κ i → α) :
  (⨆ i j, f (s i j)) ≤ f (⨆ i j, s i j) :=
calc (⨆ i j, f (s i j)) ≤ (⨆ i, f (⨆ j, s i j)) :
  supr_mono $ λ i, hf.le_map_supr
... ≤ f (⨆ i j, s i j) : hf.le_map_supr

lemma monotone.le_map_Sup [complete_lattice β] {s : set α} {f : α → β} (hf : monotone f) :
  (⨆a∈s, f a) ≤ f (Sup s) :=
by rw [Sup_eq_supr]; exact hf.le_map_supr₂ _

lemma antitone.le_map_infi [complete_lattice β] {f : α → β} (hf : antitone f) :
  (⨆ i, f (s i)) ≤ f (infi s) :=
hf.dual_left.le_map_supr

lemma antitone.le_map_infi₂ [complete_lattice β] {f : α → β} (hf : antitone f) (s : Π i, κ i → α) :
  (⨆ i j, f (s i j)) ≤ f (⨅ i j, s i j) :=
hf.dual_left.le_map_supr₂ _

lemma antitone.le_map_Inf [complete_lattice β] {s : set α} {f : α → β} (hf : antitone f) :
  (⨆ a ∈ s, f a) ≤ f (Inf s) :=
hf.dual_left.le_map_Sup

lemma order_iso.map_supr [complete_lattice β] (f : α ≃o β) (x : ι → α) :
  f (⨆ i, x i) = ⨆ i, f (x i) :=
eq_of_forall_ge_iff $ f.surjective.forall.2 $ λ x,
  by simp only [f.le_iff_le, supr_le_iff]

lemma order_iso.map_Sup [complete_lattice β] (f : α ≃o β) (s : set α) :
  f (Sup s) = ⨆ a ∈ s, f a :=
by simp only [Sup_eq_supr, order_iso.map_supr]

lemma supr_comp_le {ι' : Sort*} (f : ι' → α) (g : ι → ι') :
  (⨆ x, f (g x)) ≤ ⨆ y, f y :=
supr_mono' $ λ x, ⟨_, le_rfl⟩

lemma monotone.supr_comp_eq [preorder β] {f : β → α} (hf : monotone f)
  {s : ι → β} (hs : ∀ x, ∃ i, x ≤ s i) :
  (⨆ x, f (s x)) = ⨆ y, f y :=
le_antisymm (supr_comp_le _ _) (supr_mono' $ λ x, (hs x).imp $ λ i hi, hf hi)

lemma monotone.map_infi_le [complete_lattice β] {f : α → β} (hf : monotone f) :
  f (infi s) ≤ (⨅ i, f (s i)) :=
le_infi $ λ i, hf $ infi_le _ _

lemma monotone.map_infi₂_le [complete_lattice β] {f : α → β} (hf : monotone f) (s : Π i, κ i → α) :
  f (⨅ i j, s i j) ≤ ⨅ i j, f (s i j) :=
hf.dual.le_map_supr₂ _

lemma monotone.map_Inf_le [complete_lattice β] {s : set α} {f : α → β} (hf : monotone f) :
  f (Inf s) ≤ ⨅ a∈s, f a :=
by rw [Inf_eq_infi]; exact hf.map_infi₂_le _

lemma antitone.map_supr_le [complete_lattice β] {f : α → β} (hf : antitone f) :
  f (supr s) ≤ ⨅ i, f (s i) :=
hf.dual_left.map_infi_le

lemma antitone.map_supr₂_le [complete_lattice β] {f : α → β} (hf : antitone f) (s : Π i, κ i → α) :
  f (⨆ i j, s i j) ≤ ⨅ i j, f (s i j) :=
hf.dual_left.map_infi₂_le _

lemma antitone.map_Sup_le [complete_lattice β] {s : set α} {f : α → β} (hf : antitone f) :
  f (Sup s) ≤ ⨅ a ∈ s, f a :=
hf.dual_left.map_Inf_le

lemma order_iso.map_infi [complete_lattice β] (f : α ≃o β) (x : ι → α) :
  f (⨅ i, x i) = ⨅ i, f (x i) :=
order_iso.map_supr f.dual _

lemma order_iso.map_Inf [complete_lattice β] (f : α ≃o β) (s : set α) :
  f (Inf s) = ⨅ a ∈ s, f a :=
order_iso.map_Sup f.dual _

lemma le_infi_comp {ι' : Sort*} (f : ι' → α) (g : ι → ι') :
  (⨅ y, f y) ≤ ⨅ x, f (g x) :=
infi_mono' $ λ x, ⟨_, le_rfl⟩

lemma monotone.infi_comp_eq [preorder β] {f : β → α} (hf : monotone f)
  {s : ι → β} (hs : ∀ x, ∃ i, s i ≤ x) :
  (⨅ x, f (s x)) = ⨅ y, f y :=
le_antisymm (infi_mono' $ λ x, (hs x).imp $ λ i hi, hf hi) (le_infi_comp _ _)

lemma supr_const_le {x : α} : (⨆ (h : ι), x) ≤ x :=
supr_le (λ _, le_rfl)

lemma le_infi_const {x : α} : x ≤ (⨅ (h : ι), x) :=
le_infi (λ _, le_rfl)

-- We will generalize this to conditionally complete lattices in `cinfi_const`.
theorem infi_const [nonempty ι] {a : α} : (⨅ b:ι, a) = a :=
by rw [infi, range_const, Inf_singleton]

-- We will generalize this to conditionally complete lattices in `csupr_const`.
theorem supr_const [nonempty ι] {a : α} : (⨆ b:ι, a) = a :=
@infi_const (order_dual α) _ _ _ _

@[simp] lemma infi_top : (⨅ i:ι, ⊤ : α) = ⊤ :=
top_unique $ le_infi $ λ i, le_rfl

@[simp] lemma supr_bot : (⨆ i:ι, ⊥ : α) = ⊥ :=
@infi_top (order_dual α) _ _

@[simp] lemma supr_eq_bot : supr s = ⊥ ↔ ∀ i, s i = ⊥ := Sup_eq_bot.trans forall_range_iff
@[simp] lemma infi_eq_top : infi s = ⊤ ↔ ∀ i, s i = ⊤ := Inf_eq_top.trans forall_range_iff

@[simp] lemma supr₂_eq_bot {f : Π i, κ i → α} : (⨆ i j, f i j) = ⊥ ↔ ∀ i j, f i j = ⊥ :=
by simp_rw supr_eq_bot

@[simp] lemma infi₂_eq_top {f : Π i, κ i → α} : (⨅ i j, f i j) = ⊤ ↔ ∀ i j, f i j = ⊤ :=
by simp_rw infi_eq_top

@[simp] lemma supr_pos {p : Prop} {f : p → α} (hp : p) : (⨆ h : p, f h) = f hp :=
le_antisymm (supr_le $ λ h, le_rfl) (le_supr _ _)

@[simp] lemma infi_pos {p : Prop} {f : p → α} (hp : p) : (⨅ h : p, f h) = f hp :=
le_antisymm (infi_le _ _) (le_infi $ λ h, le_rfl)

@[simp] lemma supr_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨆ h : p, f h) = ⊥ :=
le_antisymm (supr_le $ λ h, (hp h).elim) bot_le

@[simp] lemma infi_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨅ h : p, f h) = ⊤ :=
le_antisymm le_top $ le_infi $ λ h, (hp h).elim

/--Introduction rule to prove that `b` is the supremum of `f`: it suffices to check that `b`
is larger than `f i` for all `i`, and that this is not the case of any `w<b`.
See `csupr_eq_of_forall_le_of_forall_lt_exists_gt` for a version in conditionally complete
lattices. -/
theorem supr_eq_of_forall_le_of_forall_lt_exists_gt {f : ι → α} (h₁ : ∀ i, f i ≤ b)
  (h₂ : ∀ w, w < b → (∃ i, w < f i)) : (⨆ (i : ι), f i) = b :=
Sup_eq_of_forall_le_of_forall_lt_exists_gt (forall_range_iff.mpr h₁)
  (λ w hw, exists_range_iff.mpr $ h₂ w hw)

/--Introduction rule to prove that `b` is the infimum of `f`: it suffices to check that `b`
is smaller than `f i` for all `i`, and that this is not the case of any `w>b`.
See `cinfi_eq_of_forall_ge_of_forall_gt_exists_lt` for a version in conditionally complete
lattices. -/
theorem infi_eq_of_forall_ge_of_forall_gt_exists_lt {f : ι → α} (h₁ : ∀ i, b ≤ f i)
(h₂ : ∀ w, b < w → (∃ i, f i < w)) : (⨅ (i : ι), f i) = b :=
@supr_eq_of_forall_le_of_forall_lt_exists_gt (order_dual α) _ _ _ ‹_› ‹_› ‹_›

lemma supr_eq_dif {p : Prop} [decidable p] (a : p → α) :
  (⨆h:p, a h) = (if h : p then a h else ⊥) :=
by by_cases p; simp [h]

lemma supr_eq_if {p : Prop} [decidable p] (a : α) :
  (⨆h:p, a) = (if p then a else ⊥) :=
supr_eq_dif (λ _, a)

lemma infi_eq_dif {p : Prop} [decidable p] (a : p → α) :
  (⨅h:p, a h) = (if h : p then a h else ⊤) :=
@supr_eq_dif (order_dual α) _ _ _ _

lemma infi_eq_if {p : Prop} [decidable p] (a : α) :
  (⨅h:p, a) = (if p then a else ⊤) :=
infi_eq_dif (λ _, a)

-- TODO: should this be @[simp]?
lemma supr_comm {f : ι → ι' → α} : (⨆ i j, f i j) = ⨆ j i, f i j :=
le_antisymm
  (supr_le $ λ i, supr_mono $ λ j, le_supr _ i)
  (supr_le $ λ j, supr_mono $ λ i, le_supr _ _)

-- TODO: should this be @[simp]?
lemma infi_comm {f : ι → ι' → α} : (⨅ i j, f i j) = ⨅ j i, f i j :=
@supr_comm (order_dual α) _ _ _ _

/- TODO: this is strange. In the proof below, we get exactly the desired
   among the equalities, but close does not get it.
begin
  apply @le_antisymm,
    simp, intros,
    begin [smt]
      ematch, ematch, ematch, trace_state, have := le_refl (f i_1 i),
      trace_state, close
    end
end
-/

@[simp] theorem infi_infi_eq_left {b : β} {f : Πx:β, x = b → α} :
  (⨅x, ⨅h:x = b, f x h) = f b rfl :=
le_antisymm
  (infi₂_le _ rfl)
  (le_infi $ λ b', le_infi $ λ eq, match b', eq with ._, rfl := le_rfl end)

@[simp] theorem infi_infi_eq_right {b : β} {f : Πx:β, b = x → α} :
  (⨅x, ⨅h:b = x, f x h) = f b rfl :=
le_antisymm
  (infi₂_le _ rfl)
  (le_infi₂ $ λ b' eq, match b', eq with ._, rfl := le_rfl end)

@[simp] theorem supr_supr_eq_left {b : β} {f : Πx:β, x = b → α} :
  (⨆x, ⨆h : x = b, f x h) = f b rfl :=
@infi_infi_eq_left (order_dual α) _ _ _ _

@[simp] theorem supr_supr_eq_right {b : β} {f : Πx:β, b = x → α} :
  (⨆x, ⨆h : b = x, f x h) = f b rfl :=
@infi_infi_eq_right (order_dual α) _ _ _ _

attribute [ematch] le_refl

theorem infi_subtype {p : ι → Prop} {f : subtype p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
le_antisymm (le_infi₂ $ λ i h, infi_le _ _) (le_infi $ λ ⟨i, h⟩, infi₂_le _ _)

lemma infi_subtype' {p : ι → Prop} {f : ∀ i, p i → α} :
  (⨅ i (h : p i), f i h) = (⨅ x : subtype p, f x x.property) :=
(@infi_subtype _ _ _ p (λ x, f x.val x.property)).symm

lemma infi_subtype'' {ι} (s : set ι) (f : ι → α) :
  (⨅ i : s, f i) = ⨅ (t : ι) (H : t ∈ s), f t :=
infi_subtype

theorem infi_inf_eq {f g : ι → α} : (⨅ x, f x ⊓ g x) = (⨅ x, f x) ⊓ (⨅ x, g x) :=
le_antisymm
  (le_inf (infi_mono $ λ i, inf_le_left) $ infi_mono $ λ i, inf_le_right)
  (le_infi $ λ i, inf_le_inf (infi_le _ _) $ infi_le _ _)

/- TODO: here is another example where more flexible pattern matching
   might help.

begin
  apply @le_antisymm,
  safe, pose h := f a ⊓ g a, begin [smt] ematch, ematch  end
end
-/

lemma infi_inf [h : nonempty ι] {f : ι → α} {a : α} : (⨅x, f x) ⊓ a = (⨅ x, f x ⊓ a) :=
by rw [infi_inf_eq, infi_const]

lemma inf_infi [nonempty ι] {f : ι → α} {a : α} : a ⊓ (⨅x, f x) = (⨅ x, a ⊓ f x) :=
by rw [inf_comm, infi_inf]; simp [inf_comm]

lemma binfi_inf {p : ι → Prop} {f : Π i (hi : p i), α} {a : α} (h : ∃ i, p i) :
  (⨅ i (h : p i), f i h) ⊓ a = ⨅ i (h : p i), f i h ⊓ a :=
by haveI : nonempty {i // p i} := (let ⟨i, hi⟩ := h in ⟨⟨i, hi⟩⟩);
  rw [infi_subtype', infi_subtype', infi_inf]

lemma inf_binfi {p : ι → Prop} {f : Π i (hi : p i), α} {a : α} (h : ∃ i, p i) :
  a ⊓ (⨅ i (h : p i), f i h) = ⨅ i (h : p i), a ⊓ f i h :=
by simpa only [inf_comm] using binfi_inf h

theorem supr_sup_eq {f g : ι → α} : (⨆ x, f x ⊔ g x) = (⨆ x, f x) ⊔ (⨆ x, g x) :=
@infi_inf_eq (order_dual α) ι _ _ _

lemma supr_sup [h : nonempty ι] {f : ι → α} {a : α} : (⨆ x, f x) ⊔ a = (⨆ x, f x ⊔ a) :=
@infi_inf (order_dual α) _ _ _ _ _

lemma sup_supr [nonempty ι] {f : ι → α} {a : α} : a ⊔ (⨆ x, f x) = (⨆ x, a ⊔ f x) :=
@inf_infi (order_dual α) _ _ _ _ _

/-! ### `supr` and `infi` under `Prop` -/

@[simp] theorem infi_false {s : false → α} : infi s = ⊤ :=
le_antisymm le_top (le_infi $ λ i, false.elim i)

@[simp] theorem supr_false {s : false → α} : supr s = ⊥ :=
le_antisymm (supr_le $ λ i, false.elim i) bot_le

lemma supr_true {s : true → α} : supr s = s trivial := supr_pos trivial
lemma infi_true {s : true → α} : infi s = s trivial := infi_pos trivial

@[simp] lemma infi_exists {p : ι → Prop} {f : Exists p → α} : (⨅ x, f x) = ⨅ i h, f ⟨i, h⟩ :=
le_antisymm (le_infi₂ $ λ i h, infi_le _ _) (le_infi $ λ ⟨i, h⟩, infi₂_le _ _)

@[simp] lemma supr_exists {p : ι → Prop} {f : Exists p → α} : (⨆ x, f x) = ⨆ i h, f ⟨i, h⟩ :=
@infi_exists (order_dual α) _ _ _ _

lemma infi_and {p q : Prop} {s : p ∧ q → α} : infi s = ⨅ h₁ h₂, s ⟨h₁, h₂⟩ :=
le_antisymm (le_infi₂ $ λ i j, infi_le _ _) (le_infi $ λ ⟨i, h⟩, infi₂_le _ _)

/-- The symmetric case of `infi_and`, useful for rewriting into a infimum over a conjunction -/
lemma infi_and' {p q : Prop} {s : p → q → α} :
  (⨅ (h₁ : p) (h₂ : q), s h₁ h₂) = ⨅ (h : p ∧ q), s h.1 h.2 :=
by { symmetry, exact infi_and }

lemma supr_and {p q : Prop} {s : p ∧ q → α} : supr s = ⨆ h₁ h₂, s ⟨h₁, h₂⟩ :=
@infi_and (order_dual α) _ _ _ _

/-- The symmetric case of `supr_and`, useful for rewriting into a supremum over a conjunction -/
lemma supr_and' {p q : Prop} {s : p → q → α} :
  (⨆ (h₁ : p) (h₂ : q), s h₁ h₂) = ⨆ (h : p ∧ q), s h.1 h.2 :=
by { symmetry, exact supr_and }

theorem infi_or {p q : Prop} {s : p ∨ q → α} :
  infi s = (⨅ h : p, s (or.inl h)) ⊓ (⨅ h : q, s (or.inr h)) :=
le_antisymm
  (le_inf (le_infi_comp _ _) $ le_infi_comp _ _)
  (le_infi $ λ i, match i with
  | or.inl i := inf_le_of_left_le $ infi_le _ _
  | or.inr j := inf_le_of_right_le $ infi_le _ _
  end)

theorem supr_or {p q : Prop} {s : p ∨ q → α} :
  (⨆ x, s x) = (⨆ i, s (or.inl i)) ⊔ (⨆ j, s (or.inr j)) :=
@infi_or (order_dual α) _ _ _ _

section

variables (p : ι → Prop) [decidable_pred p]

lemma supr_dite (f : Π i, p i → α) (g : Π i, ¬p i → α) :
  (⨆ i, if h : p i then f i h else g i h) = (⨆ i (h : p i), f i h) ⊔ (⨆ i (h : ¬ p i), g i h) :=
begin
  rw ←supr_sup_eq,
  congr' 1 with i,
  split_ifs with h;
  simp [h],
end

lemma supr_ite (f g : ι → α) :
  (⨆ i, if p i then f i else g i) = (⨆ i (h : p i), f i) ⊔ (⨆ i (h : ¬ p i), g i) :=
supr_dite _ _ _

lemma infi_dite (f : Π i, p i → α) (g : Π i, ¬p i → α) :
  (⨅ i, if h : p i then f i h else g i h) = (⨅ i (h : p i), f i h) ⊓ (⨅ i (h : ¬ p i), g i h) :=
supr_dite p (show Π i, p i → order_dual α, from f) g

lemma infi_ite (f g : ι → α) :
  (⨅ i, if p i then f i else g i) = (⨅ i (h : p i), f i) ⊓ (⨅ i (h : ¬ p i), g i) :=
infi_dite _ _ _

end

lemma infi_range {g : β → α} {f : ι → β} : (⨅ b ∈ range f, g b) = ⨅ i, g (f i) :=
by rw [← infi_subtype'', infi_range']

lemma supr_range {g : β → α} {f : ι → β} : (⨆ b ∈ range f, g b) = ⨆ i, g (f i) :=
@infi_range (order_dual α) _ _ _ _ _

theorem Inf_image {s : set β} {f : β → α} : Inf (f '' s) = ⨅ a ∈ s, f a :=
by rw [← infi_subtype'', Inf_image']

theorem Sup_image {s : set β} {f : β → α} : Sup (f '' s) = ⨆ a ∈ s, f a :=
@Inf_image (order_dual α) _ _ _ _

/-
### supr and infi under set constructions
-/

theorem infi_emptyset {f : β → α} : (⨅ x ∈ (∅ : set β), f x) = ⊤ :=
by simp

theorem supr_emptyset {f : β → α} : (⨆ x ∈ (∅ : set β), f x) = ⊥ :=
by simp

theorem infi_univ {f : β → α} : (⨅ x ∈ (univ : set β), f x) = (⨅ x, f x) :=
by simp

theorem supr_univ {f : β → α} : (⨆ x ∈ (univ : set β), f x) = (⨆ x, f x) :=
by simp

theorem infi_union {f : β → α} {s t : set β} : (⨅ x ∈ s ∪ t, f x) = (⨅x∈s, f x) ⊓ (⨅x∈t, f x) :=
by simp only [← infi_inf_eq, infi_or]

lemma infi_split (f : β → α) (p : β → Prop) :
  (⨅ i, f i) = (⨅ i (h : p i), f i) ⊓ (⨅ i (h : ¬ p i), f i) :=
by simpa [classical.em] using @infi_union _ _ _ f {i | p i} {i | ¬ p i}

lemma infi_split_single (f : β → α) (i₀ : β) :
  (⨅ i, f i) = f i₀ ⊓ (⨅ i (h : i ≠ i₀), f i) :=
by convert infi_split _ _; simp

theorem infi_le_infi_of_subset {f : β → α} {s t : set β} (h : s ⊆ t) :
  (⨅ x ∈ t, f x) ≤ (⨅ x ∈ s, f x) :=
by rw [(union_eq_self_of_subset_left h).symm, infi_union]; exact inf_le_left

theorem supr_union {f : β → α} {s t : set β} : (⨆ x ∈ s ∪ t, f x) = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) :=
@infi_union (order_dual α) _ _ _ _ _

lemma supr_split (f : β → α) (p : β → Prop) :
  (⨆ i, f i) = (⨆ i (h : p i), f i) ⊔ (⨆ i (h : ¬ p i), f i) :=
@infi_split (order_dual α) _ _ _ _

lemma supr_split_single (f : β → α) (i₀ : β) :
  (⨆ i, f i) = f i₀ ⊔ (⨆ i (h : i ≠ i₀), f i) :=
@infi_split_single (order_dual α) _ _ _ _

theorem supr_le_supr_of_subset {f : β → α} {s t : set β} (h : s ⊆ t) :
  (⨆ x ∈ s, f x) ≤ (⨆ x ∈ t, f x) :=
@infi_le_infi_of_subset (order_dual α) _ _ _ _ _ h

theorem infi_insert {f : β → α} {s : set β} {b : β} :
  (⨅ x ∈ insert b s, f x) = f b ⊓ (⨅x∈s, f x) :=
eq.trans infi_union $ congr_arg (λx:α, x ⊓ (⨅x∈s, f x)) infi_infi_eq_left

theorem supr_insert {f : β → α} {s : set β} {b : β} :
  (⨆ x ∈ insert b s, f x) = f b ⊔ (⨆x∈s, f x) :=
eq.trans supr_union $ congr_arg (λx:α, x ⊔ (⨆x∈s, f x)) supr_supr_eq_left

theorem infi_singleton {f : β → α} {b : β} : (⨅ x ∈ (singleton b : set β), f x) = f b :=
by simp

theorem infi_pair {f : β → α} {a b : β} : (⨅ x ∈ ({a, b} : set β), f x) = f a ⊓ f b :=
by rw [infi_insert, infi_singleton]

theorem supr_singleton {f : β → α} {b : β} : (⨆ x ∈ (singleton b : set β), f x) = f b :=
@infi_singleton (order_dual α) _ _ _ _

theorem supr_pair {f : β → α} {a b : β} : (⨆ x ∈ ({a, b} : set β), f x) = f a ⊔ f b :=
by rw [supr_insert, supr_singleton]

lemma infi_image {γ} {f : β → γ} {g : γ → α} {t : set β} :
  (⨅ c ∈ f '' t, g c) = (⨅ b ∈ t, g (f b)) :=
by rw [← Inf_image, ← Inf_image, ← image_comp]

lemma supr_image {γ} {f : β → γ} {g : γ → α} {t : set β} :
  (⨆ c ∈ f '' t, g c) = (⨆ b ∈ t, g (f b)) :=
@infi_image (order_dual α) _ _ _ _ _ _

theorem supr_extend_bot {e : ι → β} (he : injective e) (f : ι → α) :
  (⨆ j, extend e f ⊥ j) = ⨆ i, f i :=
begin
  rw supr_split _ (λ j, ∃ i, e i = j),
  simp [extend_apply he, extend_apply', @supr_comm _ β ι] { contextual := tt }
end

/-!
### `supr` and `infi` under `Type`
-/

theorem supr_of_empty' {α ι} [has_Sup α] [is_empty ι] (f : ι → α) :
  supr f = Sup (∅ : set α) :=
congr_arg Sup (range_eq_empty f)

theorem supr_of_empty [is_empty ι] (f : ι → α) : supr f = ⊥ :=
(supr_of_empty' f).trans Sup_empty

theorem infi_of_empty' {α ι} [has_Inf α] [is_empty ι] (f : ι → α) :
  infi f = Inf (∅ : set α) :=
congr_arg Inf (range_eq_empty f)

theorem infi_of_empty [is_empty ι] (f : ι → α) : infi f = ⊤ :=
@supr_of_empty (order_dual α) _ _ _ f

lemma supr_bool_eq {f : bool → α} : (⨆b:bool, f b) = f tt ⊔ f ff :=
by rw [supr, bool.range_eq, Sup_pair, sup_comm]

lemma infi_bool_eq {f : bool → α} : (⨅b:bool, f b) = f tt ⊓ f ff :=
@supr_bool_eq (order_dual α) _ _

lemma sup_eq_supr (x y : α) : x ⊔ y = ⨆ b : bool, cond b x y :=
by rw [supr_bool_eq, bool.cond_tt, bool.cond_ff]

lemma inf_eq_infi (x y : α) : x ⊓ y = ⨅ b : bool, cond b x y :=
@sup_eq_supr (order_dual α) _ _ _

lemma is_glb_binfi {s : set β} {f : β → α} : is_glb (f '' s) (⨅ x ∈ s, f x) :=
by simpa only [range_comp, subtype.range_coe, infi_subtype'] using @is_glb_infi α s _ (f ∘ coe)

theorem supr_subtype {p : ι → Prop} {f : subtype p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
@infi_subtype (order_dual α) _ _ _ _

lemma supr_subtype' {p : ι → Prop} {f : ∀ i, p i → α} :
  (⨆ i (h : p i), f i h) = (⨆ x : subtype p, f x x.property) :=
(@supr_subtype _ _ _ p (λ x, f x.val x.property)).symm

lemma supr_subtype'' {ι} (s : set ι) (f : ι → α) :
  (⨆ i : s, f i) = ⨆ (t : ι) (H : t ∈ s), f t :=
supr_subtype

lemma is_lub_bsupr {s : set β} {f : β → α} : is_lub (f '' s) (⨆ x ∈ s, f x) :=
by simpa only [range_comp, subtype.range_coe, supr_subtype'] using @is_lub_supr α s _ (f ∘ coe)

theorem infi_sigma {p : β → Type*} {f : sigma p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
eq_of_forall_le_iff $ λ c, by simp only [le_infi_iff, sigma.forall]

theorem supr_sigma {p : β → Type*} {f : sigma p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
@infi_sigma (order_dual α) _ _ _ _

theorem infi_prod {γ : Type*} {f : β × γ → α} : (⨅ x, f x) = (⨅ i j, f (i, j)) :=
eq_of_forall_le_iff $ λ c, by simp only [le_infi_iff, prod.forall]

theorem supr_prod {γ : Type*} {f : β × γ → α} : (⨆ x, f x) = (⨆ i j, f (i, j)) :=
@infi_prod (order_dual α) _ _ _ _

theorem infi_sum {γ : Type*} {f : β ⊕ γ → α} :
  (⨅ x, f x) = (⨅ i, f (sum.inl i)) ⊓ (⨅ j, f (sum.inr j)) :=
eq_of_forall_le_iff $ λ c, by simp only [le_inf_iff, le_infi_iff, sum.forall]

theorem supr_sum {γ : Type*} {f : β ⊕ γ → α} :
  (⨆ x, f x) = (⨆ i, f (sum.inl i)) ⊔ (⨆ j, f (sum.inr j)) :=
@infi_sum (order_dual α) _ _ _ _

theorem supr_option (f : option β → α) :
  (⨆ o, f o) = f none ⊔ ⨆ b, f (option.some b) :=
eq_of_forall_ge_iff $ λ c, by simp only [supr_le_iff, sup_le_iff, option.forall]

theorem infi_option (f : option β → α) :
  (⨅ o, f o) = f none ⊓ ⨅ b, f (option.some b) :=
@supr_option (order_dual α) _ _ _

/-- A version of `supr_option` useful for rewriting right-to-left. -/
lemma supr_option_elim (a : α) (f : β → α) : (⨆ o : option β, o.elim a f) = a ⊔ ⨆ b, f b :=
by simp [supr_option]

/-- A version of `infi_option` useful for rewriting right-to-left. -/
lemma infi_option_elim (a : α) (f : β → α) : (⨅ o : option β, o.elim a f) = a ⊓ ⨅ b, f b :=
@supr_option_elim (order_dual α) _ _ _ _

/-- When taking the supremum of `f : ι → α`, the elements of `ι` on which `f` gives `⊥` can be
dropped, without changing the result. -/
lemma supr_ne_bot_subtype (f : ι → α) : (⨆ i : {i // f i ≠ ⊥}, f i) = ⨆ i, f i :=
begin
  by_cases htriv : ∀ i, f i = ⊥,
  { simp only [htriv, supr_bot] },
  refine le_antisymm (supr_comp_le f _) (supr_mono' _),
  intros i,
  by_cases hi : f i = ⊥,
  { rw hi,
    obtain ⟨i₀, hi₀⟩ := not_forall.mp htriv,
    exact ⟨⟨i₀, hi₀⟩, bot_le⟩ },
  { exact ⟨⟨i, hi⟩, rfl.le⟩ },
end

/-- When taking the infimum of `f : ι → α`, the elements of `ι` on which `f` gives `⊤` can be
dropped, without changing the result. -/
lemma infi_ne_top_subtype (f : ι → α) : (⨅ i : {i // f i ≠ ⊤}, f i) = ⨅ i, f i :=
@supr_ne_bot_subtype (order_dual α) ι _ f

/-!
### `supr` and `infi` under `ℕ`
-/

lemma supr_ge_eq_supr_nat_add {u : ℕ → α} (n : ℕ) : (⨆ i ≥ n, u i) = ⨆ i, u (i + n) :=
begin
  apply le_antisymm;
  simp only [supr_le_iff],
  { exact λ i hi, le_Sup ⟨i - n, by { dsimp only, rw tsub_add_cancel_of_le hi }⟩ },
  { exact λ i, le_Sup ⟨i + n, supr_pos (nat.le_add_left _ _)⟩ }
end

lemma infi_ge_eq_infi_nat_add {u : ℕ → α} (n : ℕ) : (⨅ i ≥ n, u i) = ⨅ i, u (i + n) :=
@supr_ge_eq_supr_nat_add (order_dual α) _ _ _

lemma monotone.supr_nat_add {f : ℕ → α} (hf : monotone f) (k : ℕ) :
  (⨆ n, f (n + k)) = ⨆ n, f n :=
le_antisymm (supr_le $ λ i, le_supr _ (i + k)) $ supr_mono $ λ i, hf $ nat.le_add_right i k

@[simp] lemma supr_infi_ge_nat_add (f : ℕ → α) (k : ℕ) :
  (⨆ n, ⨅ i ≥ n, f (i + k)) = ⨆ n, ⨅ i ≥ n, f i :=
begin
  have hf : monotone (λ n, ⨅ i ≥ n, f i) := λ n m h, binfi_mono (λ i, h.trans),
  rw ←monotone.supr_nat_add hf k,
  { simp_rw [infi_ge_eq_infi_nat_add, ←nat.add_assoc], },
end

lemma sup_supr_nat_succ (u : ℕ → α) : u 0 ⊔ (⨆ i, u (i + 1)) = ⨆ i, u i :=
begin
  refine eq_of_forall_ge_iff (λ c, _),
  simp only [sup_le_iff, supr_le_iff],
  refine ⟨λ h, _, λ h, ⟨h _, λ i, h _⟩⟩,
  rintro (_|i),
  exacts [h.1, h.2 i]
end

lemma inf_infi_nat_succ (u : ℕ → α) : u 0 ⊓ (⨅ i, u (i + 1)) = ⨅ i, u i :=
@sup_supr_nat_succ (order_dual α) _ u

end

section complete_linear_order
variables [complete_linear_order α]

lemma supr_eq_top (f : ι → α) : supr f = ⊤ ↔ (∀b<⊤, ∃i, b < f i) :=
by simp only [← Sup_range, Sup_eq_top, set.exists_range_iff]

lemma infi_eq_bot (f : ι → α) : infi f = ⊥ ↔ (∀b>⊥, ∃i, f i < b) :=
by simp only [← Inf_range, Inf_eq_bot, set.exists_range_iff]

end complete_linear_order

/-!
### Instances
-/

instance Prop.complete_lattice : complete_lattice Prop :=
{ Sup    := λs, ∃a∈s, a,
  le_Sup := λ s a h p, ⟨a, h, p⟩,
  Sup_le := λ s a h ⟨b, h', p⟩, h b h' p,
  Inf    := λs, ∀a:Prop, a∈s → a,
  Inf_le := λ s a h p, p a h,
  le_Inf := λ s a h p b hb, h b hb p,
  .. Prop.bounded_order,
  .. Prop.distrib_lattice }

@[simp] lemma Sup_Prop_eq {s : set Prop} : Sup s = ∃ p ∈ s, p := rfl
@[simp] lemma Inf_Prop_eq {s : set Prop} : Inf s = ∀ p ∈ s, p := rfl

@[simp] lemma infi_Prop_eq {p : ι → Prop} : (⨅ i, p i) = ∀ i, p i :=
le_antisymm (λ h i, h _ ⟨i, rfl⟩ ) (λ h p ⟨i, eq⟩, eq ▸ h i)

@[simp] lemma supr_Prop_eq {p : ι → Prop} : (⨆ i, p i) = ∃ i, p i :=
le_antisymm (λ ⟨q, ⟨i, (eq : p i = q)⟩, hq⟩, ⟨i, eq.symm ▸ hq⟩) (λ ⟨i, hi⟩, ⟨p i, ⟨i, rfl⟩, hi⟩)

instance pi.has_Sup {α : Type*} {β : α → Type*} [Π i, has_Sup (β i)] : has_Sup (Π i, β i) :=
⟨λ s i, ⨆ f : s, (f : Π i, β i) i⟩

instance pi.has_Inf {α : Type*} {β : α → Type*} [Π i, has_Inf (β i)] : has_Inf (Π i, β i) :=
⟨λ s i, ⨅ f : s, (f : Π i, β i) i⟩

instance pi.complete_lattice {α : Type*} {β : α → Type*} [∀ i, complete_lattice (β i)] :
  complete_lattice (Π i, β i) :=
{ Sup := Sup,
  Inf := Inf,
  le_Sup := λ s f hf i, le_supr (λ f : s, (f : Π i, β i) i) ⟨f, hf⟩,
  Inf_le := λ s f hf i, infi_le (λ f : s, (f : Π i, β i) i) ⟨f, hf⟩,
  Sup_le := λ s f hf i, supr_le $ λ g, hf g g.2 i,
  le_Inf := λ s f hf i, le_infi $ λ g, hf g g.2 i,
  .. pi.bounded_order,
  .. pi.lattice }

lemma Inf_apply {α : Type*} {β : α → Type*} [Π i, has_Inf (β i)]
  {s : set (Πa, β a)} {a : α} :
  (Inf s) a = (⨅ f : s, (f : Πa, β a) a) :=
rfl

@[simp] lemma infi_apply {α : Type*} {β : α → Type*} {ι : Sort*} [Π i, has_Inf (β i)]
  {f : ι → Πa, β a} {a : α} :
  (⨅ i, f i) a = ⨅ i, f i a :=
by rw [infi, Inf_apply, infi, infi, ← image_eq_range (λ f : Π i, β i, f a) (range f), ← range_comp]

lemma Sup_apply {α : Type*} {β : α → Type*} [Π i, has_Sup (β i)] {s : set (Πa, β a)} {a : α} :
  (Sup s) a = (⨆f:s, (f : Πa, β a) a) :=
rfl

lemma unary_relation_Sup_iff {α : Type*} (s : set (α → Prop)) {a : α} :
  Sup s a ↔ ∃ (r : α → Prop), r ∈ s ∧ r a :=
by { change (∃ _, _) ↔ _, simp [-eq_iff_iff] }

lemma binary_relation_Sup_iff {α β : Type*} (s : set (α → β → Prop)) {a : α} {b : β} :
  Sup s a b ↔ ∃ (r : α → β → Prop), r ∈ s ∧ r a b :=
by { change (∃ _, _) ↔ _, simp [-eq_iff_iff] }

@[simp] lemma supr_apply {α : Type*} {β : α → Type*} {ι : Sort*} [Π i, has_Sup (β i)]
  {f : ι → Πa, β a} {a : α} :
  (⨆ i, f i) a = (⨆ i, f i a) :=
@infi_apply α (λ i, order_dual (β i)) _ _ f a

section complete_lattice
variables [preorder α] [complete_lattice β]

theorem monotone_Sup_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Sup s) :=
λ x y h, supr_mono $ λ f, m_s f f.2 h

theorem monotone_Inf_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Inf s) :=
λ x y h, infi_mono $ λ f, m_s f f.2 h

end complete_lattice

namespace prod
variables (α β)

instance [has_Inf α] [has_Inf β] : has_Inf (α × β) :=
⟨λs, (Inf (prod.fst '' s), Inf (prod.snd '' s))⟩

instance [has_Sup α] [has_Sup β] : has_Sup (α × β) :=
⟨λs, (Sup (prod.fst '' s), Sup (prod.snd '' s))⟩

instance [complete_lattice α] [complete_lattice β] : complete_lattice (α × β) :=
{ le_Sup := λ s p hab, ⟨le_Sup $ mem_image_of_mem _ hab, le_Sup $ mem_image_of_mem _ hab⟩,
  Sup_le := λ s p h,
    ⟨ Sup_le $ ball_image_of_ball $ λ p hp, (h p hp).1,
      Sup_le $ ball_image_of_ball $ λ p hp, (h p hp).2⟩,
  Inf_le := λ s p hab, ⟨Inf_le $ mem_image_of_mem _ hab, Inf_le $ mem_image_of_mem _ hab⟩,
  le_Inf := λ s p h,
    ⟨ le_Inf $ ball_image_of_ball $ λ p hp, (h p hp).1,
      le_Inf $ ball_image_of_ball $ λ p hp, (h p hp).2⟩,
  .. prod.lattice α β,
  .. prod.bounded_order α β,
  .. prod.has_Sup α β,
  .. prod.has_Inf α β }

end prod

section complete_lattice
variables [complete_lattice α] {a : α} {s : set α}

/-- This is a weaker version of `sup_Inf_eq` -/
lemma sup_Inf_le_infi_sup : a ⊔ Inf s ≤ ⨅ b ∈ s, a ⊔ b :=
le_infi₂ $ λ i h, sup_le_sup_left (Inf_le h) _

/-- This is a weaker version of `Inf_sup_eq` -/
lemma Inf_sup_le_infi_sup : Inf s ⊔ a ≤ ⨅ b ∈ s, b ⊔ a :=
le_infi₂ $ λ i h, sup_le_sup_right (Inf_le h) _

/-- This is a weaker version of `inf_Sup_eq` -/
lemma supr_inf_le_inf_Sup : (⨆ b ∈ s, a ⊓ b) ≤ a ⊓ Sup s :=
supr₂_le $ λ i h, inf_le_inf_left _ (le_Sup h)

/-- This is a weaker version of `Sup_inf_eq` -/
lemma supr_inf_le_Sup_inf : (⨆ b ∈ s, b ⊓ a) ≤ Sup s ⊓ a :=
supr₂_le $ λ i h, inf_le_inf_right _ (le_Sup h)

lemma disjoint_Sup_left {a : set α} {b : α} (d : disjoint (Sup a) b) {i} (hi : i ∈ a) :
  disjoint i b :=
(supr₂_le_iff.1 (supr_inf_le_Sup_inf.trans d) i hi : _)

lemma disjoint_Sup_right {a : set α} {b : α} (d : disjoint b (Sup a)) {i} (hi : i ∈ a) :
  disjoint b i :=
(supr₂_le_iff.mp (supr_inf_le_inf_Sup.trans d) i hi : _)

end complete_lattice

/-- Pullback a `complete_lattice` along an injection. -/
@[reducible] -- See note [reducible non-instances]
protected def function.injective.complete_lattice [has_sup α] [has_inf α] [has_Sup α]
  [has_Inf α] [has_top α] [has_bot α] [complete_lattice β]
  (f : α → β) (hf : function.injective f) (map_sup : ∀ a b, f (a ⊔ b) = f a ⊔ f b)
  (map_inf : ∀ a b, f (a ⊓ b) = f a ⊓ f b) (map_Sup : ∀ s, f (Sup s) = ⨆ a ∈ s, f a)
  (map_Inf : ∀ s, f (Inf s) = ⨅ a ∈ s, f a) (map_top : f ⊤ = ⊤) (map_bot : f ⊥ = ⊥) :
  complete_lattice α :=
{ Sup := Sup,
  le_Sup := λ s a h, (le_supr₂ a h).trans (map_Sup _).ge,
  Sup_le := λ s a h, (map_Sup _).trans_le $ supr₂_le h,
  Inf := Inf,
  Inf_le := λ s a h, (map_Inf _).trans_le $ infi₂_le a h,
  le_Inf := λ s a h, (le_infi₂ h).trans (map_Inf _).ge,
  -- we cannot use bounded_order.lift here as the `has_le` instance doesn't exist yet
  top := ⊤,
  le_top := λ a, (@le_top β _ _ _).trans map_top.ge,
  bot := ⊥,
  bot_le := λ a, map_bot.le.trans bot_le,
  ..hf.lattice f map_sup map_inf }


/-
Copyright (c) 2018 Luca Gerolla. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Luca Gerolla, Kevin Buzzard
Fundamental Group of pointed space, inverse, reparametrisation for fundamental group.
-/
import analysis.topology.continuity
import analysis.topology.topological_space
import analysis.topology.infinite_sum
import analysis.topology.topological_structures
import analysis.topology.uniform_space
import analysis.real
import data.real.basic tactic.norm_num
import data.set.basic
import Topology.Material.pasting_lemma
import Topology.Material.path
import Topology.Material.homotopy
import Topology.Material.homotopy_results

open set filter lattice classical

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

---- FUNDAMENTAL GROUP

namespace fundamental_group
open homotopy_results
open homotopy
open path
section
variables {α  : Type*} [topological_space α ] {x y : α }

instance setoid_hom_path  (x : α) : setoid (path x x) :=
setoid.mk is_homotopic_to (is_equivalence)

instance setoid_hom_loop  (x : α) : setoid (loop x) :=
by unfold loop; apply_instance

definition space_π₁ (x : α) := quotient (fundamental_group.setoid_hom_loop x)

def eq_class  ( f : loop x ) : space_π₁ x := quotient.mk f

--

-- Definition of identity and inverse classes

def id_eq_class (x : α )  : space_π₁ x := ⟦ loop_const x ⟧

lemma inv_eq_class_aux :  ∀ (a b : path x x),
    a ≈ b → ⟦ inv_of_path a ⟧ = ⟦ inv_of_path b ⟧  :=
begin
  intros a b Hab, apply quotient.sound,
  cases Hab, existsi _,
  exact path_homotopy_of_inv_path Hab,
end

def inv_eq_class : space_π₁ x → space_π₁ x :=
quotient.lift ( λ f, ⟦ inv_of_path f ⟧ ) inv_eq_class_aux

-- Definition of multiplication on π₁

lemma mul_aux  : ∀ (a₁ a₂ b₁ b₂ : loop x), a₁ ≈ b₁ → a₂ ≈ b₂ →
    ⟦comp_of_path a₁ a₂⟧ = ⟦comp_of_path b₁ b₂⟧ :=
begin
  intros a₁ a₂ b₁ b₂ H₁ H₂, apply quotient.sound,
  cases H₁ , cases H₂ , existsi _,
  exact path_homotopy_of_comp_path H₁ H₂,
end

protected noncomputable def mul : space_π₁ x → space_π₁ x → space_π₁ x :=
quotient.lift₂ (λ f g, ⟦comp_of_path f g⟧) mul_aux

-- Interface

instance coe_loop_π₁ : has_coe (loop x) (space_π₁ x) := ⟨eq_class⟩

-- To break down mul proofs and use quotient.sound
lemma quotient.out_eq'  ( F : space_π₁ x)  :  F = ⟦ quotient.out F ⟧ :=
begin apply eq.symm, exact quotient.out_eq _, end

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

local notation `fg_mul` := fundamental_group.mul

local attribute [instance] classical.prop_decidable

-----------------------------------------------
-- Identity Elememt

---- Right identity - mul_one

noncomputable def p1 : repar_I01 :=
{   to_fun :=  λ  t, (paste cover_I01 (λ s, par zero_lt_half s ) (λ s, 1) ) t ,
    at_zero := begin unfold paste, rw dif_pos, swap, exact help_T1, simp   end,
    at_one := begin unfold paste, rw dif_neg, exact help_02 end,
    cont := begin simp, refine cont_of_paste _ _ _ (continuous_par _) continuous_const,
        exact T1_is_closed,
        exact T2_is_closed,
        unfold match_of_fun,  intros x B1 B2,
        have Int : x ∈ set.inter T1 T2, exact ⟨ B1 , B2 ⟩ ,
        rwa [inter_T] at Int,
        have V : x.val = 1/2, rwa [mem_set_of_eq] at Int,
        have xeq : x = (⟨ 1/2 , help_01 ⟩ : I01 ) , apply subtype.eq, rw V,
        simp [xeq, -one_div_eq_inv],
        show par zero_lt_half ⟨⟨1 / 2, help_01⟩, help_half_T1⟩  = 1, exact eqn_1,
    end
}

--mul a (id_eq_class x) = a
noncomputable def hom_f_const_to_f ( f : path x y) : path_homotopy (comp_of_path f (loop_const y)) f :=
begin
  have H : comp_of_path f (loop_const y) = repar_path f p1,
    { apply path_equal.2, unfold comp_of_path repar_path, simp, unfold fa_path fb_path fgen_path loop_const p1, simp, unfold par, funext,
    unfold paste,  split_ifs, simp [-one_div_eq_inv], simp,
    },
  rw H, exact hom_repar_path_to_path f p1,
end

-- f ⬝ c ≈ f by using homotopy f → f ⬝ c above -- NOT NEEDED for mul_one
lemma path_const_homeq_path  ( f : path x y)  : is_homotopic_to (comp_of_path f (loop_const y)) f :=
begin  unfold is_homotopic_to, refine nonempty.intro (hom_f_const_to_f f), end

-- Now prove [f]*[c] = [f]
theorem mul_one ( F : space_π₁ x) :  fg_mul F (id_eq_class x) = F :=
begin
  unfold fundamental_group.mul, unfold id_eq_class eq_class, rw [quotient.out_eq' F],
  apply quotient.sound, existsi _,
  exact hom_f_const_to_f (quotient.out F),
end

--------

---- Left identity - one_mul

noncomputable def p2 : repar_I01 :=
{   to_fun :=  λ  t, (paste cover_I01 (λ s, 0 )(λ s, par half_lt_one s ) ) t ,
    at_zero := begin unfold paste, rw dif_pos, exact help_T1,  end,
    at_one := begin unfold paste, rw dif_neg, exact eqn_end , exact help_02  end,
    cont := begin simp, refine cont_of_paste _ _ _ continuous_const (continuous_par _),
        exact T1_is_closed,
        exact T2_is_closed,
        unfold match_of_fun,  intros x B1 B2,
        have Int : x ∈ set.inter T1 T2, exact ⟨ B1 , B2 ⟩ ,
        rwa [inter_T] at Int,
        have V : x.val = 1/2, rwa [mem_set_of_eq] at Int,
        have xeq : x = (⟨ 1/2 , help_01 ⟩ : I01 ) , apply subtype.eq, rw V,
        simp [xeq, -one_div_eq_inv],
        show 0 = par half_lt_one ⟨⟨1 / 2, help_01⟩, help_half_T2⟩, apply eq.symm, exact eqn_2
    end
}

--mul (id_eq_class x) a = a
noncomputable def hom_const_f_to_f  ( f : path x y) : path_homotopy (comp_of_path (loop_const x) f ) f:=
begin
have H : comp_of_path (loop_const x) f = repar_path f p2,
  { apply path_equal.2, unfold comp_of_path repar_path, simp, unfold fa_path fb_path fgen_path loop_const p2, simp, unfold par, funext,
  unfold paste,  split_ifs, simp [-one_div_eq_inv],
     },
rw H, exact hom_repar_path_to_path f p2,
end

-- Now prove [c]*[f] = [f]
theorem one_mul ( F : space_π₁ x) : fg_mul (id_eq_class x) F = F :=
begin
  unfold fundamental_group.mul, unfold id_eq_class eq_class, rw [quotient.out_eq' F],
  apply quotient.sound, existsi _,
  exact hom_const_f_to_f (quotient.out F),
end

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

----------------------------------------------------
-- Inverse Element

theorem mul_left_inv  (F : space_π₁ x) : fg_mul (inv_eq_class F) F = id_eq_class x :=
begin
 unfold fundamental_group.mul, unfold id_eq_class eq_class inv_eq_class, rw [quotient.out_eq' F],
 apply quotient.sound, existsi _, exact hom_inv_comp_to_const (quotient.out F)
end

---------------------------------------------------
-- Associativity

theorem mul_assoc (F G H: space_π₁ x) : fg_mul (fg_mul F G) H = fg_mul F (fg_mul G H) :=
begin
  unfold fundamental_group.mul, rw [quotient.out_eq' F ,quotient.out_eq' G , quotient.out_eq' H],
  apply quotient.sound,
  existsi _, exact path_homotopy_inverse (
  hom_comp_f_g_h (quotient.out F) (quotient.out G) (quotient.out H)),
end

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

-- Group π₁ (α  , x)

noncomputable def π₁_group (x : α ) : group ( space_π₁ x) :=
{
  mul := fundamental_group.mul ,
  mul_assoc := fundamental_group.mul_assoc,

  one := id_eq_class x ,
  one_mul := fundamental_group.one_mul ,
  mul_one := fundamental_group.mul_one ,

  inv :=  inv_eq_class  ,
  mul_left_inv := fundamental_group.mul_left_inv
}

end

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

-- Section on π₁ (ℝ , x ) to show ℝ is contractible

section
variable {x : ℝ }

noncomputable theory

-- x in {} or ()?
def c : loop x := loop_const x

def C : space_π₁ x := id_eq_class x

lemma trivial_check (x : ℝ ) : C = ⟦@c x⟧ :=
by unfold C id_eq_class c

-- Define homotopy to show that any loop f in ℝ is homotopic to the constant loop c_x (based at x)
def homotopy_real_fun ( f : loop x ) : I01 × I01 → ℝ :=
λ st, (1 - st.1.1) * f.to_fun (st.2) + st.1.1 * f.to_fun (0)

lemma homotopy_real_start_pt ( f : loop x ) : ∀ (s : I01), homotopy_real_fun f (s, 0) = x :=
begin
 intro s, unfold homotopy_real_fun, simp [-sub_eq_add_neg , sub_mul, add_sub, add_sub_assoc,  sub_self (s.val * x )],
end

lemma homotopy_real_end_pt ( f : loop x ) :  ∀ (s : I01), homotopy_real_fun f (s, 1) = x :=
begin
 intro s, unfold homotopy_real_fun, simp [-sub_eq_add_neg , sub_mul, add_sub, add_sub_assoc,  sub_self (s.val * x )],
end

lemma homotopy_real_at_zero ( f : loop x ) : ∀ (y : I01), homotopy_real_fun f (0, y) = f.to_fun y  :=
begin
 intro t, unfold homotopy_real_fun, have a₁ : (0:I01).val = (0:ℝ), trivial,
 simp [-sub_eq_add_neg , a₁ , sub_zero , zero_mul],
end

lemma homotopy_real_at_one ( f : loop x ) : ∀ (y : I01), homotopy_real_fun f (1, y) = (@c x ).to_fun y :=
begin
 intro t, unfold homotopy_real_fun c loop_const, have a₁ : (1:I01).val = (1:ℝ), trivial,
 simp [a₁],
end

lemma homotopy_real_cont ( f : loop x ) : continuous (homotopy_real_fun f):=
begin
 unfold homotopy_real_fun, refine continuous_add _ _,
   { refine continuous_mul _ _,
     { refine continuous_add _ _, exact continuous_const,
     exact continuous.comp (continuous.comp continuous_fst continuous_subtype_val) (continuous_neg continuous_id),
     },
     exact continuous.comp continuous_snd f.cont,
   },
   refine continuous_mul _ continuous_const,
   exact continuous.comp continuous_fst continuous_subtype_val,
end

--Use the above lemmas to define homotopy with path_homotopy.mk' constructor

definition homotopy_real ( f : loop x ) : path_homotopy f c  :=
path_homotopy.mk' (homotopy_real_fun f) (homotopy_real_start_pt f) (homotopy_real_end_pt f)
(homotopy_real_at_zero f) (homotopy_real_at_one f)  (homotopy_real_cont f)

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

theorem real_trivial_eq_class (F : space_π₁ x) : F = C :=
begin
 rw quotient.out_eq' F, rw trivial_check, apply quotient.sound, existsi _,
 exact homotopy_real (quotient.out F),
end

end

--set_option trace.simplify.rewrite true
--set_option pp.implicit true

end fundamental_group