/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Calle Sönne, Adam Topaz
-/
import topology.separation
import topology.subset_properties
import topology.locally_constant.basic

/-!

# Discrete quotients of a topological space.

This file defines the type of discrete quotients of a topological space,
denoted `discrete_quotient X`. To avoid quantifying over types, we model such
quotients as setoids whose equivalence classes are clopen.

## Definitions
1. `discrete_quotient X` is the type of discrete quotients of `X`.
  It is endowed with a coercion to `Type`, which is defined as the
  quotient associated to the setoid in question, and each such quotient
  is endowed with the discrete topology.
2. Given `S : discrete_quotient X`, the projection `X → S` is denoted
  `S.proj`.
3. When `X` is compact and `S : discrete_quotient X`, the space `S` is
  endowed with a `fintype` instance.

## Order structure
The type `discrete_quotient X` is endowed with an instance of a `semilattice_inf_top`.
The partial ordering `A ≤ B` mathematically means that `B.proj` factors through `A.proj`.
The top element `⊤` is the trivial quotient, meaning that every element of `X` is collapsed
to a point. Given `h : A ≤ B`, the map `A → B` is `discrete_quotient.of_le h`.

## Theorems
The two main results proved in this file are:
1. `discrete_quotient.eq_of_proj_eq` which states that when `X` is compact, t2 and totally
  disconnected, any two elements of `X` agree if their projections in `Q` agree for all
  `Q : discrete_quotient X`.
2. `discrete_quotient.exists_of_compat` which states that when `X` is compact, then any
  system of elements of `Q` as `Q : discrete_quotient X` varies, which is compatible with
  respect to `discrete_quotient.of_le`, must arise from some element of `X`.

## Remarks
The constructions in this file will be used to show that any profinite space is a limit
of finite discrete spaces.
-/

variables (X : Type*) [topological_space X]

/-- The type of discrete quotients of a topological space. -/
@[ext]
structure discrete_quotient :=
(rel : X → X → Prop)
(equiv : equivalence rel)
(clopen : ∀ x, is_clopen (set_of (rel x)))

namespace discrete_quotient

variables {X} (S : discrete_quotient X)

/-- Construct a discrete quotient from a clopen set. -/
def of_clopen {A : set X} (h : is_clopen A) : discrete_quotient X :=
{ rel := λ x y, x ∈ A ∧ y ∈ A ∨ x ∉ A ∧ y ∉ A,
  equiv := ⟨by tauto!, by tauto!, by tauto!⟩,
  clopen := begin
    intros x,
    by_cases hx : x ∈ A,
    { apply is_clopen_union,
      { convert h,
        ext,
        exact ⟨λ i, i.2, λ i, ⟨hx,i⟩⟩ },
      { convert is_clopen_empty,
        tidy } },
    { apply is_clopen_union,
      { convert is_clopen_empty,
        tidy },
      { convert is_clopen_compl h,
        ext,
        exact ⟨λ i, i.2, λ i, ⟨hx, i⟩⟩ } },
  end }

/-- The setoid whose quotient yields the discrete quotient. -/
def setoid : setoid X := ⟨S.rel, S.equiv⟩

instance : has_coe_to_sort (discrete_quotient X) :=
⟨Type*, λ S, quotient S.setoid⟩

instance : topological_space S := ⊥

/-- The projection from `X` to the given discrete quotient. -/
def proj : X → S := quotient.mk'

lemma proj_surjective : function.surjective S.proj := quotient.surjective_quotient_mk'

lemma fiber_eq (x : X) : S.proj ⁻¹' {S.proj x} = set_of (S.rel x) :=
begin
  ext1 y,
  simp only [set.mem_preimage, set.mem_singleton_iff, quotient.eq',
    discrete_quotient.proj.equations._eqn_1, set.mem_set_of_eq],
  exact ⟨λ h, S.symm _ _ h, λ h, S.symm _ _ h⟩,
end

lemma proj_is_locally_constant : is_locally_constant S.proj :=
begin
   rw (is_locally_constant.tfae S.proj).out 0 3,
   intros x,
   rcases S.proj_surjective x with ⟨x,rfl⟩,
   simp [fiber_eq, (S.clopen x).1],
end

lemma proj_continuous : continuous S.proj :=
is_locally_constant.continuous $ proj_is_locally_constant _

lemma fiber_closed (A : set S) : is_closed (S.proj ⁻¹' A) :=
is_closed.preimage S.proj_continuous ⟨trivial⟩

lemma fiber_open (A : set S) : is_open (S.proj ⁻¹' A) :=
is_open.preimage S.proj_continuous trivial

lemma fiber_clopen (A : set S) : is_clopen (S.proj ⁻¹' A) := ⟨fiber_open _ _, fiber_closed _ _⟩

/-- Comap a discrete quotient along a continuous map. -/
def comap {Y : Type*} [topological_space Y] {f : Y → X} (cont : continuous f) :
  discrete_quotient Y :=
{ rel := λ a b, S.rel (f a) (f b),
  equiv := ⟨λ a, S.refl _, λ a b h, S.symm _ _ h, λ a b c h1 h2, S.trans _ _ _ h1 h2⟩,
  clopen := λ y, ⟨is_open.preimage cont (S.clopen _).1, is_closed.preimage cont (S.clopen _).2⟩ }

instance : semilattice_inf_top (discrete_quotient X) :=
{ top := ⟨λ a b, true, ⟨by tauto, by tauto, by tauto⟩, λ _, is_clopen_univ⟩,
  inf := λ A B,
  { rel := λ x y, A.rel x y ∧ B.rel x y,
    equiv := ⟨λ a, ⟨A.refl _,B.refl _⟩, λ a b h, ⟨A.symm _ _ h.1, B.symm _ _ h.2⟩,
      λ a b c h1 h2, ⟨A.trans _ _ _ h1.1 h2.1, B.trans _ _ _ h1.2 h2.2⟩⟩,
    clopen := λ x, is_clopen_inter (A.clopen _) (B.clopen _) },
  le := λ A B, ∀ x y : X, A.rel x y → B.rel x y,
  le_refl := λ a, by tauto,
  le_trans := λ a b c h1 h2, by tauto,
  le_antisymm := λ a b h1 h2, by { ext, tauto },
  inf_le_left := λ a b, by tauto,
  inf_le_right := λ a b, by tauto,
  le_inf := λ a b c h1 h2, by tauto,
  le_top := λ a, by tauto }

instance : inhabited (discrete_quotient X) := ⟨⊤⟩

/-- The map induced by a refinement of a discrete quotient. -/
def of_le {A B : discrete_quotient X} (h : A ≤ B) : A → B :=
λ a, quotient.lift_on' a (λ x, B.proj x) (λ a b i, quotient.sound' (h _ _ i))

lemma of_le_continuous {A B : discrete_quotient X} (h : A ≤ B) :
  continuous (of_le h) := continuous_of_discrete_topology

@[simp]
lemma of_le_proj {A B : discrete_quotient X} (h : A ≤ B) :
  of_le h ∘ A.proj = B.proj := by {ext, exact quotient.sound' (B.refl _)}

@[simp]
lemma of_le_proj_apply {A B : discrete_quotient X} (h : A ≤ B) (x : X) :
  of_le h (A.proj x) = B.proj x := by {change (of_le h ∘ A.proj) x = _, simp}

lemma eq_of_proj_eq [t2_space X] [compact_space X] [disc : totally_disconnected_space X]
  {x y : X} : (∀ Q : discrete_quotient X, Q.proj x = Q.proj y) → x = y :=
begin
  intro h,
  change x ∈ ({y} : set X),
  rw totally_disconnected_space_iff_connected_component_singleton at disc,
  rw [← disc y, connected_component_eq_Inter_clopen],
  rintros U ⟨⟨U, hU1, hU2⟩, rfl⟩,
  replace h : _ ∨ _ := quotient.exact' (h (of_clopen hU1)),
  tauto,
end

lemma fiber_le_of_le {A B : discrete_quotient X} (h : A ≤ B) (a : A) :
  A.proj ⁻¹' {a} ≤ B.proj ⁻¹' {of_le h a} :=
begin
  induction a,
  erw [fiber_eq, fiber_eq],
  tidy,
end

lemma exists_of_compat [compact_space X] (Qs : Π (Q : discrete_quotient X), Q)
  (compat : ∀ (A B : discrete_quotient X) (h : A ≤ B), of_le h (Qs _) = Qs _) :
  ∃ x : X, ∀ Q : discrete_quotient X, Q.proj x = Qs _ :=
begin
  obtain ⟨x,hx⟩ := is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
    (λ (Q : discrete_quotient X), Q.proj ⁻¹' {Qs _}) (λ A B, _) (λ i, _)
    (λ i, is_closed.compact (fiber_closed _ _)) (λ i, fiber_closed _ _),
  { refine ⟨x, λ Q, _⟩,
    specialize hx _ ⟨Q,rfl⟩,
    dsimp at hx,
    rcases proj_surjective _ (Qs Q) with ⟨y,hy⟩,
    rw ← hy at *,
    rw fiber_eq at hx,
    exact quotient.sound' (Q.symm y x hx) },
  { refine ⟨A ⊓ B, λ a ha, _, λ a ha, _⟩,
    { dsimp only,
      erw ← compat (A ⊓ B) A inf_le_left,
      exact fiber_le_of_le _ _ ha },
    { dsimp only,
      erw ← compat (A ⊓ B) B inf_le_right,
      exact fiber_le_of_le _ _ ha } },
  { obtain ⟨x,hx⟩ := i.proj_surjective (Qs i),
    refine ⟨x,_⟩,
    dsimp only,
    rw [← hx, fiber_eq],
    apply i.refl },
end

noncomputable instance [compact_space X] : fintype S :=
begin
  have cond : is_compact (⊤ : set X) := compact_univ,
  rw compact_iff_finite_subcover at cond,
  have h := @cond S (λ s, S.proj ⁻¹' {s}) (λ s, fiber_open _ _)
    (λ x hx, ⟨S.proj ⁻¹' {S.proj x}, ⟨S.proj x, rfl⟩, rfl⟩),
  let T := classical.some h,
  have hT := classical.some_spec h,
  refine ⟨T,λ s, _⟩,
  rcases S.proj_surjective s with ⟨x,rfl⟩,
  rcases hT (by tauto : x ∈ ⊤) with ⟨j, ⟨j,rfl⟩, h1, ⟨hj, rfl⟩, h2⟩,
  dsimp only at h2,
  suffices : S.proj x = j, by rwa this,
  rcases j with ⟨j⟩,
  apply quotient.sound',
  erw fiber_eq at h2,
  exact S.symm _ _ h2
end

end discrete_quotient


/- Propositions as Types -/
namespace prop_as_types
  def Implies (p q : Prop) : Prop := p → q
  #check And -- Prop → Prop → Prop
  #check Or
  #check Implies
  #check Not -- Prop → Prop

  variable (p q r : Prop)
  #check And p q -- Prop
  #check Or (And p r) q -- Prop
  #check implies p q -- Prop

  structure Proof (p : Prop) : Type where
    proof : p
  #check Proof -- Prop → Type

  axiom and_comm (p q : Prop) : Proof (Implies (And p q) (And q p))
  #check and_comm p q

  axiom modus_ponens : (p q : Prop) →  Proof (Implies p q) → Proof p → Proof q
  axiom implies_intro (p q : Prop) : (Proof p → Proof q) → Proof (Implies p q)
end prop_as_types

/- Working with Propositions as Types -/

namespace work_wpt
  variable {p : Prop} {q : Prop}
  theorem t1 : p → q → p :=
    fun hp : p =>
    fun hq : q =>
    show p from hp
  #print t1

  theorem t1_ (hp : p) (hq : q) : p := show p from hp
  #print t1_

  axiom hp : p
  theorem t2 : p → q := t1 hp

  axiom unsound : False
  theorem ex : 1 = 0 :=
    False.elim unsound
  #print ex

  theorem t1_1 (p q : Prop) (hp : p) (hq : q) : p := hp
  variable (p q r s : Prop)
  #check t1_1 p q

  variable (h : r → s)
  #check t1_1 (r → s) (s → r) h

  theorem t2_1 (h₁ : q → r) (h₂ : p → q) : p → r :=
    fun h₃ : p =>
    show r from h₁ (h₂ h₃)
  #print t2_1
  #check t2_1 p q r -- (q → r) → (p → q) → p → r
end work_wpt

/- Propositional Logic -/

namespace prop_log
  variable (p q : Prop)
  #check p → q → p ∧ q
  #check ¬p → p ↔ False
  #check p ∨ q → q ∨ p
end prop_log

namespace conj
  variable (p q : Prop)
  example (hp : p) (hq : q) : p ∧ q := And.intro hp hq
  example (h : p ∧ q) : q := And.right h
  example (h : p ∧ q) : p := And.left h

  example (h: p ∧ q) : q ∧ p :=
    And.intro (And.right h) (And.left h)

  variable (hp: p) (hq : q)
  #check (⟨hp, hq⟩ : p ∧ q)

  variable (xs : List Nat)
  #check List.length xs
  #check xs.length

  example (h : p ∧ q) : q ∧ p :=
    ⟨h.right, h.left⟩

  example (h : p ∧ q) : p ∧ q ∧ p :=
    ⟨h.left, h.right, h.left⟩
end conj

namespace disj
  variable (p q r : Prop)
  example (hp : p) : p ∨ q := Or.intro_left q hp
  example (hq : q) : p ∨ q := Or.intro_right p hq

  example (h : p ∨ q) : q ∨ p :=
    Or.elim h
      (fun hp : p =>
        show q ∨ p from Or.intro_right q hp)
      (fun hq : q =>
        show q ∨ p from Or.intro_left p hq)

  example (h : p ∨ q) : q ∨ p :=
    Or.elim h (fun hp => Or.inr hp) (fun hq => Or.inl hq)
end disj

/- Negation and Falsity -/

namespace neg_f
  variable (p q r : Prop)

  example (hpq : p → q) (hnq : ¬q) : ¬p :=
    fun hp : p =>
    show False from hnq (hpq hp)

  example (hp : p) (hnp : ¬p) : q := False.elim (hnp hp)
  example (hp : p) (hnp : ¬p) : q := absurd hp hnp

  example (hnp : ¬p) (hq : q) (hqp : q → p) : r :=
    absurd (hqp hq) hnp
end neg_f

/- Logical Equivalence -/

namespace logeq
  variable (p q : Prop)

  theorem and_swap : p ∧ q ↔ q ∧ p :=
    Iff.intro
      (fun h : p ∧ q =>
        show q ∧ p from And.intro h.right h.left)
      (fun h : q ∧ p =>
        show p ∧ q from And.intro h.right h.left)

  #check and_swap p q

  variable (h : p ∧ q)
  example : q ∧ p := Iff.mp (and_swap p q) h
end logeq

/- Auxiliary subgoals -/

namespace aux_sub
  variable (p q r : Prop)

  example (h : p ∧ q) : q ∧ p :=
    have hp : p := h.left
    have hq : q := h.right
    show q ∧ p from And.intro hq hp

  example (h : p ∧ q) : q ∧ p :=
    have hp : p := h.left
    suffices hq : q from And.intro hq hp
    show q from h.right
end aux_sub

/- Classical Logic -/

namespace class_log
  open Classical

  variable (p q r : Prop)

  #check em p

  theorem dne {p : Prop} (h : ¬¬p) : p :=
    Or.elim (em p)
      (fun hp : p => hp)
      (fun hnp : ¬p => absurd hnp h)

  theorem my_em : p ∨ ¬p :=
    byCases
      (fun h : p =>
        Or.intro_left (¬p) h)
      (fun h : ¬p =>
        Or.intro_right p h)

  example (h : ¬¬p) : p :=
    byContradiction
      (fun h1 : ¬p =>
        show False from h h1)

  example (h : ¬(p ∧ q)) : ¬p ∨ ¬q :=
    Or.elim (em p)
      (fun hp : p =>
        Or.inr
          (show ¬q from
            fun hq : q =>
              h ⟨hp, hq⟩))
      (fun hnp : ¬p =>
        Or.inl hnp)
end class_log

-- Examples
namespace ex
  open Classical
  variable (p q r : Prop)

  -- distributivity
  example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
    Iff.intro
      (fun h : p ∧ (q ∨ r) =>
        have hp : p := h.left
        Or.elim (h.right)
          (fun hq : q =>
            show (p ∧ q) ∨ (p ∧ r) from Or.inl ⟨hp, hq⟩)
          (fun hr : r =>
            show (p ∧ q) ∨ (p ∧ r) from Or.inr ⟨hp, hr⟩))

      (fun h : (p ∧ q) ∨ (p ∧ r) =>
        Or.elim h
          (fun hpq : p ∧ q =>
            have hp : p := hpq.left
            have hq : q := hpq.right
            show p ∧ (q ∨ r) from ⟨hp, Or.inl hq⟩)
          (fun hpr : p ∧ r =>
            have hp : p := hpr.left
            have hr : r := hpr.right
            show p ∧ (q ∨ r) from ⟨hp, Or.inr hr⟩))

  -- classical example
  example : ¬(p ∧ ¬q) → (p → q) :=
    fun h : ¬(p ∧ ¬q) =>
      fun hp : p =>
        show q from
          Or.elim (em q)
            (fun hq : q => hq)
            (fun hnq : ¬q =>
              absurd ⟨hp, hnq⟩ h)

end ex


import order.complete_lattice
import order.fixed_points
import data.set.lattice

import syntax

-- Definition 2, page 6
structure kripkeModel (W : Type) : Type :=
  (val : W → char → Prop)
  (rel : W → W → Prop)

-- Definition 3, page 6
def evaluate {W : Type} : (kripkeModel W × W) → formula → Prop
| (M,w) ⊥       := false
| (M,w) (· p)   := M.val w p
| (M,w) (~ φ)   := ¬ evaluate (M,w) φ
| (M,w) (φ ⋏ ψ) := evaluate (M,w) φ ∧ evaluate (M,w) ψ
| (M,w) (□ φ)   := ∀ v : W, (M.rel w v → evaluate (M,v) φ)

def tautology     (φ : formula) := ∀ W (M : kripkeModel W) w, evaluate (M,w) φ
def contradiction (φ : formula) := ∀ W (M : kripkeModel W) w, ¬ evaluate (M,w) φ

-- Definition 4, page 8

-- Definition 5, page 9
class has_sat (α : Type) := (satisfiable : α → Prop)
open has_sat
instance form_has_sat : has_sat formula := has_sat.mk (λ ϕ, ∃ W (M : kripkeModel W) w, evaluate (M,w) ϕ)
instance set_has_sat : has_sat (finset formula) := has_sat.mk (λ X, ∃ W (M : kripkeModel W) w, (∀ φ ∈ X, evaluate (M,w) φ))

lemma notsatisfnotThenTaut : ∀ φ, ¬ satisfiable (~φ) → tautology φ :=
begin
  intro phi,
  unfold satisfiable,
  unfold tautology,
  simp,
  intro lhs,
  intros W M w,
  specialize lhs W M w,
  unfold evaluate at *,
  simp at lhs,
  exact lhs,
end

@[simp]
lemma singletonSat_iff_sat : ∀ φ, satisfiable ({ φ } : finset formula) ↔ satisfiable φ :=
begin
  intro phi,
  unfold satisfiable,
  simp,
end

lemma tautImp_iff_comboNotUnsat {ϕ ψ} : tautology (ϕ ↣ ψ) ↔ ¬satisfiable ({ϕ, ~ψ} : finset formula) :=
begin
  unfold tautology,
  unfold satisfiable,
  simp,
  split ;
  { intro hyp,
    intros W M w,
    specialize hyp W M w,
    intro sat_phi,
    unfold evaluate at *, simp at *, tauto,
  },
end

def semImplies_sets (X : finset formula) (Y : finset formula) := ∀ (W : Type) (M : kripkeModel W) w,
  (∀ φ ∈ X, evaluate (M,w) φ) → (∀ ψ ∈ Y, evaluate (M,w) ψ)

-- Definition 5, page 9
class vDash {α : Type} {β : Type} := (semImplies : α → β → Prop)
open vDash
@[simp]
instance model_canSemImply_form {W : Type} : vDash := vDash.mk (@evaluate W)
@[simp]
instance model_canSemImply_set {W : Type} : vDash := @vDash.mk (kripkeModel W × W) (finset formula) (λ Mw X, ∀ f ∈ X, @evaluate W Mw f)
instance set_canSemImply_set : vDash := vDash.mk semImplies_sets
instance set_canSemImply_form : vDash := vDash.mk (λ X ψ, semImplies_sets X {ψ})
instance form_canSemImply_set : vDash := vDash.mk (λ φ X, semImplies_sets {φ} X)
instance form_canSemImply_form : vDash := vDash.mk (λ φ ψ, semImplies_sets {φ} {ψ})

infixl `⊨`:40 := semImplies
infixl `⊭`:40 := λ a b, ¬ (a ⊨ b)

-- useful lemmas to connect all the different ⊨ cases

lemma forms_to_sets { φ ψ : formula } : φ ⊨ ψ → ({φ}: finset formula) ⊨ ({ψ} : finset formula):=
begin
  intros impTaut,
  intros W M w lhs ψ1 psi1_in_setpsi,
  specialize impTaut W M w,
  simp at *,
  subst psi1_in_setpsi,
  apply impTaut,
  exact lhs
end


/-
Copyright (c) 2020 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa, Jujian Zhang
-/
import analysis.calculus.mean_value
import data.polynomial.denoms_clearable
import data.real.irrational
/-!

# Liouville's theorem

This file contains a proof of Liouville's theorem stating that all Liouville numbers are
transcendental.

To obtain this result, there is first a proof that Liouville numbers are irrational and two
technical lemmas.  These lemmas exploit the fact that a polynomial with integer coefficients
takes integer values at integers.  When evaluating at a rational number, we can clear denominators
and obtain precise inequalities that ultimately allow us to prove transcendence of
Liouville numbers.
-/

/--
A Liouville number is a real number `x` such that for every natural number `n`, there exist
`a, b ∈ ℤ` with `1 < b` such that `0 < |x - a/b| < 1/bⁿ`.
In the implementation, the condition `x ≠ a/b` replaces the traditional equivalent `0 < |x - a/b|`.
-/
def liouville (x : ℝ) := ∀ n : ℕ, ∃ a b : ℤ, 1 < b ∧ x ≠ a / b ∧ |x - a / b| < 1 / b ^ n

namespace liouville

@[protected] lemma irrational {x : ℝ} (h : liouville x) : irrational x :=
begin
  -- By contradiction, `x = a / b`, with `a ∈ ℤ`, `0 < b ∈ ℕ` is a Liouville number,
  rintros ⟨⟨a, b, bN0, cop⟩, rfl⟩,
  -- clear up the mess of constructions of rationals
  change (liouville (a / b)) at h,
  -- Since `a / b` is a Liouville number, there are `p, q ∈ ℤ`, with `q1 : 1 < q`,
  -- `a0 : a / b ≠ p / q` and `a1 : |a / b - p / q| < 1 / q ^ (b + 1)`
  rcases h (b + 1) with ⟨p, q, q1, a0, a1⟩,
  -- A few useful inequalities
  have qR0 : (0 : ℝ) < q := int.cast_pos.mpr (zero_lt_one.trans q1),
  have b0 : (b : ℝ) ≠ 0 := ne_of_gt (nat.cast_pos.mpr bN0),
  have bq0 : (0 : ℝ) < b * q := mul_pos (nat.cast_pos.mpr bN0) qR0,
  -- At a1, clear denominators...
  replace a1 : |a * q - b * p| * q ^ (b + 1) < b * q, by
    rwa [div_sub_div _ _ b0 (ne_of_gt qR0), abs_div, div_lt_div_iff (abs_pos.mpr (ne_of_gt bq0))
      (pow_pos qR0 _), abs_of_pos bq0, one_mul,
      -- ... and revert to integers
       ← int.cast_pow, ← int.cast_mul, ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_mul,
       ← int.cast_sub, ← int.cast_abs, ← int.cast_mul, int.cast_lt] at a1,
  -- At a0, clear denominators...
  replace a0 : ¬a * q - ↑b * p = 0, by
    rwa [ne.def, div_eq_div_iff b0 (ne_of_gt qR0), mul_comm ↑p, ← sub_eq_zero,
      -- ... and revert to integers
      ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_mul, ← int.cast_sub, int.cast_eq_zero] at a0,
  -- Actually, `q` is a natural number
  lift q to ℕ using (zero_lt_one.trans q1).le,
  -- Looks innocuous, but we now have an integer with non-zero absolute value: this is at
  -- least one away from zero.  The gain here is what gets the proof going.
  have ap : 0 < |a * ↑q - ↑b * p| := abs_pos.mpr a0,
  -- Actually, the absolute value of an integer is a natural number
  lift (|a * ↑q - ↑b * p|) to ℕ using (abs_nonneg (a * ↑q - ↑b * p)),
  -- At a1, revert to natural numbers
  rw [← int.coe_nat_mul, ← int.coe_nat_pow, ← int.coe_nat_mul, int.coe_nat_lt] at a1,
  -- Recall this is by contradiction: we obtained the inequality `b * q ≤ x * q ^ (b + 1)`, so
  -- we are done.
  exact not_le.mpr a1 (nat.mul_lt_mul_pow_succ (int.coe_nat_pos.mp ap) (int.coe_nat_lt.mp q1)).le,
end

open polynomial metric set real ring_hom

/-- Let `Z, N` be types, let `R` be a metric space, let `α : R` be a point and let
`j : Z → N → R` be a function.  We aim to estimate how close we can get to `α`, while staying
in the image of `j`.  The points `j z a` of `R` in the image of `j` come with a "cost" equal to
`d a`.  As we get closer to `α` while staying in the image of `j`, we are interested in bounding
the quantity `d a * dist α (j z a)` from below by a strictly positive amount `1 / A`: the intuition
is that approximating well `α` with the points in the image of `j` should come at a high cost.  The
hypotheses on the function `f : R → R` provide us with sufficient conditions to ensure our goal.
The first hypothesis is that `f` is Lipschitz at `α`: this yields a bound on the distance.
The second hypothesis is specific to the Liouville argument and provides the missing bound
involving the cost function `d`.

This lemma collects the properties used in the proof of `exists_pos_real_of_irrational_root`.
It is stated in more general form than needed: in the intended application, `Z = ℤ`, `N = ℕ`,
`R = ℝ`, `d a = (a + 1) ^ f.nat_degree`, `j z a  = z / (a + 1)`, `f ∈ ℤ[x]`, `α` is an irrational
root of `f`, `ε` is small, `M` is a bound on the Lipschitz constant of `f` near `α`, `n` is
the degree of the polynomial `f`.
-/
lemma exists_one_le_pow_mul_dist {Z N R : Type*} [metric_space R]
  {d : N → ℝ} {j : Z → N → R} {f : R → R} {α : R} {ε M : ℝ}
-- denominators are positive
  (d0 : ∀ (a : N), 1 ≤ d a)
  (e0 : 0 < ε)
-- function is Lipschitz at α
  (B : ∀ ⦃y : R⦄, y ∈ closed_ball α ε → dist (f α) (f y) ≤ (dist α y) * M)
-- clear denominators
  (L : ∀ ⦃z : Z⦄, ∀ ⦃a : N⦄, j z a ∈ closed_ball α ε → 1 ≤ (d a) * dist (f α) (f (j z a))) :
  ∃ A : ℝ, 0 < A ∧ ∀ (z : Z), ∀ (a : N), 1 ≤ (d a) * (dist α (j z a) * A) :=
begin
  -- A useful inequality to keep at hand
  have me0 : 0 < max (1 / ε) M := lt_max_iff.mpr (or.inl (one_div_pos.mpr e0)),
  -- The maximum between `1 / ε` and `M` works
  refine ⟨max (1 / ε) M, me0, λ z a, _⟩,
  -- First, let's deal with the easy case in which we are far away from `α`
  by_cases dm1 : 1 ≤ (dist α (j z a) * max (1 / ε) M),
  { exact one_le_mul_of_one_le_of_one_le (d0 a) dm1 },
  { -- `j z a = z / (a + 1)`: we prove that this ratio is close to `α`
    have : j z a ∈ closed_ball α ε,
    { refine mem_closed_ball'.mp (le_trans _ ((one_div_le me0 e0).mpr (le_max_left _ _))),
      exact ((le_div_iff me0).mpr (not_le.mp dm1).le) },
    -- use the "separation from `1`" (assumption `L`) for numerators,
    refine (L this).trans _,
    -- remove a common factor and use the Lipschitz assumption `B`
    refine mul_le_mul_of_nonneg_left ((B this).trans _) (zero_le_one.trans (d0 a)),
    exact mul_le_mul_of_nonneg_left (le_max_right _ M) dist_nonneg }
end

lemma exists_pos_real_of_irrational_root {α : ℝ} (ha : irrational α)
  {f : polynomial ℤ} (f0 : f ≠ 0) (fa : eval α (map (algebra_map ℤ ℝ) f) = 0):
  ∃ A : ℝ, 0 < A ∧
    ∀ (a : ℤ), ∀ (b : ℕ), (1 : ℝ) ≤ (b + 1) ^ f.nat_degree * (|α - (a / (b + 1))| * A) :=
begin
  -- `fR` is `f` viewed as a polynomial with `ℝ` coefficients.
  set fR : polynomial ℝ := map (algebra_map ℤ ℝ) f,
  -- `fR` is non-zero, since `f` is non-zero.
  obtain fR0 : fR ≠ 0 := λ fR0, (map_injective (algebra_map ℤ ℝ) (λ _ _ A, int.cast_inj.mp A)).ne
    f0 (fR0.trans (polynomial.map_zero _).symm),
  -- reformulating assumption `fa`: `α` is a root of `fR`.
  have ar : α ∈ (fR.roots.to_finset : set ℝ) :=
    finset.mem_coe.mpr (multiset.mem_to_finset.mpr ((mem_roots fR0).mpr (is_root.def.mpr fa))),
  -- Since the polynomial `fR` has finitely many roots, there is a closed interval centered at `α`
  -- such that `α` is the only root of `fR` in the interval.
  obtain ⟨ζ, z0, U⟩ : ∃ ζ > 0, closed_ball α ζ ∩ (fR.roots.to_finset) = {α} :=
    @exists_closed_ball_inter_eq_singleton_of_discrete _ _ _ discrete_of_t1_of_finite _ ar,
  -- Since `fR` is continuous, it is bounded on the interval above.
  obtain ⟨xm, -, hM⟩ : ∃ (xm : ℝ) (H : xm ∈ Icc (α - ζ) (α + ζ)), ∀ (y : ℝ),
    y ∈ Icc (α - ζ) (α + ζ) → |fR.derivative.eval y| ≤ |fR.derivative.eval xm| :=
    is_compact.exists_forall_ge is_compact_Icc
    ⟨α, (sub_lt_self α z0).le, (lt_add_of_pos_right α z0).le⟩
    (continuous_abs.comp fR.derivative.continuous_aeval).continuous_on,
  -- Use the key lemma `exists_one_le_pow_mul_dist`: we are left to show that ...
  refine @exists_one_le_pow_mul_dist ℤ ℕ ℝ _ _ _ (λ y, fR.eval y) α ζ
    (|fR.derivative.eval xm|) _ z0 (λ y hy, _) (λ z a hq, _),
  -- 1: the denominators are positive -- essentially by definition;
  { exact λ a, one_le_pow_of_one_le ((le_add_iff_nonneg_left 1).mpr a.cast_nonneg) _ },
  -- 2: the polynomial `fR` is Lipschitz at `α` -- as its derivative continuous;
  { rw mul_comm,
    rw real.closed_ball_eq_Icc at hy,
    -- apply the Mean Value Theorem: the bound on the derivative comes from differentiability.
    refine convex.norm_image_sub_le_of_norm_deriv_le (λ _ _, fR.differentiable_at)
      (λ y h, by { rw fR.deriv, exact hM _ h }) (convex_Icc _ _) hy (mem_Icc_iff_abs_le.mp _),
    exact @mem_closed_ball_self ℝ _ α ζ (le_of_lt z0) },
  -- 3: the weird inequality of Liouville type with powers of the denominators.
  { show 1 ≤ (a + 1 : ℝ) ^ f.nat_degree * |eval α fR - eval (z / (a + 1)) fR|,
    rw [fa, zero_sub, abs_neg],
    -- key observation: the right-hand side of the inequality is an *integer*.  Therefore,
    -- if its absolute value is not at least one, then it vanishes.  Proceed by contradiction
    refine one_le_pow_mul_abs_eval_div (int.coe_nat_succ_pos a) (λ hy, _),
    -- As the evaluation of the polynomial vanishes, we found a root of `fR` that is rational.
    -- We know that `α` is the only root of `fR` in our interval, and `α` is irrational:
    -- follow your nose.
    refine (irrational_iff_ne_rational α).mp ha z (a + 1) ((mem_singleton_iff.mp _).symm),
    refine U.subset _,
    refine ⟨hq, finset.mem_coe.mp (multiset.mem_to_finset.mpr _)⟩,
    exact (mem_roots fR0).mpr (is_root.def.mpr hy) }
end

/-- **Liouville's Theorem** -/
theorem transcendental {x : ℝ} (lx : liouville x) :
  transcendental ℤ x :=
begin
  -- Proceed by contradiction: if `x` is algebraic, then `x` is the root (`ef0`) of a
  -- non-zero (`f0`) polynomial `f`
  rintros ⟨f : polynomial ℤ, f0, ef0⟩,
  -- Change `aeval x f = 0` to `eval (map _ f) = 0`, who knew.
  replace ef0 : (f.map (algebra_map ℤ ℝ)).eval x = 0, { rwa [aeval_def, ← eval_map] at ef0 },
  -- There is a "large" real number `A` such that `(b + 1) ^ (deg f) * |f (x - a / (b + 1))| * A`
  -- is at least one.  This is obtained from lemma `exists_pos_real_of_irrational_root`.
  obtain ⟨A, hA, h⟩ : ∃ (A : ℝ), 0 < A ∧
    ∀ (a : ℤ) (b : ℕ), (1 : ℝ) ≤ (b.succ) ^ f.nat_degree * (|x - a / (b.succ)| * A) :=
    exists_pos_real_of_irrational_root lx.irrational f0 ef0,
  -- Since the real numbers are Archimedean, a power of `2` exceeds `A`: `hn : A < 2 ^ r`.
  rcases pow_unbounded_of_one_lt A (lt_add_one 1) with ⟨r, hn⟩,
  -- Use the Liouville property, with exponent `r +  deg f`.
  obtain ⟨a, b, b1, -, a1⟩ : ∃ (a b : ℤ), 1 < b ∧ x ≠ a / b ∧
    |x - a / b| < 1 / b ^ (r + f.nat_degree) := lx (r + f.nat_degree),
  have b0 : (0 : ℝ) < b := zero_lt_one.trans (by { rw ← int.cast_one, exact int.cast_lt.mpr b1 }),
  -- Prove that `b ^ f.nat_degree * abs (x - a / b)` is strictly smaller than itself
  -- recall, this is a proof by contradiction!
  refine lt_irrefl ((b : ℝ) ^ f.nat_degree * |x - ↑a / ↑b|) _,
  -- clear denominators at `a1`
  rw [lt_div_iff' (pow_pos b0 _), pow_add, mul_assoc] at a1,
  -- split the inequality via `1 / A`.
  refine ((_  : (b : ℝ) ^ f.nat_degree * |x - a / b| < 1 / A).trans_le _),
  -- This branch of the proof uses the Liouville condition and the Archimedean property
  { refine (lt_div_iff' hA).mpr _,
    refine lt_of_le_of_lt _ a1,
    refine mul_le_mul_of_nonneg_right _ (mul_nonneg (pow_nonneg b0.le _) (abs_nonneg _)),
    refine hn.le.trans _,
    refine pow_le_pow_of_le_left zero_le_two _ _,
    exact int.cast_two.symm.le.trans (int.cast_le.mpr (int.add_one_le_iff.mpr b1)) },
  -- this branch of the proof exploits the "integrality" of evaluations of polynomials
  -- at ratios of integers.
  { lift b to ℕ using zero_le_one.trans b1.le,
    specialize h a b.pred,
    rwa [nat.succ_pred_eq_of_pos (zero_lt_one.trans _), ← mul_assoc, ← (div_le_iff hA)] at h,
    exact int.coe_nat_lt.mp b1 }
end

end liouville


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

If we have types `X` and `Y` with a left action of a monoid `M`,
then there are also natural actions of `M` on various other types
defined in terms of `X` and/or `Y`, such as `X × Y` and
`finset X` and `X / E` (for an equivalence relation `E` with
appropriate properties).  This file defines typeclass instances
that encode these natural actions.

-/

import group_theory.group_action
import tactic.interactive

universes uM uG uX uY uZ

variables {M : Type uM} [monoid M]
variables {G : Type uG} [group G ]
variables {X : Type uX} {Y : Type uY} {Z : Type uZ}
variables [mul_action M X] [mul_action M Y] [mul_action M Z]
variables [mul_action G X] [mul_action G Y] [mul_action G Z]

namespace mul_action

lemma smul_cancel_left {g : G} {x : X} : g⁻¹ • g • x  = x :=
by { rw [← mul_smul, mul_left_inv, one_smul] }

lemma smul_cancel_right {g : G} {x : X} : g • g⁻¹ • x  = x :=
by { rw [← mul_smul, mul_right_inv, one_smul] }

lemma smul_eq_iff_eq_smul_inv {g : G} {x y : X} :
    g • x = y ↔ x = g⁻¹ • y :=
begin
  split; intro h,
  { rw [← h, smul_cancel_left ] },
  { rw [  h, smul_cancel_right] }
end

lemma one_act : ((•) (1 : M)) = @id X :=
 by { funext x, rw[one_smul,id] }

lemma mul_act (m n : M) : (((•) (m * n)) : X → X) = ((•) m) ∘ ((•) n) :=
 by { funext x, rw[mul_smul] }

variable (M)
def trivial_action (Z : Type*) : mul_action M Z := {
  smul := λ a z, z,
  one_smul := λ z, rfl,
  mul_smul := λ a b z, rfl
}
variable {M}

instance empty_action : mul_action M empty := trivial_action _ _

instance unit_action : mul_action M unit := trivial_action _ _

instance sum_action : mul_action M (X ⊕ Y) := {
 smul := λ m z,sum.cases_on z (λ x, sum.inl (m • x)) (λ y, sum.inr (m • y)),
 one_smul := λ z,begin
  rcases z with x | y,
  { change sum.inl ((1 : M) • x) = sum.inl x, rw[one_smul], },
  { change sum.inr ((1 : M) • y) = sum.inr y, rw[one_smul], }
 end,
 mul_smul := λ m n z,begin
  rcases z with x | y,
  { change sum.inl ((m * n) • x) = sum.inl (m • n • x), rw[mul_smul] },
  { change sum.inr ((m * n) • y) = sum.inr (m • n • y), rw[mul_smul] }
 end
}

instance prod_action : mul_action M (X × Y) := {
 smul := λ m xy, ⟨m • xy.1,m • xy.2⟩,
 one_smul := λ ⟨x,y⟩,
  by {change (prod.mk ((1 : M) • x) ((1 : M) • y)) = prod.mk x y,
      rw[one_smul,one_smul] },
 mul_smul := λ m n ⟨x,y⟩,
  by {change (prod.mk ((m * n) • x) ((m * n) • y)) =
             (prod.mk (m • n • x) (m • n • y)),
      rw[mul_smul,mul_smul] }
}

lemma smul_prod (m : M) (xy : X × Y) : m • xy = ⟨m • xy.1, m • xy.2⟩ := rfl

variables (M G)
def is_equivariant (f : X → Y) := ∀ (m : M) (x : X), f (m • x) = m • (f x)

def equivariantizer (f : X → Y) : submonoid M := {
  carrier := { m : M | ∀ (x : X), f (m • x) = m • (f x) },
  one_mem' := λ x, by { rw [one_smul, one_smul] },
  mul_mem' := λ a b ha hb x,
    by { rw[mul_smul, mul_smul, ha, hb] }
}

def equivariantizer_subgroup (f : X → Y) : subgroup G := {
   inv_mem' := λ g hg x, by {
     rw [← smul_eq_iff_eq_smul_inv, ← hg, ← mul_smul,
         mul_right_inv, one_smul] },
   .. mul_action.equivariantizer G f
}

variables {M G}

lemma is_equivariant_id : is_equivariant M (id : X → X) := λ m x, rfl

lemma is_equivariant_comp {g : Y → Z} {f : X → Y}
  (hg : is_equivariant M g) (hf : is_equivariant M f) :
    (is_equivariant M (g ∘ f)) :=
λ m x,  by { rw [function.comp_app, hf, hg] }

instance map_action : mul_action G (X → Y) := {
 smul := λ g u x, g • (u (g⁻¹ • x)),
 one_smul := λ u, funext $ λ x,
   by { change _ • (u _) = u x, rw [inv_one, one_smul, one_smul] },
 mul_smul := λ a b u, funext $ λ x,
   by { change _ • (u _) = _ • (_ • _),
        rw [mul_inv_rev, mul_smul, mul_smul] }
}

lemma smul_map (g : G) (u : X → Y) (x : X) :
  (g • u) x = g • (u (g⁻¹ • x)) := rfl

instance list_scalar : has_scalar M (list X) := ⟨λ m xs,xs.map ((•) m)⟩

instance list_action : mul_action M (list X) := {
 one_smul := λ xs,
  begin
   change xs.map ((•) (1 : M)) = xs,
   rw[one_act,list.map_id],
  end,
 mul_smul := λ m n xs,calc
   (m * n) • xs = xs.map ((•) (m * n)) : rfl
   ... = xs.map (((•) m) ∘ ((•) n)) : by rw[mul_act]
   ... = m • n • xs : by { rw[← list.map_map], refl },
 .. mul_action.list_scalar
}

lemma smul_list (m : M) (xs : list X) : m • xs = xs.map ((•) m) := rfl

instance finset_scalar [decidable_eq X] : has_scalar M (finset X) :=
 ⟨λ m xs,xs.image ((•) m)⟩

instance finset_action [decidable_eq X] : mul_action M (finset X) := {
 one_smul := λ xs,
  begin
   change xs.image ((•) (1 : M)) = xs,
   rw [one_act, finset.image_id],
  end,
 mul_smul := λ m n xs, calc
   (m * n) • xs = xs.image ((•) (m * n)) : rfl
   ... = xs.image (((•) m) ∘ ((•) n)) : by rw [mul_act]
   ... = m • n • xs : by { rw [← finset.image_image], refl },
 .. mul_action.finset_scalar
}

lemma smul_finset [decidable_eq X] (m : M) (xs : finset X) :
  m • xs = xs.image ((•) m) := rfl

lemma mem_smul_finset [decidable_eq X] {x : X} {m : M} {xs : finset X} :
  x ∈ m • xs ↔ ∃ (x' : X), x' ∈ xs ∧ m • x' = x :=
by { rw [smul_finset, finset.mem_image]; simp only [exists_prop] }

lemma mem_smul_finset_of_mem [decidable_eq X] (m : M) {xs : finset X}
  {x : X} (hx : x ∈ xs) : m • x ∈ m • xs :=
finset.mem_image_of_mem ((•) m) hx

lemma mem_smul_finset' [decidable_eq X]
  {x : X} {g : G} {xs : finset X} :
    x ∈ g • xs ↔ (g⁻¹ • x) ∈ xs :=
begin
  rw [mem_smul_finset], split,
  { rintro ⟨x',⟨hm,he⟩⟩,
    have := calc g⁻¹ • x = g⁻¹ • (g • x') : by { rw [← he] }
      ... = x' : by { rw [smul_cancel_left] },
    rw [← this] at hm, exact hm },
  { intro h, use g⁻¹ • x, split,
    { exact h },
    { rw [smul_cancel_right] } }
end

lemma smul_finset_eq_iff [decidable_eq X]
  {g : G} {xs ys : finset X} :
    g • xs = ys ↔ (∀ {x : X}, x ∈ xs → g • x ∈ ys) ∧
                  (∀ {y : X}, y ∈ ys → g⁻¹ • y ∈ xs) :=
begin
  split,
  { intro h, split,
    { intros x hx, rw [← h, mem_smul_finset', smul_cancel_left], exact hx },
    { let h' : xs = g⁻¹ • ys := smul_eq_iff_eq_smul_inv.mp h,
      intros y hy, rw [h'],
      exact mem_smul_finset_of_mem g⁻¹ hy
    } },
  { rintro ⟨h₀,h₁⟩, ext y, split; intro hy,
    { replace hy := h₀ (mem_smul_finset'.mp hy),
      rw [smul_cancel_right] at hy, exact hy },
    { rw [mem_smul_finset'], exact h₁ hy } }
end

variables (M X)
structure equivariant_set : Type uX :=
(carrier : set X)
(smul : ∀ (m : M) {x : X}, x ∈ carrier → m • x ∈ carrier)
variables {M X}

namespace equivariant_set
instance : has_coe (equivariant_set M X) (set X) := ⟨equivariant_set.carrier⟩
instance : has_mem X (equivariant_set M X) := ⟨λ x Y, x ∈ (Y : set X)⟩

@[simp] theorem mem_coe {Y : equivariant_set M X} (x : X) :
 x ∈ (Y : set X) ↔ x ∈ Y := iff.rfl

theorem ext' {Y₀ Y₁ : equivariant_set M X}
 (h : (Y₀ : set X) = (Y₁ : set X)) : Y₀ = Y₁ :=
  by cases Y₀; cases Y₁; congr'

protected theorem ext'_iff {Y₀ Y₁ : equivariant_set M X}  :
 (Y₀ : set X) = (Y₁ : set X) ↔ Y₀ = Y₁ := ⟨ext', λ h, h ▸ rfl⟩

@[ext] theorem ext {Y₀ Y₁ : equivariant_set M X}
  (h : ∀ x, x ∈ Y₀ ↔ x ∈ Y₁) : Y₀ = Y₁ := ext' $ set.ext h

instance restricted_action (Y : equivariant_set M X) : mul_action M Y.carrier := {
  smul := λ m ⟨y,y_in_Y⟩, ⟨m • y,Y.smul m y_in_Y⟩,
  one_smul := λ ⟨y,y_in_Y⟩,
   by { apply subtype.eq, change (1 : M) • y = y, apply one_smul },
  mul_smul := λ m n ⟨y,y_in_Y⟩,
   by { apply subtype.eq, change (m * n) • y = m • n • y, apply mul_smul }
}

lemma coe_smul {Y : equivariant_set M X} (m : M) (y : Y) :
  ((m • y) : X) = m • (y : X) := rfl

end equivariant_set

variables (M X)
structure equivariant_setoid extends (setoid X) :=
(smul : ∀ (m : M) {x y : X}, r x y → r (m • x) (m • y))
variables {M X}

namespace equivariant_setoid
instance : has_coe (equivariant_setoid M X) (setoid X) := ⟨λ E, ⟨E.r,E.iseqv⟩⟩

def quotient (E : equivariant_setoid M X) := quotient (E : setoid X)
def quotient.mk (E : equivariant_setoid M X) (x : X) : quotient E :=
  @_root_.quotient.mk X E x

instance induced_action (E : equivariant_setoid M X) :
  mul_action M (quotient E) :=
begin
 exact {
  smul :=  λ m, @quotient.lift X _ E
           (λ x, (@_root_.quotient.mk X E (m • x)))
           (λ x₀ x₁ e, begin
             let h := @quotient.sound X E,
             exact h (equivariant_setoid.smul _ m e),
           end),
  one_smul :=
    begin
      rintro ⟨x⟩, change @_root_.quotient.mk X E _ = _,
      rw [one_smul], refl
    end,
  mul_smul :=
    begin
      rintro a b ⟨x⟩,
      change @_root_.quotient.mk X E _ = @_root_.quotient.mk X E _,
      rw [mul_smul]
    end
 }
end

lemma smul_mk (E : equivariant_setoid M X) (m : M) (x : X) :
  m • (quotient.mk E x) = quotient.mk E (m • x) := rfl

end equivariant_setoid

end mul_action

namespace mul_action

variables [decidable_eq X]

variable (X)
def smul_equiv (g : G) : X ≃ X := {
  to_fun    := λ x, g • x,
  inv_fun   := λ x, g⁻¹ • x,
  left_inv  := λ x, by { change g⁻¹ • (g • x) = x, rw [← mul_smul, inv_mul_self, one_smul] },
  right_inv := λ x, by { change g • (g⁻¹ • x) = x, rw [← mul_smul, mul_inv_self, one_smul] }
}
variable {X}

lemma finset_action_eq_map (g : G) (s : finset X) :
  g • s = s.map (smul_equiv X g).to_embedding :=
begin
  change s.image _ = s.map _,
  rw [finset.map_eq_image], refl
end

lemma finset_action.card (g : G) (s : finset X) : (g • s).card = s.card :=
begin
  rw [finset_action_eq_map, finset.card_map]
end

end mul_action


import Mathlib.Data.Nat.Basic
import BrownCs22.Library.Tactics
import BrownCs22.Library.ModSubst.ModRel
import BrownCs22.Library.Defs

set_option linter.unusedVariables false

open BrownCs22

/-

# Lecture 17 Lean notes

We've been using Lean (on and off) in homeworks.
The plan for today is to get a bit more context about *why*
people are interested in tools like this.

## GCD in Lean

First of all: we've mentioned before that Lean is in fact
a programming language itself. Here's the `gcd` function
we've been discussing, implementing Euclid's algorithm.

(We could implement the extended Euclidean algorithm, the "pulverizer",
but let's keep it simple for now.)

-/

def gcd (a b : ℕ) : ℕ :=
  if b < a then
    gcd b a
  else if h : a = 0 then
    b
  else
    have hlt : b % a < a := Nat.mod_lt _ (by positivity)
    gcd (b%a) a
termination_by gcd a b => a

#eval gcd 55 60
#eval gcd 22 3

/-

This looks more or less like our slides version, with a couple funny things.
First of all: there are `have` statements and hypothesis names `h : ` in the
body of our program!
Second of all, what's the `termination_by` at the end?

Lean is a very particular programming language.
It does not support functions that fail to terminate, or that raise
error messages. In other words: *we can only define total functions!*

The statements we write in the body of our program help Lean decide
that the program does, in fact, terminate.
(Actually: it *proves* that the program terminates, automatically.)

Proving about programs, cool. It's here that proof assistants like Lean
really shine. Most proofs can't be done automatically, but...

Here's a proof that the output of `gcd` always divides both the inputs.
(We won't talk through the details in class.)
-/

theorem gcd_divides : ∀ a b : ℕ, gcd a b ∣ a ∧ gcd a b ∣ b := by
  -- We proceed by strong induction on `a`,
  -- with predicate `∀ b : ℕ, gcd a b ∣ a ∧ gcd a b ∣ b`.
  strong_induction

  -- Introduce the induction hypothesis into the context.
  intro a
  intro ih
  intro b

  -- Expand the definition of `gcd`.
  unfold gcd

  -- Let's reason by cases on whether `b < a`.
  by_cases hba : b < a

  -- If we know `b < a`, we can simplify our `gcd` program (we know which branch of the `if` statement we take)
  { simp [hba]

    -- We can instantiate the induction hypothesis to match the goal.
    have ih2 : gcd b a ∣ b ∧ gcd b a ∣ a := ih b hba a
    rw [and_comm]
    assumption }

  -- Otherwise, we know `¬ b < a`.
  { simp [hba]

    -- Reason by cases again, on whether `a = 0`.
    by_cases ha : a = 0

    -- If `a = 0`, our proof is easy: `0 ∣ 0 ∧ 0 ∣ b` is trivial.
    { simp [ha] }

    -- Otherwise, we can again simplify our program knowing we're in the "else" branch.
    { simp [ha]

      -- We can again instantiate our induction hypothesis.
      have ih3 : gcd (b % a) a ∣ b % a ∧ gcd (b % a) a ∣ a :=
        ih (b % a) (Nat.mod_lt _ (by positivity)) a
      eliminate ih3 with hl hr

      -- We need to prove two "divides" claims.
      split_goal

      -- The first comes directly from our induction hypothesis.
      { assumption }

      -- Otherwise, let's do some arithmetic, expanding the definition of `∣`.
      { dsimp [Dvd.dvd] at hl hr ⊢
        eliminate hl with k hk
        eliminate hr with m hm

        -- We apply the qhotient-remainder theorem on `b % a`,
        -- which in Lean is named `Nat.div_add_mod`.
        have qr := Nat.div_add_mod b a

        -- We can then compute a witness for divisibility...
        existsi (b/a)*m + k

        -- and do a (slightly ugly) calculation, with the help of polyrith.
        -- (Don't worry about the details here too much.)
        zify at qr hm hk ⊢
        linear_combination hk + (b / a : ℤ) * hm - qr } } }

/-

A lot of real-world programs -- encryptors or decryptors, for instance --
depend on a subroutine that computes gcds.
A lot of these programs are safety-critical, in that bugs in this programs
could have severe social, political, or economic consequences.

Imagine if they were formally verified....

-/

open BrownCs22.Int Dvd

/-

## Modular arithmetic in Lean

On Friday we introduced the notion of "equivalence modulo `n`".
Two integers are equivalent if they are separated by a multiple of `n`.

-/

#check ModEq

#eval 4 ≡ 14 [ZMOD 5]
#eval 23 ≡ 11 [ZMOD 12]
#eval 22 ≡ 11 [ZMOD 12]

/-
We can *prove* modular equivalences, using tools we've used before.
-/

example : 4 ≡ 14 [ZMOD 5] := by
  dsimp [ModEq]
  dsimp [dvd]
  existsi -2
  numbers

/-
But if Lean can evaluate facts like this, why can't it prove them automatically?
-/

example : 4 ≡ 14 [ZMOD 5] := by
  decide

/-
Ultimately, we're not interested so much in a bare calculator.
We want to prove things about equivalences.

Here's a theorem that says, if `a ≡ b`, we can add equivalent values
to each side. (We used this in Friday's lecture...)
-/

theorem Int.ModEq.add {n a b c d : ℤ}
  (h1 : a ≡ b [ZMOD n]) (h2 : c ≡ d [ZMOD n]) :
    a + c ≡ b + d [ZMOD n] := by
  dsimp [ModEq, dvd] at *
  eliminate h1 with x hx
  eliminate h2 with y hy
  existsi x + y
  calc
    a + c - (b + d) = a - b + (c - d) := by linarith
                  _ = n * x + n * y   := by rw [hx, hy]
                  _ = n * (x + y)     := by linarith

/-
We ended the day on Friday thinking about *division*.
If I know `a ≡ b`, do I know `a/c ≡ b/c`?
Certainly not if `c` doesn't divide `a` or `b`.
But what if it does? Could we prove this theorem?
-/

example {a b c n : ℤ}
  (hca : c ∣ a) (hcb : c ∣ b) (hab : a ≡ b [ZMOD n]) :
    a/c ≡ b/c [ZMOD n] := by
sorry

/-
After some thought and experimentation: *no!*
Let `a = 10`, `b = 22`, `c = 2`, `n = 4`.
-/

example : 2 ∣ 10               := by decide
example : 2 ∣ 22               := by decide
example : 10 ≡ 22 [ZMOD 4]     := by decide
example : 10/2 ≡ 22/2 [ZMOD 4] := by sorry

#eval 10/2 ≡ 22/2 [ZMOD 4]

/-

So, we can't necessarily "cancel" across both sides of a modular equivalence.
But we can simplify addition, multiplication, exponents, ...

-/

example (a b : ℤ) (ha : a ≡ 4 [ZMOD 5]) (hb : b ≡ 3 [ZMOD 5]) :
    a * b + b ^ 3 + 3 ≡ 2 [ZMOD 5] :=
  calc
    a * b + b ^ 3 + 3 ≡ 4 * b + b ^ 3 + 3 [ZMOD 5] := by mod_subst [ha]
                    _ ≡ 4 * 3 + 3 ^ 3 + 3 [ZMOD 5] := by mod_subst [hb]
                    _ = 2 + 5 * 8                  := by numbers
                    _ ≡ 2 [ZMOD 5]                 := by decide


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
! This file was ported from Lean 3 source module order.lattice_intervals
! leanprover-community/mathlib commit d012cd09a9b256d870751284dd6a29882b0be105
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Bounds.Basic

/-!
# Intervals in Lattices

In this file, we provide instances of lattice structures on intervals within lattices.
Some of them depend on the order of the endpoints of the interval, and thus are not made
global instances. These are probably not all of the lattice instances that could be placed on these
intervals, but more can be added easily along the same lines when needed.

## Main definitions

In the following, `*` can represent either `c`, `o`, or `i`.
  * `Set.Ic*.orderBot`
  * `Set.Ii*.semillaticeInf`
  * `Set.I*c.orderTop`
  * `Set.I*c.semillaticeInf`
  * `Set.I**.lattice`
  * `Set.Iic.boundedOrder`, within an `OrderBot`
  * `Set.Ici.boundedOrder`, within an `OrderTop`
-/

variable {α : Type _}

namespace Set

namespace Ico

instance semilatticeInf [SemilatticeInf α] {a b : α} : SemilatticeInf (Ico a b) :=
  Subtype.semilatticeInf fun _ _ hx hy => ⟨le_inf hx.1 hy.1, lt_of_le_of_lt inf_le_left hx.2⟩

/-- `Ico a b` has a bottom element whenever `a < b`. -/
@[reducible]
protected def orderBot [PartialOrder α] {a b : α} (h : a < b) : OrderBot (Ico a b) :=
  (isLeast_Ico h).orderBot
#align set.Ico.order_bot Set.Ico.orderBot

end Ico

namespace Iio

instance semilatticeInf [SemilatticeInf α] {a : α} : SemilatticeInf (Iio a) :=
  Subtype.semilatticeInf fun _ _ hx _ => lt_of_le_of_lt inf_le_left hx

end Iio

namespace Ioc

instance semilatticeSup [SemilatticeSup α] {a b : α} : SemilatticeSup (Ioc a b) :=
  Subtype.semilatticeSup fun _ _ hx hy => ⟨lt_of_lt_of_le hx.1 le_sup_left, sup_le hx.2 hy.2⟩

/-- `Ioc a b` has a top element whenever `a < b`. -/
@[reducible]
protected def orderTop [PartialOrder α] {a b : α} (h : a < b) : OrderTop (Ioc a b) :=
  (isGreatest_Ioc h).orderTop
#align set.Ioc.order_top Set.Ioc.orderTop

end Ioc

namespace Ioi

instance semilatticeSup [SemilatticeSup α] {a : α} : SemilatticeSup (Ioi a) :=
  Subtype.semilatticeSup fun _ _ hx _ => lt_of_lt_of_le hx le_sup_left

end Ioi

namespace Iic

instance semilatticeInf [SemilatticeInf α] {a : α} : SemilatticeInf (Iic a) :=
  Subtype.semilatticeInf fun _ _ hx _ => le_trans inf_le_left hx

instance semilatticeSup [SemilatticeSup α] {a : α} : SemilatticeSup (Iic a) :=
  Subtype.semilatticeSup fun _ _ hx hy => sup_le hx hy

instance [Lattice α] {a : α} : Lattice (Iic a) :=
  { Iic.semilatticeInf, Iic.semilatticeSup with }

instance orderTop [Preorder α] {a : α} :
    OrderTop (Iic a) where
  top := ⟨a, le_refl a⟩
  le_top x := x.prop

@[simp]
theorem coe_top [Preorder α] {a : α} : (⊤ : Iic a) = a :=
  rfl
#align set.Iic.coe_top Set.Iic.coe_top

instance orderBot [Preorder α] [OrderBot α] {a : α} :
    OrderBot (Iic a) where
  bot := ⟨⊥, bot_le⟩
  bot_le := fun ⟨_, _⟩ => Subtype.mk_le_mk.2 bot_le

@[simp]
theorem coe_bot [Preorder α] [OrderBot α] {a : α} : (⊥ : Iic a) = (⊥ : α) :=
  rfl
#align set.Iic.coe_bot Set.Iic.coe_bot

instance [Preorder α] [OrderBot α] {a : α} : BoundedOrder (Iic a) :=
  { Iic.orderTop, Iic.orderBot with }

end Iic

namespace Ici

instance semilatticeInf [SemilatticeInf α] {a : α} : SemilatticeInf (Ici a) :=
  Subtype.semilatticeInf fun _ _ hx hy => le_inf hx hy

instance semilatticeSup [SemilatticeSup α] {a : α} : SemilatticeSup (Ici a) :=
  Subtype.semilatticeSup fun _ _ hx _ => le_trans hx le_sup_left

instance lattice [Lattice α] {a : α} : Lattice (Ici a) :=
  { Ici.semilatticeInf, Ici.semilatticeSup with }

instance distribLattice [DistribLattice α] {a : α} : DistribLattice (Ici a) :=
  { Ici.lattice with le_sup_inf := fun _ _ _ => le_sup_inf }

instance orderBot [Preorder α] {a : α} :
    OrderBot (Ici a) where
  bot := ⟨a, le_refl a⟩
  bot_le x := x.prop

@[simp]
theorem coe_bot [Preorder α] {a : α} : ↑(⊥ : Ici a) = a :=
  rfl
#align set.Ici.coe_bot Set.Ici.coe_bot

instance orderTop [Preorder α] [OrderTop α] {a : α} :
    OrderTop (Ici a) where
  top := ⟨⊤, le_top⟩
  le_top := fun ⟨_, _⟩ => Subtype.mk_le_mk.2 le_top

@[simp]
theorem coe_top [Preorder α] [OrderTop α] {a : α} : ↑(⊤ : Ici a) = (⊤ : α) :=
  rfl
#align set.Ici.coe_top Set.Ici.coe_top

instance boundedOrder [Preorder α] [OrderTop α] {a : α} : BoundedOrder (Ici a) :=
  { Ici.orderTop, Ici.orderBot with }

end Ici

namespace Icc

instance semilatticeInf [SemilatticeInf α] {a b : α} : SemilatticeInf (Icc a b) :=
  Subtype.semilatticeInf fun _ _ hx hy => ⟨le_inf hx.1 hy.1, le_trans inf_le_left hx.2⟩

instance semilatticeSup [SemilatticeSup α] {a b : α} : SemilatticeSup (Icc a b) :=
  Subtype.semilatticeSup fun _ _ hx hy => ⟨le_trans hx.1 le_sup_left, sup_le hx.2 hy.2⟩

instance lattice [Lattice α] {a b : α} : Lattice (Icc a b) :=
  { Icc.semilatticeInf, Icc.semilatticeSup with }

/-- `Icc a b` has a bottom element whenever `a ≤ b`. -/
@[reducible]
protected def orderBot [Preorder α] {a b : α} (h : a ≤ b) : OrderBot (Icc a b) :=
  (isLeast_Icc h).orderBot
#align set.Icc.order_bot Set.Icc.orderBot

/-- `Icc a b` has a top element whenever `a ≤ b`. -/
@[reducible]
protected def orderTop [Preorder α] {a b : α} (h : a ≤ b) : OrderTop (Icc a b) :=
  (isGreatest_Icc h).orderTop
#align set.Icc.order_top Set.Icc.orderTop

/-- `Icc a b` is a `bounded_order` whenever `a ≤ b`. -/
@[reducible]
protected def boundedOrder [Preorder α] {a b : α} (h : a ≤ b) : BoundedOrder (Icc a b) :=
  { Icc.orderTop h, Icc.orderBot h with }
#align set.Icc.bounded_order Set.Icc.boundedOrder

end Icc

end Set


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

! This file was ported from Lean 3 source module group_theory.subgroup.simple
! leanprover-community/mathlib commit fac369018417f980cec5fcdafc766a69f88d8cfe
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Subgroup.Actions

/-!
# Simple groups

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

This file defines `is_simple_group G`, a class indicating that a group has exactly two normal
subgroups.

## Main definitions

- `is_simple_group G`, a class indicating that a group has exactly two normal subgroups.

## Tags
subgroup, subgroups

-/

variable {G : Type _} [Group G]

variable {A : Type _} [AddGroup A]

section

variable (G) (A)

#print IsSimpleGroup /-
/-- A `group` is simple when it has exactly two normal `subgroup`s. -/
class IsSimpleGroup extends Nontrivial G : Prop where
  eq_bot_or_eq_top_of_normal : ∀ H : Subgroup G, H.Normal → H = ⊥ ∨ H = ⊤
#align is_simple_group IsSimpleGroup
-/

#print IsSimpleAddGroup /-
/-- An `add_group` is simple when it has exactly two normal `add_subgroup`s. -/
class IsSimpleAddGroup extends Nontrivial A : Prop where
  eq_bot_or_eq_top_of_normal : ∀ H : AddSubgroup A, H.Normal → H = ⊥ ∨ H = ⊤
#align is_simple_add_group IsSimpleAddGroup
-/

attribute [to_additive] IsSimpleGroup

variable {G} {A}

/- warning: subgroup.normal.eq_bot_or_eq_top -> Subgroup.Normal.eq_bot_or_eq_top is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] [_inst_3 : IsSimpleGroup.{u1} G _inst_1] {H : Subgroup.{u1} G _inst_1}, (Subgroup.Normal.{u1} G _inst_1 H) -> (Or (Eq.{succ u1} (Subgroup.{u1} G _inst_1) H (Bot.bot.{u1} (Subgroup.{u1} G _inst_1) (Subgroup.hasBot.{u1} G _inst_1))) (Eq.{succ u1} (Subgroup.{u1} G _inst_1) H (Top.top.{u1} (Subgroup.{u1} G _inst_1) (Subgroup.hasTop.{u1} G _inst_1))))
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] [_inst_3 : IsSimpleGroup.{u1} G _inst_1] {H : Subgroup.{u1} G _inst_1}, (Subgroup.Normal.{u1} G _inst_1 H) -> (Or (Eq.{succ u1} (Subgroup.{u1} G _inst_1) H (Bot.bot.{u1} (Subgroup.{u1} G _inst_1) (Subgroup.instBotSubgroup.{u1} G _inst_1))) (Eq.{succ u1} (Subgroup.{u1} G _inst_1) H (Top.top.{u1} (Subgroup.{u1} G _inst_1) (Subgroup.instTopSubgroup.{u1} G _inst_1))))
Case conversion may be inaccurate. Consider using '#align subgroup.normal.eq_bot_or_eq_top Subgroup.Normal.eq_bot_or_eq_topₓ'. -/
@[to_additive]
theorem Subgroup.Normal.eq_bot_or_eq_top [IsSimpleGroup G] {H : Subgroup G} (Hn : H.Normal) :
    H = ⊥ ∨ H = ⊤ :=
  IsSimpleGroup.eq_bot_or_eq_top_of_normal H Hn
#align subgroup.normal.eq_bot_or_eq_top Subgroup.Normal.eq_bot_or_eq_top
#align add_subgroup.normal.eq_bot_or_eq_top AddSubgroup.Normal.eq_bot_or_eq_top

namespace IsSimpleGroup

@[to_additive]
instance {C : Type _} [CommGroup C] [IsSimpleGroup C] : IsSimpleOrder (Subgroup C) :=
  ⟨fun H => H.normal_of_comm.eq_bot_or_eq_top⟩

open _Root_.Subgroup

/- warning: is_simple_group.is_simple_group_of_surjective -> IsSimpleGroup.isSimpleGroup_of_surjective is a dubious translation:
lean 3 declaration is
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] {H : Type.{u2}} [_inst_3 : Group.{u2} H] [_inst_4 : IsSimpleGroup.{u1} G _inst_1] [_inst_5 : Nontrivial.{u2} H] (f : MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))), (Function.Surjective.{succ u1, succ u2} G H (coeFn.{max (succ u2) (succ u1), max (succ u1) (succ u2)} (MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) (fun (_x : MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) => G -> H) (MonoidHom.hasCoeToFun.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) f)) -> (IsSimpleGroup.{u2} H _inst_3)
but is expected to have type
  forall {G : Type.{u1}} [_inst_1 : Group.{u1} G] {H : Type.{u2}} [_inst_3 : Group.{u2} H] [_inst_4 : IsSimpleGroup.{u1} G _inst_1] [_inst_5 : Nontrivial.{u2} H] (f : MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))), (Function.Surjective.{succ u1, succ u2} G H (FunLike.coe.{max (succ u1) (succ u2), succ u1, succ u2} (MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) G (fun (_x : G) => (fun (x._@.Mathlib.Algebra.Hom.Group._hyg.2391 : G) => H) _x) (MulHomClass.toFunLike.{max u1 u2, u1, u2} (MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) G H (MulOneClass.toMul.{u1} G (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1)))) (MulOneClass.toMul.{u2} H (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) (MonoidHomClass.toMulHomClass.{max u1 u2, u1, u2} (MonoidHom.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))) G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3))) (MonoidHom.monoidHomClass.{u1, u2} G H (Monoid.toMulOneClass.{u1} G (DivInvMonoid.toMonoid.{u1} G (Group.toDivInvMonoid.{u1} G _inst_1))) (Monoid.toMulOneClass.{u2} H (DivInvMonoid.toMonoid.{u2} H (Group.toDivInvMonoid.{u2} H _inst_3)))))) f)) -> (IsSimpleGroup.{u2} H _inst_3)
Case conversion may be inaccurate. Consider using '#align is_simple_group.is_simple_group_of_surjective IsSimpleGroup.isSimpleGroup_of_surjectiveₓ'. -/
@[to_additive]
theorem isSimpleGroup_of_surjective {H : Type _} [Group H] [IsSimpleGroup G] [Nontrivial H]
    (f : G →* H) (hf : Function.Surjective f) : IsSimpleGroup H :=
  ⟨Nontrivial.exists_pair_ne, fun H iH =>
    by
    refine' (iH.comap f).eq_bot_or_eq_top.imp (fun h => _) fun h => _
    · rw [← map_bot f, ← h, map_comap_eq_self_of_surjective hf]
    · rw [← comap_top f] at h
      exact comap_injective hf h⟩
#align is_simple_group.is_simple_group_of_surjective IsSimpleGroup.isSimpleGroup_of_surjective
#align is_simple_add_group.is_simple_add_group_of_surjective IsSimpleAddGroup.isSimpleAddGroup_of_surjective

end IsSimpleGroup

end


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

! This file was ported from Lean 3 source module linear_algebra.matrix.hermitian
! leanprover-community/mathlib commit 9abfa6f0727d5adc99067e325e15d1a9de17fd8e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.PiL2

/-! # Hermitian matrices

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

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

## Main definition

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

## Tags

self-adjoint matrix, hermitian matrix

-/

namespace Matrix

variable {α β : Type _} {m n : Type _} {A : Matrix n n α}

open Matrix

-- mathport name: «expr⟪ , ⟫»
local notation "⟪" x ", " y "⟫" => @inner α _ _ x y

section Star

variable [Star α] [Star β]

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

theorem IsHermitian.eq {A : Matrix n n α} (h : A.IsHermitian) : Aᴴ = A :=
  h
#align matrix.is_hermitian.eq Matrix.IsHermitian.eq

protected theorem IsHermitian.isSelfAdjoint {A : Matrix n n α} (h : A.IsHermitian) :
    IsSelfAdjoint A :=
  h
#align matrix.is_hermitian.is_self_adjoint Matrix.IsHermitian.isSelfAdjoint

@[ext]
theorem IsHermitian.ext {A : Matrix n n α} : (∀ i j, star (A j i) = A i j) → A.IsHermitian :=
  by
  intro h
  ext (i j)
  exact h i j
#align matrix.is_hermitian.ext Matrix.IsHermitian.ext

theorem IsHermitian.apply {A : Matrix n n α} (h : A.IsHermitian) (i j : n) : star (A j i) = A i j :=
  congr_fun (congr_fun h _) _
#align matrix.is_hermitian.apply Matrix.IsHermitian.apply

theorem IsHermitian.ext_iff {A : Matrix n n α} : A.IsHermitian ↔ ∀ i j, star (A j i) = A i j :=
  ⟨IsHermitian.apply, IsHermitian.ext⟩
#align matrix.is_hermitian.ext_iff Matrix.IsHermitian.ext_iff

@[simp]
theorem IsHermitian.map {A : Matrix n n α} (h : A.IsHermitian) (f : α → β)
    (hf : Function.Semiconj f star star) : (A.map f).IsHermitian :=
  (conjTranspose_map f hf).symm.trans <| h.Eq.symm ▸ rfl
#align matrix.is_hermitian.map Matrix.IsHermitian.map

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

@[simp]
theorem isHermitian_transpose_iff (A : Matrix n n α) : Aᵀ.IsHermitian ↔ A.IsHermitian :=
  ⟨by
    intro h
    rw [← transpose_transpose A]
    exact is_hermitian.transpose h, IsHermitian.transpose⟩
#align matrix.is_hermitian_transpose_iff Matrix.isHermitian_transpose_iff

theorem IsHermitian.conjTranspose {A : Matrix n n α} (h : A.IsHermitian) : Aᴴ.IsHermitian :=
  h.transpose.map _ fun _ => rfl
#align matrix.is_hermitian.conj_transpose Matrix.IsHermitian.conjTranspose

@[simp]
theorem IsHermitian.submatrix {A : Matrix n n α} (h : A.IsHermitian) (f : m → n) :
    (A.submatrix f f).IsHermitian :=
  (conjTranspose_submatrix _ _ _).trans (h.symm ▸ rfl)
#align matrix.is_hermitian.submatrix Matrix.IsHermitian.submatrix

@[simp]
theorem isHermitian_submatrix_equiv {A : Matrix n n α} (e : m ≃ n) :
    (A.submatrix e e).IsHermitian ↔ A.IsHermitian :=
  ⟨fun h => by simpa using h.submatrix e.symm, fun h => h.submatrix _⟩
#align matrix.is_hermitian_submatrix_equiv Matrix.isHermitian_submatrix_equiv

end Star

section InvolutiveStar

variable [InvolutiveStar α]

@[simp]
theorem isHermitian_conjTranspose_iff (A : Matrix n n α) : Aᴴ.IsHermitian ↔ A.IsHermitian :=
  IsSelfAdjoint.star_iff
#align matrix.is_hermitian_conj_transpose_iff Matrix.isHermitian_conjTranspose_iff

/-- A block matrix `A.from_blocks B C D` is hermitian,
    if `A` and `D` are hermitian and `Bᴴ = C`. -/
theorem IsHermitian.fromBlocks {A : Matrix m m α} {B : Matrix m n α} {C : Matrix n m α}
    {D : Matrix n n α} (hA : A.IsHermitian) (hBC : Bᴴ = C) (hD : D.IsHermitian) :
    (A.fromBlocks B C D).IsHermitian :=
  by
  have hCB : Cᴴ = B := by rw [← hBC, conj_transpose_conj_transpose]
  unfold Matrix.IsHermitian
  rw [from_blocks_conj_transpose]
  congr <;> assumption
#align matrix.is_hermitian.from_blocks Matrix.IsHermitian.fromBlocks

/-- This is the `iff` version of `matrix.is_hermitian.from_blocks`. -/
theorem isHermitian_fromBlocks_iff {A : Matrix m m α} {B : Matrix m n α} {C : Matrix n m α}
    {D : Matrix n n α} :
    (A.fromBlocks B C D).IsHermitian ↔ A.IsHermitian ∧ Bᴴ = C ∧ Cᴴ = B ∧ D.IsHermitian :=
  ⟨fun h =>
    ⟨congr_arg toBlocks₁₁ h, congr_arg toBlocks₂₁ h, congr_arg toBlocks₁₂ h,
      congr_arg toBlocks₂₂ h⟩,
    fun ⟨hA, hBC, hCB, hD⟩ => IsHermitian.fromBlocks hA hBC hD⟩
#align matrix.is_hermitian_from_blocks_iff Matrix.isHermitian_fromBlocks_iff

end InvolutiveStar

section AddMonoid

variable [AddMonoid α] [StarAddMonoid α] [AddMonoid β] [StarAddMonoid β]

/-- A diagonal matrix is hermitian if the entries are self-adjoint -/
theorem isHermitian_diagonal_of_self_adjoint [DecidableEq n] (v : n → α) (h : IsSelfAdjoint v) :
    (diagonal v).IsHermitian :=
  (-- TODO: add a `pi.has_trivial_star` instance and remove the `funext`
        diagonal_conjTranspose
        v).trans <|
    congr_arg _ h
#align matrix.is_hermitian_diagonal_of_self_adjoint Matrix.isHermitian_diagonal_of_self_adjoint

/-- A diagonal matrix is hermitian if the entries have the trivial `star` operation
(such as on the reals). -/
@[simp]
theorem isHermitian_diagonal [TrivialStar α] [DecidableEq n] (v : n → α) :
    (diagonal v).IsHermitian :=
  isHermitian_diagonal_of_self_adjoint _ (IsSelfAdjoint.all _)
#align matrix.is_hermitian_diagonal Matrix.isHermitian_diagonal

@[simp]
theorem isHermitian_zero : (0 : Matrix n n α).IsHermitian :=
  isSelfAdjoint_zero _
#align matrix.is_hermitian_zero Matrix.isHermitian_zero

@[simp]
theorem IsHermitian.add {A B : Matrix n n α} (hA : A.IsHermitian) (hB : B.IsHermitian) :
    (A + B).IsHermitian :=
  IsSelfAdjoint.add hA hB
#align matrix.is_hermitian.add Matrix.IsHermitian.add

end AddMonoid

section AddCommMonoid

variable [AddCommMonoid α] [StarAddMonoid α]

theorem isHermitian_add_transpose_self (A : Matrix n n α) : (A + Aᴴ).IsHermitian :=
  isSelfAdjoint_add_star_self A
#align matrix.is_hermitian_add_transpose_self Matrix.isHermitian_add_transpose_self

theorem isHermitian_transpose_add_self (A : Matrix n n α) : (Aᴴ + A).IsHermitian :=
  isSelfAdjoint_star_add_self A
#align matrix.is_hermitian_transpose_add_self Matrix.isHermitian_transpose_add_self

end AddCommMonoid

section AddGroup

variable [AddGroup α] [StarAddMonoid α]

@[simp]
theorem IsHermitian.neg {A : Matrix n n α} (h : A.IsHermitian) : (-A).IsHermitian :=
  IsSelfAdjoint.neg h
#align matrix.is_hermitian.neg Matrix.IsHermitian.neg

@[simp]
theorem IsHermitian.sub {A B : Matrix n n α} (hA : A.IsHermitian) (hB : B.IsHermitian) :
    (A - B).IsHermitian :=
  IsSelfAdjoint.sub hA hB
#align matrix.is_hermitian.sub Matrix.IsHermitian.sub

end AddGroup

section NonUnitalSemiring

variable [NonUnitalSemiring α] [StarRing α] [NonUnitalSemiring β] [StarRing β]

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

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

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

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

end NonUnitalSemiring

section Semiring

variable [Semiring α] [StarRing α] [Semiring β] [StarRing β]

/-- Note this is more general for matrices than `is_self_adjoint_one` as it does not
require `fintype n`, which is necessary for `monoid (matrix n n R)`. -/
@[simp]
theorem isHermitian_one [DecidableEq n] : (1 : Matrix n n α).IsHermitian :=
  conjTranspose_one
#align matrix.is_hermitian_one Matrix.isHermitian_one

end Semiring

section CommRing

variable [CommRing α] [StarRing α]

theorem IsHermitian.inv [Fintype m] [DecidableEq m] {A : Matrix m m α} (hA : A.IsHermitian) :
    A⁻¹.IsHermitian := by simp [is_hermitian, conj_transpose_nonsing_inv, hA.eq]
#align matrix.is_hermitian.inv Matrix.IsHermitian.inv

@[simp]
theorem isHermitian_inv [Fintype m] [DecidableEq m] (A : Matrix m m α) [Invertible A] :
    A⁻¹.IsHermitian ↔ A.IsHermitian :=
  ⟨fun h => by
    rw [← inv_inv_of_invertible A]
    exact is_hermitian.inv h, IsHermitian.inv⟩
#align matrix.is_hermitian_inv Matrix.isHermitian_inv

theorem IsHermitian.adjugate [Fintype m] [DecidableEq m] {A : Matrix m m α} (hA : A.IsHermitian) :
    A.adjugate.IsHermitian := by simp [is_hermitian, adjugate_conj_transpose, hA.eq]
#align matrix.is_hermitian.adjugate Matrix.IsHermitian.adjugate

end CommRing

section IsROrC

open IsROrC

variable [IsROrC α] [IsROrC β]

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

/-- The diagonal elements of a complex hermitian matrix are real. -/
theorem IsHermitian.coe_re_diag {A : Matrix n n α} (h : A.IsHermitian) :
    (fun i => (re (A.diag i) : α)) = A.diag :=
  funext h.coe_re_apply_self
#align matrix.is_hermitian.coe_re_diag Matrix.IsHermitian.coe_re_diag

/-- A matrix is hermitian iff the corresponding linear map is self adjoint. -/
theorem isHermitian_iff_isSymmetric [Fintype n] [DecidableEq n] {A : Matrix n n α} :
    IsHermitian A ↔ A.toEuclideanLin.IsSymmetric :=
  by
  rw [LinearMap.IsSymmetric, (PiLp.equiv 2 fun _ : n => α).symm.Surjective.Forall₂]
  simp only [to_euclidean_lin_pi_Lp_equiv_symm, EuclideanSpace.inner_piLp_equiv_symm, to_lin'_apply,
    star_mul_vec, dot_product_mul_vec]
  constructor
  · rintro (h : Aᴴ = A) x y
    rw [h]
  · intro h
    ext (i j)
    simpa only [(Pi.single_star i 1).symm, ← star_mul_vec, mul_one, dot_product_single,
      single_vec_mul, star_one, one_mul] using
      h (@Pi.single _ _ _ (fun i => AddZeroClass.toHasZero α) i 1)
        (@Pi.single _ _ _ (fun i => AddZeroClass.toHasZero α) j 1)
#align matrix.is_hermitian_iff_is_symmetric Matrix.isHermitian_iff_isSymmetric

end IsROrC

end Matrix


import data.real.nnreal

import for_mathlib.group_with_zero
import for_mathlib.linear_ordered_comm_group

/-!
# Linearly ordered commutative groups with a zero element adjoined

This file sets up a special class of linearly ordered commutative monoids
that show up as the target of so-called “valuations” in algebraic number theory.

Usually, in the informal literature, these objects are constructed
by taking a linearly ordered commutative group Γ and formally adjoining a zero element: Γ ∪ {0}.

The disadvantage is that a type such as `nnreal` is not of that form,
whereas it is a very common target for valuations.
The solutions is to use a typeclass, and that is exactly what we do in this file.

We show that both `with_zero Γ` and `nnreal` are instances of `linear_ordered_comm_group_with_zero`.
-/

set_option old_structure_cmd true

/-- A linearly ordered commutative group with zero
is a linearly ordered commutative monoid with a zero element
such that all nonzero elements are invertible.-/
class linear_ordered_comm_group_with_zero (α : Type*)
  extends linear_ordered_comm_monoid α, comm_group_with_zero α :=
(zero_le' : ∀ a, (0:α) ≤ a)

namespace with_zero

/-- Adjoining a zero element to a linearly ordered commutative group
gives a linearly ordered commutative group with zero.-/
instance (α : Type*) [linear_ordered_comm_group α] [decidable_eq α] :
  linear_ordered_comm_group_with_zero (with_zero α) :=
{ zero_le' := λ a, with_zero.zero_le,
  inv_zero := rfl,
  mul_inv_cancel := λ a h, mul_right_inv a h,
  .. (infer_instance : linear_ordered_comm_monoid (with_zero α)),
  .. (infer_instance : has_inv (with_zero α)),
  .. (infer_instance : zero_ne_one_class (with_zero α)),
  .. (infer_instance : mul_zero_class (with_zero α)) }

end with_zero

namespace linear_ordered_comm_group_with_zero
variables (α : Type*) [linear_ordered_comm_group_with_zero α]

/--The units of a linearly ordered commutative group are linearly ordered.-/
instance units.linear_order : linear_order (units α) :=
linear_order.lift (coe : units α → α) units.ext infer_instance

/--The units of a linearly ordered commutative group with zero
form a linearly ordered commutative group.-/
instance units.linear_ordered_comm_group : linear_ordered_comm_group (units α) :=
{ mul_le_mul_left := λ a b h c, mul_le_mul_left h _,
  .. units.linear_order α,
  .. (infer_instance : comm_group (units α))}

end linear_ordered_comm_group_with_zero

namespace linear_ordered_structure
variables {α : Type*} [group_with_zero α]
variables {a b c d : α}

lemma ne_zero_iff_exists : a ≠ 0 ↔ ∃ u : units α, a = u :=
begin
  split,
  { intro h, use [group_with_zero.mk₀ a h], refl },
  { rintro ⟨u, rfl⟩, exact group_with_zero.unit_ne_zero u }
end

end linear_ordered_structure

namespace linear_ordered_structure
variables {α : Type*} [linear_ordered_comm_group_with_zero α]
variables {a b c d : α}

open group_with_zero

local attribute [instance] classical.prop_decidable
local attribute [instance, priority 0] classical.DLO

@[simp] lemma zero_le {a : α} : 0 ≤ a :=
linear_ordered_comm_group_with_zero.zero_le' a

@[simp] lemma le_zero_iff : a ≤ 0 ↔ a = 0 :=
⟨λ h, le_antisymm h zero_le, λ h, h ▸ le_refl _⟩

lemma le_of_le_mul_right (h : c ≠ 0) (hab : a * c ≤ b * c) : a ≤ b :=
by simpa [h] using linear_ordered_structure.mul_le_mul_right hab c⁻¹

lemma le_mul_inv_of_mul_le (h : c ≠ 0) (hab : a * c ≤ b) : a ≤ b * c⁻¹ :=
le_of_le_mul_right h (by simpa [h] using hab)

lemma mul_inv_le_of_le_mul (h : c ≠ 0) (hab : a ≤ b * c) : a * c⁻¹ ≤ b :=
le_of_le_mul_right h (by simpa [h] using hab)

lemma div_le_div' (a b c d : α) (hb : b ≠ 0) (hd : d ≠ 0) :
  a * b⁻¹ ≤ c * d⁻¹ ↔ a * d ≤ c * b :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  by_cases hc : c = 0,
  { replace hb := inv_ne_zero' _ hb,
    simp [hb, hc, hd], },
  exact (div_le_div (mk₀ a ha) (mk₀ b hb) (mk₀ c hc) (mk₀ d hd)),
end

lemma lt_of_mul_lt_mul_left' {a b c : α} (h : a * b < a * c) : b < c :=
begin
  by_cases ha : a = 0, { contrapose! h, simp [ha] },
  by_cases hc : c = 0, { contrapose! h, simp [hc] },
  by_cases hb : b = 0, { contrapose! hc, simpa [hb] using hc },
  exact linear_ordered_structure.lt_of_mul_lt_mul_left (mk₀ a ha) (mk₀ b hb) (mk₀ c hc) h
end

/-- Every linearly ordered commutative group with zero is an ordered commutative monoid.-/
instance : actual_ordered_comm_monoid α :=
{ lt_of_mul_lt_mul_left := λ a b c, lt_of_mul_lt_mul_left',
  .. ‹linear_ordered_comm_group_with_zero α› }

@[move_cast] lemma coe_min (x y : units α) :
  ((min x y : units α) : α) = min (x : α) (y : α) :=
begin
  by_cases h: x ≤ y,
  { simp [min_eq_left, h] },
  { simp [min_eq_right, le_of_not_le h] }
end

lemma ne_zero_of_lt (h : b < a) : a ≠ 0 :=
by { contrapose! h, simp [h] }

@[simp] lemma zero_lt_unit (u : units α) : (0 : α) < u :=
by { have h := group_with_zero.unit_ne_zero u, contrapose! h, simpa using h }

lemma mul_lt_mul' : a < b → c < d → a*c < b*d :=
begin
  intros hab hcd,
  let b' := group_with_zero.mk₀ b (ne_zero_of_lt hab),
  let d' := group_with_zero.mk₀ d (ne_zero_of_lt hcd),
  have hbd : 0 < b * d,
  { have h := group_with_zero.unit_ne_zero (b' * d'), contrapose! h, simpa using h },
  by_cases ha : a = 0,
  { simp [ha, hbd], },
  by_cases hc : c = 0,
  { simp [hc, hbd], },
  let a' := group_with_zero.mk₀ a ha,
  let c' := group_with_zero.mk₀ c hc,
  show a' * c' < b' * d',
  exact linear_ordered_structure.mul_lt_mul hab hcd
end

lemma mul_inv_lt_of_lt_mul' {x y z : α} (h : x < y*z) : x*z⁻¹ < y :=
begin
  by_cases hx : x = 0, { contrapose! h, simp * at *, },
  by_cases hy : y = 0, { contrapose! h, simp [hy] },
  by_cases hz : z = 0, { contrapose! h, simp [hz] },
  change (group_with_zero.mk₀ _ hx) < (group_with_zero.mk₀ _ hy) * (group_with_zero.mk₀ _ hz) at h,
  exact mul_inv_lt_of_lt_mul h
end
.

lemma mul_lt_right' (γ : α) (h : a < b) (hγ : γ ≠ 0) : a*γ < b*γ :=
begin
  have hb : b ≠ 0 := ne_zero_of_lt h,
  by_cases ha : a = 0,
  { by_contra H, simp [ha] at H, tauto, },
  change (group_with_zero.mk₀ _ ha) < (group_with_zero.mk₀ _ hb) at h,
  exact linear_ordered_structure.mul_lt_right (group_with_zero.mk₀ _ hγ) h
end

lemma inv_lt_inv (ha : a ≠ 0) (hb : b ≠ 0) :
  a⁻¹ < b⁻¹ ↔ b < a :=
begin
  suffices : ∀ {x y : α}, x ≠ 0 → y ≠ 0 → x < y → y⁻¹ < x⁻¹,
  { refine ⟨_, this hb ha⟩, intro h, rw [← inv_inv'' a, ← inv_inv'' b],
    apply this _ _ h; solve_by_elim [inv_ne_zero'], },
  clear ha hb a b,
  intros x y hx hy h,
  have hx' : x⁻¹ ≠ 0 := by solve_by_elim [inv_ne_zero'],
  have hy' : y⁻¹ ≠ 0 := by solve_by_elim [inv_ne_zero'],
  replace h := linear_ordered_structure.mul_lt_right' _ h hx',
  replace h := linear_ordered_structure.mul_lt_right' _ h hy',
  rw [mul_inv_cancel' _ hx, _root_.one_mul] at h,
  erw [mul_comm y x⁻¹, _root_.mul_assoc, mul_inv_cancel' _ hy, _root_.mul_one] at h,
  exact h
end

lemma inv_le_inv (ha : a ≠ 0) (hb : b ≠ 0) :
  a⁻¹ ≤ b⁻¹ ↔ b ≤ a :=
begin
  have := not_iff_not_of_iff (inv_lt_inv hb ha),
  push_neg at this,
  exact this
end

end linear_ordered_structure


import .subset

universes u v

namespace subset

section
parameters {A : Type u} {B : Type v} (F : subset A → subset B)
def cocontinuous :=
  ∀ (Ix : Type) (f : Ix → subset A),
    F (union_ix f) = union_ix (F ∘ f)

def cocontinuous_inh :=
  ∀ (Ix : Type) [inhabited Ix] (f : Ix → subset A),
    F (union_ix f) = union_ix (F ∘ f)

def continuous :=
  ∀ (Ix : Type) (f : Ix → subset A),
    F (intersection_ix f) = intersection_ix (F ∘ f)

def continuous_inh :=
  ∀ (Ix : Type) [inhabited Ix] (f : Ix → subset A),
    F (intersection_ix f) = intersection_ix (F ∘ f)

end

section
parameter {A : Type u}

/-- Given a function over subsets, the greatest fixpoint
    for that function is the union of all sets that might
    be produced by applying the fixpoint-/
def greatest_fixpoint (F : subset A → subset A) : subset A
  := union_st (λ P, P ≤ F P)

/-- Given a function over subsets, the greatest fixpoint
    for that function is the intersection of all sets that might
    be produced by applying the fixpoint-/
def least_fixpoint (F : subset A → subset A) : subset A
:= intersection_st (λ P, F P ≤ P)

section
parameters (F : subset A → subset A) (Fmono : monotone F)
include Fmono

/-- Applying F to a greatest fixpoint of F results in
    a set that includes the greatest fixpoint
    this should likely be an internal only lemma -/
lemma greatest_fixpoint_postfixed
  : greatest_fixpoint F ≤ F (greatest_fixpoint F)
:= begin
intros tr H, induction H, apply Fmono, tactic.swap,
apply a, assumption, clear a_1 tr,
intros x H, constructor; assumption,
end

/-- Applying F to a greatest fixpoint of F results in
    the same set --/
lemma greatest_fixpoint_fixed
  : greatest_fixpoint F = F (greatest_fixpoint F)
:= begin
apply included_eq,
{ apply greatest_fixpoint_postfixed, assumption },
{ intros x H, constructor, apply Fmono,
  apply greatest_fixpoint_postfixed, assumption,
  assumption
}
end

/-- Applying a function to the fixpoint is no smaller than the fixpoint -/
lemma least_fixpoint_prefixed
  : F (least_fixpoint F) ≤ least_fixpoint F
:= begin
unfold least_fixpoint intersection_st,
intros x H P HP, apply HP, revert x H,
apply Fmono, intros x H, apply H, dsimp, assumption
end

/-- Applying a function to the fixpoint does not change the set -/
lemma least_fixpoint_fixed
  : F (least_fixpoint F) = least_fixpoint F
:= begin
apply included_eq,
{ apply least_fixpoint_prefixed, assumption },
{ intros x H,
  apply H, dsimp, apply Fmono,
  apply least_fixpoint_prefixed, assumption,
}
end

end

lemma greatest_fixpoint_and_le (F G : subset A → subset A)
  : greatest_fixpoint (λ X, F X ∩ G X)
  ≤ greatest_fixpoint F ∩ greatest_fixpoint G
:= begin
unfold greatest_fixpoint,
apply included_trans,
tactic.swap,
apply union_st_bintersection,
apply union_st_mono, intros x H,
constructor; intros z Hz;
specialize (H z Hz); induction H with H1 H2; assumption
end

/-- A function F from subset to subset is finitary if
    an arbitrary application can be described as the union of some number of applications to finite arguments -/
def finitary (F : subset A → subset A) : Prop :=
  ∀ x, F x = union_ix_st (λ xs : list A, from_list xs ≤ x) (λ xs, F (from_list xs))

/-- Finitary functions are monotone -/
lemma finitary_monotone (F : subset A → subset A)
  (Ffin : finitary F) : monotone F :=
begin
intros P Q PQ,
repeat { rw Ffin },
intros x H,
induction H,
constructor, apply included_trans; assumption,
assumption,
end

def chain_cont (F : subset A → subset A) :=
  ∀ (f : ℕ → subset A),
  (∀ x y : ℕ, x ≤ y → f x ≤ f y)
  → F (union_ix f) = union_ix (F ∘ f)

def chain_cocont (F : subset A → subset A) :=
  ∀ (f : ℕ → subset A),
  (∀ x y : ℕ, x ≤ y → f y ≤ f x)
  → F (intersection_ix f) = intersection_ix (F ∘ f)

protected def simple_chain (P Q : subset A) : ℕ → subset A
| 0 := P
| (nat.succ n) := Q

private lemma simple_chain_mono
  {P Q : subset A}  (PQ : P ≤ Q) (x y : ℕ)
  (H : x ≤ y) : simple_chain P Q x ≤ simple_chain P Q y
:= begin
induction H, apply included_refl,
apply included_trans, assumption,
clear ih_1 a x y,
cases b; simp [subset.simple_chain],
intros x Px, apply PQ, assumption,
apply included_refl,
end

private lemma simple_chain_anti
  {P Q : subset A}  (PQ : Q ≤ P) (x y : ℕ)
  (H : x ≤ y) : simple_chain P Q y ≤ simple_chain P Q x
:= begin
induction H, apply included_refl,
apply included_trans, tactic.swap, assumption,
clear ih_1 a x y,
cases b; simp [subset.simple_chain],
intros x Px, apply PQ, assumption,
apply included_refl,
end

lemma chain_cont_union {F : subset A → subset A}
  (H : chain_cont F) {P Q : subset A}
  (PQ : P ≤ Q)
  : F (P ∪ Q) = F P ∪ F Q
:= begin
unfold chain_cont at H,
specialize (H (subset.simple_chain P Q) (simple_chain_mono PQ)),
transitivity (F (union_ix (subset.simple_chain P Q))),
f_equal,
apply included_eq, rw imp_or at PQ, rw PQ,
intros x Qx, apply (union_ix_st.mk 1),
trivial, dsimp [subset.simple_chain], assumption,
intros x Hx, induction Hx with n _ Hn,
cases n; dsimp [subset.simple_chain] at Hn,
apply or.inl, assumption, apply or.inr, assumption,
rw H, clear H, apply included_eq,
intros x Hx, induction Hx with n _ Hn,
cases n; dsimp [function.comp, subset.simple_chain] at Hn,
apply or.inl, assumption, apply or.inr, assumption,
intros x Hx, induction Hx with Hx Hx,
apply (union_ix_st.mk 0), trivial,
dsimp [function.comp, subset.simple_chain], assumption,
apply (union_ix_st.mk 1), trivial,
dsimp [function.comp, subset.simple_chain], assumption,
end

lemma chain_cocont_intersection {F : subset A → subset A}
  (H : chain_cocont F) {P Q : subset A}
  (PQ : P ≤ Q)
  : F (P ∩ Q) = F P ∩ F Q
:= begin
unfold chain_cocont at H,
specialize (H (subset.simple_chain Q P) (simple_chain_anti PQ)),
transitivity (F (intersection_ix (subset.simple_chain Q P))),
-- f_equal -- TODO: FIX, the tactic isn't working here
apply congr_arg,
apply included_eq,
intros x PQx n, induction PQx with Px Qx,
cases n; dsimp [subset.simple_chain]; assumption,
rw imp_and at PQ, rw ← PQ,
intros x Hx, apply (Hx 1),
rw H, clear H, apply included_eq,
intros x Hx, constructor, apply (Hx 1),
apply (Hx 0),
intros x FPQx, induction FPQx with FPx FQx,
intros n,
cases n; dsimp [function.comp, subset.simple_chain]; assumption,
end

lemma chain_cont_mono {F : subset A → subset A}
  (H : chain_cont F) : monotone F
:= begin
unfold monotone, intros P Q PQ,
rw imp_or, rw ← chain_cont_union,
rw imp_or at PQ, rw PQ, assumption, assumption
end

lemma chain_cocont_mono {F : subset A → subset A}
  (H : chain_cocont F) : monotone F
  :=
begin
unfold monotone, intros P Q PQ,
rw imp_and, rw ← chain_cocont_intersection,
rw imp_and at PQ, rw ← PQ, assumption, assumption
end

/-- Repeatedly apply a function f starting with x. -/
def iterate {A : Type u} (f : A → A) (x : A) : ℕ → A
| 0 := x
| (nat.succ n) := f (iterate n)

/-- The least fixpoint is described by the union of all sets
    indexed by the number of iterations
-/
def least_fixpointn (F : subset A → subset A) : subset A
  := union_ix (iterate F ff)

/-- The greatest fixpoint is described by the intersection of all sets
    indexed by the number of iterations
-/
def greatest_fixpointn (F : subset A → subset A) : subset A
  := intersection_ix (iterate F tt)

lemma least_fixpointn_postfixed
  {F : subset A → subset A}
  (Fmono : monotone F)
  : least_fixpointn F ≤ F (least_fixpointn F)
:= begin
intros x H, induction H with n _ Hn,
cases n; simp [iterate] at Hn, exfalso, apply Hn,
apply Fmono, tactic.swap, assumption,
clear Hn x,
intros x H, constructor, constructor, assumption,
end

lemma greatest_fixpointn_prefixed
  {F : subset A → subset A}
  (Fmono : monotone F)
  : F (greatest_fixpointn F) ≤ greatest_fixpointn F
:= begin
intros x H n,
cases n; simp [iterate], apply Fmono,
tactic.swap, assumption, clear H x,
intros x H, apply H,
end

lemma continuous_chain_cocont {F : subset A → subset A}
  (H : continuous_inh F) : chain_cocont F :=
begin
intros f fmono, apply H
end

lemma cocontinuous_chain_cont {F : subset A → subset A}
  (H : cocontinuous F) : chain_cont F :=
begin
intros f fmono, apply H
end

lemma and_continuous_r (P : subset A)
  : continuous_inh (bintersection P)
:= begin
unfold continuous_inh, intros Ix inh f, apply included_eq,
{ intros x H ix, dsimp [function.comp],
  induction H with Hl Hr, constructor, assumption,
  apply Hr  },
{ intros x H, constructor,
  specialize (H inh.default),
  dsimp [function.comp] at H,
  induction H with Hl Hr, assumption,
  intros ix, specialize (H ix),
  induction H with Hl Hr, assumption, }
end

lemma and_cocontinuous_r (P : subset A)
  : cocontinuous (bintersection P)
:= begin
unfold cocontinuous, intros Ix f, apply included_eq,
{ intros x H, dsimp [function.comp],
  induction H with Hl Hr, induction Hr,
  constructor, trivial, constructor; assumption,
},
{ intros x H, induction H, induction a_1, constructor,
  assumption, constructor; assumption
}
end

lemma or_continuous_r (P : subset A)
  [decP : decidable_pred P]
  : continuous (bunion P)
:= begin
unfold continuous, intros Ix f,
apply included_eq,
{ intros x H ix, dsimp [function.comp],
  induction H with H H,
  apply or.inl, assumption,
  apply or.inr, apply H, },
{ intros x Hx,
  have H := decP x, induction H with HP HP,
  { apply or.inr, intros n,
    specialize (Hx n), induction Hx with Hl Hr,
    contradiction, assumption },
  { apply or.inl, assumption }
}
end

lemma or_cocontinuous_r (P : subset A)
  : cocontinuous_inh (bunion P)
:= begin
unfold cocontinuous_inh, intros Ix inh f,
apply included_eq,
{ intros x H, dsimp [function.comp],
  induction H with H H,
  constructor, trivial, apply or.inl,
  assumption, apply inh.default,
  induction H, constructor, trivial,
  apply or.inr, assumption },
{ intros x Hx,
  induction Hx with ix _ H', induction H',
  apply or.inl, assumption,
  apply or.inr, constructor, trivial, assumption,
}
end

lemma iterate_mono_tt_succ {F : subset A → subset A}
  (Fmono : monotone F) (n : ℕ)
  : iterate F tt n.succ ≤ iterate F tt n
:= begin
dsimp [iterate], induction n; dsimp [iterate],
apply tt_top, apply Fmono, assumption,
end

lemma iterate_mono_tt_n {F : subset A → subset A}
  (Fmono : monotone F) (x y : ℕ)
  (H : x ≤ y)
  : iterate F tt y ≤ iterate F tt x
:= begin
induction H, apply included_refl,
simp [iterate], apply included_trans,
apply Fmono, assumption,
apply iterate_mono_tt_succ,
apply Fmono,
end

lemma greatest_fixpointn_fixed
  {F : subset A → subset A}
  (Fcont : chain_cocont F)
  : F (greatest_fixpointn F) = greatest_fixpointn F
:= begin
apply included_eq, apply greatest_fixpointn_prefixed,
apply chain_cocont_mono,
assumption,
unfold greatest_fixpointn,
rw Fcont, intros x Hx,
intros n, dsimp [function.comp],
specialize (Hx n.succ), apply Hx,
intros, apply iterate_mono_tt_n,
apply chain_cocont_mono, assumption,
assumption
end

lemma le_greatest_fixpoint {P : subset A}
  {F : subset A → subset A}
  (H : P ≤ F P)
  : P ≤ greatest_fixpoint F
:= begin
intros x H', constructor, apply H, assumption
end

lemma least_fixpoint_le {P : subset A}
  {F : subset A → subset A}
  (H : F P ≤ P)
  : least_fixpoint F ≤ P
:= begin
intros x H', apply H', apply H
end

lemma greatest_fixpoint_le {P : subset A}
  {F : subset A → subset A} (Fmono : monotone F)
  (H : ∀ Q, Q = F Q → Q ≤ P)
  : greatest_fixpoint F ≤ P
:= begin
apply (H _ (greatest_fixpoint_fixed F Fmono))
end

lemma le_least_fixpoint {P : subset A}
  {F : subset A → subset A} (Fmono : monotone F)
  (H : ∀ Q, F Q = Q → P ≤ Q)
  : P ≤ least_fixpoint F
:= begin
apply (H _ (least_fixpoint_fixed F Fmono))
end

lemma iterate_mono_ff_succ {F : subset A → subset A}
  (Fmono : monotone F) (n : ℕ)
  : iterate F ff n ≤ iterate F ff n.succ
:= begin
dsimp [iterate], induction n; dsimp [iterate],
apply ff_bot, apply Fmono, assumption,
end

lemma iterate_mono_ff_n {F : subset A → subset A}
  (Fmono : monotone F) (x y : ℕ)
  (H : x ≤ y)
  : iterate F ff x ≤ iterate F ff y
:= begin
induction H, apply included_refl,
simp [iterate], apply included_trans,
apply ih_1,
apply iterate_mono_ff_succ,
apply Fmono,
end

lemma iterate_mono {F : subset A → subset A}
  (Fmono : monotone F) {P Q : subset A}
  (PQ : P ≤ Q) (n : ℕ)
  : iterate F P n ≤ iterate F Q n
:= begin
induction n; simp [iterate],
{ assumption },
{ apply Fmono, assumption }
end

lemma iterate_mono2 {F G : subset A → subset A}
  {P : subset A}
  (Fmono : monotone F)
  (FG : ∀ x, F x ≤ G x)
  (n : ℕ)
  : iterate F P n ≤ iterate G P n
:= begin
induction n; simp [iterate],
{ apply included_refl },
{ apply included_trans, apply Fmono, assumption,
  apply FG }
end

lemma least_fixpointn_fixed
  {F : subset A → subset A}
  (Fcoc : chain_cont F)
  : least_fixpointn F = F (least_fixpointn F)
:= begin
apply included_eq, apply least_fixpointn_postfixed,
apply chain_cont_mono, assumption,
unfold least_fixpointn,
rw Fcoc, intros x Hx,
induction Hx with n _ Hn,
dsimp [function.comp] at Hn,
constructor, assumption,
tactic.swap, exact n.succ,
apply Hn, intros,
apply iterate_mono_ff_n,
apply chain_cont_mono, assumption, assumption
end

/-- The fixpoint defined by greatest_fixpointn is actually a greatest fixpoint-/
lemma greatest_fixpointn_same
  {F : subset A → subset A}
  (Fcoc : chain_cocont F)
  : greatest_fixpointn F = greatest_fixpoint F
:= begin
apply included_eq,
apply le_greatest_fixpoint,
rw (greatest_fixpointn_fixed Fcoc),
apply (included_refl (greatest_fixpointn F)),
apply (greatest_fixpoint_le _ _),
apply chain_cocont_mono, assumption,
intros Q HQ, intros x Qx,
have HQx : ∀ n, Q = iterate F Q n,
intros n, induction n; simp [iterate],
rw ← ih_1, assumption,
intros n, apply iterate_mono,
apply chain_cocont_mono, assumption,
tactic.swap, rw (HQx n) at Qx,
assumption, apply tt_top
end
/-- The fixpoint defined by least_fixpointn is actually a least fixpoint-/
lemma least_fixpointn_same
  {F : subset A → subset A}
  (Fchain_cont : chain_cont F)
  : least_fixpointn F = least_fixpoint F
:= begin
apply included_eq, tactic.swap,
apply least_fixpoint_le,
rw ← (least_fixpointn_fixed Fchain_cont),
apply included_refl,
apply (le_least_fixpoint _ _),
apply chain_cont_mono, assumption,
intros Q HQ, intros x Qx,
have HQx : ∀ n, Q = iterate F Q n,
intros n, induction n; simp [iterate],
rw ← ih_1, symmetry, assumption,
unfold least_fixpointn at Qx,
induction Qx with n _ Hn,
rw (HQx n), apply iterate_mono,
apply chain_cont_mono, assumption,
tactic.swap, assumption, apply ff_bot,
end

lemma greatest_fixpoint_mono
  {F G : subset A → subset A}
  (H : ∀ P, F P ≤ G P)
  : greatest_fixpoint F ≤ greatest_fixpoint G
:= begin
intros x Hx, induction Hx,
constructor, tactic.swap, apply a_1,
dsimp, apply included_trans, apply a, apply H
end

lemma greatest_fixpointn_mono
  {F G : subset A → subset A}
  (Fmono : monotone F)
  (H : ∀ P, F P ≤ G P)
  : greatest_fixpointn F ≤ greatest_fixpointn G
:= begin
unfold greatest_fixpointn,
intros x H n, specialize (H n),
revert H, apply iterate_mono2,
assumption, assumption
end

lemma and_functional_mono
  {F G : subset A → subset A}
  (Fmono : monotone F) (Gmono : monotone G)
  : monotone (λ X, F X ∩ G X)
:= begin
  unfold monotone, intros P Q PQ, apply bintersection_mono,
  apply Fmono, assumption, apply Gmono, assumption
end

lemma greatest_fixpointn_and_le (F G : subset A → subset A)
  (Fmono : monotone F) (Gmono : monotone G)
  : greatest_fixpointn (λ X, F X ∩ G X)
  ≤ greatest_fixpointn F ∩ greatest_fixpointn G
:= begin
intros x H,
  constructor,
  { revert H,
  apply greatest_fixpointn_mono, apply and_functional_mono,
  apply Fmono, apply Gmono,
  intros P x H, induction H with Hl Hr, apply Hl,
  },
  { revert H,
  apply greatest_fixpointn_mono, apply and_functional_mono,
  apply Fmono, apply Gmono,
  intros P x H, induction H with Hl Hr, apply Hr,
  }
end

lemma tImp_cocontinuous_l {Ix : Type}
  (P : Ix → subset A) (Q : subset A)
  : (union_ix P => Q) = intersection_ix (λ ix, P ix => Q)
:= begin
apply included_eq; intros x Hx,
{ intros n Pn, apply Hx,
  constructor, trivial, assumption },
{ intros H, induction H, apply Hx, assumption }
end

end

end subset


import tactic -- hide
open function nat -- hide

/-
## The `apply` tactic

If we have a proof of the implication `h : P → Q` and we want to prove `Q`, then it is enough to prove `P`
instead. In mathematics, we may say: "To prove `Q` it suffices to prove `P`, since by `h` we know that
it implies `Q`". We then forget about `Q` and prove `P` instead.

In *Lean*, this reasoning is realised by the `apply` tactic. If the goal is `Q` and we do `apply h,`,
the goal gets changed to `P` instead. Note that it may well be that `P` is impossible to prove,
so we might be able to backtrack if we `apply` the wrong statements...
-/

/- Lemma : no-side-bar
If $P$ implies $Q$ and we know $P$, then we can prove $Q$.
-/
lemma l5 (P Q : Prop) (h : P → Q) (hp : P) : Q :=
begin
  apply h,
  assumption,

end


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Data.String.Defs
import Mathlib.Data.String.Lemmas
import Mathlib.Algebra.Group.Defs
import Mathlib.Algebra.Ring.Basic
import Mathlib.Data.Equiv.Basic
import Timelib.NanoPrecision.Duration.SignedDuration

/--
A unsigned duration in nanoseconds, implemented as a `Nat`.

Arithmetic behaves as on `Nat`.
-/
structure UnsignedDuration where
  val : Nat
deriving DecidableEq, Ord, Repr

instance : Coe UnsignedDuration SignedDuration where
  coe u := ⟨u.val⟩

instance : Add UnsignedDuration where
  add a b := ⟨a.val + b.val⟩

@[simp]
theorem UnsignedDuration.add_def (a b : UnsignedDuration) : a + b = ⟨a.val + b.val⟩ := rfl

instance : Sub UnsignedDuration where
  sub a b := ⟨a.val - b.val⟩

@[simp]
theorem UnsignedDuration.sub_def (a b : UnsignedDuration) : a - b = ⟨a.val - b.val⟩ := rfl

instance : HMul UnsignedDuration Nat UnsignedDuration where
  hMul d n := ⟨d.val * n⟩

instance : HMod UnsignedDuration Nat UnsignedDuration where
  hMod a n := ⟨a.val % n⟩

instance : HDiv UnsignedDuration Nat UnsignedDuration where
  hDiv a b := ⟨a.val / b⟩

instance : HPow UnsignedDuration Nat UnsignedDuration where
  hPow a b := ⟨a.val ^ b⟩

instance : LT UnsignedDuration where
  lt := InvImage Nat.lt UnsignedDuration.val

instance : LE UnsignedDuration where
  le := InvImage Nat.le UnsignedDuration.val

theorem UnsignedDuration.le_def {d₁ d₂ : UnsignedDuration} : (d₁ <= d₂) = (d₁.val <= d₂.val) := rfl
theorem UnsignedDuration.lt_def {d₁ d₂ : UnsignedDuration} : (d₁ < d₂) = (d₁.val < d₂.val) := rfl

theorem UnsignedDuration.val_eq_of_eq : ∀ {d1 d2 : UnsignedDuration} (h : d1 = d2), d1.val = d2.val
| ⟨_⟩, _, rfl => rfl

theorem UnsignedDuration.eq_of_val_eq : ∀ {d1 d2 : UnsignedDuration} (h : d1.val = d2.val), d1 = d2
| ⟨_⟩, _, rfl => rfl

instance (a b : UnsignedDuration) : Decidable (a < b) := inferInstanceAs (Decidable (a.val < b.val))
instance (a b : UnsignedDuration) : Decidable (a <= b) := inferInstanceAs (Decidable (a.val <= b.val))

instance : LinearOrder UnsignedDuration where
  le_refl (a) := le_refl a.val
  le_trans (a b c) := Nat.le_trans
  lt_iff_le_not_le (a b) := Nat.lt_iff_le_not_le
  le_antisymm (a b h1 h2) := by
    apply UnsignedDuration.eq_of_val_eq
    exact le_antisymm h1 h2
  le_total := by simp [UnsignedDuration.le_def, le_total]
  decidable_le := inferInstance

theorem UnsignedDuration.monotone {d₁ d₂ : UnsignedDuration} : d₁.val <= d₂.val -> d₁ <= d₂ :=
  fun h => (UnsignedDuration.le_def) ▸ h

@[reducible] def UnsignedDuration.toNanos (d : UnsignedDuration) : Nat := d.val
@[reducible] def UnsignedDuration.toSeconds (d : UnsignedDuration) : Nat := d.val / oneSecondNanos
@[reducible] def UnsignedDuration.toMinutes (d : UnsignedDuration) : Nat := d.val / oneMinuteNanos
@[reducible] def UnsignedDuration.toHours (d : UnsignedDuration) : Nat := d.val / oneHourNanos
@[reducible] def UnsignedDuration.toDays (d : UnsignedDuration) : Nat := d.val / oneDayNanos
@[reducible] def UnsignedDuration.toWeeks (d : UnsignedDuration) : Nat := d.val / oneWeekNanos
@[reducible] def UnsignedDuration.toNonLeapYears (d : UnsignedDuration) : Nat := d.val / (365 * oneDayNanos)

@[reducible] def UnsignedDuration.fromNanos (n : Nat) : UnsignedDuration := ⟨n⟩
@[reducible] def UnsignedDuration.fromSeconds (n : Nat) : UnsignedDuration := ⟨n * oneSecondNanos⟩
@[reducible] def UnsignedDuration.fromMinutes (n : Nat) : UnsignedDuration := ⟨n * oneMinuteNanos⟩
@[reducible] def UnsignedDuration.fromHours (n : Nat) : UnsignedDuration := ⟨n * oneHourNanos⟩
@[reducible] def UnsignedDuration.fromWeeks (n : Nat) : UnsignedDuration := ⟨n * oneWeekNanos⟩
@[reducible] def UnsignedDuration.fromDays (n : Nat) : UnsignedDuration := ⟨n * oneDayNanos⟩
@[reducible] def UnsignedDuration.fromNonLeapYears (n : Nat) : UnsignedDuration := ⟨n * oneYearNanos⟩

instance (n : Nat) : OfNat UnsignedDuration n where
  ofNat := ⟨n⟩

@[simp] theorem UnsignedDuration.zero_def : (0 : UnsignedDuration).val = (0 : Nat) := by rfl

instance : ToString UnsignedDuration where
  toString d :=
    let secs := String.leftpad 2 '0' s!"{d.toSeconds}"
    let nanos := String.leftpad 9 '0' s!"{d.toNanos % oneSecondNanos}"
    s!"P{secs}.{nanos}S"

instance : AddCommSemigroup UnsignedDuration := {
  add_assoc := fun a b c => by simp [UnsignedDuration.add_def, AddSemigroup.add_assoc]
  add_comm := fun a b => by simp [UnsignedDuration.add_def]; exact AddCommSemigroup.add_comm (A := Nat) _ _
}

instance : IsAddLeftCancel UnsignedDuration where
  add_left_cancel := fun a b c => by
    simp [UnsignedDuration.add_def]
    have h0 := @Nat.add_left_cancel a.val b.val c.val
    intro h1
    specialize h0 h1
    exact UnsignedDuration.eq_of_val_eq h0

instance : IsAddRightCancel UnsignedDuration where
  add_right_cancel := fun a b c => by
    simp [UnsignedDuration.add_def]
    have h0 := @Nat.add_right_cancel b.val a.val c.val
    intro h1
    specialize h0 h1
    exact UnsignedDuration.eq_of_val_eq h0

instance : AddCommMonoid UnsignedDuration where
  add_zero := by simp [UnsignedDuration.eq_of_val_eq, UnsignedDuration.add_def, add_zero]
  zero_add := by simp [UnsignedDuration.eq_of_val_eq, UnsignedDuration.add_def, zero_add]
  nsmul_zero' := by simp [nsmul_rec]
  nsmul_succ' := by simp [nsmul_rec]
  add_comm := by simp [UnsignedDuration.eq_of_val_eq, UnsignedDuration.add_def, add_comm]

instance : Equiv Nat UnsignedDuration where
  toFun := UnsignedDuration.mk
  invFun := UnsignedDuration.val
  left_inv := by simp [Function.LeftInverse]
  right_inv := by simp [Function.RightInverse, Function.LeftInverse]


-- Desigualdad de naturales (2)
-- ============================

import tactic
import data.pnat.basic

lemma pnat.add_sub_cancel
  (a b : ℕ+)
  : a + b - b = a :=
pnat.eq
begin
  rw [pnat.sub_coe, if_pos],
  { apply nat.add_sub_cancel },
  { exact lt_add_of_pos_left b.1 a.pos },
end

lemma eq_with_2
  (x z: ℕ+)
  (h2: ¬x + 2 * z < 2 * z)
  : x + 2 * z - 2 * z = x :=
pnat.add_sub_cancel _ _


variables A B C : Prop

premise P : (A->(B/\C))

example : ((A->B)/\(A->C)) :=
and.intro
    (assume H2: A,
        show B, from and.left(P H2))
    (assume H3: A,
        show C, from and.right(P H3)).