/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Kappelmann
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.floor
import Mathlib.tactic.field_simp
import Mathlib.PostPort

namespace Mathlib

/-!
# Floor Function for Rational Numbers

## Summary

We define the `floor` function and the `floor_ring` instance on `ℚ`. Some technical lemmas relating
`floor` to integer division and modulo arithmetic are derived as well as some simple inequalities.

## Tags

rat, rationals, ℚ, floor
-/

namespace rat

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
protected def floor : ℚ → ℤ := sorry

protected theorem le_floor {z : ℤ} {r : ℚ} : z ≤ rat.floor r ↔ ↑z ≤ r := sorry

protected instance floor_ring : floor_ring ℚ := floor_ring.mk rat.floor rat.le_floor

protected theorem floor_def {q : ℚ} : floor q = num q / ↑(denom q) :=
  cases_on q
    fun (q_num : ℤ) (q_denom : ℕ) (q_pos : 0 < q_denom)
      (q_cop : nat.coprime (int.nat_abs q_num) q_denom) =>
      Eq.refl (floor (mk' q_num q_denom q_pos q_cop))

theorem floor_int_div_nat_eq_div {n : ℤ} {d : ℕ} : floor (↑n / ↑d) = n / ↑d := sorry

end rat

theorem int.mod_nat_eq_sub_mul_floor_rat_div {n : ℤ} {d : ℕ} : n % ↑d = n - ↑d * floor (↑n / ↑d) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (n % ↑d = n - ↑d * floor (↑n / ↑d)))
        (eq_sub_of_add_eq (int.mod_add_div n ↑d))))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (n - ↑d * (n / ↑d) = n - ↑d * floor (↑n / ↑d)))
          rat.floor_int_div_nat_eq_div))
      (Eq.refl (n - ↑d * (n / ↑d))))

theorem nat.coprime_sub_mul_floor_rat_div_of_coprime {n : ℕ} {d : ℕ}
    (n_coprime_d : nat.coprime n d) : nat.coprime (int.nat_abs (↑n - ↑d * floor (↑n / ↑d))) d :=
  sorry

namespace rat

theorem num_lt_succ_floor_mul_denom (q : ℚ) : num q < (floor q + 1) * ↑(denom q) := sorry

theorem fract_inv_num_lt_num_of_pos {q : ℚ} (q_pos : 0 < q) : num (fract (q⁻¹)) < num q := sorry

end Mathlib


inductive fml
| atom (i : ℕ)
| imp (a b : fml)
| not (a : fml)

open fml

infixr ` →' `:50 := imp -- right associative

prefix `¬' `:40 := fml.not

inductive prf : fml → Type
| axk (p q) : prf (p →' q →' p)
| axs (p q r) : prf $ (p →' q →' r) →' (p →' q) →' (p →' r)
| axX (p q) : prf $ ((¬' q) →' (¬' p)) →' p →' q
| mp {p q} : prf (p →' q) → prf p → prf q -- bracket change

open prf

-- example usage:

lemma p_of_p_of_p_of_q (p q : fml) : prf $ (p →' q) →' (p →' p) :=
begin
  apply mp (axs p q p),
  exact (axk p q)
end

lemma Q6a (p : fml) : prf $ p →' p :=

mp (p_of_p_of_p_of_q _ (p →' p)) $ axk p p

theorem Q6b (p : fml) : prf $ p →' ¬' ¬' p := sorry


open expr tactic classical

variables {p q r s : Prop}
variables {a b c d e : Prop}

section

local attribute [instance] classical.prop_decidable

  theorem not_or_of_imp (h : a → b) : ¬ a ∨ b :=
begin
  by_cases H : a,
   from or.inr (h ‹_›),
   from or.inl ‹_›
end

  theorem imp_iff_not_or : (a → b) ↔ (¬ a ∨ b) := sorry

  theorem iff_def : (a ↔ b) ↔ (a → b) ∧ (b → a) := sorry

  theorem not_not : ¬¬a ↔ a := sorry

  theorem not_or_distrib : ¬ (a ∨ b) ↔ ¬ a ∧ ¬ b := sorry

  theorem not_and_of_not_or_not (h : ¬ a ∨ ¬ b) : ¬ (a ∧ b) := sorry

  theorem not_and_distrib : ¬ (a ∧ b) ↔ ¬a ∨ ¬b := sorry

end

meta def normalize : tactic unit :=
`[ try { simp only
   [ not_or_distrib,
     not_and_distrib,
     not_not,
     imp_iff_not_or,
     not_true_iff,
     not_false_iff,
     iff_def ] at *} ]

/- Given a list of expr of hypotheses, find an expr of a
   conjunctive hypothesis in the list and return it. -/
meta def find_conj : list expr → tactic expr := sorry

/- Given a list of expr of hypotheses, find an expr of a
   disjunctive hypothesis in the list and return it. -/
meta def find_disj : list expr → tactic expr := sorry

/- Find and split a conjunction. -/
meta def split_conj : tactic unit := sorry

/- Split all conjunctions using split_conj. -/
meta def split_conjs : tactic unit := sorry

/- Find and split a disjunction. -/
meta def split_disj : tactic unit := sorry

/- Given a goal of the form Γ ⊢ φ, reduce it to the goal Γ, ¬φ ⊢ ⊥ -/
meta def go_by_contradiction : tactic unit := sorry

/- The main proof search loop. First, split all conjunctions.
   If the result has complementary literals, discharge the goal.
   If not, find a disjunction, split it, and discharge the new
   subgoals by entering the proof search loop again. -/
meta def tab_aux : tactic unit := sorry

/- Normalize goal and enter proof search loop. -/
meta def tab : tactic unit := sorry

#exit

example : a ∧ b → b ∧ a := by tab
example : a ∧ (a → b) → b := by tab

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p := by tab
example : p ∨ q ↔ q ∨ p := by tab

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := by tab
example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := by tab

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := by tab
example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) := by tab

-- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) := by tab
example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) := by tab
example : ¬(p ∨ q) ↔ ¬p ∧ ¬q := by tab
example : ¬p ∨ ¬q → ¬(p ∧ q) := by tab
example : ¬(p ∧ ¬p) := by tab
example : p ∧ ¬q → ¬(p → q) := by tab
example : ¬p → (p → q) := by tab
example : (¬p ∨ q) → (p → q) := by tab
example : p ∨ false ↔ p := by tab
example : p ∧ false ↔ false := by tab
example : ¬(p ↔ ¬p) := by tab
example : (p → q) → (¬q → ¬p) := by tab

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) := by tab
example : ¬(p ∧ q) → ¬p ∨ ¬q := by tab
example : ¬(p → q) → p ∧ ¬q := by tab
example : (p → q) → (¬p ∨ q) := by tab
example : (¬q → ¬p) → (p → q) := by tab
example : p ∨ ¬p := by tab
example : (((p → q) → p) → p) := by tab

example (h₁ : a ∧ b) (h₂ : b ∧ ¬ c) : a ∨ c :=
by tab

example (h₁ : a ∧ b) (h₂ : b ∧ ¬ c) : a ∧ ¬ c :=
by tab

example : ((a → b) → a) → a :=
by tab

example : (a → b) ∧ (b → c) → a → c :=
by tab

example (α : Type) (x y z w : α) :
  x = y ∧ (x = y → z = w) → z = w :=
by tab

example : ¬ (a ↔ ¬ a) :=
by tab


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

! This file was ported from Lean 3 source module number_theory.zsqrtd.basic
! leanprover-community/mathlib commit 7ec294687917cbc5c73620b4414ae9b5dd9ae1b4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Associated
import Mathlib.RingTheory.Int.Basic
import Mathlib.Tactic.Ring
import Mathlib.Algebra.Star.Unitary

/-! # ℤ[√d]

The ring of integers adjoined with a square root of `d : ℤ`.

After defining the norm, we show that it is a linearly ordered commutative ring,
as well as an integral domain.

We provide the universal property, that ring homomorphisms `ℤ√d →+* R` correspond
to choices of square roots of `d` in `R`.

-/

/-- 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. -/
structure Zsqrtd (d : ℤ) where
  re : ℤ
  im : ℤ
  deriving DecidableEq
#align zsqrtd Zsqrtd

prefix:100 "ℤ√" => Zsqrtd

namespace Zsqrtd

section

variable {d : ℤ}

theorem ext : ∀ {z w : ℤ√d}, z = w ↔ z.re = w.re ∧ z.im = w.im
  | ⟨x, y⟩, ⟨x', y'⟩ =>
    ⟨fun h => by injection h; constructor <;> assumption,
     fun ⟨h₁, h₂⟩ => by congr⟩
#align zsqrtd.ext Zsqrtd.ext

/-- Convert an integer to a `ℤ√d` -/
def ofInt (n : ℤ) : ℤ√d :=
  ⟨n, 0⟩
#align zsqrtd.of_int Zsqrtd.ofInt

theorem ofInt_re (n : ℤ) : (ofInt n : ℤ√d).re = n :=
  rfl
#align zsqrtd.of_int_re Zsqrtd.ofInt_re

theorem ofInt_im (n : ℤ) : (ofInt n : ℤ√d).im = 0 :=
  rfl
#align zsqrtd.of_int_im Zsqrtd.ofInt_im

/-- The zero of the ring -/
instance : Zero (ℤ√d) :=
  ⟨ofInt 0⟩

@[simp]
theorem zero_re : (0 : ℤ√d).re = 0 :=
  rfl
#align zsqrtd.zero_re Zsqrtd.zero_re

@[simp]
theorem zero_im : (0 : ℤ√d).im = 0 :=
  rfl
#align zsqrtd.zero_im Zsqrtd.zero_im

instance : Inhabited (ℤ√d) :=
  ⟨0⟩

/-- The one of the ring -/
instance : One (ℤ√d) :=
  ⟨ofInt 1⟩

@[simp]
theorem one_re : (1 : ℤ√d).re = 1 :=
  rfl
#align zsqrtd.one_re Zsqrtd.one_re

@[simp]
theorem one_im : (1 : ℤ√d).im = 0 :=
  rfl
#align zsqrtd.one_im Zsqrtd.one_im

/-- The representative of `√d` in the ring -/
def sqrtd : ℤ√d :=
  ⟨0, 1⟩
#align zsqrtd.sqrtd Zsqrtd.sqrtd

@[simp]
theorem sqrtd_re : (sqrtd : ℤ√d).re = 0 :=
  rfl
#align zsqrtd.sqrtd_re Zsqrtd.sqrtd_re

@[simp]
theorem sqrtd_im : (sqrtd : ℤ√d).im = 1 :=
  rfl
#align zsqrtd.sqrtd_im Zsqrtd.sqrtd_im

/-- Addition of elements of `ℤ√d` -/
instance : Add (ℤ√d) :=
  ⟨fun z w => ⟨z.1 + w.1, z.2 + w.2⟩⟩

@[simp]
theorem add_def (x y x' y' : ℤ) : (⟨x, y⟩ + ⟨x', y'⟩ : ℤ√d) = ⟨x + x', y + y'⟩ :=
  rfl
#align zsqrtd.add_def Zsqrtd.add_def

@[simp]
theorem add_re (z w : ℤ√d) : (z + w).re = z.re + w.re :=
  rfl
#align zsqrtd.add_re Zsqrtd.add_re

@[simp]
theorem add_im (z w : ℤ√d) : (z + w).im = z.im + w.im :=
  rfl
#align zsqrtd.add_im Zsqrtd.add_im

section bit
set_option linter.deprecated false

@[simp]
theorem bit0_re (z) : (bit0 z : ℤ√d).re = bit0 z.re :=
  rfl
#align zsqrtd.bit0_re Zsqrtd.bit0_re

@[simp]
theorem bit0_im (z) : (bit0 z : ℤ√d).im = bit0 z.im :=
  rfl
#align zsqrtd.bit0_im Zsqrtd.bit0_im

@[simp]
theorem bit1_re (z) : (bit1 z : ℤ√d).re = bit1 z.re :=
  rfl
#align zsqrtd.bit1_re Zsqrtd.bit1_re

@[simp]
theorem bit1_im (z) : (bit1 z : ℤ√d).im = bit0 z.im := by simp [bit1]
#align zsqrtd.bit1_im Zsqrtd.bit1_im

end bit

/-- Negation in `ℤ√d` -/
instance : Neg (ℤ√d) :=
  ⟨fun z => ⟨-z.1, -z.2⟩⟩

@[simp]
theorem neg_re (z : ℤ√d) : (-z).re = -z.re :=
  rfl
#align zsqrtd.neg_re Zsqrtd.neg_re

@[simp]
theorem neg_im (z : ℤ√d) : (-z).im = -z.im :=
  rfl
#align zsqrtd.neg_im Zsqrtd.neg_im

/-- Multiplication in `ℤ√d` -/
instance : Mul (ℤ√d) :=
  ⟨fun z w => ⟨z.1 * w.1 + d * z.2 * w.2, z.1 * w.2 + z.2 * w.1⟩⟩

@[simp]
theorem mul_re (z w : ℤ√d) : (z * w).re = z.re * w.re + d * z.im * w.im :=
  rfl
#align zsqrtd.mul_re Zsqrtd.mul_re

@[simp]
theorem mul_im (z w : ℤ√d) : (z * w).im = z.re * w.im + z.im * w.re :=
  rfl
#align zsqrtd.mul_im Zsqrtd.mul_im

instance addCommGroup : AddCommGroup (ℤ√d) := by
  refine
  { add := (· + ·)
    zero := (0 : ℤ√d)
    sub := fun a b => a + -b
    neg := Neg.neg
    zsmul := @zsmulRec (ℤ√d) ⟨0⟩ ⟨(· + ·)⟩ ⟨Neg.neg⟩
    nsmul := @nsmulRec (ℤ√d) ⟨0⟩ ⟨(· + ·)⟩
    add_assoc := ?_
    zero_add := ?_
    add_zero := ?_
    add_left_neg := ?_
    add_comm := ?_ } <;>
  intros <;>
  simp [ext, add_comm, add_left_comm]

instance addGroupWithOne : AddGroupWithOne (ℤ√d) :=
  { Zsqrtd.addCommGroup with
    natCast := fun n => ofInt n
    intCast := ofInt
    one := 1 }

instance commRing : CommRing (ℤ√d) := by
  refine
  { Zsqrtd.addGroupWithOne with
    add := (· + ·)
    zero := (0 : ℤ√d)
    mul := (· * ·)
    one := 1
    npow := @npowRec (ℤ√d) ⟨1⟩ ⟨(· * ·)⟩,
    add_comm := ?_
    left_distrib := ?_
    right_distrib := ?_
    zero_mul := ?_
    mul_zero := ?_
    mul_assoc := ?_
    one_mul := ?_
    mul_one := ?_
    mul_comm := ?_ } <;>
  intros <;>
  refine ext.mpr ⟨?_, ?_⟩ <;>
  simp <;>
  ring

instance : AddMonoid (ℤ√d) := by infer_instance

instance : Monoid (ℤ√d) := by infer_instance

instance : CommMonoid (ℤ√d) := by infer_instance

instance : CommSemigroup (ℤ√d) := by infer_instance

instance : Semigroup (ℤ√d) := by infer_instance

instance : AddCommSemigroup (ℤ√d) := by infer_instance

instance : AddSemigroup (ℤ√d) := by infer_instance

instance : CommSemiring (ℤ√d) := by infer_instance

instance : Semiring (ℤ√d) := by infer_instance

instance : Ring (ℤ√d) := by infer_instance

instance : Distrib (ℤ√d) := by infer_instance

/-- Conjugation in `ℤ√d`. The conjugate of `a + b √d` is `a - b √d`. -/
instance : Star (ℤ√d) where
  star z := ⟨z.1, -z.2⟩

@[simp]
theorem star_mk (x y : ℤ) : star (⟨x, y⟩ : ℤ√d) = ⟨x, -y⟩ :=
  rfl
#align zsqrtd.star_mk Zsqrtd.star_mk

@[simp]
theorem star_re (z : ℤ√d) : (star z).re = z.re :=
  rfl
#align zsqrtd.star_re Zsqrtd.star_re

@[simp]
theorem star_im (z : ℤ√d) : (star z).im = -z.im :=
  rfl
#align zsqrtd.star_im Zsqrtd.star_im

instance : StarRing (ℤ√d) where
  star_involutive x := ext.mpr ⟨rfl, neg_neg _⟩
  star_mul a b := ext.mpr ⟨by simp; ring, by simp; ring⟩
  star_add a b := ext.mpr ⟨rfl, neg_add _ _⟩

-- Porting note: proof was `by decide`
instance nontrivial : Nontrivial (ℤ√d) :=
  ⟨⟨0, 1, ext.not.mpr <| by simp⟩⟩

@[simp]
theorem coe_nat_re (n : ℕ) : (n : ℤ√d).re = n :=
  rfl
#align zsqrtd.coe_nat_re Zsqrtd.coe_nat_re

@[simp]
theorem ofNat_re (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : ℤ√d).re = n :=
  rfl

@[simp]
theorem coe_nat_im (n : ℕ) : (n : ℤ√d).im = 0 :=
  rfl
#align zsqrtd.coe_nat_im Zsqrtd.coe_nat_im

@[simp]
theorem ofNat_im (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : ℤ√d).im = 0 :=
  rfl

theorem coe_nat_val (n : ℕ) : (n : ℤ√d) = ⟨n, 0⟩ :=
  rfl
#align zsqrtd.coe_nat_val Zsqrtd.coe_nat_val

@[simp]
theorem coe_int_re (n : ℤ) : (n : ℤ√d).re = n := by cases n <;> rfl
#align zsqrtd.coe_int_re Zsqrtd.coe_int_re

@[simp]
theorem coe_int_im (n : ℤ) : (n : ℤ√d).im = 0 := by cases n <;> rfl
#align zsqrtd.coe_int_im Zsqrtd.coe_int_im

theorem coe_int_val (n : ℤ) : (n : ℤ√d) = ⟨n, 0⟩ := by simp [ext]
#align zsqrtd.coe_int_val Zsqrtd.coe_int_val

instance : CharZero (ℤ√d) where cast_injective m n := by simp [ext]

@[simp]
theorem ofInt_eq_coe (n : ℤ) : (ofInt n : ℤ√d) = n := by simp [ext, ofInt_re, ofInt_im]
#align zsqrtd.of_int_eq_coe Zsqrtd.ofInt_eq_coe

@[simp]
theorem smul_val (n x y : ℤ) : (n : ℤ√d) * ⟨x, y⟩ = ⟨n * x, n * y⟩ := by simp [ext]
#align zsqrtd.smul_val Zsqrtd.smul_val

theorem smul_re (a : ℤ) (b : ℤ√d) : (↑a * b).re = a * b.re := by simp
#align zsqrtd.smul_re Zsqrtd.smul_re

theorem smul_im (a : ℤ) (b : ℤ√d) : (↑a * b).im = a * b.im := by simp
#align zsqrtd.smul_im Zsqrtd.smul_im

@[simp]
theorem muld_val (x y : ℤ) : sqrtd (d := d) * ⟨x, y⟩ = ⟨d * y, x⟩ := by simp [ext]
#align zsqrtd.muld_val Zsqrtd.muld_val

@[simp]
theorem dmuld : sqrtd (d := d) * sqrtd (d := d) = d := by simp [ext]
#align zsqrtd.dmuld Zsqrtd.dmuld

@[simp]
theorem smuld_val (n x y : ℤ) : sqrtd * (n : ℤ√d) * ⟨x, y⟩ = ⟨d * n * y, n * x⟩ := by simp [ext]
#align zsqrtd.smuld_val Zsqrtd.smuld_val

theorem decompose {x y : ℤ} : (⟨x, y⟩ : ℤ√d) = x + sqrtd (d := d) * y := by simp [ext]
#align zsqrtd.decompose Zsqrtd.decompose

theorem mul_star {x y : ℤ} : (⟨x, y⟩ * star ⟨x, y⟩ : ℤ√d) = x * x - d * y * y := by
  simp [ext, sub_eq_add_neg, mul_comm]
#align zsqrtd.mul_star Zsqrtd.mul_star

protected theorem coe_int_add (m n : ℤ) : (↑(m + n) : ℤ√d) = ↑m + ↑n :=
  (Int.castRingHom _).map_add _ _
#align zsqrtd.coe_int_add Zsqrtd.coe_int_add

protected theorem coe_int_sub (m n : ℤ) : (↑(m - n) : ℤ√d) = ↑m - ↑n :=
  (Int.castRingHom _).map_sub _ _
#align zsqrtd.coe_int_sub Zsqrtd.coe_int_sub

protected theorem coe_int_mul (m n : ℤ) : (↑(m * n) : ℤ√d) = ↑m * ↑n :=
  (Int.castRingHom _).map_mul _ _
#align zsqrtd.coe_int_mul Zsqrtd.coe_int_mul

protected theorem coe_int_inj {m n : ℤ} (h : (↑m : ℤ√d) = ↑n) : m = n := by
  simpa using congr_arg re h
#align zsqrtd.coe_int_inj Zsqrtd.coe_int_inj

theorem coe_int_dvd_iff (z : ℤ) (a : ℤ√d) : ↑z ∣ a ↔ z ∣ a.re ∧ z ∣ a.im := by
  constructor
  · rintro ⟨x, rfl⟩
    simp only [add_zero, coe_int_re, MulZeroClass.zero_mul, mul_im, dvd_mul_right, and_self_iff,
      mul_re, mul_zero, coe_int_im]
  · rintro ⟨⟨r, hr⟩, ⟨i, hi⟩⟩
    use ⟨r, i⟩
    rw [smul_val, ext]
    exact ⟨hr, hi⟩
#align zsqrtd.coe_int_dvd_iff Zsqrtd.coe_int_dvd_iff

@[simp, norm_cast]
theorem coe_int_dvd_coe_int (a b : ℤ) : (a : ℤ√d) ∣ b ↔ a ∣ b := by
  rw [coe_int_dvd_iff]
  constructor
  · rintro ⟨hre, -⟩
    rwa [coe_int_re] at hre
  · rw [coe_int_re, coe_int_im]
    exact fun hc => ⟨hc, dvd_zero a⟩
#align zsqrtd.coe_int_dvd_coe_int Zsqrtd.coe_int_dvd_coe_int

protected theorem eq_of_smul_eq_smul_left {a : ℤ} {b c : ℤ√d} (ha : a ≠ 0) (h : ↑a * b = a * c) :
    b = c := by
  rw [ext] at h⊢
  apply And.imp _ _ h <;> simpa only [smul_re, smul_im] using mul_left_cancel₀ ha
#align zsqrtd.eq_of_smul_eq_smul_left Zsqrtd.eq_of_smul_eq_smul_left

section Gcd

theorem gcd_eq_zero_iff (a : ℤ√d) : Int.gcd a.re a.im = 0 ↔ a = 0 := by
  simp only [Int.gcd_eq_zero_iff, ext, eq_self_iff_true, zero_im, zero_re]
#align zsqrtd.gcd_eq_zero_iff Zsqrtd.gcd_eq_zero_iff

theorem gcd_pos_iff (a : ℤ√d) : 0 < Int.gcd a.re a.im ↔ a ≠ 0 :=
  pos_iff_ne_zero.trans <| not_congr a.gcd_eq_zero_iff
#align zsqrtd.gcd_pos_iff Zsqrtd.gcd_pos_iff

theorem coprime_of_dvd_coprime {a b : ℤ√d} (hcoprime : IsCoprime a.re a.im) (hdvd : b ∣ a) :
    IsCoprime b.re b.im := by
  apply isCoprime_of_dvd
  · rintro ⟨hre, him⟩
    obtain rfl : b = 0 := by
      simp only [ext, hre, eq_self_iff_true, zero_im, him, and_self_iff, zero_re]
    rw [zero_dvd_iff] at hdvd
    simp [hdvd, zero_im, zero_re, not_isCoprime_zero_zero] at hcoprime
  · rintro z hz - hzdvdu hzdvdv
    apply hz
    obtain ⟨ha, hb⟩ : z ∣ a.re ∧ z ∣ a.im := by
      rw [← coe_int_dvd_iff]
      apply dvd_trans _ hdvd
      rw [coe_int_dvd_iff]
      exact ⟨hzdvdu, hzdvdv⟩
    exact hcoprime.isUnit_of_dvd' ha hb
#align zsqrtd.coprime_of_dvd_coprime Zsqrtd.coprime_of_dvd_coprime

theorem exists_coprime_of_gcd_pos {a : ℤ√d} (hgcd : 0 < Int.gcd a.re a.im) :
    ∃ b : ℤ√d, a = ((Int.gcd a.re a.im : ℤ) : ℤ√d) * b ∧ IsCoprime b.re b.im := by
  obtain ⟨re, im, H1, Hre, Him⟩ := Int.exists_gcd_one hgcd
  rw [mul_comm] at Hre Him
  refine' ⟨⟨re, im⟩, _, _⟩
  · rw [smul_val, ext, ← Hre, ← Him]
    constructor <;> rfl
  · rw [← Int.gcd_eq_one_iff_coprime, H1]
#align zsqrtd.exists_coprime_of_gcd_pos Zsqrtd.exists_coprime_of_gcd_pos

end Gcd

/-- Read `SqLe a c b d` as `a √c ≤ b √d` -/
def SqLe (a c b d : ℕ) : Prop :=
  c * a * a ≤ d * b * b
#align zsqrtd.sq_le Zsqrtd.SqLe

theorem sqLe_of_le {c d x y z w : ℕ} (xz : z ≤ x) (yw : y ≤ w) (xy : SqLe x c y d) : SqLe z c w d :=
  le_trans (mul_le_mul (Nat.mul_le_mul_left _ xz) xz (Nat.zero_le _) (Nat.zero_le _)) <|
    le_trans xy (mul_le_mul (Nat.mul_le_mul_left _ yw) yw (Nat.zero_le _) (Nat.zero_le _))
#align zsqrtd.sq_le_of_le Zsqrtd.sqLe_of_le

theorem sqLe_add_mixed {c d x y z w : ℕ} (xy : SqLe x c y d) (zw : SqLe z c w d) :
    c * (x * z) ≤ d * (y * w) :=
  Nat.mul_self_le_mul_self_iff.2 <| by
    simpa [mul_comm, mul_left_comm] using mul_le_mul xy zw (Nat.zero_le _) (Nat.zero_le _)
#align zsqrtd.sq_le_add_mixed Zsqrtd.sqLe_add_mixed

theorem sqLe_add {c d x y z w : ℕ} (xy : SqLe x c y d) (zw : SqLe z c w d) :
    SqLe (x + z) c (y + w) d := by
  have xz := sqLe_add_mixed xy zw
  simp [SqLe, mul_assoc] at xy zw
  simp [SqLe, mul_add, mul_comm, mul_left_comm, add_le_add, *]
#align zsqrtd.sq_le_add Zsqrtd.sqLe_add

theorem sqLe_cancel {c d x y z w : ℕ} (zw : SqLe y d x c) (h : SqLe (x + z) c (y + w) d) :
    SqLe z c w d := by
  apply le_of_not_gt
  intro l
  refine' not_le_of_gt _ h
  simp only [SqLe, mul_add, mul_comm, mul_left_comm, add_assoc, gt_iff_lt]
  have hm := sqLe_add_mixed zw (le_of_lt l)
  simp only [SqLe, mul_assoc, gt_iff_lt] at l zw
  exact
    lt_of_le_of_lt (add_le_add_right zw _)
      (add_lt_add_left (add_lt_add_of_le_of_lt hm (add_lt_add_of_le_of_lt hm l)) _)
#align zsqrtd.sq_le_cancel Zsqrtd.sqLe_cancel

theorem sqLe_smul {c d x y : ℕ} (n : ℕ) (xy : SqLe x c y d) : SqLe (n * x) c (n * y) d := by
  simpa [SqLe, mul_left_comm, mul_assoc] using Nat.mul_le_mul_left (n * n) xy
#align zsqrtd.sq_le_smul Zsqrtd.sqLe_smul

theorem sqLe_mul {d x y z w : ℕ} :
    (SqLe x 1 y d → SqLe z 1 w d → SqLe (x * w + y * z) d (x * z + d * y * w) 1) ∧
      (SqLe x 1 y d → SqLe w d z 1 → SqLe (x * z + d * y * w) 1 (x * w + y * z) d) ∧
        (SqLe y d x 1 → SqLe z 1 w d → SqLe (x * z + d * y * w) 1 (x * w + y * z) d) ∧
          (SqLe y d x 1 → SqLe w d z 1 → SqLe (x * w + y * z) d (x * z + d * y * w) 1) := by
  refine' ⟨_, _, _, _⟩ <;>
    · intro xy zw
      have :=
        Int.mul_nonneg (sub_nonneg_of_le (Int.ofNat_le_ofNat_of_le xy))
          (sub_nonneg_of_le (Int.ofNat_le_ofNat_of_le zw))
      refine' Int.le_of_ofNat_le_ofNat (le_of_sub_nonneg _)
      convert this using 1
      simp only [one_mul, Int.ofNat_add, Int.ofNat_mul]
      ring
#align zsqrtd.sq_le_mul Zsqrtd.sqLe_mul

open Int in
/-- "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
  | (a : ℕ), (b : ℕ) => True
  | (a : ℕ), -[b+1] => SqLe (b + 1) c a d
  | -[a+1], (b : ℕ) => SqLe (a + 1) d b c
  | -[_+1], -[_+1] => False
#align zsqrtd.nonnegg Zsqrtd.Nonnegg

theorem nonnegg_neg_pos {c d} : ∀ {a b : ℕ}, Nonnegg c d (-a) b ↔ SqLe a d b c
  | 0, b => ⟨by simp [SqLe, Nat.zero_le], fun _ => trivial⟩
  | a + 1, b => by rw [← Int.negSucc_coe]; rfl
#align zsqrtd.nonnegg_neg_pos Zsqrtd.nonnegg_neg_pos

theorem nonnegg_pos_neg {c d} {a b : ℕ} : Nonnegg c d a (-b) ↔ SqLe b c a d := by
  rw [nonnegg_comm]; exact nonnegg_neg_pos
#align zsqrtd.nonnegg_pos_neg Zsqrtd.nonnegg_pos_neg

open Int in
theorem nonnegg_cases_right {c d} {a : ℕ} :
    ∀ {b : ℤ}, (∀ x : ℕ, b = -x → SqLe x c a d) → Nonnegg c d a b
  | (b : Nat), _ => trivial
  | -[b+1], h => h (b + 1) rfl
#align zsqrtd.nonnegg_cases_right Zsqrtd.nonnegg_cases_right

theorem nonnegg_cases_left {c d} {b : ℕ} {a : ℤ} (h : ∀ x : ℕ, a = -x → SqLe x d b c) :
    Nonnegg c d a b :=
  cast nonnegg_comm (nonnegg_cases_right h)
#align zsqrtd.nonnegg_cases_left Zsqrtd.nonnegg_cases_left

section Norm

/-- The norm of an element of `ℤ[√d]`. -/
def norm (n : ℤ√d) : ℤ :=
  n.re * n.re - d * n.im * n.im
#align zsqrtd.norm Zsqrtd.norm

theorem norm_def (n : ℤ√d) : n.norm = n.re * n.re - d * n.im * n.im :=
  rfl
#align zsqrtd.norm_def Zsqrtd.norm_def

@[simp]
theorem norm_zero : norm (0 : ℤ√d) = 0 := by simp [norm]
#align zsqrtd.norm_zero Zsqrtd.norm_zero

@[simp]
theorem norm_one : norm (1 : ℤ√d) = 1 := by simp [norm]
#align zsqrtd.norm_one Zsqrtd.norm_one

@[simp]
theorem norm_int_cast (n : ℤ) : norm (n : ℤ√d) = n * n := by simp [norm]
#align zsqrtd.norm_int_cast Zsqrtd.norm_int_cast

@[simp]
theorem norm_nat_cast (n : ℕ) : norm (n : ℤ√d) = n * n :=
  norm_int_cast n
#align zsqrtd.norm_nat_cast Zsqrtd.norm_nat_cast

@[simp]
theorem norm_mul (n m : ℤ√d) : norm (n * m) = norm n * norm m := by
  simp only [norm, mul_im, mul_re]
  ring
#align zsqrtd.norm_mul Zsqrtd.norm_mul

/-- `norm` as a `MonoidHom`. -/
def normMonoidHom : ℤ√d →* ℤ where
  toFun := norm
  map_mul' := norm_mul
  map_one' := norm_one
#align zsqrtd.norm_monoid_hom Zsqrtd.normMonoidHom

theorem norm_eq_mul_conj (n : ℤ√d) : (norm n : ℤ√d) = n * star n := by
  cases n
  simp [norm, star, Zsqrtd.ext, mul_comm, sub_eq_add_neg]
#align zsqrtd.norm_eq_mul_conj Zsqrtd.norm_eq_mul_conj

@[simp]
theorem norm_neg (x : ℤ√d) : (-x).norm = x.norm :=
  -- Porting note: replaced `simp` with `rw`
  Zsqrtd.coe_int_inj <| by rw [norm_eq_mul_conj, star_neg, neg_mul_neg, norm_eq_mul_conj]
#align zsqrtd.norm_neg Zsqrtd.norm_neg

@[simp]
theorem norm_conj (x : ℤ√d) : (star x).norm = x.norm :=
  -- Porting note: replaced `simp` with `rw`
  Zsqrtd.coe_int_inj <| by rw [norm_eq_mul_conj, star_star, mul_comm, norm_eq_mul_conj]
#align zsqrtd.norm_conj Zsqrtd.norm_conj

theorem norm_nonneg (hd : d ≤ 0) (n : ℤ√d) : 0 ≤ n.norm :=
  add_nonneg (mul_self_nonneg _)
    (by
      rw [mul_assoc, neg_mul_eq_neg_mul]
      exact mul_nonneg (neg_nonneg.2 hd) (mul_self_nonneg _))
#align zsqrtd.norm_nonneg Zsqrtd.norm_nonneg

theorem norm_eq_one_iff {x : ℤ√d} : x.norm.natAbs = 1 ↔ IsUnit x :=
  ⟨fun h =>
    isUnit_iff_dvd_one.2 <|
      (le_total 0 (norm x)).casesOn
        (fun hx =>
          ⟨star x, by
            rwa [← Int.coe_nat_inj', Int.natAbs_of_nonneg hx, ← @Int.cast_inj (ℤ√d) _ _,
              norm_eq_mul_conj, eq_comm] at h⟩)
        fun hx =>
          ⟨-star x, by
            rwa [← Int.coe_nat_inj', Int.ofNat_natAbs_of_nonpos hx, ← @Int.cast_inj (ℤ√d) _ _,
              Int.cast_neg, norm_eq_mul_conj, neg_mul_eq_mul_neg, eq_comm] at h⟩,
    fun h => by
    let ⟨y, hy⟩ := isUnit_iff_dvd_one.1 h
    have := congr_arg (Int.natAbs ∘ norm) hy
    rw [Function.comp_apply, Function.comp_apply, norm_mul, Int.natAbs_mul, norm_one,
      Int.natAbs_one, eq_comm, Nat.mul_eq_one_iff] at this
    exact this.1⟩
#align zsqrtd.norm_eq_one_iff Zsqrtd.norm_eq_one_iff

theorem isUnit_iff_norm_isUnit {d : ℤ} (z : ℤ√d) : IsUnit z ↔ IsUnit z.norm := by
  rw [Int.isUnit_iff_natAbs_eq, norm_eq_one_iff]
#align zsqrtd.is_unit_iff_norm_is_unit Zsqrtd.isUnit_iff_norm_isUnit

theorem norm_eq_one_iff' {d : ℤ} (hd : d ≤ 0) (z : ℤ√d) : z.norm = 1 ↔ IsUnit z := by
  rw [← norm_eq_one_iff, ← Int.coe_nat_inj', Int.natAbs_of_nonneg (norm_nonneg hd z), Int.ofNat_one]
#align zsqrtd.norm_eq_one_iff' Zsqrtd.norm_eq_one_iff'

theorem norm_eq_zero_iff {d : ℤ} (hd : d < 0) (z : ℤ√d) : z.norm = 0 ↔ z = 0 := by
  constructor
  · intro h
    rw [ext, zero_re, zero_im]
    rw [norm_def, sub_eq_add_neg, mul_assoc] at h
    have left := mul_self_nonneg z.re
    have right := neg_nonneg.mpr (mul_nonpos_of_nonpos_of_nonneg hd.le (mul_self_nonneg z.im))
    obtain ⟨ha, hb⟩ := (add_eq_zero_iff' left right).mp h
    constructor <;> apply eq_zero_of_mul_self_eq_zero
    · exact ha
    · rw [neg_eq_zero, mul_eq_zero] at hb
      exact hb.resolve_left hd.ne
  · rintro rfl
    exact norm_zero
#align zsqrtd.norm_eq_zero_iff Zsqrtd.norm_eq_zero_iff

theorem norm_eq_of_associated {d : ℤ} (hd : d ≤ 0) {x y : ℤ√d} (h : Associated x y) :
    x.norm = y.norm := by
  obtain ⟨u, rfl⟩ := h
  rw [norm_mul, (norm_eq_one_iff' hd _).mpr u.isUnit, mul_one]
#align zsqrtd.norm_eq_of_associated Zsqrtd.norm_eq_of_associated

end Norm

end

section

variable {d : ℕ}

/-- Nonnegativity of an element of `ℤ√d`. -/
def Nonneg : ℤ√d → Prop
  | ⟨a, b⟩ => Nonnegg d 1 a b
#align zsqrtd.nonneg Zsqrtd.Nonneg

instance : LE (ℤ√d) :=
  ⟨fun a b => Nonneg (b - a)⟩

instance : LT (ℤ√d) :=
  ⟨fun a b => ¬b ≤ a⟩

instance decidableNonnegg (c d a b) : Decidable (Nonnegg c d a b) := by
  cases a <;> cases b <;> simp_rw [Int.ofNat_eq_coe] <;> unfold Nonnegg SqLe <;> infer_instance
#align zsqrtd.decidable_nonnegg Zsqrtd.decidableNonnegg

instance decidableNonneg : ∀ a : ℤ√d, Decidable (Nonneg a)
  | ⟨_, _⟩ => Zsqrtd.decidableNonnegg _ _ _ _
#align zsqrtd.decidable_nonneg Zsqrtd.decidableNonneg

instance decidableLE : @DecidableRel (ℤ√d) (· ≤ ·) := fun _ _ => decidableNonneg _
#align zsqrtd.decidable_le Zsqrtd.decidableLE

open Int in
theorem nonneg_cases : ∀ {a : ℤ√d}, Nonneg a → ∃ x y : ℕ, a = ⟨x, y⟩ ∨ a = ⟨x, -y⟩ ∨ a = ⟨-x, y⟩
  | ⟨(x : ℕ), (y : ℕ)⟩, _ => ⟨x, y, Or.inl rfl⟩
  | ⟨(x : ℕ), -[y+1]⟩, _ => ⟨x, y + 1, Or.inr <| Or.inl rfl⟩
  | ⟨-[x+1], (y : ℕ)⟩, _ => ⟨x + 1, y, Or.inr <| Or.inr rfl⟩
  | ⟨-[_+1], -[_+1]⟩, h => False.elim h
#align zsqrtd.nonneg_cases Zsqrtd.nonneg_cases

open Int in
theorem nonneg_add_lem {x y z w : ℕ} (xy : Nonneg (⟨x, -y⟩ : ℤ√d)) (zw : Nonneg (⟨-z, w⟩ : ℤ√d)) :
    Nonneg (⟨x, -y⟩ + ⟨-z, w⟩ : ℤ√d) := by
  have : Nonneg ⟨Int.subNatNat x z, Int.subNatNat w y⟩ :=
    Int.subNatNat_elim x z
      (fun m n i => SqLe y d m 1 → SqLe n 1 w d → Nonneg ⟨i, Int.subNatNat w y⟩)
      (fun j k =>
        Int.subNatNat_elim w y
          (fun m n i => SqLe n d (k + j) 1 → SqLe k 1 m d → Nonneg ⟨Int.ofNat j, i⟩)
          (fun _ _ _ _ => trivial) fun m n xy zw => sqLe_cancel zw xy)
      (fun j k =>
        Int.subNatNat_elim w y
          (fun m n i => SqLe n d k 1 → SqLe (k + j + 1) 1 m d → Nonneg ⟨-[j+1], i⟩)
          (fun m n xy zw => sqLe_cancel xy zw) fun m n xy zw =>
          let t := Nat.le_trans zw (sqLe_of_le (Nat.le_add_right n (m + 1)) le_rfl xy)
          have : k + j + 1 ≤ k :=
            Nat.mul_self_le_mul_self_iff.2 (by simpa [one_mul] using t)
          absurd this (not_le_of_gt <| Nat.succ_le_succ <| Nat.le_add_right _ _))
      (nonnegg_pos_neg.1 xy) (nonnegg_neg_pos.1 zw)
  rw [add_def, neg_add_eq_sub]
  rwa [Int.subNatNat_eq_coe, Int.subNatNat_eq_coe] at this
#align zsqrtd.nonneg_add_lem Zsqrtd.nonneg_add_lem

theorem Nonneg.add {a b : ℤ√d} (ha : Nonneg a) (hb : Nonneg b) : Nonneg (a + b) := by
  rcases nonneg_cases ha with ⟨x, y, rfl | rfl | rfl⟩ <;>
    rcases nonneg_cases hb with ⟨z, w, rfl | rfl | rfl⟩
  · trivial
  · refine' nonnegg_cases_right fun i h => sqLe_of_le _ _ (nonnegg_pos_neg.1 hb)
    · dsimp only at h
      exact Int.ofNat_le.1 (le_of_neg_le_neg (Int.le.intro y (by simp [add_comm, *])))
    · apply Nat.le_add_left
  · refine' nonnegg_cases_left fun i h => sqLe_of_le _ _ (nonnegg_neg_pos.1 hb)
    · dsimp only at h
      exact Int.ofNat_le.1 (le_of_neg_le_neg (Int.le.intro x (by simp [add_comm, *])))
    · apply Nat.le_add_left
  · refine' nonnegg_cases_right fun i h => sqLe_of_le _ _ (nonnegg_pos_neg.1 ha)
    · dsimp only at h
      exact Int.ofNat_le.1 (le_of_neg_le_neg (Int.le.intro w (by simp [*])))
    · apply Nat.le_add_right
  · have : Nonneg ⟨_, _⟩ :=
      nonnegg_pos_neg.2 (sqLe_add (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb))
    rw [Nat.cast_add, Nat.cast_add, neg_add] at this
    rwa [add_def]
    -- Porting note: was
    -- simpa [add_comm] using
    --   nonnegg_pos_neg.2 (sqLe_add (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb))
  · exact nonneg_add_lem ha hb
  · refine' nonnegg_cases_left fun i h => sqLe_of_le _ _ (nonnegg_neg_pos.1 ha)
    · dsimp only at h
      exact Int.ofNat_le.1 (le_of_neg_le_neg (Int.le.intro _ h))
    · apply Nat.le_add_right
  · dsimp
    rw [add_comm, add_comm (y : ℤ)]
    exact nonneg_add_lem hb ha
  · have : Nonneg ⟨_, _⟩ :=
      nonnegg_neg_pos.2 (sqLe_add (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb))
    rw [Nat.cast_add, Nat.cast_add, neg_add] at this
    rwa [add_def]
    -- Porting note: was
    -- simpa [add_comm] using
    --   nonnegg_neg_pos.2 (sqLe_add (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb))
#align zsqrtd.nonneg.add Zsqrtd.Nonneg.add

theorem nonneg_iff_zero_le {a : ℤ√d} : Nonneg a ↔ 0 ≤ a :=
  show _ ↔ Nonneg _ by simp
#align zsqrtd.nonneg_iff_zero_le Zsqrtd.nonneg_iff_zero_le

theorem le_of_le_le {x y z w : ℤ} (xz : x ≤ z) (yw : y ≤ w) : (⟨x, y⟩ : ℤ√d) ≤ ⟨z, w⟩ :=
  show Nonneg ⟨z - x, w - y⟩ from
    match z - x, w - y, Int.le.dest_sub xz, Int.le.dest_sub yw with
    | _, _, ⟨_, rfl⟩, ⟨_, rfl⟩ => trivial
#align zsqrtd.le_of_le_le Zsqrtd.le_of_le_le

open Int in
protected theorem nonneg_total : ∀ a : ℤ√d, Nonneg a ∨ Nonneg (-a)
  | ⟨(x : ℕ), (y : ℕ)⟩ => Or.inl trivial
  | ⟨-[_+1], -[_+1]⟩ => Or.inr trivial
  | ⟨0, -[_+1]⟩ => Or.inr trivial
  | ⟨-[_+1], 0⟩ => Or.inr trivial
  | ⟨(_ + 1 : ℕ), -[_+1]⟩ => Nat.le_total _ _
  | ⟨-[_+1], (_ + 1 : ℕ)⟩ => Nat.le_total _ _
#align zsqrtd.nonneg_total Zsqrtd.nonneg_total

protected theorem le_total (a b : ℤ√d) : a ≤ b ∨ b ≤ a := by
  have t := (b - a).nonneg_total
  rwa [neg_sub] at t
#align zsqrtd.le_total Zsqrtd.le_total

instance preorder : Preorder (ℤ√d) where
  le := (· ≤ ·)
  le_refl a := show Nonneg (a - a) by simp only [sub_self]; trivial
  le_trans a b c hab hbc := by simpa [sub_add_sub_cancel'] using hab.add hbc
  lt := (· < ·)
  lt_iff_le_not_le a b := (and_iff_right_of_imp (Zsqrtd.le_total _ _).resolve_left).symm

open Int in
theorem le_arch (a : ℤ√d) : ∃ n : ℕ, a ≤ n := by
  obtain ⟨x, y, (h : a ≤ ⟨x, y⟩)⟩ : ∃ x y : ℕ, Nonneg (⟨x, y⟩ + -a) :=
    match -a with
    | ⟨Int.ofNat x, Int.ofNat y⟩ => ⟨0, 0, by trivial⟩
    | ⟨Int.ofNat x, -[y+1]⟩ => ⟨0, y + 1, by simp [add_def, Int.negSucc_coe, add_assoc]; trivial⟩
    | ⟨-[x+1], Int.ofNat y⟩ => ⟨x + 1, 0, by simp [Int.negSucc_coe, add_assoc]; trivial⟩
    | ⟨-[x+1], -[y+1]⟩ => ⟨x + 1, y + 1, by simp [Int.negSucc_coe, add_assoc]; trivial⟩
  refine' ⟨x + d * y, h.trans _⟩
  change Nonneg ⟨↑x + d * y - ↑x, 0 - ↑y⟩
  cases' y with y
  · simp
    trivial
  have h : ∀ y, SqLe y d (d * y) 1 := fun y => by
    simpa [SqLe, mul_comm, mul_left_comm] using Nat.mul_le_mul_right (y * y) (Nat.le_mul_self d)
  rw [show (x : ℤ) + d * Nat.succ y - x = d * Nat.succ y by simp]
  exact h (y + 1)
#align zsqrtd.le_arch Zsqrtd.le_arch

protected theorem add_le_add_left (a b : ℤ√d) (ab : a ≤ b) (c : ℤ√d) : c + a ≤ c + b :=
  show Nonneg _ by rw [add_sub_add_left_eq_sub]; exact ab
#align zsqrtd.add_le_add_left Zsqrtd.add_le_add_left

protected theorem le_of_add_le_add_left (a b c : ℤ√d) (h : c + a ≤ c + b) : a ≤ b := by
  simpa using Zsqrtd.add_le_add_left _ _ h (-c)
#align zsqrtd.le_of_add_le_add_left Zsqrtd.le_of_add_le_add_left

protected theorem add_lt_add_left (a b : ℤ√d) (h : a < b) (c) : c + a < c + b := fun h' =>
  h (Zsqrtd.le_of_add_le_add_left _ _ _ h')
#align zsqrtd.add_lt_add_left Zsqrtd.add_lt_add_left

theorem nonneg_smul {a : ℤ√d} {n : ℕ} (ha : Nonneg a) : Nonneg ((n : ℤ√d) * a) := by
  rw [← Int.cast_ofNat n]
  exact
    match a, nonneg_cases ha, ha with
    | _, ⟨x, y, Or.inl rfl⟩, _ => by rw [smul_val]; trivial
    | _, ⟨x, y, Or.inr <| Or.inl rfl⟩, ha => by
      rw [smul_val]; simpa using nonnegg_pos_neg.2 (sqLe_smul n <| nonnegg_pos_neg.1 ha)
    | _, ⟨x, y, Or.inr <| Or.inr rfl⟩, ha => by
      rw [smul_val]; simpa using nonnegg_neg_pos.2 (sqLe_smul n <| nonnegg_neg_pos.1 ha)
#align zsqrtd.nonneg_smul Zsqrtd.nonneg_smul

theorem nonneg_muld {a : ℤ√d} (ha : Nonneg a) : Nonneg (sqrtd * a) :=
  match a, nonneg_cases ha, ha with
  | _, ⟨_, _, Or.inl rfl⟩, _ => trivial
  | _, ⟨x, y, Or.inr <| Or.inl rfl⟩, ha => by
    simp only [muld_val, mul_neg]
    apply nonnegg_neg_pos.2
    simpa [SqLe, mul_comm, mul_left_comm] using Nat.mul_le_mul_left d (nonnegg_pos_neg.1 ha)
  | _, ⟨x, y, Or.inr <| Or.inr rfl⟩, ha => by
    simp only [muld_val]
    apply nonnegg_pos_neg.2
    simpa [SqLe, mul_comm, mul_left_comm] using Nat.mul_le_mul_left d (nonnegg_neg_pos.1 ha)
#align zsqrtd.nonneg_muld Zsqrtd.nonneg_muld

theorem nonneg_mul_lem {x y : ℕ} {a : ℤ√d} (ha : Nonneg a) : Nonneg (⟨x, y⟩ * a) := by
  have : (⟨x, y⟩ * a : ℤ√d) = (x : ℤ√d) * a + sqrtd * ((y : ℤ√d) * a) := by
    rw [decompose, right_distrib, mul_assoc, Int.cast_ofNat, Int.cast_ofNat]
  rw [this]
  exact (nonneg_smul ha).add (nonneg_muld <| nonneg_smul ha)
#align zsqrtd.nonneg_mul_lem Zsqrtd.nonneg_mul_lem

theorem nonneg_mul {a b : ℤ√d} (ha : Nonneg a) (hb : Nonneg b) : Nonneg (a * b) :=
  match a, b, nonneg_cases ha, nonneg_cases hb, ha, hb with
  | _, _, ⟨_, _, Or.inl rfl⟩, ⟨_, _, Or.inl rfl⟩, _, _ => trivial
  | _, _, ⟨x, y, Or.inl rfl⟩, ⟨z, w, Or.inr <| Or.inr rfl⟩, _, hb => nonneg_mul_lem hb
  | _, _, ⟨x, y, Or.inl rfl⟩, ⟨z, w, Or.inr <| Or.inl rfl⟩, _, hb => nonneg_mul_lem hb
  | _, _, ⟨x, y, Or.inr <| Or.inr rfl⟩, ⟨z, w, Or.inl rfl⟩, ha, _ => by
    rw [mul_comm]; exact nonneg_mul_lem ha
  | _, _, ⟨x, y, Or.inr <| Or.inl rfl⟩, ⟨z, w, Or.inl rfl⟩, ha, _ => by
    rw [mul_comm]; exact nonneg_mul_lem ha
  | _, _, ⟨x, y, Or.inr <| Or.inr rfl⟩, ⟨z, w, Or.inr <| Or.inr rfl⟩, ha, hb => by
    rw [calc
          (⟨-x, y⟩ * ⟨-z, w⟩ : ℤ√d) = ⟨_, _⟩ := rfl
          _ = ⟨x * z + d * y * w, -(x * w + y * z)⟩ := by simp [add_comm]
          ]
    exact nonnegg_pos_neg.2 (sqLe_mul.left (nonnegg_neg_pos.1 ha) (nonnegg_neg_pos.1 hb))
  | _, _, ⟨x, y, Or.inr <| Or.inr rfl⟩, ⟨z, w, Or.inr <| Or.inl rfl⟩, ha, hb => by
    rw [calc
          (⟨-x, y⟩ * ⟨z, -w⟩ : ℤ√d) = ⟨_, _⟩ := rfl
          _ = ⟨-(x * z + d * y * w), x * w + y * z⟩ := by simp [add_comm]
          ]
    exact nonnegg_neg_pos.2 (sqLe_mul.right.left (nonnegg_neg_pos.1 ha) (nonnegg_pos_neg.1 hb))
  | _, _, ⟨x, y, Or.inr <| Or.inl rfl⟩, ⟨z, w, Or.inr <| Or.inr rfl⟩, ha, hb => by
    rw [calc
          (⟨x, -y⟩ * ⟨-z, w⟩ : ℤ√d) = ⟨_, _⟩ := rfl
          _ = ⟨-(x * z + d * y * w), x * w + y * z⟩ := by simp [add_comm]
          ]
    exact
        nonnegg_neg_pos.2 (sqLe_mul.right.right.left (nonnegg_pos_neg.1 ha) (nonnegg_neg_pos.1 hb))
  | _, _, ⟨x, y, Or.inr <| Or.inl rfl⟩, ⟨z, w, Or.inr <| Or.inl rfl⟩, ha, hb => by
    rw [calc
          (⟨x, -y⟩ * ⟨z, -w⟩ : ℤ√d) = ⟨_, _⟩ := rfl
          _ = ⟨x * z + d * y * w, -(x * w + y * z)⟩ := by simp [add_comm]
          ]
    exact
        nonnegg_pos_neg.2
          (sqLe_mul.right.right.right (nonnegg_pos_neg.1 ha) (nonnegg_pos_neg.1 hb))
#align zsqrtd.nonneg_mul Zsqrtd.nonneg_mul

protected theorem mul_nonneg (a b : ℤ√d) : 0 ≤ a → 0 ≤ b → 0 ≤ a * b := by
  simp_rw [← nonneg_iff_zero_le]
  exact nonneg_mul
#align zsqrtd.mul_nonneg Zsqrtd.mul_nonneg

theorem not_sqLe_succ (c d y) (h : 0 < c) : ¬SqLe (y + 1) c 0 d :=
  not_le_of_gt <| mul_pos (mul_pos h <| Nat.succ_pos _) <| Nat.succ_pos _
#align zsqrtd.not_sq_le_succ Zsqrtd.not_sqLe_succ

-- Porting note: renamed field and added theorem to make `x` explicit
/-- 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 : ℕ) : Prop where
  ns' : ∀ n : ℕ, x ≠ n * n
#align zsqrtd.nonsquare Zsqrtd.Nonsquare

theorem Nonsquare.ns (x : ℕ) [Nonsquare x] : ∀ n : ℕ, x ≠ n * n := ns'

variable [dnsq : Nonsquare d]

theorem d_pos : 0 < d :=
  lt_of_le_of_ne (Nat.zero_le _) <| Ne.symm <| Nonsquare.ns d 0
#align zsqrtd.d_pos Zsqrtd.d_pos

theorem divides_sq_eq_zero {x y} (h : x * x = d * y * y) : x = 0 ∧ y = 0 :=
  let g := x.gcd y
  Or.elim g.eq_zero_or_pos
    (fun H => ⟨Nat.eq_zero_of_gcd_eq_zero_left H, Nat.eq_zero_of_gcd_eq_zero_right H⟩) fun gpos =>
    False.elim <|
      by
      let ⟨m, n, co, (hx : x = m * g), (hy : y = n * g)⟩ := Nat.exists_coprime gpos
      rw [hx, hy] at h
      have : m * m = d * (n * n) := by
        refine mul_left_cancel₀ (mul_pos gpos gpos).ne' ?_
        -- Porting note: was `simpa [mul_comm, mul_left_comm] using h`
        calc
          g * g * (m * m)
          _ = m * g * (m * g) := by ring
          _ = d * (n * g) * (n * g) := h
          _ = g * g * (d * (n * n)) := by ring
      have co2 :=
        let co1 := co.mul_right co
        co1.mul co1
      exact
        Nonsquare.ns d m
          (Nat.dvd_antisymm (by rw [this]; apply dvd_mul_right) <|
            co2.dvd_of_dvd_mul_right <| by simp [this])
#align zsqrtd.divides_sq_eq_zero Zsqrtd.divides_sq_eq_zero

theorem divides_sq_eq_zero_z {x y : ℤ} (h : x * x = d * y * y) : x = 0 ∧ y = 0 := by
  rw [mul_assoc, ← Int.natAbs_mul_self, ← Int.natAbs_mul_self, ← Int.ofNat_mul, ← mul_assoc] at h
  exact
    let ⟨h1, h2⟩ := divides_sq_eq_zero (Int.ofNat.inj h)
    ⟨Int.natAbs_eq_zero.mp h1, Int.natAbs_eq_zero.mp h2⟩
#align zsqrtd.divides_sq_eq_zero_z Zsqrtd.divides_sq_eq_zero_z

theorem not_divides_sq (x y) : (x + 1) * (x + 1) ≠ d * (y + 1) * (y + 1) := fun e => by
  have t := (divides_sq_eq_zero e).left
  contradiction
#align zsqrtd.not_divides_sq Zsqrtd.not_divides_sq

open Int in
theorem nonneg_antisymm : ∀ {a : ℤ√d}, Nonneg a → Nonneg (-a) → a = 0
  | ⟨0, 0⟩, _, _ => rfl
  | ⟨-[x+1], -[y+1]⟩, xy, _ => False.elim xy
  | ⟨(x + 1 : Nat), (y + 1 : Nat)⟩, _, yx => False.elim yx
  | ⟨-[x+1], 0⟩, xy, _ => absurd xy (not_sqLe_succ _ _ _ (by decide))
  | ⟨(x + 1 : Nat), 0⟩, _, yx => absurd yx (not_sqLe_succ _ _ _ (by decide))
  | ⟨0, -[y+1]⟩, xy, _ => absurd xy (not_sqLe_succ _ _ _ d_pos)
  | ⟨0, (y + 1 : Nat)⟩, _, yx => absurd yx (not_sqLe_succ _ _ _ d_pos)
  | ⟨(x + 1 : Nat), -[y+1]⟩, (xy : SqLe _ _ _ _), (yx : SqLe _ _ _ _) => by
    let t := le_antisymm yx xy
    rw [one_mul] at t
    exact absurd t (not_divides_sq _ _)
  | ⟨-[x+1], (y + 1 : Nat)⟩, (xy : SqLe _ _ _ _), (yx : SqLe _ _ _ _) => by
    let t := le_antisymm xy yx
    rw [one_mul] at t
    exact absurd t (not_divides_sq _ _)
#align zsqrtd.nonneg_antisymm Zsqrtd.nonneg_antisymm

theorem le_antisymm {a b : ℤ√d} (ab : a ≤ b) (ba : b ≤ a) : a = b :=
  eq_of_sub_eq_zero <| nonneg_antisymm ba (by rwa [neg_sub])
#align zsqrtd.le_antisymm Zsqrtd.le_antisymm

instance linearOrder : LinearOrder (ℤ√d) :=
  { Zsqrtd.preorder with
    le_antisymm := fun _ _ => Zsqrtd.le_antisymm
    le_total := Zsqrtd.le_total
    decidable_le := Zsqrtd.decidableLE }

protected theorem eq_zero_or_eq_zero_of_mul_eq_zero : ∀ {a b : ℤ√d}, a * b = 0 → a = 0 ∨ b = 0
  | ⟨x, y⟩, ⟨z, w⟩, h => by
    injection h with h1 h2
    have h1 : x * z = -(d * y * w) := eq_neg_of_add_eq_zero_left h1
    have h2 : x * w = -(y * z) := eq_neg_of_add_eq_zero_left h2
    have fin : x * x = d * y * y → (⟨x, y⟩ : ℤ√d) = 0 := fun e =>
      match x, y, divides_sq_eq_zero_z e with
      | _, _, ⟨rfl, rfl⟩ => rfl
    exact
      if z0 : z = 0 then
        if w0 : w = 0 then
          Or.inr
            (match z, w, z0, w0 with
            | _, _, rfl, rfl => rfl)
        else
          Or.inl <|
            fin <|
              mul_right_cancel₀ w0 <|
                calc
                  x * x * w = -y * (x * z) := by simp [h2, mul_assoc, mul_left_comm]
                  _ = d * y * y * w := by simp [h1, mul_assoc, mul_left_comm]

      else
        Or.inl <|
          fin <|
            mul_right_cancel₀ z0 <|
              calc
                x * x * z = d * -y * (x * w) := by simp [h1, mul_assoc, mul_left_comm]
                _ = d * y * y * z := by simp [h2, mul_assoc, mul_left_comm]

#align zsqrtd.eq_zero_or_eq_zero_of_mul_eq_zero Zsqrtd.eq_zero_or_eq_zero_of_mul_eq_zero

instance : NoZeroDivisors (ℤ√d) where
  eq_zero_or_eq_zero_of_mul_eq_zero := Zsqrtd.eq_zero_or_eq_zero_of_mul_eq_zero

instance : IsDomain (ℤ√d) :=
  NoZeroDivisors.to_isDomain _

protected theorem mul_pos (a b : ℤ√d) (a0 : 0 < a) (b0 : 0 < b) : 0 < a * b := fun ab =>
  Or.elim
    (eq_zero_or_eq_zero_of_mul_eq_zero
      (le_antisymm ab (Zsqrtd.mul_nonneg _ _ (le_of_lt a0) (le_of_lt b0))))
    (fun e => ne_of_gt a0 e) fun e => ne_of_gt b0 e
#align zsqrtd.mul_pos Zsqrtd.mul_pos

instance : LinearOrderedCommRing (ℤ√d) :=
  { Zsqrtd.commRing, Zsqrtd.linearOrder, Zsqrtd.nontrivial with
    add_le_add_left := Zsqrtd.add_le_add_left
    mul_pos := Zsqrtd.mul_pos
    zero_le_one := by trivial }

instance : LinearOrderedRing (ℤ√d) := by infer_instance

instance : OrderedRing (ℤ√d) := by infer_instance

end

theorem norm_eq_zero {d : ℤ} (h_nonsquare : ∀ n : ℤ, d ≠ n * n) (a : ℤ√d) : norm a = 0 ↔ a = 0 := by
  refine' ⟨fun ha => ext.mpr _, fun h => by rw [h, norm_zero]⟩
  dsimp only [norm] at ha
  rw [sub_eq_zero] at ha
  by_cases h : 0 ≤ d
  · obtain ⟨d', rfl⟩ := Int.eq_ofNat_of_zero_le h
    haveI : Nonsquare d' := ⟨fun n h => h_nonsquare n <| by exact_mod_cast h⟩
    exact divides_sq_eq_zero_z ha
  · push_neg at h
    suffices a.re * a.re = 0 by
      rw [eq_zero_of_mul_self_eq_zero this] at ha⊢
      simpa only [true_and_iff, or_self_right, zero_re, zero_im, eq_self_iff_true, zero_eq_mul,
        mul_zero, mul_eq_zero, h.ne, false_or_iff, or_self_iff] using ha
    apply _root_.le_antisymm _ (mul_self_nonneg _)
    rw [ha, mul_assoc]
    exact mul_nonpos_of_nonpos_of_nonneg h.le (mul_self_nonneg _)
#align zsqrtd.norm_eq_zero Zsqrtd.norm_eq_zero

variable {R : Type}

@[ext]
theorem hom_ext [Ring R] {d : ℤ} (f g : ℤ√d →+* R) (h : f sqrtd = g sqrtd) : f = g := by
  ext ⟨x_re, x_im⟩
  simp [decompose, h]
#align zsqrtd.hom_ext Zsqrtd.hom_ext

variable [CommRing R]

/-- The unique `RingHom` 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`. -/
@[simps]
def lift {d : ℤ} : { r : R // r * r = ↑d } ≃ (ℤ√d →+* R) where
  toFun r :=
    { toFun := fun a => a.1 + a.2 * (r : R)
      map_zero' := by simp
      map_add' := fun a b => by
        simp
        ring
      map_one' := by simp
      map_mul' := fun a b => by
        have :
          (a.re + a.im * r : R) * (b.re + b.im * r) =
            a.re * b.re + (a.re * b.im + a.im * b.re) * r + a.im * b.im * (r * r) := by
          ring
        simp [this, r.prop]
        ring }
  invFun f := ⟨f sqrtd, by rw [← f.map_mul, dmuld, map_intCast]⟩
  left_inv r := by
    ext
    simp
  right_inv f := by
    -- Porting note: was `ext`
    refine hom_ext _ _ ?_
    simp
#align zsqrtd.lift Zsqrtd.lift

/-- `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 [CharZero R] {d : ℤ} (r : { r : R // r * r = ↑d })
    (hd : ∀ n : ℤ, d ≠ n * n) : Function.Injective (lift r) :=
  (injective_iff_map_eq_zero (lift r)).mpr fun a ha => by
    have h_inj : Function.Injective ((↑) : ℤ → R) := Int.cast_injective
    suffices lift r a.norm = 0 by
      simp only [coe_int_re, add_zero, lift_apply_apply, coe_int_im, Int.cast_zero,
        MulZeroClass.zero_mul] at this
      rwa [← Int.cast_zero, h_inj.eq_iff, norm_eq_zero hd] at this
    rw [norm_eq_mul_conj, RingHom.map_mul, ha, MulZeroClass.zero_mul]
#align zsqrtd.lift_injective Zsqrtd.lift_injective

/-- An element of `ℤ√d` has norm equal to `1` if and only if it is contained in the submonoid
of unitary elements. -/
theorem norm_eq_one_iff_mem_unitary {d : ℤ} {a : ℤ√d} : a.norm = 1 ↔ a ∈ unitary (ℤ√d) := by
  rw [unitary.mem_iff_self_mul_star, ← norm_eq_mul_conj]
  norm_cast
#align zsqrtd.norm_eq_one_iff_mem_unitary Zsqrtd.norm_eq_one_iff_mem_unitary

/-- The kernel of the norm map on `ℤ√d` equals the submonoid of unitary elements. -/
theorem mker_norm_eq_unitary {d : ℤ} : MonoidHom.mker (@normMonoidHom d) = unitary (ℤ√d) :=
  Submonoid.ext fun _ => norm_eq_one_iff_mem_unitary
#align zsqrtd.mker_norm_eq_unitary Zsqrtd.mker_norm_eq_unitary

end Zsqrtd


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Kappelmann
-/
import algebra.order.floor
import tactic.field_simp

/-!
# Floor Function for Rational Numbers

## Summary

We define the `floor` function and the `floor_ring` instance on `ℚ`. Some technical lemmas relating
`floor` to integer division and modulo arithmetic are derived as well as some simple inequalities.

## Tags

rat, rationals, ℚ, floor
-/

open int

namespace rat

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
protected def floor : ℚ → ℤ
| ⟨n, d, h, c⟩ := n / d

protected theorem le_floor {z : ℤ} : ∀ {r : ℚ}, z ≤ rat.floor r ↔ (z : ℚ) ≤ r
| ⟨n, d, h, c⟩ := begin
  simp [rat.floor],
  rw [num_denom'],
  have h' := int.coe_nat_lt.2 h,
  conv { to_rhs,
    rw [coe_int_eq_mk, rat.le_def zero_lt_one h', mul_one] },
  exact int.le_div_iff_mul_le h'
end

instance : floor_ring ℚ :=
floor_ring.of_floor ℚ rat.floor $ λ a z, rat.le_floor.symm

protected lemma floor_def {q : ℚ} : ⌊q⌋ = q.num / q.denom := by { cases q, refl }

lemma floor_int_div_nat_eq_div {n : ℤ} {d : ℕ} : ⌊(↑n : ℚ) / (↑d : ℚ)⌋ = n / (↑d : ℤ) :=
begin
  rw [rat.floor_def],
  cases decidable.em (d = 0) with d_eq_zero d_ne_zero,
  { simp [d_eq_zero] },
  { cases decidable.em (n = 0) with n_eq_zero n_ne_zero,
    { simp [n_eq_zero] },
    { set q := (n : ℚ) / d with q_eq,
      obtain ⟨c, n_eq_c_mul_num, d_eq_c_mul_denom⟩ : ∃ c, n = c * q.num ∧ (d : ℤ) = c * q.denom, by
      { rw q_eq,
        exact_mod_cast (@rat.exists_eq_mul_div_num_and_eq_mul_div_denom n d n_ne_zero
          (by exact_mod_cast d_ne_zero)) },
      suffices : q.num / q.denom = c * q.num / (c * q.denom),
        by rwa [n_eq_c_mul_num, d_eq_c_mul_denom],
      suffices : c > 0, by solve_by_elim [int.mul_div_mul_of_pos],
      have q_denom_mul_c_pos : (0 : ℤ) < q.denom * c, by
      { have : (d : ℤ) > 0, by exact_mod_cast (pos_iff_ne_zero.elim_right d_ne_zero),
        rwa [d_eq_c_mul_denom, mul_comm] at this },
      suffices : (0 : ℤ) ≤ q.denom, from pos_of_mul_pos_left q_denom_mul_c_pos this,
      exact_mod_cast (le_of_lt q.pos) } }
end

end rat

lemma int.mod_nat_eq_sub_mul_floor_rat_div {n : ℤ} {d : ℕ} : n % d = n - d * ⌊(n : ℚ) / d⌋ :=
by rw [(eq_sub_of_add_eq $ int.mod_add_div n d), rat.floor_int_div_nat_eq_div]

lemma nat.coprime_sub_mul_floor_rat_div_of_coprime {n d : ℕ} (n_coprime_d : n.coprime d) :
  ((n : ℤ) - d * ⌊(n : ℚ)/ d⌋).nat_abs.coprime d :=
begin
  have : (n : ℤ) % d = n - d * ⌊(n : ℚ)/ d⌋, from int.mod_nat_eq_sub_mul_floor_rat_div,
  rw ←this,
  have : d.coprime n, from n_coprime_d.symm,
  rwa [nat.coprime, nat.gcd_rec] at this
end

namespace rat

lemma num_lt_succ_floor_mul_denom (q : ℚ) : q.num < (⌊q⌋ + 1) * q.denom :=
begin
  suffices : (q.num : ℚ) < (⌊q⌋ + 1) * q.denom, by exact_mod_cast this,
  suffices : (q.num : ℚ) < (q - fract q + 1) * q.denom, by
  { have : (⌊q⌋ : ℚ) = q - fract q, from (eq_sub_of_add_eq $ floor_add_fract q),
    rwa this },
  suffices : (q.num : ℚ) < q.num + (1 - fract q) * q.denom, by
  { have : (q - fract q + 1) * q.denom = q.num + (1 - fract q) * q.denom, calc
      (q - fract q + 1) * q.denom = (q + (1 - fract q)) * q.denom            : by ring
                              ... = q * q.denom + (1 - fract q) * q.denom    : by rw add_mul
                              ... = q.num + (1 - fract q) * q.denom : by simp,
    rwa this },
  suffices : 0 < (1 - fract q) * q.denom, by { rw ←sub_lt_iff_lt_add', simpa },
  have : 0 < 1 - fract q, by
  { have : fract q < 1, from fract_lt_one q,
    have : 0 + fract q < 1, by simp [this],
    rwa lt_sub_iff_add_lt },
  exact mul_pos this (by exact_mod_cast q.pos)
end

lemma fract_inv_num_lt_num_of_pos {q : ℚ} (q_pos : 0 < q): (fract q⁻¹).num < q.num :=
begin
  -- we know that the numerator must be positive
  have q_num_pos : 0 < q.num, from rat.num_pos_iff_pos.elim_right q_pos,
  -- we will work with the absolute value of the numerator, which is equal to the numerator
  have q_num_abs_eq_q_num : (q.num.nat_abs : ℤ) = q.num, from
    (int.nat_abs_of_nonneg q_num_pos.le),
  set q_inv := (q.denom : ℚ) / q.num with q_inv_def,
  have q_inv_eq : q⁻¹ = q_inv, from rat.inv_def',
  suffices : (q_inv - ⌊q_inv⌋).num < q.num, by rwa q_inv_eq,
  suffices : ((q.denom - q.num * ⌊q_inv⌋ : ℚ) / q.num).num < q.num, by
    field_simp [this, (ne_of_gt q_num_pos)],
  suffices : (q.denom : ℤ) - q.num * ⌊q_inv⌋ < q.num, by
  { -- use that `q.num` and `q.denom` are coprime to show that the numerator stays unreduced
    have : ((q.denom - q.num * ⌊q_inv⌋ : ℚ) / q.num).num = q.denom - q.num * ⌊q_inv⌋, by
    { suffices : ((q.denom : ℤ) - q.num * ⌊q_inv⌋).nat_abs.coprime q.num.nat_abs, by
        exact_mod_cast (rat.num_div_eq_of_coprime q_num_pos this),
      have : (q.num.nat_abs : ℚ) = (q.num : ℚ), by exact_mod_cast q_num_abs_eq_q_num,
      have tmp := nat.coprime_sub_mul_floor_rat_div_of_coprime q.cop.symm,
      simpa only [this, q_num_abs_eq_q_num] using tmp },
    rwa this },
  -- to show the claim, start with the following inequality
  have q_inv_num_denom_ineq : q⁻¹.num - ⌊q⁻¹⌋ * q⁻¹.denom < q⁻¹.denom, by
  { have : q⁻¹.num < (⌊q⁻¹⌋ + 1) * q⁻¹.denom, from rat.num_lt_succ_floor_mul_denom q⁻¹,
    have : q⁻¹.num < ⌊q⁻¹⌋ * q⁻¹.denom + q⁻¹.denom, by rwa [right_distrib, one_mul] at this,
    rwa [←sub_lt_iff_lt_add'] at this },
  -- use that `q.num` and `q.denom` are coprime to show that q_inv is the unreduced reciprocal
  -- of `q`
  have : q_inv.num = q.denom ∧ q_inv.denom = q.num.nat_abs, by
  { have coprime_q_denom_q_num : q.denom.coprime q.num.nat_abs, from q.cop.symm,
    have : int.nat_abs q.denom = q.denom, by simp,
    rw ←this at coprime_q_denom_q_num,
    rw q_inv_def,
    split,
    { exact_mod_cast (rat.num_div_eq_of_coprime q_num_pos coprime_q_denom_q_num) },
    { suffices : (((q.denom : ℚ) / q.num).denom : ℤ) = q.num.nat_abs, by exact_mod_cast this,
      rw q_num_abs_eq_q_num,
      exact_mod_cast (rat.denom_div_eq_of_coprime q_num_pos coprime_q_denom_q_num) } },
  rwa [q_inv_eq, this.left, this.right, q_num_abs_eq_q_num, mul_comm] at q_inv_num_denom_ineq
end

end rat


import kaplanski
import ring_theory.localization.ideal

example {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] [is_domain R] {M : submonoid R}
  [is_localization M S] (hM : M ≤ non_zero_divisors R) : is_domain S :=
is_localization.is_domain_of_le_non_zero_divisors _ hM

example {R : Type*} [comm_ring R] [is_domain R] : cancel_comm_monoid_with_zero R :=
begin
  refine is_domain.to_cancel_comm_monoid_with_zero,
end

lemma is_localization.prime_of_prime {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] [is_domain R] {M : submonoid R} [is_localization M S] (hM : M ≤ non_zero_divisors R) (p : R) (hp : prime p) (hp₂ : ∃ (I : ideal R), disjoint (M : set R) (I : set R) ∧ p ∈ I) : prime ((algebra_map R S) p) :=
begin
  rcases hp₂ with ⟨I, hI, hp₂⟩,
  have hp' := is_localization.is_prime_of_is_prime_disjoint M S (ideal.span {p}) ((ideal.span_singleton_prime hp.ne_zero).2 hp) (set.disjoint_of_subset_right (I.span_singleton_le_iff_mem.2 hp₂) hI),
  rw [ideal.map_span, set.image_singleton] at hp',
  exact (ideal.span_singleton_prime (λ hp₃, hp.ne_zero ((is_localization.to_map_eq_zero_iff S hM).1 hp₃))).1 hp',
end

example {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] [is_domain R] {M : submonoid R}
  [is_localization M S] (hM : M ≤ non_zero_divisors R) [unique_factorization_monoid R] :
  @unique_factorization_monoid S (@is_domain.to_cancel_comm_monoid_with_zero S _
    (is_localization.is_domain_of_le_non_zero_divisors _ hM)) :=
begin
  haveI : is_domain S := is_localization.is_domain_of_le_non_zero_divisors _ hM,
  refine theo1_gauche (λ J hJzero hJprime, _),
  set I := J.comap (algebra_map R S) with Idef,
  have hIprime : I.is_prime := ((is_localization.is_prime_iff_is_prime_disjoint M S J).1 hJprime).1,
  have hI : I ≠ ⊥,
  { intro h,
    refine hJzero _,
    rw [← is_localization.map_comap M S J, ← Idef, h, ideal.map_bot] },
  obtain ⟨p, hpI, hp⟩ := theo1_droite hI hIprime,
  refine ⟨algebra_map R S p, ideal.mem_comap.mp hpI, _⟩,
  refine is_localization.prime_of_prime hM p hp ⟨I, ⟨(((is_localization.is_prime_iff_is_prime_disjoint M S J).1 hJprime).2), hpI⟩⟩,
end


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Stochastic operators.
-/
import .tensor .tfacts .tgrads .tcont .mvn

namespace certigrad

namespace rand
open list

def pdf_function (ishapes : list S) (oshape : S) : Type := dvec T ishapes → T oshape → ℝ
def rng_function (ishapes : list S) (oshape : S) : Type := dvec T ishapes → state RNG (T oshape)

def precondition (ishapes : list S) : Type := dvec T ishapes → Prop

noncomputable def pdf_cdiff {ishapes : list S} {oshape : S} (pdf : pdf_function ishapes oshape) (pdf_pre : precondition ishapes) : Prop :=
  ∀ ⦃xs : dvec T ishapes⦄ {y : T oshape} {idx : ℕ} {fshape : S},
  at_idx ishapes idx fshape → pdf_pre xs →
  T.is_cdifferentiable (λ θ₀, pdf (dvec.update_at θ₀ xs idx) y) (dvec.get fshape xs idx)

def grad_logpdf (ishapes : list S) (oshape : S) : Type := dvec T ishapes → T oshape → Π (idx : ℕ) (fshape : S), T fshape

def pdf_positive {ishapes : list S} {oshape : S} (pdf : pdf_function ishapes oshape) (pdf_pre : precondition ishapes) : Prop :=
  ∀ (xs : dvec T ishapes), pdf_pre xs → ∀ (y : T oshape), pdf xs y > 0

noncomputable def pdf_integrates_to_one {ishapes : list S} {oshape : S} (pdf : pdf_function ishapes oshape) (pdf_pre : precondition ishapes) : Prop :=
  ∀ (xs : dvec T ishapes), pdf_pre xs → ∫ (λ (y : T oshape), pdf xs y) = 1

noncomputable def grad_logpdf_correct {ishapes : list S} {oshape : S}
                        (pdf : pdf_function ishapes oshape) (pdf_pre : precondition ishapes) (pdf_grad : grad_logpdf ishapes oshape) : Prop :=
  ∀ ⦃xs : dvec T ishapes⦄ {y : T oshape} {idx : ℕ} {ishape : S},
    list.at_idx ishapes idx ishape →
    pdf_pre xs →
    pdf_grad xs y idx ishape
    =
    ∇ (λ (θ₀ : T ishape), T.log (pdf (dvec.update_at θ₀ xs idx) y)) (dvec.get ishape xs idx)

noncomputable def continuous {ishapes : list S} {oshape : S} (pdf : pdf_function ishapes oshape) (pdf_pre : precondition ishapes) : Prop :=
  ∀ ⦃xs : dvec T ishapes⦄ {y : T oshape} {idx : ℕ} {tshape : S},
    list.at_idx ishapes idx tshape →
    pdf_pre xs → T.is_continuous (λ (x : T tshape), pdf (dvec.update_at x xs idx) y) (dvec.get tshape xs idx)

namespace pdf

def mvn (shape : S) : pdf_function [shape, shape] shape
| ⟦μ, σ⟧ x := T.mvn_pdf μ σ x

def mvn_std (shape : S) : pdf_function [] shape
| ⟦⟧ x := T.mvn_pdf 0 1 x

end pdf

namespace run

def mvn (shape : S) : rng_function [shape, shape] shape
| ⟦μ, σ⟧ := T.sample_mvn μ σ

def mvn_std (shape : S) : rng_function [] shape
| ⟦⟧ := T.sample_mvn 0 1

end run

namespace pre

def mvn : Π (shape : S), precondition [shape, shape]
| shape := λ xs, xs^.head2 > 0

def mvn_std : Π (shape : S), precondition []
| shape := λ xs, true

end pre

namespace pdiff

def mvn (shape : S) : pdf_cdiff (pdf.mvn shape) (pre.mvn shape)
| ⟦μ, σ⟧ x 0 ishape H_at_idx H_pre :=
begin
clear mvn,
note H_ishape_eq := H_at_idx^.right,
dsimp [list.dnth] at H_ishape_eq,
subst H_ishape_eq,
dsimp [dvec.update_at, dvec.get],
simp,
dunfold pdf.mvn T.mvn_pdf,
T.prove_differentiable,
end

| ⟦μ, σ⟧ x 1 ishape H_at_idx H_pre :=
have H_σ₂ : T.square σ > 0, from T.square_pos_of_pos H_pre,
have H_inv : T.sqrt (2 * T.pi shape * T.square σ) > 0, from T.sqrt_pos (T.mul_pos_of_pos_pos (T.mul_pos_of_pos_pos T.two_pos T.pi_pos) H_σ₂),
begin
clear mvn,
note H_ishape_eq := H_at_idx^.right,
dsimp [list.dnth] at H_ishape_eq,
subst H_ishape_eq,
dsimp [dvec.update_at, dvec.get],
simp,
dunfold pdf.mvn T.mvn_pdf,
apply T.is_cdifferentiable_binary (λ θ₁ θ₂, T.prod ((T.sqrt (2 * T.pi ishape * T.square θ₁))⁻¹ * T.exp (-2⁻¹ * T.square ((x - μ) / θ₂)))),
all_goals { dsimp, T.prove_differentiable }
end

| ⟦μ, σ⟧ x (n+2) ishape H_at_idx H_pre := false.rec _ (list.at_idx_over H_at_idx (by tactic.dec_triv))

def mvn_std (shape : S) : pdf_cdiff (pdf.mvn_std shape) (pre.mvn_std shape)
| ⟦⟧ x tgt ishape H_at_idx H_pre := false.rec _ (list.at_idx_over H_at_idx (by tactic.dec_triv))

end pdiff

namespace glogpdf

def mvn (shape : S) : grad_logpdf [shape, shape] shape
| ⟦μ, σ⟧ x 0     fshape := T.force (T.mvn_grad_logpdf_μ μ σ x) fshape
| ⟦μ, σ⟧ x 1     fshape := T.force (T.mvn_grad_logpdf_σ μ σ x) fshape
| ⟦μ, σ⟧ x (n+2) fshape := T.error "mvn grad_logpdf: index too large"

def mvn_std (shape : S) : grad_logpdf [] shape
| ⟦⟧ x idx fshape := 0

end glogpdf

namespace glogpdf_correct

lemma mvn (shape : S) : grad_logpdf_correct (pdf.mvn shape) (pre.mvn shape) (glogpdf.mvn shape)
| ⟦μ, σ⟧ x 0     ishape H_at_idx H_pre :=
begin
clear mvn,
note H_ishape_eq := H_at_idx^.right,
dsimp [list.dnth] at H_ishape_eq,
subst H_ishape_eq,
dsimp [dvec.update_at, dvec.get],
simp,
assert H : ∀ (θ₀ : T ishape), T.log (pdf.mvn ishape ⟦θ₀, σ⟧ x) = T.mvn_logpdf θ₀ σ x,
{ intro θ₀, simp [pdf.mvn, T.mvn_logpdf_correct θ₀ σ x H_pre] },
rw (funext H), clear H,
erw T.mvn_grad_logpdf_μ_correct _ _ _ H_pre,
simp [glogpdf.mvn, dvec.head2]
end

| ⟦μ, σ⟧ x 1     ishape H_at_idx H_pre :=
begin
clear mvn,
note H_ishape_eq := H_at_idx^.right,
dsimp [list.dnth] at H_ishape_eq,
subst H_ishape_eq,
dsimp [dvec.update_at, dvec.get],
simp,
assert H : ∀ (θ₀ : T ishape), θ₀ > 0 → T.log (pdf.mvn ishape ⟦μ, θ₀⟧ x) = T.mvn_logpdf μ θ₀ x,
{ intros θ₀ H_θ₀, simp [pdf.mvn, T.mvn_logpdf_correct μ θ₀ x H_θ₀] },

erw T.grad_congr_pos _ _ _ H_pre H,
clear H,
erw T.mvn_grad_logpdf_σ_correct _ _ _ H_pre,
simp [glogpdf.mvn, dvec.head2]
end
| ⟦μ, σ⟧ x (n+2) ishape H_at_idx H_pre := false.rec _ (list.at_idx_over H_at_idx (by tactic.dec_triv))

lemma mvn_std (shape : S) : grad_logpdf_correct (pdf.mvn_std shape) (pre.mvn_std shape) (glogpdf.mvn_std shape)
| ⟦⟧ x idx     ishape H_at_idx H_pre := false.rec _ (list.at_idx_over H_at_idx (by tactic.dec_triv))

end glogpdf_correct

namespace pdf_pos

lemma mvn (shape : S) : pdf_positive (pdf.mvn shape) (pre.mvn shape)
| ⟦μ, σ⟧ H_pre y := T.mvn_pdf_pos μ σ H_pre y

lemma mvn_std (shape : S) : pdf_positive (pdf.mvn_std shape) (pre.mvn_std shape)
| ⟦⟧ H_pre y := T.mvn_pdf_pos 0 1 T.one_pos y

end pdf_pos

namespace pdf_int1

lemma mvn (shape : S) : pdf_integrates_to_one (pdf.mvn shape) (pre.mvn shape)
| ⟦μ, σ⟧ H_pre := T.mvn_pdf_int1 μ σ H_pre

lemma mvn_std (shape : S) : pdf_integrates_to_one (pdf.mvn_std shape) (pre.mvn_std shape)
| ⟦⟧ H_pre := T.mvn_pdf_int1 0 1 T.one_pos

end pdf_int1

namespace cont

lemma mvn (shape : S) : continuous (pdf.mvn shape) (pre.mvn shape)
| ⟦μ, σ⟧ x 0     tshape H_at_idx H_pre :=
begin
clear mvn,
note H_ishape_eq := H_at_idx^.right,
dsimp [list.dnth] at H_ishape_eq,
subst H_ishape_eq,
dsimp [dvec.update_at, dvec.get],
simp,
apply T.continuous_mvn_pdf_μ,
exact H_pre
end
| ⟦μ, σ⟧ x 1     tshape H_at_idx H_pre :=
begin
clear mvn,
note H_ishape_eq := H_at_idx^.right,
dsimp [list.dnth] at H_ishape_eq,
subst H_ishape_eq,
dsimp [dvec.update_at, dvec.get],
simp,
apply T.continuous_mvn_pdf_σ,
exact H_pre
end

| ⟦μ, σ⟧ x (n+2) tshape H_at_idx H_pre := false.rec _ (list.at_idx_over H_at_idx (by tactic.dec_triv))

lemma mvn_std (shape : S) : continuous (pdf.mvn_std shape) (pre.mvn_std shape)
| ⟦⟧ x 0     tshape H_at_idx H_pre := false.rec _ (list.at_idx_over H_at_idx (by tactic.dec_triv))

end cont

inductive op : Π (ishapes : list S) (oshape : S), Type
| mvn : ∀ (shape : S), op [shape, shape] shape
| mvn_std : ∀ (shape : S), op [] shape

namespace op

def pdf : Π {ishapes : list S} {oshape : S}, op ishapes oshape → pdf_function ishapes oshape
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.pdf.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.pdf.mvn_std shape

def run : Π {ishapes : list S} {oshape : S}, op ishapes oshape → rng_function ishapes oshape
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.run.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.run.mvn_std shape

def pre : Π {ishapes : list S} {oshape : S}, op ishapes oshape → precondition ishapes
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.pre.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.pre.mvn_std shape

def pdf_cdiff : Π {ishapes : list S} {oshape : S} (p : op ishapes oshape), pdf_cdiff p^.pdf p^.pre
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.pdiff.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.pdiff.mvn_std shape

def glogpdf : Π {ishapes : list S} {oshape : S}, op ishapes oshape → grad_logpdf ishapes oshape
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.glogpdf.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.glogpdf.mvn_std shape

def glogpdf_correct : Π {ishapes : list S} {oshape : S} (p : op ishapes oshape), grad_logpdf_correct p^.pdf p^.pre p^.glogpdf
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.glogpdf_correct.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.glogpdf_correct.mvn_std shape

def pdf_pos : Π {ishapes : list S} {oshape : S} (p : op ishapes oshape), pdf_positive p^.pdf p^.pre
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.pdf_pos.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.pdf_pos.mvn_std shape

def pdf_int1 : Π {ishapes : list S} {oshape : S} (p : op ishapes oshape), pdf_integrates_to_one p^.pdf p^.pre
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.pdf_int1.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.pdf_int1.mvn_std shape

def cont : Π {ishapes : list S} {oshape : S} (p : op ishapes oshape), continuous p^.pdf p^.pre
| [shape, .(shape)] .(shape) (mvn .(shape)) := _root_.certigrad.rand.cont.mvn shape
| []               shape (mvn_std .(shape)) := _root_.certigrad.rand.cont.mvn_std shape

end op
end rand

lemma mvn_pre {shape : S} (xs : dvec T [shape, shape]) :
  (rand.op.mvn shape)^.pre xs = (dvec.head2 xs > 0) := rfl

end certigrad


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.of_associative
import algebra.ring_quot
import linear_algebra.tensor_algebra.basic

/-!
# Universal enveloping algebra

Given a commutative ring `R` and a Lie algebra `L` over `R`, we construct the universal
enveloping algebra of `L`, together with its universal property.

## Main definitions

  * `universal_enveloping_algebra`: the universal enveloping algebra, endowed with an
    `R`-algebra structure.
  * `universal_enveloping_algebra.ι`: the Lie algebra morphism from `L` to its universal
    enveloping algebra.
  * `universal_enveloping_algebra.lift`: given an associative algebra `A`, together with a Lie
    algebra morphism `f : L →ₗ⁅R⁆ A`, `lift R L f : universal_enveloping_algebra R L →ₐ[R] A` is the
    unique morphism of algebras through which `f` factors.
  * `universal_enveloping_algebra.ι_comp_lift`: states that the lift of a morphism is indeed part
    of a factorisation.
  * `universal_enveloping_algebra.lift_unique`: states that lifts of morphisms are indeed unique.
  * `universal_enveloping_algebra.hom_ext`: a restatement of `lift_unique` as an extensionality
    lemma.

## Tags

lie algebra, universal enveloping algebra, tensor algebra
-/

universes u₁ u₂ u₃

variables (R : Type u₁) (L : Type u₂)
variables [comm_ring R] [lie_ring L] [lie_algebra R L]

local notation `ιₜ` := tensor_algebra.ι R

namespace universal_enveloping_algebra

/-- The quotient by the ideal generated by this relation is the universal enveloping algebra.

Note that we have avoided using the more natural expression:
| lie_compat (x y : L) : rel (ιₜ ⁅x, y⁆) ⁅ιₜ x, ιₜ y⁆
so that our construction needs only the semiring structure of the tensor algebra. -/
inductive rel : tensor_algebra R L → tensor_algebra R L → Prop
| lie_compat (x y : L) : rel (ιₜ ⁅x, y⁆ + (ιₜ y) * (ιₜ x)) ((ιₜ x) * (ιₜ y))

end universal_enveloping_algebra

/-- The universal enveloping algebra of a Lie algebra. -/
@[derive [inhabited, ring, algebra R]]
def universal_enveloping_algebra := ring_quot (universal_enveloping_algebra.rel R L)

namespace universal_enveloping_algebra

/-- The quotient map from the tensor algebra to the universal enveloping algebra as a morphism of
associative algebras. -/
def mk_alg_hom : tensor_algebra R L →ₐ[R] universal_enveloping_algebra R L :=
ring_quot.mk_alg_hom R (rel R L)

variables {L}

/-- The natural Lie algebra morphism from a Lie algebra to its universal enveloping algebra. -/
def ι : L →ₗ⁅R⁆ universal_enveloping_algebra R L :=
{ map_lie'   := λ x y, by
  { suffices : mk_alg_hom R L (ιₜ ⁅x, y⁆ + (ιₜ y) * (ιₜ x)) = mk_alg_hom R L ((ιₜ x) * (ιₜ y)),
    { rw alg_hom.map_mul at this, simp [lie_ring.of_associative_ring_bracket, ← this], },
    exact ring_quot.mk_alg_hom_rel _ (rel.lie_compat x y), },
  ..(mk_alg_hom R L).to_linear_map.comp ιₜ }

variables {A : Type u₃} [ring A] [algebra R A] (f : L →ₗ⁅R⁆ A)

/-- The universal property of the universal enveloping algebra: Lie algebra morphisms into
associative algebras lift to associative algebra morphisms from the universal enveloping algebra. -/
def lift : (L →ₗ⁅R⁆ A) ≃ (universal_enveloping_algebra R L →ₐ[R] A) :=
{ to_fun := λ f,
    ring_quot.lift_alg_hom R ⟨tensor_algebra.lift R (f : L →ₗ[R] A),
    begin
      intros a b h, induction h with x y,
      simp only [lie_ring.of_associative_ring_bracket,
        map_add, tensor_algebra.lift_ι_apply, lie_hom.coe_to_linear_map, lie_hom.map_lie,
        map_mul, sub_add_cancel],
    end⟩,
  inv_fun := λ F, (F : universal_enveloping_algebra R L →ₗ⁅R⁆ A).comp (ι R),
  left_inv := λ f, by { ext, simp only [ι, mk_alg_hom,
    tensor_algebra.lift_ι_apply, lie_hom.coe_to_linear_map, linear_map.to_fun_eq_coe,
    linear_map.coe_comp, lie_hom.coe_comp, alg_hom.coe_to_lie_hom, lie_hom.coe_mk,
    function.comp_app, alg_hom.to_linear_map_apply, ring_quot.lift_alg_hom_mk_alg_hom_apply], },
  right_inv := λ F, by { ext, simp only [ι, mk_alg_hom,
    tensor_algebra.lift_ι_apply, lie_hom.coe_to_linear_map, linear_map.to_fun_eq_coe,
    linear_map.coe_comp, lie_hom.coe_linear_map_comp, alg_hom.comp_to_linear_map,
    function.comp_app, alg_hom.to_linear_map_apply, ring_quot.lift_alg_hom_mk_alg_hom_apply,
    alg_hom.coe_to_lie_hom, lie_hom.coe_mk], } }

@[simp] lemma lift_symm_apply (F : universal_enveloping_algebra R L →ₐ[R] A) :
  (lift R).symm F = (F : universal_enveloping_algebra R L →ₗ⁅R⁆ A).comp (ι R) :=
rfl

@[simp] lemma ι_comp_lift : (lift R f) ∘ (ι R) = f :=
funext $ lie_hom.ext_iff.mp $ (lift R).symm_apply_apply f

@[simp] lemma lift_ι_apply (x : L) : lift R f (ι R x) = f x :=
by rw [←function.comp_apply (lift R f) (ι R) x, ι_comp_lift]

lemma lift_unique (g : universal_enveloping_algebra R L →ₐ[R] A) :
  g ∘ (ι R) = f ↔ g = lift R f :=
begin
  refine iff.trans _ (lift R).symm_apply_eq,
  split; {intro h, ext, simp [←h] },
end

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma hom_ext {g₁ g₂ : universal_enveloping_algebra R L →ₐ[R] A}
  (h : (g₁ : universal_enveloping_algebra R L →ₗ⁅R⁆ A).comp (ι R) =
       (g₂ : universal_enveloping_algebra R L →ₗ⁅R⁆ A).comp (ι R)) :
  g₁ = g₂ :=
have h' : (lift R).symm g₁ = (lift R).symm g₂, { ext, simp [h], },
(lift R).symm.injective h'

end universal_enveloping_algebra


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl

! This file was ported from Lean 3 source module topology.algebra.group_completion
! leanprover-community/mathlib commit a148d797a1094ab554ad4183a4ad6f130358ef64
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Algebra.UniformGroup
import Mathlib.Topology.Algebra.UniformMulAction
import Mathlib.Topology.UniformSpace.Completion

/-!
# Completion of topological groups:

This files endows the completion of a topological abelian group with a group structure.
More precisely the instance `UniformSpace.Completion.addGroup` builds an abelian group structure
on the completion of an abelian group endowed with a compatible uniform structure.
Then the instance `UniformSpace.Completion.uniformAddGroup` proves this group structure is
compatible with the completed uniform structure. The compatibility condition is `UniformAddGroup`.

## Main declarations:

Beyond the instances explained above (that don't have to be explicitly invoked),
the main constructions deal with continuous group morphisms.

* `AddMonoidHom.extension`: extends a continuous group morphism from `G`
  to a complete separated group `H` to `Completion G`.
* `AddMonoidHom.completion`: promotes a continuous group morphism
  from `G` to `H` into a continuous group morphism
  from `Completion G` to `Completion H`.
-/

noncomputable section

variable {M R α β : Type _}

section Group

open UniformSpace CauchyFilter Filter Set

variable [UniformSpace α]

instance [Zero α] : Zero (Completion α) :=
  ⟨(0 : α)⟩

instance [Neg α] : Neg (Completion α) :=
  ⟨Completion.map (fun a ↦ -a : α → α)⟩

instance [Add α] : Add (Completion α) :=
  ⟨Completion.map₂ (· + ·)⟩

instance [Sub α] : Sub (Completion α) :=
  ⟨Completion.map₂ Sub.sub⟩

@[norm_cast]
theorem UniformSpace.Completion.coe_zero [Zero α] : ((0 : α) : Completion α) = 0 :=
  rfl
#align uniform_space.completion.coe_zero UniformSpace.Completion.coe_zero

end Group

namespace UniformSpace.Completion

open UniformSpace

section Zero

instance [UniformSpace α] [MonoidWithZero M] [Zero α] [MulActionWithZero M α]
    [UniformContinuousConstSMul M α] : MulActionWithZero M (Completion α) :=
  { (inferInstance : MulAction M $ Completion α) with
    smul := (· • ·)
    smul_zero := fun r ↦ by rw [← coe_zero, ← coe_smul, MulActionWithZero.smul_zero r]
    zero_smul :=
      ext' (continuous_const_smul _) continuous_const fun a ↦ by
        rw [← coe_smul, zero_smul, coe_zero] }

end Zero

section UniformAddGroup

variable [UniformSpace α] [AddGroup α] [UniformAddGroup α]

@[norm_cast]
theorem coe_neg (a : α) : ((-a : α) : Completion α) = -a :=
  (map_coe uniformContinuous_neg a).symm
#align uniform_space.completion.coe_neg UniformSpace.Completion.coe_neg

@[norm_cast]
theorem coe_sub (a b : α) : ((a - b : α) : Completion α) = a - b :=
  (map₂_coe_coe a b Sub.sub uniformContinuous_sub).symm
#align uniform_space.completion.coe_sub UniformSpace.Completion.coe_sub

@[norm_cast]
theorem coe_add (a b : α) : ((a + b : α) : Completion α) = a + b :=
  (map₂_coe_coe a b (· + ·) uniformContinuous_add).symm
#align uniform_space.completion.coe_add UniformSpace.Completion.coe_add

instance : AddMonoid (Completion α) :=
  { (inferInstance : Zero $ Completion α),
    (inferInstance : Add $ Completion α) with
    zero_add := fun a ↦
      Completion.induction_on a
        (isClosed_eq (continuous_map₂ continuous_const continuous_id) continuous_id) fun a ↦
        show 0 + (a : Completion α) = a by rw [← coe_zero, ← coe_add, zero_add]
    add_zero := fun a ↦
      Completion.induction_on a
        (isClosed_eq (continuous_map₂ continuous_id continuous_const) continuous_id) fun a ↦
        show (a : Completion α) + 0 = a by rw [← coe_zero, ← coe_add, add_zero]
    add_assoc := fun a b c ↦
      Completion.induction_on₃ a b c
        (isClosed_eq
          (continuous_map₂ (continuous_map₂ continuous_fst (continuous_fst.comp continuous_snd))
            (continuous_snd.comp continuous_snd))
          (continuous_map₂ continuous_fst
            (continuous_map₂ (continuous_fst.comp continuous_snd)
              (continuous_snd.comp continuous_snd))))
        fun a b c ↦
        show (a : Completion α) + b + c = a + (b + c) by repeat' rw_mod_cast [add_assoc]
    nsmul := (· • ·)
    nsmul_zero := fun a ↦
      Completion.induction_on a (isClosed_eq continuous_map continuous_const) fun a ↦
        show 0 • (a : Completion α) = 0 by rw [← coe_smul, ← coe_zero, zero_smul]
    nsmul_succ := fun n a ↦
      Completion.induction_on a
        (isClosed_eq continuous_map <| continuous_map₂ continuous_id continuous_map) fun a ↦
        show (n + 1) • (a : Completion α) = (a : Completion α) + n • (a : Completion α) by
          rw [← coe_smul, succ_nsmul, coe_add, coe_smul] }

instance : SubNegMonoid (Completion α) :=
  { (inferInstance : AddMonoid $ Completion α),
    (inferInstance : Neg $ Completion α),
    (inferInstance : Sub $ Completion α) with
    sub_eq_add_neg := fun a b ↦
      Completion.induction_on₂ a b
        (isClosed_eq (continuous_map₂ continuous_fst continuous_snd)
          (continuous_map₂ continuous_fst (Completion.continuous_map.comp continuous_snd)))
        fun a b ↦ by exact_mod_cast congr_arg ((↑) : α → Completion α) (sub_eq_add_neg a b)
    zsmul := (· • ·)
    zsmul_zero' := fun a ↦
      Completion.induction_on a (isClosed_eq continuous_map continuous_const) fun a ↦
        show (0 : ℤ) • (a : Completion α) = 0 by rw [← coe_smul, ← coe_zero, zero_smul]
    zsmul_succ' := fun n a ↦
      Completion.induction_on a
        (isClosed_eq continuous_map <| continuous_map₂ continuous_id continuous_map) fun a ↦
          show Int.ofNat n.succ • (a : Completion α) = _ by
            rw [← coe_smul, show Int.ofNat n.succ • a = a + Int.ofNat n • a from
              SubNegMonoid.zsmul_succ' n a, coe_add, coe_smul]
    zsmul_neg' := fun n a ↦
      Completion.induction_on a
        (isClosed_eq continuous_map <| Completion.continuous_map.comp continuous_map) fun a ↦
          show (Int.negSucc n) • (a : Completion α) = _ by
            rw [← coe_smul, show (Int.negSucc n) • a = -((n.succ : ℤ) • a) from
              SubNegMonoid.zsmul_neg' n a, coe_neg, coe_smul] }

instance addGroup : AddGroup (Completion α) :=
  { (inferInstance : SubNegMonoid $ Completion α) with
    add_left_neg := fun a ↦
      Completion.induction_on a
        (isClosed_eq (continuous_map₂ Completion.continuous_map continuous_id) continuous_const)
        fun a ↦
        show -(a : Completion α) + a = 0
          by
          rw_mod_cast [add_left_neg]
          rfl }

instance uniformAddGroup : UniformAddGroup (Completion α) :=
  ⟨uniformContinuous_map₂ Sub.sub⟩

instance {M} [Monoid M] [DistribMulAction M α] [UniformContinuousConstSMul M α] :
    DistribMulAction M (Completion α) :=
  { (inferInstance : MulAction M $ Completion α) with
    smul := (· • ·)
    smul_add := fun r x y ↦
      induction_on₂ x y
        (isClosed_eq ((continuous_fst.add continuous_snd).const_smul _)
          ((continuous_fst.const_smul _).add (continuous_snd.const_smul _)))
        fun a b ↦ by simp only [← coe_add, ← coe_smul, smul_add]
    smul_zero := fun r ↦ by rw [← coe_zero, ← coe_smul, smul_zero r] }

/-- The map from a group to its completion as a group hom. -/
@[simps]
def toCompl : α →+ Completion α where
  toFun := (↑)
  map_add' := coe_add
  map_zero' := coe_zero
#align uniform_space.completion.to_compl UniformSpace.Completion.toCompl

theorem continuous_toCompl : Continuous (toCompl : α → Completion α) :=
  continuous_coe α
#align uniform_space.completion.continuous_to_compl UniformSpace.Completion.continuous_toCompl

variable (α)

theorem denseInducing_toCompl : DenseInducing (toCompl : α → Completion α) :=
  denseInducing_coe
#align uniform_space.completion.dense_inducing_to_compl UniformSpace.Completion.denseInducing_toCompl

variable {α}

end UniformAddGroup

section UniformAddCommGroup

variable [UniformSpace α] [AddCommGroup α] [UniformAddGroup α]

instance : AddCommGroup (Completion α) :=
  { (inferInstance : AddGroup $ Completion α) with
    add_comm := fun a b ↦
      Completion.induction_on₂ a b
        (isClosed_eq (continuous_map₂ continuous_fst continuous_snd)
          (continuous_map₂ continuous_snd continuous_fst))
        fun x y ↦ by
        change (x : Completion α) + ↑y = ↑y + ↑x
        rw [← coe_add, ← coe_add, add_comm] }

instance [Semiring R] [Module R α] [UniformContinuousConstSMul R α] : Module R (Completion α) :=
  { (inferInstance : DistribMulAction R $ Completion α),
    (inferInstance : MulActionWithZero R $ Completion α) with
    smul := (· • ·)
    add_smul := fun a b ↦
      ext' (continuous_const_smul _) ((continuous_const_smul _).add (continuous_const_smul _))
        fun x ↦ by
          rw [← coe_smul, add_smul, coe_add, coe_smul, coe_smul] }

end UniformAddCommGroup

end UniformSpace.Completion

section AddMonoidHom

variable [UniformSpace α] [AddGroup α] [UniformAddGroup α] [UniformSpace β] [AddGroup β]
  [UniformAddGroup β]

open UniformSpace UniformSpace.Completion

/-- Extension to the completion of a continuous group hom. -/
def AddMonoidHom.extension [CompleteSpace β] [SeparatedSpace β] (f : α →+ β) (hf : Continuous f) :
    Completion α →+ β :=
  have hf : UniformContinuous f := uniformContinuous_addMonoidHom_of_continuous hf
  { toFun := Completion.extension f
    map_zero' := by rw [← coe_zero, extension_coe hf, f.map_zero]
    map_add' := fun a b ↦
      Completion.induction_on₂ a b
        (isClosed_eq (continuous_extension.comp continuous_add)
          ((continuous_extension.comp continuous_fst).add
            (continuous_extension.comp continuous_snd)))
        fun a b ↦
        show Completion.extension f _ = Completion.extension f _ + Completion.extension f _ by
        rw_mod_cast [extension_coe hf, extension_coe hf, extension_coe hf, f.map_add] }
#align add_monoid_hom.extension AddMonoidHom.extension

theorem AddMonoidHom.extension_coe [CompleteSpace β] [SeparatedSpace β] (f : α →+ β)
    (hf : Continuous f) (a : α) : f.extension hf a = f a :=
  UniformSpace.Completion.extension_coe (uniformContinuous_addMonoidHom_of_continuous hf) a
#align add_monoid_hom.extension_coe AddMonoidHom.extension_coe

@[continuity]
theorem AddMonoidHom.continuous_extension [CompleteSpace β] [SeparatedSpace β] (f : α →+ β)
    (hf : Continuous f) : Continuous (f.extension hf) :=
  UniformSpace.Completion.continuous_extension
#align add_monoid_hom.continuous_extension AddMonoidHom.continuous_extension

/-- Completion of a continuous group hom, as a group hom. -/
def AddMonoidHom.completion (f : α →+ β) (hf : Continuous f) : Completion α →+ Completion β :=
  (toCompl.comp f).extension (continuous_toCompl.comp hf)
#align add_monoid_hom.completion AddMonoidHom.completion

@[continuity]
theorem AddMonoidHom.continuous_completion (f : α →+ β) (hf : Continuous f) :
    Continuous (AddMonoidHom.completion f hf : Completion α → Completion β) :=
  continuous_map
#align add_monoid_hom.continuous_completion AddMonoidHom.continuous_completion

theorem AddMonoidHom.completion_coe (f : α →+ β) (hf : Continuous f) (a : α) :
    AddMonoidHom.completion f hf a = f a :=
  map_coe (uniformContinuous_addMonoidHom_of_continuous hf) a
#align add_monoid_hom.completion_coe AddMonoidHom.completion_coe

theorem AddMonoidHom.completion_zero :
    AddMonoidHom.completion (0 : α →+ β) continuous_const = 0 := by
  ext x
  refine Completion.induction_on x ?_ ?_
  · apply isClosed_eq (AddMonoidHom.continuous_completion (0 : α →+ β) continuous_const)
    simp [continuous_const]
  · intro a
    simp [(0 : α →+ β).completion_coe continuous_const, coe_zero]
#align add_monoid_hom.completion_zero AddMonoidHom.completion_zero

theorem AddMonoidHom.completion_add {γ : Type _} [AddCommGroup γ] [UniformSpace γ]
    [UniformAddGroup γ] (f g : α →+ γ) (hf : Continuous f) (hg : Continuous g) :
    AddMonoidHom.completion (f + g) (hf.add hg) =
    AddMonoidHom.completion f hf + AddMonoidHom.completion g hg := by
  have hfg := hf.add hg
  ext x
  refine Completion.induction_on x ?_ ?_
  · exact isClosed_eq ((f + g).continuous_completion hfg)
      ((f.continuous_completion hf).add (g.continuous_completion hg))
  · intro a
    simp [(f + g).completion_coe hfg, coe_add, f.completion_coe hf, g.completion_coe hg]
#align add_monoid_hom.completion_add AddMonoidHom.completion_add

end AddMonoidHom


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

/-!
# The M construction as a multivariate polynomial functor.

M types are potentially infinite tree-like structures. They are defined
as the greatest fixpoint of a polynomial functor.

## Main definitions

 * `M.mk`     - constructor
 * `M.dest`   - destructor
 * `M.corec`  - corecursor: useful for formulating infinite, productive computations
 * `M.bisim`  - bisimulation: proof technique to show the equality of infinite objects

## Implementation notes

Dual view of M-types:

 * `Mp`: polynomial functor
 * `M`: greatest fixed point of a polynomial functor

Specifically, we define the polynomial functor `Mp` as:

 * A := a possibly infinite tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   from the root of `t` to any given node.

As a result `Mp.obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

The difference with the polynomial functor of an initial algebra is
that `A` is a possibly infinite tree.

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

universe u

open_locale mvfunctor

namespace mvpfunctor
open typevec

variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- A path from the root of a tree to one of its node -/
inductive M.path : P.last.M → fin2 n → Type u
| root (x : P.last.M) (a : P.A) (f : P.last.B a → P.last.M) (h : pfunctor.M.dest x = ⟨a, f⟩)
       (i : fin2 n) (c : P.drop.B a i) :
    M.path x i
| child (x : P.last.M) (a : P.A) (f : P.last.B a → P.last.M) (h : pfunctor.M.dest x = ⟨a, f⟩)
      (j : P.last.B a) (i : fin2 n) (c : M.path (f j) i) :
    M.path x i

instance M.path.inhabited (x : P.last.M) {i} [inhabited (P.drop.B x.head i)] :
  inhabited (M.path P x i) :=
⟨ M.path.root _ (pfunctor.M.head x) (pfunctor.M.children x)
  (pfunctor.M.cases_on' x $
    by intros; simp [pfunctor.M.dest_mk]; ext; rw pfunctor.M.children_mk; refl) _
    (default _) ⟩

/-- Polynomial functor of the M-type of `P`. `A` is a data-less
possibly infinite tree whereas, for a given `a : A`, `B a` is a valid
path in tree `a` so that `Wp.obj α` is made of a tree and a function
from its valid paths to the values it contains -/
def Mp : mvpfunctor n :=
{ A := P.last.M, B := M.path P }

/-- `n`-ary M-type for `P` -/
def M (α : typevec n) : Type* := P.Mp.obj α

instance mvfunctor_M : mvfunctor P.M := by delta M; apply_instance
instance inhabited_M {α : typevec _}
  [I : inhabited P.A]
  [Π (i : fin2 n), inhabited (α i)] :
  inhabited (P.M α) :=
@obj.inhabited _ (Mp P) _ (@pfunctor.M.inhabited P.last I) _

/-- construct through corecursion the shape of an M-type
without its contents -/
def M.corec_shape {β : Type u}
    (g₀ : β → P.A)
    (g₂ : Π b : β, P.last.B (g₀ b) → β) :
  β → P.last.M :=
pfunctor.M.corec (λ b, ⟨g₀ b, g₂ b⟩)

/-- Proof of type equality as an arrow -/
def cast_dropB {a a' : P.A} (h : a = a') : P.drop.B a ⟹ P.drop.B a' :=
λ i b, eq.rec_on h b

/-- Proof of type equality as a function -/
def cast_lastB {a a' : P.A} (h : a = a') : P.last.B a → P.last.B a' :=
λ b, eq.rec_on h b

/-- Using corecursion, construct the contents of an M-type -/
def M.corec_contents {α : typevec.{u} n} {β : Type u}
    (g₀ : β → P.A)
    (g₁ : Π b : β, P.drop.B (g₀ b) ⟹ α)
    (g₂ : Π b : β, P.last.B (g₀ b) → β) :
  Π x b, x = M.corec_shape P g₀ g₂ b → M.path P x ⟹ α
| ._ b h ._ (M.path.root x a f h' i c)    :=
  have a = g₀ b,
    by { rw [h, M.corec_shape, pfunctor.M.dest_corec] at h', cases h', refl },
  g₁ b i (P.cast_dropB this i c)
| ._ b h ._ (M.path.child x a f h' j i c) :=
  have h₀ : a = g₀ b,
    by { rw [h, M.corec_shape, pfunctor.M.dest_corec] at h', cases h', refl },
  have h₁ : f j = M.corec_shape P g₀ g₂ (g₂ b (cast_lastB P h₀ j)),
    by { rw [h, M.corec_shape, pfunctor.M.dest_corec] at h', cases h', refl },
  M.corec_contents (f j) (g₂ b (P.cast_lastB h₀ j)) h₁ i c

/-- Corecursor for M-type of `P` -/
def M.corec' {α : typevec n} {β : Type u}
    (g₀ : β → P.A)
    (g₁ : Π b : β, P.drop.B (g₀ b) ⟹ α)
    (g₂ : Π b : β, P.last.B (g₀ b) → β) :
  β → P.M α :=
λ b, ⟨M.corec_shape P g₀ g₂ b, M.corec_contents P g₀ g₁ g₂ _ _ rfl⟩

/-- Corecursor for M-type of `P` -/
def M.corec {α : typevec n} {β : Type u} (g : β → P.obj (α.append1 β)) :
  β → P.M α :=
M.corec' P
  (λ b, (g b).fst)
  (λ b, drop_fun (g b).snd)
  (λ b, last_fun (g b).snd)

/-- Implementation of destructor for M-type of `P` -/
def M.path_dest_left {α : typevec n} {x : P.last.M}
    {a : P.A} {f : P.last.B a → P.last.M} (h : pfunctor.M.dest x = ⟨a, f⟩)
    (f' : M.path P x ⟹ α) :
  P.drop.B a ⟹ α :=
λ i c, f' i (M.path.root x a f h i c)

/-- Implementation of destructor for M-type of `P` -/
def M.path_dest_right {α : typevec n} {x : P.last.M}
    {a : P.A} {f : P.last.B a → P.last.M} (h : pfunctor.M.dest x = ⟨a, f⟩)
    (f' : M.path P x ⟹ α) :
  Π j : P.last.B a, M.path P (f j) ⟹ α :=
λ j i c, f' i (M.path.child x a f h j i c)

/-- Destructor for M-type of `P` -/
def M.dest' {α : typevec n} {x : P.last.M}
    {a : P.A} {f : P.last.B a → P.last.M} (h : pfunctor.M.dest x = ⟨a, f⟩)
    (f' : M.path P x ⟹ α) :
  P.obj (α.append1 (P.M α)) :=
⟨a, split_fun (M.path_dest_left P h f') (λ x, ⟨f x, M.path_dest_right P h f' x⟩)⟩

/-- Destructor for M-types -/
def M.dest {α : typevec n} (x : P.M α) : P.obj (α ::: P.M α) :=
M.dest' P (sigma.eta $ pfunctor.M.dest x.fst).symm x.snd

/-- Constructor for M-types -/
def M.mk  {α : typevec n} : P.obj (α.append1 (P.M α)) → P.M α :=
M.corec _ (λ i, append_fun id (M.dest P) <$$> i)

theorem M.dest'_eq_dest' {α : typevec n} {x : P.last.M}
    {a₁ : P.A} {f₁ : P.last.B a₁ → P.last.M} (h₁ : pfunctor.M.dest x = ⟨a₁, f₁⟩)
    {a₂ : P.A} {f₂ : P.last.B a₂ → P.last.M} (h₂ : pfunctor.M.dest x = ⟨a₂, f₂⟩)
    (f' : M.path P x ⟹ α) : M.dest' P h₁ f' = M.dest' P h₂ f' :=
by cases h₁.symm.trans h₂; refl

theorem M.dest_eq_dest' {α : typevec n} {x : P.last.M}
    {a : P.A} {f : P.last.B a → P.last.M} (h : pfunctor.M.dest x = ⟨a, f⟩)
    (f' : M.path P x ⟹ α) : M.dest P ⟨x, f'⟩ = M.dest' P h f' :=
M.dest'_eq_dest' _ _ _ _

theorem M.dest_corec' {α : typevec.{u} n} {β : Type u}
    (g₀ : β → P.A)
    (g₁ : Π b : β, P.drop.B (g₀ b) ⟹ α)
    (g₂ : Π b : β, P.last.B (g₀ b) → β)
    (x : β) :
  M.dest P (M.corec' P g₀ g₁ g₂ x)  =
    ⟨g₀ x, split_fun (g₁ x) (M.corec' P g₀ g₁ g₂ ∘ (g₂ x))⟩ :=
rfl

theorem M.dest_corec {α : typevec n} {β : Type u} (g : β → P.obj (α.append1 β)) (x : β) :
  M.dest P (M.corec P g x) = append_fun id (M.corec P g) <$$> g x :=
begin
  transitivity, apply M.dest_corec',
  cases g x with a f, dsimp,
  rw mvpfunctor.map_eq, congr,
  conv { to_rhs, rw [←split_drop_fun_last_fun f, append_fun_comp_split_fun] },
  refl
end

lemma M.bisim_lemma {α : typevec n}
  {a₁ : (Mp P).A} {f₁ : (Mp P).B a₁ ⟹ α}
  {a' : P.A} {f' : (P.B a').drop ⟹ α} {f₁' : (P.B a').last → M P α}
  (e₁ : M.dest P ⟨a₁, f₁⟩ = ⟨a', split_fun f' f₁'⟩) :
  ∃ g₁' (e₁' : pfunctor.M.dest a₁ = ⟨a', g₁'⟩),
    f' = M.path_dest_left P e₁' f₁ ∧
    f₁' = λ (x : (last P).B a'),
      ⟨g₁' x, M.path_dest_right P e₁' f₁ x⟩ :=
begin
  generalize_hyp ef : @split_fun n _ (append1 α (M P α)) f' f₁' = ff at e₁,
  cases e₁' : pfunctor.M.dest a₁ with a₁' g₁',
  rw M.dest_eq_dest' _ e₁' at e₁,
  cases e₁, exact ⟨_, e₁', split_fun_inj ef⟩,
end

theorem M.bisim {α : typevec n} (R : P.M α → P.M α → Prop)
  (h : ∀ x y, R x y → ∃ a f f₁ f₂,
    M.dest P x = ⟨a, split_fun f f₁⟩ ∧
    M.dest P y = ⟨a, split_fun f f₂⟩ ∧
    ∀ i, R (f₁ i) (f₂ i))
  (x y) (r : R x y) : x = y :=
begin
  cases x with a₁ f₁,
  cases y with a₂ f₂,
  dsimp [Mp] at *,
  have : a₁ = a₂, {
    refine pfunctor.M.bisim
      (λ a₁ a₂, ∃ x y, R x y ∧ x.1 = a₁ ∧ y.1 = a₂) _ _ _
      ⟨⟨a₁, f₁⟩, ⟨a₂, f₂⟩, r, rfl, rfl⟩,
    rintro _ _ ⟨⟨a₁, f₁⟩, ⟨a₂, f₂⟩, r, rfl, rfl⟩,
    rcases h _ _ r with ⟨a', f', f₁', f₂', e₁, e₂, h'⟩,
    rcases M.bisim_lemma P e₁ with ⟨g₁', e₁', rfl, rfl⟩,
    rcases M.bisim_lemma P e₂ with ⟨g₂', e₂', _, rfl⟩,
    rw [e₁', e₂'],
    exact ⟨_, _, _, rfl, rfl, λ b, ⟨_, _, h' b, rfl, rfl⟩⟩ },
  subst this, congr' with i p,
  induction p with x a f h' i c x a f h' i c p IH generalizing f₁ f₂;
  try {
    rcases h _ _ r with ⟨a', f', f₁', f₂', e₁, e₂, h''⟩,
    rcases M.bisim_lemma P e₁ with ⟨g₁', e₁', rfl, rfl⟩,
    rcases M.bisim_lemma P e₂ with ⟨g₂', e₂', e₃, rfl⟩,
    cases h'.symm.trans e₁',
    cases h'.symm.trans e₂' },
  { exact (congr_fun (congr_fun e₃ i) c : _) },
  { exact IH _ _ (h'' _) }
end

theorem M.bisim₀ {α : typevec n} (R : P.M α → P.M α → Prop)
  (h₀ : equivalence R)
  (h : ∀ x y, R x y →
    (id ::: quot.mk R) <$$> M.dest _ x = (id ::: quot.mk R) <$$> M.dest _ y)
  (x y) (r : R x y) : x = y :=
begin
  apply M.bisim P R _ _ _ r, clear r x y,
  introv Hr, specialize h _ _ Hr, clear Hr,
  rcases M.dest P x with ⟨ax,fx⟩, rcases M.dest P y with ⟨ay,fy⟩,
  intro h, rw [map_eq,map_eq] at h, injection h with h₀ h₁, subst ay,
  simp at h₁, clear h,
  have Hdrop : drop_fun fx = drop_fun fy,
  { replace h₁ := congr_arg drop_fun h₁,
    simpa using h₁, },
  existsi [ax,drop_fun fx,last_fun fx,last_fun fy],
  rw [split_drop_fun_last_fun,Hdrop,split_drop_fun_last_fun],
  simp, intro i,
  replace h₁ := congr_fun (congr_fun h₁ fin2.fz) i,
  simp [(⊚),append_fun,split_fun] at h₁,
  replace h₁ := quot.exact _  h₁,
  rw relation.eqv_gen_iff_of_equivalence at h₁,
  exact h₁, exact h₀
end

theorem M.bisim' {α : typevec n} (R : P.M α → P.M α → Prop)
  (h : ∀ x y, R x y →
    (id ::: quot.mk R) <$$> M.dest _ x = (id ::: quot.mk R) <$$> M.dest _ y)
  (x y) (r : R x y) : x = y :=
begin
  have := M.bisim₀ P (eqv_gen R) _ _,
  { solve_by_elim [eqv_gen.rel] },
  { apply eqv_gen.is_equivalence },
  { clear r x y, introv Hr,
    have : ∀ x y, R x y → eqv_gen R x y := @eqv_gen.rel _ R,
    induction Hr,
    { rw ← quot.factor_mk_eq R (eqv_gen R) this,
      rwa [append_fun_comp_id,← mvfunctor.map_map,← mvfunctor.map_map,h] },
    all_goals { cc } }
end

theorem M.dest_map {α β : typevec n} (g : α ⟹ β) (x : P.M α) :
  M.dest P (g <$$> x) = append_fun g (λ x, g <$$> x) <$$> M.dest P x :=
begin
  cases x with a f,
  rw map_eq,
  conv { to_rhs, rw [M.dest, M.dest', map_eq, append_fun_comp_split_fun] },
  reflexivity
end

theorem M.map_dest {α β : typevec n} (g : α ::: P.M α ⟹ β ::: P.M β) (x : P.M α)
  (h : ∀ x : P.M α, last_fun g x = (drop_fun g <$$> x : P.M β) ):
  g <$$> M.dest P x = M.dest P (drop_fun g <$$> x) :=
begin
  rw M.dest_map, congr,
  apply eq_of_drop_last_eq; simp,
  ext1, apply h
end

end mvpfunctor


import analysis.topology.continuity
import analysis.topology.topological_space
import analysis.topology.infinite_sum
import analysis.topology.topological_structures
import analysis.topology.uniform_space

universe u

open set filter lattice classical

#print definition set

#check empty
def empty_topology : topological_space empty :=
{
is_open := λ (a : set empty),
true, is_open_univ := begin trivial, end,
is_open_inter := begin intros h1 h2 h3 h4, trivial end,
is_open_sUnion := begin intros h1 h2, trivial end
}
#print univ
#check empty_topology.is_open

#print set

definition is_open_sets {α : Type u} (is_open : set α → Prop) :=
  is_open univ ∧ (∀s t, is_open s → is_open t → is_open (s ∩ t)) ∧ (∀s, (∀t∈s, is_open t) → is_open (⋃₀ s))

definition is_to_top {α : Type u} (is_open : set α → Prop) (H : is_open_sets (is_open)) : topological_space α :=
{ is_open := is_open,
  is_open_univ := H.left,
  is_open_inter := H.right.left,
  is_open_sUnion := H.right.right
}

definition top_to_is {α : Type u} (T : topological_space α) : is_open_sets (T.is_open) :=
⟨T.is_open_univ,T.is_open_inter,T.is_open_sUnion⟩

theorem exercisefoura {α : Type u} {T1_sets T2_sets : set α → Prop} : is_open_sets T1_sets → is_open_sets T2_sets → is_open_sets (λ (a : set α), and (T1_sets a) (T2_sets a) :=
begin
intros H1 H2,
unfold is_open_sets,
split,
exact ⟨H1.left, H2.left⟩,
split,
intros s t H3 H4,
exact ⟨H1.right.left s t H3.left H4.left, H2.right.left s t H3.right H4.right⟩,
intros I H3,
split,
have H4 : ∀ (t : set α), t ∈ I → T1_sets t,
intros A H5,
exact (H3 A H5).left,
exact H1.right.right I H4,
have H4 :  ∀ (t : set α), t ∈ I → T2_sets t,
intros A H5,
exact (H3 A H5).right,
exact H2.right.right I H4,
end

-- We need to use finsets to do this more easily. We can use the functions that turn sets into finsets and back in order to agree with the definition of a topology, which uses sets.
@[derive decidable_eq] inductive zeroonetwo : Type
| zero : zeroonetwo
| one : zeroonetwo
| two : zeroonetwo

open zeroonetwo

instance : fintype zeroonetwo :=
⟨{zero, one, two}, λ x, by cases x; simp⟩

local attribute [instance] fintype.set_fintype

example : ({zero, one} : finset zeroonetwo) ∩ {zero} = {zero} := dec_trivial

def collection_one : finset zeroonetwo  → Prop := λ s, s = ∅ ∨ s = {one, two} ∨ s = {zero, one, two}
def collection_two : finset zeroonetwo → Prop := λ s, s = ∅ ∨ s = {zero, one} ∨ s = {zero, one, two}

def T1 : topological_space zeroonetwo := {
is_open := collection_one,
is_open_univ := begin have : (univ : set zeroonetwo) = {zero, one, two}, apply set.ext, assume x, cases x; simp, rewrite this, unfold collection_one, have obv : {zero, one, two} = {zero, one, two}, trivial, exact or.inr (or.inr obv) end,
is_open_inter := begin intros s t H1 H2, unfold collection_one at H1 H2, cases H1, cases H2, simp *,
 unfold collection_one, cc, cases H2, simp *, unfold collection_one, cc, simp *,
  unfold collection_one, cc, cases H1, cases H2, simp *, unfold collection_one, cc,
   cases H2, simp [*, collection_one], cc, simp [*, collection_one],
    have obv2 : insert two {one} ∩ insert two (insert one {zero}) = insert two {one}, unfold insert, rw inter_eq_self_of_subset_left, assume x : zeroonetwo, finish, exact or.inr (or.inl obv2),
    cases H2, simp [*, collection_one], finish, cases H2, simp[*, collection_one], have obv3 : insert two (insert one {zero}) ∩ insert two {one} = insert two {one}, unfold insert, rw inter_eq_self_of_subset_right, assume x : zeroonetwo, finish, exact or.inr (or.inl obv3),
    simp [*, collection_one], finish, end,
is_open_sUnion := by admit
 }

def T2 : topological_space zeroonetwo := {
    is_open := collection_two,
    is_open_univ := by admit,
    is_open_inter := by admit,
    is_open_sUnion := by admit
}

example : zero ∈ ({zero, one} : set zeroonetwo) := by simp

theorem exercisefourb : ¬ ∀ {α : Type} {T1_sets T2_sets : set α → Prop}, (is_open_sets T1_sets → is_open_sets T2_sets → is_open_sets (λ (a : set α), or (T1_sets a) (T2_sets a)) :=
begin
intro H1,
have is_topology : is_open_sets (λ (a : set zeroonetwo), collection_one a ∨ collection_two a),
exact H1 (top_to_is T1) (top_to_is T2),
unfold is_open_sets at is_topology,
have S : collection_one {one, two},
unfold collection_one, cc,
have T : collection_two {zero, one},
unfold collection_two, cc,
have M : collection_one ({one, two} ∩ {zero, one}) ∨ collection_two ({one, two} ∩ {zero, one}),
exact is_topology.right.left {one,two} {zero, one} (or.inl S) (or.inr T),
have obvious : {one, two} ∩ {zero, one} = {one},
apply set.ext, assume x : zeroonetwo, cases x, finish, split, rw mem_inter_eq one {one,two} {zero, one}, simp, exact mem_singleton _,
simp, finish,
rw obvious at M,
cases M,

end