import Logic.Predicate.FirstOrder.Calculus
import Logic.Predicate.Semantics
import Logic.Vorspiel.Logic

universe u u₁ u₂ v v₁ v₂ w w₁ w₂

variable {L : Language.{u}} {μ : Type v} {μ₁ : Type v₁} {μ₂ : Type v₂}

namespace FirstOrder

namespace SubFormula
variable {M : Type w} (s : Structure L M)

def Eval' (ε : μ → M) : ∀ {n}, (Fin n → M) → SubFormula L μ n → Prop
  | _, _, ⊤        => True
  | _, _, ⊥        => False
  | _, e, rel p v  => s.rel p (fun i => SubTerm.val s e ε (v i))
  | _, e, nrel p v => ¬s.rel p (fun i => SubTerm.val s e ε (v i))
  | _, e, p ⋏ q    => p.Eval' ε e ∧ q.Eval' ε e
  | _, e, p ⋎ q    => p.Eval' ε e ∨ q.Eval' ε e
  | _, e, ∀' p     => ∀ x : M, (p.Eval' ε (x :> e))
  | _, e, ∃' p     => ∃ x : M, (p.Eval' ε (x :> e))

@[simp] lemma Eval'_neg (p : SubFormula L μ n) :
    Eval' s ε e (~p) = ¬Eval' s ε e p :=
  by induction p using rec' <;> simp[*, Eval', ←neg_eq, or_iff_not_imp_left]

section

variable {n : ℕ} (e : Fin n → M) (e₂ : Fin n₂ → M) (ε : μ → M) (ε₂ : μ₂ → M)

def Eval : SubFormula L μ n →L Prop where
  toFun := Eval' s ε e
  map_top' := rfl
  map_bot' := rfl
  map_and' := by simp[Eval']
  map_or' := by simp[Eval']
  map_neg' := by simp[Eval'_neg]
  map_imp' := by simp[imp_eq, Eval'_neg, ←neg_eq, Eval', imp_iff_not_or]

abbrev Eval! (M : Type w) [s : Structure L M] {n} (e : Fin n → M) (ε : μ → M) :
    SubFormula L μ n →L Prop := Eval s e ε

abbrev Val (ε : μ → M) : Formula L μ →L Prop := Eval s ![] ε

abbrev Val! (M : Type w) [s : Structure L M] (ε : μ → M) :
    Formula L μ →L Prop := Val s ε

end

lemma eval_rel {k} {r : L.rel k} {v} :
    Eval s e ε (rel r v) ↔ s.rel r (fun i => SubTerm.val s e ε (v i)) := of_eq rfl

@[simp] lemma eval_rel₀ {r : L.rel 0} :
    Eval s e ε (rel r ![]) ↔ s.rel r ![] := by simp[eval_rel, Matrix.empty_eq]

@[simp] lemma eval_rel₁ {r : L.rel 1} (t : SubTerm L μ n) :
    Eval s e ε (rel r ![t]) ↔ s.rel r ![t.val s e ε] := by
  simp[eval_rel]; apply of_eq; congr
  funext i; cases' i using Fin.cases with i <;> simp

@[simp] lemma eval_rel₂ {r : L.rel 2} (t₁ t₂ : SubTerm L μ n) :
    Eval s e ε (rel r ![t₁, t₂]) ↔ s.rel r ![t₁.val s e ε, t₂.val s e ε] := by
  simp[eval_rel]; apply of_eq; congr
  funext i; cases' i using Fin.cases with i <;> simp

lemma eval_nrel {k} {r : L.rel k} {v} :
    Eval s e ε (nrel r v) ↔ ¬s.rel r (fun i => SubTerm.val s e ε (v i)) := of_eq rfl

@[simp] lemma eval_nrel₀ {r : L.rel 0} :
    Eval s e ε (nrel r ![]) ↔ ¬s.rel r ![] := by simp[eval_nrel, Matrix.empty_eq]

@[simp] lemma eval_nrel₁ {r : L.rel 1} (t : SubTerm L μ n) :
    Eval s e ε (nrel r ![t]) ↔ ¬s.rel r ![t.val s e ε] := by
  simp[eval_rel]; apply of_eq; congr
  funext i; cases' i using Fin.cases with i <;> simp

@[simp] lemma eval_nrel₂ {r : L.rel 2} (t₁ t₂ : SubTerm L μ n) :
    Eval s e ε (nrel r ![t₁, t₂]) ↔ ¬s.rel r ![t₁.val s e ε, t₂.val s e ε] := by
  simp[eval_rel]; apply of_eq; congr
  funext i; cases' i using Fin.cases with i <;> simp

@[simp] lemma eval_all {p : SubFormula L μ (n + 1)} :
    Eval s e ε (∀' p) ↔ ∀ x : M, Eval s (x :> e) ε p := of_eq rfl

@[simp] lemma eval_univClosure {e'} {p : SubFormula L μ n} :
    Eval s e' ε (univClosure p) ↔ ∀ e, Eval s e ε p := by
  induction' n with n ih generalizing e' <;> simp[*, eq_finZeroElim]
  constructor
  · intro h e; simpa using h (Matrix.vecTail e) (Matrix.vecHead e)
  · intro h e x; exact h (x :> e)

@[simp] lemma eval_ex {p : SubFormula L μ (n + 1)} :
    Eval s e ε (∃' p) ↔ ∃ x : M, Eval s (x :> e) ε p := of_eq rfl

lemma eval_bind (bound : Fin n₁ → SubTerm L μ₂ n₂) (free : μ₁ → SubTerm L μ₂ n₂) (p : SubFormula L μ₁ n₁) :
    Eval s e₂ ε₂ (bind bound free p) ↔
    Eval s (SubTerm.val s e₂ ε₂ ∘ bound) (SubTerm.val s e₂ ε₂ ∘ free) p := by
  induction p using rec' generalizing n₂ <;> simp[*, SubTerm.val_bind, Function.comp, bind_rel, bind_nrel, eval_rel, eval_nrel]
  · apply forall_congr'; intros a; apply of_eq; congr; exact funext $ Fin.cases (by simp) (by simp)
  · apply exists_congr; intros a; apply of_eq; congr; exact funext $ Fin.cases (by simp) (by simp)

lemma eval_map (bound : Fin n₁ → Fin n₂) (free : μ₁ → μ₂) (e : Fin n₂ → M) (ε : μ₂ → M) (p : SubFormula L μ₁ n₁) :
    Eval s e ε (map bound free p) ↔ Eval s (e ∘ bound) (ε ∘ free) p :=
  by simp[map, eval_bind, Function.comp]

@[simp] lemma eval_subst (u : SubTerm L μ n) (p : SubFormula L μ (n + 1)) :
    Eval s e ε (subst u p) ↔ Eval s (e <: u.val s e ε) ε p :=
  by simp[subst, eval_bind]; apply of_eq; congr ; exact funext $ Fin.lastCases (by simp) (by simp)

@[simp] lemma eval_emb (p : SubFormula L Empty n) :
    Eval s e ε (emb p) ↔ Eval s e Empty.elim p := by simp[emb, eval_map, Empty.eq_elim]

section Syntactic

variable (ε : ℕ → M)

@[simp] lemma eval_free (p : SyntacticSubFormula L (n + 1)) :
    Eval s e (a :>ₙ ε) (free p) ↔ Eval s (e <: a) ε p :=
  by simp[free, eval_bind]; apply of_eq; congr; funext x; cases x using Fin.lastCases <;> simp

@[simp] lemma eval_shift (p : SyntacticSubFormula L n) :
    Eval s e (a :>ₙ ε) (shift p) ↔ Eval s e ε p :=
  by simp[shift, eval_map]; apply of_eq; congr

end Syntactic

end SubFormula

instance semantics : Semantics (Sentence L) where
  struc := Structure.{u, u} L
  realize := (SubFormula.Val · Empty.elim)

abbrev Models (M : Type u) [s : Structure L M] : Sentence L →L Prop := Semantics.realize (self := semantics) s

postfix:max " ⊧₁ " => Models

abbrev ModelsTheory (M : Type u) [s : Structure L M] (T : CTheory L) : Prop := Semantics.realizeTheory (s := semantics) s T

infix:55 " ⊧₁* " => ModelsTheory

variable (L)

def ElementaryEquiv (M₁ M₂ : Type u) [Structure L M₁] [Structure L M₂] : Prop :=
  ∀ σ : Sentence L, M₁ ⊧₁ σ ↔ M₂ ⊧₁ σ

notation:50 M₁ " ≃ₑ[" L "] " M₂ => ElementaryEquiv L M₁ M₂

variable {L}

section
variable {M : Type u} [s : Structure L M]

lemma models_def : M ⊧₁ = SubFormula.Val s Empty.elim := rfl

lemma models_iff {σ : Sentence L} : M ⊧₁ σ ↔ SubFormula.Val s Empty.elim σ := by simp[models_def]

lemma realize_def : Semantics.realize (self := semantics) s = SubFormula.Val s Empty.elim := rfl

lemma modelsₛ_iff {T : CTheory L} : M ⊧₁* T ↔ (∀ ⦃p⦄, p ∈ T → M ⊧₁ p) := of_eq rfl

lemma models_iff_realize {σ : Sentence L} :
    M ⊧₁ σ ↔ Semantics.realize (self := semantics) s σ := of_eq rfl

lemma consequence_iff {T : CTheory L} {σ : Sentence L} :
    T ⊨ σ ↔ (∀ (M : Type u) [Inhabited M] [Structure L M], M ⊧₁* T → M ⊧₁ σ) :=
  of_eq rfl

lemma satisfiableₛ_iff {T : CTheory L} :
    Semantics.Satisfiableₛ T ↔ ∃ (M : Type u) (_ : Inhabited M) (_ : Structure L M), M ⊧₁* T :=
  of_eq rfl

lemma satisfiableₛ_intro {T : CTheory L} (M : Type u) [i : Inhabited M] [s : Structure L M] (h : M ⊧₁* T) : Semantics.Satisfiableₛ T :=
⟨M, i, s, h⟩

lemma validₛ_iff {T : CTheory L} :
    Semantics.Validₛ T ↔ ∀ ⦃M : Type u⦄ [Inhabited M] [Structure L M], M ⊧₁* T :=
  of_eq rfl

@[refl]
lemma ElementaryEquiv.refl (M) [Structure L M] : M ≃ₑ[L] M := fun σ => by rfl

@[symm]
lemma ElementaryEquiv.symm {M₁ M₂} [Structure L M₁] [Structure L M₂] : (M₁ ≃ₑ[L] M₂) → (M₂ ≃ₑ[L] M₁) :=
  fun h σ => (h σ).symm

@[trans]
lemma ElementaryEquiv.trans {M₁ M₂ M₃ : Type u} [Structure L M₁] [Structure L M₂] [Structure L M₃] :
    (M₁ ≃ₑ[L] M₂) → (M₂ ≃ₑ[L] M₃) → (M₁ ≃ₑ[L] M₃) :=
  fun h₁ h₂ σ => Iff.trans (h₁ σ) (h₂ σ)

lemma ElementaryEquiv.models {M₁ M₂} [Structure L M₁] [Structure L M₂] (h : M₁ ≃ₑ[L] M₂) :
    ∀ {σ : Sentence L}, M₁ ⊧₁ σ ↔ M₂ ⊧₁ σ := @h

lemma ElementaryEquiv.modelsₛ {M₁ M₂} [Structure L M₁] [Structure L M₂] (h : M₁ ≃ₑ[L] M₂) :
    ∀ {T : CTheory L}, M₁ ⊧₁* T ↔ M₂ ⊧₁* T := by simp[modelsₛ_iff, h.models]

end

namespace SubFormula

section onSubFormula₁

variable {L₁ L₂ : Language.{u}} {Φ : L₁ →ᵥ L₂}

section
variable {M : Type u} {s₂ : Structure L₂ M} {n} {e : Fin n → M} {ε : μ → M}

lemma eval_onSubFormula₁ {p : SubFormula L₁ μ n} :
    Eval s₂ e ε (Φ.onSubFormula₁ p) ↔ Eval (Φ.onStructure s₂) e ε p :=
  by induction p using rec' <;>
    simp[*, SubTerm.val_onSubTerm, Language.Hom.onSubFormula₁_rel, Language.Hom.onSubFormula₁_nrel,
      eval_rel, eval_nrel]

lemma models_onSubFormula₁ {σ : Sentence L₁} :
    Semantics.realize (self := semantics) s₂ (Φ.onSubFormula₁ σ) ↔ Semantics.realize (self := semantics) (Φ.onStructure s₂) σ :=
  by simp[Semantics.realize, Val, eval_onSubFormula₁]

lemma onSubFormula₁_models_onSubFormula₁ {T : CTheory L₁} {σ : Sentence L₁} (h : T ⊨ σ) :
    Φ.onSubFormula₁ '' T ⊨ Φ.onSubFormula₁ σ := by
  intro M _ s hM
  have : Semantics.realize (self := semantics) (Φ.onStructure s) σ :=
    h M (Φ.onStructure s) (fun q hq => models_onSubFormula₁.mp $ hM (Set.mem_image_of_mem _ hq))
  exact models_onSubFormula₁.mpr this

end

section

variable
  (injf : ∀ k, Function.Injective (Φ.onFunc : L₁.func k → L₂.func k))
  (injr : ∀ k, Function.Injective (Φ.onRel : L₁.rel k → L₂.rel k))
  {M : Type u} [Inhabited M] (s₁ : Structure L₁ M)
  {n} (e : Fin n → M) (ε : μ → M)

lemma eval_extendStructure_onSubFormula₁ {p : SubFormula L₁ μ n} :
    Eval (Φ.extendStructure s₁) e ε (Φ.onSubFormula₁ p) ↔ Eval s₁ e ε p := by
  induction p using rec' <;> simp[*, SubTerm.val_extendStructure_onSubTerm Φ e ε injf s₁,
    Language.Hom.onSubFormula₁_rel, Language.Hom.onSubFormula₁_nrel, eval_rel, eval_nrel]
  · case hrel k r v =>
    exact Structure.extendStructure_rel Φ s₁ (injr k) r (fun i => SubTerm.val s₁ e ε (v i))
  · case hnrel k r v =>
    simpa[not_iff_not] using
      Structure.extendStructure_rel Φ s₁ (injr k) r (fun i => SubTerm.val s₁ e ε (v i))

lemma models_extendStructure_onSubFormula₁ (σ : Sentence L₁) :
    Semantics.realize (self := semantics) (Φ.extendStructure s₁) (Φ.onSubFormula₁ σ) ↔ Semantics.realize (self := semantics) s₁ σ := by
  simp[Semantics.realize, Val, eval_extendStructure_onSubFormula₁ injf injr]

lemma onSubFormula₁_models_onSubFormula₁_iff {T : CTheory L₁} {σ : Sentence L₁} :
    Φ.onSubFormula₁ '' T ⊨ Φ.onSubFormula₁ σ ↔ T ⊨ σ := by
  constructor
  · simp; intro h M _ s₁ hs₁
    exact (models_extendStructure_onSubFormula₁ injf injr s₁ σ).mp $
      h M (Φ.extendStructure s₁)
      (by simp[Semantics.realizeTheory]; intro σ hσ; exact (models_extendStructure_onSubFormula₁ injf injr s₁ σ).mpr (hs₁ hσ))
  · exact onSubFormula₁_models_onSubFormula₁

end

end onSubFormula₁

end SubFormula

namespace SubFormula

variable {L : Language.{u}} [L.HasEq] {μ : Type v} (M : Type w) (s : Structure L M) [s.Eq]
  {n} (e : Fin n → M) (ε : μ → M)

@[simp] lemma eval_eq (t u : SubTerm L μ n) :
    Eval s e ε (rel Language.HasEq.eq ![t, u]) ↔ t.val s e ε = u.val s e ε :=
  by simp

end SubFormula

section soundness

variable {L : Language.{u}} [∀ k, DecidableEq (L.func k)] [∀ k, DecidableEq (L.rel k)]

lemma Derivation.sound : ∀ {Γ : Finset (SyntacticFormula L)},
    ⊩ Γ → ∀ (M : Type u) [s : Structure L M] (ε : ℕ → M), ∃ p ∈ Γ, SubFormula.Val! M ε p
  | _, axL Δ r v hrel hnrel, M, s, ε => by
    by_cases h : s.rel r (SubTerm.val! M ![] ε ∘ v)
    · exact ⟨SubFormula.rel r v, hrel, h⟩
    · exact ⟨SubFormula.nrel r v, hnrel, h⟩
  | _, verum Δ h,            M, s, ε => ⟨⊤, h, by simp⟩
  | _, orLeft Δ p q d,       M, s, ε => by
    have : SubFormula.Val! M ε p ∨ ∃ q ∈ Δ, SubFormula.Val! M ε q := by simpa using Derivation.sound d M ε
    rcases this with (hp | ⟨r, hr, hhr⟩)
    · exact ⟨p ⋎ q, by simp, by simp[hp]⟩
    · exact ⟨r, by simp[hr], hhr⟩
  | _, orRight Δ p q d,       M, s, ε => by
    have : SubFormula.Val! M ε q ∨ ∃ q ∈ Δ, SubFormula.Val! M ε q := by simpa using Derivation.sound d M ε
    rcases this with (hq | ⟨r, hr, hhr⟩)
    · exact ⟨p ⋎ q, by simp, by simp[hq]⟩
    · exact ⟨r, by simp[hr], hhr⟩
  | _, and Δ p q dp dq,       M, s, ε => by
    have : SubFormula.Val! M ε p ∨ ∃ r ∈ Δ, SubFormula.Val! M ε r := by simpa using Derivation.sound dp M ε
    rcases this with (hp | ⟨r, hr, hhr⟩)
    · have : SubFormula.Val! M ε q ∨ ∃ r ∈ Δ, SubFormula.Val! M ε r := by simpa using Derivation.sound dq M ε
      rcases this with (hq | ⟨r, hr, hhr⟩)
      · exact ⟨p ⋏ q, by simp, by simp[hp, hq]⟩
      · exact ⟨r, by simp[hr], hhr⟩
    · exact ⟨r, by simp[hr], hhr⟩
  | _, all Δ p d,             M, s, ε => by
    have : (∀ a : M, SubFormula.Eval! M ![a] ε p) ∨ ∃ q ∈ Δ, SubFormula.Val! M ε q := by
      simpa[shifts, SubFormula.shiftEmb, Matrix.vecConsLast_vecEmpty, forall_or_right]
        using fun a : M => Derivation.sound d M (a :>ₙ ε)
    rcases this with (hp | ⟨q, hq, hhq⟩)
    · exact ⟨∀' p, by simp, hp⟩
    · exact ⟨q, by simp[hq], hhq⟩
  | _, ex Δ t p d,            M, s, ε => by
    have : SubFormula.Eval! M ![t.val! M ![] ε] ε p ∨ ∃ p ∈ Δ, SubFormula.Val! M ε p := by
      simpa[Matrix.vecConsLast_vecEmpty] using Derivation.sound d M ε
    rcases this with (hp | ⟨q, hq, hhq⟩)
    · exact ⟨∃' p, by simp, t.val! M ![] ε, hp⟩
    · exact ⟨q, by simp[hq], hhq⟩

lemma Proof.sound {T : CTheory L} {σ : Sentence L} : T ⊢ σ → T ⊨ σ := by
  simp[consequence_iff]; rintro ⟨Γ, hΓ, d⟩ M _ _ hT
  have : M ⊧₁ σ ∨ ∃ τ ∈ Γ, M ⊧₁ τ := by simpa using Derivation.sound d M default
  rcases this with (hσ | ⟨τ, hτ, hhτ⟩)
  · assumption
  · have : ~τ ∈ T := by rcases hΓ hτ with ⟨τ', hτ', rfl⟩; simpa[←SubFormula.neg_eq] using hτ'
    have : ¬ M ⊧₁ τ := by simpa using hT this
    contradiction

end soundness

end FirstOrder


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.associated
import Mathlib.tactic.ring
import Mathlib.PostPort

universes l

namespace Mathlib

/-- The ring of integers adjoined with a square root of `d`.
  These have the form `a + b √d` where `a b : ℤ`. The components
  are called `re` and `im` by analogy to the negative `d` case,
  but of course both parts are real here since `d` is nonnegative. -/
structure zsqrtd (d : ℤ) where
  re : ℤ
  im : ℤ

prefix:100 "ℤ√" => Mathlib.zsqrtd

namespace zsqrtd

protected instance decidable_eq {d : ℤ} : DecidableEq (ℤ√d) :=
  id
    fun (_v : ℤ√d) =>
      cases_on _v
        fun (re im : ℤ) (w : ℤ√d) =>
          cases_on w
            fun (w_re w_im : ℤ) =>
              decidable.by_cases
                (fun (ᾰ : re = w_re) =>
                  Eq._oldrec
                    (decidable.by_cases (fun (ᾰ : im = w_im) => Eq._oldrec (is_true sorry) ᾰ)
                      fun (ᾰ : ¬im = w_im) => isFalse sorry)
                    ᾰ)
                fun (ᾰ : ¬re = w_re) => isFalse sorry

theorem ext {d : ℤ} {z : ℤ√d} {w : ℤ√d} : z = w ↔ re z = re w ∧ im z = im w := sorry

/-- Convert an integer to a `ℤ√d` -/
def of_int {d : ℤ} (n : ℤ) : ℤ√d := mk n 0

theorem of_int_re {d : ℤ} (n : ℤ) : re (of_int n) = n := rfl

theorem of_int_im {d : ℤ} (n : ℤ) : im (of_int n) = 0 := rfl

/-- The zero of the ring -/
def zero {d : ℤ} : ℤ√d := of_int 0

protected instance has_zero {d : ℤ} : HasZero (ℤ√d) := { zero := zero }

@[simp] theorem zero_re {d : ℤ} : re 0 = 0 := rfl

@[simp] theorem zero_im {d : ℤ} : im 0 = 0 := rfl

protected instance inhabited {d : ℤ} : Inhabited (ℤ√d) := { default := 0 }

/-- The one of the ring -/
def one {d : ℤ} : ℤ√d := of_int 1

protected instance has_one {d : ℤ} : HasOne (ℤ√d) := { one := one }

@[simp] theorem one_re {d : ℤ} : re 1 = 1 := rfl

@[simp] theorem one_im {d : ℤ} : im 1 = 0 := rfl

/-- The representative of `√d` in the ring -/
def sqrtd {d : ℤ} : ℤ√d := mk 0 1

@[simp] theorem sqrtd_re {d : ℤ} : re sqrtd = 0 := rfl

@[simp] theorem sqrtd_im {d : ℤ} : im sqrtd = 1 := rfl

/-- Addition of elements of `ℤ√d` -/
def add {d : ℤ} : ℤ√d → ℤ√d → ℤ√d := sorry

protected instance has_add {d : ℤ} : Add (ℤ√d) := { add := add }

@[simp] theorem add_def {d : ℤ} (x : ℤ) (y : ℤ) (x' : ℤ) (y' : ℤ) :
    mk x y + mk x' y' = mk (x + x') (y + y') :=
  rfl

@[simp] theorem add_re {d : ℤ} (z : ℤ√d) (w : ℤ√d) : re (z + w) = re z + re w :=
  cases_on z
    fun (z_re z_im : ℤ) =>
      cases_on w
        fun (w_re w_im : ℤ) =>
          idRhs (re (mk z_re z_im + mk w_re w_im) = re (mk z_re z_im + mk w_re w_im)) rfl

@[simp] theorem add_im {d : ℤ} (z : ℤ√d) (w : ℤ√d) : im (z + w) = im z + im w :=
  cases_on z
    fun (z_re z_im : ℤ) =>
      cases_on w
        fun (w_re w_im : ℤ) =>
          idRhs (im (mk z_re z_im + mk w_re w_im) = im (mk z_re z_im + mk w_re w_im)) rfl

@[simp] theorem bit0_re {d : ℤ} (z : ℤ√d) : re (bit0 z) = bit0 (re z) := add_re z z

@[simp] theorem bit0_im {d : ℤ} (z : ℤ√d) : im (bit0 z) = bit0 (im z) := add_im z z

@[simp] theorem bit1_re {d : ℤ} (z : ℤ√d) : re (bit1 z) = bit1 (re z) := sorry

@[simp] theorem bit1_im {d : ℤ} (z : ℤ√d) : im (bit1 z) = bit0 (im z) := sorry

/-- Negation in `ℤ√d` -/
def neg {d : ℤ} : ℤ√d → ℤ√d := sorry

protected instance has_neg {d : ℤ} : Neg (ℤ√d) := { neg := neg }

@[simp] theorem neg_re {d : ℤ} (z : ℤ√d) : re (-z) = -re z :=
  cases_on z fun (z_re z_im : ℤ) => idRhs (re (-mk z_re z_im) = re (-mk z_re z_im)) rfl

@[simp] theorem neg_im {d : ℤ} (z : ℤ√d) : im (-z) = -im z :=
  cases_on z fun (z_re z_im : ℤ) => idRhs (im (-mk z_re z_im) = im (-mk z_re z_im)) rfl

/-- Conjugation in `ℤ√d`. The conjugate of `a + b √d` is `a - b √d`. -/
def conj {d : ℤ} : ℤ√d → ℤ√d := sorry

@[simp] theorem conj_re {d : ℤ} (z : ℤ√d) : re (conj z) = re z :=
  cases_on z fun (z_re z_im : ℤ) => idRhs (re (conj (mk z_re z_im)) = re (conj (mk z_re z_im))) rfl

@[simp] theorem conj_im {d : ℤ} (z : ℤ√d) : im (conj z) = -im z :=
  cases_on z fun (z_re z_im : ℤ) => idRhs (im (conj (mk z_re z_im)) = im (conj (mk z_re z_im))) rfl

/-- Multiplication in `ℤ√d` -/
def mul {d : ℤ} : ℤ√d → ℤ√d → ℤ√d := sorry

protected instance has_mul {d : ℤ} : Mul (ℤ√d) := { mul := mul }

@[simp] theorem mul_re {d : ℤ} (z : ℤ√d) (w : ℤ√d) : re (z * w) = re z * re w + d * im z * im w :=
  cases_on z
    fun (z_re z_im : ℤ) =>
      cases_on w
        fun (w_re w_im : ℤ) =>
          idRhs (re (mk z_re z_im * mk w_re w_im) = re (mk z_re z_im * mk w_re w_im)) rfl

@[simp] theorem mul_im {d : ℤ} (z : ℤ√d) (w : ℤ√d) : im (z * w) = re z * im w + im z * re w :=
  cases_on z
    fun (z_re z_im : ℤ) =>
      cases_on w
        fun (w_re w_im : ℤ) =>
          idRhs (im (mk z_re z_im * mk w_re w_im) = im (mk z_re z_im * mk w_re w_im)) rfl

protected instance comm_ring {d : ℤ} : comm_ring (ℤ√d) :=
  comm_ring.mk Add.add sorry 0 sorry sorry Neg.neg (fun (a b : ℤ√d) => a + -b) sorry sorry Mul.mul
    sorry 1 sorry sorry sorry sorry sorry

protected instance add_comm_monoid {d : ℤ} : add_comm_monoid (ℤ√d) :=
  add_comm_group.to_add_comm_monoid (ℤ√d)

protected instance add_monoid {d : ℤ} : add_monoid (ℤ√d) := sub_neg_monoid.to_add_monoid (ℤ√d)

protected instance monoid {d : ℤ} : monoid (ℤ√d) := ring.to_monoid (ℤ√d)

protected instance comm_monoid {d : ℤ} : comm_monoid (ℤ√d) := comm_semiring.to_comm_monoid (ℤ√d)

protected instance comm_semigroup {d : ℤ} : comm_semigroup (ℤ√d) :=
  comm_ring.to_comm_semigroup (ℤ√d)

protected instance semigroup {d : ℤ} : semigroup (ℤ√d) := monoid.to_semigroup (ℤ√d)

protected instance add_comm_semigroup {d : ℤ} : add_comm_semigroup (ℤ√d) :=
  add_comm_monoid.to_add_comm_semigroup (ℤ√d)

protected instance add_semigroup {d : ℤ} : add_semigroup (ℤ√d) := add_monoid.to_add_semigroup (ℤ√d)

protected instance comm_semiring {d : ℤ} : comm_semiring (ℤ√d) := comm_ring.to_comm_semiring

protected instance semiring {d : ℤ} : semiring (ℤ√d) := ring.to_semiring

protected instance ring {d : ℤ} : ring (ℤ√d) := comm_ring.to_ring (ℤ√d)

protected instance distrib {d : ℤ} : distrib (ℤ√d) := ring.to_distrib (ℤ√d)

protected instance nontrivial {d : ℤ} : nontrivial (ℤ√d) :=
  nontrivial.mk (Exists.intro 0 (Exists.intro 1 (of_as_true trivial)))

@[simp] theorem coe_nat_re {d : ℤ} (n : ℕ) : re ↑n = ↑n := sorry

@[simp] theorem coe_nat_im {d : ℤ} (n : ℕ) : im ↑n = 0 := sorry

theorem coe_nat_val {d : ℤ} (n : ℕ) : ↑n = mk (↑n) 0 := sorry

@[simp] theorem coe_int_re {d : ℤ} (n : ℤ) : re ↑n = n := sorry

@[simp] theorem coe_int_im {d : ℤ} (n : ℤ) : im ↑n = 0 := sorry

theorem coe_int_val {d : ℤ} (n : ℤ) : ↑n = mk n 0 := sorry

protected instance char_zero {d : ℤ} : char_zero (ℤ√d) := sorry

@[simp] theorem of_int_eq_coe {d : ℤ} (n : ℤ) : of_int n = ↑n := sorry

@[simp] theorem smul_val {d : ℤ} (n : ℤ) (x : ℤ) (y : ℤ) : ↑n * mk x y = mk (n * x) (n * y) := sorry

@[simp] theorem muld_val {d : ℤ} (x : ℤ) (y : ℤ) : sqrtd * mk x y = mk (d * y) x := sorry

@[simp] theorem dmuld {d : ℤ} : sqrtd * sqrtd = ↑d := sorry

@[simp] theorem smuld_val {d : ℤ} (n : ℤ) (x : ℤ) (y : ℤ) :
    sqrtd * ↑n * mk x y = mk (d * n * y) (n * x) :=
  sorry

theorem decompose {d : ℤ} {x : ℤ} {y : ℤ} : mk x y = ↑x + sqrtd * ↑y := sorry

theorem mul_conj {d : ℤ} {x : ℤ} {y : ℤ} : mk x y * conj (mk x y) = ↑x * ↑x - ↑d * ↑y * ↑y := sorry

theorem conj_mul {d : ℤ} {a : ℤ√d} {b : ℤ√d} : conj (a * b) = conj a * conj b := sorry

protected theorem coe_int_add {d : ℤ} (m : ℤ) (n : ℤ) : ↑(m + n) = ↑m + ↑n :=
  ring_hom.map_add (int.cast_ring_hom (ℤ√d)) m n

protected theorem coe_int_sub {d : ℤ} (m : ℤ) (n : ℤ) : ↑(m - n) = ↑m - ↑n :=
  ring_hom.map_sub (int.cast_ring_hom (ℤ√d)) m n

protected theorem coe_int_mul {d : ℤ} (m : ℤ) (n : ℤ) : ↑(m * n) = ↑m * ↑n :=
  ring_hom.map_mul (int.cast_ring_hom (ℤ√d)) m n

protected theorem coe_int_inj {d : ℤ} {m : ℤ} {n : ℤ} (h : ↑m = ↑n) : m = n := sorry

/-- Read `sq_le a c b d` as `a √c ≤ b √d` -/
def sq_le (a : ℕ) (c : ℕ) (b : ℕ) (d : ℕ) := c * a * a ≤ d * b * b

theorem sq_le_of_le {c : ℕ} {d : ℕ} {x : ℕ} {y : ℕ} {z : ℕ} {w : ℕ} (xz : z ≤ x) (yw : y ≤ w)
    (xy : sq_le x c y d) : sq_le z c w d :=
  le_trans (mul_le_mul (nat.mul_le_mul_left c xz) xz (nat.zero_le z) (nat.zero_le (c * x)))
    (le_trans xy (mul_le_mul (nat.mul_le_mul_left d yw) yw (nat.zero_le y) (nat.zero_le (d * w))))

theorem sq_le_add_mixed {c : ℕ} {d : ℕ} {x : ℕ} {y : ℕ} {z : ℕ} {w : ℕ} (xy : sq_le x c y d)
    (zw : sq_le z c w d) : c * (x * z) ≤ d * (y * w) :=
  sorry

theorem sq_le_add {c : ℕ} {d : ℕ} {x : ℕ} {y : ℕ} {z : ℕ} {w : ℕ} (xy : sq_le x c y d)
    (zw : sq_le z c w d) : sq_le (x + z) c (y + w) d :=
  sorry

theorem sq_le_cancel {c : ℕ} {d : ℕ} {x : ℕ} {y : ℕ} {z : ℕ} {w : ℕ} (zw : sq_le y d x c)
    (h : sq_le (x + z) c (y + w) d) : sq_le z c w d :=
  sorry

theorem sq_le_smul {c : ℕ} {d : ℕ} {x : ℕ} {y : ℕ} (n : ℕ) (xy : sq_le x c y d) :
    sq_le (n * x) c (n * y) d :=
  sorry

theorem sq_le_mul {d : ℕ} {x : ℕ} {y : ℕ} {z : ℕ} {w : ℕ} :
    (sq_le x 1 y d → sq_le z 1 w d → sq_le (x * w + y * z) d (x * z + d * y * w) 1) ∧
        (sq_le x 1 y d → sq_le w d z 1 → sq_le (x * z + d * y * w) 1 (x * w + y * z) d) ∧
          (sq_le y d x 1 → sq_le z 1 w d → sq_le (x * z + d * y * w) 1 (x * w + y * z) d) ∧
            (sq_le y d x 1 → sq_le w d z 1 → sq_le (x * w + y * z) d (x * z + d * y * w) 1) :=
  sorry

/-- "Generalized" `nonneg`. `nonnegg c d x y` means `a √c + b √d ≥ 0`;
  we are interested in the case `c = 1` but this is more symmetric -/
def nonnegg (c : ℕ) (d : ℕ) : ℤ → ℤ → Prop := sorry

theorem nonnegg_comm {c : ℕ} {d : ℕ} {x : ℤ} {y : ℤ} : nonnegg c d x y = nonnegg d c y x := sorry

theorem nonnegg_neg_pos {c : ℕ} {d : ℕ} {a : ℕ} {b : ℕ} : nonnegg c d (-↑a) ↑b ↔ sq_le a d b c :=
  sorry

theorem nonnegg_pos_neg {c : ℕ} {d : ℕ} {a : ℕ} {b : ℕ} : nonnegg c d (↑a) (-↑b) ↔ sq_le b c a d :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nonnegg c d (↑a) (-↑b) ↔ sq_le b c a d)) nonnegg_comm))
    nonnegg_neg_pos

theorem nonnegg_cases_right {c : ℕ} {d : ℕ} {a : ℕ} {b : ℤ} :
    (∀ (x : ℕ), b = -↑x → sq_le x c a d) → nonnegg c d (↑a) b :=
  fun (ᾰ : ∀ (x : ℕ), b = -↑x → sq_le x c a d) =>
    int.cases_on b
      (fun (b : ℕ) (ᾰ : ∀ (x : ℕ), Int.ofNat b = -↑x → sq_le x c a d) => idRhs True trivial)
      (fun (b : ℕ) (ᾰ : ∀ (x : ℕ), Int.negSucc b = -↑x → sq_le x c a d) =>
        idRhs (sq_le (b + 1) c a d) (ᾰ (b + 1) rfl))
      ᾰ

theorem nonnegg_cases_left {c : ℕ} {d : ℕ} {b : ℕ} {a : ℤ}
    (h : ∀ (x : ℕ), a = -↑x → sq_le x d b c) : nonnegg c d a ↑b :=
  cast nonnegg_comm (nonnegg_cases_right h)

def norm {d : ℤ} (n : ℤ√d) : ℤ := re n * re n - d * im n * im n

@[simp] theorem norm_zero {d : ℤ} : norm 0 = 0 := sorry

@[simp] theorem norm_one {d : ℤ} : norm 1 = 1 := sorry

@[simp] theorem norm_int_cast {d : ℤ} (n : ℤ) : norm ↑n = n * n := sorry

@[simp] theorem norm_nat_cast {d : ℤ} (n : ℕ) : norm ↑n = ↑n * ↑n := norm_int_cast ↑n

@[simp] theorem norm_mul {d : ℤ} (n : ℤ√d) (m : ℤ√d) : norm (n * m) = norm n * norm m := sorry

theorem norm_eq_mul_conj {d : ℤ} (n : ℤ√d) : ↑(norm n) = n * conj n := sorry

protected instance norm.is_monoid_hom {d : ℤ} : is_monoid_hom norm := is_monoid_hom.mk norm_one

theorem norm_nonneg {d : ℤ} (hd : d ≤ 0) (n : ℤ√d) : 0 ≤ norm n := sorry

theorem norm_eq_one_iff {d : ℤ} {x : ℤ√d} : int.nat_abs (norm x) = 1 ↔ is_unit x := sorry

/-- Nonnegativity of an element of `ℤ√d`. -/
def nonneg {d : ℕ} : ℤ√↑d → Prop := sorry

protected def le {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) := nonneg (b - a)

protected instance has_le {d : ℕ} : HasLessEq (ℤ√↑d) := { LessEq := zsqrtd.le }

protected def lt {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) := ¬b ≤ a

protected instance has_lt {d : ℕ} : HasLess (ℤ√↑d) := { Less := zsqrtd.lt }

protected instance decidable_nonnegg (c : ℕ) (d : ℕ) (a : ℤ) (b : ℤ) :
    Decidable (nonnegg c d a b) :=
  int.cases_on a
    (fun (a : ℕ) =>
      int.cases_on b (fun (b : ℕ) => eq.mpr sorry (eq.mpr sorry (eq.mpr sorry decidable.true)))
        fun (b : ℕ) =>
          eq.mpr sorry (eq.mpr sorry (nat.decidable_le (c * (b + 1) * (b + 1)) (d * a * a))))
    fun (a : ℕ) =>
      int.cases_on b
        (fun (b : ℕ) =>
          eq.mpr sorry (eq.mpr sorry (nat.decidable_le (d * (a + 1) * (a + 1)) (c * b * b))))
        fun (b : ℕ) => eq.mpr sorry decidable.false

protected instance decidable_nonneg {d : ℕ} (a : ℤ√↑d) : Decidable (nonneg a) := sorry

protected instance decidable_le {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) : Decidable (a ≤ b) :=
  zsqrtd.decidable_nonneg (b - a)

theorem nonneg_cases {d : ℕ} {a : ℤ√↑d} :
    nonneg a → ∃ (x : ℕ), ∃ (y : ℕ), a = mk ↑x ↑y ∨ a = mk (↑x) (-↑y) ∨ a = mk (-↑x) ↑y :=
  sorry

theorem nonneg_add_lem {d : ℕ} {x : ℕ} {y : ℕ} {z : ℕ} {w : ℕ} (xy : nonneg (mk (↑x) (-↑y)))
    (zw : nonneg (mk (-↑z) ↑w)) : nonneg (mk (↑x) (-↑y) + mk (-↑z) ↑w) :=
  sorry

theorem nonneg_add {d : ℕ} {a : ℤ√↑d} {b : ℤ√↑d} (ha : nonneg a) (hb : nonneg b) : nonneg (a + b) :=
  sorry

theorem le_refl {d : ℕ} (a : ℤ√↑d) : a ≤ a :=
  (fun (this : nonneg (a - a)) => this)
    (eq.mpr
      (id ((fun (ᾰ ᾰ_1 : ℤ√↑d) (e_1 : ᾰ = ᾰ_1) => congr_arg nonneg e_1) (a - a) 0 (sub_self a)))
      trivial)

protected theorem le_trans {d : ℕ} {a : ℤ√↑d} {b : ℤ√↑d} {c : ℤ√↑d} (ab : a ≤ b) (bc : b ≤ c) :
    a ≤ c :=
  sorry

theorem nonneg_iff_zero_le {d : ℕ} {a : ℤ√↑d} : nonneg a ↔ 0 ≤ a := sorry

theorem le_of_le_le {d : ℕ} {x : ℤ} {y : ℤ} {z : ℤ} {w : ℤ} (xz : x ≤ z) (yw : y ≤ w) :
    mk x y ≤ mk z w :=
  sorry

theorem le_arch {d : ℕ} (a : ℤ√↑d) : ∃ (n : ℕ), a ≤ ↑n := sorry

protected theorem nonneg_total {d : ℕ} (a : ℤ√↑d) : nonneg a ∨ nonneg (-a) := sorry

protected theorem le_total {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) : a ≤ b ∨ b ≤ a :=
  let t : nonneg (b - a) ∨ nonneg (-(b - a)) := zsqrtd.nonneg_total (b - a);
  eq.mp
    (Eq._oldrec (Eq.refl (nonneg (b - a) ∨ nonneg (-(b - a))))
      ((fun (this : -(b - a) = a - b) => this) (neg_sub b a)))
    t

protected instance preorder {d : ℕ} : preorder (ℤ√↑d) :=
  preorder.mk zsqrtd.le zsqrtd.lt le_refl zsqrtd.le_trans

protected theorem add_le_add_left {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) (ab : a ≤ b) (c : ℤ√↑d) :
    c + a ≤ c + b :=
  (fun (this : nonneg (c + b - (c + a))) => this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (nonneg (c + b - (c + a)))) (add_sub_add_left_eq_sub b a c)))
      ab)

protected theorem le_of_add_le_add_left {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) (c : ℤ√↑d)
    (h : c + a ≤ c + b) : a ≤ b :=
  sorry

protected theorem add_lt_add_left {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) (h : a < b) (c : ℤ√↑d) :
    c + a < c + b :=
  fun (h' : c + b ≤ c + a) => h (zsqrtd.le_of_add_le_add_left b a c h')

theorem nonneg_smul {d : ℕ} {a : ℤ√↑d} {n : ℕ} (ha : nonneg a) : nonneg (↑n * a) := sorry

theorem nonneg_muld {d : ℕ} {a : ℤ√↑d} (ha : nonneg a) : nonneg (sqrtd * a) := sorry

theorem nonneg_mul_lem {d : ℕ} {x : ℕ} {y : ℕ} {a : ℤ√↑d} (ha : nonneg a) : nonneg (mk ↑x ↑y * a) :=
  sorry

theorem nonneg_mul {d : ℕ} {a : ℤ√↑d} {b : ℤ√↑d} (ha : nonneg a) (hb : nonneg b) : nonneg (a * b) :=
  sorry

protected theorem mul_nonneg {d : ℕ} (a : ℤ√↑d) (b : ℤ√↑d) : 0 ≤ a → 0 ≤ b → 0 ≤ a * b := sorry

theorem not_sq_le_succ (c : ℕ) (d : ℕ) (y : ℕ) (h : 0 < c) : ¬sq_le (y + 1) c 0 d :=
  not_le_of_gt (mul_pos (mul_pos h (nat.succ_pos y)) (nat.succ_pos y))

/-- A nonsquare is a natural number that is not equal to the square of an
  integer. This is implemented as a typeclass because it's a necessary condition
  for much of the Pell equation theory. -/
class nonsquare (x : ℕ) where
  ns : ∀ (n : ℕ), x ≠ n * n

theorem d_pos {d : ℕ} [dnsq : nonsquare d] : 0 < d :=
  lt_of_le_of_ne (nat.zero_le d) (ne.symm (nonsquare.ns d 0))

theorem divides_sq_eq_zero {d : ℕ} [dnsq : nonsquare d] {x : ℕ} {y : ℕ} (h : x * x = d * y * y) :
    x = 0 ∧ y = 0 :=
  sorry

theorem divides_sq_eq_zero_z {d : ℕ} [dnsq : nonsquare d] {x : ℤ} {y : ℤ} (h : x * x = ↑d * y * y) :
    x = 0 ∧ y = 0 :=
  sorry

theorem not_divides_square {d : ℕ} [dnsq : nonsquare d] (x : ℕ) (y : ℕ) :
    (x + 1) * (x + 1) ≠ d * (y + 1) * (y + 1) :=
  fun (e : (x + 1) * (x + 1) = d * (y + 1) * (y + 1)) =>
    nat.no_confusion (and.left (divides_sq_eq_zero e))

theorem nonneg_antisymm {d : ℕ} [dnsq : nonsquare d] {a : ℤ√↑d} : nonneg a → nonneg (-a) → a = 0 :=
  sorry

theorem le_antisymm {d : ℕ} [dnsq : nonsquare d] {a : ℤ√↑d} {b : ℤ√↑d} (ab : a ≤ b) (ba : b ≤ a) :
    a = b :=
  eq_of_sub_eq_zero
    (nonneg_antisymm ba (eq.mpr (id (Eq._oldrec (Eq.refl (nonneg (-(a - b)))) (neg_sub a b))) ab))

protected instance linear_order {d : ℕ} [dnsq : nonsquare d] : linear_order (ℤ√↑d) :=
  linear_order.mk preorder.le preorder.lt sorry sorry le_antisymm zsqrtd.le_total
    zsqrtd.decidable_le Mathlib.decidable_eq_of_decidable_le Mathlib.decidable_lt_of_decidable_le

protected theorem eq_zero_or_eq_zero_of_mul_eq_zero {d : ℕ} [dnsq : nonsquare d] {a : ℤ√↑d}
    {b : ℤ√↑d} : a * b = 0 → a = 0 ∨ b = 0 :=
  sorry

protected instance integral_domain {d : ℕ} [dnsq : nonsquare d] : integral_domain (ℤ√↑d) :=
  integral_domain.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg comm_ring.sub
    sorry sorry comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry sorry sorry
    zsqrtd.eq_zero_or_eq_zero_of_mul_eq_zero

protected theorem mul_pos {d : ℕ} [dnsq : nonsquare d] (a : ℤ√↑d) (b : ℤ√↑d) (a0 : 0 < a)
    (b0 : 0 < b) : 0 < a * b :=
  sorry

protected instance linear_ordered_comm_ring {d : ℕ} [dnsq : nonsquare d] :
    linear_ordered_comm_ring (ℤ√↑d) :=
  linear_ordered_comm_ring.mk comm_ring.add sorry comm_ring.zero sorry sorry comm_ring.neg
    comm_ring.sub sorry sorry comm_ring.mul sorry comm_ring.one sorry sorry sorry sorry
    linear_order.le linear_order.lt sorry sorry sorry zsqrtd.add_le_add_left sorry zsqrtd.mul_pos
    sorry linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt sorry sorry

protected instance linear_ordered_semiring {d : ℕ} [dnsq : nonsquare d] :
    linear_ordered_semiring (ℤ√↑d) :=
  linear_ordered_comm_ring.to_linear_ordered_semiring

protected instance ordered_semiring {d : ℕ} [dnsq : nonsquare d] : ordered_semiring (ℤ√↑d) :=
  ordered_ring.to_ordered_semiring

theorem norm_eq_zero {d : ℤ} (h_nonsquare : ∀ (n : ℤ), d ≠ n * n) (a : ℤ√d) : norm a = 0 ↔ a = 0 :=
  sorry

theorem hom_ext {R : Type} [comm_ring R] {d : ℤ} (f : ℤ√d →+* R) (g : ℤ√d →+* R)
    (h : coe_fn f sqrtd = coe_fn g sqrtd) : f = g :=
  sorry

/-- The unique `ring_hom` from `ℤ√d` to a ring `R`, constructed by replacing `√d` with the provided
root. Conversely, this associates to every mapping `ℤ√d →+* R` a value of `√d` in `R`. -/
@[simp] theorem lift_symm_apply_coe {R : Type} [comm_ring R] {d : ℤ} (f : ℤ√d →+* R) :
    ↑(coe_fn (equiv.symm lift) f) = coe_fn f sqrtd :=
  Eq.refl ↑(coe_fn (equiv.symm lift) f)

/-- `lift r` is injective if `d` is non-square, and R has characteristic zero (that is, the map from
`ℤ` into `R` is injective). -/
theorem lift_injective {R : Type} [comm_ring R] [char_zero R] {d : ℤ}
    (r : Subtype fun (r : R) => r * r = ↑d) (hd : ∀ (n : ℤ), d ≠ n * n) :
    function.injective ⇑(coe_fn lift r) :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne

! This file was ported from Lean 3 source module measure_theory.lattice
! leanprover-community/mathlib commit a95b442734d137aef46c1871e147089877fd0f62
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Measure.AeMeasurable

/-!
# Typeclasses for measurability of lattice operations

In this file we define classes `has_measurable_sup` and `has_measurable_inf` and prove dot-style
lemmas (`measurable.sup`, `ae_measurable.sup` etc). For binary operations we define two typeclasses:

- `has_measurable_sup` says that both left and right sup are measurable;
- `has_measurable_sup₂` says that `λ p : α × α, p.1 ⊔ p.2` is measurable,

and similarly for other binary operations. The reason for introducing these classes is that in case
of topological space `α` equipped with the Borel `σ`-algebra, instances for `has_measurable_sup₂`
etc require `α` to have a second countable topology.

For instances relating, e.g., `has_continuous_sup` to `has_measurable_sup` see file
`measure_theory.borel_space`.

## Tags

measurable function, lattice operation

-/

open MeasureTheory

/-- We say that a type `has_measurable_sup` if `((⊔) c)` and `(⊔ c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (⊔)` see `has_measurable_sup₂`. -/
class HasMeasurableSup (M : Type _) [MeasurableSpace M] [Sup M] : Prop where
  measurable_const_sup : ∀ c : M, Measurable ((· ⊔ ·) c)
  measurable_sup_const : ∀ c : M, Measurable (· ⊔ c)
#align has_measurable_sup HasMeasurableSup

/-- We say that a type `has_measurable_sup₂` if `uncurry (⊔)` is a measurable functions.
For a typeclass assuming measurability of `((⊔) c)` and `(⊔ c)` see `has_measurable_sup`. -/
class HasMeasurableSup₂ (M : Type _) [MeasurableSpace M] [Sup M] : Prop where
  measurable_sup : Measurable fun p : M × M => p.1 ⊔ p.2
#align has_measurable_sup₂ HasMeasurableSup₂

export HasMeasurableSup₂ (measurable_sup)

export HasMeasurableSup (measurable_const_sup measurable_sup_const)

/-- We say that a type `has_measurable_inf` if `((⊓) c)` and `(⊓ c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (⊓)` see `has_measurable_inf₂`. -/
class HasMeasurableInf (M : Type _) [MeasurableSpace M] [Inf M] : Prop where
  measurable_const_inf : ∀ c : M, Measurable ((· ⊓ ·) c)
  measurable_inf_const : ∀ c : M, Measurable (· ⊓ c)
#align has_measurable_inf HasMeasurableInf

/-- We say that a type `has_measurable_inf₂` if `uncurry (⊔)` is a measurable functions.
For a typeclass assuming measurability of `((⊔) c)` and `(⊔ c)` see `has_measurable_inf`. -/
class HasMeasurableInf₂ (M : Type _) [MeasurableSpace M] [Inf M] : Prop where
  measurable_inf : Measurable fun p : M × M => p.1 ⊓ p.2
#align has_measurable_inf₂ HasMeasurableInf₂

export HasMeasurableInf₂ (measurable_inf)

export HasMeasurableInf (measurable_const_inf measurable_inf_const)

variable {M : Type _} [MeasurableSpace M]

section OrderDual

instance (priority := 100) [Inf M] [HasMeasurableInf M] : HasMeasurableSup Mᵒᵈ :=
  ⟨@measurable_const_inf M _ _ _, @measurable_inf_const M _ _ _⟩

instance (priority := 100) [Sup M] [HasMeasurableSup M] : HasMeasurableInf Mᵒᵈ :=
  ⟨@measurable_const_sup M _ _ _, @measurable_sup_const M _ _ _⟩

instance (priority := 100) [Inf M] [HasMeasurableInf₂ M] : HasMeasurableSup₂ Mᵒᵈ :=
  ⟨@measurable_inf M _ _ _⟩

instance (priority := 100) [Sup M] [HasMeasurableSup₂ M] : HasMeasurableInf₂ Mᵒᵈ :=
  ⟨@measurable_sup M _ _ _⟩

end OrderDual

variable {α : Type _} {m : MeasurableSpace α} {μ : Measure α} {f g : α → M}

include m

section Sup

variable [Sup M]

section MeasurableSup

variable [HasMeasurableSup M]

@[measurability]
theorem Measurable.const_sup (hf : Measurable f) (c : M) : Measurable fun x => c ⊔ f x :=
  (measurable_const_sup c).comp hf
#align measurable.const_sup Measurable.const_sup

@[measurability]
theorem AeMeasurable.constSup (hf : AeMeasurable f μ) (c : M) : AeMeasurable (fun x => c ⊔ f x) μ :=
  (HasMeasurableSup.measurable_const_sup c).compAeMeasurable hf
#align ae_measurable.const_sup AeMeasurable.constSup

@[measurability]
theorem Measurable.sup_const (hf : Measurable f) (c : M) : Measurable fun x => f x ⊔ c :=
  (measurable_sup_const c).comp hf
#align measurable.sup_const Measurable.sup_const

@[measurability]
theorem AeMeasurable.supConst (hf : AeMeasurable f μ) (c : M) : AeMeasurable (fun x => f x ⊔ c) μ :=
  (measurable_sup_const c).compAeMeasurable hf
#align ae_measurable.sup_const AeMeasurable.supConst

end MeasurableSup

section MeasurableSup₂

variable [HasMeasurableSup₂ M]

@[measurability]
theorem Measurable.sup' (hf : Measurable f) (hg : Measurable g) : Measurable (f ⊔ g) :=
  measurable_sup.comp (hf.prod_mk hg)
#align measurable.sup' Measurable.sup'

@[measurability]
theorem Measurable.sup (hf : Measurable f) (hg : Measurable g) : Measurable fun a => f a ⊔ g a :=
  measurable_sup.comp (hf.prod_mk hg)
#align measurable.sup Measurable.sup

@[measurability]
theorem AeMeasurable.sup' (hf : AeMeasurable f μ) (hg : AeMeasurable g μ) :
    AeMeasurable (f ⊔ g) μ :=
  measurable_sup.compAeMeasurable (hf.prod_mk hg)
#align ae_measurable.sup' AeMeasurable.sup'

@[measurability]
theorem AeMeasurable.sup (hf : AeMeasurable f μ) (hg : AeMeasurable g μ) :
    AeMeasurable (fun a => f a ⊔ g a) μ :=
  measurable_sup.compAeMeasurable (hf.prod_mk hg)
#align ae_measurable.sup AeMeasurable.sup

omit m

instance (priority := 100) HasMeasurableSup₂.to_hasMeasurableSup : HasMeasurableSup M :=
  ⟨fun c => measurable_const.sup measurable_id, fun c => measurable_id.sup measurable_const⟩
#align has_measurable_sup₂.to_has_measurable_sup HasMeasurableSup₂.to_hasMeasurableSup

include m

end MeasurableSup₂

end Sup

section Inf

variable [Inf M]

section MeasurableInf

variable [HasMeasurableInf M]

@[measurability]
theorem Measurable.const_inf (hf : Measurable f) (c : M) : Measurable fun x => c ⊓ f x :=
  (measurable_const_inf c).comp hf
#align measurable.const_inf Measurable.const_inf

@[measurability]
theorem AeMeasurable.constInf (hf : AeMeasurable f μ) (c : M) : AeMeasurable (fun x => c ⊓ f x) μ :=
  (HasMeasurableInf.measurable_const_inf c).compAeMeasurable hf
#align ae_measurable.const_inf AeMeasurable.constInf

@[measurability]
theorem Measurable.inf_const (hf : Measurable f) (c : M) : Measurable fun x => f x ⊓ c :=
  (measurable_inf_const c).comp hf
#align measurable.inf_const Measurable.inf_const

@[measurability]
theorem AeMeasurable.infConst (hf : AeMeasurable f μ) (c : M) : AeMeasurable (fun x => f x ⊓ c) μ :=
  (measurable_inf_const c).compAeMeasurable hf
#align ae_measurable.inf_const AeMeasurable.infConst

end MeasurableInf

section MeasurableInf₂

variable [HasMeasurableInf₂ M]

@[measurability]
theorem Measurable.inf' (hf : Measurable f) (hg : Measurable g) : Measurable (f ⊓ g) :=
  measurable_inf.comp (hf.prod_mk hg)
#align measurable.inf' Measurable.inf'

@[measurability]
theorem Measurable.inf (hf : Measurable f) (hg : Measurable g) : Measurable fun a => f a ⊓ g a :=
  measurable_inf.comp (hf.prod_mk hg)
#align measurable.inf Measurable.inf

@[measurability]
theorem AeMeasurable.inf' (hf : AeMeasurable f μ) (hg : AeMeasurable g μ) :
    AeMeasurable (f ⊓ g) μ :=
  measurable_inf.compAeMeasurable (hf.prod_mk hg)
#align ae_measurable.inf' AeMeasurable.inf'

@[measurability]
theorem AeMeasurable.inf (hf : AeMeasurable f μ) (hg : AeMeasurable g μ) :
    AeMeasurable (fun a => f a ⊓ g a) μ :=
  measurable_inf.compAeMeasurable (hf.prod_mk hg)
#align ae_measurable.inf AeMeasurable.inf

omit m

instance (priority := 100) HasMeasurableInf₂.to_hasMeasurableInf : HasMeasurableInf M :=
  ⟨fun c => measurable_const.inf measurable_id, fun c => measurable_id.inf measurable_const⟩
#align has_measurable_inf₂.to_has_measurable_inf HasMeasurableInf₂.to_hasMeasurableInf

include m

end MeasurableInf₂

end Inf

section SemilatticeSup

open Finset

variable {δ : Type _} [MeasurableSpace δ] [SemilatticeSup α] [HasMeasurableSup₂ α]

@[measurability]
theorem Finset.measurable_sup' {ι : Type _} {s : Finset ι} (hs : s.Nonempty) {f : ι → δ → α}
    (hf : ∀ n ∈ s, Measurable (f n)) : Measurable (s.sup' hs f) :=
  Finset.sup'_induction hs _ (fun f hf g hg => hf.sup hg) fun n hn => hf n hn
#align finset.measurable_sup' Finset.measurable_sup'

@[measurability]
theorem Finset.measurable_range_sup' {f : ℕ → δ → α} {n : ℕ} (hf : ∀ k ≤ n, Measurable (f k)) :
    Measurable ((range (n + 1)).sup' nonempty_range_succ f) :=
  by
  simp_rw [← Nat.lt_succ_iff] at hf
  refine' Finset.measurable_sup' _ _
  simpa [Finset.mem_range]
#align finset.measurable_range_sup' Finset.measurable_range_sup'

@[measurability]
theorem Finset.measurable_range_sup'' {f : ℕ → δ → α} {n : ℕ} (hf : ∀ k ≤ n, Measurable (f k)) :
    Measurable fun x => (range (n + 1)).sup' nonempty_range_succ fun k => f k x :=
  by
  convert Finset.measurable_range_sup' hf
  ext x
  simp
#align finset.measurable_range_sup'' Finset.measurable_range_sup''

end SemilatticeSup


import tutorial_world.level17_by_cases --hide
open set IncidencePlane --hide

/-
This is an extra level you can use for practice.
-/

variables {Ω : Type} [IncidencePlane Ω] --hide

/- Lemma :
The only point on the segment A⬝A is A itself.
-/
@[simp] lemma one_point_segment (A B : Ω) : B ∈ A⬝A ↔ B = A :=
begin
  split,
  {
    intro hx,
    cases hx,
    {
      exact hx,
    },
    {
      cases hx,
      {
        exact hx,
      },
      {
        exfalso,
        apply (different_of_between hx).2.1,
        refl,
      }
    }
  },
  {
    intro h,
    rw h,
    left,
    refl,
  },

end


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

/-!
# Orders on a sum type

This file defines the disjoint sum and the linear (aka lexicographic) sum of two orders and provides
relation instances for `sum.lift_rel` and `sum.lex`.

We declare the disjoint sum of orders as the default set of instances. The linear order goes on a
type synonym.

## Main declarations

* `sum.has_le`, `sum.has_lt`: Disjoint sum of orders.
* `sum.lex.has_le`, `sum.lex.has_lt`: Lexicographic/linear sum of orders.

## Notation

* `α ⊕ₗ β`:  The linear sum of `α` and `β`.
-/

namespace sum
variables {α β γ δ : Type*}

/-! ### Unbundled relation classes -/

section lift_rel
variables (r : α → α → Prop) (s : β → β → Prop)

@[refl] lemma lift_rel.refl [is_refl α r] [is_refl β s] : ∀ x, lift_rel r s x x
| (inl a) := lift_rel.inl (refl _)
| (inr a) := lift_rel.inr (refl _)

instance [is_refl α r] [is_refl β s] : is_refl (α ⊕ β) (lift_rel r s) := ⟨lift_rel.refl _ _⟩

instance [is_irrefl α r] [is_irrefl β s] : is_irrefl (α ⊕ β) (lift_rel r s) :=
⟨by { rintro _ (⟨a, _, h⟩ | ⟨a, _, h⟩); exact irrefl _ h }⟩

@[trans] lemma lift_rel.trans [is_trans α r] [is_trans β s] :
  ∀ {a b c}, lift_rel r s a b → lift_rel r s b c → lift_rel r s a c
| _ _ _ (lift_rel.inl hab) (lift_rel.inl hbc) := lift_rel.inl $ trans hab hbc
| _ _ _ (lift_rel.inr hab) (lift_rel.inr hbc) := lift_rel.inr $ trans hab hbc

instance [is_trans α r] [is_trans β s] : is_trans (α ⊕ β) (lift_rel r s) :=
⟨λ _ _ _, lift_rel.trans _ _⟩

instance [is_antisymm α r] [is_antisymm β s] : is_antisymm (α ⊕ β) (lift_rel r s) :=
⟨by { rintro _ _ (⟨a, b, hab⟩ | ⟨a, b, hab⟩) (⟨_, _, hba⟩ | ⟨_, _, hba⟩); rw antisymm hab hba }⟩

end lift_rel

section lex
variables (r : α → α → Prop) (s : β → β → Prop)

instance [is_refl α r] [is_refl β s] : is_refl (α ⊕ β) (lex r s) :=
⟨by { rintro (a | a), exacts [lex.inl (refl _), lex.inr (refl _)] }⟩

instance [is_irrefl α r] [is_irrefl β s] : is_irrefl (α ⊕ β) (lex r s) :=
⟨by { rintro _ (⟨a, _, h⟩ | ⟨a, _, h⟩); exact irrefl _ h }⟩

instance [is_trans α r] [is_trans β s] : is_trans (α ⊕ β) (lex r s) :=
⟨by { rintro _ _ _ (⟨a, b, hab⟩ | ⟨a, b, hab⟩) (⟨_, c, hbc⟩ | ⟨_, c, hbc⟩),
  exacts [lex.inl (trans hab hbc), lex.sep _ _, lex.inr (trans hab hbc), lex.sep _ _] }⟩

instance [is_antisymm α r] [is_antisymm β s] : is_antisymm (α ⊕ β) (lex r s) :=
⟨by { rintro _ _ (⟨a, b, hab⟩ | ⟨a, b, hab⟩) (⟨_, _, hba⟩ | ⟨_, _, hba⟩); rw antisymm hab hba }⟩

instance [is_total α r] [is_total β s] : is_total (α ⊕ β) (lex r s) :=
⟨λ a b, match a, b with
  | inl a, inl b := (total_of r a b).imp lex.inl lex.inl
  | inl a, inr b := or.inl (lex.sep _ _)
  | inr a, inl b := or.inr (lex.sep _ _)
  | inr a, inr b := (total_of s a b).imp lex.inr lex.inr
end⟩

instance [is_trichotomous α r] [is_trichotomous β s] : is_trichotomous (α ⊕ β) (lex r s) :=
⟨λ a b, match a, b with
  | inl a, inl b := (trichotomous_of r a b).imp3 lex.inl (congr_arg _) lex.inl
  | inl a, inr b := or.inl (lex.sep _ _)
  | inr a, inl b := or.inr (or.inr $ lex.sep _ _)
  | inr a, inr b := (trichotomous_of s a b).imp3 lex.inr (congr_arg _) lex.inr
end⟩

instance [is_well_order α r] [is_well_order β s] : is_well_order (α ⊕ β) (sum.lex r s) :=
{ wf := sum.lex_wf is_well_order.wf is_well_order.wf }

end lex

/-! ### Disjoint sum of two orders -/

section disjoint

instance [has_le α] [has_le β] : has_le (α ⊕ β) := ⟨lift_rel (≤) (≤)⟩
instance [has_lt α] [has_lt β] : has_lt (α ⊕ β) := ⟨lift_rel (<) (<)⟩

lemma le_def [has_le α] [has_le β] {a b : α ⊕ β} : a ≤ b ↔ lift_rel (≤) (≤) a b := iff.rfl
lemma lt_def [has_lt α] [has_lt β] {a b : α ⊕ β} : a < b ↔ lift_rel (<) (<) a b := iff.rfl

@[simp] lemma inl_le_inl_iff [has_le α] [has_le β] {a b : α} : (inl a : α ⊕ β) ≤ inl b ↔ a ≤ b :=
lift_rel_inl_inl

@[simp] lemma inr_le_inr_iff [has_le α] [has_le β] {a b : β} : (inr a : α ⊕ β) ≤ inr b ↔ a ≤ b :=
lift_rel_inr_inr

@[simp] lemma inl_lt_inl_iff [has_lt α] [has_lt β] {a b : α} : (inl a : α ⊕ β) < inl b ↔ a < b :=
lift_rel_inl_inl

@[simp] lemma inr_lt_inr_iff [has_lt α] [has_lt β] {a b : β} : (inr a : α ⊕ β) < inr b ↔ a < b :=
lift_rel_inr_inr

@[simp] lemma not_inl_le_inr [has_le α] [has_le β] {a : α} {b : β} : ¬ inl b ≤ inr a :=
not_lift_rel_inl_inr

@[simp] lemma not_inl_lt_inr [has_lt α] [has_lt β] {a : α} {b : β} : ¬ inl b < inr a :=
not_lift_rel_inl_inr

@[simp] lemma not_inr_le_inl [has_le α] [has_le β] {a : α} {b : β} : ¬ inr b ≤ inl a :=
not_lift_rel_inr_inl

@[simp] lemma not_inr_lt_inl [has_lt α] [has_lt β] {a : α} {b : β} : ¬ inr b < inl a :=
not_lift_rel_inr_inl

section preorder
variables [preorder α] [preorder β]

instance : preorder (α ⊕ β) :=
{ le_refl := λ _, refl _,
  le_trans := λ _ _ _, trans,
  lt_iff_le_not_le := λ a b, begin
    refine ⟨λ hab, ⟨hab.mono (λ _ _, le_of_lt) (λ _ _, le_of_lt), _⟩, _⟩,
    { rintro (⟨b, a, hba⟩ | ⟨b, a, hba⟩),
      { exact hba.not_lt (inl_lt_inl_iff.1 hab) },
      { exact hba.not_lt (inr_lt_inr_iff.1 hab) } },
    { rintro ⟨⟨a, b, hab⟩ | ⟨a, b, hab⟩, hba⟩,
      { exact lift_rel.inl (hab.lt_of_not_le $ λ h, hba $ lift_rel.inl h) },
      { exact lift_rel.inr (hab.lt_of_not_le $ λ h, hba $ lift_rel.inr h) } }
  end,
  .. sum.has_le, .. sum.has_lt }

lemma inl_mono : monotone (inl : α → α ⊕ β) := λ a b, lift_rel.inl
lemma inr_mono : monotone (inr : β → α ⊕ β) := λ a b, lift_rel.inr

end preorder

instance [partial_order α] [partial_order β] : partial_order (α ⊕ β) :=
{ le_antisymm := λ _ _, antisymm,
  .. sum.preorder }

instance no_min_order [has_lt α] [has_lt β] [no_min_order α] [no_min_order β] :
  no_min_order (α ⊕ β) :=
⟨λ a, match a with
| inl a := let ⟨b, h⟩ := exists_lt a in ⟨inl b, inl_lt_inl_iff.2 h⟩
| inr a := let ⟨b, h⟩ := exists_lt a in ⟨inr b, inr_lt_inr_iff.2 h⟩
end⟩

instance no_max_order [has_lt α] [has_lt β] [no_max_order α] [no_max_order β] :
  no_max_order (α ⊕ β) :=
⟨λ a, match a with
| inl a := let ⟨b, h⟩ := exists_gt a in ⟨inl b, inl_lt_inl_iff.2 h⟩
| inr a := let ⟨b, h⟩ := exists_gt a in ⟨inr b, inr_lt_inr_iff.2 h⟩
end⟩

@[simp] lemma no_min_order_iff [has_lt α] [has_lt β] :
  no_min_order (α ⊕ β) ↔ no_min_order α ∧ no_min_order β :=
⟨λ _, by exactI ⟨⟨λ a, begin
  obtain ⟨b | b, h⟩ := exists_lt (inl a : α ⊕ β),
  { exact ⟨b, inl_lt_inl_iff.1 h⟩ },
  { exact (not_inr_lt_inl h).elim }
end⟩, ⟨λ a, begin
  obtain ⟨b | b, h⟩ := exists_lt (inr a : α ⊕ β),
  { exact (not_inl_lt_inr h).elim },
  { exact ⟨b, inr_lt_inr_iff.1 h⟩ }
end⟩⟩, λ h, @sum.no_min_order _ _ _ _ h.1 h.2⟩

@[simp] lemma no_max_order_iff [has_lt α] [has_lt β] :
  no_max_order (α ⊕ β) ↔ no_max_order α ∧ no_max_order β :=
⟨λ _, by exactI ⟨⟨λ a, begin
  obtain ⟨b | b, h⟩ := exists_gt (inl a : α ⊕ β),
  { exact ⟨b, inl_lt_inl_iff.1 h⟩ },
  { exact (not_inl_lt_inr h).elim }
end⟩, ⟨λ a, begin
  obtain ⟨b | b, h⟩ := exists_gt (inr a : α ⊕ β),
  { exact (not_inr_lt_inl h).elim },
  { exact ⟨b, inr_lt_inr_iff.1 h⟩ }
end⟩⟩, λ h, @sum.no_max_order _ _ _ _ h.1 h.2⟩

instance densely_ordered [has_lt α] [has_lt β] [densely_ordered α] [densely_ordered β] :
  densely_ordered (α ⊕ β) :=
⟨λ a b h, match a, b, h with
| inl a, inl b, lift_rel.inl h := let ⟨c, ha, hb⟩ := exists_between h in
                    ⟨to_lex (inl c), lift_rel.inl ha, lift_rel.inl hb⟩
| inr a, inr b, lift_rel.inr h := let ⟨c, ha, hb⟩ := exists_between h in
                    ⟨to_lex (inr c), lift_rel.inr ha, lift_rel.inr hb⟩
end⟩

@[simp] lemma densely_ordered_iff [has_lt α] [has_lt β] :
  densely_ordered (α ⊕ β) ↔ densely_ordered α ∧ densely_ordered β :=
⟨λ _, by exactI ⟨⟨λ a b h, begin
  obtain ⟨c | c, ha, hb⟩ := @exists_between (α ⊕ β) _ _ _ _ (inl_lt_inl_iff.2 h),
  { exact ⟨c, inl_lt_inl_iff.1 ha, inl_lt_inl_iff.1 hb⟩ },
  { exact (not_inl_lt_inr ha).elim }
end⟩, ⟨λ a b h, begin
  obtain ⟨c | c, ha, hb⟩ := @exists_between (α ⊕ β) _ _ _ _ (inr_lt_inr_iff.2 h),
  { exact (not_inl_lt_inr hb).elim },
  { exact ⟨c, inr_lt_inr_iff.1 ha, inr_lt_inr_iff.1 hb⟩ }
end⟩⟩, λ h, @sum.densely_ordered _ _ _ _ h.1 h.2⟩

@[simp] lemma swap_le_swap_iff [has_le α] [has_le β] {a b : α ⊕ β} : a.swap ≤ b.swap ↔ a ≤ b :=
by cases a; cases b;
  simp only [swap, inr_le_inr_iff, inl_le_inl_iff, not_inl_le_inr, not_inr_le_inl]

@[simp] lemma swap_lt_swap_iff [has_lt α] [has_lt β] {a b : α ⊕ β} : a.swap < b.swap ↔ a < b :=
by cases a; cases b;
  simp only [swap, inr_lt_inr_iff, inl_lt_inl_iff, not_inl_lt_inr, not_inr_lt_inl]

end disjoint

/-! ### Linear sum of two orders -/

namespace lex

notation α ` ⊕ₗ `:30 β:29 := _root_.lex (α ⊕ β)

--TODO: Can we make `inlₗ`, `inrₗ` `local notation`?

/-- Lexicographical `sum.inl`. Only used for pattern matching. -/
@[pattern] abbreviation _root_.sum.inlₗ (x : α) : α ⊕ₗ β := to_lex (sum.inl x)

/-- Lexicographical `sum.inr`. Only used for pattern matching. -/
@[pattern] abbreviation _root_.sum.inrₗ (x : β) : α ⊕ₗ β := to_lex (sum.inr x)

/-- The linear/lexicographical `≤` on a sum. -/
instance has_le [has_le α] [has_le β] : has_le (α ⊕ₗ β) := ⟨lex (≤) (≤)⟩

/-- The linear/lexicographical `<` on a sum. -/
instance has_lt [has_lt α] [has_lt β] : has_lt (α ⊕ₗ β) := ⟨lex (<) (<)⟩

@[simp] lemma to_lex_le_to_lex [has_le α] [has_le β] {a b : α ⊕ β} :
  to_lex a ≤ to_lex b ↔ lex (≤) (≤) a b := iff.rfl

@[simp] lemma to_lex_lt_to_lex [has_lt α] [has_lt β] {a b : α ⊕ β} :
  to_lex a < to_lex b ↔ lex (<) (<) a b := iff.rfl

lemma le_def [has_le α] [has_le β] {a b : α ⊕ₗ β} : a ≤ b ↔ lex (≤) (≤) (of_lex a) (of_lex b) :=
iff.rfl

lemma lt_def [has_lt α] [has_lt β] {a b : α ⊕ₗ β} : a < b ↔ lex (<) (<) (of_lex a) (of_lex b) :=
iff.rfl

@[simp] lemma inl_le_inl_iff [has_le α] [has_le β] {a b : α} :
  to_lex (inl a : α ⊕ β) ≤ to_lex (inl b) ↔ a ≤ b :=
lex_inl_inl

@[simp] lemma inr_le_inr_iff [has_le α] [has_le β] {a b : β} :
  to_lex (inr a : α ⊕ β) ≤ to_lex (inr b) ↔ a ≤ b :=
lex_inr_inr

@[simp] lemma inl_lt_inl_iff [has_lt α] [has_lt β] {a b : α} :
  to_lex (inl a : α ⊕ β) < to_lex (inl b) ↔ a < b :=
lex_inl_inl

@[simp] lemma inr_lt_inr_iff [has_lt α] [has_lt β] {a b : β} :
  to_lex (inr a : α ⊕ₗ β) < to_lex (inr b) ↔ a < b :=
lex_inr_inr

@[simp] lemma inl_le_inr [has_le α] [has_le β] (a : α) (b : β) : to_lex (inl a) ≤ to_lex (inr b) :=
lex.sep _ _

@[simp] lemma inl_lt_inr [has_lt α] [has_lt β] (a : α) (b : β) : to_lex (inl a) < to_lex (inr b) :=
lex.sep _ _

@[simp] lemma not_inr_le_inl [has_le α] [has_le β] {a : α} {b : β} :
  ¬ to_lex (inr b) ≤ to_lex (inl a) :=
lex_inr_inl

@[simp] lemma not_inr_lt_inl [has_lt α] [has_lt β] {a : α} {b : β} :
  ¬ to_lex (inr b) < to_lex (inl a) :=
lex_inr_inl

section preorder
variables [preorder α] [preorder β]

instance preorder : preorder (α ⊕ₗ β) :=
{ le_refl := refl_of (lex (≤) (≤)),
  le_trans := λ _ _ _, trans_of (lex (≤) (≤)),
  lt_iff_le_not_le := λ a b, begin
    refine ⟨λ hab, ⟨hab.mono (λ _ _, le_of_lt) (λ _ _, le_of_lt), _⟩, _⟩,
    { rintro (⟨b, a, hba⟩ | ⟨b, a, hba⟩ | ⟨b, a⟩),
      { exact hba.not_lt (inl_lt_inl_iff.1 hab) },
      { exact hba.not_lt (inr_lt_inr_iff.1 hab) },
      { exact not_inr_lt_inl hab } },
    { rintro ⟨⟨a, b, hab⟩ | ⟨a, b, hab⟩ | ⟨a, b⟩, hba⟩,
      { exact lex.inl (hab.lt_of_not_le $ λ h, hba $ lex.inl h) },
      { exact lex.inr (hab.lt_of_not_le $ λ h, hba $ lex.inr h) },
      { exact lex.sep _ _} }
  end,
  .. lex.has_le, .. lex.has_lt }

lemma to_lex_mono : monotone (@to_lex (α ⊕ β)) := λ a b h, h.lex
lemma to_lex_strict_mono : strict_mono (@to_lex (α ⊕ β)) := λ a b h, h.lex

lemma inl_mono : monotone (to_lex ∘ inl : α → α ⊕ₗ β) := to_lex_mono.comp inl_mono
lemma inr_mono : monotone (to_lex ∘ inr : β → α ⊕ₗ β) := to_lex_mono.comp inr_mono

lemma inl_strict_mono : strict_mono (to_lex ∘ inl : α → α ⊕ₗ β) :=
to_lex_strict_mono.comp inl_strict_mono

lemma inr_strict_mono : strict_mono (to_lex ∘ inr : β → α ⊕ₗ β) :=
to_lex_strict_mono.comp inr_strict_mono

end preorder

instance partial_order [partial_order α] [partial_order β] : partial_order (α ⊕ₗ β) :=
{ le_antisymm := λ _ _, antisymm_of (lex (≤) (≤)),
  .. lex.preorder }

instance linear_order [linear_order α] [linear_order β] : linear_order (α ⊕ₗ β) :=
{ le_total := total_of (lex (≤) (≤)),
  decidable_le := lex.decidable_rel,
  decidable_eq := sum.decidable_eq _ _,
  .. lex.partial_order }

/-- The lexicographical bottom of a sum is the bottom of the left component. -/
instance order_bot [has_le α] [order_bot α] [has_le β] : order_bot (α ⊕ₗ β) :=
{ bot := inl ⊥,
  bot_le := begin
    rintro (a | b),
    { exact lex.inl bot_le },
    { exact lex.sep _ _ }
  end }

@[simp] lemma inl_bot [has_le α] [order_bot α] [has_le β]: to_lex (inl ⊥ : α ⊕ β) = ⊥ := rfl

/-- The lexicographical top of a sum is the top of the right component. -/
instance order_top [has_le α] [has_le β] [order_top β] : order_top (α ⊕ₗ β) :=
{ top := inr ⊤,
  le_top := begin
    rintro (a | b),
    { exact lex.sep _ _ },
    { exact lex.inr le_top }
  end }

@[simp] lemma inr_top [has_le α] [has_le β] [order_top β] : to_lex (inr ⊤ : α ⊕ β) = ⊤ := rfl

instance bounded_order [has_le α] [has_le β] [order_bot α] [order_top β] :
  bounded_order (α ⊕ₗ β) :=
{ .. lex.order_bot, .. lex.order_top }

instance no_min_order [has_lt α] [has_lt β] [no_min_order α] [no_min_order β] :
  no_min_order (α ⊕ₗ β) :=
⟨λ a, match a with
| inl a := let ⟨b, h⟩ := exists_lt a in ⟨to_lex (inl b), inl_lt_inl_iff.2 h⟩
| inr a := let ⟨b, h⟩ := exists_lt a in ⟨to_lex (inr b), inr_lt_inr_iff.2 h⟩
end⟩

instance no_max_order [has_lt α] [has_lt β] [no_max_order α] [no_max_order β] :
  no_max_order (α ⊕ₗ β) :=
⟨λ a, match a with
| inl a := let ⟨b, h⟩ := exists_gt a in ⟨to_lex (inl b), inl_lt_inl_iff.2 h⟩
| inr a := let ⟨b, h⟩ := exists_gt a in ⟨to_lex (inr b), inr_lt_inr_iff.2 h⟩
end⟩

instance no_min_order_of_nonempty [has_lt α] [has_lt β] [no_min_order α] [nonempty α] :
  no_min_order (α ⊕ₗ β) :=
⟨λ a, match a with
| inl a := let ⟨b, h⟩ := exists_lt a in ⟨to_lex (inl b), inl_lt_inl_iff.2 h⟩
| inr a := ⟨to_lex (inl $ classical.arbitrary α), inl_lt_inr _ _⟩
end⟩

instance no_max_order_of_nonempty [has_lt α] [has_lt β] [no_max_order β] [nonempty β] :
  no_max_order (α ⊕ₗ β) :=
⟨λ a, match a with
| inl a := ⟨to_lex (inr $ classical.arbitrary β), inl_lt_inr _ _⟩
| inr a := let ⟨b, h⟩ := exists_gt a in ⟨to_lex (inr b), inr_lt_inr_iff.2 h⟩
end⟩

instance densely_ordered_of_no_max_order [has_lt α] [has_lt β] [densely_ordered α]
  [densely_ordered β] [no_max_order α] :
  densely_ordered (α ⊕ₗ β) :=
⟨λ a b h, match a, b, h with
| inl a, inl b, lex.inl h := let ⟨c, ha, hb⟩ := exists_between h in
                    ⟨to_lex (inl c), inl_lt_inl_iff.2 ha, inl_lt_inl_iff.2 hb⟩
| inl a, inr b, lex.sep _ _ := let ⟨c, h⟩ := exists_gt a in
                    ⟨to_lex (inl c), inl_lt_inl_iff.2 h, inl_lt_inr _ _⟩
| inr a, inr b, lex.inr h := let ⟨c, ha, hb⟩ := exists_between h in
                    ⟨to_lex (inr c), inr_lt_inr_iff.2 ha, inr_lt_inr_iff.2 hb⟩
end⟩

instance densely_ordered_of_no_min_order [has_lt α] [has_lt β] [densely_ordered α]
  [densely_ordered β] [no_min_order β] :
  densely_ordered (α ⊕ₗ β) :=
⟨λ a b h, match a, b, h with
| inl a, inl b, lex.inl h := let ⟨c, ha, hb⟩ := exists_between h in
                    ⟨to_lex (inl c), inl_lt_inl_iff.2 ha, inl_lt_inl_iff.2 hb⟩
| inl a, inr b, lex.sep _ _ := let ⟨c, h⟩ := exists_lt b in
                    ⟨to_lex (inr c), inl_lt_inr _ _, inr_lt_inr_iff.2 h⟩
| inr a, inr b, lex.inr h := let ⟨c, ha, hb⟩ := exists_between h in
                    ⟨to_lex (inr c), inr_lt_inr_iff.2 ha, inr_lt_inr_iff.2 hb⟩
end⟩

end lex
end sum

/-! ### Order isomorphisms -/

open order_dual sum

namespace order_iso
variables {α β γ : Type*} [has_le α] [has_le β] [has_le γ] (a : α) (b : β) (c : γ)

/-- `equiv.sum_comm` promoted to an order isomorphism. -/
@[simps apply] def sum_comm (α β : Type*) [has_le α] [has_le β] : α ⊕ β ≃o β ⊕ α :=
{ map_rel_iff' := λ a b, swap_le_swap_iff,
  ..equiv.sum_comm α β }

@[simp] lemma sum_comm_symm (α β : Type*) [has_le α] [has_le β] :
  (order_iso.sum_comm α β).symm = order_iso.sum_comm β α := rfl

/-- `equiv.sum_assoc` promoted to an order isomorphism. -/
def sum_assoc (α β γ : Type*) [has_le α] [has_le β] [has_le γ] : (α ⊕ β) ⊕ γ ≃o α ⊕ β ⊕ γ :=
{ map_rel_iff' := by { rintro ((a | a) | a) ((b | b) | b); simp },
  ..equiv.sum_assoc α β γ }

@[simp] lemma sum_assoc_apply_inl_inl : sum_assoc α β γ (inl (inl a)) = inl a := rfl
@[simp] lemma sum_assoc_apply_inl_inr : sum_assoc α β γ (inl (inr b)) = inr (inl b) := rfl
@[simp] lemma sum_assoc_apply_inr : sum_assoc α β γ (inr c) = inr (inr c) := rfl
@[simp] lemma sum_assoc_symm_apply_inl : (sum_assoc α β γ).symm (inl a) = inl (inl a) := rfl
@[simp] lemma sum_assoc_symm_apply_inr_inl : (sum_assoc α β γ).symm (inr (inl b)) = inl (inr b) :=
rfl
@[simp] lemma sum_assoc_symm_apply_inr_inr : (sum_assoc α β γ).symm (inr (inr c)) = inr c := rfl

/-- `order_dual` is distributive over `⊕` up to an order isomorphism. -/
def sum_dual_distrib (α β : Type*) [has_le α] [has_le β] : (α ⊕ β)ᵒᵈ ≃o αᵒᵈ ⊕ βᵒᵈ :=
{ map_rel_iff' := begin
  rintro (a | a) (b | b),
  { change inl (to_dual a) ≤ inl (to_dual b) ↔ to_dual (inl a) ≤ to_dual (inl b),
    simp only [to_dual_le_to_dual, inl_le_inl_iff] },
  { exact iff_of_false not_inl_le_inr not_inr_le_inl },
  { exact iff_of_false not_inr_le_inl not_inl_le_inr },
  { change inr (to_dual a) ≤ inr (to_dual b) ↔ to_dual (inr a) ≤ to_dual (inr b),
    simp only [to_dual_le_to_dual, inr_le_inr_iff] }
end,
  ..equiv.refl _ }

@[simp] lemma sum_dual_distrib_inl :
  sum_dual_distrib α β (to_dual (inl a)) = inl (to_dual a) := rfl

@[simp] lemma sum_dual_distrib_inr :
  sum_dual_distrib α β (to_dual (inr b)) = inr (to_dual b) := rfl

@[simp] lemma sum_dual_distrib_symm_inl :
  (sum_dual_distrib α β).symm (inl (to_dual a)) = to_dual (inl a) := rfl

@[simp] lemma sum_dual_distrib_symm_inr  :
  (sum_dual_distrib α β).symm (inr (to_dual b)) = to_dual (inr b) := rfl

/-- `equiv.sum_assoc` promoted to an order isomorphism. -/
def sum_lex_assoc (α β γ : Type*) [has_le α] [has_le β] [has_le γ] : (α ⊕ₗ β) ⊕ₗ γ ≃o α ⊕ₗ β ⊕ₗ γ :=
{ map_rel_iff' := λ a b, ⟨λ h, match a, b, h with
    | inlₗ (inlₗ a), inlₗ (inlₗ b), lex.inl h := lex.inl $ lex.inl h
    | inlₗ (inlₗ a), inlₗ (inrₗ b), lex.sep _ _ := lex.inl $ lex.sep _ _
    | inlₗ (inlₗ a),        inrₗ b, lex.sep _ _ := lex.sep _ _
    | inlₗ (inrₗ a), inlₗ (inrₗ b), lex.inr (lex.inl h) := lex.inl $ lex.inr h
    | inlₗ (inrₗ a),        inrₗ b, lex.inr (lex.sep _ _) := lex.sep _ _
    |       inrₗ a,        inrₗ b, lex.inr (lex.inr h) := lex.inr h
    end, λ h, match a, b, h with
    | inlₗ (inlₗ a), inlₗ (inlₗ b), lex.inl (lex.inl h) := lex.inl h
    | inlₗ (inlₗ a), inlₗ (inrₗ b), lex.inl (lex.sep _ _) := lex.sep _ _
    | inlₗ (inlₗ a),        inrₗ b, lex.sep _ _ := lex.sep _ _
    | inlₗ (inrₗ a), inlₗ (inrₗ b), lex.inl (lex.inr h) := lex.inr $ lex.inl h
    | inlₗ (inrₗ a),        inrₗ b, lex.sep _ _ := lex.inr $ lex.sep _ _
    |       inrₗ a,        inrₗ b, lex.inr h  := lex.inr $ lex.inr h
    end⟩,
  ..equiv.sum_assoc α β γ }

@[simp] lemma sum_lex_assoc_apply_inl_inl :
  sum_lex_assoc α β γ (to_lex $ inl $ to_lex $ inl a) = to_lex (inl a) := rfl

@[simp] lemma sum_lex_assoc_apply_inl_inr :
  sum_lex_assoc α β γ (to_lex $ inl $ to_lex $ inr b) = to_lex (inr $ to_lex $ inl b) := rfl

@[simp] lemma sum_lex_assoc_apply_inr :
  sum_lex_assoc α β γ (to_lex $ inr c) = to_lex (inr $ to_lex $ inr c) := rfl

@[simp] lemma sum_lex_assoc_symm_apply_inl :
  (sum_lex_assoc α β γ).symm (inl a) = inl (inl a) := rfl

@[simp] lemma sum_lex_assoc_symm_apply_inr_inl :
  (sum_lex_assoc α β γ).symm (inr (inl b)) = inl (inr b) := rfl

@[simp] lemma sum_lex_assoc_symm_apply_inr_inr :
  (sum_lex_assoc α β γ).symm (inr (inr c)) = inr c := rfl

/-- `order_dual` is antidistributive over `⊕ₗ` up to an order isomorphism. -/
def sum_lex_dual_antidistrib (α β : Type*) [has_le α] [has_le β] : (α ⊕ₗ β)ᵒᵈ ≃o βᵒᵈ ⊕ₗ αᵒᵈ :=
{ map_rel_iff' := begin
  rintro (a | a) (b | b), simp,
  { change to_lex (inr $ to_dual a) ≤ to_lex (inr $ to_dual b) ↔
      to_dual (to_lex $ inl a) ≤ to_dual (to_lex $ inl b),
    simp only [to_dual_le_to_dual, lex.inl_le_inl_iff, lex.inr_le_inr_iff] },
  { exact iff_of_false lex.not_inr_le_inl lex.not_inr_le_inl },
  { exact iff_of_true (lex.inl_le_inr _ _) (lex.inl_le_inr _ _) },
  { change to_lex (inl $ to_dual a) ≤ to_lex (inl $ to_dual b) ↔
      to_dual (to_lex $ inr a) ≤ to_dual (to_lex $ inr b),
    simp only [to_dual_le_to_dual, lex.inl_le_inl_iff, lex.inr_le_inr_iff] }
end,
  ..equiv.sum_comm α β }

@[simp] lemma sum_lex_dual_antidistrib_inl :
  sum_lex_dual_antidistrib α β (to_dual (inl a)) = inr (to_dual a) := rfl

@[simp] lemma sum_lex_dual_antidistrib_inr :
  sum_lex_dual_antidistrib α β (to_dual (inr b)) = inl (to_dual b) := rfl

@[simp] lemma sum_lex_dual_antidistrib_symm_inl :
  (sum_lex_dual_antidistrib α β).symm (inl (to_dual b)) = to_dual (inr b) := rfl

@[simp] lemma sum_lex_dual_antidistrib_symm_inr :
  (sum_lex_dual_antidistrib α β).symm (inr (to_dual a)) = to_dual (inl a) := rfl

end order_iso


import Basic
open Brick

-- a wall is a tangle if, for every two rows of bricks,
-- the number of outputs from the first row matches the number of inputs from the second row
def isTangle : Wall → Prop
  | [] => true
  | [_] => true
  | bs::bs'::w => bs.codomain = bs'.domain ∧ isTangle (bs'::w)

def Tangle := { w : Wall // isTangle w }

namespace Tangle

def domain (t : Tangle) : Nat := match t.val with
  | [] => 0
  | bs::_ => bs.domain
def codomain (t : Tangle) : Nat := match t.val with
  | [] => 0
  | hd::tl => Bricks.codomain (tl.getLastD hd)

theorem cons_tangle_tl : isTangle (hd::tl) → isTangle tl := by
  intro t
  cases tl with
  | nil => rfl
  | cons => exact t.right

theorem append_tangle_fst : isTangle (a ++ b) → isTangle a := by
  intro t
  induction a with
  | nil => rfl
  | cons _ tl h => cases tl with
    | nil => rfl
    | cons => exact And.intro t.left (h t.right)
theorem append_tangle_snd : isTangle (a ++ b) → isTangle b := by
  intro t
  induction a with
  | nil => exact t
  | cons hd tl hind => cases tl with
    | nil => cases b with
      | nil => rfl
      | cons => exact t.right
    | cons => exact hind t.right

theorem codomain_append {a b : Wall} {ht : isTangle (a ++ b)} : b ≠ [] → Tangle.codomain ⟨a ++ b, ht⟩ = Tangle.codomain ⟨b, append_tangle_snd ht⟩ := by
  intros
  cases a with
  | nil => simp
  | cons =>
    cases b with
    | nil => contradiction
    | cons =>
      simp [Tangle.codomain]
      -- there's very litte in stdlib for getLast proofs
      have last_append_cons {α : Type} {hd j: α} {tl k: List α} : List.getLastD (k++(hd::tl)) j = List.getLastD tl hd := by
        have get_last_d_cons {α : Type} {hd j: α} {tl : List α} : List.getLastD (hd::tl) j = List.getLastD tl hd := by
          induction tl with
          | nil => simp [List.getLastD, List.getLast]
          | cons => simp [List.getLastD, List.getLast]
        revert j
        induction k with
        | nil => simp [get_last_d_cons]
        | cons _ _ h =>
          intro
          rewrite [List.cons_append, get_last_d_cons, h]
          rfl
      rewrite [last_append_cons]
      rfl

@[simp] theorem codomain_append_cons : {a : List Bricks} → {ht: isTangle (a ++ (hd::b))} →
  Tangle.codomain ⟨a ++ (hd::b), ht⟩ = Tangle.codomain ⟨hd::b, append_tangle_snd ht⟩ := Tangle.codomain_append List.noConfusion

def happend_tangle : (a b : Wall) → (hlen : a.length = b.length) → isTangle a → isTangle b → isTangle (Wall.happend a b hlen) := by
  intro a
  induction a <;> intro b <;> cases b <;> try { intro hlen; contradiction }
  case nil.nil => intros; simp [Wall.happend, isTangle]
  case cons.cons ahd atl h bhd btl =>
    cases atl <;> cases btl <;> try { intro hlen; simp at hlen; contradiction; }
    case nil.nil => intros; simp [Wall.happend, isTangle]
    case cons.cons ahd' atl bhd' btl =>
      intro hlen ta tb
      simp [Wall.happend, isTangle]
      apply And.intro
      case right =>
        have h' := h (bhd'::btl) (by simp; simp at hlen; exact hlen) (by simp [isTangle] at ta; exact ta.right) (by simp [isTangle] at tb; exact tb.right)
        simp [Wall.happend] at h'
        exact h'
      case left =>
        have foldr_distr (a b : List Brick) (f : Brick → Nat) : ((a++b).map f).foldr Nat.add 0 = (a.map f).foldr Nat.add 0 + (b.map f).foldr Nat.add 0 := by
          induction a with
          | nil => simp [List.map, List.foldr]
          | cons hd tl h => rewrite [List.cons_append]; simp [List.map, List.foldr]; rewrite [h, Nat.add_assoc]; rfl
        rewrite [Bricks.codomain, Bricks.domain]
        repeat rewrite [foldr_distr]
        repeat rewrite [←Bricks.codomain, ←Bricks.domain]
        rewrite [ta.left, tb.left]
        rfl

def happend (a b : Tangle) (hlen : a.val.length = b.val.length) : Tangle where
  val := Wall.happend a.val b.val hlen
  property := happend_tangle a.val b.val hlen a.property b.property

theorem happend_cons_tangle: isTangle (Wall.happend (a'::a) (b'::b) hlen') → isTangle (Wall.happend a b hlen) := by sorry
theorem happend_left_tangle {a b : Wall} {hlen : a.length = b.length} : isTangle (Wall.happend a b hlen) → isTangle a → isTangle b := by
  revert b
  induction a with
  | nil => intro b; intros; cases b <;> trivial
  | cons ahd a h =>
    intro b; cases b <;> intros <;> try { trivial }
    case cons bhd b hlen _ _ =>
    -- need to prove (isTangle ((ahd::a).happend (bhd::b))) → isTangle (ahd::a) → isTangle b → isTangle (bhd::b)
    cases a <;> cases b <;> try { simp at hlen; trivial }
    case cons ahd' a ta bhd' b tapp =>
    have h := by
      have hlen' : (ahd'::a).length = (bhd'::b).length := by
        rewrite [List.length] at hlen
        have hlen := Eq.symm hlen; rewrite [List.length] at hlen
        exact (Nat.add_right_cancel (Eq.symm hlen))
      exact @h _ hlen' (happend_cons_tangle tapp) ta.right

    -- have isTangle (bhd'::b), need to prove bhd.codomain = bhd'.domain
    have tbl : bhd.codomain = bhd'.domain := by
      have tappl := tapp.left
      simp at tappl
      rewrite [Bricks.codomain_append, Bricks.domain_append] at tappl
      rewrite [ta.left] at tappl
      exact (Nat.add_left_cancel tappl)

    exact And.intro tbl h

theorem happend_right_tangle {a b : Wall} {hlen : a.length = b.length} : isTangle (Wall.happend a b hlen) → isTangle b → isTangle a := by
  sorry

@[simp] theorem wall_happend {w : Wall} {t : Tangle} {hlen : w.length = t.val.length} {tapp : isTangle (w.happend t.val hlen)}:
  ⟨(w.happend t.val hlen), tapp⟩ = Tangle.happend ⟨w, (happend_right_tangle tapp t.property)⟩ t hlen
:= sorry
@[simp] theorem happend_wall {w : Wall} {t : Tangle} {hlen : t.val.length = w.length} {tapp : isTangle (t.val.happend w hlen)}:
  ⟨(t.val.happend w hlen), tapp⟩ = Tangle.happend t ⟨w, (happend_left_tangle tapp t.property)⟩ hlen
:= sorry

@[simp] theorem domain_happend_add {a b : Tangle} {hlen: a.val.length = b.val.length}:
  Tangle.domain (a.happend b hlen) = Tangle.domain a + Tangle.domain b := by sorry
@[simp] theorem codomain_happend_add {a b : Tangle} {hlen: a.val.length = b.val.length}:
  Tangle.codomain (a.happend b hlen) = Tangle.codomain a + Tangle.codomain b := by sorry

end Tangle

namespace Equivalence

inductive Surgery : Wall → Wall → Prop
  | top : Surgery a b → (c : Wall) → Surgery (a ++ c) (b ++ c)
  | bottom : Surgery a b → (c : Wall) → Surgery (c ++ a) (c ++ b)
  | right: Surgery a b → (c : Tangle) → (h : a.length = c.val.length ∧ b.length = c.val.length) → Surgery (a.happend c.val h.left) (b.happend c.val h.right)
  | left: Surgery a b → (c : Tangle) → (h : c.val.length = a.length ∧ c.val.length = b.length) → Surgery (c.val.happend a h.left) (c.val.happend b h.right)

inductive LocalHomotopic : Wall → Wall → Prop
  | planar : PlanarIsotopic a b → LocalHomotopic a b
  | rmove : ReidemeisterMove a b → LocalHomotopic a b
  | surgery : Surgery a b → LocalHomotopic a b
  -- equiv
  | id : LocalHomotopic a a
  | symm : LocalHomotopic a b → LocalHomotopic b a
  | trans : LocalHomotopic a b → LocalHomotopic b c → LocalHomotopic a c

inductive Homotopic : Wall → Wall → Prop
  | surgery : LocalHomotopic a b → Homotopic a b
  | vflip : Homotopic a a.vflip
  | hflip : Homotopic a a.hflip
  -- equiv
  | id : Homotopic a a
  | symm : Homotopic a b → Homotopic b a
  | trans : Homotopic a b → Homotopic b c → Homotopic a c

theorem verts_boundary_eq_n { n : Nat } : Bricks.domain (vert_bricks n) = n ∧ Bricks.codomain (vert_bricks n) = n := by
  induction n with
  | zero => simp
  | succ n' h =>
      simp [vert_bricks]
      rewrite [←vert_bricks, h.left, Brick.domain, h.right, Brick.codomain]
      -- don't know how to simplify '(match true with |true => a |false => b)' to 'a'
      simp
      apply Nat.add_comm

-- height_eq is useful because Wall.happend requires it (and LocalHomotopic.left/right use happend)
theorem piso_height_eq : { w₁ w₂ : Wall } → PlanarIsotopic w₁ w₂ → w₁.length = w₂.length := by
  intro a b piso
  cases piso <;> rfl

theorem rmove_height_eq : { w₁ w₂ : Wall } → ReidemeisterMove w₁ w₂ → w₁.length = w₂.length := by
  intro a b rmove
  cases rmove <;> rfl

theorem surgery_height_eq : { w₁ w₂ : Wall } → Surgery w₁ w₂ → w₁.length = w₂.length := by
  intro a b srgy
  sorry

theorem homt_height_eq : { w₁ w₂ : Wall } → LocalHomotopic w₁ w₂ → w₁.length = w₂.length := by
  intro a b lhomt
  induction lhomt with
  | planar piso => exact piso_height_eq piso
  | rmove rmove => exact rmove_height_eq rmove
  | surgery srgy => exact surgery_height_eq srgy
  | id => exact Eq.refl _
  | symm _ h => exact Eq.symm h
  | trans _ _ hab hbc => exact Eq.trans hab hbc

-- boundary equivalence is useful for knot surgery proofs
theorem piso_boundary_eq : { w₁ w₂ : Wall } → PlanarIsotopic w₁ w₂ → (ht₁ : isTangle w₁) → (ht₂ : isTangle w₂)
  → Tangle.domain ⟨w₁, ht₁⟩ = Tangle.domain ⟨w₂, ht₂⟩ ∧ Tangle.codomain ⟨w₁, ht₁⟩ = Tangle.codomain ⟨w₂, ht₂⟩ := by
  sorry

theorem rmove_boundary_eq : { w₁ w₂ : Wall } → ReidemeisterMove w₁ w₂ → (ht₁ : isTangle w₁) → (ht₂ : isTangle w₂)
  → Tangle.domain ⟨w₁, ht₁⟩ = Tangle.domain ⟨w₂, ht₂⟩ ∧ Tangle.codomain ⟨w₁, ht₁⟩ = Tangle.codomain ⟨w₂, ht₂⟩ := by
  sorry

theorem surgery_boundary_eq : { w₁ w₂ : Wall } → Surgery w₁ w₂ → (ht₁ : isTangle w₁) → (ht₂ : isTangle w₂)
  → Tangle.domain ⟨w₁, ht₁⟩ = Tangle.domain ⟨w₂, ht₂⟩ ∧ Tangle.codomain ⟨w₁, ht₁⟩ = Tangle.codomain ⟨w₂, ht₂⟩
  := by
  intro a b srgy ta tb
  apply And.intro
  checkpoint case left => -- domain
    induction srgy with
    | @top a b homt c h =>
      have h := (h (Tangle.append_tangle_fst ta) (Tangle.append_tangle_fst tb))
      have hlen := surgery_height_eq homt
      cases a <;> cases b <;> try { simp at hlen }
      case nil => simp
      case cons h _ _ _ _ => exact h
    | @bottom a b _ c h =>
      cases c with
      | nil => exact (h ta tb)
      | cons hd tl => simp [Tangle.domain]

    | @left a b _ c hlen h =>
      -- for some reason I can't call apply Tangle.mk
      cases c; case mk c hc =>

      have h := (h (Tangle.happend_left_tangle ta hc) (Tangle.happend_left_tangle tb hc))
      -- we want to tease out Bricks.domain statements from Tangle.domain
      -- so split out cases to [], _::_
      -- since all the lengths must be equal (hlen), we can remove a bunch of
      -- absurd cases using contradictions
      cases c <;> cases a <;> cases b <;> simp at hlen
      case nil => trivial
      case cons =>
        simp [Tangle.domain, Wall.happend]
        simp [Tangle.domain] at h
        -- have Bricks.domain ahd = Bricks.domain bhd
        -- want Bricks.domain (chd++ahd) = Bricks.domain (chd++bhd)
        repeat rewrite [Bricks.domain_append]
        rewrite [h]
        rfl

    | @right a b homt c hlen h =>
      cases c; case mk c hc =>

      have h := (h (Tangle.happend_right_tangle ta hc) (Tangle.happend_right_tangle tb hc))
      cases c <;> cases a <;> cases b <;> simp at hlen
      case nil => trivial
      case cons =>
        simp [Tangle.domain, Wall.happend]
        simp [Tangle.domain] at h
        repeat rewrite [Bricks.domain_append]
        rewrite [h]
        rfl

  checkpoint case right => -- codomain
    induction srgy with
    | @top a b _ c h =>
      cases c with
      | nil => simp; exact (h (Tangle.append_tangle_fst ta) (Tangle.append_tangle_fst tb))
      | cons => repeat rewrite [Tangle.codomain_append_cons, Tangle.codomain_append_cons]; rfl

    | @bottom a b homt c h =>
      induction c with
      | nil => exact (h (Tangle.append_tangle_snd ta) (Tangle.append_tangle_snd tb))
      | cons hd tl h =>
        cases a <;> cases b
          <;> try { have hlen := surgery_height_eq homt; trivial }
        case cons h _ _ _ _ =>
          have h := (h (Tangle.cons_tangle_tl ta) (Tangle.cons_tangle_tl tb))
          repeat rewrite [Tangle.codomain_append_cons]
          repeat rewrite [Tangle.codomain_append_cons] at h
          exact h

    | @left a b _ c hlen h =>
      repeat rewrite [Tangle.happend_wall, Tangle.codomain_happend_add]
      have h := h (Tangle.happend_left_tangle ta c.property) (Tangle.happend_left_tangle tb c.property)
      rewrite [h]
      rfl
    | @right a b _ c hlen h =>
      have h := h (Tangle.happend_right_tangle ta c.property) (Tangle.happend_right_tangle tb c.property)
      repeat rewrite [Tangle.wall_happend, Tangle.codomain_happend_add]
      rewrite [h]
      rfl

theorem homt_boundary_eq : { w₁ w₂ : Wall } → LocalHomotopic w₁ w₂ → (ht₁ : isTangle w₁) → (ht₂ : isTangle w₂)
  → Tangle.domain ⟨w₁, ht₁⟩ = Tangle.domain ⟨w₂, ht₂⟩ ∧ Tangle.codomain ⟨w₁, ht₁⟩ = Tangle.codomain ⟨w₂, ht₂⟩
  := by
  intro w₁ w₂ homt ht₁ ht₂
  induction homt with
  | planar m => exact piso_boundary_eq m ht₁ ht₂
  | rmove m => exact rmove_boundary_eq m ht₁ ht₂
  | surgery m => exact surgery_boundary_eq m ht₁ ht₂
  | id => simp
  | symm homt hind =>
    have hind := hind ht₂ ht₁
    exact And.intro (Eq.symm hind.left) (Eq.symm hind.right)
  | trans homab hombc hindab hindbc =>
    have hindab := hindab ht₁
    have hindbc (ht₃ : isTangle _) := hindbc ht₃ ht₂
    -- need proof of LocalHomotopic a b → (isTangle a = isTangle b)
    -- but this proof is supposed to be a lemma for that proof ...
    sorry

theorem piso_tangle_inv : { a b : Wall } → PlanarIsotopic a b → (isTangle a = isTangle b) := by
  intro a b m
  induction m <;> simp [isTangle]
  case slide => rewrite [verts_boundary_eq_n.left, verts_boundary_eq_n.right]; simp

theorem rmove_tangle_inv : { a b : Wall } → ReidemeisterMove a b → (isTangle a = isTangle b) := by
  intro a b m
  induction m <;> simp [isTangle]

theorem surgery_tangle_inv : { a b : Wall } → Surgery a b → (isTangle a = isTangle b) := by
  intro a b m
  sorry

theorem homt_tangle_inv : { a b : Wall } → LocalHomotopic a b → (isTangle a = isTangle b) := by
  intro a b homt
  induction homt with
  | planar m => exact piso_tangle_inv m
  | rmove m => exact rmove_tangle_inv m
  | surgery m => exact surgery_tangle_inv m
  | id => rfl
  | symm _ hind => exact Eq.symm hind
  | trans _ _ tab tbc => rewrite [tab, tbc]; rfl

end Equivalence


/-
Copyright (c) 2021 Bhavik Mehta, Thomas Bloom. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Thomas Bloom
-/

import data.real.basic
import analysis.special_functions.log.basic
import analysis.special_functions.pow
import order.filter.at_top_bot
import number_theory.arithmetic_function
import algebra.is_prime_pow

/-!
# Title

This file should contain a formal proof of https://arxiv.org/pdf/2112.03726.pdf, but for now it
contains associated results useful for that paper.
-/

open_locale big_operators -- this lets me use ∑ and ∏ notation
open filter real finset
open nat (coprime)

open_locale arithmetic_function classical
noncomputable theory

section

variables (A : set ℕ)

def partial_density (N : ℕ) : ℝ := ((range N).filter (λ n, n ∈ A)).card / N

def upper_density : ℝ := limsup at_top (partial_density A)

variables {A}

lemma partial_density_sdiff_finset (N : ℕ) (S : finset ℕ) :
  partial_density A N ≤ partial_density (A \ S) N + S.card / N :=
begin
  rw [partial_density, partial_density, ←add_div],
  refine div_le_div_of_le (nat.cast_nonneg _) _,
  rw [←nat.cast_add, nat.cast_le],
  refine (card_le_of_subset _).trans (card_union_le _ _),
  intros x hx,
  simp only [mem_filter] at hx,
  simp only [mem_union, mem_filter, set.mem_diff, hx.1, hx.2, mem_coe, true_and],
  apply em'
end

lemma is_bounded_under_ge_partial_density : is_bounded_under (≥) at_top (partial_density A) :=
is_bounded_under_of ⟨0, λ x, div_nonneg (nat.cast_nonneg _) (nat.cast_nonneg _)⟩

lemma is_cobounded_under_le_partial_density : is_cobounded_under (≤) at_top (partial_density A) :=
is_bounded_under_ge_partial_density.is_cobounded_le

lemma is_bounded_under_le_partial_density : is_bounded_under (≤) at_top (partial_density A) :=
is_bounded_under_of
  ⟨1, λ x, div_le_one_of_le
    (nat.cast_le.2 ((card_le_of_subset (filter_subset _ _)).trans (by simp))) (nat.cast_nonneg _)⟩

lemma upper_density_preserved {S : finset ℕ} :
  upper_density A = upper_density (A \ (S : set ℕ)) :=
begin
  apply ge_antisymm,
  { refine limsup_le_limsup _ is_cobounded_under_le_partial_density
      is_bounded_under_le_partial_density,
    refine eventually_of_forall (λ N, div_le_div_of_le (nat.cast_nonneg _) _),
    refine nat.mono_cast (card_le_of_subset _),
    letI := classical.prop_decidable,
    refine monotone_filter_right _ (λ n, _),
    simp only [set.mem_diff, le_Prop_eq, and_imp, implies_true_iff] {contextual := tt} },
  rw le_iff_forall_pos_le_add,
  intros ε hε,
  rw ←sub_le_iff_le_add,
  apply le_Limsup_of_le is_bounded_under_le_partial_density,
  rintro a (ha : ∀ᶠ n : ℕ in at_top, _ ≤ _),
  rw sub_le_iff_le_add,
  apply Limsup_le_of_le is_cobounded_under_le_partial_density,
  change ∀ᶠ n : ℕ in at_top, _ ≤ _,
  have := tendsto_coe_nat_at_top_at_top.eventually_ge_at_top (↑S.card / ε),
  filter_upwards [ha, this, eventually_gt_at_top 0] with N hN hN' hN'',
  have : 0 < (N : ℝ) := nat.cast_pos.2 hN'',
  rw [div_le_iff hε, ←div_le_iff' this] at hN',
  exact (partial_density_sdiff_finset _ S).trans (add_le_add hN hN'),
end

lemma frequently_nat_of {ε : ℝ} (hA : ε < upper_density A) :
  ∃ᶠ (N : ℕ) in at_top, ε < ((range N).filter (λ n, n ∈ A)).card / N :=
frequently_lt_of_lt_limsup is_cobounded_under_le_partial_density hA

lemma exists_nat_of {ε : ℝ} (hA : ε < upper_density A) :
  ∃ (N : ℕ), 0 < N ∧ ε < ((range N).filter (λ n, n ∈ A)).card / N :=
by simpa using frequently_at_top'.1 (frequently_nat_of hA) 0

lemma exists_density_of {ε : ℝ} (hA : ε < upper_density A) :
  ∃ (N : ℕ), 0 < N ∧ ε * N < ((range N).filter (λ n, n ∈ A)).card :=
begin
  obtain ⟨N, hN, hN'⟩ := exists_nat_of hA,
  refine ⟨N, hN, _⟩,
  rwa lt_div_iff at hN',
  rwa nat.cast_pos
end

lemma upper_density_nonneg : 0 ≤ upper_density A :=
begin
  refine le_limsup_of_frequently_le _ is_bounded_under_le_partial_density,
  exact frequently_of_forall (λ x, div_nonneg (nat.cast_nonneg _) (nat.cast_nonneg _)),
end

end

-- This is R(A) in the paper.
def rec_sum (A : finset ℕ) : ℚ := ∑ n in A, 1/n

lemma rec_sum_bUnion_disjoint {A : finset (finset ℕ)}
  (hA : (A : set (finset ℕ)).pairwise_disjoint id) : rec_sum (A.bUnion id) = ∑ s in A, rec_sum s :=
by simp only [rec_sum, sum_bUnion hA, id.def]

lemma rec_sum_disjoint {A B : finset ℕ} (h : disjoint A B) :
   rec_sum (A ∪ B) = rec_sum A + rec_sum B :=
by simp only [rec_sum, sum_union h]

@[simp] lemma rec_sum_empty : rec_sum ∅ = 0 := by simp [rec_sum]

lemma rec_sum_nonneg {A : finset ℕ} : 0 ≤ rec_sum A :=
sum_nonneg (λ i hi, div_nonneg zero_le_one (nat.cast_nonneg _))

lemma rec_sum_mono {A₁ A₂ : finset ℕ} (h : A₁ ⊆ A₂) : rec_sum A₁ ≤ rec_sum A₂ :=
sum_le_sum_of_subset_of_nonneg h (λ _ _ _, div_nonneg zero_le_one (nat.cast_nonneg _))

-- can make this stronger without 0 ∉ A but we never care about that case
lemma rec_sum_eq_zero_iff {A : finset ℕ} (hA : 0 ∉ A) : rec_sum A = 0 ↔ A = ∅ :=
begin
  symmetry,
  split,
  { rintro rfl,
    simp },
  simp_rw [rec_sum, one_div],
  rw [sum_eq_zero_iff_of_nonneg (λ i hi, _)],
  { intro h,
    simp only [one_div, inv_eq_zero, nat.cast_eq_zero] at h,
    apply eq_empty_of_forall_not_mem,
    intros x hx,
    cases h x hx,
    apply hA hx },
  exact inv_nonneg.2 (nat.cast_nonneg _),
end

lemma nonempty_of_rec_sum_recip {A : finset ℕ} {d : ℕ} (hd : 1 ≤ d) :
  rec_sum A = 1 / d → A.nonempty :=
begin -- should be able to simplify this
  intro h,
  rw [nonempty_iff_ne_empty],
  rintro rfl,
  simp only [one_div, zero_eq_inv, rec_sum_empty] at h,
  have : 0 < d := hd,
  exact this.ne (by exact_mod_cast h),
end

/--
This is A_q in the paper.
-/
def local_part (A : finset ℕ) (q : ℕ) : finset ℕ := A.filter (λ n, q ∣ n ∧ coprime q (n / q))

lemma mem_local_part {A : finset ℕ} {q : ℕ} (n : ℕ) :
  n ∈ local_part A q ↔ n ∈ A ∧ q ∣ n ∧ coprime q (n / q) :=
by rw [local_part, mem_filter]

lemma local_part_mono {A₁ A₂ : finset ℕ} {q : ℕ} (h : A₁ ⊆ A₂) :
  local_part A₁ q ⊆ local_part A₂ q :=
filter_subset_filter _ h

lemma local_part_subset {A : finset ℕ} {q : ℕ} :
  local_part A q ⊆ A :=
filter_subset _ _

lemma zero_mem_local_part_iff {A : finset ℕ} {q : ℕ} (hA : 0 ∉ A) :
  0 ∉ local_part A q :=
λ i, hA (local_part_subset i)

/--
This is Q_A in the paper. The definition looks a bit different, but `mem_ppowers_in_set` shows
it's the same thing.
-/
def ppowers_in_set (A : finset ℕ) : finset ℕ :=
A.bUnion (λ n, n.divisors.filter (λ q, is_prime_pow q ∧ coprime q (n / q)))

@[simp] lemma ppowers_in_set_empty : ppowers_in_set ∅ = ∅ := bUnion_empty

lemma ppowers_in_set_insert_zero (A : finset ℕ) : ppowers_in_set (insert 0 A) = ppowers_in_set A :=
by rw [ppowers_in_set, ppowers_in_set, bUnion_insert, nat.divisors_zero, filter_empty, empty_union]

lemma ppowers_in_set_erase_zero (A : finset ℕ) : ppowers_in_set (A.erase 0) = ppowers_in_set A :=
begin
  by_cases 0 ∈ A,
  { rw [←ppowers_in_set_insert_zero, insert_erase h] },
  { rw finset.erase_eq_of_not_mem h },
end

lemma mem_ppowers_in_set {A : finset ℕ} {q : ℕ} :
  q ∈ ppowers_in_set A ↔ is_prime_pow q ∧ (local_part A q).nonempty :=
begin
  simp only [ppowers_in_set, mem_bUnion, mem_filter, exists_prop, nat.mem_divisors,
    finset.nonempty, mem_local_part, ←exists_and_distrib_left],
  refine exists_congr (λ i, _),
  split,
  { rintro ⟨h₁, h₂, h₃, h₄⟩,
    exact ⟨h₃, h₁, h₂.1, h₄⟩ },
  { rintro ⟨h₁, h₂, h₃, h₄⟩,
    refine ⟨h₂, ⟨h₃, _⟩, h₁, h₄⟩,
    rintro rfl,
    simp only [nat.zero_div, nat.coprime_zero_right] at h₄,
    exact h₁.ne_one h₄ },
end

lemma zero_not_mem_ppowers_in_set {A : finset ℕ} : 0 ∉ ppowers_in_set A :=
λ t, not_is_prime_pow_zero (mem_ppowers_in_set.1 t).1

lemma nat.pow_eq_one_iff {n k : ℕ} : n ^ k = 1 ↔ n = 1 ∨ k = 0 :=
begin
  rcases eq_or_ne k 0 with rfl | hk,
  { simp },
  { simp [pow_eq_one_iff, hk] },
end

lemma coprime_div_iff {n p k : ℕ} (hp : p.prime) (hn : p ^ k ∣ n) (hk : k ≠ 0) :
  nat.coprime (p^k) (n / p^k) → k = n.factorization p :=
begin
  rcases eq_or_ne n 0 with rfl | hn',
  { simp [nat.pow_eq_one_iff, hp.ne_one] },
  intro h,
  have := nat.factorization_mul_of_coprime h,
  rw [nat.mul_div_cancel' hn] at this,
  rw [this, hp.factorization_pow, finsupp.coe_add, pi.add_apply, finsupp.single_eq_same,
    self_eq_add_right, ←finsupp.not_mem_support_iff],
  intro i,
  apply nat.factorization_disjoint_of_coprime h,
  simp only [inf_eq_inter, mem_inter],
  refine ⟨_, i⟩,
  simp only [nat.support_factorization],
  rw [nat.prime_pow_prime_divisor hk hp, finset.mem_singleton],
end

lemma factorization_disjoint_iff {a b : ℕ} (ha : a ≠ 0) (hb : b ≠ 0) :
  disjoint a.factorization.support b.factorization.support ↔ a.coprime b :=
begin
  rw ←@not_not (a.coprime b),
  simp [disjoint_left, nat.prime.not_coprime_iff_dvd, nat.mem_factors ha, nat.mem_factors hb]
    {contextual := tt},
end

lemma factorization_eq_iff {n p k : ℕ} (hp : p.prime) (hk : k ≠ 0) :
  p ^ k ∣ n ∧ (p ^ k).coprime (n / p ^ k) ↔ n.factorization p = k :=
begin
  split,
  { rintro ⟨h₁, h₂⟩,
    rw ←coprime_div_iff hp h₁ hk h₂ },
  intro hk',
  have : p ^ k ∣ n,
  { rw ←hk',
    exact nat.pow_factorization_dvd n p },
  have hn : n ≠ 0,
  { rintro rfl,
    apply hk,
    simpa using hk'.symm },
  refine ⟨this, _⟩,
  rw ←factorization_disjoint_iff (pow_ne_zero _ hp.ne_zero),
  { rw [nat.factorization_div this, hp.factorization_pow, finsupp.support_single_ne_zero _ hk,
      disjoint_singleton_left, finsupp.mem_support_iff, finsupp.coe_tsub, pi.sub_apply, ne.def,
      tsub_eq_zero_iff_le, not_not, finsupp.single_eq_same, hk'] },
  rw [ne.def, nat.div_eq_zero_iff (pow_pos hp.pos _), not_lt],
  apply nat.le_of_dvd hn.bot_lt this,
end

lemma mem_ppowers_in_set' {A : finset ℕ} {p k : ℕ} (hp : p.prime) (hk : k ≠ 0) :
  p ^ k ∈ ppowers_in_set A ↔ ∃ n ∈ A, nat.factorization n p = k :=
begin
  rw [mem_ppowers_in_set, and_iff_right (hp.is_prime_pow.pow hk)],
  simp only [finset.nonempty, mem_local_part, exists_prop],
  refine exists_congr (λ n, and_congr_right' _),
  rw factorization_eq_iff hp hk,
end

lemma mem_ppowers_in_set'' {A : finset ℕ} {n p : ℕ} (hn : n ∈ A) (hpk : n.factorization p ≠ 0) :
  p ^ n.factorization p ∈ ppowers_in_set A :=
(mem_ppowers_in_set' (nat.prime_of_mem_factorization (finsupp.mem_support_iff.2 hpk)) hpk).2
  ⟨_, hn, rfl⟩

lemma ppowers_in_set_subset { A B : finset ℕ} (hAB : A ⊆ B) :
  ppowers_in_set A ⊆ ppowers_in_set B :=
bUnion_subset_bUnion_of_subset_left _ hAB

lemma ppowers_in_set_nonempty {A : finset ℕ} (hA : ∃ n ∈ A, 2 ≤ n) :
  (ppowers_in_set A).nonempty :=
begin
  obtain ⟨n, hn, hn'⟩ := hA,
  have : n ≠ 1,
  { linarith },
  rw nat.ne_one_iff_exists_prime_dvd at this,
  obtain ⟨p, hp₁, hp₂⟩ := this,
  refine ⟨p ^ _, (mem_ppowers_in_set' hp₁ _).2 ⟨n, hn, rfl⟩⟩,
  rwa [←finsupp.mem_support_iff, nat.support_factorization, list.mem_to_finset,
    nat.mem_factors_iff_dvd _ hp₁],
  linarith
end

lemma ppowers_in_set_eq_empty {A : finset ℕ} (hA : ppowers_in_set A = ∅) :
  ∀ n ∈ A, n < 2 :=
begin
  contrapose hA,
  rw [←ne.def, ←finset.nonempty_iff_ne_empty],
  apply ppowers_in_set_nonempty,
  simpa using hA
end

lemma ppowers_in_set_eq_empty' {A : finset ℕ} (hA : ppowers_in_set A = ∅) (hA' : 0 ∉ A):
  A.lcm id = 1 :=
begin
  have : A ⊆ {1},
  { intros n hn,
    have := ppowers_in_set_eq_empty hA n hn,
    interval_cases n,
    { trivial },
    simp },
  rw finset.subset_singleton_iff at this,
  rcases this with rfl | rfl;
  simp,
end

-- This is R(A;q) in the paper.
def rec_sum_local (A : finset ℕ) (q : ℕ) : ℚ := ∑ n in local_part A q, q / n

lemma rec_sum_local_disjoint {A B : finset ℕ} {q : ℕ} (h : disjoint A B) :
   rec_sum_local (A ∪ B) q = rec_sum_local A q + rec_sum_local B q :=
by { rw [rec_sum_local, local_part, filter_union, sum_union (disjoint_filter_filter h)], refl }

lemma rec_sum_local_mono {A₁ A₂ : finset ℕ} {q : ℕ} (h : A₁ ⊆ A₂) :
  rec_sum_local A₁ q ≤ rec_sum_local A₂ q :=
sum_le_sum_of_subset_of_nonneg (local_part_mono h) (λ i _ _, div_nonneg (by simp) (by simp))

def ppower_rec_sum (A : finset ℕ) : ℚ :=
∑ q in ppowers_in_set A, 1 / q

lemma ppower_rec_sum_mono  {A₁ A₂ : finset ℕ} (h : A₁ ⊆ A₂) :
  ppower_rec_sum A₁ ≤ ppower_rec_sum A₂ :=
sum_le_sum_of_subset_of_nonneg (ppowers_in_set_subset h) (by simp)

-- Replace nat.prime here with prime_power
def is_smooth (y : ℝ) (n : ℕ) : Prop := ∀ q : ℕ, is_prime_pow q → q ∣ n → (q : ℝ) ≤ y

def arith_regular (N : ℕ) (A : finset ℕ) : Prop :=
∀ n ∈ A, ((99 : ℝ) / 100) * log (log N) ≤ ω n ∧ (ω n : ℝ) ≤ 2 * log (log N)

lemma arith_regular.subset {N : ℕ} {A A' : finset ℕ} (hA : arith_regular N A) (hA' : A' ⊆ A) :
  arith_regular N A' :=
λ n hn, hA n (hA' hn)

-- This is the set D_I
def interval_rare_ppowers (I : finset ℤ) (A : finset ℕ) (K : ℝ) : finset ℕ :=
(ppowers_in_set A).filter $ λ q, ↑((local_part A q).filter (λ n, ∀ x ∈ I, ¬ ↑n ∣ x)).card < K / q

lemma interval_rare_ppowers_subset (I : finset ℤ) {A : finset ℕ} (K : ℝ) :
  interval_rare_ppowers I A K ⊆ ppowers_in_set A :=
filter_subset _ _

-- This is the awkward condition that 'bridges' the hypothesis of the Fourier stuff
-- with the conclusion of the combinatorial bits
def good_condition (A : finset ℕ) (K T L : ℝ) : Prop :=
(∀ (t : ℝ) (I : finset ℤ), I = finset.Icc ⌈t - K / 2⌉ ⌊t + K / 2⌋ →
      T ≤ (A.filter (λ n, ∀ x ∈ I, ¬ ↑n ∣ x)).card ∨
      ∃ x ∈ I, ∀ q ∈ interval_rare_ppowers I A L, ↑q ∣ x)


import group_theory.semidirect_product for_mathlib.coproduct

namespace whatever

noncomputable theory

variables {G : Type} [group G] [decidable_eq G]
variables {H : Type} [group H] [decidable_eq H]
variables {K : Type} [group K] [decidable_eq K]

open free_group semidirect_product

def mul_free : G →* mul_aut (free_group G) :=
{ to_fun := λ g, free_group.equiv (mul_left g),
  map_mul' := by simp [mul_aut.mul_def, equiv.perm.mul_def],
  map_one' := by simp [mul_aut.one_def, equiv.perm.one_def] }

@[simp] lemma mul_free_of' (g : G) (h : G) (n : C∞) :
  mul_free g (of' h n) = of' (g * h) n :=
by simp [mul_free]

@[simp] lemma mul_free_of (g : G) (h : G) : mul_free g (of h) = of (g * h) :=
by simp [mul_free, of_eq_of']

variable G
def P : Type := free_group G ⋊[mul_free] G

variable {G}
instance : group (P G) := by dunfold P; apply_instance

def pure : G →* P G := inr

def unpure (r : G) : P G →* G :=
semidirect_product.lift (free_group.lift (λ g, mul_aut.conj g r))
  (monoid_hom.id _)
  (λ g, free_group.hom_ext
    (by simp [free_group.lift, of_eq_of', ii, multiplicative.to_add, gpowers_hom,
      mul_assoc]))

def bind' (rG : G) (rH : H) (f : G →* P H) : P G →* P H :=
monoid_hom.comp f (unpure rG)

def bind (rG : G) (f : G → P H) : P G → P H :=
λ x, f (unpure rG x)

def bind'' (f : G → P H) : P G → P H :=
λ x, ⟨free_group.lift (λ g, of (f g).right) x.left * (f x.right).left, (f x.right).right⟩
-- λ x, (inl.comp (free_group.lift (λ g, mul_aut.conj (f g).left (of (f g).right)))) x.left *
--   f x.right

def map'' (f : G → H) (g : P G) : P H :=
bind'' (pure ∘ f) g

def join'' : P (P G) → P G :=
bind'' id

-- example (x : P (P G)): join'' x = ⟨x.1 * x.2.1, _⟩

-- example (rG : G) (rH : H) (f : G →* H) (h : f rG = rH) (g : P G) :
--   unpure rH (map'' f g) = f (unpure rG g) :=
-- begin
--   cases g,
--   subst h,
--   simp [unpure, map'', bind'', pure, mul_assoc],
--   refine free_group.rec_on g_left _ _,
--   { simp },
--   { intros,
--     simp * }
-- end

def bind''' (f : G →* P H) : P G →* P H :=
semidirect_product.lift
  (inl.comp (free_group.lift (λ g, mul_aut.conj (f g).left (of (f g).right))))
  f
(λ g, free_group.hom_ext begin
  assume i,
  refine semidirect_product.ext _ _ _ _,
  { simp,
    cases f g;
    simp [mul_aut.inv_def, mul_assoc, mul_equiv.map_mul, mul_equiv.map_inv] },
  { simp, }
end)

lemma bind_assoc (rG : G) (rH : H) (f : G → P H) (g : H → P K) (x : P G) :
  bind rH g (bind rG f x) = bind rG (λ y, bind rH g (f y)) x :=
begin
  refine semidirect_product.ext _ _ _ _;
  simp [bind]
end

lemma bind_pure (rG : G) (f : G → P H) (g : G) : bind rG f (pure g) = f g :=
begin
  refine semidirect_product.ext _ _ _ _;
  simp [bind, unpure, pure]
end

-- lemma pure_bind (rG : G) (g : P G) : bind rG pure g = g :=
-- begin
--   refine semidirect_product.ext _ _ _ _;
--   cases g;
--   simp [bind, unpure, pure],
-- end

lemma bind''_assoc (rG : G) (rH : H) (f : G → P H) (g : H → P K) (x : P G) :
  bind''  g (bind''  f x) = bind''  (λ y, bind'' g (f y)) x :=
begin
  refine semidirect_product.ext _ _ _ _,
  { cases x with xl xr,
    simp [bind'', mul_assoc],
    simp only [← monoid_hom.comp_apply],
    refine congr_fun (congr_arg _ _) _,
    refine free_group.hom_ext _,
    simp },
  { simp [bind'', mul_assoc] }
end

lemma bind''_pure (rG: G) (f : G → P H) (g : G) : bind'' f (pure g) = f g :=
begin
  refine semidirect_product.ext _ _ _ _;
  simp [bind'', unpure, pure],
end

lemma pure_bind'' (rG: G) (g : P G) : bind'' pure g = g :=
begin
  refine semidirect_product.ext _ _ _ _;
  cases g;
  simp [bind'', unpure, pure],
  conv_rhs { rw ← monoid_hom.id_apply g_left },
  refine congr_fun _ _,
  refine congr_arg _ _,
  refine free_group.hom_ext _,
  simp [free_group.lift, of_eq_of', gpowers_hom, ii, multiplicative.to_add],
end

local attribute [instance] classical.dec

def M (α : Type) : Type := free_group α × α

instance : monad M :=
{ bind := λ α β m f, show M β,
    from ⟨free_group.lift (λ g, (of (f g).2)) m.1 * (f m.2).1, (f m.2).2⟩,
  pure := λ α a, (1, a) }

instance : is_lawful_functor M :=
{ id_map := λ α x, begin
    cases x,
    simp [functor.map],
    conv_rhs { rw ← monoid_hom.id_apply x_fst },
    refine congr_fun (congr_arg _ _) _,
    refine free_group.hom_ext _,
    simp
  end,
  comp_map := λ α β γ g h x, begin
    cases x,
    simp [functor.map],
    simp only [← monoid_hom.comp_apply],
    refine congr_fun (congr_arg _ _) _,
    refine free_group.hom_ext _,
    simp
  end }

instance : is_lawful_monad M :=
{ pure_bind := λ α β x f, by simp [has_bind.bind, has_pure.pure],
  bind_assoc := λ α β γ x f g,
    begin
      cases x,
      simp [has_bind.bind, has_pure.pure, mul_assoc],
      simp only [← monoid_hom.comp_apply],
      refine congr_fun (congr_arg _ _) _,
      refine free_group.hom_ext _,
      simp
    end }

def mul (x y : M G) : M G :=
x >>= (λ x', (λ y', x' * y') <$> y)
#print functor.map
lemma mul_def (x y : M G) : mul x y =
  (x.1 * mul_free x.2 y.1, x.2 * y.2) :=
begin
  simp [mul, has_bind.bind, return, has_pure.pure, functor.map],
  cases y,
  refine free_group.rec_on y_fst _ _,
  simp [mul_equiv.map_mul], admit,
  simp [mul_equiv.map_mul],

end

end whatever