/-
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 order.bounds
import data.set.bool
import data.nat.basic

/-!
# 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

We use `Sup`/`Inf`/`supr`/`infi` for the corresponding functions in the statement. Sometimes we
also use `bsupr`/`binfi` for "bounded" supremum or infimum, i.e. one of `⨆ i ∈ s, f i`,
`⨆ i (hi : p i), f i`, or more generally `⨆ i (hi : p i), f i hi`.

## 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

variables {α β β₂ : Type*} {ι ι₂ : 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) := ⟨assume x, le_Sup, assume 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)⟩

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) := ⟨assume a, Inf_le, assume 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, (∀ x ∈ s, b ≤ x) → b ≤ a) :=
⟨λ h b hb, le_trans (le_Inf hb) h, λ hb, hb _ (λ x, Inf_le)⟩

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 α

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 :=
by finish
/-
  Sup_le (assume 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
  (assume h a ha, top_unique $ h ▸ Inf_le ha)
  (assume h, top_unique $ le_Inf $ assume 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 (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, by finish [lt_irrefl (Sup s)],
show Sup s = b, by finish

/--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
  (assume (h : Sup s = ⊤) b hb, by rwa [←h, lt_Sup_iff] at hb)
  (assume h, top_unique $ le_of_not_gt $ assume 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
variables [complete_lattice α] {s t : ι → α} {a b : α}

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

@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i ≤ supr s :) :=
le_Sup ⟨i, rfl⟩

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

lemma is_lub_supr : is_lub (range s) (⨆j, s j) := is_lub_Sup _

lemma is_lub.supr_eq (h : is_lub (range s) a) : (⨆j, s j) = a := h.Sup_eq

lemma is_glb_infi : is_glb (range s) (⨅j, s j) := is_glb_Inf _

lemma is_glb.infi_eq (h : is_glb (range s) a) : (⨅j, s j) = a := h.Inf_eq

theorem le_supr_of_le (i : ι) (h : a ≤ s i) : a ≤ supr s :=
le_trans h (le_supr _ i)

theorem le_bsupr {p : ι → Prop} {f : Π i (h : p i), α} (i : ι) (hi : p i) :
  f i hi ≤ ⨆ i hi, f i hi :=
le_supr_of_le i $ le_supr (f i) hi

theorem le_bsupr_of_le {p : ι → Prop} {f : Π i (h : p i), α} (i : ι) (hi : p i) (h : a ≤ f i hi) :
  a ≤ ⨆ i hi, f i hi :=
le_trans h (le_bsupr i hi)

theorem supr_le (h : ∀i, s i ≤ a) : supr s ≤ a :=
Sup_le $ assume b ⟨i, eq⟩, eq ▸ h i

theorem bsupr_le {p : ι → Prop} {f : Π i (h : p i), α} (h : ∀ i hi, f i hi ≤ a) :
  (⨆ i (hi : p i), f i hi) ≤ a :=
supr_le $ λ i, supr_le $ h i

theorem bsupr_le_supr (p : ι → Prop) (f : ι → α) : (⨆ i (H : p i), f i) ≤ ⨆ i, f i :=
bsupr_le (λ i hi, le_supr f i)

theorem supr_le_supr (h : ∀i, s i ≤ t i) : supr s ≤ supr t :=
supr_le $ assume i, le_supr_of_le i (h i)

theorem supr_le_supr2 {t : ι₂ → α} (h : ∀i, ∃j, s i ≤ t j) : supr s ≤ supr t :=
supr_le $ assume j, exists.elim (h j) le_supr_of_le

theorem bsupr_le_bsupr {p : ι → Prop} {f g : Π i (hi : p i), α} (h : ∀ i hi, f i hi ≤ g i hi) :
  (⨆ i hi, f i hi) ≤ ⨆ i hi, g i hi :=
bsupr_le $ λ i hi, le_trans (h i hi) (le_bsupr i hi)

theorem supr_le_supr_const (h : ι → ι₂) : (⨆ i:ι, a) ≤ (⨆ j:ι₂, a) :=
supr_le $ le_supr _ ∘ h

theorem bsupr_le_bsupr' {p q : ι → Prop} (hpq : ∀ i, p i → q i) {f : ι → α} :
  (⨆ i (hpi : p i), f i) ≤ ⨆ i (hqi : q i), f i :=
supr_le_supr $ λ i, supr_le_supr_const (hpq i)

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

theorem supr_lt_iff : supr s < a ↔ ∃ b < a, ∀ i, s i ≤ b :=
⟨λ h, ⟨supr s, h, λ i, le_supr s i⟩, λ ⟨b, hba, hsb⟩, (supr_le hsb).trans_lt hba⟩

theorem Sup_eq_supr {s : set α} : Sup s = (⨆a ∈ s, a) :=
le_antisymm
  (Sup_le $ assume b h, le_supr_of_le b $ le_supr _ h)
  (supr_le $ assume b, supr_le $ assume h, le_Sup h)

lemma Sup_eq_supr' {α} [has_Sup α] (s : set α) : Sup s = ⨆ x : s, (x : α) :=
by rw [supr, subtype.range_coe]

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 le_supr_iff : (a ≤ supr s) ↔ (∀ b, (∀ i, s i ≤ b) → a ≤ b) :=
⟨λ h b hb, le_trans h (supr_le hb), λ h, h _ $ λ i, le_supr s i⟩

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_supr2 [complete_lattice β] {f : α → β} (hf : monotone f)
  {ι' : ι → Sort*} (s : Π i, ι' i → α) :
  (⨆ i (h : ι' i), f (s i h)) ≤ f (⨆ i (h : ι' i), s i h) :=
calc (⨆ i h, f (s i h)) ≤ (⨆ i, f (⨆ h, s i h)) :
  supr_le_supr $ λ i, hf.le_map_supr
... ≤ f (⨆ i (h : ι' i), s i h) : 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_supr2 _

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_le_supr2 $ λ x, ⟨_, le_refl _⟩

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_le_supr2 $ λ x, (hs x).imp $ λ i hi, hf hi)

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

lemma supr_congr {α : Type*} [has_Sup α] {f : ι → α} {g : ι₂ → α} (h : ι → ι₂)
  (h1 : function.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 }

-- TODO: finish doesn't do well here.
@[congr] theorem supr_congr_Prop {α : Type*} [has_Sup α] {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

theorem infi_le (s : ι → α) (i : ι) : infi s ≤ s i :=
Inf_le ⟨i, rfl⟩

@[ematch] theorem infi_le' (s : ι → α) (i : ι) : (: infi s ≤ s i :) :=
Inf_le ⟨i, rfl⟩

theorem infi_le_of_le (i : ι) (h : s i ≤ a) : infi s ≤ a :=
le_trans (infi_le _ i) h

theorem binfi_le {p : ι → Prop} {f : Π i (hi : p i), α} (i : ι) (hi : p i) :
  (⨅ i hi, f i hi) ≤ f i hi :=
infi_le_of_le i $ infi_le (f i) hi

theorem binfi_le_of_le {p : ι → Prop} {f : Π i (hi : p i), α} (i : ι) (hi : p i) (h : f i hi ≤ a) :
  (⨅ i hi, f i hi) ≤ a :=
le_trans (binfi_le i hi) h

theorem le_infi (h : ∀i, a ≤ s i) : a ≤ infi s :=
le_Inf $ assume b ⟨i, eq⟩, eq ▸ h i

theorem le_binfi {p : ι → Prop} {f : Π i (h : p i), α} (h : ∀ i hi, a ≤ f i hi) :
  a ≤ ⨅ i hi, f i hi :=
le_infi $ λ i, le_infi $ h i

theorem infi_le_binfi (p : ι → Prop) (f : ι → α) : (⨅ i, f i) ≤ ⨅ i (H : p i), f i :=
le_binfi (λ i hi, infi_le f i)

theorem infi_le_infi (h : ∀i, s i ≤ t i) : infi s ≤ infi t :=
le_infi $ assume i, infi_le_of_le i (h i)

theorem infi_le_infi2 {t : ι₂ → α} (h : ∀j, ∃i, s i ≤ t j) : infi s ≤ infi t :=
le_infi $ assume j, exists.elim (h j) infi_le_of_le

theorem binfi_le_binfi {p : ι → Prop} {f g : Π i (h : p i), α} (h : ∀ i hi, f i hi ≤ g i hi) :
  (⨅ i hi, f i hi) ≤ ⨅ i hi, g i hi :=
le_binfi $ λ i hi, le_trans (binfi_le i hi) (h i hi)

theorem infi_le_infi_const (h : ι₂ → ι) : (⨅ i:ι, a) ≤ (⨅ j:ι₂, a) :=
le_infi $ infi_le _ ∘ h

@[simp] theorem le_infi_iff : a ≤ infi s ↔ (∀i, a ≤ s i) :=
⟨assume : a ≤ infi s, assume i, le_trans this (infi_le _ _), le_infi⟩

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

theorem Inf_eq_infi' {α} [has_Inf α] (s : set α) : Inf s = ⨅ a : s, a :=
@Sup_eq_supr' (order_dual α) _ _

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_infi2_le [complete_lattice β] {f : α → β} (hf : monotone f)
  {ι' : ι → Sort*} (s : Π i, ι' i → α) :
  f (⨅ i (h : ι' i), s i h) ≤ (⨅ i (h : ι' i), f (s i h)) :=
@monotone.le_map_supr2 (order_dual α) (order_dual β) _ _ _ f hf.dual _ _

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_infi2_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_le_infi2 $ λ x, ⟨_, le_refl _⟩

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_le_infi2 $ λ x, (hs x).imp $ λ i hi, hf hi) (le_infi_comp _ _)

lemma function.surjective.infi_comp {α : Type*} [has_Inf α] {f : ι → ι₂}
  (hf : function.surjective f) (g : ι₂ → α) :
  (⨅ x, g (f x)) = ⨅ y, g y :=
@function.surjective.supr_comp _ _ (order_dual α) _ f hf g

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

@[congr] theorem infi_congr_Prop {α : Type*} [has_Inf α] {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 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 $ assume i, le_refl _

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

@[simp] lemma infi_eq_top : infi s = ⊤ ↔ (∀i, s i = ⊤) :=
Inf_eq_top.trans forall_range_iff

@[simp] lemma supr_eq_bot : supr s = ⊥ ↔ (∀i, s i = ⊥) :=
Sup_eq_bot.trans forall_range_iff

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

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

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

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

/--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]?
theorem infi_comm {f : ι → ι₂ → α} : (⨅i, ⨅j, f i j) = (⨅j, ⨅i, f i j) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le_of_le j $ infi_le _ i)
  (le_infi $ assume j, le_infi $ assume i, infi_le_of_le i $ infi_le _ j)

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

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

@[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_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_refl _ 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_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_refl _ 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 $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ 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
    (le_infi $ assume i, infi_le_of_le i inf_le_left)
    (le_infi $ assume i, infi_le_of_le i inf_le_right))
  (le_infi $ assume i, le_inf
    (inf_le_of_left_le $ infi_le _ _)
    (inf_le_of_right_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 $ assume i, false.elim i)

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

theorem infi_true {s : true → α} : infi s = s trivial :=
infi_pos trivial

theorem supr_true {s : true → α} : supr s = s trivial :=
supr_pos trivial

@[simp] theorem infi_exists {p : ι → Prop} {f : Exists p → α} :
  (⨅ x, f x) = (⨅ i, ⨅ h:p i, f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

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

theorem infi_and {p q : Prop} {s : p ∧ q → α} : infi s = (⨅ h₁ h₂, s ⟨h₁, h₂⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ 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 }

theorem 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
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩)
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩))
  (le_infi $ assume 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 Sup_range {α : Type*} [has_Sup α] {f : ι → α} : Sup (range f) = supr f := rfl

lemma Inf_range {α : Type*} [has_Inf α] {f : ι → α} : Inf (range f) = infi f := rfl

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

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

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' {α} [has_Inf α] {s : set β} {f : β → α} :
  Inf (f '' s) = (⨅ a : s, f a) :=
by rw [infi, image_eq_range]

theorem Sup_image' {α} [has_Sup α] {s : set β} {f : β → α} :
  Sup (f '' s) = (⨆ a : s, f a) :=
@Inf_image' _ (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 α) _ _ _ _ _ _

/-!
### `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_le_supr2 _),
  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_refl _).trans (le_supr _ (i + k))))
    (supr_le_supr (λ 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),
    from λ n m hnm, le_infi (λ i, (infi_le _ i).trans (le_infi (λ h, infi_le _ (hnm.trans h)))),
  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 := assume s a h p, ⟨a, h, p⟩,
  Sup_le := assume s a h ⟨b, h', p⟩, h b h' p,
  Inf    := λs, ∀a:Prop, a∈s → a,
  Inf_le := assume s a h p, p a h,
  le_Inf := assume s a h p b hb, h b hb p,
  .. Prop.bounded_order,
  .. Prop.distrib_lattice }

@[simp] lemma Inf_Prop_eq {s : set Prop} : Inf s = (∀p ∈ s, p) := rfl

@[simp] lemma Sup_Prop_eq {s : set Prop} : Sup s = (∃p ∈ s, p) := rfl

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

@[simp] lemma supr_Prop_eq {ι : Sort*} {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) :=
assume x y h, supr_le $ λ f, le_supr_of_le f $ m_s f f.2 h

theorem monotone_Inf_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Inf s) :=
assume x y h, le_infi $ λ f, infi_le_of_le 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 := assume s p hab, ⟨le_Sup $ mem_image_of_mem _ hab, le_Sup $ mem_image_of_mem _ hab⟩,
  Sup_le := assume s p h,
    ⟨ Sup_le $ ball_image_of_ball $ assume p hp, (h p hp).1,
      Sup_le $ ball_image_of_ball $ assume p hp, (h p hp).2⟩,
  Inf_le := assume s p hab, ⟨Inf_le $ mem_image_of_mem _ hab, Inf_le $ mem_image_of_mem _ hab⟩,
  le_Inf := assume s p h,
    ⟨ le_Inf $ ball_image_of_ball $ assume p hp, (h p hp).1,
      le_Inf $ ball_image_of_ball $ assume 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 $ assume i, le_infi $ assume 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 $ assume i, le_infi $ assume 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 $ assume i, supr_le $ assume 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 $ assume i, supr_le $ assume 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.mp (supr_le_iff.mp (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_le_iff.mp (supr_inf_le_inf_Sup.trans (d : _)) i : _) hi : _)

end complete_lattice

namespace complete_lattice
variables [complete_lattice α]

/-- An independent set of elements in a complete lattice is one in which every element is disjoint
  from the `Sup` of the rest. -/
def set_independent (s : set α) : Prop := ∀ ⦃a⦄, a ∈ s → disjoint a (Sup (s \ {a}))

variables {s : set α} (hs : set_independent s)

@[simp]
lemma set_independent_empty : set_independent (∅ : set α) :=
λ x hx, (set.not_mem_empty x hx).elim

theorem set_independent.mono {t : set α} (hst : t ⊆ s) :
  set_independent t :=
λ a ha, (hs (hst ha)).mono_right (Sup_le_Sup (diff_subset_diff_left hst))

/-- If the elements of a set are independent, then any pair within that set is disjoint. -/
lemma set_independent.disjoint {x y : α} (hx : x ∈ s) (hy : y ∈ s) (h : x ≠ y) : disjoint x y :=
disjoint_Sup_right (hs hx) ((mem_diff y).mpr ⟨hy, by simp [h.symm]⟩)

include hs

/-- If the elements of a set are independent, then any element is disjoint from the `Sup` of some
subset of the rest. -/
lemma set_independent.disjoint_Sup {x : α} {y : set α} (hx : x ∈ s) (hy : y ⊆ s) (hxy : x ∉ y) :
  disjoint x (Sup y) :=
begin
  have := (hs.mono $ insert_subset.mpr ⟨hx, hy⟩) (mem_insert x _),
  rw [insert_diff_of_mem _ (mem_singleton _), diff_singleton_eq_self hxy] at this,
  exact this,
end

omit hs

/-- An independent indexed family of elements in a complete lattice is one in which every element
  is disjoint from the `supr` of the rest.

  Example: an indexed family of non-zero elements in a
  vector space is linearly independent iff the indexed family of subspaces they generate is
  independent in this sense.

  Example: an indexed family of submodules of a module is independent in this sense if
  and only the natural map from the direct sum of the submodules to the module is injective. -/
def independent {ι : Sort*} {α : Type*} [complete_lattice α] (t : ι → α) : Prop :=
∀ i : ι, disjoint (t i) (⨆ (j ≠ i), t j)

lemma set_independent_iff {α : Type*} [complete_lattice α] (s : set α) :
  set_independent s ↔ independent (coe : s → α) :=
begin
  simp_rw [independent, set_independent, set_coe.forall, Sup_eq_supr],
  apply forall_congr, intro a, apply forall_congr, intro ha,
  congr' 2,
  convert supr_subtype.symm,
  simp [supr_and],
end

variables {t : ι → α} (ht : independent t)

theorem independent_def : independent t ↔ ∀ i : ι, disjoint (t i) (⨆ (j ≠ i), t j) :=
iff.rfl

theorem independent_def' {ι : Type*} {t : ι → α} :
  independent t ↔ ∀ i, disjoint (t i) (Sup (t '' {j | j ≠ i})) :=
by {simp_rw Sup_image, refl}

theorem independent_def'' {ι : Type*} {t : ι → α} :
  independent t ↔ ∀ i, disjoint (t i) (Sup {a | ∃ j ≠ i, t j = a}) :=
by {rw independent_def', tidy}

@[simp]
lemma independent_empty (t : empty → α) : independent t.

@[simp]
lemma independent_pempty (t : pempty → α) : independent t.

/-- If the elements of a set are independent, then any pair within that set is disjoint. -/
lemma independent.disjoint {x y : ι} (h : x ≠ y) : disjoint (t x) (t y) :=
disjoint_Sup_right (ht x) ⟨y, by simp [h.symm]⟩

lemma independent.mono {ι : Type*} {α : Type*} [complete_lattice α]
  {s t : ι → α} (hs : independent s) (hst : t ≤ s) :
  independent t :=
λ i, (hs i).mono (hst i) (supr_le_supr $ λ j, supr_le_supr $ λ _, hst j)

/-- Composing an independent indexed family with an injective function on the index results in
another indepedendent indexed family. -/
lemma independent.comp {ι ι' : Sort*} {α : Type*} [complete_lattice α]
  {s : ι → α} (hs : independent s) (f : ι' → ι) (hf : function.injective f) :
  independent (s ∘ f) :=
λ i, (hs (f i)).mono_right begin
  refine (supr_le_supr $ λ i, _).trans (supr_comp_le _ f),
  exact supr_le_supr_const hf.ne,
end

/-- Composing an indepedent indexed family with an order isomorphism on the elements results in
another indepedendent indexed family. -/
lemma independent.map_order_iso {ι : Sort*} {α β : Type*}
  [complete_lattice α] [complete_lattice β] (f : α ≃o β) {a : ι → α} (ha : independent a) :
  independent (f ∘ a) :=
λ i, ((ha i).map_order_iso f).mono_right (f.monotone.le_map_supr2 _)

@[simp] lemma independent_map_order_iso_iff {ι : Sort*} {α β : Type*}
  [complete_lattice α] [complete_lattice β] (f : α ≃o β) {a : ι → α} :
  independent (f ∘ a) ↔ independent a :=
⟨ λ h, have hf : f.symm ∘ f ∘ a = a := congr_arg (∘ a) f.left_inv.comp_eq_id,
      hf ▸ h.map_order_iso f.symm,
  λ h, h.map_order_iso f⟩

/-- If the elements of a set are independent, then any element is disjoint from the `supr` of some
subset of the rest. -/
lemma independent.disjoint_bsupr {ι : Type*} {α : Type*} [complete_lattice α]
  {t : ι → α} (ht : independent t) {x : ι} {y : set ι} (hx : x ∉ y) :
  disjoint (t x) (⨆ i ∈ y, t i) :=
disjoint.mono_right (bsupr_le_bsupr' $ λ i hi, (ne_of_mem_of_not_mem hi hx : _)) (ht x)

end complete_lattice


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Aaron Anderson, Yakov Pechersky
-/
import data.fintype.basic
import group_theory.perm.basic

/-!
# Support of a permutation

## Main definitions

In the following, `f g : equiv.perm α`.

* `equiv.perm.disjoint`: two permutations `f` and `g` are `disjoint` if every element is fixed
  either by `f`, or by `g`.
  Equivalently, `f` and `g` are `disjoint` iff their `support` are disjoint.
* `equiv.perm.is_swap`: `f = swap x y` for `x ≠ y`.
* `equiv.perm.support`: the elements `x : α` that are not fixed by `f`.

-/

open equiv finset

namespace equiv.perm

variables {α : Type*}
section disjoint

/-- Two permutations `f` and `g` are `disjoint` if their supports are disjoint, i.e.,
every element is fixed either by `f`, or by `g`. -/
def disjoint (f g : perm α) := ∀ x, f x = x ∨ g x = x

variables {f g h : perm α}

@[symm] lemma disjoint.symm : disjoint f g → disjoint g f :=
by simp only [disjoint, or.comm, imp_self]

lemma disjoint.symmetric : symmetric (@disjoint α) :=
λ _ _, disjoint.symm

lemma disjoint_comm : disjoint f g ↔ disjoint g f :=
⟨disjoint.symm, disjoint.symm⟩

lemma disjoint.commute (h : disjoint f g) : commute f g :=
equiv.ext $ λ x, (h x).elim
  (λ hf, (h (g x)).elim (λ hg, by simp [mul_apply, hf, hg])
    (λ hg, by simp [mul_apply, hf, g.injective hg]))
  (λ hg, (h (f x)).elim (λ hf, by simp [mul_apply, f.injective hf, hg])
    (λ hf, by simp [mul_apply, hf, hg]))

@[simp] lemma disjoint_one_left (f : perm α) : disjoint 1 f := λ _, or.inl rfl

@[simp] lemma disjoint_one_right (f : perm α) : disjoint f 1 := λ _, or.inr rfl

lemma disjoint_iff_eq_or_eq : disjoint f g ↔ ∀ (x : α), f x = x ∨ g x = x := iff.rfl

@[simp] lemma disjoint_refl_iff : disjoint f f ↔ f = 1 :=
begin
  refine ⟨λ h, _, λ h, h.symm ▸ disjoint_one_left 1⟩,
  ext x,
  cases h x with hx hx;
  simp [hx]
end

lemma disjoint.inv_left (h : disjoint f g) : disjoint f⁻¹ g :=
begin
  intro x,
  rw [inv_eq_iff_eq, eq_comm],
  exact h x
end

lemma disjoint.inv_right (h : disjoint f g) : disjoint f g⁻¹ :=
h.symm.inv_left.symm

@[simp] lemma disjoint_inv_left_iff : disjoint f⁻¹ g ↔  disjoint f g :=
begin
  refine ⟨λ h, _, disjoint.inv_left⟩,
  convert h.inv_left,
  exact (inv_inv _).symm
end

@[simp] lemma disjoint_inv_right_iff : disjoint f g⁻¹ ↔ disjoint f g :=
by rw [disjoint_comm, disjoint_inv_left_iff, disjoint_comm]

lemma disjoint.mul_left (H1 : disjoint f h) (H2 : disjoint g h) :
  disjoint (f * g) h :=
λ x, by cases H1 x; cases H2 x; simp *

lemma disjoint.mul_right (H1 : disjoint f g) (H2 : disjoint f h) :
  disjoint f (g * h) :=
by { rw disjoint_comm, exact H1.symm.mul_left H2.symm }

lemma disjoint_prod_right (l : list (perm α))
  (h : ∀ g ∈ l, disjoint f g) : disjoint f l.prod :=
begin
  induction l with g l ih,
  { exact disjoint_one_right _ },
  { rw list.prod_cons,
    exact (h _ (list.mem_cons_self _ _)).mul_right (ih (λ g hg, h g (list.mem_cons_of_mem _ hg))) }
end

lemma disjoint_prod_perm {l₁ l₂ : list (perm α)} (hl : l₁.pairwise disjoint)
  (hp : l₁ ~ l₂) : l₁.prod = l₂.prod :=
hp.prod_eq' $ hl.imp $ λ f g, disjoint.commute

lemma pow_apply_eq_self_of_apply_eq_self {x : α} (hfx : f x = x) :
  ∀ n : ℕ, (f ^ n) x = x
| 0     := rfl
| (n+1) := by rw [pow_succ', mul_apply, hfx, pow_apply_eq_self_of_apply_eq_self]

lemma zpow_apply_eq_self_of_apply_eq_self {x : α} (hfx : f x = x) :
  ∀ n : ℤ, (f ^ n) x = x
| (n : ℕ) := pow_apply_eq_self_of_apply_eq_self hfx n
| -[1+ n] := by rw [zpow_neg_succ_of_nat, inv_eq_iff_eq, pow_apply_eq_self_of_apply_eq_self hfx]

lemma pow_apply_eq_of_apply_apply_eq_self {x : α} (hffx : f (f x) = x) :
  ∀ n : ℕ, (f ^ n) x = x ∨ (f ^ n) x = f x
| 0     := or.inl rfl
| (n+1) := (pow_apply_eq_of_apply_apply_eq_self n).elim
  (λ h, or.inr (by rw [pow_succ, mul_apply, h]))
  (λ h, or.inl (by rw [pow_succ, mul_apply, h, hffx]))

lemma zpow_apply_eq_of_apply_apply_eq_self {x : α} (hffx : f (f x) = x) :
  ∀ i : ℤ, (f ^ i) x = x ∨ (f ^ i) x = f x
| (n : ℕ) := pow_apply_eq_of_apply_apply_eq_self hffx n
| -[1+ n] := by { rw [zpow_neg_succ_of_nat, inv_eq_iff_eq, ← f.injective.eq_iff, ← mul_apply,
    ← pow_succ, eq_comm, inv_eq_iff_eq, ← mul_apply, ← pow_succ', @eq_comm _ x, or.comm],
  exact pow_apply_eq_of_apply_apply_eq_self hffx _ }

lemma disjoint.mul_apply_eq_iff {σ τ : perm α} (hστ : disjoint σ τ) {a : α} :
  (σ * τ) a = a ↔ σ a = a ∧ τ a = a :=
begin
  refine ⟨λ h, _, λ h, by rw [mul_apply, h.2, h.1]⟩,
  cases hστ a with hσ hτ,
  { exact ⟨hσ, σ.injective (h.trans hσ.symm)⟩ },
  { exact ⟨(congr_arg σ hτ).symm.trans h, hτ⟩ },
end

lemma disjoint.mul_eq_one_iff {σ τ : perm α} (hστ : disjoint σ τ) :
  σ * τ = 1 ↔ σ = 1 ∧ τ = 1 :=
by simp_rw [ext_iff, one_apply, hστ.mul_apply_eq_iff, forall_and_distrib]

lemma disjoint.zpow_disjoint_zpow {σ τ : perm α} (hστ : disjoint σ τ) (m n : ℤ) :
  disjoint (σ ^ m) (τ ^ n) :=
λ x, or.imp (λ h, zpow_apply_eq_self_of_apply_eq_self h m)
  (λ h, zpow_apply_eq_self_of_apply_eq_self h n) (hστ x)

lemma disjoint.pow_disjoint_pow {σ τ : perm α} (hστ : disjoint σ τ) (m n : ℕ) :
  disjoint (σ ^ m) (τ ^ n) :=
hστ.zpow_disjoint_zpow m n

end disjoint

section is_swap

variable [decidable_eq α]

/-- `f.is_swap` indicates that the permutation `f` is a transposition of two elements. -/
def is_swap (f : perm α) : Prop := ∃ x y, x ≠ y ∧ f = swap x y

lemma is_swap.of_subtype_is_swap {p : α → Prop} [decidable_pred p]
  {f : perm (subtype p)} (h : f.is_swap) : (of_subtype f).is_swap :=
let ⟨⟨x, hx⟩, ⟨y, hy⟩, hxy⟩ := h in
⟨x, y, by { simp only [ne.def] at hxy, exact hxy.1 },
  equiv.ext $ λ z, begin
    rw [hxy.2, of_subtype],
    simp only [swap_apply_def, coe_fn_mk, swap_inv, subtype.mk_eq_mk, monoid_hom.coe_mk],
    split_ifs;
    rw subtype.coe_mk <|> cc,
  end⟩

lemma ne_and_ne_of_swap_mul_apply_ne_self {f : perm α} {x y : α}
  (hy : (swap x (f x) * f) y ≠ y) : f y ≠ y ∧ y ≠ x :=
begin
  simp only [swap_apply_def, mul_apply, f.injective.eq_iff] at *,
  by_cases h : f y = x,
  { split; intro; simp only [*, if_true, eq_self_iff_true, not_true, ne.def] at * },
  { split_ifs at hy; cc }
end

end is_swap

section support

section set

variables (p q : perm α)

lemma set_support_inv_eq :
  {x | p⁻¹ x ≠ x} = {x | p x ≠ x} :=
begin
  ext x,
  simp only [set.mem_set_of_eq, ne.def],
  rw [inv_def, symm_apply_eq, eq_comm]
end

lemma set_support_apply_mem {p : perm α} {a : α} :
  p a ∈ {x | p x ≠ x} ↔ a ∈ {x | p x ≠ x} :=
by simp

lemma set_support_zpow_subset (n : ℤ) :
  {x | (p ^ n) x ≠ x} ⊆ {x | p x ≠ x} :=
begin
  intros x,
  simp only [set.mem_set_of_eq, ne.def],
  intros hx H,
  simpa [zpow_apply_eq_self_of_apply_eq_self H] using hx
end

lemma set_support_mul_subset :
  {x | (p * q) x ≠ x} ⊆ {x | p x ≠ x} ∪ {x | q x ≠ x} :=
begin
  intro x,
  simp only [perm.coe_mul, function.comp_app, ne.def, set.mem_union_eq, set.mem_set_of_eq],
  by_cases hq : q x = x;
  simp [hq]
end

end set

variables [decidable_eq α] [fintype α] {f g : perm α}

/-- The `finset` of nonfixed points of a permutation. -/
def support (f : perm α) : finset α := univ.filter (λ x, f x ≠ x)

@[simp] lemma mem_support {x : α} : x ∈ f.support ↔ f x ≠ x :=
by rw [support, mem_filter, and_iff_right (mem_univ x)]

lemma not_mem_support {x : α} : x ∉ f.support ↔ f x = x := by simp

lemma coe_support_eq_set_support (f : perm α) :
  (f.support : set α) = {x | f x ≠ x} :=
by { ext, simp }

@[simp] lemma support_eq_empty_iff {σ : perm α} : σ.support = ∅ ↔ σ = 1 :=
by simp_rw [finset.ext_iff, mem_support, finset.not_mem_empty, iff_false, not_not,
  equiv.perm.ext_iff, one_apply]

@[simp] lemma support_one : (1 : perm α).support = ∅ :=
by rw support_eq_empty_iff

@[simp] lemma support_refl : support (equiv.refl α) = ∅ := support_one

lemma support_congr (h : f.support ⊆ g.support)
  (h' : ∀ x ∈ g.support, f x = g x) : f = g :=
begin
  ext x,
  by_cases hx : x ∈ g.support,
  { exact h' x hx },
  { rw [not_mem_support.mp hx, ←not_mem_support],
    exact λ H, hx (h H) }
end

lemma support_mul_le (f g : perm α) :
  (f * g).support ≤ f.support ⊔ g.support :=
λ x, begin
  rw [sup_eq_union, mem_union, mem_support, mem_support,
    mem_support, mul_apply, ←not_and_distrib, not_imp_not],
  rintro ⟨hf, hg⟩,
  rw [hg, hf]
end

lemma exists_mem_support_of_mem_support_prod {l : list (perm α)} {x : α}
  (hx : x ∈ l.prod.support) :
  ∃ f : perm α, f ∈ l ∧ x ∈ f.support :=
begin
  contrapose! hx,
  simp_rw [mem_support, not_not] at hx ⊢,
  induction l with f l ih generalizing hx,
  { refl },
  { rw [list.prod_cons, mul_apply, ih (λ g hg, hx g (or.inr hg)), hx f (or.inl rfl)] },
end

lemma support_pow_le (σ : perm α) (n : ℕ) :
  (σ ^ n).support ≤ σ.support :=
λ x h1, mem_support.mpr (λ h2, mem_support.mp h1 (pow_apply_eq_self_of_apply_eq_self h2 n))

@[simp] lemma support_inv (σ : perm α) : support (σ⁻¹) = σ.support :=
by simp_rw [finset.ext_iff, mem_support, not_iff_not,
  (inv_eq_iff_eq).trans eq_comm, iff_self, imp_true_iff]

@[simp]
lemma apply_mem_support {x : α} :
  f x ∈ f.support ↔ x ∈ f.support :=
by rw [mem_support, mem_support, ne.def, ne.def, not_iff_not, apply_eq_iff_eq]

@[simp]
lemma pow_apply_mem_support {n : ℕ} {x : α} :
  (f ^ n) x ∈ f.support ↔ x ∈ f.support :=
begin
  induction n with n ih,
  { refl },
  rw [pow_succ, perm.mul_apply, apply_mem_support, ih]
end

@[simp]
lemma zpow_apply_mem_support {n : ℤ} {x : α} :
  (f ^ n) x ∈ f.support ↔ x ∈ f.support :=
begin
  cases n,
  { rw [int.of_nat_eq_coe, zpow_coe_nat, pow_apply_mem_support] },
  { rw [zpow_neg_succ_of_nat, ← support_inv, ← inv_pow, pow_apply_mem_support] }
end

lemma pow_eq_on_of_mem_support (h : ∀ (x ∈ f.support ∩ g.support), f x = g x)
  (k : ℕ) : ∀ (x ∈ f.support ∩ g.support), (f ^ k) x = (g ^ k) x :=
begin
  induction k with k hk,
  { simp },
  { intros x hx,
    rw [pow_succ', mul_apply, pow_succ', mul_apply, h _ hx, hk],
    rwa [mem_inter, apply_mem_support, ←h _ hx, apply_mem_support, ←mem_inter] }
end

lemma disjoint_iff_disjoint_support :
  disjoint f g ↔ _root_.disjoint f.support g.support :=
by simp [disjoint_iff_eq_or_eq, disjoint_iff, finset.ext_iff, not_and_distrib]

lemma disjoint.disjoint_support (h : disjoint f g) :
  _root_.disjoint f.support g.support :=
disjoint_iff_disjoint_support.1 h

lemma disjoint.support_mul (h : disjoint f g) :
  (f * g).support = f.support ∪ g.support :=
begin
  refine le_antisymm (support_mul_le _ _) (λ a, _),
  rw [mem_union, mem_support, mem_support, mem_support, mul_apply, ←not_and_distrib, not_imp_not],
  exact (h a).elim (λ hf h, ⟨hf, f.apply_eq_iff_eq.mp (h.trans hf.symm)⟩)
    (λ hg h, ⟨(congr_arg f hg).symm.trans h, hg⟩),
end

lemma support_prod_of_pairwise_disjoint (l : list (perm α)) (h : l.pairwise disjoint) :
  l.prod.support = (l.map support).foldr (⊔) ⊥ :=
begin
  induction l with hd tl hl,
  { simp },
  { rw [list.pairwise_cons] at h,
    have : disjoint hd tl.prod := disjoint_prod_right _ h.left,
    simp [this.support_mul, hl h.right] }
end

lemma support_prod_le (l : list (perm α)) :
  l.prod.support ≤ (l.map support).foldr (⊔) ⊥ :=
begin
  induction l with hd tl hl,
  { simp },
  { rw [list.prod_cons, list.map_cons, list.foldr_cons],
    refine (support_mul_le hd tl.prod).trans _,
    exact sup_le_sup (le_refl _) hl }
end

lemma support_zpow_le (σ : perm α) (n : ℤ) :
  (σ ^ n).support ≤ σ.support :=
λ x h1, mem_support.mpr (λ h2, mem_support.mp h1 (zpow_apply_eq_self_of_apply_eq_self h2 n))

@[simp] lemma support_swap {x y : α} (h : x ≠ y) : support (swap x y) = {x, y} :=
begin
  ext z,
  by_cases hx : z = x,
  any_goals { simpa [hx] using h.symm },
  by_cases hy : z = y;
  { simp [swap_apply_of_ne_of_ne, hx, hy]; cc }
end

lemma support_swap_iff (x y : α) :
  support (swap x y) = {x, y} ↔ x ≠ y :=
begin
  refine ⟨λ h H, _, support_swap⟩,
  subst H,
  simp only [swap_self, support_refl, insert_singleton_self_eq] at h,
  have : x ∈ ∅,
  { rw h,
    exact mem_singleton.mpr rfl },
  simpa
end

lemma support_swap_mul_swap {x y z : α} (h : list.nodup [x, y, z]) :
  support (swap x y * swap y z) = {x, y, z} :=
begin
  simp only [list.not_mem_nil, and_true, list.mem_cons_iff, not_false_iff, list.nodup_cons,
             list.mem_singleton, and_self, list.nodup_nil] at h,
  push_neg at h,
  apply le_antisymm,
  { convert support_mul_le _ _,
    rw [support_swap h.left.left, support_swap h.right],
    ext,
    simp [or.comm, or.left_comm] },
  { intro,
    simp only [mem_insert, mem_singleton],
    rintro (rfl | rfl | rfl | _);
    simp [swap_apply_of_ne_of_ne, h.left.left, h.left.left.symm, h.left.right, h.left.right.symm,
          h.right.symm] }
end

lemma support_swap_mul_ge_support_diff (f : perm α) (x y : α) :
  f.support \ {x, y} ≤ (swap x y * f).support :=
begin
  intro,
  simp only [and_imp, perm.coe_mul, function.comp_app, ne.def, mem_support, mem_insert, mem_sdiff,
             mem_singleton],
  push_neg,
  rintro ha ⟨hx, hy⟩ H,
  rw [swap_apply_eq_iff, swap_apply_of_ne_of_ne hx hy] at H,
  exact ha H
end

lemma support_swap_mul_eq (f : perm α) (x : α) (h : f (f x) ≠ x) :
  (swap x (f x) * f).support = f.support \ {x} :=
begin
  by_cases hx : f x = x,
  { simp [hx, sdiff_singleton_eq_erase, not_mem_support.mpr hx, erase_eq_of_not_mem] },
  ext z,
  by_cases hzx : z = x,
  { simp [hzx] },
  by_cases hzf : z = f x,
  { simp [hzf, hx, h, swap_apply_of_ne_of_ne], },
  by_cases hzfx : f z = x,
  { simp [ne.symm hzx, hzx, ne.symm hzf, hzfx] },
  { simp [ne.symm hzx, hzx, ne.symm hzf, hzfx, f.injective.ne hzx, swap_apply_of_ne_of_ne] }
end

lemma mem_support_swap_mul_imp_mem_support_ne {x y : α}
  (hy : y ∈ support (swap x (f x) * f)) : y ∈ support f ∧ y ≠ x :=
begin
  simp only [mem_support, swap_apply_def, mul_apply, f.injective.eq_iff] at *,
  by_cases h : f y = x,
  { split; intro; simp only [*, if_true, eq_self_iff_true, not_true, ne.def] at * },
  { split_ifs at hy; cc }
end

lemma disjoint.mem_imp (h : disjoint f g) {x : α} (hx : x ∈ f.support) :
  x ∉ g.support :=
λ H, h.disjoint_support (mem_inter_of_mem hx H)

lemma eq_on_support_mem_disjoint {l : list (perm α)} (h : f ∈ l) (hl : l.pairwise disjoint) :
  ∀ (x ∈ f.support), f x = l.prod x :=
begin
  induction l with hd tl IH,
  { simpa using h },
  { intros x hx,
    rw list.pairwise_cons at hl,
    rw list.mem_cons_iff at h,
    rcases h with rfl|h,
    { rw [list.prod_cons, mul_apply, not_mem_support.mp
          ((disjoint_prod_right tl hl.left).mem_imp hx)] },
    { rw [list.prod_cons, mul_apply, ←IH h hl.right _ hx, eq_comm, ←not_mem_support],
      refine (hl.left _ h).symm.mem_imp _,
      simpa using hx } }
end

lemma disjoint.mono {x y : perm α} (h : disjoint f g)
  (hf : x.support ≤ f.support) (hg : y.support ≤ g.support) :
  disjoint x y :=
begin
  rw disjoint_iff_disjoint_support at h ⊢,
  intros a ha,
  exact h (mem_inter_of_mem (hf (mem_of_mem_inter_left ha)) (hg (mem_of_mem_inter_right ha)))
end

lemma support_le_prod_of_mem {l : list (perm α)} (h : f ∈ l) (hl : l.pairwise disjoint) :
  f.support ≤ l.prod.support :=
begin
  intros x hx,
  rwa [mem_support, ←eq_on_support_mem_disjoint h hl _ hx, ←mem_support],
end

section extend_domain
variables {β : Type*} [decidable_eq β] [fintype β] {p : β → Prop} [decidable_pred p]

@[simp]
lemma support_extend_domain (f : α ≃ subtype p) {g : perm α} :
  support (g.extend_domain f) = g.support.map f.as_embedding :=
begin
  ext b,
  simp only [exists_prop, function.embedding.coe_fn_mk, to_embedding_apply, mem_map, ne.def,
    function.embedding.trans_apply, mem_support],
  by_cases pb : p b,
  { rw [extend_domain_apply_subtype _ _ pb],
    split,
    { rintro h,
      refine ⟨f.symm ⟨b, pb⟩, _, by simp⟩,
      contrapose! h,
      simp [h] },
    { rintro ⟨a, ha, hb⟩,
      contrapose! ha,
      obtain rfl : a = f.symm ⟨b, pb⟩,
      { rw eq_symm_apply,
        exact subtype.coe_injective hb },
      rw eq_symm_apply,
      exact subtype.coe_injective ha } },
  { rw [extend_domain_apply_not_subtype _ _ pb],
    simp only [not_exists, false_iff, not_and, eq_self_iff_true, not_true],
    rintros a ha rfl,
    exact pb (subtype.prop _) }
end

lemma card_support_extend_domain (f : α ≃ subtype p) {g : perm α} :
  (g.extend_domain f).support.card = g.support.card :=
by simp

end extend_domain

section card

@[simp]
lemma card_support_eq_zero {f : perm α} :
  f.support.card = 0 ↔ f = 1 :=
by rw [finset.card_eq_zero, support_eq_empty_iff]

lemma one_lt_card_support_of_ne_one {f : perm α} (h : f ≠ 1) :
  1 < f.support.card :=
begin
  simp_rw [one_lt_card_iff, mem_support, ←not_or_distrib],
  contrapose! h,
  ext a,
  specialize h (f a) a,
  rwa [apply_eq_iff_eq, or_self, or_self] at h,
end

lemma card_support_ne_one (f : perm α) : f.support.card ≠ 1 :=
begin
  by_cases h : f = 1,
  { exact ne_of_eq_of_ne (card_support_eq_zero.mpr h) zero_ne_one },
  { exact ne_of_gt (one_lt_card_support_of_ne_one h) },
end

@[simp] lemma card_support_le_one {f : perm α} : f.support.card ≤ 1 ↔ f = 1 :=
by rw [le_iff_lt_or_eq, nat.lt_succ_iff, nat.le_zero_iff, card_support_eq_zero,
  or_iff_not_imp_right, imp_iff_right f.card_support_ne_one]

lemma two_le_card_support_of_ne_one {f : perm α} (h : f ≠ 1) :
  2 ≤ f.support.card :=
one_lt_card_support_of_ne_one h

lemma card_support_swap_mul {f : perm α} {x : α}
  (hx : f x ≠ x) : (swap x (f x) * f).support.card < f.support.card :=
finset.card_lt_card
  ⟨λ z hz, (mem_support_swap_mul_imp_mem_support_ne hz).left,
    λ h, absurd (h (mem_support.2 hx)) (mt mem_support.1 (by simp))⟩

lemma card_support_swap {x y : α} (hxy : x ≠ y) : (swap x y).support.card = 2 :=
show (swap x y).support.card = finset.card ⟨x ::ₘ y ::ₘ 0, by simp [hxy]⟩,
from congr_arg card $ by simp [support_swap hxy, *, finset.ext_iff]

@[simp]
lemma card_support_eq_two {f : perm α} : f.support.card = 2 ↔ is_swap f :=
begin
  split; intro h,
  { obtain ⟨x, t, hmem, hins, ht⟩ := card_eq_succ.1 h,
    obtain ⟨y, rfl⟩ := card_eq_one.1 ht,
    rw mem_singleton at hmem,
    refine ⟨x, y, hmem, _⟩,
    ext a,
    have key : ∀ b, f b ≠ b ↔ _ := λ b, by rw [←mem_support, ←hins, mem_insert, mem_singleton],
    by_cases ha : f a = a,
    { have ha' := not_or_distrib.mp (mt (key a).mpr (not_not.mpr ha)),
      rw [ha, swap_apply_of_ne_of_ne ha'.1 ha'.2] },
    { have ha' := (key (f a)).mp (mt f.apply_eq_iff_eq.mp ha),
      obtain rfl | rfl := ((key a).mp ha),
      { rw [or.resolve_left ha' ha, swap_apply_left] },
      { rw [or.resolve_right ha' ha, swap_apply_right] } } },
  { obtain ⟨x, y, hxy, rfl⟩ := h,
    exact card_support_swap hxy }
end

lemma disjoint.card_support_mul (h : disjoint f g) :
  (f * g).support.card = f.support.card + g.support.card :=
begin
  rw ←finset.card_disjoint_union,
  { congr,
    ext,
    simp [h.support_mul] },
  { simpa using h.disjoint_support }
end

lemma card_support_prod_list_of_pairwise_disjoint {l : list (perm α)}
  (h : l.pairwise disjoint) :
  l.prod.support.card = (l.map (finset.card ∘ support)).sum :=
begin
  induction l with a t ih,
  { exact card_support_eq_zero.mpr rfl, },
  { obtain ⟨ha, ht⟩ := list.pairwise_cons.1 h,
    rw [list.prod_cons, list.map_cons, list.sum_cons, ←ih ht],
    exact (disjoint_prod_right _ ha).card_support_mul }
end

end card

end support

end equiv.perm


import data.list
import tactic
import data.finset

theorem sublist_take_mp_sublist
{X : Type*}
(A S: list X)
(n : ℕ)
(h: S <+ A.take n)
: S <+ A
:= list.sublist.trans h (list.sublist_of_prefix (A.take_prefix n))

theorem nth_le_mem_take_succ
{X : Type*}
(A : list X)
(n : ℕ)
(h : n < A.length)
: A.nth_le n h ∈ A.take n.succ
:= begin
  rw list.nth_le_take A h (lt_add_one n),
  exact list.nth_le_mem (list.take n.succ A) n _,
end

theorem sublist_concat_is_sublist {X : Type*} {l1 l2 : list X} {e : X} (n : ℕ)
  (h_sub : l1 <+ l2.take n) (h_in : e ∈ l2.drop n)
: l1.concat e <+ l2 :=
begin
  rw [list.concat_eq_append, ←list.take_append_drop n l2],
  exact list.sublist.append h_sub (list.singleton_sublist.mpr h_in),
end

theorem sublist_of_take_concat_sublist_of_take
{X : Type*}
{A B: list X}
{n₁ n₂ : ℕ}
(h₁ : n₂ < A.length)
(h₂ : n₁ ≤ n₂)
(h₃ : B <+ A.take n₁)
: B.concat (A.nth_le n₂ h₁) <+ A.take n₂.succ := begin
  have le_add_of_sub_eq_id : ∀ {a b : ℕ} (h : a ≤ b), a + (b - a) = b           := by omega,
  have succ_bring_in2 :      ∀ {a b : ℕ} (h : a ≤ b), (b + 1) - a = (b - a) + 1 := by omega,
  have le_comp : n₁ + (n₂ - n₁) < A.length,
  { rw le_add_of_sub_eq_id h₂, exact h₁, },
  have comp_nth_le : A.nth_le n₂ h₁ = A.nth_le (n₁ + (n₂ - n₁)) le_comp,
  { congr, exact (le_add_of_sub_eq_id h₂).symm, },
  apply sublist_concat_is_sublist n₁,
  { rw [list.take_take, min_eq_left (le_trans h₂ (nat.le_succ n₂))],
    exact h₃, },
  { rw [←(le_add_of_sub_eq_id (le_trans h₂ (nat.le_succ n₂))), list.drop_take n₁, comp_nth_le, list.nth_le_drop, succ_bring_in2 h₂],
    exact nth_le_mem_take_succ (A.drop n₁) (n₂ - n₁) _, }
end

theorem list_chain_concat
{X : Type*}
{R : X → X → Prop}
{l : list X}
(a : X)
(h1 : list.chain' R l)
(h2 : ∀ (x : X), x ∈ l.last' → R x a)
: list.chain' R (l.concat a)
:= begin
  rw list.concat_eq_append,
  apply list.chain'.append h1 (list.chain'_singleton a),
  intros _ x_in _ y_in,
  rw option.mem_unique y_in rfl,
  exact h2 x x_in,
end

theorem pair_from_pairwise_to_pair_from_map
{X Y: Type*}
{A : list X}
{f : X → Y}
{r1 : X → X → Prop} [ant : anti_symmetric r1]
{r2 : Y → Y → Prop} [rfx : reflexive r2]
(h1 : A.pairwise r1)
(h2 : (A.map f).pairwise r2)
{x y : X}
(h3 : x ∈ A)
(h4 : y ∈ A)
(h5 : r1 x y)
: r2 (f x) (f y)
:= begin
  induction A,
  { finish },
  { have A_tl_pair     := list.pairwise_of_pairwise_cons h1,
    have A_tl_map_pair := list.pairwise_of_pairwise_cons h2,
    have hypp := A_ih A_tl_pair A_tl_map_pair,
    cases h3,
    { cases h4,
      { rw [h3, h4],
        exact rfx (f A_hd), },
      { rw list.map_cons at h2,
        rw h3,
        exact list.rel_of_pairwise_cons h2 (list.mem_map_of_mem f h4), } },
    { cases h4,
      { have thinger := list.rel_of_pairwise_cons h1 h3,
        rw ←h4 at thinger,
        rw ant h5 thinger,
        exact rfx (f y), },
      { exact hypp h3 h4, } }, }
end

theorem prod_ne_iff_right_or_left_ne
{X Y : Type*}
(a b : X × Y)
: a.1 ≠ b.1 ∨ a.2 ≠ b.2 ↔ a ≠ b
:= begin
  cases a, cases b,
  simpa [not_and, prod.mk.inj_iff, ne.def] using imp_iff_not_or.symm,
end

theorem nat_mul_sub_right_lt
{a b : ℕ}
(h1 : a ≠ 0)
(h2 : b ≠ 0)
: a*(b-1) < a*b
:= (mul_lt_mul_left (pos_iff_ne_zero.mpr h1)).mpr (nat.pred_lt h2)

theorem nat_mul_sub_left_lt
{a b : ℕ}
(h1 : a ≠ 0)
(h2 : b ≠ 0)
: (a-1)*b < a*b
:= (mul_lt_mul_right (pos_iff_ne_zero.mpr h2)).mpr (nat.pred_lt h1)

theorem nat_mul_sub_left_le
(a b : ℕ)
: (a-1)*b ≤ a*b
:= begin
  by_cases h : 0 < b,
  { exact (mul_le_mul_right h).mpr (nat.sub_le a 1), },
  { rw [not_lt, nonpos_iff_eq_zero] at h,
    rw [h, mul_zero, mul_zero], }
end

theorem cons_sub_not_eq
{X : Type*}
{A B : list X}
{a b : X}
(h1 : a ≠ b)
(h2 : a :: A <+ b :: B)
: a :: A <+ B
:= begin
  cases h2 with _ _ _ e _ _ _ _,
  { exact e },
  { exact absurd rfl h1 },
end

theorem drop_while_imp_mem
{X: Type*} [decidable_eq X]
(A : list X)
(f : X → Prop) [decidable_pred f]
: A.drop_while f = A.drop_while (λ x, x ∈ A → f x)
:= begin
  induction A,
  { exact rfl, },
  { dsimp [list.drop_while],
    have thing : (A_hd ∈ (A_hd :: A_tl) → f A_hd) = f A_hd, by simp,
    have step2 : ∀ x, (x ∈ A_hd :: A_tl → f x) = ((x = A_hd ∨ x ∈ A_tl) → f x),
    { tauto, },
    simp only [thing],
    simp only [step2],

    split_ifs,
    { rw A_ih,
      congr,
      ext,
      split,
      { intros dkdkkd huehue,
        cases huehue,
        { rw ←huehue at h,
          exact h, },
        { exact dkdkkd huehue, }, },
      { intros juju x_inn,
        exact juju (or.inr x_inn), }, },
    { exact ⟨rfl, rfl⟩, } },
end

theorem sublist_map_exists
{X Y : Type*}
{A : list X}
{B : list Y}
{f : X → Y}
(h : B <+ A.map f)
: ∃ C, C <+ A ∧ C.map f = B
:= begin
  induction A generalizing B,
  { refine ⟨list.nil, list.nil.nil_sublist, _⟩,
    rw list.eq_nil_of_sublist_nil h,
    exact rfl, },
  { rw list.map_cons at h,
    by_cases hhh : B = list.nil,
    { rw hhh,
      exact ⟨list.nil, (A_hd :: A_tl).nil_sublist, rfl⟩, },
    { obtain ⟨b, B', hhh2⟩ := list.exists_cons_of_ne_nil hhh,
      rw hhh2 at *,
      by_cases heads_eq : b = f A_hd,
      { rw [heads_eq] at h,
        obtain ⟨C',C'_le,C'_map⟩ := A_ih (list.cons_sublist_cons_iff.mp h),
        refine ⟨A_hd :: C',_,_⟩,
        exact list.cons_sublist_cons_iff.mpr C'_le,
        rw [list.map_cons, C'_map, heads_eq], },
      { obtain ⟨C,C_le,C_map⟩ := A_ih (cons_sub_not_eq heads_eq h),
        exact ⟨C, list.sublist.cons C A_tl A_hd C_le, C_map⟩, }, } }
end

@[simp]
theorem take_while_false_mem
{X : Type*}
{A : list X}
(f : X → Prop) [decidable_pred f]
(h: ∀ x ∈ A, ¬(f x))
: list.take_while f A = list.nil
:= begin
  induction A,
  { exact rfl },
  { dsimp [list.take_while],
    rw [A_ih _, if_neg (h A_hd (list.mem_cons_self A_hd A_tl))],
    finish, }
end

@[simp]
theorem drop_while_false_mem
{X : Type*}
{A : list X}
(f : X → Prop) [decidable_pred f]
(h: ∀ x ∈ A, ¬(f x))
: list.drop_while f A = A
:= begin
  nth_rewrite 1 ←(list.take_while_append_drop f A),
  rw [take_while_false_mem f h, list.nil_append],
end

theorem finset_sort_idempotent
{X: Type*} [linear_order X]
{A : list X}
(h1 : A.sorted (≤))
(h2 : A.nodup)
: A.to_finset.sort (≤) = A
:= begin
  induction A,
  tauto,
  dsimp [finset.sort],
  have rw_nodup := list.erase_dup_eq_self.mpr h2,
  rw [  rw_nodup, list.merge_sort_eq_insertion_sort,
        list.insertion_sort_cons_eq_take_drop,
        list.sorted.insertion_sort_eq (list.sorted_of_sorted_cons h1)],
  dsimp [list.sorted] at h1,
  have drop_simple : list.drop_while (λ b, ¬A_hd ≤ b) A_tl = A_tl,
  { apply drop_while_false_mem _ _,
    intros _ aa_mem,
    rw not_not,
    exact list.rel_of_pairwise_cons h1 aa_mem, },
  have take_simple: list.take_while (λ b, ¬A_hd ≤ b) A_tl = [],
  { apply @list.append_right_cancel _ _ _(list.drop_while (λ (b : X), ¬A_hd ≤ b) A_tl),
    rw [list.take_while_append_drop _ A_tl, drop_simple, list.nil_append], },
  rw [take_simple, drop_simple, list.nil_append],
end


/-
Copyright (c) 2022 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp
-/
import analysis.inner_product_space.pi_L2

/-! # Hermitian matrices

This file defines hermitian matrices and some basic results about them.

See also `is_self_adjoint`, which generalizes this definition to other star rings.

## Main definition

 * `matrix.is_hermitian` : a matrix `A : matrix n n α` is hermitian if `Aᴴ = A`.

## Tags

self-adjoint matrix, hermitian matrix

-/

namespace matrix

variables {α β : Type*} {m n : Type*} {A : matrix n n α}

open_locale matrix

local notation `⟪`x`, `y`⟫` := @inner α _ _ x y

section has_star
variables [has_star α] [has_star β]

/-- A matrix is hermitian if it is equal to its conjugate transpose. On the reals, this definition
captures symmetric matrices. -/
def is_hermitian (A : matrix n n α) : Prop := Aᴴ = A

lemma is_hermitian.eq {A : matrix n n α} (h : A.is_hermitian) : Aᴴ = A := h

protected lemma is_hermitian.is_self_adjoint {A : matrix n n α} (h : A.is_hermitian) :
  is_self_adjoint A := h

@[ext]
lemma is_hermitian.ext {A : matrix n n α} : (∀ i j, star (A j i) = A i j) → A.is_hermitian :=
by { intros h, ext i j, exact h i j }

lemma is_hermitian.apply {A : matrix n n α} (h : A.is_hermitian) (i j : n) : star (A j i) = A i j :=
congr_fun (congr_fun h _) _

lemma is_hermitian.ext_iff {A : matrix n n α} : A.is_hermitian ↔ ∀ i j, star (A j i) = A i j :=
⟨is_hermitian.apply, is_hermitian.ext⟩

@[simp] lemma is_hermitian.map {A : matrix n n α} (h : A.is_hermitian) (f : α → β)
  (hf : function.semiconj f star star) :
  (A.map f).is_hermitian :=
(conj_transpose_map f hf).symm.trans $ h.eq.symm ▸ rfl

lemma is_hermitian.transpose {A : matrix n n α} (h : A.is_hermitian) :
  Aᵀ.is_hermitian :=
by { rw [is_hermitian, conj_transpose, transpose_map], congr, exact h }

@[simp] lemma is_hermitian_transpose_iff (A : matrix n n α) :
  Aᵀ.is_hermitian ↔ A.is_hermitian :=
⟨by { intro h, rw [← transpose_transpose A], exact is_hermitian.transpose h },
  is_hermitian.transpose⟩

lemma is_hermitian.conj_transpose {A : matrix n n α} (h : A.is_hermitian) :
  Aᴴ.is_hermitian :=
h.transpose.map _ $ λ _, rfl

@[simp] lemma is_hermitian.submatrix {A : matrix n n α} (h : A.is_hermitian) (f : m → n) :
  (A.submatrix f f).is_hermitian :=
(conj_transpose_submatrix _ _ _).trans (h.symm ▸ rfl)

@[simp] lemma is_hermitian_submatrix_equiv {A : matrix n n α} (e : m ≃ n) :
  (A.submatrix e e).is_hermitian ↔ A.is_hermitian :=
⟨λ h, by simpa using h.submatrix e.symm, λ h, h.submatrix _⟩

end has_star

section has_involutive_star
variables [has_involutive_star α]

@[simp] lemma is_hermitian_conj_transpose_iff (A : matrix n n α) :
  Aᴴ.is_hermitian ↔ A.is_hermitian :=
is_self_adjoint.star_iff

/-- A block matrix `A.from_blocks B C D` is hermitian,
    if `A` and `D` are hermitian and `Bᴴ = C`. -/
lemma is_hermitian.from_blocks
  {A : matrix m m α} {B : matrix m n α} {C : matrix n m α} {D : matrix n n α}
  (hA : A.is_hermitian) (hBC : Bᴴ = C) (hD : D.is_hermitian) :
  (A.from_blocks B C D).is_hermitian :=
begin
  have hCB : Cᴴ = B,
  { rw [← hBC, conj_transpose_conj_transpose] },
  unfold matrix.is_hermitian,
  rw from_blocks_conj_transpose,
  congr;
  assumption
end

/-- This is the `iff` version of `matrix.is_hermitian.from_blocks`. -/
lemma is_hermitian_from_blocks_iff
  {A : matrix m m α} {B : matrix m n α} {C : matrix n m α} {D : matrix n n α} :
  (A.from_blocks B C D).is_hermitian ↔ A.is_hermitian ∧ Bᴴ = C ∧ Cᴴ = B ∧ D.is_hermitian :=
⟨λ h, ⟨congr_arg to_blocks₁₁ h, congr_arg to_blocks₂₁ h,
       congr_arg to_blocks₁₂ h, congr_arg to_blocks₂₂ h⟩,
 λ ⟨hA, hBC, hCB, hD⟩, is_hermitian.from_blocks hA hBC hD⟩

end has_involutive_star

section add_monoid
variables [add_monoid α] [star_add_monoid α] [add_monoid β] [star_add_monoid β]

/-- A diagonal matrix is hermitian if the entries are self-adjoint -/
lemma is_hermitian_diagonal_of_self_adjoint [decidable_eq n]
  (v : n → α) (h : is_self_adjoint v) :
  (diagonal v).is_hermitian :=
-- TODO: add a `pi.has_trivial_star` instance and remove the `funext`
(diagonal_conj_transpose v).trans $ congr_arg _ h

/-- A diagonal matrix is hermitian if the entries have the trivial `star` operation
(such as on the reals). -/
@[simp] lemma is_hermitian_diagonal [has_trivial_star α] [decidable_eq n] (v : n → α) :
  (diagonal v).is_hermitian :=
is_hermitian_diagonal_of_self_adjoint _ (is_self_adjoint.all _)

@[simp] lemma is_hermitian_zero :
  (0 : matrix n n α).is_hermitian :=
is_self_adjoint_zero _

@[simp] lemma is_hermitian.add {A B : matrix n n α} (hA : A.is_hermitian) (hB : B.is_hermitian) :
  (A + B).is_hermitian :=
is_self_adjoint.add hA hB

end add_monoid

section add_comm_monoid
variables [add_comm_monoid α] [star_add_monoid α]

lemma is_hermitian_add_transpose_self (A : matrix n n α) :
  (A + Aᴴ).is_hermitian :=
is_self_adjoint_add_star_self A

lemma is_hermitian_transpose_add_self (A : matrix n n α) :
  (Aᴴ + A).is_hermitian :=
is_self_adjoint_star_add_self A

end add_comm_monoid

section add_group
variables [add_group α] [star_add_monoid α]

@[simp] lemma is_hermitian.neg {A : matrix n n α} (h : A.is_hermitian) :
  (-A).is_hermitian :=
is_self_adjoint.neg h

@[simp] lemma is_hermitian.sub {A B : matrix n n α} (hA : A.is_hermitian) (hB : B.is_hermitian) :
  (A - B).is_hermitian :=
is_self_adjoint.sub hA hB

end add_group

section non_unital_semiring
variables [non_unital_semiring α] [star_ring α] [non_unital_semiring β] [star_ring β]

/-- Note this is more general than `is_self_adjoint.mul_star_self` as `B` can be rectangular. -/
lemma is_hermitian_mul_conj_transpose_self [fintype n] (A : matrix m n α) :
  (A ⬝ Aᴴ).is_hermitian :=
by rw [is_hermitian, conj_transpose_mul, conj_transpose_conj_transpose]

/-- Note this is more general than `is_self_adjoint.star_mul_self` as `B` can be rectangular. -/
lemma is_hermitian_transpose_mul_self [fintype m] (A : matrix m n α) :
  (Aᴴ ⬝ A).is_hermitian :=
by rw [is_hermitian, conj_transpose_mul, conj_transpose_conj_transpose]

/-- Note this is more general than `is_self_adjoint.conjugate'` as `B` can be rectangular. -/
lemma is_hermitian_conj_transpose_mul_mul [fintype m] {A : matrix m m α} (B : matrix m n α)
  (hA : A.is_hermitian) : (Bᴴ ⬝ A ⬝ B).is_hermitian :=
by simp only [is_hermitian, conj_transpose_mul, conj_transpose_conj_transpose, hA.eq,
  matrix.mul_assoc]

/-- Note this is more general than `is_self_adjoint.conjugate` as `B` can be rectangular. -/
lemma is_hermitian_mul_mul_conj_transpose [fintype m] {A : matrix m m α} (B : matrix n m α)
  (hA : A.is_hermitian) : (B ⬝ A ⬝ Bᴴ).is_hermitian :=
by simp only [is_hermitian, conj_transpose_mul, conj_transpose_conj_transpose, hA.eq,
  matrix.mul_assoc]

end non_unital_semiring

section semiring

variables [semiring α] [star_ring α] [semiring β] [star_ring β]

/-- Note this is more general for matrices than `is_self_adjoint_one` as it does not
require `fintype n`, which is necessary for `monoid (matrix n n R)`. -/
@[simp] lemma is_hermitian_one [decidable_eq n] :
  (1 : matrix n n α).is_hermitian :=
conj_transpose_one

end semiring

section comm_ring
variables [comm_ring α] [star_ring α]

lemma is_hermitian.inv [fintype m] [decidable_eq m] {A : matrix m m α}
  (hA : A.is_hermitian) : A⁻¹.is_hermitian :=
by simp [is_hermitian, conj_transpose_nonsing_inv, hA.eq]

@[simp] lemma is_hermitian_inv [fintype m] [decidable_eq m] (A : matrix m m α) [invertible A]:
  (A⁻¹).is_hermitian ↔ A.is_hermitian :=
⟨λ h, by {rw [← inv_inv_of_invertible A], exact is_hermitian.inv h }, is_hermitian.inv⟩

lemma is_hermitian.adjugate [fintype m] [decidable_eq m] {A : matrix m m α}
  (hA : A.is_hermitian) : A.adjugate.is_hermitian :=
by simp [is_hermitian, adjugate_conj_transpose, hA.eq]

end comm_ring

section is_R_or_C
open is_R_or_C

variables [is_R_or_C α] [is_R_or_C β]

/-- The diagonal elements of a complex hermitian matrix are real. -/
lemma is_hermitian.coe_re_apply_self {A : matrix n n α} (h : A.is_hermitian) (i : n) :
  (re (A i i) : α) = A i i :=
by rw [←eq_conj_iff_re, ←star_def, ←conj_transpose_apply, h.eq]

/-- The diagonal elements of a complex hermitian matrix are real. -/
lemma is_hermitian.coe_re_diag {A : matrix n n α} (h : A.is_hermitian) :
  (λ i, (re (A.diag i) : α)) = A.diag :=
funext h.coe_re_apply_self

/-- A matrix is hermitian iff the corresponding linear map is self adjoint. -/

end is_R_or_C

end matrix


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker
-/
import algebra.order.floor
import topology.algebra.order.group

/-!
# Topological facts about `int.floor`, `int.ceil` and `int.fract`

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

This file proves statements about limits and continuity of functions involving `floor`, `ceil` and
`fract`.

## Main declarations

* `tendsto_floor_at_top`, `tendsto_floor_at_bot`, `tendsto_ceil_at_top`, `tendsto_ceil_at_bot`:
  `int.floor` and `int.ceil` tend to +-∞ in +-∞.
* `continuous_on_floor`: `int.floor` is continuous on `Ico n (n + 1)`, because constant.
* `continuous_on_ceil`: `int.ceil` is continuous on `Ioc n (n + 1)`, because constant.
* `continuous_on_fract`: `int.fract` is continuous on `Ico n (n + 1)`.
* `continuous_on.comp_fract`: Precomposing a continuous function satisfying `f 0 = f 1` with
  `int.fract` yields another continuous function.
-/

open filter function int set
open_locale topology

variables {α β γ : Type*} [linear_ordered_ring α] [floor_ring α]

lemma tendsto_floor_at_top : tendsto (floor : α → ℤ) at_top at_top :=
floor_mono.tendsto_at_top_at_top $ λ b, ⟨(b + 1 : ℤ),
  by { rw floor_int_cast, exact (lt_add_one _).le }⟩

lemma tendsto_floor_at_bot : tendsto (floor : α → ℤ) at_bot at_bot :=
floor_mono.tendsto_at_bot_at_bot $ λ b, ⟨b, (floor_int_cast _).le⟩

lemma tendsto_ceil_at_top : tendsto (ceil : α → ℤ) at_top at_top :=
ceil_mono.tendsto_at_top_at_top $ λ b, ⟨b, (ceil_int_cast _).ge⟩

lemma tendsto_ceil_at_bot : tendsto (ceil : α → ℤ) at_bot at_bot :=
ceil_mono.tendsto_at_bot_at_bot $ λ b, ⟨(b - 1 : ℤ),
  by { rw ceil_int_cast, exact (sub_one_lt _).le }⟩

variables [topological_space α]

lemma continuous_on_floor (n : ℤ) : continuous_on (λ x, floor x : α → α) (Ico n (n+1) : set α) :=
(continuous_on_congr $ floor_eq_on_Ico' n).mpr continuous_on_const

lemma continuous_on_ceil (n : ℤ) : continuous_on (λ x, ceil x : α → α) (Ioc (n-1) n : set α) :=
(continuous_on_congr $ ceil_eq_on_Ioc' n).mpr continuous_on_const

lemma tendsto_floor_right' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[≥] n) (𝓝 n) :=
begin
  rw ← nhds_within_Ico_eq_nhds_within_Ici (lt_add_one (n : α)),
  simpa only [floor_int_cast] using
    (continuous_on_floor n _ (left_mem_Ico.mpr $ lt_add_one (_ : α))).tendsto
end

lemma tendsto_ceil_left' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[≤] n) (𝓝 n) :=
begin
  rw ← nhds_within_Ioc_eq_nhds_within_Iic (sub_one_lt (n : α)),
  simpa only [ceil_int_cast] using
    (continuous_on_ceil _ _ (right_mem_Ioc.mpr $ sub_one_lt (_ : α))).tendsto
end

lemma tendsto_floor_right [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[≥] n) (𝓝[≥] n) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ (tendsto_floor_right' _)
begin
  refine (eventually_nhds_within_of_forall $ λ x (hx : (n : α) ≤ x), _),
  change _ ≤ _,
  norm_cast,
  convert ← floor_mono hx,
  rw floor_eq_iff,
  exact ⟨le_rfl, lt_add_one _⟩
end

lemma tendsto_ceil_left [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[≤] n) (𝓝[≤] n) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ (tendsto_ceil_left' _)
begin
  refine (eventually_nhds_within_of_forall $ λ x (hx : x ≤ (n : α)), _),
  change _ ≤ _,
  norm_cast,
  convert ← ceil_mono hx,
  rw ceil_eq_iff,
  exact ⟨sub_one_lt _, le_rfl⟩
end

lemma tendsto_floor_left [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[<] n) (𝓝[≤] (n-1)) :=
begin
  rw ← nhds_within_Ico_eq_nhds_within_Iio (sub_one_lt (n : α)),
  convert (tendsto_nhds_within_congr $ (λ x hx, (floor_eq_on_Ico' (n-1) x hx).symm))
    (tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ tendsto_const_nhds
      (eventually_of_forall (λ _, mem_Iic.mpr $ le_rfl)));
  norm_cast <|> apply_instance,
  ring
end

lemma tendsto_ceil_right [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[>] n) (𝓝[≥] (n+1)) :=
begin
  rw ← nhds_within_Ioc_eq_nhds_within_Ioi (lt_add_one (n : α)),
  convert (tendsto_nhds_within_congr $ (λ x hx, (ceil_eq_on_Ioc' (n+1) x hx).symm))
    (tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ tendsto_const_nhds
      (eventually_of_forall (λ _, mem_Ici.mpr $ le_rfl)));
  norm_cast <|> apply_instance,
  ring
end

lemma tendsto_floor_left' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[<] n) (𝓝 (n-1)) :=
begin
  rw ← nhds_within_univ,
  exact tendsto_nhds_within_mono_right (subset_univ _) (tendsto_floor_left n),
end

lemma tendsto_ceil_right' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[>] n) (𝓝 (n+1)) :=
begin
  rw ← nhds_within_univ,
  exact tendsto_nhds_within_mono_right (subset_univ _) (tendsto_ceil_right n),
end

lemma continuous_on_fract [topological_add_group α] (n : ℤ) :
  continuous_on (fract : α → α) (Ico n (n+1) : set α) :=
continuous_on_id.sub (continuous_on_floor n)

lemma tendsto_fract_left' [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[<] n) (𝓝 1) :=
begin
  convert (tendsto_nhds_within_of_tendsto_nhds tendsto_id).sub (tendsto_floor_left' n);
  [{norm_cast, ring}, apply_instance, apply_instance]
end

lemma tendsto_fract_left [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[<] n) (𝓝[<] 1) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  (tendsto_fract_left' _) (eventually_of_forall fract_lt_one)

lemma tendsto_fract_right' [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[≥] n) (𝓝 0) :=
begin
  convert (tendsto_nhds_within_of_tendsto_nhds tendsto_id).sub (tendsto_floor_right' n);
  [exact (sub_self _).symm, apply_instance, apply_instance]
end

lemma tendsto_fract_right [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[≥] n) (𝓝[≥] 0) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  (tendsto_fract_right' _) (eventually_of_forall fract_nonneg)

local notation `I` := (Icc 0 1 : set α)

variables [order_topology α] [topological_space β] [topological_space γ]

/-- Do not use this, use `continuous_on.comp_fract` instead. -/
lemma continuous_on.comp_fract' {f : β → α → γ}
  (h : continuous_on (uncurry f) $ univ ×ˢ I) (hf : ∀ s, f s 0 = f s 1) :
  continuous (λ st : β × α, f st.1 $ fract st.2) :=
begin
  change continuous ((uncurry f) ∘ (prod.map id (fract))),
  rw continuous_iff_continuous_at,
  rintro ⟨s, t⟩,
  by_cases ht : t = floor t,
  { rw ht,
    rw ← continuous_within_at_univ,
    have : (univ : set (β × α)) ⊆ (univ ×ˢ Iio ↑⌊t⌋) ∪ (univ ×ˢ Ici ↑⌊t⌋),
    { rintros p -,
      rw ← prod_union,
      exact ⟨trivial, lt_or_le p.2 _⟩ },
    refine continuous_within_at.mono _ this,
    refine continuous_within_at.union _ _,
    { simp only [continuous_within_at, fract_int_cast, nhds_within_prod_eq,
                  nhds_within_univ, id.def, comp_app, prod.map_mk],
      have : (uncurry f) (s, 0) = (uncurry f) (s, (1 : α)),
        by simp [uncurry, hf],
      rw this,
      refine (h _ ⟨⟨⟩, by exact_mod_cast right_mem_Icc.2 (zero_le_one' α)⟩).tendsto.comp _,
      rw [nhds_within_prod_eq, nhds_within_univ],
      rw nhds_within_Icc_eq_nhds_within_Iic (zero_lt_one' α),
      exact tendsto_id.prod_map
        (tendsto_nhds_within_mono_right Iio_subset_Iic_self $ tendsto_fract_left _) },
    { simp only [continuous_within_at, fract_int_cast, nhds_within_prod_eq,
                  nhds_within_univ, id.def, comp_app, prod.map_mk],
      refine (h _ ⟨⟨⟩, by exact_mod_cast left_mem_Icc.2 (zero_le_one' α)⟩).tendsto.comp _,
      rw [nhds_within_prod_eq, nhds_within_univ,
        nhds_within_Icc_eq_nhds_within_Ici (zero_lt_one' α)],
      exact tendsto_id.prod_map (tendsto_fract_right _) } },
  { have : t ∈ Ioo (floor t : α) ((floor t : α) + 1),
      from ⟨lt_of_le_of_ne (floor_le t) (ne.symm ht), lt_floor_add_one _⟩,
    apply (h ((prod.map _ fract) _) ⟨trivial, ⟨fract_nonneg _, (fract_lt_one _).le⟩⟩).tendsto.comp,
    simp only [nhds_prod_eq, nhds_within_prod_eq, nhds_within_univ, id.def, prod.map_mk],
    exact continuous_at_id.tendsto.prod_map
            (tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
              (((continuous_on_fract _ _ (Ioo_subset_Ico_self this)).mono
                  Ioo_subset_Ico_self).continuous_at (Ioo_mem_nhds this.1 this.2))
              (eventually_of_forall (λ x, ⟨fract_nonneg _, (fract_lt_one _).le⟩)) ) }
end

lemma continuous_on.comp_fract
  {s : β → α}
  {f : β → α → γ}
  (h : continuous_on (uncurry f) $ univ ×ˢ Icc 0 1)
  (hs : continuous s)
  (hf : ∀ s, f s 0 = f s 1) :
  continuous (λ x : β, f x $ int.fract (s x)) :=
(h.comp_fract' hf).comp (continuous_id.prod_mk hs)

/-- A special case of `continuous_on.comp_fract`. -/
lemma continuous_on.comp_fract'' {f : α → β} (h : continuous_on f I) (hf : f 0 = f 1) :
  continuous (f ∘ fract) :=
continuous_on.comp_fract (h.comp continuous_on_snd $ λ x hx, (mem_prod.mp hx).2)
  continuous_id (λ _, hf)