/-
Copyright (c) 2014 Robert Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Lewis, Leonardo de Moura, Mario Carneiro, Floris van Doorn

! This file was ported from Lean 3 source module algebra.order.field.power
! leanprover-community/mathlib commit acb3d204d4ee883eb686f45d486a2a6811a01329
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Parity
import Mathlib.Algebra.CharZero.Lemmas
import Mathlib.Algebra.GroupWithZero.Power
import Mathlib.Algebra.Order.Field.Basic

/-!
# Lemmas about powers in ordered fields.
-/

variable {α : Type _}

open Function Int

section LinearOrderedSemifield

variable [LinearOrderedSemifield α] {a b c d e : α} {m n : ℤ}

/-! ### Integer powers -/

theorem zpow_le_of_le (ha : 1 ≤ a) (h : m ≤ n) : a ^ m ≤ a ^ n := by
  have ha₀ : 0 < a := one_pos.trans_le ha
  lift n - m to ℕ using sub_nonneg.2 h with k hk
  calc
    a ^ m = a ^ m * 1 := (mul_one _).symm
    _ ≤ a ^ m * a ^ k :=
      mul_le_mul_of_nonneg_left (one_le_pow_of_one_le ha _) (zpow_nonneg ha₀.le _)
    _ = a ^ n := by rw [← zpow_ofNat, ← zpow_add₀ ha₀.ne', hk, add_sub_cancel'_right]

#align zpow_le_of_le zpow_le_of_le

theorem zpow_le_one_of_nonpos (ha : 1 ≤ a) (hn : n ≤ 0) : a ^ n ≤ 1 :=
  (zpow_le_of_le ha hn).trans_eq <| zpow_zero _
#align zpow_le_one_of_nonpos zpow_le_one_of_nonpos

theorem one_le_zpow_of_nonneg (ha : 1 ≤ a) (hn : 0 ≤ n) : 1 ≤ a ^ n :=
  (zpow_zero _).symm.trans_le <| zpow_le_of_le ha hn
#align one_le_zpow_of_nonneg one_le_zpow_of_nonneg

protected theorem Nat.zpow_pos_of_pos {a : ℕ} (h : 0 < a) (n : ℤ) : 0 < (a : α) ^ n := by
  apply zpow_pos_of_pos
  exact_mod_cast h
#align nat.zpow_pos_of_pos Nat.zpow_pos_of_pos

theorem Nat.zpow_ne_zero_of_pos {a : ℕ} (h : 0 < a) (n : ℤ) : (a : α) ^ n ≠ 0 :=
  (Nat.zpow_pos_of_pos h n).ne'
#align nat.zpow_ne_zero_of_pos Nat.zpow_ne_zero_of_pos

theorem one_lt_zpow (ha : 1 < a) : ∀ n : ℤ, 0 < n → 1 < a ^ n
  | (n : ℕ), h => (zpow_ofNat _ _).symm.subst (one_lt_pow ha <| Int.coe_nat_ne_zero.mp h.ne')
  | -[_+1], h => ((Int.negSucc_not_pos _).mp h).elim
#align one_lt_zpow one_lt_zpow

theorem zpow_strictMono (hx : 1 < a) : StrictMono ((· ^ ·) a : ℤ → α) :=
  strictMono_int_of_lt_succ fun n =>
    have xpos : 0 < a := zero_lt_one.trans hx
    calc
      a ^ n < a ^ n * a := lt_mul_of_one_lt_right (zpow_pos_of_pos xpos _) hx
      _ = a ^ (n + 1) := (zpow_add_one₀ xpos.ne' _).symm
#align zpow_strict_mono zpow_strictMono

theorem zpow_strictAnti (h₀ : 0 < a) (h₁ : a < 1) : StrictAnti ((· ^ ·) a : ℤ → α) :=
  strictAnti_int_of_succ_lt fun n =>
    calc
      a ^ (n + 1) = a ^ n * a := zpow_add_one₀ h₀.ne' _
      _ < a ^ n * 1 := (mul_lt_mul_left <| zpow_pos_of_pos h₀ _).2 h₁
      _ = a ^ n := mul_one _
#align zpow_strict_anti zpow_strictAnti

@[simp]
theorem zpow_lt_iff_lt (hx : 1 < a) : a ^ m < a ^ n ↔ m < n :=
  (zpow_strictMono hx).lt_iff_lt
#align zpow_lt_iff_lt zpow_lt_iff_lt

@[simp]
theorem zpow_le_iff_le (hx : 1 < a) : a ^ m ≤ a ^ n ↔ m ≤ n :=
  (zpow_strictMono hx).le_iff_le
#align zpow_le_iff_le zpow_le_iff_le

@[simp]
theorem div_pow_le (ha : 0 ≤ a) (hb : 1 ≤ b) (k : ℕ) : a / b ^ k ≤ a :=
  div_le_self ha <| one_le_pow_of_one_le hb _
#align div_pow_le div_pow_le

theorem zpow_injective (h₀ : 0 < a) (h₁ : a ≠ 1) : Injective ((· ^ ·) a : ℤ → α) := by
  rcases h₁.lt_or_lt with (H | H)
  · exact (zpow_strictAnti h₀ H).injective
  · exact (zpow_strictMono H).injective
#align zpow_injective zpow_injective

@[simp]
theorem zpow_inj (h₀ : 0 < a) (h₁ : a ≠ 1) : a ^ m = a ^ n ↔ m = n :=
  (zpow_injective h₀ h₁).eq_iff
#align zpow_inj zpow_inj

theorem zpow_le_max_of_min_le {x : α} (hx : 1 ≤ x) {a b c : ℤ} (h : min a b ≤ c) :
    x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) :=
  have : Antitone fun n : ℤ => x ^ (-n) := fun _ _ h => zpow_le_of_le hx (neg_le_neg h)
  (this h).trans_eq this.map_min
#align zpow_le_max_of_min_le zpow_le_max_of_min_le

theorem zpow_le_max_iff_min_le {x : α} (hx : 1 < x) {a b c : ℤ} :
    x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) ↔ min a b ≤ c := by
  simp_rw [le_max_iff, min_le_iff, zpow_le_iff_le hx, neg_le_neg_iff]
#align zpow_le_max_iff_min_le zpow_le_max_iff_min_le

end LinearOrderedSemifield

section LinearOrderedField

variable [LinearOrderedField α] {a b c d : α} {n : ℤ}

/-! ### Lemmas about powers to numerals. -/

section bits

set_option linter.deprecated false

theorem zpow_bit0_nonneg (a : α) (n : ℤ) : 0 ≤ a ^ bit0 n :=
  (mul_self_nonneg _).trans_eq <| (zpow_bit0 _ _).symm
#align zpow_bit0_nonneg zpow_bit0_nonneg

theorem zpow_two_nonneg (a : α) : 0 ≤ a ^ (2 : ℤ) := by
  convert zpow_bit0_nonneg a 1
#align zpow_two_nonneg zpow_two_nonneg

theorem zpow_neg_two_nonneg (a : α) : 0 ≤ a ^ (-2 : ℤ) :=
  zpow_bit0_nonneg _ (-1)
#align zpow_neg_two_nonneg zpow_neg_two_nonneg

theorem zpow_bit0_pos (h : a ≠ 0) (n : ℤ) : 0 < a ^ bit0 n :=
  (zpow_bit0_nonneg a n).lt_of_ne (zpow_ne_zero _ h).symm
#align zpow_bit0_pos zpow_bit0_pos

theorem zpow_two_pos_of_ne_zero (h : a ≠ 0) : 0 < a ^ (2 : ℤ) := by
  convert zpow_bit0_pos h 1
#align zpow_two_pos_of_ne_zero zpow_two_pos_of_ne_zero

@[simp]
theorem zpow_bit0_pos_iff (hn : n ≠ 0) : 0 < a ^ bit0 n ↔ a ≠ 0 :=
  ⟨by
    rintro h rfl
    refine' (zero_zpow _ _).not_gt h
    rwa [bit0_ne_zero],
   fun h => zpow_bit0_pos h _⟩
#align zpow_bit0_pos_iff zpow_bit0_pos_iff

@[simp]
theorem zpow_bit1_neg_iff : a ^ bit1 n < 0 ↔ a < 0 :=
  ⟨fun h => not_le.1 fun h' => not_le.2 h <| zpow_nonneg h' _, fun h => by
    rw [bit1, zpow_add_one₀ h.ne]; exact mul_neg_of_pos_of_neg (zpow_bit0_pos h.ne _) h⟩
#align zpow_bit1_neg_iff zpow_bit1_neg_iff

@[simp]
theorem zpow_bit1_nonneg_iff : 0 ≤ a ^ bit1 n ↔ 0 ≤ a :=
  le_iff_le_iff_lt_iff_lt.2 zpow_bit1_neg_iff
#align zpow_bit1_nonneg_iff zpow_bit1_nonneg_iff

@[simp]
theorem zpow_bit1_nonpos_iff : a ^ bit1 n ≤ 0 ↔ a ≤ 0 := by
  rw [le_iff_lt_or_eq, le_iff_lt_or_eq, zpow_bit1_neg_iff, zpow_eq_zero_iff (Int.bit1_ne_zero n)]
#align zpow_bit1_nonpos_iff zpow_bit1_nonpos_iff

@[simp]
theorem zpow_bit1_pos_iff : 0 < a ^ bit1 n ↔ 0 < a :=
  lt_iff_lt_of_le_iff_le zpow_bit1_nonpos_iff
#align zpow_bit1_pos_iff zpow_bit1_pos_iff

end bits

protected theorem Even.zpow_nonneg (hn : Even n) (a : α) : 0 ≤ a ^ n := by
  obtain ⟨k, rfl⟩ := hn; exact zpow_bit0_nonneg _ _
#align even.zpow_nonneg Even.zpow_nonneg

theorem Even.zpow_pos_iff (hn : Even n) (h : n ≠ 0) : 0 < a ^ n ↔ a ≠ 0 := by
  obtain ⟨k, rfl⟩ := hn; exact zpow_bit0_pos_iff (by rintro rfl; simp at h)
#align even.zpow_pos_iff Even.zpow_pos_iff

theorem Odd.zpow_neg_iff (hn : Odd n) : a ^ n < 0 ↔ a < 0 := by
  cases' hn with k hk; simpa only [hk, two_mul] using zpow_bit1_neg_iff
#align odd.zpow_neg_iff Odd.zpow_neg_iff

protected theorem Odd.zpow_nonneg_iff (hn : Odd n) : 0 ≤ a ^ n ↔ 0 ≤ a := by
  cases' hn with k hk; simpa only [hk, two_mul] using zpow_bit1_nonneg_iff
#align odd.zpow_nonneg_iff Odd.zpow_nonneg_iff

theorem Odd.zpow_nonpos_iff (hn : Odd n) : a ^ n ≤ 0 ↔ a ≤ 0 := by
  cases' hn with k hk; simpa only [hk, two_mul] using zpow_bit1_nonpos_iff
#align odd.zpow_nonpos_iff Odd.zpow_nonpos_iff

theorem Odd.zpow_pos_iff (hn : Odd n) : 0 < a ^ n ↔ 0 < a := by
  cases' hn with k hk; simpa only [hk, two_mul] using zpow_bit1_pos_iff
#align odd.zpow_pos_iff Odd.zpow_pos_iff

alias Even.zpow_pos_iff ↔ _ Even.zpow_pos
#align even.zpow_pos Even.zpow_pos

alias Odd.zpow_neg_iff ↔ _ Odd.zpow_neg
#align odd.zpow_neg Odd.zpow_neg

alias Odd.zpow_nonpos_iff ↔ _ Odd.zpow_nonpos
#align odd.zpow_nonpos Odd.zpow_nonpos

theorem Even.zpow_abs {p : ℤ} (hp : Even p) (a : α) : |a| ^ p = a ^ p := by
  cases' abs_choice a with h h <;> simp only [h, hp.neg_zpow _]
#align even.zpow_abs Even.zpow_abs

set_option linter.deprecated false in
@[simp]
theorem zpow_bit0_abs (a : α) (p : ℤ) : |a| ^ bit0 p = a ^ bit0 p :=
  (even_bit0 _).zpow_abs _
#align zpow_bit0_abs zpow_bit0_abs

/-! ### Miscellaneous lemmmas -/

/-- Bernoulli's inequality reformulated to estimate `(n : α)`. -/
theorem Nat.cast_le_pow_sub_div_sub (H : 1 < a) (n : ℕ) : (n : α) ≤ (a ^ n - 1) / (a - 1) :=
  (le_div_iff (sub_pos.2 H)).2 <|
    le_sub_left_of_add_le <| one_add_mul_sub_le_pow ((neg_le_self zero_le_one).trans H.le) _
#align nat.cast_le_pow_sub_div_sub Nat.cast_le_pow_sub_div_sub

/-- For any `a > 1` and a natural `n` we have `n ≤ a ^ n / (a - 1)`. See also
`nat.cast_le_pow_sub_div_sub` for a stronger inequality with `a ^ n - 1` in the numerator. -/
theorem Nat.cast_le_pow_div_sub (H : 1 < a) (n : ℕ) : (n : α) ≤ a ^ n / (a - 1) :=
  (n.cast_le_pow_sub_div_sub H).trans <|
    div_le_div_of_le (sub_nonneg.2 H.le) (sub_le_self _ zero_le_one)
#align nat.cast_le_pow_div_sub Nat.cast_le_pow_div_sub

end LinearOrderedField


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

Zorn's lemmas.

Ported from Isabelle/HOL (written by Jacques D. Fleuriot, Tobias Nipkow, and Christian Sternagel).
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes u u_1 u_2

namespace Mathlib

namespace zorn

/-- A chain is a subset `c` satisfying
  `x ≺ y ∨ x = y ∨ y ≺ x` for all `x y ∈ c`. -/
def chain {α : Type u} (r : α → α → Prop) (c : set α) :=
  set.pairwise_on c fun (x y : α) => r x y ∨ r y x

theorem chain.total_of_refl {α : Type u} {r : α → α → Prop} [is_refl α r] {c : set α}
    (H : chain r c) {x : α} {y : α} (hx : x ∈ c) (hy : y ∈ c) : r x y ∨ r y x :=
  dite (x = y) (fun (e : x = y) => Or.inl (e ▸ refl x)) fun (e : ¬x = y) => H x hx y hy e

theorem chain.mono {α : Type u} {r : α → α → Prop} {c : set α} {c' : set α} :
    c' ⊆ c → chain r c → chain r c' :=
  set.pairwise_on.mono

theorem chain.directed_on {α : Type u} {r : α → α → Prop} [is_refl α r] {c : set α}
    (H : chain r c) : directed_on r c :=
  sorry

theorem chain_insert {α : Type u} {r : α → α → Prop} {c : set α} {a : α} (hc : chain r c)
    (ha : ∀ (b : α), b ∈ c → b ≠ a → r a b ∨ r b a) : chain r (insert a c) :=
  sorry

/-- `super_chain c₁ c₂` means that `c₂ is a chain that strictly includes `c₁`. -/
def super_chain {α : Type u} {r : α → α → Prop} (c₁ : set α) (c₂ : set α) := chain r c₂ ∧ c₁ ⊂ c₂

/-- A chain `c` is a maximal chain if there does not exists a chain strictly including `c`. -/
def is_max_chain {α : Type u} {r : α → α → Prop} (c : set α) :=
  chain r c ∧ ¬∃ (c' : set α), super_chain c c'

/-- Given a set `c`, if there exists a chain `c'` strictly including `c`, then `succ_chain c`
is one of these chains. Otherwise it is `c`. -/
def succ_chain {α : Type u} {r : α → α → Prop} (c : set α) : set α :=
  dite (∃ (c' : set α), chain r c ∧ super_chain c c')
    (fun (h : ∃ (c' : set α), chain r c ∧ super_chain c c') => classical.some h)
    fun (h : ¬∃ (c' : set α), chain r c ∧ super_chain c c') => c

theorem succ_spec {α : Type u} {r : α → α → Prop} {c : set α}
    (h : ∃ (c' : set α), chain r c ∧ super_chain c c') : super_chain c (succ_chain c) :=
  sorry

theorem chain_succ {α : Type u} {r : α → α → Prop} {c : set α} (hc : chain r c) :
    chain r (succ_chain c) :=
  sorry

theorem super_of_not_max {α : Type u} {r : α → α → Prop} {c : set α} (hc₁ : chain r c)
    (hc₂ : ¬is_max_chain c) : super_chain c (succ_chain c) :=
  sorry

theorem succ_increasing {α : Type u} {r : α → α → Prop} {c : set α} : c ⊆ succ_chain c := sorry

/-- Set of sets reachable from `∅` using `succ_chain` and `⋃₀`. -/
inductive chain_closure {α : Type u} {r : α → α → Prop} : set α → Prop where
| succ : ∀ {s : set α}, chain_closure s → chain_closure (succ_chain s)
| union : ∀ {s : set (set α)}, (∀ (a : set α), a ∈ s → chain_closure a) → chain_closure (⋃₀s)

theorem chain_closure_empty {α : Type u} {r : α → α → Prop} : chain_closure ∅ := sorry

theorem chain_closure_closure {α : Type u} {r : α → α → Prop} : chain_closure (⋃₀chain_closure) :=
  chain_closure.union fun (s : set α) (hs : s ∈ chain_closure) => hs

theorem chain_closure_total {α : Type u} {r : α → α → Prop} {c₁ : set α} {c₂ : set α}
    (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂) : c₁ ⊆ c₂ ∨ c₂ ⊆ c₁ :=
  (fun (this : c₁ ⊆ c₂ ∨ succ_chain c₂ ⊆ c₁) =>
      or.imp_right (fun (this : succ_chain c₂ ⊆ c₁) => set.subset.trans succ_increasing this) this)
    (chain_closure_succ_total_aux hc₁ hc₂
      fun (c₃ : set α) (hc₃ : chain_closure c₃) => chain_closure_succ_total hc₃ hc₂)

theorem chain_closure_succ_fixpoint {α : Type u} {r : α → α → Prop} {c₁ : set α} {c₂ : set α}
    (hc₁ : chain_closure c₁) (hc₂ : chain_closure c₂) (h_eq : succ_chain c₂ = c₂) : c₁ ⊆ c₂ :=
  sorry

theorem chain_closure_succ_fixpoint_iff {α : Type u} {r : α → α → Prop} {c : set α}
    (hc : chain_closure c) : succ_chain c = c ↔ c = ⋃₀chain_closure :=
  sorry

theorem chain_chain_closure {α : Type u} {r : α → α → Prop} {c : set α} (hc : chain_closure c) :
    chain r c :=
  sorry

/-- `max_chain` is the union of all sets in the chain closure. -/
def max_chain {α : Type u} {r : α → α → Prop} : set α := ⋃₀chain_closure

/-- Hausdorff's maximality principle

There exists a maximal totally ordered subset of `α`.
Note that we do not require `α` to be partially ordered by `r`. -/
theorem max_chain_spec {α : Type u} {r : α → α → Prop} : is_max_chain max_chain := sorry

/-- Zorn's lemma

If every chain has an upper bound, then there is a maximal element -/
theorem exists_maximal_of_chains_bounded {α : Type u} {r : α → α → Prop}
    (h : ∀ (c : set α), chain r c → ∃ (ub : α), ∀ (a : α), a ∈ c → r a ub)
    (trans : ∀ {a b c : α}, r a b → r b c → r a c) : ∃ (m : α), ∀ (a : α), r m a → r a m :=
  sorry

theorem zorn_partial_order {α : Type u} [partial_order α]
    (h : ∀ (c : set α), chain LessEq c → ∃ (ub : α), ∀ (a : α), a ∈ c → a ≤ ub) :
    ∃ (m : α), ∀ (a : α), m ≤ a → a = m :=
  sorry

theorem zorn_partial_order₀ {α : Type u} [partial_order α] (s : set α)
    (ih :
      ∀ (c : set α) (H : c ⊆ s),
        chain LessEq c →
          ∀ (y : α) (H : y ∈ c), ∃ (ub : α), ∃ (H : ub ∈ s), ∀ (z : α), z ∈ c → z ≤ ub)
    (x : α) (hxs : x ∈ s) : ∃ (m : α), ∃ (H : m ∈ s), x ≤ m ∧ ∀ (z : α), z ∈ s → m ≤ z → z = m :=
  sorry

theorem zorn_subset {α : Type u} (S : set (set α))
    (h :
      ∀ (c : set (set α)) (H : c ⊆ S),
        chain has_subset.subset c → ∃ (ub : set α), ∃ (H : ub ∈ S), ∀ (s : set α), s ∈ c → s ⊆ ub) :
    ∃ (m : set α), ∃ (H : m ∈ S), ∀ (a : set α), a ∈ S → m ⊆ a → a = m :=
  sorry

theorem zorn_subset₀ {α : Type u} (S : set (set α))
    (H :
      ∀ (c : set (set α)) (H : c ⊆ S),
        chain has_subset.subset c →
          set.nonempty c → ∃ (ub : set α), ∃ (H : ub ∈ S), ∀ (s : set α), s ∈ c → s ⊆ ub)
    (x : set α) (hx : x ∈ S) :
    ∃ (m : set α), ∃ (H : m ∈ S), x ⊆ m ∧ ∀ (a : set α), a ∈ S → m ⊆ a → a = m :=
  sorry

theorem chain.total {α : Type u} [preorder α] {c : set α} (H : chain LessEq c) {x : α} {y : α} :
    x ∈ c → y ∈ c → x ≤ y ∨ y ≤ x :=
  chain.total_of_refl H

theorem chain.image {α : Type u_1} {β : Type u_2} (r : α → α → Prop) (s : β → β → Prop) (f : α → β)
    (h : ∀ (x y : α), r x y → s (f x) (f y)) {c : set α} (hrc : chain r c) : chain s (f '' c) :=
  sorry

end zorn

theorem directed_of_chain {α : Type u_1} {β : Type u_2} {r : β → β → Prop} [is_refl β r] {f : α → β}
    {c : set α} (h : zorn.chain (f ⁻¹'o r) c) :
    directed r fun (x : Subtype fun (a : α) => a ∈ c) => f ↑x :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Martin Zinkevich. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Martin Zinkevich
-/
import measure_theory.integral.lebesgue
import probability_theory.independence

/-!
# Integration in Probability Theory

Integration results for independent random variables. Specifically, for two
independent random variables X and Y over the extended non-negative
reals, `E[X * Y] = E[X] * E[Y]`, and similar results.

## Implementation notes

Many lemmas in this file take two arguments of the same typeclass. It is worth remembering that lean
will always pick the later typeclass in this situation, and does not care whether the arguments are
`[]`, `{}`, or `()`. All of these use the `measurable_space` `M2` to define `μ`:

```lean
example {M1 : measurable_space α} [M2 : measurable_space α] {μ : measure α} : sorry := sorry
example [M1 : measurable_space α] {M2 : measurable_space α} {μ : measure α} : sorry := sorry
```

-/

noncomputable theory
open set measure_theory
open_locale ennreal

variables {α : Type*}

namespace probability_theory

/-- This (roughly) proves that if a random variable `f` is independent of an event `T`,
   then if you restrict the random variable to `T`, then
   `E[f * indicator T c 0]=E[f] * E[indicator T c 0]`. It is useful for
   `lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space`. -/
lemma lintegral_mul_indicator_eq_lintegral_mul_lintegral_indicator
  {Mf : measurable_space α} [M : measurable_space α] {μ : measure α} (hMf : Mf ≤ M)
  (c : ℝ≥0∞) {T : set α} (h_meas_T : measurable_set T)
  (h_ind : indep_sets Mf.measurable_set' {T} μ)
  {f : α → ℝ≥0∞} (h_meas_f : @measurable α ℝ≥0∞ Mf _ f) :
  ∫⁻ a, f a * T.indicator (λ _, c) a ∂μ = ∫⁻ a, f a ∂μ * ∫⁻ a, T.indicator (λ _, c) a ∂μ :=
begin
  revert f,
  have h_mul_indicator : ∀ g, measurable g → measurable (λ a, g a * T.indicator (λ x, c) a),
    from λ g h_mg, h_mg.mul (measurable_const.indicator h_meas_T),
  apply measurable.ennreal_induction,
  { intros c' s' h_meas_s',
    simp_rw [← inter_indicator_mul],
    rw [lintegral_indicator _ (measurable_set.inter (hMf _ h_meas_s') (h_meas_T)),
      lintegral_indicator _ (hMf _ h_meas_s'), lintegral_indicator _ h_meas_T],
    simp only [measurable_const, lintegral_const, univ_inter, lintegral_const_mul,
      measurable_set.univ, measure.restrict_apply],
    ring_nf,
    congr,
    rw [mul_comm, h_ind s' T h_meas_s' (set.mem_singleton _)], },
  { intros f' g h_univ h_meas_f' h_meas_g h_ind_f' h_ind_g,
    have h_measM_f' : measurable f', from h_meas_f'.mono hMf le_rfl,
    have h_measM_g : measurable g, from h_meas_g.mono hMf le_rfl,
    simp_rw [pi.add_apply, right_distrib],
    rw [lintegral_add (h_mul_indicator _ h_measM_f') (h_mul_indicator _ h_measM_g),
      lintegral_add h_measM_f' h_measM_g, right_distrib, h_ind_f', h_ind_g] },
  { intros f h_meas_f h_mono_f h_ind_f,
    have h_measM_f : ∀ n, measurable (f n), from λ n, (h_meas_f n).mono hMf le_rfl,
    simp_rw [ennreal.supr_mul],
    rw [lintegral_supr h_measM_f h_mono_f, lintegral_supr, ennreal.supr_mul],
    { simp_rw [← h_ind_f] },
    { exact λ n, h_mul_indicator _ (h_measM_f n) },
    { exact λ m n h_le a, ennreal.mul_le_mul (h_mono_f h_le a) le_rfl, }, },
end

/-- This (roughly) proves that if `f` and `g` are independent random variables,
   then `E[f * g] = E[f] * E[g]`. However, instead of directly using the independence
   of the random variables, it uses the independence of measurable spaces for the
   domains of `f` and `g`. This is similar to the sigma-algebra approach to
   independence. See `lintegral_mul_eq_lintegral_mul_lintegral_of_independent_fn` for
   a more common variant of the product of independent variables. -/
lemma lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space
  {Mf Mg : measurable_space α} [M : measurable_space α] {μ : measure α}
  (hMf : Mf ≤ M) (hMg : Mg ≤ M) (h_ind : indep Mf Mg μ) {f g : α → ℝ≥0∞}
  (h_meas_f : @measurable α ℝ≥0∞ Mf _ f) (h_meas_g : @measurable α ℝ≥0∞ Mg _ g) :
  ∫⁻ a, f a * g a ∂μ = ∫⁻ a, f a ∂μ * ∫⁻ a, g a ∂μ :=
begin
  revert g,
  have h_measM_f : measurable f, from h_meas_f.mono hMf le_rfl,
  apply measurable.ennreal_induction,
  { intros c s h_s,
    apply lintegral_mul_indicator_eq_lintegral_mul_lintegral_indicator hMf _ (hMg _ h_s) _ h_meas_f,
    apply indep_sets_of_indep_sets_of_le_right h_ind,
    rwa singleton_subset_iff, },
  { intros f' g h_univ h_measMg_f' h_measMg_g h_ind_f' h_ind_g',
    have h_measM_f' : measurable f', from h_measMg_f'.mono hMg le_rfl,
    have h_measM_g : measurable g, from h_measMg_g.mono hMg le_rfl,
    simp_rw [pi.add_apply, left_distrib],
    rw [lintegral_add h_measM_f' h_measM_g,
      lintegral_add (h_measM_f.mul h_measM_f') (h_measM_f.mul h_measM_g),
      left_distrib, h_ind_f', h_ind_g'] },
  { intros f' h_meas_f' h_mono_f' h_ind_f',
    have h_measM_f' : ∀ n, measurable (f' n), from λ n, (h_meas_f' n).mono hMg le_rfl,
    simp_rw [ennreal.mul_supr],
    rw [lintegral_supr, lintegral_supr h_measM_f' h_mono_f', ennreal.mul_supr],
    { simp_rw [← h_ind_f'], },
    { exact λ n, h_measM_f.mul (h_measM_f' n), },
    { exact λ n m (h_le : n ≤ m) a, ennreal.mul_le_mul le_rfl (h_mono_f' h_le a), }, }
end

/-- This proves that if `f` and `g` are independent random variables,
   then `E[f * g] = E[f] * E[g]`. -/
lemma lintegral_mul_eq_lintegral_mul_lintegral_of_indep_fun [measurable_space α] {μ : measure α}
  {f g : α → ℝ≥0∞} (h_meas_f : measurable f) (h_meas_g : measurable g)
  (h_indep_fun : indep_fun f g μ) :
  ∫⁻ a, (f * g) a ∂μ = ∫⁻ a, f a ∂μ * ∫⁻ a, g a ∂μ :=
lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space
  (measurable_iff_comap_le.1 h_meas_f) (measurable_iff_comap_le.1 h_meas_g) h_indep_fun
  (measurable.of_comap_le le_rfl) (measurable.of_comap_le le_rfl)

end probability_theory


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import data.finset.card

/-!
# UV-compressions

This file defines UV-compression. It is an operation on a set family that reduces its shadow.

UV-compressing `a : α` along `u v : α` means replacing `a` by `(a ⊔ u) \ v` if `a` and `u` are
disjoint and `v ≤ a`. In some sense, it's moving `a` from `v` to `u`.

UV-compressions are immensely useful to prove the Kruskal-Katona theorem. The idea is that
compressing a set family might decrease the size of its shadow, so iterated compressions hopefully
minimise the shadow.

## Main declarations

* `uv.compress`: `compress u v a` is `a` compressed along `u` and `v`.
* `uv.compression`: `compression u v s` is the compression of the set family `s` along `u` and `v`.
  It is the compressions of the elements of `s` whose compression is not already in `s` along with
  the element whose compression is already in `s`. This way of splitting into what moves and what
  does not ensures the compression doesn't squash the set family, which is proved by
  `uv.card_compress`.

## Notation

`𝓒` (typed with `\MCC`) is notation for `uv.compression` in locale `finset_family`.

## Notes

Even though our emphasis is on `finset α`, we define UV-compressions more generally in a generalized
boolean algebra, so that one can use it for `set α`.

## TODO

Prove that compressing reduces the size of shadow. This result and some more already exist on the
branch `combinatorics`.

## References

* https://github.com/b-mehta/maths-notes/blob/master/iii/mich/combinatorics.pdf

## Tags

compression, UV-compression, shadow
-/

open finset

variable {α : Type*}

/-- UV-compression is injective on the elements it moves. See `uv.compress`. -/
lemma sup_sdiff_inj_on [generalized_boolean_algebra α] (u v : α) :
  {x | disjoint u x ∧ v ≤ x}.inj_on (λ x, (x ⊔ u) \ v) :=
begin
  rintro a ha b hb hab,
  have h : (a ⊔ u) \ v \ u ⊔ v = (b ⊔ u) \ v \ u ⊔ v,
  { dsimp at hab,
    rw hab },
  rwa [sdiff_sdiff_comm, ha.1.symm.sup_sdiff_cancel_right, sdiff_sdiff_comm,
    hb.1.symm.sup_sdiff_cancel_right, sdiff_sup_cancel ha.2, sdiff_sup_cancel hb.2] at h,
end

-- The namespace is here to distinguish from other compressions.
namespace uv

/-! ### UV-compression in generalized boolean algebras -/

section generalized_boolean_algebra
variables [generalized_boolean_algebra α] [decidable_rel (@disjoint α _ _)]
  [decidable_rel ((≤) : α → α → Prop)] {s : finset α} {u v a b : α}

/-- To UV-compress `a`, if it doesn't touch `U` and does contain `V`, we remove `V` and
put `U` in. We'll only really use this when `|U| = |V|` and `U ∩ V = ∅`. -/
def compress (u v a : α) : α := if disjoint u a ∧ v ≤ a then (a ⊔ u) \ v else a

/-- To UV-compress a set family, we compress each of its elements, except that we don't want to
reduce the cardinality, so we keep all elements whose compression is already present. -/
def compression (u v : α) (s : finset α) :=
s.filter (λ a, compress u v a ∈ s) ∪ (s.image $ compress u v).filter (λ a, a ∉ s)

localized "notation `𝓒 ` := uv.compression" in finset_family

/-- `is_compressed u v s` expresses that `s` is UV-compressed. -/
def is_compressed (u v : α) (s : finset α) := 𝓒 u v s = s

/-- `a` is in the UV-compressed family iff it's in the original and its compression is in the
original, or it's not in the original but it's the compression of something in the original. -/
lemma mem_compression :
  a ∈ 𝓒 u v s ↔ a ∈ s ∧ compress u v a ∈ s ∨ a ∉ s ∧ ∃ b ∈ s, compress u v b = a :=
by simp_rw [compression, mem_union, mem_filter, mem_image, and_comm (a ∉ s)]

@[simp] lemma compress_self (u a : α) : compress u u a = a :=
begin
  unfold compress,
  split_ifs,
  { exact h.1.symm.sup_sdiff_cancel_right },
  { refl }
end

@[simp] lemma compression_self (u : α) (s : finset α) : 𝓒 u u s = s :=
begin
  unfold compression,
  convert union_empty s,
  { ext a,
    rw [mem_filter, compress_self, and_self] },
  { refine eq_empty_of_forall_not_mem (λ a ha, _),
    simp_rw [mem_filter, mem_image, compress_self] at ha,
    obtain ⟨⟨b, hb, rfl⟩, hb'⟩ := ha,
    exact hb' hb }
end

/-- Any family is compressed along two identical elements. -/
lemma is_compressed_self (u : α) (s : finset α) : is_compressed u u s := compression_self u s

lemma compress_disjoint (u v : α) :
  disjoint (s.filter (λ a, compress u v a ∈ s)) ((s.image $ compress u v).filter (λ a, a ∉ s)) :=
disjoint_left.2 $ λ a ha₁ ha₂, (mem_filter.1 ha₂).2 (mem_filter.1 ha₁).1

/-- Compressing an element is idempotent. -/
@[simp] lemma compress_idem (u v a : α) : compress u v (compress u v a) = compress u v a :=
begin
  unfold compress,
  split_ifs with h h',
  { rw [le_sdiff_iff.1 h'.2, sdiff_bot, sdiff_bot, sup_assoc, sup_idem] },
  { refl },
  { refl }
end

lemma compress_mem_compression (ha : a ∈ s) : compress u v a ∈ 𝓒 u v s :=
begin
  rw mem_compression,
  by_cases compress u v a ∈ s,
  { rw compress_idem,
    exact or.inl ⟨h, h⟩ },
  { exact or.inr ⟨h, a, ha, rfl⟩ }
end

-- This is a special case of `compress_mem_compression` once we have `compression_idem`.
lemma compress_mem_compression_of_mem_compression (ha : a ∈ 𝓒 u v s) : compress u v a ∈ 𝓒 u v s :=
begin
  rw mem_compression at ⊢ ha,
  simp only [compress_idem, exists_prop],
  obtain ⟨_, ha⟩ | ⟨_, b, hb, rfl⟩ := ha,
  { exact or.inl ⟨ha, ha⟩ },
  { exact or.inr ⟨by rwa compress_idem, b, hb, (compress_idem _ _ _).symm⟩ }
end

/-- Compressing a family is idempotent. -/
@[simp] lemma compression_idem (u v : α) (s : finset α) : 𝓒 u v (𝓒 u v s) = 𝓒 u v s :=
begin
  have h : filter (λ a, compress u v a ∉ 𝓒 u v s) (𝓒 u v s) = ∅ :=
    filter_false_of_mem (λ a ha h, h $ compress_mem_compression_of_mem_compression ha),
  rw [compression, image_filter, h, image_empty, ←h],
  exact filter_union_filter_neg_eq _ (compression u v s),
end

/-- Compressing a family doesn't change its size. -/
lemma card_compression (u v : α) (s : finset α) : (𝓒 u v s).card = s.card :=
begin
  rw [compression, card_disjoint_union (compress_disjoint _ _), image_filter, card_image_of_inj_on,
    ←card_disjoint_union, filter_union_filter_neg_eq],
  { rw disjoint_iff_inter_eq_empty,
    exact filter_inter_filter_neg_eq _ _ },
  intros a ha b hb hab,
  dsimp at hab,
  rw [mem_coe, mem_filter, function.comp_app] at ha hb,
  rw compress at ha hab,
  split_ifs at ha hab with has,
  { rw compress at hb hab,
    split_ifs at hb hab with hbs,
    { exact sup_sdiff_inj_on u v has hbs hab },
    { exact (hb.2 hb.1).elim } },
  { exact (ha.2 ha.1).elim }
end

/-- If `a` is in the family compression and can be compressed, then its compression is in the
original family. -/
lemma sup_sdiff_mem_of_mem_compression (ha : a ∈ 𝓒 u v s) (hva : v ≤ a) (hua : disjoint u a) :
  (a ⊔ u) \ v ∈ s :=
begin
  rw [mem_compression, compress_of_disjoint_of_le hua hva] at ha,
  obtain ⟨_, ha⟩ | ⟨_, b, hb, rfl⟩ := ha,
  { exact ha },
  have hu : u = ⊥,
  { suffices : disjoint u (u \ v),
    { rwa [(hua.mono_right hva).sdiff_eq_left, disjoint_self] at this },
    refine hua.mono_right _,
    rw [←compress_idem, compress_of_disjoint_of_le hua hva],
    exact sdiff_le_sdiff_right le_sup_right },
  have hv : v = ⊥,
  { rw ←disjoint_self,
    apply disjoint.mono_right hva,
    rw [←compress_idem, compress_of_disjoint_of_le hua hva],
    exact disjoint_sdiff_self_right },
  rwa [hu, hv, compress_self, sup_bot_eq, sdiff_bot],
end

/-- If `a` is in the `u, v`-compression but `v ≤ a`, then `a` must have been in the original
family. -/
lemma mem_of_mem_compression (ha : a ∈ 𝓒 u v s) (hva : v ≤ a) (hvu : v = ⊥ → u = ⊥) : a ∈ s :=
begin
  rw mem_compression at ha,
  obtain ha | ⟨_, b, hb, h⟩ := ha,
  { exact ha.1 },
  unfold compress at h,
  split_ifs at h,
  { rw [←h, le_sdiff_iff] at hva,
    rw [hvu hva, hva, sup_bot_eq, sdiff_bot] at h,
    rwa ←h },
  { rwa ←h }
end

end generalized_boolean_algebra

/-! ### UV-compression on finsets -/

open_locale finset_family

variables [decidable_eq α] {𝒜 : finset (finset α)} {U V A : finset α}

/-- Compressing a finset doesn't change its size. -/
lemma card_compress (hUV : U.card = V.card) (A : finset α) : (compress U V A).card = A.card :=
begin
  unfold compress,
  split_ifs,
  { rw [card_sdiff (h.2.trans le_sup_left), sup_eq_union, card_disjoint_union h.1.symm, hUV,
    add_tsub_cancel_right] },
  { refl }
end

end uv


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

import group_theory.exponent
import group_theory.order_of_element
import group_theory.quotient_group
import group_theory.submonoid.operations

/-!
# Torsion groups

This file defines torsion groups, i.e. groups where all elements have finite order.

## Main definitions

* `monoid.is_torsion` a predicate asserting `G` is torsion, i.e. that all
  elements are of finite order.
* `add_monoid.is_torsion` the additive version of `monoid.is_torsion`.
* `comm_group.torsion G`, the torsion subgroup of an abelian group `G`
* `comm_monoid.torsion G`, the above stated for commutative monoids

## Implementation

All torsion monoids are really groups (which is proven here as `monoid.is_torsion.group`), but since
the definition can be stated on monoids it is implemented on `monoid` to match other declarations in
the group theory library.

## Tags

periodic group, torsion subgroup, torsion abelian group

## Future work

* torsion-free groups
-/

variable {G : Type*}

namespace monoid

variables (G) [monoid G]

/-- A predicate on a monoid saying that all elements are of finite order. -/
@[to_additive "A predicate on an additive monoid saying that all elements are of finite order."]
def is_torsion := ∀ g : G, is_of_fin_order g

end monoid

open monoid

/-- Torsion monoids are really groups. -/
@[to_additive "Torsion additive monoids are really additive groups"]
noncomputable def is_torsion.group [monoid G] (tG : is_torsion G) : group G :=
{ inv := λ g, g ^ (order_of g - 1),
  mul_left_inv := λ g,
  begin
    erw [←pow_succ', tsub_add_cancel_of_le, pow_order_of_eq_one],
    exact order_of_pos' (tG g)
  end,
  ..‹monoid G› }

section group

variables [group G] {N : subgroup G}

/-- Subgroups of torsion groups are torsion groups. -/
@[to_additive "Subgroups of additive torsion groups are additive torsion groups."]
lemma is_torsion.subgroup (tG : is_torsion G) (H : subgroup G) : is_torsion H :=
λ h, (is_of_fin_order_iff_coe _ h).mpr $ tG h

/-- Quotient groups of torsion groups are torsion groups. -/
@[to_additive "Quotient groups of additive torsion groups are additive torsion groups."]
lemma is_torsion.quotient_group [nN : N.normal] (tG : is_torsion G) : is_torsion (G ⧸ N) :=
λ h, quotient_group.induction_on' h $ λ g, (tG g).quotient N g

/-- If a group exponent exists, the group is torsion. -/
@[to_additive exponent_exists.is_add_torsion
  "If a group exponent exists, the group is additively torsion."]
lemma exponent_exists.is_torsion (h : exponent_exists G) : is_torsion G := begin
  obtain ⟨n, npos, hn⟩ := h,
  intro g,
  exact (is_of_fin_order_iff_pow_eq_one g).mpr ⟨n, npos, hn g⟩,
end

/-- The group exponent exists for any bounded torsion group. -/
@[to_additive is_add_torsion.exponent_exists
  "The group exponent exists for any bounded additive torsion group."]
lemma is_torsion.exponent_exists
  (tG : is_torsion G) (bounded : (set.range (λ g : G, order_of g)).finite) :
  exponent_exists G :=
exponent_exists_iff_ne_zero.mpr $
  (exponent_ne_zero_iff_range_order_of_finite (λ g, order_of_pos' (tG g))).mpr bounded

/-- Finite groups are torsion groups. -/
@[to_additive is_add_torsion_of_fintype "Finite additive groups are additive torsion groups."]
lemma is_torsion_of_fintype [fintype G] : is_torsion G :=
exponent_exists.is_torsion $ exponent_exists_iff_ne_zero.mpr exponent_ne_zero_of_fintype

end group

section comm_monoid

variables (G) [comm_monoid G]

namespace comm_monoid

/--
The torsion submonoid of a commutative monoid.

(Note that by `monoid.is_torsion.group` torsion monoids are truthfully groups.)
-/
@[to_additive add_torsion "The torsion submonoid of an additive commutative monoid."]
def torsion : submonoid G :=
{ carrier := {x | is_of_fin_order x},
  one_mem' := is_of_fin_order_one,
  mul_mem' := λ _ _ hx hy, hx.mul hy }

variable {G}

/-- Torsion submonoids are torsion. -/
@[to_additive "Additive torsion submonoids are additively torsion."]
lemma torsion.is_torsion : is_torsion $ torsion G :=
λ ⟨_, n, npos, hn⟩,
  ⟨n, npos, subtype.ext $
    by rw [mul_left_iterate, _root_.mul_one, submonoid.coe_pow,
           subtype.coe_mk, submonoid.coe_one, (is_periodic_pt_mul_iff_pow_eq_one _).mp hn]⟩

end comm_monoid

open comm_monoid (torsion)

namespace monoid.is_torsion

variable {G}

/-- The torsion submonoid of a torsion monoid is `⊤`. -/
@[simp, to_additive "The additive torsion submonoid of an additive torsion monoid is `⊤`."]
lemma torsion_eq_top (tG : is_torsion G) : torsion G = ⊤ := by ext; tauto

/-- A torsion monoid is isomorphic to its torsion submonoid. -/
@[to_additive "An additive torsion monoid is isomorphic to its torsion submonoid.", simps]
def torsion_mul_equiv (tG : is_torsion G) : torsion G ≃* G :=
 (mul_equiv.submonoid_congr tG.torsion_eq_top).trans submonoid.top_equiv

end monoid.is_torsion

/-- Torsion submonoids of a torsion submonoid are isomorphic to the submonoid. -/
@[simp, to_additive add_comm_monoid.torsion.of_torsion
  "Additive torsion submonoids of an additive torsion submonoid are isomorphic to the submonoid."]
def torsion.of_torsion : (torsion (torsion G)) ≃* (torsion G) :=
monoid.is_torsion.torsion_mul_equiv comm_monoid.torsion.is_torsion

end comm_monoid

section comm_group

variables (G) [comm_group G]

/-- The torsion subgroup of an abelian group. -/
@[to_additive add_torsion "The torsion subgroup of an additive abelian group."]
def torsion : subgroup G := { comm_monoid.torsion G with inv_mem' := λ x, is_of_fin_order.inv }

/-- The torsion submonoid of an abelian group equals the torsion subgroup as a submonoid. -/
@[to_additive add_torsion_eq_add_torsion_submonoid
  "The additive torsion submonoid of an abelian group equals the torsion subgroup as a submonoid."]
lemma torsion_eq_torsion_submonoid : comm_monoid.torsion G = (torsion G).to_submonoid := rfl

end comm_group


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/

import field_theory.subfield
import field_theory.tower
import ring_theory.algebraic

/-!
# Intermediate fields

Let `L / K` be a field extension, given as an instance `algebra K L`.
This file defines the type of fields in between `K` and `L`, `intermediate_field K L`.
An `intermediate_field K L` is a subfield of `L` which contains (the image of) `K`,
i.e. it is a `subfield L` and a `subalgebra K L`.

## Main definitions

 * `intermediate_field K L` : the type of intermediate fields between `K` and `L`.

 * `subalgebra.to_intermediate_field`: turns a subalgebra closed under `⁻¹`
   into an intermediate field

 * `subfield.to_intermediate_field`: turns a subfield containing the image of `K`
   into an intermediate field

* `intermediate_field.map`: map an intermediate field along an `alg_hom`

## Implementation notes

Intermediate fields are defined with a structure extending `subfield` and `subalgebra`.
A `subalgebra` is closed under all operations except `⁻¹`,

## Tags
intermediate field, field extension
-/

open finite_dimensional
open_locale big_operators

variables (K L : Type*) [field K] [field L] [algebra K L]

/-- `S : intermediate_field K L` is a subset of `L` such that there is a field
tower `L / S / K`. -/
structure intermediate_field extends subalgebra K L :=
(neg_mem' : ∀ x ∈ carrier, -x ∈ carrier)
(inv_mem' : ∀ x ∈ carrier, x⁻¹ ∈ carrier)

/-- Reinterpret an `intermediate_field` as a `subalgebra`. -/
add_decl_doc intermediate_field.to_subalgebra

variables {K L} (S : intermediate_field K L)

namespace intermediate_field

/-- Reinterpret an `intermediate_field` as a `subfield`. -/
def to_subfield : subfield L := { ..S.to_subalgebra, ..S }

instance : set_like (intermediate_field K L) L :=
⟨λ S, S.to_subalgebra.carrier, by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨h⟩, congr, }⟩

@[simp]
lemma mem_carrier {s : intermediate_field K L} {x : L} : x ∈ s.carrier ↔ x ∈ s := iff.rfl

/-- Two intermediate fields are equal if they have the same elements. -/
@[ext] theorem ext {S T : intermediate_field K L} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T :=
set_like.ext h

@[simp] lemma coe_to_subalgebra : (S.to_subalgebra : set L) = S := rfl

@[simp] lemma coe_to_subfield : (S.to_subfield : set L) = S := rfl

@[simp] lemma mem_mk (s : set L) (hK : ∀ x, algebra_map K L x ∈ s)
  (ho hm hz ha hn hi) (x : L) :
  x ∈ intermediate_field.mk (subalgebra.mk s ho hm hz ha hK) hn hi ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subalgebra (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subalgebra ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subfield (s : intermediate_field K L) (x : L) :
  x ∈ s.to_subfield ↔ x ∈ s := iff.rfl

/-- An intermediate field contains the image of the smaller field. -/
theorem algebra_map_mem (x : K) : algebra_map K L x ∈ S :=
S.algebra_map_mem' x

/-- An intermediate field contains the ring's 1. -/
theorem one_mem : (1 : L) ∈ S := S.one_mem'

/-- An intermediate field contains the ring's 0. -/
theorem zero_mem : (0 : L) ∈ S := S.zero_mem'

/-- An intermediate field is closed under multiplication. -/
theorem mul_mem : ∀ {x y : L}, x ∈ S → y ∈ S → x * y ∈ S := S.mul_mem'

/-- An intermediate field is closed under scalar multiplication. -/

/-- An intermediate field is closed under addition. -/
theorem add_mem : ∀ {x y : L}, x ∈ S → y ∈ S → x + y ∈ S := S.add_mem'

/-- An intermediate field is closed under subtraction -/
theorem sub_mem {x y : L} (hx : x ∈ S) (hy : y ∈ S) : x - y ∈ S :=
S.to_subfield.sub_mem hx hy

/-- An intermediate field is closed under negation. -/
theorem neg_mem : ∀ {x : L}, x ∈ S → -x ∈ S := S.neg_mem'

/-- An intermediate field is closed under inverses. -/
theorem inv_mem : ∀ {x : L}, x ∈ S → x⁻¹ ∈ S := S.inv_mem'

/-- An intermediate field is closed under division. -/
theorem div_mem {x y : L} (hx : x ∈ S) (hy : y ∈ S) : x / y ∈ S :=
S.to_subfield.div_mem hx hy

/-- Product of a list of elements in an intermediate_field is in the intermediate_field. -/
lemma list_prod_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.prod ∈ S :=
S.to_subfield.list_prod_mem

/-- Sum of a list of elements in an intermediate field is in the intermediate_field. -/
lemma list_sum_mem {l : list L} : (∀ x ∈ l, x ∈ S) → l.sum ∈ S :=
S.to_subfield.list_sum_mem

/-- Product of a multiset of elements in an intermediate field is in the intermediate_field. -/
lemma multiset_prod_mem (m : multiset L) :
  (∀ a ∈ m, a ∈ S) → m.prod ∈ S :=
S.to_subfield.multiset_prod_mem m

/-- Sum of a multiset of elements in a `intermediate_field` is in the `intermediate_field`. -/
lemma multiset_sum_mem (m : multiset L) :
  (∀ a ∈ m, a ∈ S) → m.sum ∈ S :=
S.to_subfield.multiset_sum_mem m

/-- Product of elements of an intermediate field indexed by a `finset` is in the intermediate_field.
-/
lemma prod_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∏ i in t, f i ∈ S :=
S.to_subfield.prod_mem h

/-- Sum of elements in a `intermediate_field` indexed by a `finset` is in the `intermediate_field`.
-/
lemma sum_mem {ι : Type*} {t : finset ι} {f : ι → L} (h : ∀ c ∈ t, f c ∈ S) :
  ∑ i in t, f i ∈ S :=
S.to_subfield.sum_mem h

lemma pow_mem {x : L} (hx : x ∈ S) : ∀ (n : ℤ), x^n ∈ S
| (n : ℕ) := by { rw zpow_coe_nat, exact S.to_subfield.pow_mem hx _, }
| -[1+ n] := by { rw [zpow_neg_succ_of_nat],
    exact S.to_subfield.inv_mem (S.to_subfield.pow_mem hx _) }

lemma zsmul_mem {x : L} (hx : x ∈ S) (n : ℤ) :
  n • x ∈ S := S.to_subfield.zsmul_mem hx n

lemma coe_int_mem (n : ℤ) : (n : L) ∈ S :=
by simp only [← zsmul_one, zsmul_mem, one_mem]

end intermediate_field

/-- Turn a subalgebra closed under inverses into an intermediate field -/
def subalgebra.to_intermediate_field (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  intermediate_field K L :=
{ neg_mem' := λ x, S.neg_mem,
  inv_mem' := inv_mem,
  .. S }

@[simp] lemma to_subalgebra_to_intermediate_field
  (S : subalgebra K L) (inv_mem : ∀ x ∈ S, x⁻¹ ∈ S) :
  (S.to_intermediate_field inv_mem).to_subalgebra = S :=
by { ext, refl }

@[simp] lemma to_intermediate_field_to_subalgebra
  (S : intermediate_field K L) (inv_mem : ∀ x ∈ S.to_subalgebra, x⁻¹ ∈ S) :
  S.to_subalgebra.to_intermediate_field inv_mem = S :=
by { ext, refl }

/-- Turn a subfield of `L` containing the image of `K` into an intermediate field -/
def subfield.to_intermediate_field (S : subfield L)
  (algebra_map_mem : ∀ x, algebra_map K L x ∈ S) :
  intermediate_field K L :=
{ algebra_map_mem' := algebra_map_mem,
  .. S }

namespace intermediate_field

/-- An intermediate field inherits a field structure -/
instance to_field : field S :=
S.to_subfield.to_field

@[simp, norm_cast] lemma coe_add (x y : S) : (↑(x + y) : L) = ↑x + ↑y := rfl
@[simp, norm_cast] lemma coe_neg (x : S) : (↑(-x) : L) = -↑x := rfl
@[simp, norm_cast] lemma coe_mul (x y : S) : (↑(x * y) : L) = ↑x * ↑y := rfl
@[simp, norm_cast] lemma coe_inv (x : S) : (↑(x⁻¹) : L) = (↑x)⁻¹ := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : S) : L) = 0 := rfl
@[simp, norm_cast] lemma coe_one : ((1 : S) : L) = 1 := rfl
@[simp, norm_cast] lemma coe_pow (x : S) (n : ℕ) : (↑(x ^ n) : L) = ↑x ^ n :=
begin
  induction n with n ih,
  { simp },
  { simp [pow_succ, ih] }
end

/-! `intermediate_field`s inherit structure from their `subalgebra` coercions. -/

instance module' {R} [semiring R] [has_scalar R K] [module R L] [is_scalar_tower R K L] :
  module R S :=
S.to_subalgebra.module'
instance module : module K S := S.to_subalgebra.module

instance is_scalar_tower {R} [semiring R] [has_scalar R K] [module R L]
  [is_scalar_tower R K L] :
  is_scalar_tower R K S :=
S.to_subalgebra.is_scalar_tower

@[simp] lemma coe_smul {R} [semiring R] [has_scalar R K] [module R L] [is_scalar_tower R K L]
  (r : R) (x : S) :
  ↑(r • x) = (r • x : L) := rfl

instance algebra' {K'} [comm_semiring K'] [has_scalar K' K] [algebra K' L]
  [is_scalar_tower K' K L] :
  algebra K' S :=
S.to_subalgebra.algebra'
instance algebra : algebra K S := S.to_subalgebra.algebra

instance to_algebra {R : Type*} [semiring R] [algebra L R] : algebra S R :=
S.to_subalgebra.to_algebra

instance is_scalar_tower_bot {R : Type*} [semiring R] [algebra L R] :
  is_scalar_tower S L R :=
is_scalar_tower.subalgebra _ _ _ S.to_subalgebra

instance is_scalar_tower_mid {R : Type*} [semiring R] [algebra L R] [algebra K R]
  [is_scalar_tower K L R] : is_scalar_tower K S R :=
is_scalar_tower.subalgebra' _ _ _ S.to_subalgebra

/-- Specialize `is_scalar_tower_mid` to the common case where the top field is `L` -/
instance is_scalar_tower_mid' : is_scalar_tower K S L :=
S.is_scalar_tower_mid

variables {L' : Type*} [field L'] [algebra K L']

/-- If `f : L →+* L'` fixes `K`, `S.map f` is the intermediate field between `L'` and `K`
such that `x ∈ S ↔ f x ∈ S.map f`. -/
def map (f : L →ₐ[K] L') : intermediate_field K L' :=
{ inv_mem' := by { rintros _ ⟨x, hx, rfl⟩, exact ⟨x⁻¹, S.inv_mem hx, f.map_inv x⟩ },
  neg_mem' := λ x hx, (S.to_subalgebra.map f).neg_mem hx,
  .. S.to_subalgebra.map f}

/-- The embedding from an intermediate field of `L / K` to `L`. -/
def val : S →ₐ[K] L :=
S.to_subalgebra.val

@[simp] theorem coe_val : ⇑S.val = coe := rfl

@[simp] lemma val_mk {x : L} (hx : x ∈ S) : S.val ⟨x, hx⟩ = x := rfl

variables {S}

lemma to_subalgebra_injective {S S' : intermediate_field K L}
  (h : S.to_subalgebra = S'.to_subalgebra) : S = S' :=
by { ext, rw [← mem_to_subalgebra, ← mem_to_subalgebra, h] }

variables (S)

lemma set_range_subset : set.range (algebra_map K L) ⊆ S :=
S.to_subalgebra.range_subset

lemma field_range_le : (algebra_map K L).field_range ≤ S.to_subfield :=
λ x hx, S.to_subalgebra.range_subset (by rwa [set.mem_range, ← ring_hom.mem_field_range])

@[simp] lemma to_subalgebra_le_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra ≤ S'.to_subalgebra ↔ S ≤ S' := iff.rfl

@[simp] lemma to_subalgebra_lt_to_subalgebra {S S' : intermediate_field K L} :
  S.to_subalgebra < S'.to_subalgebra ↔ S < S' := iff.rfl

variables {S}

section tower

/-- Lift an intermediate_field of an intermediate_field -/
def lift1 {F : intermediate_field K L} (E : intermediate_field K F) : intermediate_field K L :=
  map E (val F)

/-- Lift an intermediate_field of an intermediate_field -/
def lift2 {F : intermediate_field K L} (E : intermediate_field F L) : intermediate_field K L :=
{ carrier := E.carrier,
  zero_mem' := zero_mem E,
  add_mem' := λ x y, add_mem E,
  neg_mem' := λ x, neg_mem E,
  one_mem' := one_mem E,
  mul_mem' := λ x y, mul_mem E,
  inv_mem' := λ x, inv_mem E,
  algebra_map_mem' := λ x, algebra_map_mem E (algebra_map K F x) }

instance has_lift1 {F : intermediate_field K L} :
  has_lift_t (intermediate_field K F) (intermediate_field K L) := ⟨lift1⟩

instance has_lift2 {F : intermediate_field K L} :
  has_lift_t (intermediate_field F L) (intermediate_field K L) := ⟨lift2⟩

@[simp] lemma mem_lift2 {F : intermediate_field K L} {E : intermediate_field F L} {x : L} :
  x ∈ (↑E : intermediate_field K L) ↔ x ∈ E := iff.rfl

/-- This was formerly an instance called `lift2_alg`, but an instance above already provides it. -/
example {F : intermediate_field K L} {E : intermediate_field F L} : algebra K E :=
by apply_instance

lemma lift2_algebra_map {F : intermediate_field K L} {E : intermediate_field F L} :
  algebra_map K E = (algebra_map F E).comp (algebra_map K F) := rfl

instance lift2_tower {F : intermediate_field K L} {E : intermediate_field F L} :
  is_scalar_tower K F E :=
E.is_scalar_tower

/-- `lift2` is isomorphic to the original `intermediate_field`. -/
def lift2_alg_equiv {F : intermediate_field K L} (E : intermediate_field F L) :
  (↑E : intermediate_field K L) ≃ₐ[K] E :=
alg_equiv.refl

end tower

section finite_dimensional

variables (F E : intermediate_field K L)

instance finite_dimensional_left [finite_dimensional K L] : finite_dimensional K F :=
finite_dimensional.finite_dimensional_submodule F.to_subalgebra.to_submodule

instance finite_dimensional_right [finite_dimensional K L] : finite_dimensional F L :=
right K F L

@[simp] lemma dim_eq_dim_subalgebra :
  module.rank K F.to_subalgebra = module.rank K F := rfl

@[simp] lemma finrank_eq_finrank_subalgebra :
  finrank K F.to_subalgebra = finrank K F := rfl

variables {F} {E}

@[simp] lemma to_subalgebra_eq_iff : F.to_subalgebra = E.to_subalgebra ↔ F = E :=
by { rw [set_like.ext_iff, set_like.ext'_iff, set.ext_iff], refl }

lemma eq_of_le_of_finrank_le [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank K E ≤ finrank K F) : F = E :=
to_subalgebra_injective $ subalgebra.to_submodule_injective $ eq_of_le_of_finrank_le h_le h_finrank

lemma eq_of_le_of_finrank_eq [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank K F = finrank K E) : F = E :=
eq_of_le_of_finrank_le h_le h_finrank.ge

lemma eq_of_le_of_finrank_le' [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank F L ≤ finrank E L) : F = E :=
begin
  apply eq_of_le_of_finrank_le h_le,
  have h1 := finrank_mul_finrank K F L,
  have h2 := finrank_mul_finrank K E L,
  have h3 : 0 < finrank E L := finrank_pos,
  nlinarith,
end

lemma eq_of_le_of_finrank_eq' [finite_dimensional K L] (h_le : F ≤ E)
  (h_finrank : finrank F L = finrank E L) : F = E :=
eq_of_le_of_finrank_le' h_le h_finrank.le

end finite_dimensional

end intermediate_field

/-- If `L/K` is algebraic, the `K`-subalgebras of `L` are all fields.  -/
def subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L) :
  subalgebra K L ≃o intermediate_field K L :=
{ to_fun := λ S, S.to_intermediate_field (λ x hx, S.inv_mem_of_algebraic (alg (⟨x, hx⟩ : S))),
  inv_fun := λ S, S.to_subalgebra,
  left_inv := λ S, to_subalgebra_to_intermediate_field _ _,
  right_inv := λ S, to_intermediate_field_to_subalgebra _ _,
  map_rel_iff' := λ S S', iff.rfl }

@[simp] lemma mem_subalgebra_equiv_intermediate_field (alg : algebra.is_algebraic K L)
  {S : subalgebra K L} {x : L} :
  x ∈ subalgebra_equiv_intermediate_field alg S ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_subalgebra_equiv_intermediate_field_symm (alg : algebra.is_algebraic K L)
  {S : intermediate_field K L} {x : L} :
  x ∈ (subalgebra_equiv_intermediate_field alg).symm S ↔ x ∈ S :=
iff.rfl


/-
Copyright (c) 2022 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.star.pi
import algebra.star.prod
import topology.algebra.group

/-!
# Continuity of `star`

This file defines the `has_continuous_star` typeclass, along with instances on `pi`, `prod`,
`mul_opposite`, and `units`.
-/

open_locale filter topological_space
open filter

universes u

variables {ι α R S : Type*}

/-- Basic hypothesis to talk about a topological space with a continuous `star` operator. -/
class has_continuous_star (R : Type u) [topological_space R] [has_star R] : Prop :=
(continuous_star : continuous (star : R → R))

export has_continuous_star (continuous_star)

section continuity

variables [topological_space R] [has_star R] [has_continuous_star R]

lemma continuous_on_star {s : set R} : continuous_on star s :=
continuous_star.continuous_on

lemma continuous_within_at_star {s : set R} {x : R} : continuous_within_at star s x :=
continuous_star.continuous_within_at

lemma continuous_at_star {x : R} : continuous_at star x :=
continuous_star.continuous_at

lemma tendsto_star (a : R) : tendsto star (𝓝 a) (𝓝 (star a)) :=
continuous_at_star

lemma filter.tendsto.star {f : α → R} {l : filter α} {y : R} (h : tendsto f l (𝓝 y)) :
  tendsto (λ x, star (f x)) l (𝓝 (star y)) :=
(continuous_star.tendsto y).comp h

variables [topological_space α] {f : α → R} {s : set α} {x : α}

@[continuity]
lemma continuous.star (hf : continuous f) : continuous (λ x, star (f x)) :=
continuous_star.comp hf

lemma continuous_at.star (hf : continuous_at f x) : continuous_at (λ x, star (f x)) x :=
continuous_at_star.comp hf

lemma continuous_on.star (hf : continuous_on f s) : continuous_on (λ x, star (f x)) s :=
continuous_star.comp_continuous_on hf

lemma continuous_within_at.star (hf : continuous_within_at f s x) :
  continuous_within_at (λ x, star (f x)) s x :=
hf.star

/-- The star operation bundled as a continuous map. -/
@[simps] def star_continuous_map : C(R, R) := ⟨star, continuous_star⟩

end continuity

section instances

instance [has_star R] [has_star S] [topological_space R] [topological_space S]
  [has_continuous_star R] [has_continuous_star S] : has_continuous_star (R × S) :=
⟨(continuous_star.comp continuous_fst).prod_mk (continuous_star.comp continuous_snd)⟩

instance {C : ι → Type*} [∀ i, topological_space (C i)]
  [∀ i, has_star (C i)] [∀ i, has_continuous_star (C i)] : has_continuous_star (Π i, C i) :=
{ continuous_star := continuous_pi (λ i, continuous.star (continuous_apply i)) }

instance [has_star R] [topological_space R] [has_continuous_star R] : has_continuous_star Rᵐᵒᵖ :=
⟨mul_opposite.continuous_op.comp $ mul_opposite.continuous_unop.star⟩

instance [monoid R] [star_semigroup R] [topological_space R] [has_continuous_star R] :
  has_continuous_star Rˣ :=
⟨continuous_induced_rng units.continuous_embed_product.star⟩

end instances


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import data.finset.basic

/-!
# UV-compressions

This file defines UV-compression. It is an operation on a set family that reduces its shadow.

UV-compressing `a : α` along `u v : α` means replacing `a` by `(a ⊔ u) \ v` if `a` and `u` are
disjoint and `v ≤ a`. In some sense, it's moving `a` from `v` to `u`.

UV-compressions are immensely useful to prove the Kruskal-Katona theorem. The idea is that
compressing a set family might decrease the size of its shadow, so iterated compressions hopefully
minimise the shadow.

## Main declarations

* `uv.compress`: `compress u v a` is `a` compressed along `u` and `v`.
* `uv.compression`: `compression u v s` is the compression of the set family `s` along `u` and `v`.
  It is the compressions of the elements of `s` whose compression is not already in `s` along with
  the element whose compression is already in `s`. This way of splitting into what moves and what
  does not ensures the compression doesn't squash the set family, which is proved by
  `uv.card_compress`.

## Notation

`𝓒` (typed with `\MCC`) is notation for `uv.compression` in locale `finset_family`.

## Notes

Even though our emphasis is on `finset α`, we define UV-compressions more generally in a generalized
boolean algebra, so that one can use it for `set α`.

## TODO

Prove that compressing reduces the size of shadow. This result and some more already exist on the
branch `combinatorics`.

## References

* https://github.com/b-mehta/maths-notes/blob/master/iii/mich/combinatorics.pdf

## Tags

compression, UV-compression, shadow
-/

open finset

variable {α : Type*}

/-- UV-compression is injective on the elements it moves. See `uv.compress`. -/
lemma sup_sdiff_inj_on [generalized_boolean_algebra α] (u v : α) :
  {x | disjoint u x ∧ v ≤ x}.inj_on (λ x, (x ⊔ u) \ v) :=
begin
  rintro a ha b hb hab,
  have h : (a ⊔ u) \ v \ u ⊔ v = (b ⊔ u) \ v \ u ⊔ v,
  { dsimp at hab,
    rw hab },
  rwa [sdiff_sdiff_comm, ha.1.symm.sup_sdiff_cancel_right, sdiff_sdiff_comm,
    hb.1.symm.sup_sdiff_cancel_right, sdiff_sup_cancel ha.2, sdiff_sup_cancel hb.2] at h,
end

-- The namespace is here to distinguish from other compressions.
namespace uv

/-! ### UV-compression in generalized boolean algebras -/

section generalized_boolean_algebra
variables [generalized_boolean_algebra α] [decidable_rel (@disjoint α _ _)]
  [decidable_rel ((≤) : α → α → Prop)] {s : finset α} {u v a b : α}

/-- To UV-compress `a`, if it doesn't touch `U` and does contain `V`, we remove `V` and
put `U` in. We'll only really use this when `|U| = |V|` and `U ∩ V = ∅`. -/
def compress (u v a : α) : α := if disjoint u a ∧ v ≤ a then (a ⊔ u) \ v else a

/-- To UV-compress a set family, we compress each of its elements, except that we don't want to
reduce the cardinality, so we keep all elements whose compression is already present. -/
def compression (u v : α) (s : finset α) :=
s.filter (λ a, compress u v a ∈ s) ∪ (s.image $ compress u v).filter (λ a, a ∉ s)

localized "notation `𝓒 ` := uv.compression" in finset_family

/-- `is_compressed u v s` expresses that `s` is UV-compressed. -/
def is_compressed (u v : α) (s : finset α) := 𝓒 u v s = s

/-- `a` is in the UV-compressed family iff it's in the original and its compression is in the
original, or it's not in the original but it's the compression of something in the original. -/
lemma mem_compression :
  a ∈ 𝓒 u v s ↔ a ∈ s ∧ compress u v a ∈ s ∨ a ∉ s ∧ ∃ b ∈ s, compress u v b = a :=
by simp_rw [compression, mem_union, mem_filter, mem_image, and_comm (a ∉ s)]

@[simp] lemma compress_self (u a : α) : compress u u a = a :=
begin
  unfold compress,
  split_ifs,
  { exact h.1.symm.sup_sdiff_cancel_right },
  { refl }
end

@[simp] lemma compression_self (u : α) (s : finset α) : 𝓒 u u s = s :=
begin
  unfold compression,
  convert union_empty s,
  { ext a,
    rw [mem_filter, compress_self, and_self] },
  { refine eq_empty_of_forall_not_mem (λ a ha, _),
    simp_rw [mem_filter, mem_image, compress_self] at ha,
    obtain ⟨⟨b, hb, rfl⟩, hb'⟩ := ha,
    exact hb' hb }
end

/-- Any family is compressed along two identical elements. -/
lemma is_compressed_self (u : α) (s : finset α) : is_compressed u u s := compression_self u s

lemma compress_disjoint (u v : α) :
  disjoint (s.filter (λ a, compress u v a ∈ s)) ((s.image $ compress u v).filter (λ a, a ∉ s)) :=
disjoint_left.2 $ λ a ha₁ ha₂, (mem_filter.1 ha₂).2 (mem_filter.1 ha₁).1

/-- Compressing an element is idempotent. -/
@[simp] lemma compress_idem (u v a : α) : compress u v (compress u v a) = compress u v a :=
begin
  unfold compress,
  split_ifs with h h',
  { rw [le_sdiff_iff.1 h'.2, sdiff_bot, sdiff_bot, sup_assoc, sup_idem] },
  { refl },
  { refl }
end

lemma compress_mem_compression (ha : a ∈ s) : compress u v a ∈ 𝓒 u v s :=
begin
  rw mem_compression,
  by_cases compress u v a ∈ s,
  { rw compress_idem,
    exact or.inl ⟨h, h⟩ },
  { exact or.inr ⟨h, a, ha, rfl⟩ }
end

-- This is a special case of `compress_mem_compression` once we have `compression_idem`.
lemma compress_mem_compression_of_mem_compression (ha : a ∈ 𝓒 u v s) : compress u v a ∈ 𝓒 u v s :=
begin
  rw mem_compression at ⊢ ha,
  simp only [compress_idem, exists_prop],
  obtain ⟨_, ha⟩ | ⟨_, b, hb, rfl⟩ := ha,
  { exact or.inl ⟨ha, ha⟩ },
  { exact or.inr ⟨by rwa compress_idem, b, hb, (compress_idem _ _ _).symm⟩ }
end

/-- Compressing a family is idempotent. -/
@[simp] lemma compression_idem (u v : α) (s : finset α) : 𝓒 u v (𝓒 u v s) = 𝓒 u v s :=
begin
  have h : filter (λ a, compress u v a ∉ 𝓒 u v s) (𝓒 u v s) = ∅ :=
    filter_false_of_mem (λ a ha h, h $ compress_mem_compression_of_mem_compression ha),
  rw [compression, image_filter, h, image_empty, ←h],
  exact filter_union_filter_neg_eq _ (compression u v s),
end

/-- Compressing a family doesn't change its size. -/
lemma card_compression (u v : α) (s : finset α) : (𝓒 u v s).card = s.card :=
begin
  rw [compression, card_disjoint_union (compress_disjoint _ _), image_filter, card_image_of_inj_on,
    ←card_disjoint_union, filter_union_filter_neg_eq],
  { rw disjoint_iff_inter_eq_empty,
    exact filter_inter_filter_neg_eq _ _ },
  intros a ha b hb hab,
  dsimp at hab,
  rw [mem_coe, mem_filter, function.comp_app] at ha hb,
  rw compress at ha hab,
  split_ifs at ha hab with has,
  { rw compress at hb hab,
    split_ifs at hb hab with hbs,
    { exact sup_sdiff_inj_on u v has hbs hab },
    { exact (hb.2 hb.1).elim } },
  { exact (ha.2 ha.1).elim }
end

/-- If `a` is in the family compression and can be compressed, then its compression is in the
original family. -/
lemma sup_sdiff_mem_of_mem_compression (ha : a ∈ 𝓒 u v s) (hva : v ≤ a) (hua : disjoint u a) :
  (a ⊔ u) \ v ∈ s :=
begin
  rw [mem_compression, compress_of_disjoint_of_le hua hva] at ha,
  obtain ⟨_, ha⟩ | ⟨_, b, hb, rfl⟩ := ha,
  { exact ha },
  have hu : u = ⊥,
  { suffices : disjoint u (u \ v),
    { rwa [(hua.mono_right hva).sdiff_eq_left, disjoint_self] at this },
    refine hua.mono_right _,
    rw [←compress_idem, compress_of_disjoint_of_le hua hva],
    exact sdiff_le_sdiff_right le_sup_right },
  have hv : v = ⊥,
  { rw ←disjoint_self,
    apply disjoint.mono_right hva,
    rw [←compress_idem, compress_of_disjoint_of_le hua hva],
    exact disjoint_sdiff_self_right },
  rwa [hu, hv, compress_self, sup_bot_eq, sdiff_bot],
end

/-- If `a` is in the `u, v`-compression but `v ≤ a`, then `a` must have been in the original
family. -/
lemma mem_of_mem_compression (ha : a ∈ 𝓒 u v s) (hva : v ≤ a) (hvu : v = ⊥ → u = ⊥) : a ∈ s :=
begin
  rw mem_compression at ha,
  obtain ha | ⟨_, b, hb, h⟩ := ha,
  { exact ha.1 },
  unfold compress at h,
  split_ifs at h,
  { rw [←h, le_sdiff_iff] at hva,
    rw [hvu hva, hva, sup_bot_eq, sdiff_bot] at h,
    rwa ←h },
  { rwa ←h }
end

end generalized_boolean_algebra

/-! ### UV-compression on finsets -/

open_locale finset_family

variables [decidable_eq α] {𝒜 : finset (finset α)} {U V A : finset α}

/-- Compressing a finset doesn't change its size. -/
lemma card_compress (hUV : U.card = V.card) (A : finset α) : (compress U V A).card = A.card :=
begin
  unfold compress,
  split_ifs,
  { rw [card_sdiff (h.2.trans le_sup_left), sup_eq_union, card_disjoint_union h.1.symm, hUV,
    add_tsub_cancel_right] },
  { refl }
end

end uv


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad

! This file was ported from Lean 3 source module data.int.lemmas
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Function
import Mathbin.Data.Int.Order.Lemmas
import Mathbin.Data.Int.Bitwise
import Mathbin.Data.Nat.Cast.Basic
import Mathbin.Data.Nat.Order.Lemmas

/-!
# Miscellaneous lemmas about the integers

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

This file contains lemmas about integers, which require further imports than
`data.int.basic` or `data.int.order`.

-/

open Nat

namespace Int

#print Int.le_coe_nat_sub /-
theorem le_coe_nat_sub (m n : ℕ) : (m - n : ℤ) ≤ ↑(m - n : ℕ) :=
  by
  by_cases h : m ≥ n
  · exact le_of_eq (Int.ofNat_sub h).symm
  · simp [le_of_not_ge h, coe_nat_le]
#align int.le_coe_nat_sub Int.le_coe_nat_sub
-/

/-! ### succ and pred -/

#print Int.succ_coe_nat_pos /-
@[simp]
theorem succ_coe_nat_pos (n : ℕ) : 0 < (n : ℤ) + 1 :=
  lt_add_one_iff.mpr (by simp)
#align int.succ_coe_nat_pos Int.succ_coe_nat_pos
-/

/-! ### nat abs -/

variable {a b : ℤ} {n : ℕ}

/- warning: int.nat_abs_eq_iff_sq_eq -> Int.natAbs_eq_iff_sq_eq is a dubious translation:
lean 3 declaration is
  forall {a : Int} {b : Int}, Iff (Eq.{1} Nat (Int.natAbs a) (Int.natAbs b)) (Eq.{1} Int (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) a (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) b (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))))
but is expected to have type
  forall {a : Int} {b : Int}, Iff (Eq.{1} Nat (Int.natAbs a) (Int.natAbs b)) (Eq.{1} Int (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) a (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) b (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))))
Case conversion may be inaccurate. Consider using '#align int.nat_abs_eq_iff_sq_eq Int.natAbs_eq_iff_sq_eqₓ'. -/
theorem natAbs_eq_iff_sq_eq {a b : ℤ} : a.natAbs = b.natAbs ↔ a ^ 2 = b ^ 2 :=
  by
  rw [sq, sq]
  exact nat_abs_eq_iff_mul_self_eq
#align int.nat_abs_eq_iff_sq_eq Int.natAbs_eq_iff_sq_eq

/- warning: int.nat_abs_lt_iff_sq_lt -> Int.natAbs_lt_iff_sq_lt is a dubious translation:
lean 3 declaration is
  forall {a : Int} {b : Int}, Iff (LT.lt.{0} Nat Nat.hasLt (Int.natAbs a) (Int.natAbs b)) (LT.lt.{0} Int Int.hasLt (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) a (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) b (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))))
but is expected to have type
  forall {a : Int} {b : Int}, Iff (LT.lt.{0} Nat instLTNat (Int.natAbs a) (Int.natAbs b)) (LT.lt.{0} Int Int.instLTInt (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) a (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) b (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))))
Case conversion may be inaccurate. Consider using '#align int.nat_abs_lt_iff_sq_lt Int.natAbs_lt_iff_sq_ltₓ'. -/
theorem natAbs_lt_iff_sq_lt {a b : ℤ} : a.natAbs < b.natAbs ↔ a ^ 2 < b ^ 2 :=
  by
  rw [sq, sq]
  exact nat_abs_lt_iff_mul_self_lt
#align int.nat_abs_lt_iff_sq_lt Int.natAbs_lt_iff_sq_lt

/- warning: int.nat_abs_le_iff_sq_le -> Int.natAbs_le_iff_sq_le is a dubious translation:
lean 3 declaration is
  forall {a : Int} {b : Int}, Iff (LE.le.{0} Nat Nat.hasLe (Int.natAbs a) (Int.natAbs b)) (LE.le.{0} Int Int.hasLe (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) a (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.monoid)) b (OfNat.ofNat.{0} Nat 2 (OfNat.mk.{0} Nat 2 (bit0.{0} Nat Nat.hasAdd (One.one.{0} Nat Nat.hasOne))))))
but is expected to have type
  forall {a : Int} {b : Int}, Iff (LE.le.{0} Nat instLENat (Int.natAbs a) (Int.natAbs b)) (LE.le.{0} Int Int.instLEInt (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) a (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))) (HPow.hPow.{0, 0, 0} Int Nat Int (instHPow.{0, 0} Int Nat (Monoid.Pow.{0} Int Int.instMonoidInt)) b (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))))
Case conversion may be inaccurate. Consider using '#align int.nat_abs_le_iff_sq_le Int.natAbs_le_iff_sq_leₓ'. -/
theorem natAbs_le_iff_sq_le {a b : ℤ} : a.natAbs ≤ b.natAbs ↔ a ^ 2 ≤ b ^ 2 :=
  by
  rw [sq, sq]
  exact nat_abs_le_iff_mul_self_le
#align int.nat_abs_le_iff_sq_le Int.natAbs_le_iff_sq_le

#print Int.natAbs_inj_of_nonneg_of_nonneg /-
theorem natAbs_inj_of_nonneg_of_nonneg {a b : ℤ} (ha : 0 ≤ a) (hb : 0 ≤ b) :
    natAbs a = natAbs b ↔ a = b := by rw [← sq_eq_sq ha hb, ← nat_abs_eq_iff_sq_eq]
#align int.nat_abs_inj_of_nonneg_of_nonneg Int.natAbs_inj_of_nonneg_of_nonneg
-/

#print Int.natAbs_inj_of_nonpos_of_nonpos /-
theorem natAbs_inj_of_nonpos_of_nonpos {a b : ℤ} (ha : a ≤ 0) (hb : b ≤ 0) :
    natAbs a = natAbs b ↔ a = b := by
  simpa only [Int.natAbs_neg, neg_inj] using
    nat_abs_inj_of_nonneg_of_nonneg (neg_nonneg_of_nonpos ha) (neg_nonneg_of_nonpos hb)
#align int.nat_abs_inj_of_nonpos_of_nonpos Int.natAbs_inj_of_nonpos_of_nonpos
-/

#print Int.natAbs_inj_of_nonneg_of_nonpos /-
theorem natAbs_inj_of_nonneg_of_nonpos {a b : ℤ} (ha : 0 ≤ a) (hb : b ≤ 0) :
    natAbs a = natAbs b ↔ a = -b := by
  simpa only [Int.natAbs_neg] using nat_abs_inj_of_nonneg_of_nonneg ha (neg_nonneg_of_nonpos hb)
#align int.nat_abs_inj_of_nonneg_of_nonpos Int.natAbs_inj_of_nonneg_of_nonpos
-/

#print Int.natAbs_inj_of_nonpos_of_nonneg /-
theorem natAbs_inj_of_nonpos_of_nonneg {a b : ℤ} (ha : a ≤ 0) (hb : 0 ≤ b) :
    natAbs a = natAbs b ↔ -a = b := by
  simpa only [Int.natAbs_neg] using nat_abs_inj_of_nonneg_of_nonneg (neg_nonneg_of_nonpos ha) hb
#align int.nat_abs_inj_of_nonpos_of_nonneg Int.natAbs_inj_of_nonpos_of_nonneg
-/

section Intervals

open Set

#print Int.strictMonoOn_natAbs /-
theorem strictMonoOn_natAbs : StrictMonoOn natAbs (Ici 0) := fun a ha b hb hab =>
  natAbs_lt_natAbs_of_nonneg_of_lt ha hab
#align int.strict_mono_on_nat_abs Int.strictMonoOn_natAbs
-/

#print Int.strictAntiOn_natAbs /-
theorem strictAntiOn_natAbs : StrictAntiOn natAbs (Iic 0) := fun a ha b hb hab => by
  simpa [Int.natAbs_neg] using
    nat_abs_lt_nat_abs_of_nonneg_of_lt (right.nonneg_neg_iff.mpr hb) (neg_lt_neg_iff.mpr hab)
#align int.strict_anti_on_nat_abs Int.strictAntiOn_natAbs
-/

#print Int.injOn_natAbs_Ici /-
theorem injOn_natAbs_Ici : InjOn natAbs (Ici 0) :=
  strictMonoOn_natAbs.InjOn
#align int.inj_on_nat_abs_Ici Int.injOn_natAbs_Ici
-/

#print Int.injOn_natAbs_Iic /-
theorem injOn_natAbs_Iic : InjOn natAbs (Iic 0) :=
  strictAntiOn_natAbs.InjOn
#align int.inj_on_nat_abs_Iic Int.injOn_natAbs_Iic
-/

end Intervals

/-! ### to_nat -/

#print Int.toNat_of_nonpos /-
theorem toNat_of_nonpos : ∀ {z : ℤ}, z ≤ 0 → z.toNat = 0
  | 0, _ => rfl
  | (n + 1 : ℕ), h => (h.not_lt (by simp)).elim
  | -[n+1], _ => rfl
#align int.to_nat_of_nonpos Int.toNat_of_nonpos
-/

/-! ### bitwise ops

This lemma is orphaned from `data.int.bitwise` as it also requires material from `data.int.order`.
-/

attribute [local simp] Int.zero_div

#print Int.div2_bit /-
@[simp]
theorem div2_bit (b n) : div2 (bit b n) = n :=
  by
  rw [bit_val, div2_val, add_comm, Int.add_mul_ediv_left, (_ : (_ / 2 : ℤ) = 0), zero_add]
  cases b
  · simp
  · show of_nat _ = _
    rw [Nat.div_eq_zero] <;> simp
  · cc
#align int.div2_bit Int.div2_bit
-/

end Int


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

Euclidean domains and Euclidean algorithm (extended to come)
A lot is based on pre-existing code in mathlib for natural number gcds
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.int.basic
import Mathlib.algebra.field
import Mathlib.PostPort

universes u l u_1

namespace Mathlib

/-- A `euclidean_domain` is an `integral_domain` with a division and a remainder, satisfying
  `b * (a / b) + a % b = a`. The definition of a euclidean domain usually includes a valuation
  function `R → ℕ`. This definition is slightly generalised to include a well founded relation
  `r` with the property that `r (a % b) b`, instead of a valuation.  -/
class euclidean_domain (R : Type u)
extends comm_ring R, nontrivial R
where
  quotient : R → R → R
  quotient_zero : ∀ (a : R), quotient a 0 = 0
  remainder : R → R → R
  quotient_mul_add_remainder_eq : ∀ (a b : R), b * quotient a b + remainder a b = a
  r : R → R → Prop
  r_well_founded : well_founded r
  remainder_lt : ∀ (a : R) {b : R}, b ≠ 0 → r (remainder a b) b
  mul_left_not_lt : ∀ (a : R) {b : R}, b ≠ 0 → ¬r (a * b) a

namespace euclidean_domain

protected instance has_div {R : Type u} [euclidean_domain R] : Div R :=
  { div := euclidean_domain.quotient }

protected instance has_mod {R : Type u} [euclidean_domain R] : Mod R :=
  { mod := euclidean_domain.remainder }

theorem div_add_mod {R : Type u} [euclidean_domain R] (a : R) (b : R) : b * (a / b) + a % b = a :=
  euclidean_domain.quotient_mul_add_remainder_eq a b

theorem mod_add_div {R : Type u} [euclidean_domain R] (a : R) (b : R) : a % b + b * (a / b) = a :=
  Eq.trans (add_comm (a % b) (b * (a / b))) (div_add_mod a b)

theorem mod_eq_sub_mul_div {R : Type u_1} [euclidean_domain R] (a : R) (b : R) : a % b = a - b * (a / b) :=
  Eq.trans (Eq.symm (add_sub_cancel' (b * (a / b)) (a % b)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (b * (a / b) + a % b - b * (a / b) = a - b * (a / b))) (div_add_mod a b)))
      (Eq.refl (a - b * (a / b))))

theorem mod_lt {R : Type u} [euclidean_domain R] (a : R) {b : R} : b ≠ 0 → euclidean_domain.r (a % b) b :=
  euclidean_domain.remainder_lt

theorem mul_right_not_lt {R : Type u} [euclidean_domain R] {a : R} (b : R) (h : a ≠ 0) : ¬euclidean_domain.r (a * b) b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (¬euclidean_domain.r (a * b) b)) (mul_comm a b))) (mul_left_not_lt b h)

theorem mul_div_cancel_left {R : Type u} [euclidean_domain R] {a : R} (b : R) (a0 : a ≠ 0) : a * b / a = b := sorry

theorem mul_div_cancel {R : Type u} [euclidean_domain R] (a : R) {b : R} (b0 : b ≠ 0) : a * b / b = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a * b / b = a)) (mul_comm a b))) (mul_div_cancel_left a b0)

@[simp] theorem mod_zero {R : Type u} [euclidean_domain R] (a : R) : a % 0 = a := sorry

@[simp] theorem mod_eq_zero {R : Type u} [euclidean_domain R] {a : R} {b : R} : a % b = 0 ↔ b ∣ a := sorry

@[simp] theorem mod_self {R : Type u} [euclidean_domain R] (a : R) : a % a = 0 :=
  iff.mpr mod_eq_zero (dvd_refl a)

theorem dvd_mod_iff {R : Type u} [euclidean_domain R] {a : R} {b : R} {c : R} (h : c ∣ b) : c ∣ a % b ↔ c ∣ a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (c ∣ a % b ↔ c ∣ a)) (propext (dvd_add_iff_right (dvd_mul_of_dvd_left h (a / b))))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (c ∣ b * (a / b) + a % b ↔ c ∣ a)) (div_add_mod a b))) (iff.refl (c ∣ a)))

theorem lt_one {R : Type u} [euclidean_domain R] (a : R) : euclidean_domain.r a 1 → a = 0 := sorry

theorem val_dvd_le {R : Type u} [euclidean_domain R] (a : R) (b : R) : b ∣ a → a ≠ 0 → ¬euclidean_domain.r a b := sorry

@[simp] theorem mod_one {R : Type u} [euclidean_domain R] (a : R) : a % 1 = 0 :=
  iff.mpr mod_eq_zero (one_dvd a)

@[simp] theorem zero_mod {R : Type u} [euclidean_domain R] (b : R) : 0 % b = 0 :=
  iff.mpr mod_eq_zero (dvd_zero b)

@[simp] theorem div_zero {R : Type u} [euclidean_domain R] (a : R) : a / 0 = 0 :=
  euclidean_domain.quotient_zero a

@[simp] theorem zero_div {R : Type u} [euclidean_domain R] {a : R} : 0 / a = 0 := sorry

@[simp] theorem div_self {R : Type u} [euclidean_domain R] {a : R} (a0 : a ≠ 0) : a / a = 1 := sorry

theorem eq_div_of_mul_eq_left {R : Type u} [euclidean_domain R] {a : R} {b : R} {c : R} (hb : b ≠ 0) (h : a * b = c) : a = c / b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a = c / b)) (Eq.symm h)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a = a * b / b)) (mul_div_cancel a hb))) (Eq.refl a))

theorem eq_div_of_mul_eq_right {R : Type u} [euclidean_domain R] {a : R} {b : R} {c : R} (ha : a ≠ 0) (h : a * b = c) : b = c / a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (b = c / a)) (Eq.symm h)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (b = a * b / a)) (mul_div_cancel_left b ha))) (Eq.refl b))

theorem mul_div_assoc {R : Type u} [euclidean_domain R] (x : R) {y : R} {z : R} (h : z ∣ y) : x * y / z = x * (y / z) := sorry

theorem gcd.induction {R : Type u} [euclidean_domain R] {P : R → R → Prop} (a : R) (b : R) : (∀ (x : R), P 0 x) → (∀ (a b : R), a ≠ 0 → P (b % a) a → P a b) → P a b := sorry

/-- `gcd a b` is a (non-unique) element such that `gcd a b ∣ a` `gcd a b ∣ b`, and for
  any element `c` such that `c ∣ a` and `c ∣ b`, then `c ∣ gcd a b` -/
def gcd {R : Type u} [euclidean_domain R] [DecidableEq R] : R → R → R :=
  sorry

@[simp] theorem gcd_zero_left {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) : gcd 0 a = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (gcd 0 a = a)) (gcd.equations._eqn_1 0))) (if_pos rfl)

@[simp] theorem gcd_zero_right {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) : gcd a 0 = a := sorry

theorem gcd_val {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) (b : R) : gcd a b = gcd (b % a) a := sorry

theorem gcd_dvd {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) (b : R) : gcd a b ∣ a ∧ gcd a b ∣ b := sorry

theorem gcd_dvd_left {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) (b : R) : gcd a b ∣ a :=
  and.left (gcd_dvd a b)

theorem gcd_dvd_right {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) (b : R) : gcd a b ∣ b :=
  and.right (gcd_dvd a b)

protected theorem gcd_eq_zero_iff {R : Type u} [euclidean_domain R] [DecidableEq R] {a : R} {b : R} : gcd a b = 0 ↔ a = 0 ∧ b = 0 := sorry

theorem dvd_gcd {R : Type u} [euclidean_domain R] [DecidableEq R] {a : R} {b : R} {c : R} : c ∣ a → c ∣ b → c ∣ gcd a b := sorry

theorem gcd_eq_left {R : Type u} [euclidean_domain R] [DecidableEq R] {a : R} {b : R} : gcd a b = a ↔ a ∣ b := sorry

@[simp] theorem gcd_one_left {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) : gcd 1 a = 1 :=
  iff.mpr gcd_eq_left (one_dvd a)

@[simp] theorem gcd_self {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) : gcd a a = a :=
  iff.mpr gcd_eq_left (dvd_refl a)

/--
An implementation of the extended GCD algorithm.
At each step we are computing a triple `(r, s, t)`, where `r` is the next value of the GCD
algorithm, to compute the greatest common divisor of the input (say `x` and `y`), and `s` and `t`
are the coefficients in front of `x` and `y` to obtain `r` (i.e. `r = s * x + t * y`).
The function `xgcd_aux` takes in two triples, and from these recursively computes the next triple:
```
xgcd_aux (r, s, t) (r', s', t') = xgcd_aux (r' % r, s' - (r' / r) * s, t' - (r' / r) * t) (r, s, t)
```
-/
def xgcd_aux {R : Type u} [euclidean_domain R] [DecidableEq R] : R → R → R → R → R → R → R × R × R :=
  sorry

@[simp] theorem xgcd_zero_left {R : Type u} [euclidean_domain R] [DecidableEq R] {s : R} {t : R} {r' : R} {s' : R} {t' : R} : xgcd_aux 0 s t r' s' t' = (r', s', t') := sorry

theorem xgcd_aux_rec {R : Type u} [euclidean_domain R] [DecidableEq R] {r : R} {s : R} {t : R} {r' : R} {s' : R} {t' : R} (h : r ≠ 0) : xgcd_aux r s t r' s' t' = xgcd_aux (r' % r) (s' - r' / r * s) (t' - r' / r * t) r s t := sorry

/-- Use the extended GCD algorithm to generate the `a` and `b` values
  satisfying `gcd x y = x * a + y * b`. -/
def xgcd {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : R × R :=
  prod.snd (xgcd_aux x 1 0 y 0 1)

/-- The extended GCD `a` value in the equation `gcd x y = x * a + y * b`. -/
def gcd_a {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : R :=
  prod.fst (xgcd x y)

/-- The extended GCD `b` value in the equation `gcd x y = x * a + y * b`. -/
def gcd_b {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : R :=
  prod.snd (xgcd x y)

@[simp] theorem gcd_a_zero_left {R : Type u} [euclidean_domain R] [DecidableEq R] {s : R} : gcd_a 0 s = 0 := sorry

@[simp] theorem gcd_b_zero_left {R : Type u} [euclidean_domain R] [DecidableEq R] {s : R} : gcd_b 0 s = 1 := sorry

@[simp] theorem xgcd_aux_fst {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) (s : R) (t : R) (s' : R) (t' : R) : prod.fst (xgcd_aux x s t y s' t') = gcd x y := sorry

theorem xgcd_aux_val {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : xgcd_aux x 1 0 y 0 1 = (gcd x y, xgcd x y) := sorry

theorem xgcd_val {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : xgcd x y = (gcd_a x y, gcd_b x y) :=
  Eq.symm prod.mk.eta

theorem xgcd_aux_P {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) (b : R) {r : R} {r' : R} {s : R} {t : R} {s' : R} {t' : R} : P a b (r, s, t) → P a b (r', s', t') → P a b (xgcd_aux r s t r' s' t') := sorry

theorem gcd_eq_gcd_ab {R : Type u} [euclidean_domain R] [DecidableEq R] (a : R) (b : R) : gcd a b = a * gcd_a a b + b * gcd_b a b := sorry

protected instance integral_domain (R : Type u_1) [e : euclidean_domain R] : integral_domain R :=
  integral_domain.mk Add.add euclidean_domain.add_assoc 0 euclidean_domain.zero_add euclidean_domain.add_zero
    euclidean_domain.neg euclidean_domain.sub euclidean_domain.add_left_neg euclidean_domain.add_comm Mul.mul
    euclidean_domain.mul_assoc euclidean_domain.one euclidean_domain.one_mul euclidean_domain.mul_one
    euclidean_domain.left_distrib euclidean_domain.right_distrib euclidean_domain.mul_comm euclidean_domain.exists_pair_ne
    sorry

/-- `lcm a b` is a (non-unique) element such that `a ∣ lcm a b` `b ∣ lcm a b`, and for
  any element `c` such that `a ∣ c` and `b ∣ c`, then `lcm a b ∣ c` -/
def lcm {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : R :=
  x * y / gcd x y

theorem dvd_lcm_left {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : x ∣ lcm x y := sorry

theorem dvd_lcm_right {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : y ∣ lcm x y := sorry

theorem lcm_dvd {R : Type u} [euclidean_domain R] [DecidableEq R] {x : R} {y : R} {z : R} (hxz : x ∣ z) (hyz : y ∣ z) : lcm x y ∣ z := sorry

@[simp] theorem lcm_dvd_iff {R : Type u} [euclidean_domain R] [DecidableEq R] {x : R} {y : R} {z : R} : lcm x y ∣ z ↔ x ∣ z ∧ y ∣ z := sorry

@[simp] theorem lcm_zero_left {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) : lcm 0 x = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm 0 x = 0)) (lcm.equations._eqn_1 0 x)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (0 * x / gcd 0 x = 0)) (zero_mul x)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 / gcd 0 x = 0)) zero_div)) (Eq.refl 0)))

@[simp] theorem lcm_zero_right {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) : lcm x 0 = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (lcm x 0 = 0)) (lcm.equations._eqn_1 x 0)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (x * 0 / gcd x 0 = 0)) (mul_zero x)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (0 / gcd x 0 = 0)) zero_div)) (Eq.refl 0)))

@[simp] theorem lcm_eq_zero_iff {R : Type u} [euclidean_domain R] [DecidableEq R] {x : R} {y : R} : lcm x y = 0 ↔ x = 0 ∨ y = 0 := sorry

@[simp] theorem gcd_mul_lcm {R : Type u} [euclidean_domain R] [DecidableEq R] (x : R) (y : R) : gcd x y * lcm x y = x * y := sorry

end euclidean_domain

protected instance int.euclidean_domain : euclidean_domain ℤ :=
  euclidean_domain.mk Add.add comm_ring.add_assoc 0 comm_ring.zero_add comm_ring.add_zero Neg.neg comm_ring.sub
    comm_ring.add_left_neg comm_ring.add_comm Mul.mul comm_ring.mul_assoc 1 comm_ring.one_mul comm_ring.mul_one
    comm_ring.left_distrib comm_ring.right_distrib comm_ring.mul_comm nontrivial.exists_pair_ne Div.div int.div_zero
    Mod.mod sorry (fun (a b : ℤ) => int.nat_abs a < int.nat_abs b) sorry sorry sorry

protected instance field.to_euclidean_domain {K : Type u} [field K] : euclidean_domain K :=
  euclidean_domain.mk Add.add field.add_assoc 0 field.zero_add field.add_zero Neg.neg field.sub field.add_left_neg
    field.add_comm Mul.mul field.mul_assoc 1 field.one_mul field.mul_one field.left_distrib field.right_distrib
    field.mul_comm field.exists_pair_ne Div.div sorry (fun (a b : K) => a - a * b / b) sorry
    (fun (a b : K) => a = 0 ∧ b ≠ 0) sorry sorry sorry


/-
Copyright (c) 2020 Aaron Anderson, Jalex Stark, Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Aaron Anderson, Jalex Stark, Kyle Miller.
-/
import data.fintype.basic
import ..sym2
import tactic

open finset
-- noncomputable theory

/-!
# Simple graphs
This module defines simple graphs on a vertex type `V` as an
irreflexive symmetric relation.
There is a basic API for locally finite graphs and for graphs with
finitely many vertices.
## Main definitions
* `simple_graph` is a structure for symmetric, irreflexive relations
* `neighbor_set` is the `set` of vertices adjacent to a given vertex
* `neighbor_finset` is the `finset` of vertices adjacent to a given vertex,
   if `neighbor_set` is finite
## Implementation notes
* A locally finite graph is one with instances `∀ v, fintype (G.neighbor_set v)`.
* Given instances `decidable_rel G.adj` and `fintype V`, then the graph
is locally finite, too.
TODO: This is the simplest notion of an unoriented graph.  This should
eventually fit into a more complete combinatorics hierarchy which
includes multigraphs and directed graphs.  We begin with simple graphs
in order to start learning what the combinatorics hierarchy should
look like.
TODO: Part of this would include defining, for example, subgraphs of a
simple graph.
-/

universe u
variables (V : Type u)
/--
A simple graph is an irreflexive symmetric relation `adj` on a vertex type `V`.
The relation describes which pairs of vertices are adjacent.
There is exactly one edge for every pair of adjacent edges;
see `simple_graph.E` for the corresponding type of edges.
Note: The type of the relation is given as `V → set V` rather than
`V → V → Prop` so that, given vertices `v` and `w`, then `w ∈ G.adj v`
works as another way to write `G.adj v w`.  Otherwise Lean cannot find
a `has_mem` instance.
-/
@[ext] structure simple_graph :=
(adj : V → V → Prop)
(sym : symmetric adj . obviously)
(loopless : irreflexive adj . obviously)
--(unique_edges : edge set not multiset?)
namespace simple_graph

-- notation for adj
-- class has_splodge (α : Sort*) := { bigcirc : α → α → Prop }
-- instance (α : Type u) [simple_graph α] : has_splodge α :=
-- { bigcirc := @simple_graph.adj α _inst_1 }

-- CR jstark: we should probably use a localized notation for adj
#print notation ~

-- why can't I use exotic unicode in infix notation?
-- binding power and associativity sent to default values
--infix `◯`:37 := has_splodge.bigcirc
notation v ` ◯⦃`:37 G `⦄ `:37 w := G.adj v w

/--
The complete graph on a type `V` is the simple graph with all pairs of distinct vertices adjacent.
-/
variables {V} (G : simple_graph V)

def complete_graph : simple_graph V :=
{ adj := ne }

def empty : simple_graph V :=
{ adj := λ _ _, false}

-- @[simp] lemma empty_adj (v u : V) : (@empty V).adj v u ↔ false := by tidy

instance : inhabited (simple_graph V) := ⟨@complete_graph V⟩

instance complete_graph_adj_decidable (V : Type u) [decidable_eq V] :
  decidable_rel (@complete_graph V).adj :=
by { dsimp [complete_graph], apply_instance }

-- variables {V} (G : simple_graph V)

/-- `G.neighbor_set v` is the set of vertices adjacent to `v` in `G`. -/
def neighbor_set (v : V) : set V := set_of (G.adj v)

lemma ne_of_edge {a b : V} (hab : G.adj a b) : a ≠ b :=
by { rintro rfl, exact G.loopless a hab }

/--
The edges of G consist of the unordered pairs of vertices related by
`G.adj`.  It is given as a subtype of the symmetric square.
-/
def E : Type u := {x : sym2 V // x ∈ sym2.from_rel G.sym}

/-- Allows us to refer to a vertex being a member of an edge. -/
instance has_mem : has_mem V G.E := { mem := λ v e, v ∈ e.val }

/-- Construct an edge from its endpoints. -/
def edge_of_adj {v w : V} (h : G.adj v w) : G.E := ⟨⟦(v,w)⟧, h⟩

lemma edge_eq_edge_of_adj (e : G.E):
  ∃ v w, ∃ (h : v ◯⦃G⦄ w), e = G.edge_of_adj h :=
begin
    cases e,
    rcases e_val,
    cases e_val with v w,
    use [v, w, e_property],
    refl
end

lemma edge_eq_edge_of_adj_iff (e : G.E) {v w} (h : G.adj v w) :
  e = G.edge_of_adj h ↔ v ∈ e ∧ w ∈ e :=
begin
  cases e with e he,
  rcases e with ⟨v', w'⟩,
  change v' ◯⦃G⦄ w' at he,
  split,
  { intro H,
    cases G with adj symm loopless,
    dsimp at symm loopless h he,
    unfold edge_of_adj at H,
    rw H,
    unfold has_mem.mem sym2.mem,
    simp,
    split,
    use w, use v,
    apply quotient.exact,
    -- how the fuck
    exact sym2.eq_swap },
  { sorry }
end

@[simp]
lemma mem_of_adj {v w : V} (h : G.adj v w) :
  v ∈ G.edge_of_adj h := sym2.mk_has_mem v w

@[simp]
lemma mem_of_adj_right {v w : V} (h : G.adj v w) :
  w ∈ G.edge_of_adj h := sym2.mk_has_mem_right v w

lemma adj_iff_exists_edge {v w : V} (hne : v ≠ w) :
G.adj v w ↔ ∃ (e : G.E), v ∈ e ∧ w ∈ e :=
begin
  split, { intro, use ⟦(v,w)⟧, assumption, refine ⟨(G.mem_of_adj _), (G.mem_of_adj_right _)⟩ },
  rintro ⟨e, ⟨w', hve⟩, ⟨v', hew⟩⟩,
  have : e.val = ⟦(v,w)⟧, { rw [hve, sym2.eq_iff] at hew ⊢, cc },
  have key := e.property, rwa this at key,
end

lemma empty_edge (e : (@empty V).E) : false := by tidy

lemma edge_eq_iff (e d : G.E) : e = d ↔ ∃ u, ∃ v ≠ u, u ∈ e ∧ u ∈ d ∧ v ∈ e ∧ v ∈ d :=
begin
 split,
 { rintro rfl, rcases G.edge_eq_edge_of_adj e with ⟨u, v, h, rfl⟩,
  use [u, v], have := G.ne_of_edge h, simp; cc,
 },
 rintro ⟨u, v, h, _⟩,
 have : G.adj v u, rw G.adj_iff_exists_edge h, use e, tauto,
 transitivity G.edge_of_adj this,
 { rw edge_eq_edge_of_adj_iff, tauto },
 { symmetry, rw edge_eq_edge_of_adj_iff, tauto },
end

@[ext]
lemma edge_eq_iff' (e d : G.E) : e = d ↔ ∀ u, u ∈ e ↔ u ∈ d :=
begin
  split, { rintro rfl, simp },
  intro h, rw edge_eq_iff,
  rcases G.edge_eq_edge_of_adj e with ⟨u, v, h_adj, rfl⟩,
  use [u, v],
  have := G.ne_of_edge h_adj, simp only [← h], simp; tauto,
end

variables {G}

/-- Given an edge and one vertex incident on it, construct the other one. -/
noncomputable def E.other (e : G.E) {v : V} (h : v ∈ e) : V :=
by { have : v ∈ e.val, apply h, exact this.other }

lemma E.other_mem (e : G.E) {v : V} (h : v ∈ e) : e.other h ∈ e :=
begin
  change sym2.mem.other h ∈ e.val, have := sym2.mem_other_spec h,
  convert sym2.mk_has_mem_right _ _; tauto,
end

lemma E.other_adj (e : G.E) {v : V} (h : v ∈ e) : G.adj v $ e.other h :=
begin
  sorry
end

lemma E.other_ne (e : G.E) {v : V} (h : v ∈ e) : e.other h ≠ v :=
begin
  have key := e.property,
  erw [← sym2.mem_other_spec h, sym2.eq_swap] at key,
  exact G.ne_of_edge key,
end

lemma E.mem_iff (e : G.E) {v : V} (h : v ∈ e) (u : V) :
  u ∈ e ↔ u = v ∨ u = e.other h :=
begin
  convert sym2.mem_iff using 1,
  erw sym2.mem_other_spec h, refl,
end

lemma E.eq_other_iff (e : G.E) {v : V} (h : v ∈ e) (u : V) :
 u = e.other h ↔ u ≠ v ∧ u ∈ e :=
begin
  split, { rintro rfl, refine ⟨ E.other_ne _ _, E.other_mem _ _⟩ },
  rintro ⟨huv, hu⟩,
  rw e.mem_iff h at hu, tauto,
end
attribute [irreducible] E.other

instance E.inhabited [inhabited {p : V × V | G.adj p.1 p.2}] : inhabited G.E :=
⟨begin
  rcases inhabited.default {p : V × V | G.adj p.1 p.2} with ⟨⟨x, y⟩, h⟩,
  use ⟦(x, y)⟧, rwa sym2.from_rel_prop,
end⟩
#check sym2

instance edges_fintype [decidable_eq V] [fintype V] [decidable_rel G.adj] :
  fintype G.E := subtype.fintype _

section classical
open_locale classical
noncomputable theory

def E.some (e : G.E) : V :=
begin
  suffices : ∃ v, v ∈ e,
  exact classical.some this,
  sorry
end

lemma E.some_spec (e : G.E) : e.some ∈ e :=
begin
  dsimp [E.some],
  -- refine classical.some_spec _,
  sorry,
end

variables [fintype V]

def E_finset  (G : simple_graph V) : finset $ V × V :=
finset.filter (λ x, G.adj x.1 x.2) univ

lemma E_finset_spec [decidable_eq V] [fintype V] [decidable_rel G.adj] :
2 * fintype.card G.E = finset.card G.E_finset :=
begin
  -- transitivity 2 * finset.card _, ring,
  have : fintype.card (fin 2) = 2, { tidy },
  rw [← this, ← fintype.card_prod],
  rw ← fintype.card_of_finset, swap, { intro, refl },
  convert fintype.of_equiv_card _,
  symmetry, refine equiv.of_bijective _ _,
  rintro ⟨b, e⟩,
  refine if b = 0
    then ⟨(e.some, e.other e.some_spec), _⟩
    else ⟨(e.other e.some_spec, e.some), _⟩,
  { suffices : G.adj e.some (e.other e.some_spec), simpa [E_finset],
    rw adj_iff_exists_edge, refine ⟨ e, e.some_spec, _⟩, apply e.other_mem,
    symmetry, apply e.other_ne },
  { suffices : G.adj (e.other e.some_spec) _, simpa [E_finset],
    rw adj_iff_exists_edge, { refine ⟨ e, _, e.some_spec⟩, apply e.other_mem },
    simp [e.other_ne] },
  sorry,
  -- refine ⟨_, _⟩,
  -- intros x y h,
  -- by_cases hxy : x.1 = y.1,
  -- ext, any_goals { simp [hxy] },
  -- dsimp at h, by_cases hy : y.1 = 0,
end
variables (G)
#check prod.eq_iff_fst_eq_snd_eq
def card_edges : ℕ := fintype.card G.E

@[simp] lemma empty_card_edges : (@empty V).card_edges = 0 :=
by { dsimp [card_edges], rw fintype.card_eq_zero_iff, tidy }

@[simp] lemma card_edges_eq_zero_iff :
  G.card_edges = 0 ↔ G = empty :=
begin
  split, swap, { rintro rfl, simp },
  intro h, dsimp [card_edges] at h,
  ext, simp only [empty, iff_false], contrapose! h,
  rw [← nat.pos_iff_ne_zero, fintype.card_pos_iff],
  apply nonempty.intro, exact G.edge_of_adj h,
end

lemma empty_iff_not_edge : G = empty ↔ G.E → false :=
begin
  split, { rintro rfl, apply empty_edge },
  intro h, ext u v, suffices : ¬ G.adj u v, { tidy },
  intro he, have e := G.edge_of_adj he, exact h e,
end

def inhabited_of_ne_empty (h : G ≠ empty) : inhabited G.E :=
begin
  suffices : nonempty G.E, { letI := this, inhabit G.E, assumption },
  refine fintype.card_pos_iff.mp _, contrapose! h,
  erw [le_zero_iff_eq, card_edges_eq_zero_iff] at h, exact h,
end
end classical

attribute [irreducible] E

@[simp] lemma irrefl {v : V} : ¬G.adj v v := G.loopless v

@[symm] lemma edge_symm (u v : V) : G.adj u v ↔ G.adj v u :=
by split; apply G.sym

@[simp] lemma mem_neighbor_set (v w : V) : w ∈ G.neighbor_set v ↔ G.adj v w :=
by tauto

section finite_at

/-!
## Finiteness at a vertex
This section contains definitions and lemmas concerning vertices that
have finitely many adjacent vertices.  We denote this condition by
`fintype (G.neighbor_set v)`.
We define `G.neighbor_finset v` to be the `finset` version of `G.neighbor_set v`.
Use `neighbor_finset_eq_filter` to rewrite this definition as a `filter`.
-/

variables (v : V) [fintype (G.neighbor_set v)]
variables (G)
/--
`G.neighbors v` is the `finset` version of `G.adj v` in case `G` is
locally finite at `v`.
-/
def neighbor_finset : finset V := (G.neighbor_set v).to_finset

@[simp] lemma mem_neighbor_finset (w : V) :
  w ∈ G.neighbor_finset v ↔ G.adj v w :=
by simp [neighbor_finset]

/--
`G.degree v` is the number of vertices adjacent to `v`.
-/
def degree : ℕ := (G.neighbor_finset v).card

@[simp]
lemma card_neighbor_set_eq_degree : fintype.card (G.neighbor_set v) = G.degree v :=
by simp [degree, neighbor_finset]

end finite_at

section locally_finite

variables (G) [∀ (v : V), fintype (G.neighbor_set v)]
/--
A regular graph is a locally finite graph such that every vertex has the same degree.
-/
def regular_graph (d : ℕ) : Prop := ∀ (v : V), G.degree v = d

end locally_finite

section finite

variables [fintype V]

instance neighbor_set_fintype [decidable_rel G.adj] (v : V) : fintype (G.neighbor_set v) :=
  @subtype.fintype _ _ (by {simp_rw mem_neighbor_set, apply_instance}) _

lemma neighbor_finset_eq_filter {v : V} [decidable_rel G.adj] :
  G.neighbor_finset v = finset.univ.filter (G.adj v) :=
by { ext, simp }

@[simp]
lemma complete_graph_degree [decidable_eq V] (v : V) :
  (@complete_graph V).degree v = fintype.card V - 1 :=
begin
  convert univ.card.pred_eq_sub_one,
  erw [degree, neighbor_finset_eq_filter, filter_ne, card_erase_of_mem (mem_univ v)],
end

lemma complete_graph_is_regular [decidable_eq V] :
  (@complete_graph V).regular_graph (fintype.card V - 1) :=
by { intro v, simp }

end finite

end simple_graph


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.clause
import Mathlib.PostPort

universes l

namespace Mathlib

/-
Correctness lemmas for equality elimination.
See 5.5 of <http://www.decision-procedures.org/> for details.
-/

namespace omega

def symdiv (i : ℤ) (j : ℤ) : ℤ := ite (bit0 1 * (i % j) < j) (i / j) (i / j + 1)

def symmod (i : ℤ) (j : ℤ) : ℤ := ite (bit0 1 * (i % j) < j) (i % j) (i % j - j)

theorem symmod_add_one_self {i : ℤ} : 0 < i → symmod i (i + 1) = -1 := sorry

theorem mul_symdiv_eq {i : ℤ} {j : ℤ} : j * symdiv i j = i - symmod i j := sorry

theorem symmod_eq {i : ℤ} {j : ℤ} : symmod i j = i - j * symdiv i j :=
  eq.mpr (id (Eq._oldrec (Eq.refl (symmod i j = i - j * symdiv i j)) mul_symdiv_eq))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (symmod i j = i - (i - symmod i j))) (sub_sub_cancel i (symmod i j))))
      (Eq.refl (symmod i j)))

/-- (sgm v b as n) is the new value assigned to the nth variable
after a single step of equality elimination using valuation v,
term ⟨b, as⟩, and variable index n. If v satisfies the initial
constraint set, then (v ⟨n ↦ sgm v b as n⟩) satisfies the new
constraint set after equality elimination. -/
def sgm (v : ℕ → ℤ) (b : ℤ) (as : List ℤ) (n : ℕ) : ℤ :=
  let a_n : ℤ := list.func.get n as;
  let m : ℤ := a_n + 1;
  (symmod b m + coeffs.val v (list.map (fun (x : ℤ) => symmod x m) as)) / m

def rhs : ℕ → ℤ → List ℤ → term := sorry

theorem rhs_correct_aux {v : ℕ → ℤ} {m : ℤ} {as : List ℤ} {k : ℕ} :
    ∃ (d : ℤ),
        m * d + coeffs.val_between v (list.map (fun (x : ℤ) => symmod x m) as) 0 k =
          coeffs.val_between v as 0 k :=
  sorry

theorem rhs_correct {v : ℕ → ℤ} {b : ℤ} {as : List ℤ} (n : ℕ) :
    0 < list.func.get n as →
        0 = term.val v (b, as) → v n = term.val (update n (sgm v b as n) v) (rhs n b as) :=
  sorry

def sym_sym (m : ℤ) (b : ℤ) : ℤ := symdiv b m + symmod b m

def coeffs_reduce : ℕ → ℤ → List ℤ → term := sorry

theorem coeffs_reduce_correct {v : ℕ → ℤ} {b : ℤ} {as : List ℤ} {n : ℕ} :
    0 < list.func.get n as →
        0 = term.val v (b, as) → 0 = term.val (update n (sgm v b as n) v) (coeffs_reduce n b as) :=
  sorry

-- Requires : t1.coeffs[m] = 1

def cancel (m : ℕ) (t1 : term) (t2 : term) : term :=
  term.add (term.mul (-list.func.get m (prod.snd t2)) t1) t2

def subst (n : ℕ) (t1 : term) (t2 : term) : term :=
  term.add (term.mul (list.func.get n (prod.snd t2)) t1)
    (prod.fst t2, list.func.set 0 (prod.snd t2) n)

theorem subst_correct {v : ℕ → ℤ} {b : ℤ} {as : List ℤ} {t : term} {n : ℕ} :
    0 < list.func.get n as →
        0 = term.val v (b, as) →
          term.val v t = term.val (update n (sgm v b as n) v) (subst n (rhs n b as) t) :=
  sorry

/-- The type of equality elimination rules. -/
inductive ee where
| drop : ee
| nondiv : ℤ → ee
| factor : ℤ → ee
| neg : ee
| reduce : ℕ → ee
| cancel : ℕ → ee

namespace ee

def repr : ee → string := sorry

protected instance has_repr : has_repr ee := has_repr.mk repr

end ee

/-- Apply a given sequence of equality elimination steps to a clause. -/
def eq_elim : List ee → clause → clause := sorry

theorem sat_empty : clause.sat ([], []) :=
  Exists.intro (fun (_x : ℕ) => 0) { left := of_as_true trivial, right := of_as_true trivial }

theorem sat_eq_elim {es : List ee} {c : clause} : clause.sat c → clause.sat (eq_elim es c) := sorry

/-- If the result of equality elimination is unsatisfiable, the original clause is unsatisfiable. -/
theorem unsat_of_unsat_eq_elim (ee : List ee) (c : clause) :
    clause.unsat (eq_elim ee c) → clause.unsat c :=
  fun (h1 : clause.unsat (eq_elim ee c)) => id fun (h2 : clause.sat c) => h1 (sat_eq_elim h2)

end Mathlib