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

! This file was ported from Lean 3 source module number_theory.dioph
! leanprover-community/mathlib commit a66d07e27d5b5b8ac1147cacfe353478e5c14002
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fin.Fin2
import Mathbin.Data.Pfun
import Mathbin.Data.Vector3
import Mathbin.NumberTheory.PellMatiyasevic

/-!
# Diophantine functions and Matiyasevic's theorem

Hilbert's tenth problem asked whether there exists an algorithm which for a given integer polynomial
determines whether this polynomial has integer solutions. It was answered in the negative in 1970,
the final step being completed by Matiyasevic who showed that the power function is Diophantine.

Here a function is called Diophantine if its graph is Diophantine as a set. A subset `S ⊆ ℕ ^ α` in
turn is called Diophantine if there exists an integer polynomial on `α ⊕ β` such that `v ∈ S` iff
there exists `t : ℕ^β` with `p (v, t) = 0`.

## Main definitions

* `is_poly`: a predicate stating that a function is a multivariate integer polynomial.
* `poly`: the type of multivariate integer polynomial functions.
* `dioph`: a predicate stating that a set is Diophantine, i.e. a set `S ⊆ ℕ^α` is
  Diophantine if there exists a polynomial on `α ⊕ β` such that `v ∈ S` iff there
  exists `t : ℕ^β` with `p (v, t) = 0`.
* `dioph_fn`: a predicate on a function stating that it is Diophantine in the sense that its graph
  is Diophantine as a set.

## Main statements

* `pell_dioph` states that solutions to Pell's equation form a Diophantine set.
* `pow_dioph` states that the power function is Diophantine, a version of Matiyasevic's theorem.

## References

* [M. Carneiro, _A Lean formalization of Matiyasevic's theorem_][carneiro2018matiyasevic]
* [M. Davis, _Hilbert's tenth problem is unsolvable_][MR317916]

## Tags

Matiyasevic's theorem, Hilbert's tenth problem

## TODO

* Finish the solution of Hilbert's tenth problem.
* Connect `poly` to `mv_polynomial`
-/

open Fin2 Function Nat Sum

-- mathport name: «expr ::ₒ »
local infixr:67 " ::ₒ " => Option.elim'

-- mathport name: «expr ⊗ »
local infixr:65 " ⊗ " => Sum.elim

universe u

/-!
### Multivariate integer polynomials

Note that this duplicates `mv_polynomial`.
-/

section Polynomials

variable {α β γ : Type _}

/-- A predicate asserting that a function is a multivariate integer polynomial.
  (We are being a bit lazy here by allowing many representations for multiplication,
  rather than only allowing monomials and addition, but the definition is equivalent
  and this is easier to use.) -/
inductive IsPoly : ((α → ℕ) → ℤ) → Prop
  | proj : ∀ i, IsPoly fun x : α → ℕ => x i
  | const : ∀ n : ℤ, IsPoly fun x : α → ℕ => n
  | sub : ∀ {f g : (α → ℕ) → ℤ}, IsPoly f → IsPoly g → IsPoly fun x => f x - g x
  | mul : ∀ {f g : (α → ℕ) → ℤ}, IsPoly f → IsPoly g → IsPoly fun x => f x * g x
#align is_poly IsPoly

theorem IsPoly.neg {f : (α → ℕ) → ℤ} : IsPoly f → IsPoly (-f) :=
  by
  rw [← zero_sub]
  exact (IsPoly.const 0).sub
#align is_poly.neg IsPoly.neg

theorem IsPoly.add {f g : (α → ℕ) → ℤ} (hf : IsPoly f) (hg : IsPoly g) : IsPoly (f + g) :=
  by
  rw [← sub_neg_eq_add]
  exact hf.sub hg.neg
#align is_poly.add IsPoly.add

/-- The type of multivariate integer polynomials -/
def Poly (α : Type u) :=
  { f : (α → ℕ) → ℤ // IsPoly f }
#align poly Poly

namespace Poly

section

instance funLike : FunLike (Poly α) (α → ℕ) fun _ => ℤ :=
  ⟨Subtype.val, Subtype.val_injective⟩
#align poly.fun_like Poly.funLike

/-- Helper instance for when there are too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : CoeFun (Poly α) fun _ => (α → ℕ) → ℤ :=
  FunLike.hasCoeToFun

/-- The underlying function of a `poly` is a polynomial -/
protected theorem isPoly (f : Poly α) : IsPoly f :=
  f.2
#align poly.is_poly Poly.isPoly

/-- Extensionality for `poly α` -/
@[ext]
theorem ext {f g : Poly α} : (∀ x, f x = g x) → f = g :=
  FunLike.ext _ _
#align poly.ext Poly.ext

/-- The `i`th projection function, `x_i`. -/
def proj (i) : Poly α :=
  ⟨_, IsPoly.proj i⟩
#align poly.proj Poly.proj

@[simp]
theorem proj_apply (i : α) (x) : proj i x = x i :=
  rfl
#align poly.proj_apply Poly.proj_apply

/-- The constant function with value `n : ℤ`. -/
def const (n) : Poly α :=
  ⟨_, IsPoly.const n⟩
#align poly.const Poly.const

@[simp]
theorem const_apply (n) (x : α → ℕ) : const n x = n :=
  rfl
#align poly.const_apply Poly.const_apply

instance : Zero (Poly α) :=
  ⟨const 0⟩

instance : One (Poly α) :=
  ⟨const 1⟩

instance : Neg (Poly α) :=
  ⟨fun f => ⟨-f, f.2.neg⟩⟩

instance : Add (Poly α) :=
  ⟨fun f g => ⟨f + g, f.2.add g.2⟩⟩

instance : Sub (Poly α) :=
  ⟨fun f g => ⟨f - g, f.2.sub g.2⟩⟩

instance : Mul (Poly α) :=
  ⟨fun f g => ⟨f * g, f.2.mul g.2⟩⟩

@[simp]
theorem coe_zero : ⇑(0 : Poly α) = const 0 :=
  rfl
#align poly.coe_zero Poly.coe_zero

@[simp]
theorem coe_one : ⇑(1 : Poly α) = const 1 :=
  rfl
#align poly.coe_one Poly.coe_one

@[simp]
theorem coe_neg (f : Poly α) : ⇑(-f) = -f :=
  rfl
#align poly.coe_neg Poly.coe_neg

@[simp]
theorem coe_add (f g : Poly α) : ⇑(f + g) = f + g :=
  rfl
#align poly.coe_add Poly.coe_add

@[simp]
theorem coe_sub (f g : Poly α) : ⇑(f - g) = f - g :=
  rfl
#align poly.coe_sub Poly.coe_sub

@[simp]
theorem coe_mul (f g : Poly α) : ⇑(f * g) = f * g :=
  rfl
#align poly.coe_mul Poly.coe_mul

@[simp]
theorem zero_apply (x) : (0 : Poly α) x = 0 :=
  rfl
#align poly.zero_apply Poly.zero_apply

@[simp]
theorem one_apply (x) : (1 : Poly α) x = 1 :=
  rfl
#align poly.one_apply Poly.one_apply

@[simp]
theorem neg_apply (f : Poly α) (x) : (-f) x = -f x :=
  rfl
#align poly.neg_apply Poly.neg_apply

@[simp]
theorem add_apply (f g : Poly α) (x : α → ℕ) : (f + g) x = f x + g x :=
  rfl
#align poly.add_apply Poly.add_apply

@[simp]
theorem sub_apply (f g : Poly α) (x : α → ℕ) : (f - g) x = f x - g x :=
  rfl
#align poly.sub_apply Poly.sub_apply

@[simp]
theorem mul_apply (f g : Poly α) (x : α → ℕ) : (f * g) x = f x * g x :=
  rfl
#align poly.mul_apply Poly.mul_apply

instance (α : Type _) : Inhabited (Poly α) :=
  ⟨0⟩

instance : AddCommGroup (Poly α) := by
  refine_struct
            { add := ((· + ·) : Poly α → Poly α → Poly α)
              neg := (Neg.neg : Poly α → Poly α)
              sub := Sub.sub
              zero := 0
              zsmul := @zsmulRec _ ⟨(0 : Poly α)⟩ ⟨(· + ·)⟩ ⟨Neg.neg⟩
              nsmul := @nsmulRec _ ⟨(0 : Poly α)⟩ ⟨(· + ·)⟩ } <;>
          intros <;>
        try rfl <;>
      refine' ext fun _ => _ <;>
    simp [sub_eq_add_neg, add_comm, add_assoc]

instance : AddGroupWithOne (Poly α) :=
  { Poly.addCommGroup with
    one := 1
    natCast := fun n => Poly.const n
    intCast := Poly.const }

instance : CommRing (Poly α) := by
  refine_struct
            { Poly.addGroupWithOne,
              Poly.addCommGroup with
              add := ((· + ·) : Poly α → Poly α → Poly α)
              zero := 0
              mul := (· * ·)
              one := 1
              npow := @npowRec _ ⟨(1 : Poly α)⟩ ⟨(· * ·)⟩ } <;>
          intros <;>
        try rfl <;>
      refine' ext fun _ => _ <;>
    simp [sub_eq_add_neg, mul_add, mul_left_comm, mul_comm, add_comm, add_assoc]

theorem induction {C : Poly α → Prop} (H1 : ∀ i, C (proj i)) (H2 : ∀ n, C (const n))
    (H3 : ∀ f g, C f → C g → C (f - g)) (H4 : ∀ f g, C f → C g → C (f * g)) (f : Poly α) : C f :=
  by
  cases' f with f pf
  induction' pf with i n f g pf pg ihf ihg f g pf pg ihf ihg
  apply H1; apply H2; apply H3 _ _ ihf ihg; apply H4 _ _ ihf ihg
#align poly.induction Poly.induction

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The sum of squares of a list of polynomials. This is relevant for
  Diophantine equations, because it means that a list of equations
  can be encoded as a single equation: `x = 0 ∧ y = 0 ∧ z = 0` is
  equivalent to `x^2 + y^2 + z^2 = 0`. -/
def sumsq : List (Poly α) → Poly α
  | [] => 0
  | p::ps => p * p + sumsq ps
#align poly.sumsq Poly.sumsq

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem sumsq_nonneg (x : α → ℕ) : ∀ l, 0 ≤ sumsq l x
  | [] => le_refl 0
  | p::ps => by
    rw [sumsq] <;> simp [-add_comm] <;> exact add_nonneg (mul_self_nonneg _) (sumsq_nonneg ps)
#align poly.sumsq_nonneg Poly.sumsq_nonneg

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem sumsq_eq_zero (x) : ∀ l, sumsq l x = 0 ↔ l.All₂ fun a : Poly α => a x = 0
  | [] => eq_self_iff_true _
  | p::ps => by
    rw [List.all₂_cons, ← sumsq_eq_zero ps] <;> rw [sumsq] <;> simp [-add_comm] <;>
      exact
        ⟨fun h : p x * p x + sumsq ps x = 0 =>
          have : p x = 0 :=
            eq_zero_of_mul_self_eq_zero <|
              le_antisymm
                (by
                  rw [← h] <;> have t := add_le_add_left (sumsq_nonneg x ps) (p x * p x) <;>
                    rwa [add_zero] at t)
                (mul_self_nonneg _)
          ⟨this, by simp [this] at h <;> exact h⟩,
          fun ⟨h1, h2⟩ => by rw [h1, h2] <;> rfl⟩
#align poly.sumsq_eq_zero Poly.sumsq_eq_zero

end

/-- Map the index set of variables, replacing `x_i` with `x_(f i)`. -/
def map {α β} (f : α → β) (g : Poly α) : Poly β :=
  ⟨fun v => g <| v ∘ f,
    g.induction (fun i => by simp <;> apply IsPoly.proj) (fun n => by simp <;> apply IsPoly.const)
      (fun f g pf pg => by simp <;> apply IsPoly.sub pf pg) fun f g pf pg => by
      simp <;> apply IsPoly.mul pf pg⟩
#align poly.map Poly.map

@[simp]
theorem map_apply {α β} (f : α → β) (g : Poly α) (v) : map f g v = g (v ∘ f) :=
  rfl
#align poly.map_apply Poly.map_apply

end Poly

end Polynomials

/-! ### Diophantine sets -/

/-- A set `S ⊆ ℕ^α` is Diophantine if there exists a polynomial on
  `α ⊕ β` such that `v ∈ S` iff there exists `t : ℕ^β` with `p (v, t) = 0`. -/
def Dioph {α : Type u} (S : Set (α → ℕ)) : Prop :=
  ∃ (β : Type u)(p : Poly (Sum α β)), ∀ v, S v ↔ ∃ t, p (v ⊗ t) = 0
#align dioph Dioph

namespace Dioph

section

variable {α β γ : Type u} {S S' : Set (α → ℕ)}

theorem ext (d : Dioph S) (H : ∀ v, v ∈ S ↔ v ∈ S') : Dioph S' := by rwa [← Set.ext H]
#align dioph.ext Dioph.ext

theorem of_no_dummies (S : Set (α → ℕ)) (p : Poly α) (h : ∀ v, S v ↔ p v = 0) : Dioph S :=
  ⟨PEmpty, p.map inl, fun v => (h v).trans ⟨fun h => ⟨PEmpty.rec _, h⟩, fun ⟨t, ht⟩ => ht⟩⟩
#align dioph.of_no_dummies Dioph.of_no_dummies

theorem inject_dummies_lem (f : β → γ) (g : γ → Option β) (inv : ∀ x, g (f x) = some x)
    (p : Poly (Sum α β)) (v : α → ℕ) :
    (∃ t, p (v ⊗ t) = 0) ↔ ∃ t, p.map (inl ⊗ inr ∘ f) (v ⊗ t) = 0 :=
  by
  dsimp; refine' ⟨fun t => _, fun t => _⟩ <;> cases' t with t ht
  · have : (v ⊗ (0 ::ₒ t) ∘ g) ∘ (inl ⊗ inr ∘ f) = v ⊗ t :=
      funext fun s => by cases' s with a b <;> dsimp [(· ∘ ·)] <;> try rw [inv] <;> rfl
    exact ⟨(0 ::ₒ t) ∘ g, by rwa [this]⟩
  · have : v ⊗ t ∘ f = (v ⊗ t) ∘ (inl ⊗ inr ∘ f) := funext fun s => by cases' s with a b <;> rfl
    exact ⟨t ∘ f, by rwa [this]⟩
#align dioph.inject_dummies_lem Dioph.inject_dummies_lem

theorem inject_dummies (f : β → γ) (g : γ → Option β) (inv : ∀ x, g (f x) = some x)
    (p : Poly (Sum α β)) (h : ∀ v, S v ↔ ∃ t, p (v ⊗ t) = 0) :
    ∃ q : Poly (Sum α γ), ∀ v, S v ↔ ∃ t, q (v ⊗ t) = 0 :=
  ⟨p.map (inl ⊗ inr ∘ f), fun v => (h v).trans <| inject_dummies_lem f g inv _ _⟩
#align dioph.inject_dummies Dioph.inject_dummies

variable (β)

theorem reindex_dioph (f : α → β) : ∀ d : Dioph S, Dioph { v | v ∘ f ∈ S }
  | ⟨γ, p, pe⟩ =>
    ⟨γ, p.map (inl ∘ f ⊗ inr), fun v =>
      (pe _).trans <|
        exists_congr fun t =>
          suffices v ∘ f ⊗ t = (v ⊗ t) ∘ (inl ∘ f ⊗ inr) by simp [this]
          funext fun s => by cases' s with a b <;> rfl⟩
#align dioph.reindex_dioph Dioph.reindex_dioph

variable {β}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem DiophList.all₂ (l : List (Set <| α → ℕ)) (d : l.All₂ Dioph) :
    Dioph { v | l.All₂ fun S : Set (α → ℕ) => v ∈ S } :=
  by
  suffices
    ∃ (β : _)(pl : List (Poly (Sum α β))),
      ∀ v,
        List.All₂ (fun S : Set _ => S v) l ↔
          ∃ t, List.All₂ (fun p : Poly (Sum α β) => p (v ⊗ t) = 0) pl
    from
    let ⟨β, pl, h⟩ := this
    ⟨β, Poly.sumsq pl, fun v => (h v).trans <| exists_congr fun t => (Poly.sumsq_eq_zero _ _).symm⟩
  induction' l with S l IH
  exact ⟨ULift Empty, [], fun v => by simp <;> exact ⟨fun ⟨t⟩ => Empty.rec _ t, trivial⟩⟩
  simp at d
  exact
    let ⟨⟨β, p, pe⟩, dl⟩ := d
    let ⟨γ, pl, ple⟩ := IH dl
    ⟨Sum β γ, p.map (inl ⊗ inr ∘ inl)::pl.map fun q => q.map (inl ⊗ inr ∘ inr), fun v => by
      simp <;>
        exact
          Iff.trans (and_congr (pe v) (ple v))
            ⟨fun ⟨⟨m, hm⟩, ⟨n, hn⟩⟩ =>
              ⟨m ⊗ n, by
                rw [show (v ⊗ m ⊗ n) ∘ (inl ⊗ inr ∘ inl) = v ⊗ m from
                      funext fun s => by cases' s with a b <;> rfl] <;>
                  exact hm,
                by
                refine' List.All₂.imp (fun q hq => _) hn
                dsimp [(· ∘ ·)]
                rw [show
                      (fun x : Sum α γ => (v ⊗ m ⊗ n) ((inl ⊗ fun x : γ => inr (inr x)) x)) = v ⊗ n
                      from funext fun s => by cases' s with a b <;> rfl] <;>
                  exact hq⟩,
              fun ⟨t, hl, hr⟩ =>
              ⟨⟨t ∘ inl, by
                  rwa [show (v ⊗ t) ∘ (inl ⊗ inr ∘ inl) = v ⊗ t ∘ inl from
                      funext fun s => by cases' s with a b <;> rfl] at
                    hl⟩,
                ⟨t ∘ inr, by
                  refine' List.All₂.imp (fun q hq => _) hr
                  dsimp [(· ∘ ·)] at hq
                  rwa [show
                      (fun x : Sum α γ => (v ⊗ t) ((inl ⊗ fun x : γ => inr (inr x)) x)) =
                        v ⊗ t ∘ inr
                      from funext fun s => by cases' s with a b <;> rfl] at
                    hq⟩⟩⟩⟩
#align dioph.dioph_list.all₂ Dioph.DiophList.all₂

theorem inter (d : Dioph S) (d' : Dioph S') : Dioph (S ∩ S') :=
  DiophList.all₂ [S, S'] ⟨d, d'⟩
#align dioph.inter Dioph.inter

theorem union : ∀ (d : Dioph S) (d' : Dioph S'), Dioph (S ∪ S')
  | ⟨β, p, pe⟩, ⟨γ, q, qe⟩ =>
    ⟨Sum β γ, p.map (inl ⊗ inr ∘ inl) * q.map (inl ⊗ inr ∘ inr), fun v =>
      by
      refine'
        Iff.trans (or_congr ((pe v).trans _) ((qe v).trans _))
          (exists_or_distrib.symm.trans
            (exists_congr fun t =>
              (@mul_eq_zero _ _ _ (p ((v ⊗ t) ∘ (inl ⊗ inr ∘ inl)))
                  (q ((v ⊗ t) ∘ (inl ⊗ inr ∘ inr)))).symm))
      exact inject_dummies_lem _ (some ⊗ fun _ => none) (fun x => rfl) _ _
      exact inject_dummies_lem _ ((fun _ => none) ⊗ some) (fun x => rfl) _ _⟩
#align dioph.union Dioph.union

/-- A partial function is Diophantine if its graph is Diophantine. -/
def DiophPfun (f : (α → ℕ) →. ℕ) : Prop :=
  Dioph { v : Option α → ℕ | f.graph (v ∘ some, v none) }
#align dioph.dioph_pfun Dioph.DiophPfun

/-- A function is Diophantine if its graph is Diophantine. -/
def DiophFn (f : (α → ℕ) → ℕ) : Prop :=
  Dioph { v : Option α → ℕ | f (v ∘ some) = v none }
#align dioph.dioph_fn Dioph.DiophFn

theorem reindex_diophFn {f : (α → ℕ) → ℕ} (g : α → β) (d : DiophFn f) :
    DiophFn fun v => f (v ∘ g) := by convert reindex_dioph (Option β) (Option.map g) d
#align dioph.reindex_dioph_fn Dioph.reindex_diophFn

theorem ex_dioph {S : Set (Sum α β → ℕ)} : Dioph S → Dioph { v | ∃ x, v ⊗ x ∈ S }
  | ⟨γ, p, pe⟩ =>
    ⟨Sum β γ, p.map ((inl ⊗ inr ∘ inl) ⊗ inr ∘ inr), fun v =>
      ⟨fun ⟨x, hx⟩ =>
        let ⟨t, ht⟩ := (pe _).1 hx
        ⟨x ⊗ t, by
          simp <;>
              rw [show (v ⊗ x ⊗ t) ∘ ((inl ⊗ inr ∘ inl) ⊗ inr ∘ inr) = (v ⊗ x) ⊗ t from
                  funext fun s => by cases' s with a b <;> try cases a <;> rfl] <;>
            exact ht⟩,
        fun ⟨t, ht⟩ =>
        ⟨t ∘ inl,
          (pe _).2
            ⟨t ∘ inr, by
              simp at ht <;>
                rwa [show (v ⊗ t) ∘ ((inl ⊗ inr ∘ inl) ⊗ inr ∘ inr) = (v ⊗ t ∘ inl) ⊗ t ∘ inr from
                    funext fun s => by cases' s with a b <;> try cases a <;> rfl] at
                  ht⟩⟩⟩⟩
#align dioph.ex_dioph Dioph.ex_dioph

theorem ex1_dioph {S : Set (Option α → ℕ)} : Dioph S → Dioph { v | ∃ x, x ::ₒ v ∈ S }
  | ⟨β, p, pe⟩ =>
    ⟨Option β, p.map (inr none ::ₒ inl ⊗ inr ∘ some), fun v =>
      ⟨fun ⟨x, hx⟩ =>
        let ⟨t, ht⟩ := (pe _).1 hx
        ⟨x ::ₒ t, by
          simp <;>
              rw [show (v ⊗ x ::ₒ t) ∘ (inr none ::ₒ inl ⊗ inr ∘ some) = x ::ₒ v ⊗ t from
                  funext fun s => by cases' s with a b <;> try cases a <;> rfl] <;>
            exact ht⟩,
        fun ⟨t, ht⟩ =>
        ⟨t none,
          (pe _).2
            ⟨t ∘ some, by
              simp at ht <;>
                rwa [show (v ⊗ t) ∘ (inr none ::ₒ inl ⊗ inr ∘ some) = t none ::ₒ v ⊗ t ∘ some from
                    funext fun s => by cases' s with a b <;> try cases a <;> rfl] at
                  ht⟩⟩⟩⟩
#align dioph.ex1_dioph Dioph.ex1_dioph

theorem dom_dioph {f : (α → ℕ) →. ℕ} (d : DiophPfun f) : Dioph f.Dom :=
  cast (congr_arg Dioph <| Set.ext fun v => (PFun.dom_iff_graph _ _).symm) (ex1_dioph d)
#align dioph.dom_dioph Dioph.dom_dioph

theorem diophFn_iff_pFun (f : (α → ℕ) → ℕ) : DiophFn f = @DiophPfun α f := by
  refine' congr_arg Dioph (Set.ext fun v => _) <;> exact pfun.lift_graph.symm
#align dioph.dioph_fn_iff_pfun Dioph.diophFn_iff_pFun

theorem abs_poly_dioph (p : Poly α) : DiophFn fun v => (p v).natAbs :=
  of_no_dummies _ ((p.map some - Poly.proj none) * (p.map some + Poly.proj none)) fun v =>
    by
    dsimp
    exact Int.eq_natAbs_iff_mul_eq_zero
#align dioph.abs_poly_dioph Dioph.abs_poly_dioph

theorem proj_dioph (i : α) : DiophFn fun v => v i :=
  abs_poly_dioph (Poly.proj i)
#align dioph.proj_dioph Dioph.proj_dioph

theorem diophPfun_comp1 {S : Set (Option α → ℕ)} (d : Dioph S) {f} (df : DiophPfun f) :
    Dioph { v : α → ℕ | ∃ h : f.Dom v, f.fn v h ::ₒ v ∈ S } :=
  ext (ex1_dioph (d.inter df)) fun v =>
    ⟨fun ⟨x, hS, (h : Exists _)⟩ => by
      rw [show (x ::ₒ v) ∘ some = v from funext fun s => rfl] at h <;> cases' h with hf h <;>
            refine' ⟨hf, _⟩ <;>
          rw [PFun.fn, h] <;>
        exact hS,
      fun ⟨x, hS⟩ =>
      ⟨f.fn v x, hS,
        show Exists _ by
          rw [show (f.fn v x ::ₒ v) ∘ some = v from funext fun s => rfl] <;> exact ⟨x, rfl⟩⟩⟩
#align dioph.dioph_pfun_comp1 Dioph.diophPfun_comp1

theorem diophFn_comp1 {S : Set (Option α → ℕ)} (d : Dioph S) {f : (α → ℕ) → ℕ} (df : DiophFn f) :
    Dioph { v | f v ::ₒ v ∈ S } :=
  ext (diophPfun_comp1 d <| cast (diophFn_iff_pFun f) df) fun v =>
    ⟨fun ⟨_, h⟩ => h, fun h => ⟨trivial, h⟩⟩
#align dioph.dioph_fn_comp1 Dioph.diophFn_comp1

end

section

variable {α β : Type} {n : ℕ}

open Vector3

open Vector3

attribute [local reducible] Vector3

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem diophFn_vec_comp1 {S : Set (Vector3 ℕ (succ n))} (d : Dioph S) {f : Vector3 ℕ n → ℕ}
    (df : DiophFn f) : Dioph { v : Vector3 ℕ n | (f v::v) ∈ S } :=
  ext (diophFn_comp1 (reindex_dioph _ (none::some) d) df) fun v =>
    by
    dsimp
    congr
    ext x
    cases x <;> rfl
#align dioph.dioph_fn_vec_comp1 Dioph.diophFn_vec_comp1

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem vec_ex1_dioph (n) {S : Set (Vector3 ℕ (succ n))} (d : Dioph S) :
    Dioph { v : Fin2 n → ℕ | ∃ x, (x::v) ∈ S } :=
  ext (ex1_dioph <| reindex_dioph _ (none::some) d) fun v =>
    exists_congr fun x => by
      dsimp
      rw [show Option.elim' x v ∘ cons none some = x::v from
          funext fun s => by cases' s with a b <;> rfl]
#align dioph.vec_ex1_dioph Dioph.vec_ex1_dioph

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem diophFn_vec (f : Vector3 ℕ n → ℕ) : DiophFn f ↔ Dioph { v | f (v ∘ fs) = v fz } :=
  ⟨reindex_dioph _ (fz ::ₒ fs), reindex_dioph _ (none::some)⟩
#align dioph.dioph_fn_vec Dioph.diophFn_vec

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem diophPfun_vec (f : Vector3 ℕ n →. ℕ) : DiophPfun f ↔ Dioph { v | f.graph (v ∘ fs, v fz) } :=
  ⟨reindex_dioph _ (fz ::ₒ fs), reindex_dioph _ (none::some)⟩
#align dioph.dioph_pfun_vec Dioph.diophPfun_vec

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem diophFn_compn :
    ∀ {n} {S : Set (Sum α (Fin2 n) → ℕ)} (d : Dioph S) {f : Vector3 ((α → ℕ) → ℕ) n}
      (df : VectorAllp DiophFn f), Dioph { v : α → ℕ | (v ⊗ fun i => f i v) ∈ S }
  | 0, S, d, f => fun df =>
    ext (reindex_dioph _ (id ⊗ Fin2.elim0) d) fun v =>
      by
      dsimp
      congr
      ext x
      obtain _ | _ | _ := x
      rfl
  | succ n, S, d, f =>
    f.consElim fun f fl => by
      simp <;>
        exact fun df dfl =>
          have : Dioph { v | (v ∘ inl ⊗ f (v ∘ inl)::v ∘ inr) ∈ S } :=
            ext
              (dioph_fn_comp1 (reindex_dioph _ (some ∘ inl ⊗ none::some ∘ inr) d) <|
                reindex_dioph_fn inl df)
              fun v => by
              dsimp
              congr
              ext x
              obtain _ | _ | _ := x <;> rfl
          have : Dioph { v | (v ⊗ f v::fun i : Fin2 n => fl i v) ∈ S } :=
            @dioph_fn_compn n (fun v => S (v ∘ inl ⊗ f (v ∘ inl)::v ∘ inr)) this _ dfl
          ext this fun v => by
            dsimp
            congr
            ext x
            obtain _ | _ | _ := x <;> rfl
#align dioph.dioph_fn_compn Dioph.diophFn_compn

theorem dioph_comp {S : Set (Vector3 ℕ n)} (d : Dioph S) (f : Vector3 ((α → ℕ) → ℕ) n)
    (df : VectorAllp DiophFn f) : Dioph { v | (fun i => f i v) ∈ S } :=
  diophFn_compn (reindex_dioph _ inr d) df
#align dioph.dioph_comp Dioph.dioph_comp

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem diophFn_comp {f : Vector3 ℕ n → ℕ} (df : DiophFn f) (g : Vector3 ((α → ℕ) → ℕ) n)
    (dg : VectorAllp DiophFn g) : DiophFn fun v => f fun i => g i v :=
  dioph_comp ((diophFn_vec _).1 df) ((fun v => v none)::fun i v => g i (v ∘ some)) <| by
    simp <;>
      exact
        ⟨proj_dioph none,
          (vectorAllp_iff_forall _ _).2 fun i =>
            reindex_dioph_fn _ <| (vectorAllp_iff_forall _ _).1 dg _⟩
#align dioph.dioph_fn_comp Dioph.diophFn_comp

-- mathport name: dioph.inter
scoped notation:35 x " D∧ " y => Dioph.inter x y

-- mathport name: dioph.union
scoped notation:35 x " D∨ " y => Dioph.union x y

-- mathport name: dioph.vec_ex1_dioph
scoped notation:30 "D∃" => Dioph.vec_ex1_dioph

-- mathport name: fin2.of_nat'
scoped prefix:arg "&" => Fin2.ofNat'

theorem proj_dioph_of_nat {n : ℕ} (m : ℕ) [IsLT m n] : DiophFn fun v : Vector3 ℕ n => v &m :=
  proj_dioph &m
#align dioph.proj_dioph_of_nat Dioph.proj_dioph_of_nat

-- mathport name: proj_dioph_of_nat
scoped prefix:100 "D&" => Dioph.proj_dioph_of_nat

theorem const_dioph (n : ℕ) : DiophFn (const (α → ℕ) n) :=
  abs_poly_dioph (Poly.const n)
#align dioph.const_dioph Dioph.const_dioph

-- mathport name: const_dioph
scoped prefix:100 "D." => Dioph.const_dioph

variable {f g : (α → ℕ) → ℕ} (df : DiophFn f) (dg : DiophFn g)

include df dg

theorem dioph_comp2 {S : ℕ → ℕ → Prop} (d : Dioph fun v : Vector3 ℕ 2 => S (v &0) (v &1)) :
    Dioph fun v => S (f v) (g v) :=
  dioph_comp d [f, g] ⟨df, dg⟩
#align dioph.dioph_comp2 Dioph.dioph_comp2

theorem diophFn_comp2 {h : ℕ → ℕ → ℕ} (d : DiophFn fun v : Vector3 ℕ 2 => h (v &0) (v &1)) :
    DiophFn fun v => h (f v) (g v) :=
  diophFn_comp d [f, g] ⟨df, dg⟩
#align dioph.dioph_fn_comp2 Dioph.diophFn_comp2

theorem eq_dioph : Dioph fun v => f v = g v :=
  dioph_comp2 df dg <|
    of_no_dummies _ (Poly.proj &0 - Poly.proj &1) fun v =>
      (Int.ofNat_inj _ _).symm.trans ⟨@sub_eq_zero_of_eq ℤ _ (v &0) (v &1), eq_of_sub_eq_zero⟩
#align dioph.eq_dioph Dioph.eq_dioph

-- mathport name: eq_dioph
scoped infixl:50 " D= " => Dioph.eq_dioph

theorem add_dioph : DiophFn fun v => f v + g v :=
  diophFn_comp2 df dg <| abs_poly_dioph (Poly.proj &0 + Poly.proj &1)
#align dioph.add_dioph Dioph.add_dioph

-- mathport name: add_dioph
scoped infixl:80 " D+ " => Dioph.add_dioph

theorem mul_dioph : DiophFn fun v => f v * g v :=
  diophFn_comp2 df dg <| abs_poly_dioph (Poly.proj &0 * Poly.proj &1)
#align dioph.mul_dioph Dioph.mul_dioph

-- mathport name: mul_dioph
scoped infixl:90 " D* " => Dioph.mul_dioph

theorem le_dioph : Dioph { v | f v ≤ g v } :=
  dioph_comp2 df dg <|
    ext ((D∃) 2 <| D&1 D+ D&0 D= D&2) fun v => ⟨fun ⟨x, hx⟩ => le.intro hx, le.dest⟩
#align dioph.le_dioph Dioph.le_dioph

-- mathport name: le_dioph
scoped infixl:50 " D≤ " => Dioph.le_dioph

theorem lt_dioph : Dioph { v | f v < g v } :=
  df D+ D.1 D≤ dg
#align dioph.lt_dioph Dioph.lt_dioph

-- mathport name: lt_dioph
scoped infixl:50 " D< " => Dioph.lt_dioph

theorem ne_dioph : Dioph { v | f v ≠ g v } :=
  ext (df D< dg D∨ dg D< df) fun v => by
    dsimp
    exact lt_or_lt_iff_ne
#align dioph.ne_dioph Dioph.ne_dioph

-- mathport name: ne_dioph
scoped infixl:50 " D≠ " => Dioph.ne_dioph

theorem sub_dioph : DiophFn fun v => f v - g v :=
  diophFn_comp2 df dg <|
    (diophFn_vec _).2 <|
      ext (D&1 D= D&0 D+ D&2 D∨ D&1 D≤ D&2 D∧ D&0 D= D.0) <|
        (vectorAll_iff_forall _).1 fun x y z =>
          show y = x + z ∨ y ≤ z ∧ x = 0 ↔ y - z = x from
            ⟨fun o => by
              rcases o with (ae | ⟨yz, x0⟩)
              · rw [ae, add_tsub_cancel_right]
              · rw [x0, tsub_eq_zero_iff_le.mpr yz],
              by
              rintro rfl
              cases' le_total y z with yz zy
              · exact Or.inr ⟨yz, tsub_eq_zero_iff_le.mpr yz⟩
              · exact Or.inl (tsub_add_cancel_of_le zy).symm⟩
#align dioph.sub_dioph Dioph.sub_dioph

-- mathport name: sub_dioph
scoped infixl:80 " D- " => Dioph.sub_dioph

theorem dvd_dioph : Dioph fun v => f v ∣ g v :=
  dioph_comp ((D∃) 2 <| D&2 D= D&1 D* D&0) [f, g] ⟨df, dg⟩
#align dioph.dvd_dioph Dioph.dvd_dioph

-- mathport name: dvd_dioph
scoped infixl:50 " D∣ " => Dioph.dvd_dioph

theorem mod_dioph : DiophFn fun v => f v % g v :=
  have : Dioph fun v : Vector3 ℕ 3 => (v &2 = 0 ∨ v &0 < v &2) ∧ ∃ x : ℕ, v &0 + v &2 * x = v &1 :=
    (D&2 D= D.0 D∨ D&0 D< D&2) D∧ (D∃) 3 <| D&1 D+ D&3 D* D&0 D= D&2
  diophFn_comp2 df dg <|
    (diophFn_vec _).2 <|
      ext this <|
        (vectorAll_iff_forall _).1 fun z x y =>
          show ((y = 0 ∨ z < y) ∧ ∃ c, z + y * c = x) ↔ x % y = z from
            ⟨fun ⟨h, c, hc⟩ => by
              rw [← hc] <;> simp <;> cases' h with x0 hl; rw [x0, mod_zero]
              exact mod_eq_of_lt hl, fun e => by
              rw [← e] <;>
                exact
                  ⟨or_iff_not_imp_left.2 fun h => mod_lt _ (Nat.pos_of_ne_zero h), x / y,
                    mod_add_div _ _⟩⟩
#align dioph.mod_dioph Dioph.mod_dioph

-- mathport name: mod_dioph
scoped infixl:80 " D% " => Dioph.mod_dioph

theorem modEq_dioph {h : (α → ℕ) → ℕ} (dh : DiophFn h) : Dioph fun v => f v ≡ g v [MOD h v] :=
  df D% dh D= dg D% dh
#align dioph.modeq_dioph Dioph.modEq_dioph

-- mathport name: modeq_dioph
scoped notation " D≡ " => Dioph.modEq_dioph

theorem div_dioph : DiophFn fun v => f v / g v :=
  have :
    Dioph fun v : Vector3 ℕ 3 =>
      v &2 = 0 ∧ v &0 = 0 ∨ v &0 * v &2 ≤ v &1 ∧ v &1 < (v &0 + 1) * v &2 :=
    (D&2 D= D.0 D∧ D&0 D= D.0) D∨ D&0 D* D&2 D≤ D&1 D∧ D&1 D< (D&0 D+ D.1) D* D&2
  diophFn_comp2 df dg <|
    (diophFn_vec _).2 <|
      ext this <|
        (vectorAll_iff_forall _).1 fun z x y =>
          show y = 0 ∧ z = 0 ∨ z * y ≤ x ∧ x < (z + 1) * y ↔ x / y = z by
            refine' Iff.trans _ eq_comm <;>
              exact
                y.eq_zero_or_pos.elim
                  (fun y0 => by
                    rw [y0, Nat.div_zero] <;>
                      exact
                        ⟨fun o => (o.resolve_right fun ⟨_, h2⟩ => Nat.not_lt_zero _ h2).right,
                          fun z0 => Or.inl ⟨rfl, z0⟩⟩)
                  fun ypos =>
                  Iff.trans ⟨fun o => o.resolve_left fun ⟨h1, _⟩ => ne_of_gt ypos h1, Or.inr⟩
                    (le_antisymm_iff.trans <|
                        and_congr (Nat.le_div_iff_mul_le ypos) <|
                          Iff.trans ⟨lt_succ_of_le, le_of_lt_succ⟩ (div_lt_iff_lt_mul ypos)).symm
#align dioph.div_dioph Dioph.div_dioph

-- mathport name: div_dioph
scoped infixl:80 " D/ " => Dioph.div_dioph

omit df dg

open Pell

theorem pell_dioph :
    Dioph fun v : Vector3 ℕ 4 => ∃ h : 1 < v &0, xn h (v &1) = v &2 ∧ yn h (v &1) = v &3 :=
  have :
    Dioph
      { v : Vector3 ℕ 4 |
        1 < v &0 ∧
          v &1 ≤ v &3 ∧
            (v &2 = 1 ∧ v &3 = 0 ∨
              ∃ u w s t b : ℕ,
                v &2 * v &2 - (v &0 * v &0 - 1) * v &3 * v &3 = 1 ∧
                  u * u - (v &0 * v &0 - 1) * w * w = 1 ∧
                    s * s - (b * b - 1) * t * t = 1 ∧
                      1 < b ∧
                        b ≡ 1 [MOD 4 * v &3] ∧
                          b ≡ v &0 [MOD u] ∧
                            0 < w ∧
                              v &3 * v &3 ∣ w ∧ s ≡ v &2 [MOD u] ∧ t ≡ v &1 [MOD 4 * v &3]) } :=
    D.1 D< D&0 D∧
      D&1 D≤ D&3 D∧
        (D&2 D= D.1 D∧ D&3 D= D.0) D∨
          (D∃) 4 <|
            (D∃) 5 <|
              (D∃) 6 <|
                (D∃) 7 <|
                  (D∃) 8 <|
                    D&7 D* D&7 D- (D&5 D* D&5 D- D.1) D* D&8 D* D&8 D= D.1 D∧
                      D&4 D* D&4 D- (D&5 D* D&5 D- D.1) D* D&3 D* D&3 D= D.1 D∧
                        D&2 D* D&2 D- (D&0 D* D&0 D- D.1) D* D&1 D* D&1 D= D.1 D∧
                          D.1 D<
                              D&0 D∧ D≡ (D&0) (D.1)
                                (D.4 D*
                                  D&8) D∧ D≡ (D&0) (D&5) (D&4) D∧
                                D.0 D< D&3 D∧
                                  D&8 D* D&8 D∣
                                      D&3 D∧ D≡ (D&2) (D&7) (D&4) D∧ D≡ (D&1) (D&6) (D.4 D* D&8)
  Dioph.ext this fun v => matiyasevic.symm
#align dioph.pell_dioph Dioph.pell_dioph

theorem xn_dioph : DiophPfun fun v : Vector3 ℕ 2 => ⟨1 < v &0, fun h => xn h (v &1)⟩ :=
  have : Dioph fun v : Vector3 ℕ 3 => ∃ y, ∃ h : 1 < v &1, xn h (v &2) = v &0 ∧ yn h (v &2) = y :=
    let D_pell := pell_dioph.reindex_dioph (Fin2 4) [&2, &3, &1, &0]
    (D∃) 3 D_pell
  (diophPfun_vec _).2 <|
    Dioph.ext this fun v => ⟨fun ⟨y, h, xe, ye⟩ => ⟨h, xe⟩, fun ⟨h, xe⟩ => ⟨_, h, xe, rfl⟩⟩
#align dioph.xn_dioph Dioph.xn_dioph

include df dg

/-- A version of **Matiyasevic's theorem** -/
theorem pow_dioph : DiophFn fun v => f v ^ g v :=
  have :
    Dioph
      { v : Vector3 ℕ 3 |
        v &2 = 0 ∧ v &0 = 1 ∨
          0 < v &2 ∧
            (v &1 = 0 ∧ v &0 = 0 ∨
              0 < v &1 ∧
                ∃ w a t z x y : ℕ,
                  (∃ a1 : 1 < a, xn a1 (v &2) = x ∧ yn a1 (v &2) = y) ∧
                    x ≡ y * (a - v &1) + v &0 [MOD t] ∧
                      2 * a * v &1 = t + (v &1 * v &1 + 1) ∧
                        v &0 < t ∧
                          v &1 ≤ w ∧
                            v &2 ≤ w ∧ a * a - ((w + 1) * (w + 1) - 1) * (w * z) * (w * z) = 1) } :=
    let D_pell := pell_dioph.reindex_dioph (Fin2 9) [&4, &8, &1, &0]
    (D&2 D= D.0 D∧ D&0 D= D.1) D∨
      D.0 D< D&2 D∧
        (D&1 D= D.0 D∧ D&0 D= D.0) D∨
          D.0 D< D&1 D∧
            (D∃) 3 <|
              (D∃) 4 <|
                (D∃) 5 <|
                  (D∃) 6 <|
                    (D∃) 7 <|
                      (D∃) 8 <|
                        D_pell D∧ D≡ (D&1) (D&0 D* (D&4 D- D&7) D+ D&6) (D&3) D∧
                            D.2 D* D&4 D* D&7 D= D&3 D+ (D&7 D* D&7 D+ D.1) D∧
                              D&6 D< D&3 D∧
                                D&7 D≤ D&5 D∧
                                  D&8 D≤ D&5 D∧
                                    D&4 D* D&4 D-
                                        ((D&5 D+ D.1) D* (D&5 D+ D.1) D- D.1) D* (D&5 D* D&2) D*
                                          (D&5 D* D&2) D=
                                      D.1
  diophFn_comp2 df dg <|
    (diophFn_vec _).2 <|
      Dioph.ext this fun v =>
        Iff.symm <|
          eq_pow_of_pell.trans <|
            or_congr Iff.rfl <|
              and_congr Iff.rfl <|
                or_congr Iff.rfl <|
                  and_congr Iff.rfl <|
                    ⟨fun ⟨w, a, t, z, a1, h⟩ => ⟨w, a, t, z, _, _, ⟨a1, rfl, rfl⟩, h⟩,
                      fun ⟨w, a, t, z, _, _, ⟨a1, rfl, rfl⟩, h⟩ => ⟨w, a, t, z, a1, h⟩⟩
#align dioph.pow_dioph Dioph.pow_dioph

end

end Dioph


import data.nat.prime
import data.pnat

import data.nat.exactly_divides

open nat

namespace order

section raw_order

variables (p : ℕ) (hp : p > 1)

protected def order_core : Π (n : ℕ), n > 0 → {r // p^r ∣∣ n}
| 0       := λ n_pos, absurd n_pos dec_trivial
| n@(k+1) := λ n_pos,
  have n / p < n, from div_lt_self n_pos hp,
  if h : p ∣ n
  then
    have p * (n / p) = n, from nat.mul_div_cancel' h,
    let ⟨s, hs⟩ :=
      order_core (n / p)
        (pos_of_mul_pos_left (this.symm ▸ n_pos : 0 < p * (n / p)) dec_trivial)
    in ⟨succ s, this ▸ (exactly_divides_succ (hp.trans dec_trivial)).mp hs⟩
  else ⟨0, (exactly_divides_zero (hp.trans dec_trivial)).mp h⟩

def order (n : ℕ) (n_pos : n > 0) : ℕ := (order.order_core p hp n n_pos).val

lemma exactly_divides_order (n : ℕ) (n_pos : n > 0) :
  p^(order p hp n n_pos) ∣∣ n :=
(order.order_core p hp n n_pos).property

end raw_order

/- XXX comments -/

instance : has_dvd ℕ+ := ⟨λ a b, a.val ∣ b.val⟩

def 𝓟 := {p : ℕ // prime p}
notation `PP` := 𝓟

def 𝓟.gt_one (p : 𝓟) : p.val > 1 := p.property.gt_one
def 𝓟.pos (p : 𝓟) : p.val > 0 := p.property.pos

instance : has_coe 𝓟 ℕ+ := ⟨λ p, ⟨p.val, p.pos⟩⟩

def ord (p : 𝓟) (n : ℕ+) : ℕ := order p p.gt_one n n.property
def exactly_divides_ord {p : 𝓟} {n : ℕ+} : p^(ord p n) ∣∣ n :=
exactly_divides_order p p.gt_one n n.property
def exactly_divides_iff_ord {p : 𝓟} {r : ℕ} {n : ℕ+} : ord p n = r ↔ p^r ∣∣ n :=
iff.intro
  (λ e, e ▸ exactly_divides_ord)
  (exactly_divides_unique exactly_divides_ord)

variable {p : 𝓟}

-- Recursion (though we prove them in a round-about fashion)

lemma ord_not_div {n : ℕ+} : ¬(↑p ∣ n) ↔ ord p n = 0 :=
(exactly_divides_zero p.pos).trans exactly_divides_iff_ord.symm

lemma ord_div {n : ℕ+} : ord p (p * n) = succ (ord p n) :=
exactly_divides_iff_ord.mpr
((exactly_divides_succ p.pos).mp exactly_divides_ord)

-- Multiplicative

lemma ord_one : ord p 1 = 0 :=
exactly_divides_iff_ord.mpr (exactly_divides_one p.property)

lemma ord_mul (a b : ℕ+) : ord p (a * b) = ord p a + ord p b :=
exactly_divides_iff_ord.mpr
(exactly_divides_mul p.property
  exactly_divides_ord exactly_divides_ord)

lemma ord_ppow {k : ℕ} {a : ℕ+} : ord p (pnat.pow a k) = k * ord p a :=
exactly_divides_iff_ord.mpr
(exactly_divides_pow p.property exactly_divides_ord)

lemma ord_pow {k : ℕ} {a : ℕ+} : ord p (a^k) = k * ord p a :=
have pnat.pow a k = a^k, from (pnat.coe_nat_coe _).symm, this ▸ ord_ppow

-- Gcd

def pgcd (a b : ℕ+) : ℕ+ := ⟨gcd a b, gcd_pos_of_pos_left b a.pos⟩

lemma ord_pgcd {a b : ℕ+} : ord p (pgcd a b) = min (ord p a) (ord p b) :=
exactly_divides_iff_ord.mpr
(exactly_divides_gcd
  exactly_divides_ord exactly_divides_ord)

lemma ord_gcd {a b : ℕ+} : ord p (gcd a b) = min (ord p a) (ord p b) :=
have pgcd a b = gcd a b, from (pnat.coe_nat_coe _).symm, this ▸ ord_pgcd

end order


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Bryan Gin-ge Chen
-/
import logic.relation
import order.galois_connection

/-!
# Equivalence relations

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

This file defines the complete lattice of equivalence relations on a type, results about the
inductively defined equivalence closure of a binary relation, and the analogues of some isomorphism
theorems for quotients of arbitrary types.

## Implementation notes

The function `rel` and lemmas ending in ' make it easier to talk about different
equivalence relations on the same type.

The complete lattice instance for equivalence relations could have been defined by lifting
the Galois insertion of equivalence relations on α into binary relations on α, and then using
`complete_lattice.copy` to define a complete lattice instance with more appropriate
definitional equalities (a similar example is `filter.complete_lattice` in
`order/filter/basic.lean`). This does not save space, however, and is less clear.

Partitions are not defined as a separate structure here; users are encouraged to
reason about them using the existing `setoid` and its infrastructure.

## Tags

setoid, equivalence, iseqv, relation, equivalence relation
-/
variables {α : Type*} {β : Type*}

/-- A version of `setoid.r` that takes the equivalence relation as an explicit argument. -/
def setoid.rel (r : setoid α) : α → α → Prop := @setoid.r _ r

instance setoid.decidable_rel (r : setoid α) [h : decidable_rel r.r] : decidable_rel r.rel := h

/-- A version of `quotient.eq'` compatible with `setoid.rel`, to make rewriting possible. -/
lemma quotient.eq_rel {r : setoid α} {x y} :
  (quotient.mk' x : quotient r) = quotient.mk' y ↔ r.rel x y := quotient.eq

namespace setoid

@[ext] lemma ext' {r s : setoid α} (H : ∀ a b, r.rel a b ↔ s.rel a b) :
  r = s := ext H

lemma ext_iff {r s : setoid α} : r = s ↔ ∀ a b, r.rel a b ↔ s.rel a b :=
⟨λ h a b, h ▸ iff.rfl, ext'⟩

/-- Two equivalence relations are equal iff their underlying binary operations are equal. -/
theorem eq_iff_rel_eq {r₁ r₂ : setoid α} : r₁ = r₂ ↔ r₁.rel = r₂.rel :=
⟨λ h, h ▸ rfl, λ h, setoid.ext' $ λ x y, h ▸ iff.rfl⟩

/-- Defining `≤` for equivalence relations. -/
instance : has_le (setoid α) := ⟨λ r s, ∀ ⦃x y⦄, r.rel x y → s.rel x y⟩

theorem le_def {r s : setoid α} : r ≤ s ↔ ∀ {x y}, r.rel x y → s.rel x y := iff.rfl

@[refl] lemma refl' (r : setoid α) (x) : r.rel x x := r.2.1 x
@[symm] lemma symm' (r : setoid α) : ∀ {x y}, r.rel x y → r.rel y x := λ _ _ h, r.2.2.1 h
@[trans]

lemma comm' (s : setoid α) {x y} : s.rel x y ↔ s.rel y x :=
⟨s.symm', s.symm'⟩

/-- The kernel of a function is an equivalence relation. -/
def ker (f : α → β) : setoid α :=
⟨(=) on f, eq_equivalence.comap f⟩

/-- The kernel of the quotient map induced by an equivalence relation r equals r. -/
@[simp] lemma ker_mk_eq (r : setoid α) : ker (@quotient.mk _ r) = r :=
ext' $ λ x y, quotient.eq

lemma ker_apply_mk_out {f : α → β} (a : α) :
  f (by haveI := setoid.ker f; exact ⟦a⟧.out) = f a :=
@quotient.mk_out _ (setoid.ker f) a

lemma ker_apply_mk_out' {f : α → β} (a : α) :
  f ((quotient.mk' a : quotient $ setoid.ker f).out') = f a :=
@quotient.mk_out' _ (setoid.ker f) a

lemma ker_def {f : α → β} {x y : α} : (ker f).rel x y ↔ f x = f y := iff.rfl

/-- Given types `α`, `β`, the product of two equivalence relations `r` on `α` and `s` on `β`:
    `(x₁, x₂), (y₁, y₂) ∈ α × β` are related by `r.prod s` iff `x₁` is related to `y₁`
    by `r` and `x₂` is related to `y₂` by `s`. -/
protected def prod (r : setoid α) (s : setoid β) : setoid (α × β) :=
{ r := λ x y, r.rel x.1 y.1 ∧ s.rel x.2 y.2,
  iseqv := ⟨λ x, ⟨r.refl' x.1, s.refl' x.2⟩, λ _ _ h, ⟨r.symm' h.1, s.symm' h.2⟩,
            λ _ _ _ h1 h2, ⟨r.trans' h1.1 h2.1, s.trans' h1.2 h2.2⟩⟩ }

/-- The infimum of two equivalence relations. -/
instance : has_inf (setoid α) :=
⟨λ r s, ⟨λ x y, r.rel x y ∧ s.rel x y, ⟨λ x, ⟨r.refl' x, s.refl' x⟩,
 λ _ _ h, ⟨r.symm' h.1, s.symm' h.2⟩,
 λ _ _ _ h1 h2, ⟨r.trans' h1.1 h2.1, s.trans' h1.2 h2.2⟩⟩⟩⟩

/-- The infimum of 2 equivalence relations r and s is the same relation as the infimum
    of the underlying binary operations. -/
lemma inf_def {r s : setoid α} : (r ⊓ s).rel = r.rel ⊓ s.rel := rfl

theorem inf_iff_and {r s : setoid α} {x y} :
  (r ⊓ s).rel x y ↔ r.rel x y ∧ s.rel x y := iff.rfl

/-- The infimum of a set of equivalence relations. -/
instance : has_Inf (setoid α) :=
⟨λ S, ⟨λ x y, ∀ r ∈ S, rel r x y,
⟨λ x r hr, r.refl' x, λ _ _ h r hr, r.symm' $ h r hr,
 λ _ _ _ h1 h2 r hr, r.trans' (h1 r hr) $ h2 r hr⟩⟩⟩

/-- The underlying binary operation of the infimum of a set of equivalence relations
    is the infimum of the set's image under the map to the underlying binary operation. -/
theorem Inf_def {s : set (setoid α)} : (Inf s).rel = Inf (rel '' s) :=
by { ext, simp only [Inf_image, infi_apply, infi_Prop_eq], refl }

instance : partial_order (setoid α) :=
{ le := (≤),
  lt := λ r s, r ≤ s ∧ ¬s ≤ r,
  le_refl := λ _ _ _, id,
  le_trans := λ _ _ _ hr hs _ _ h, hs $ hr h,
  lt_iff_le_not_le := λ _ _, iff.rfl,
  le_antisymm := λ r s h1 h2, setoid.ext' $ λ x y, ⟨λ h, h1 h, λ h, h2 h⟩ }

/-- The complete lattice of equivalence relations on a type, with bottom element `=`
    and top element the trivial equivalence relation. -/
instance complete_lattice : complete_lattice (setoid α) :=
{ inf := has_inf.inf,
  inf_le_left := λ _ _ _ _ h, h.1,
  inf_le_right := λ _ _ _ _ h, h.2,
  le_inf := λ _ _ _ h1 h2 _ _ h, ⟨h1 h, h2 h⟩,
  top := ⟨λ _ _, true, ⟨λ _, trivial, λ _ _ h, h, λ _ _ _ h1 h2, h1⟩⟩,
  le_top := λ _ _ _ _, trivial,
  bot := ⟨(=), ⟨λ _, rfl, λ _ _ h, h.symm, λ _ _ _ h1 h2, h1.trans h2⟩⟩,
  bot_le := λ r x y h, h ▸ r.2.1 x,
  .. complete_lattice_of_Inf (setoid α) $ assume s,
    ⟨λ r hr x y h, h _ hr, λ r hr x y h r' hr', hr hr' h⟩ }

@[simp]
lemma top_def : (⊤ : setoid α).rel = ⊤ := rfl

@[simp]
lemma bot_def : (⊥ : setoid α).rel = (=) := rfl

lemma eq_top_iff {s : setoid α} : s = (⊤ : setoid α) ↔ ∀ x y : α, s.rel x y :=
by simp [eq_top_iff, setoid.le_def, setoid.top_def, pi.top_apply]

/-- The inductively defined equivalence closure of a binary relation r is the infimum
    of the set of all equivalence relations containing r. -/
theorem eqv_gen_eq (r : α → α → Prop) :
  eqv_gen.setoid r = Inf {s : setoid α | ∀ ⦃x y⦄, r x y → s.rel x y} :=
le_antisymm
  (λ _ _ H, eqv_gen.rec (λ _ _ h _ hs, hs h) (refl' _)
    (λ _ _ _, symm' _) (λ _ _ _ _ _, trans' _) H)
  (Inf_le $ λ _ _ h, eqv_gen.rel _ _ h)

/-- The supremum of two equivalence relations r and s is the equivalence closure of the binary
    relation `x is related to y by r or s`. -/
lemma sup_eq_eqv_gen (r s : setoid α) :
  r ⊔ s = eqv_gen.setoid (λ x y, r.rel x y ∨ s.rel x y) :=
begin
  rw eqv_gen_eq,
  apply congr_arg Inf,
  simp only [le_def, or_imp_distrib, ← forall_and_distrib]
end

/-- The supremum of 2 equivalence relations r and s is the equivalence closure of the
    supremum of the underlying binary operations. -/
lemma sup_def {r s : setoid α} : r ⊔ s = eqv_gen.setoid (r.rel ⊔ s.rel) :=
by rw sup_eq_eqv_gen; refl

/-- The supremum of a set S of equivalence relations is the equivalence closure of the binary
    relation `there exists r ∈ S relating x and y`. -/
lemma Sup_eq_eqv_gen (S : set (setoid α)) :
  Sup S = eqv_gen.setoid (λ x y, ∃ r : setoid α, r ∈ S ∧ r.rel x y) :=
begin
  rw eqv_gen_eq,
  apply congr_arg Inf,
  simp only [upper_bounds, le_def, and_imp, exists_imp_distrib],
  ext,
  exact ⟨λ H x y r hr, H hr, λ H r hr x y, H r hr⟩
end

/-- The supremum of a set of equivalence relations is the equivalence closure of the
    supremum of the set's image under the map to the underlying binary operation. -/
lemma Sup_def {s : set (setoid α)} : Sup s = eqv_gen.setoid (Sup (rel '' s)) :=
begin
  rw [Sup_eq_eqv_gen, Sup_image],
  congr' with x y,
  simp only [supr_apply, supr_Prop_eq, exists_prop]
end

/-- The equivalence closure of an equivalence relation r is r. -/
@[simp] lemma eqv_gen_of_setoid (r : setoid α) : eqv_gen.setoid r.r = r :=
le_antisymm (by rw eqv_gen_eq; exact Inf_le (λ _ _, id)) eqv_gen.rel

/-- Equivalence closure is idempotent. -/
@[simp] lemma eqv_gen_idem (r : α → α → Prop) :
  eqv_gen.setoid (eqv_gen.setoid r).rel = eqv_gen.setoid r :=
eqv_gen_of_setoid _

/-- The equivalence closure of a binary relation r is contained in any equivalence
    relation containing r. -/
theorem eqv_gen_le {r : α → α → Prop} {s : setoid α} (h : ∀ x y, r x y → s.rel x y) :
  eqv_gen.setoid r ≤ s :=
by rw eqv_gen_eq; exact Inf_le h

/-- Equivalence closure of binary relations is monotone. -/
theorem eqv_gen_mono {r s : α → α → Prop} (h : ∀ x y, r x y → s x y) :
  eqv_gen.setoid r ≤ eqv_gen.setoid s :=
eqv_gen_le $ λ _ _ hr, eqv_gen.rel _ _ $ h _ _ hr

/-- There is a Galois insertion of equivalence relations on α into binary relations
    on α, with equivalence closure the lower adjoint. -/
def gi : @galois_insertion (α → α → Prop) (setoid α) _ _ eqv_gen.setoid rel :=
{ choice := λ r h, eqv_gen.setoid r,
  gc := λ r s, ⟨λ H _ _ h, H $ eqv_gen.rel _ _ h, λ H, eqv_gen_of_setoid s ▸ eqv_gen_mono H⟩,
  le_l_u := λ x, (eqv_gen_of_setoid x).symm ▸ le_refl x,
  choice_eq := λ _ _, rfl }

open function

/-- A function from α to β is injective iff its kernel is the bottom element of the complete lattice
    of equivalence relations on α. -/
theorem injective_iff_ker_bot (f : α → β) :
  injective f ↔ ker f = ⊥ :=
(@eq_bot_iff (setoid α) _ _ (ker f)).symm

/-- The elements related to x ∈ α by the kernel of f are those in the preimage of f(x) under f. -/
lemma ker_iff_mem_preimage {f : α → β} {x y} : (ker f).rel x y ↔ x ∈ f ⁻¹' {f y} :=
iff.rfl

/-- Equivalence between functions `α → β` such that `r x y → f x = f y` and functions
`quotient r → β`. -/
def lift_equiv (r : setoid α) : {f : α → β // r ≤ ker f} ≃ (quotient r → β) :=
{ to_fun := λ f, quotient.lift (f : α → β) f.2,
  inv_fun := λ f, ⟨f ∘ quotient.mk, λ x y h, by simp [ker_def, quotient.sound h]⟩,
  left_inv := λ ⟨f, hf⟩, subtype.eq $ funext $ λ x, rfl,
  right_inv := λ f, funext $ λ x, quotient.induction_on' x $ λ x, rfl }

/-- The uniqueness part of the universal property for quotients of an arbitrary type. -/
theorem lift_unique {r : setoid α} {f : α → β} (H : r ≤ ker f) (g : quotient r → β)
  (Hg : f = g ∘ quotient.mk) : quotient.lift f H = g :=
begin
  ext ⟨x⟩,
  erw [quotient.lift_mk f H, Hg],
  refl
end

/-- Given a map f from α to β, the natural map from the quotient of α by the kernel of f is
    injective. -/
lemma ker_lift_injective (f : α → β) : injective (@quotient.lift _ _ (ker f) f (λ _ _ h, h)) :=
λ x y, quotient.induction_on₂' x y $ λ a b h, quotient.sound' h

/-- Given a map f from α to β, the kernel of f is the unique equivalence relation on α whose
    induced map from the quotient of α to β is injective. -/
lemma ker_eq_lift_of_injective {r : setoid α} (f : α → β) (H : ∀ x y, r.rel x y → f x = f y)
  (h : injective (quotient.lift f H)) : ker f = r :=
le_antisymm
  (λ x y hk, quotient.exact $ h $ show quotient.lift f H ⟦x⟧ = quotient.lift f H ⟦y⟧, from hk)
  H

variables (r : setoid α) (f : α → β)

/-- The first isomorphism theorem for sets: the quotient of α by the kernel of a function f
    bijects with f's image. -/
noncomputable def quotient_ker_equiv_range :
  quotient (ker f) ≃ set.range f :=
equiv.of_bijective (@quotient.lift _ (set.range f) (ker f)
  (λ x, ⟨f x, set.mem_range_self x⟩) $ λ _ _ h, subtype.ext_val h)
  ⟨λ x y h, ker_lift_injective f $ by rcases x; rcases y; injections,
   λ ⟨w, z, hz⟩, ⟨@quotient.mk _ (ker f) z, by rw quotient.lift_mk; exact subtype.ext_iff_val.2 hz⟩⟩

/-- If `f` has a computable right-inverse, then the quotient by its kernel is equivalent to its
domain. -/
@[simps]
def quotient_ker_equiv_of_right_inverse (g : β → α) (hf : function.right_inverse g f) :
  quotient (ker f) ≃ β :=
{ to_fun := λ a, quotient.lift_on' a f $ λ _ _, id,
  inv_fun := λ b, quotient.mk' (g b),
  left_inv := λ a, quotient.induction_on' a $ λ a, quotient.sound' $ by exact hf (f a),
  right_inv := hf }

/-- The quotient of α by the kernel of a surjective function f bijects with f's codomain.

If a specific right-inverse of `f` is known, `setoid.quotient_ker_equiv_of_right_inverse` can be
definitionally more useful. -/
noncomputable def quotient_ker_equiv_of_surjective (hf : surjective f) :
  quotient (ker f) ≃ β :=
quotient_ker_equiv_of_right_inverse _ (function.surj_inv hf) (right_inverse_surj_inv hf)

variables {r f}

/-- Given a function `f : α → β` and equivalence relation `r` on `α`, the equivalence
    closure of the relation on `f`'s image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are
    related to the elements of `f⁻¹(y)` by `r`.' -/
def map (r : setoid α) (f : α → β) : setoid β :=
eqv_gen.setoid $ λ x y, ∃ a b, f a = x ∧ f b = y ∧ r.rel a b

/-- Given a surjective function f whose kernel is contained in an equivalence relation r, the
    equivalence relation on f's codomain defined by x ≈ y ↔ the elements of f⁻¹(x) are related to
    the elements of f⁻¹(y) by r. -/
def map_of_surjective (r) (f : α → β) (h : ker f ≤ r) (hf : surjective f) :
  setoid β :=
⟨λ x y, ∃ a b, f a = x ∧ f b = y ∧ r.rel a b,
  ⟨λ x, let ⟨y, hy⟩ := hf x in ⟨y, y, hy, hy, r.refl' y⟩,
   λ _ _ ⟨x, y, hx, hy, h⟩, ⟨y, x, hy, hx, r.symm' h⟩,
   λ _ _ _ ⟨x, y, hx, hy, h₁⟩ ⟨y', z, hy', hz, h₂⟩,
     ⟨x, z, hx, hz, r.trans' h₁ $ r.trans' (h $ by rwa ←hy' at hy) h₂⟩⟩⟩

/-- A special case of the equivalence closure of an equivalence relation r equalling r. -/
lemma map_of_surjective_eq_map (h : ker f ≤ r) (hf : surjective f) :
  map r f = map_of_surjective r f h hf :=
by rw ←eqv_gen_of_setoid (map_of_surjective r f h hf); refl

/-- Given a function `f : α → β`, an equivalence relation `r` on `β` induces an equivalence
relation on `α` defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `r`'.

See note [reducible non-instances]. -/
@[reducible]
def comap (f : α → β) (r : setoid β) : setoid α :=
⟨r.rel on f, r.iseqv.comap _⟩

lemma comap_rel (f : α → β) (r : setoid β) (x y : α) : (comap f r).rel x y ↔ r.rel (f x) (f y) :=
iff.rfl

/-- Given a map `f : N → M` and an equivalence relation `r` on `β`, the equivalence relation
    induced on `α` by `f` equals the kernel of `r`'s quotient map composed with `f`. -/
lemma comap_eq {f : α → β} {r : setoid β} : comap f r = ker (@quotient.mk _ r ∘ f) :=
ext $ λ x y, show _ ↔ ⟦_⟧ = ⟦_⟧, by rw quotient.eq; refl

/-- The second isomorphism theorem for sets. -/
noncomputable def comap_quotient_equiv (f : α → β) (r : setoid β) :
  quotient (comap f r) ≃ set.range (@quotient.mk _ r ∘ f) :=
(quotient.congr_right $ ext_iff.1 comap_eq).trans $ quotient_ker_equiv_range $ quotient.mk ∘ f

variables (r f)

/-- The third isomorphism theorem for sets. -/
def quotient_quotient_equiv_quotient (s : setoid α) (h : r ≤ s) :
  quotient (ker (quot.map_right h)) ≃ quotient s :=
{ to_fun := λ x, quotient.lift_on' x (λ w, quotient.lift_on' w (@quotient.mk _ s) $
    λ x y H, quotient.sound $ h H) $ λ x y, quotient.induction_on₂' x y $ λ w z H,
      show @quot.mk _ _ _ = @quot.mk _ _ _, from H,
  inv_fun := λ x, quotient.lift_on' x
    (λ w, @quotient.mk _ (ker $ quot.map_right h) $ @quotient.mk _ r w) $
      λ x y H, quotient.sound' $ show @quot.mk _ _ _ = @quot.mk _ _ _, from quotient.sound H,
  left_inv := λ x, quotient.induction_on' x $ λ y, quotient.induction_on' y $
    λ w, by show ⟦_⟧ = _; refl,
  right_inv := λ x, quotient.induction_on' x $ λ y, by show ⟦_⟧ = _; refl }

variables {r f}

open quotient

/-- Given an equivalence relation `r` on `α`, the order-preserving bijection between the set of
equivalence relations containing `r` and the equivalence relations on the quotient of `α` by `r`. -/
def correspondence (r : setoid α) : {s // r ≤ s} ≃o setoid (quotient r) :=
{ to_fun := λ s, map_of_surjective s.1 quotient.mk ((ker_mk_eq r).symm ▸ s.2) exists_rep,
  inv_fun := λ s, ⟨comap quotient.mk' s, λ x y h, by rw [comap_rel, eq_rel.2 h]⟩,
  left_inv := λ s, subtype.ext_iff_val.2 $ ext' $ λ _ _,
    ⟨λ h, let ⟨a, b, hx, hy, H⟩ := h in
      s.1.trans' (s.1.symm' $ s.2 $ eq_rel.1 hx) $ s.1.trans' H $ s.2 $ eq_rel.1 hy,
     λ h, ⟨_, _, rfl, rfl, h⟩⟩,
  right_inv := λ s, let Hm : ker quotient.mk' ≤ comap quotient.mk' s :=
      λ x y h, by rw [comap_rel, (@eq_rel _ r x y).2 ((ker_mk_eq r) ▸ h)] in
    ext' $ λ x y, ⟨λ h, let ⟨a, b, hx, hy, H⟩ := h in hx ▸ hy ▸ H,
      quotient.induction_on₂ x y $ λ w z h, ⟨w, z, rfl, rfl, h⟩⟩,
  map_rel_iff' := λ s t, ⟨λ h x y hs, let ⟨a, b, hx, hy, ht⟩ := h ⟨x, y, rfl, rfl, hs⟩ in
      t.1.trans' (t.1.symm' $ t.2 $ eq_rel.1 hx) $ t.1.trans' ht $ t.2 $ eq_rel.1 hy,
      λ h x y hs, let ⟨a, b, hx, hy, Hs⟩ := hs in ⟨a, b, hx, hy, h Hs⟩⟩ }

end setoid

@[simp]
lemma quotient.subsingleton_iff  {s : setoid α} :
  subsingleton (quotient s) ↔ s = ⊤ :=
begin
  simp only [subsingleton_iff, eq_top_iff, setoid.le_def, setoid.top_def,
    pi.top_apply, forall_const],
  refine (surjective_quotient_mk _).forall.trans (forall_congr $ λ a, _),
  refine (surjective_quotient_mk _).forall.trans (forall_congr $ λ b, _),
  exact quotient.eq',
end

lemma quot.subsingleton_iff (r : α → α → Prop) : subsingleton (quot r) ↔ eqv_gen r = ⊤ :=
begin
  simp only [subsingleton_iff, _root_.eq_top_iff, pi.le_def, pi.top_apply, forall_const],
  refine (surjective_quot_mk _).forall.trans (forall_congr $ λ a, _),
  refine (surjective_quot_mk _).forall.trans (forall_congr $ λ b, _),
  rw quot.eq,
  simp only [forall_const, le_Prop_eq],
end


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

! This file was ported from Lean 3 source module computability.NFA
! leanprover-community/mathlib commit 23aa88e32dcc9d2a24cca7bc23268567ed4cd7d6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Computability.DFA
import Mathbin.Data.Fintype.Powerset

/-!
# Nondeterministic Finite Automata

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
This file contains the definition of a Nondeterministic Finite Automaton (NFA), a state machine
which determines whether a string (implemented as a list over an arbitrary alphabet) is in a regular
set by evaluating the string over every possible path.
We show that DFA's are equivalent to NFA's however the construction from NFA to DFA uses an
exponential number of states.
Note that this definition allows for Automaton with infinite states, a `fintype` instance must be
supplied for true NFA's.
-/

open Set

open Computability

universe u v

#print NFA /-
/-- An NFA is a set of states (`σ`), a transition function from state to state labelled by the
  alphabet (`step`), a starting state (`start`) and a set of acceptance states (`accept`).
  Note the transition function sends a state to a `set` of states. These are the states that it
  may be sent to. -/
structure NFA (α : Type u) (σ : Type v) where
  step : σ → α → Set σ
  start : Set σ
  accept : Set σ
#align NFA NFA
-/

variable {α : Type u} {σ σ' : Type v} (M : NFA α σ)

namespace NFA

instance : Inhabited (NFA α σ) :=
  ⟨NFA.mk (fun _ _ => ∅) ∅ ∅⟩

#print NFA.stepSet /-
/-- `M.step_set S a` is the union of `M.step s a` for all `s ∈ S`. -/
def stepSet (S : Set σ) (a : α) : Set σ :=
  ⋃ s ∈ S, M.step s a
#align NFA.step_set NFA.stepSet
-/

/- warning: NFA.mem_step_set -> NFA.mem_stepSet is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : Type.{u2}} (M : NFA.{u1, u2} α σ) (s : σ) (S : Set.{u2} σ) (a : α), Iff (Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) s (NFA.stepSet.{u1, u2} α σ M S a)) (Exists.{succ u2} σ (fun (t : σ) => Exists.{0} (Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) t S) (fun (H : Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) t S) => Membership.Mem.{u2, u2} σ (Set.{u2} σ) (Set.hasMem.{u2} σ) s (NFA.step.{u1, u2} α σ M t a))))
but is expected to have type
  forall {α : Type.{u1}} {σ : Type.{u2}} (M : NFA.{u1, u2} α σ) (s : σ) (S : Set.{u2} σ) (a : α), Iff (Membership.mem.{u2, u2} σ (Set.{u2} σ) (Set.instMembershipSet.{u2} σ) s (NFA.stepSet.{u1, u2} α σ M S a)) (Exists.{succ u2} σ (fun (t : σ) => And (Membership.mem.{u2, u2} σ (Set.{u2} σ) (Set.instMembershipSet.{u2} σ) t S) (Membership.mem.{u2, u2} σ (Set.{u2} σ) (Set.instMembershipSet.{u2} σ) s (NFA.step.{u1, u2} α σ M t a))))
Case conversion may be inaccurate. Consider using '#align NFA.mem_step_set NFA.mem_stepSetₓ'. -/
theorem mem_stepSet (s : σ) (S : Set σ) (a : α) : s ∈ M.stepSet S a ↔ ∃ t ∈ S, s ∈ M.step t a :=
  mem_unionᵢ₂
#align NFA.mem_step_set NFA.mem_stepSet

#print NFA.stepSet_empty /-
@[simp]
theorem stepSet_empty (a : α) : M.stepSet ∅ a = ∅ := by simp_rw [step_set, Union_false, Union_empty]
#align NFA.step_set_empty NFA.stepSet_empty
-/

#print NFA.evalFrom /-
/-- `M.eval_from S x` computes all possible paths though `M` with input `x` starting at an element
  of `S`. -/
def evalFrom (start : Set σ) : List α → Set σ :=
  List.foldl M.stepSet start
#align NFA.eval_from NFA.evalFrom
-/

#print NFA.evalFrom_nil /-
@[simp]
theorem evalFrom_nil (S : Set σ) : M.evalFrom S [] = S :=
  rfl
#align NFA.eval_from_nil NFA.evalFrom_nil
-/

#print NFA.evalFrom_singleton /-
@[simp]
theorem evalFrom_singleton (S : Set σ) (a : α) : M.evalFrom S [a] = M.stepSet S a :=
  rfl
#align NFA.eval_from_singleton NFA.evalFrom_singleton
-/

#print NFA.evalFrom_append_singleton /-
@[simp]
theorem evalFrom_append_singleton (S : Set σ) (x : List α) (a : α) :
    M.evalFrom S (x ++ [a]) = M.stepSet (M.evalFrom S x) a := by
  simp only [eval_from, List.foldl_append, List.foldl_cons, List.foldl_nil]
#align NFA.eval_from_append_singleton NFA.evalFrom_append_singleton
-/

#print NFA.eval /-
/-- `M.eval x` computes all possible paths though `M` with input `x` starting at an element of
  `M.start`. -/
def eval : List α → Set σ :=
  M.evalFrom M.start
#align NFA.eval NFA.eval
-/

#print NFA.eval_nil /-
@[simp]
theorem eval_nil : M.eval [] = M.start :=
  rfl
#align NFA.eval_nil NFA.eval_nil
-/

#print NFA.eval_singleton /-
@[simp]
theorem eval_singleton (a : α) : M.eval [a] = M.stepSet M.start a :=
  rfl
#align NFA.eval_singleton NFA.eval_singleton
-/

#print NFA.eval_append_singleton /-
@[simp]
theorem eval_append_singleton (x : List α) (a : α) : M.eval (x ++ [a]) = M.stepSet (M.eval x) a :=
  evalFrom_append_singleton _ _ _ _
#align NFA.eval_append_singleton NFA.eval_append_singleton
-/

#print NFA.accepts /-
/-- `M.accepts` is the language of `x` such that there is an accept state in `M.eval x`. -/
def accepts : Language α := fun x => ∃ S ∈ M.accept, S ∈ M.eval x
#align NFA.accepts NFA.accepts
-/

#print NFA.toDFA /-
/-- `M.to_DFA` is an `DFA` constructed from a `NFA` `M` using the subset construction. The
  states is the type of `set`s of `M.state` and the step function is `M.step_set`. -/
def toDFA : DFA α (Set σ) where
  step := M.stepSet
  start := M.start
  accept := { S | ∃ s ∈ S, s ∈ M.accept }
#align NFA.to_DFA NFA.toDFA
-/

#print NFA.toDFA_correct /-
@[simp]
theorem toDFA_correct : M.toDFA.accepts = M.accepts :=
  by
  ext x
  rw [accepts, DFA.accepts, eval, DFA.eval]
  change List.foldl _ _ _ ∈ { S | _ } ↔ _
  constructor <;> · exact fun ⟨w, h2, h3⟩ => ⟨w, h3, h2⟩
#align NFA.to_DFA_correct NFA.toDFA_correct
-/

/- warning: NFA.pumping_lemma -> NFA.pumping_lemma is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {σ : Type.{u2}} (M : NFA.{u1, u2} α σ) [_inst_1 : Fintype.{u2} σ] {x : List.{u1} α}, (Membership.Mem.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasMem.{u1} α) x (NFA.accepts.{u1, u2} α σ M)) -> (LE.le.{0} Nat Nat.hasLe (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1)) (List.length.{u1} α x)) -> (Exists.{succ u1} (List.{u1} α) (fun (a : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (b : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (c : List.{u1} α) => And (Eq.{succ u1} (List.{u1} α) x (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) (Append.append.{u1} (List.{u1} α) (List.hasAppend.{u1} α) a b) c)) (And (LE.le.{0} Nat Nat.hasLe (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (List.length.{u1} α a) (List.length.{u1} α b)) (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1))) (And (Ne.{succ u1} (List.{u1} α) b (List.nil.{u1} α)) (LE.le.{u1} (Language.{u1} α) (Preorder.toLE.{u1} (Language.{u1} α) (PartialOrder.toPreorder.{u1} (Language.{u1} α) (CompleteSemilatticeInf.toPartialOrder.{u1} (Language.{u1} α) (CompleteLattice.toCompleteSemilatticeInf.{u1} (Language.{u1} α) (Order.Coframe.toCompleteLattice.{u1} (Language.{u1} α) (CompleteDistribLattice.toCoframe.{u1} (Language.{u1} α) (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} (Language.{u1} α) (Language.completeBooleanAlgebra.{u1} α)))))))) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.hasMul.{u1} α)) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.hasMul.{u1} α)) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasSingleton.{u1} α) a) (KStar.kstar.{u1} (Language.{u1} α) (Language.hasKstar.{u1} α) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasSingleton.{u1} α) b))) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (Language.hasSingleton.{u1} α) c)) (NFA.accepts.{u1, u2} α σ M))))))))
but is expected to have type
  forall {α : Type.{u1}} {σ : Type.{u2}} (M : NFA.{u1, u2} α σ) [_inst_1 : Fintype.{u2} σ] {x : List.{u1} α}, (Membership.mem.{u1, u1} (List.{u1} α) (Language.{u1} α) (instMembershipListLanguage.{u1} α) x (NFA.accepts.{u1, u2} α σ M)) -> (LE.le.{0} Nat instLENat (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1)) (List.length.{u1} α x)) -> (Exists.{succ u1} (List.{u1} α) (fun (a : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (b : List.{u1} α) => Exists.{succ u1} (List.{u1} α) (fun (c : List.{u1} α) => And (Eq.{succ u1} (List.{u1} α) x (HAppend.hAppend.{u1, u1, u1} (List.{u1} α) (List.{u1} α) (List.{u1} α) (instHAppend.{u1} (List.{u1} α) (List.instAppendList.{u1} α)) (HAppend.hAppend.{u1, u1, u1} (List.{u1} α) (List.{u1} α) (List.{u1} α) (instHAppend.{u1} (List.{u1} α) (List.instAppendList.{u1} α)) a b) c)) (And (LE.le.{0} Nat instLENat (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (List.length.{u1} α a) (List.length.{u1} α b)) (Fintype.card.{u2} (Set.{u2} σ) (Set.fintype.{u2} σ _inst_1))) (And (Ne.{succ u1} (List.{u1} α) b (List.nil.{u1} α)) (LE.le.{u1} (Language.{u1} α) (Preorder.toLE.{u1} (Language.{u1} α) (PartialOrder.toPreorder.{u1} (Language.{u1} α) (CompleteSemilatticeInf.toPartialOrder.{u1} (Language.{u1} α) (CompleteLattice.toCompleteSemilatticeInf.{u1} (Language.{u1} α) (Order.Coframe.toCompleteLattice.{u1} (Language.{u1} α) (CompleteDistribLattice.toCoframe.{u1} (Language.{u1} α) (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} (Language.{u1} α) (instCompleteBooleanAlgebraLanguage.{u1} α)))))))) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.instMulLanguage.{u1} α)) (HMul.hMul.{u1, u1, u1} (Language.{u1} α) (Language.{u1} α) (Language.{u1} α) (instHMul.{u1} (Language.{u1} α) (Language.instMulLanguage.{u1} α)) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (instSingletonListLanguage.{u1} α) a) (KStar.kstar.{u1} (Language.{u1} α) (Language.instKStarLanguage.{u1} α) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (instSingletonListLanguage.{u1} α) b))) (Singleton.singleton.{u1, u1} (List.{u1} α) (Language.{u1} α) (instSingletonListLanguage.{u1} α) c)) (NFA.accepts.{u1, u2} α σ M))))))))
Case conversion may be inaccurate. Consider using '#align NFA.pumping_lemma NFA.pumping_lemmaₓ'. -/
theorem pumping_lemma [Fintype σ] {x : List α} (hx : x ∈ M.accepts)
    (hlen : Fintype.card (Set σ) ≤ List.length x) :
    ∃ a b c,
      x = a ++ b ++ c ∧
        a.length + b.length ≤ Fintype.card (Set σ) ∧ b ≠ [] ∧ {a} * {b}∗ * {c} ≤ M.accepts :=
  by
  rw [← to_DFA_correct] at hx⊢
  exact M.to_DFA.pumping_lemma hx hlen
#align NFA.pumping_lemma NFA.pumping_lemma

end NFA

namespace DFA

#print DFA.toNFA /-
/-- `M.to_NFA` is an `NFA` constructed from a `DFA` `M` by using the same start and accept
  states and a transition function which sends `s` with input `a` to the singleton `M.step s a`. -/
def toNFA (M : DFA α σ') : NFA α σ'
    where
  step s a := {M.step s a}
  start := {M.start}
  accept := M.accept
#align DFA.to_NFA DFA.toNFA
-/

#print DFA.toNFA_evalFrom_match /-
@[simp]
theorem toNFA_evalFrom_match (M : DFA α σ) (start : σ) (s : List α) :
    M.toNFA.evalFrom {start} s = {M.evalFrom start s} :=
  by
  change List.foldl M.to_NFA.step_set {start} s = {List.foldl M.step start s}
  induction' s with a s ih generalizing start
  · tauto
  · rw [List.foldl, List.foldl,
      show M.to_NFA.step_set {start} a = {M.step start a} by simpa [NFA.stepSet] ]
    tauto
#align DFA.to_NFA_eval_from_match DFA.toNFA_evalFrom_match
-/

#print DFA.toNFA_correct /-
@[simp]
theorem toNFA_correct (M : DFA α σ) : M.toNFA.accepts = M.accepts :=
  by
  ext x
  change (∃ S H, S ∈ M.to_NFA.eval_from {M.start} x) ↔ _
  rw [to_NFA_eval_from_match]
  constructor
  · rintro ⟨S, hS₁, hS₂⟩
    rwa [set.mem_singleton_iff.mp hS₂] at hS₁
  · exact fun h => ⟨M.eval x, h, rfl⟩
#align DFA.to_NFA_correct DFA.toNFA_correct
-/

end DFA


inductive natu : Type
| Zer : natu
| Suc : natu -> natu

#check natu.rec

theorem t1 : ∀ p q r : Prop, (p->(q->r)) ↔ (p ∧ q) -> r :=
begin
    intros,
    apply iff.intro,
    {
        intros,
        apply a,
        cases a_1,
        assumption,
        cases a_1,
        assumption,
    },
    {
        intros,
        apply a,
        show p ∧ q, from and.intro a_1 a_2,
    }
end

theorem t2 : ∀ p, ¬ ¬ ¬ p ↔ ¬ p :=
begin
intros,
apply iff.intro,
{
    intros,
    apply not.intro,
    intros,
    apply a,
    apply not.intro,
    intros,
    apply a_2,
    assumption,
},
{
    intros,
    apply not.intro,
    intros,
    apply a_1,
    assumption,
}
end

theorem demorgan_l : ∀ p q, ¬ p ∧ ¬ q ↔ ¬ (p ∨ q) :=
begin
intros,
apply iff.intro,
{
    intros,
    cases a,
    apply not.intro,
    intros,
    cases a,
    {
        apply a_left,
        assumption,
    },
    {
        apply a_right,
        assumption,
    }
},
{
    intros,
    apply and.intro,
    {
        apply not.intro,
        intros,
        apply a,
        apply or.intro_left,
        assumption,
    },
    {
        apply not.intro,
        intros,
        apply a,
        apply or.intro_right,
        assumption,
    }
}
end

theorem demorgan_2 : ∀ p q, ¬ p ∨ ¬ q → ¬ (p ∧ q) :=
begin
intros,
apply not.intro,
intros,
cases a_1,
{
    cases a,
    {
        apply a,
        assumption,
    },
    {
        apply a,
        assumption,
    }
}
end

theorem t3 : ∀ p q, ¬¬ (p ∧ q) ↔ ¬¬ p ∧ ¬¬ q :=
begin
intros,
apply iff.intro,
{
    intros,
    apply and.intro,
    {
        apply not.intro,
        intros,
        apply a,
        apply not.intro,
        intros,
        cases a_2,
        apply a_1,
        assumption,
    },
    {
        apply not.intro,
        intros,
        apply a,
        apply not.intro,
        intros,
        cases a_2,
        apply a_1,
        exact a_2_right,
    }
},
{
    intros,
    apply not.intro,
    intros,
    cases a,
    apply a_1,
    have both : ¬¬ p ∨ ¬¬ q,
    {
        apply or.intro_left,
        assumption,
    },
    have dmo : ¬ (¬p ∧ ¬ q),
    {
        apply demorgan_2,
        assumption,
    },
    exfalso,
    apply dmo,
    apply and.intro,
    {
        apply not.intro,
        intros,
        have a_1_impl : (p ∧ q) -> false,
        {
            apply a_1,
        },
        have qtf : q → false,
        {
            intros,
            apply a_1_impl,
            exact and.intro a a_2,
        },
        have dumb : (q -> false) -> false,
        {
            apply a_right,
        },
        apply dumb,
        apply qtf,
    },
    {
        apply not.intro,
        intros,
        have a_1_impl : (p ∧ q) -> false,
        {
            apply a_1,
        },
        have qtf : p → false,
        {
            intros,
            apply a_1_impl,
            exact and.intro a_2 a,
        },
        have dumb : (p -> false) -> false,
        {
            apply a_left,
        },
        apply dumb,
        apply qtf,
    }
}
end


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

! This file was ported from Lean 3 source module linear_algebra.clifford_algebra.equivs
! leanprover-community/mathlib commit 4d66277cfec381260ba05c68f9ae6ce2a118031d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.DualNumber
import Mathbin.Algebra.QuaternionBasis
import Mathbin.Data.Complex.Module
import Mathbin.LinearAlgebra.CliffordAlgebra.Conjugation
import Mathbin.LinearAlgebra.CliffordAlgebra.Star
import Mathbin.LinearAlgebra.QuadraticForm.Prod

/-!
# Other constructions isomorphic to Clifford Algebras

This file contains isomorphisms showing that other types are equivalent to some `clifford_algebra`.

## Rings

* `clifford_algebra_ring.equiv`: any ring is equivalent to a `clifford_algebra` over a
  zero-dimensional vector space.

## Complex numbers

* `clifford_algebra_complex.equiv`: the `complex` numbers are equivalent as an `ℝ`-algebra to a
  `clifford_algebra` over a one-dimensional vector space with a quadratic form that satisfies
  `Q (ι Q 1) = -1`.
* `clifford_algebra_complex.to_complex`: the forward direction of this equiv
* `clifford_algebra_complex.of_complex`: the reverse direction of this equiv

We show additionally that this equivalence sends `complex.conj` to `clifford_algebra.involute` and
vice-versa:

* `clifford_algebra_complex.to_complex_involute`
* `clifford_algebra_complex.of_complex_conj`

Note that in this algebra `clifford_algebra.reverse` is the identity and so the clifford conjugate
is the same as `clifford_algebra.involute`.

## Quaternion algebras

* `clifford_algebra_quaternion.equiv`: a `quaternion_algebra` over `R` is equivalent as an
  `R`-algebra to a clifford algebra over `R × R`, sending `i` to `(0, 1)` and `j` to `(1, 0)`.
* `clifford_algebra_quaternion.to_quaternion`: the forward direction of this equiv
* `clifford_algebra_quaternion.of_quaternion`: the reverse direction of this equiv

We show additionally that this equivalence sends `quaternion_algebra.conj` to the clifford conjugate
and vice-versa:

* `clifford_algebra_quaternion.to_quaternion_star`
* `clifford_algebra_quaternion.of_quaternion_conj`

## Dual numbers

* `clifford_algebra_dual_number.equiv`: `R[ε]` is is equivalent as an `R`-algebra to a clifford
  algebra over `R` where `Q = 0`.

-/

open CliffordAlgebra

/-! ### The clifford algebra isomorphic to a ring -/

namespace CliffordAlgebraRing

open ComplexConjugate

variable {R : Type _} [CommRing R]

@[simp]
theorem ι_eq_zero : ι (0 : QuadraticForm R Unit) = 0 :=
  Subsingleton.elim _ _
#align clifford_algebra_ring.ι_eq_zero CliffordAlgebraRing.ι_eq_zero

/-- Since the vector space is empty the ring is commutative. -/
instance : CommRing (CliffordAlgebra (0 : QuadraticForm R Unit)) :=
  { CliffordAlgebra.ring _ with
    mul_comm := fun x y => by
      induction x using CliffordAlgebra.induction
      case h_grade0 r => apply Algebra.commutes
      case h_grade1 x => simp
      case h_add x₁ x₂ hx₁ hx₂ => rw [mul_add, add_mul, hx₁, hx₂]
      case h_mul x₁ x₂ hx₁ hx₂ => rw [mul_assoc, hx₂, ← mul_assoc, hx₁, ← mul_assoc] }

theorem reverse_apply (x : CliffordAlgebra (0 : QuadraticForm R Unit)) : x.reverse = x :=
  by
  induction x using CliffordAlgebra.induction
  case h_grade0 r => exact reverse.commutes _
  case h_grade1 x => rw [ι_eq_zero, LinearMap.zero_apply, reverse.map_zero]
  case h_mul x₁ x₂ hx₁ hx₂ => rw [reverse.map_mul, mul_comm, hx₁, hx₂]
  case h_add x₁ x₂ hx₁ hx₂ => rw [reverse.map_add, hx₁, hx₂]
#align clifford_algebra_ring.reverse_apply CliffordAlgebraRing.reverse_apply

@[simp]
theorem reverse_eq_id :
    (reverse : CliffordAlgebra (0 : QuadraticForm R Unit) →ₗ[R] _) = LinearMap.id :=
  LinearMap.ext reverse_apply
#align clifford_algebra_ring.reverse_eq_id CliffordAlgebraRing.reverse_eq_id

@[simp]
theorem involute_eq_id :
    (involute : CliffordAlgebra (0 : QuadraticForm R Unit) →ₐ[R] _) = AlgHom.id R _ :=
  by
  ext
  simp
#align clifford_algebra_ring.involute_eq_id CliffordAlgebraRing.involute_eq_id

/-- The clifford algebra over a 0-dimensional vector space is isomorphic to its scalars. -/
protected def equiv : CliffordAlgebra (0 : QuadraticForm R Unit) ≃ₐ[R] R :=
  AlgEquiv.ofAlgHom
    (CliffordAlgebra.lift (0 : QuadraticForm R Unit) <|
      ⟨0, fun m : Unit => (MulZeroClass.zero_mul (0 : R)).trans (algebraMap R _).map_zero.symm⟩)
    (Algebra.ofId R _)
    (by
      ext x
      exact AlgHom.commutes _ x)
    (by
      ext : 1
      rw [ι_eq_zero, LinearMap.comp_zero, LinearMap.comp_zero])
#align clifford_algebra_ring.equiv CliffordAlgebraRing.equiv

end CliffordAlgebraRing

/-! ### The clifford algebra isomorphic to the complex numbers -/

namespace CliffordAlgebraComplex

open ComplexConjugate

/-- The quadratic form sending elements to the negation of their square. -/
def q : QuadraticForm ℝ ℝ :=
  -QuadraticForm.sq
#align clifford_algebra_complex.Q CliffordAlgebraComplex.q

@[simp]
theorem q_apply (r : ℝ) : q r = -(r * r) :=
  rfl
#align clifford_algebra_complex.Q_apply CliffordAlgebraComplex.q_apply

/-- Intermediate result for `clifford_algebra_complex.equiv`: clifford algebras over
`clifford_algebra_complex.Q` above can be converted to `ℂ`. -/
def toComplex : CliffordAlgebra q →ₐ[ℝ] ℂ :=
  CliffordAlgebra.lift q
    ⟨LinearMap.toSpanSingleton _ _ Complex.I, fun r =>
      by
      dsimp [LinearMap.toSpanSingleton, LinearMap.id]
      rw [mul_mul_mul_comm]
      simp⟩
#align clifford_algebra_complex.to_complex CliffordAlgebraComplex.toComplex

@[simp]
theorem toComplex_ι (r : ℝ) : toComplex (ι q r) = r • Complex.I :=
  CliffordAlgebra.lift_ι_apply _ _ r
#align clifford_algebra_complex.to_complex_ι CliffordAlgebraComplex.toComplex_ι

/-- `clifford_algebra.involute` is analogous to `complex.conj`. -/
@[simp]
theorem toComplex_involute (c : CliffordAlgebra q) : toComplex c.involute = conj (toComplex c) :=
  by
  have : to_complex (involute (ι Q 1)) = conj (to_complex (ι Q 1)) := by
    simp only [involute_ι, to_complex_ι, AlgHom.map_neg, one_smul, Complex.conj_I]
  suffices to_complex.comp involute = complex.conj_ae.to_alg_hom.comp to_complex by
    exact AlgHom.congr_fun this c
  ext : 2
  exact this
#align clifford_algebra_complex.to_complex_involute CliffordAlgebraComplex.toComplex_involute

/-- Intermediate result for `clifford_algebra_complex.equiv`: `ℂ` can be converted to
`clifford_algebra_complex.Q` above can be converted to. -/
def ofComplex : ℂ →ₐ[ℝ] CliffordAlgebra q :=
  Complex.lift
    ⟨CliffordAlgebra.ι q 1, by
      rw [CliffordAlgebra.ι_sq_scalar, Q_apply, one_mul, RingHom.map_neg, RingHom.map_one]⟩
#align clifford_algebra_complex.of_complex CliffordAlgebraComplex.ofComplex

@[simp]
theorem ofComplex_i : ofComplex Complex.I = ι q 1 :=
  Complex.liftAux_apply_i _ _
#align clifford_algebra_complex.of_complex_I CliffordAlgebraComplex.ofComplex_i

@[simp]
theorem toComplex_comp_ofComplex : toComplex.comp ofComplex = AlgHom.id ℝ ℂ :=
  by
  ext1
  dsimp only [AlgHom.comp_apply, Subtype.coe_mk, AlgHom.id_apply]
  rw [of_complex_I, to_complex_ι, one_smul]
#align clifford_algebra_complex.to_complex_comp_of_complex CliffordAlgebraComplex.toComplex_comp_ofComplex

@[simp]
theorem toComplex_ofComplex (c : ℂ) : toComplex (ofComplex c) = c :=
  AlgHom.congr_fun toComplex_comp_ofComplex c
#align clifford_algebra_complex.to_complex_of_complex CliffordAlgebraComplex.toComplex_ofComplex

@[simp]
theorem ofComplex_comp_toComplex : ofComplex.comp toComplex = AlgHom.id ℝ (CliffordAlgebra q) :=
  by
  ext
  dsimp only [LinearMap.comp_apply, Subtype.coe_mk, AlgHom.id_apply, AlgHom.toLinearMap_apply,
    AlgHom.comp_apply]
  rw [to_complex_ι, one_smul, of_complex_I]
#align clifford_algebra_complex.of_complex_comp_to_complex CliffordAlgebraComplex.ofComplex_comp_toComplex

@[simp]
theorem ofComplex_toComplex (c : CliffordAlgebra q) : ofComplex (toComplex c) = c :=
  AlgHom.congr_fun ofComplex_comp_toComplex c
#align clifford_algebra_complex.of_complex_to_complex CliffordAlgebraComplex.ofComplex_toComplex

/-- The clifford algebras over `clifford_algebra_complex.Q` is isomorphic as an `ℝ`-algebra to
`ℂ`. -/
@[simps]
protected def equiv : CliffordAlgebra q ≃ₐ[ℝ] ℂ :=
  AlgEquiv.ofAlgHom toComplex ofComplex toComplex_comp_ofComplex ofComplex_comp_toComplex
#align clifford_algebra_complex.equiv CliffordAlgebraComplex.equiv

/-- The clifford algebra is commutative since it is isomorphic to the complex numbers.

TODO: prove this is true for all `clifford_algebra`s over a 1-dimensional vector space. -/
instance : CommRing (CliffordAlgebra q) :=
  { CliffordAlgebra.ring _ with
    mul_comm := fun x y =>
      CliffordAlgebraComplex.equiv.Injective <| by
        rw [AlgEquiv.map_mul, mul_comm, AlgEquiv.map_mul] }

/-- `reverse` is a no-op over `clifford_algebra_complex.Q`. -/
theorem reverse_apply (x : CliffordAlgebra q) : x.reverse = x :=
  by
  induction x using CliffordAlgebra.induction
  case h_grade0 r => exact reverse.commutes _
  case h_grade1 x => rw [reverse_ι]
  case h_mul x₁ x₂ hx₁ hx₂ => rw [reverse.map_mul, mul_comm, hx₁, hx₂]
  case h_add x₁ x₂ hx₁ hx₂ => rw [reverse.map_add, hx₁, hx₂]
#align clifford_algebra_complex.reverse_apply CliffordAlgebraComplex.reverse_apply

@[simp]
theorem reverse_eq_id : (reverse : CliffordAlgebra q →ₗ[ℝ] _) = LinearMap.id :=
  LinearMap.ext reverse_apply
#align clifford_algebra_complex.reverse_eq_id CliffordAlgebraComplex.reverse_eq_id

/-- `complex.conj` is analogous to `clifford_algebra.involute`. -/
@[simp]
theorem ofComplex_conj (c : ℂ) : ofComplex (conj c) = (ofComplex c).involute :=
  CliffordAlgebraComplex.equiv.Injective <| by
    rw [equiv_apply, equiv_apply, to_complex_involute, to_complex_of_complex, to_complex_of_complex]
#align clifford_algebra_complex.of_complex_conj CliffordAlgebraComplex.ofComplex_conj

-- this name is too short for us to want it visible after `open clifford_algebra_complex`
attribute [protected] Q

end CliffordAlgebraComplex

/-! ### The clifford algebra isomorphic to the quaternions -/

namespace CliffordAlgebraQuaternion

open Quaternion

open QuaternionAlgebra

variable {R : Type _} [CommRing R] (c₁ c₂ : R)

/-- `Q c₁ c₂` is a quadratic form over `R × R` such that `clifford_algebra (Q c₁ c₂)` is isomorphic
as an `R`-algebra to `ℍ[R,c₁,c₂]`. -/
def q : QuadraticForm R (R × R) :=
  (c₁ • QuadraticForm.sq).Prod (c₂ • QuadraticForm.sq)
#align clifford_algebra_quaternion.Q CliffordAlgebraQuaternion.q

@[simp]
theorem q_apply (v : R × R) : q c₁ c₂ v = c₁ * (v.1 * v.1) + c₂ * (v.2 * v.2) :=
  rfl
#align clifford_algebra_quaternion.Q_apply CliffordAlgebraQuaternion.q_apply

/-- The quaternion basis vectors within the algebra. -/
@[simps i j k]
def quaternionBasis : QuaternionAlgebra.Basis (CliffordAlgebra (q c₁ c₂)) c₁ c₂
    where
  i := ι (q c₁ c₂) (1, 0)
  j := ι (q c₁ c₂) (0, 1)
  k := ι (q c₁ c₂) (1, 0) * ι (q c₁ c₂) (0, 1)
  i_mul_i := by
    rw [ι_sq_scalar, Q_apply, ← Algebra.algebraMap_eq_smul_one]
    simp
  j_mul_j := by
    rw [ι_sq_scalar, Q_apply, ← Algebra.algebraMap_eq_smul_one]
    simp
  i_mul_j := rfl
  j_mul_i := by
    rw [eq_neg_iff_add_eq_zero, ι_mul_ι_add_swap, QuadraticForm.polar]
    simp
#align clifford_algebra_quaternion.quaternion_basis CliffordAlgebraQuaternion.quaternionBasis

variable {c₁ c₂}

/-- Intermediate result of `clifford_algebra_quaternion.equiv`: clifford algebras over
`clifford_algebra_quaternion.Q` can be converted to `ℍ[R,c₁,c₂]`. -/
def toQuaternion : CliffordAlgebra (q c₁ c₂) →ₐ[R] ℍ[R,c₁,c₂] :=
  CliffordAlgebra.lift (q c₁ c₂)
    ⟨{  toFun := fun v => (⟨0, v.1, v.2, 0⟩ : ℍ[R,c₁,c₂])
        map_add' := fun v₁ v₂ => by simp
        map_smul' := fun r v => by ext <;> simp }, fun v =>
      by
      dsimp
      ext
      all_goals dsimp; ring⟩
#align clifford_algebra_quaternion.to_quaternion CliffordAlgebraQuaternion.toQuaternion

@[simp]
theorem toQuaternion_ι (v : R × R) :
    toQuaternion (ι (q c₁ c₂) v) = (⟨0, v.1, v.2, 0⟩ : ℍ[R,c₁,c₂]) :=
  CliffordAlgebra.lift_ι_apply _ _ v
#align clifford_algebra_quaternion.to_quaternion_ι CliffordAlgebraQuaternion.toQuaternion_ι

/-- The "clifford conjugate" maps to the quaternion conjugate. -/
theorem toQuaternion_star (c : CliffordAlgebra (q c₁ c₂)) :
    toQuaternion (star c) = QuaternionAlgebra.conj (toQuaternion c) :=
  by
  simp only [CliffordAlgebra.star_def']
  induction c using CliffordAlgebra.induction
  case h_grade0 r =>
    simp only [reverse.commutes, AlgHom.commutes, QuaternionAlgebra.coe_algebraMap,
      QuaternionAlgebra.conj_coe]
  case h_grade1 x =>
    rw [reverse_ι, involute_ι, to_quaternion_ι, AlgHom.map_neg, to_quaternion_ι,
      QuaternionAlgebra.neg_mk, conj_mk, neg_zero]
  case h_mul x₁ x₂ hx₁ hx₂ =>
    simp only [reverse.map_mul, AlgHom.map_mul, hx₁, hx₂, QuaternionAlgebra.conj_mul]
  case h_add x₁ x₂ hx₁ hx₂ =>
    simp only [reverse.map_add, AlgHom.map_add, hx₁, hx₂, QuaternionAlgebra.conj_add]
#align clifford_algebra_quaternion.to_quaternion_star CliffordAlgebraQuaternion.toQuaternion_star

/-- Map a quaternion into the clifford algebra. -/
def ofQuaternion : ℍ[R,c₁,c₂] →ₐ[R] CliffordAlgebra (q c₁ c₂) :=
  (quaternionBasis c₁ c₂).liftHom
#align clifford_algebra_quaternion.of_quaternion CliffordAlgebraQuaternion.ofQuaternion

@[simp]
theorem ofQuaternion_mk (a₁ a₂ a₃ a₄ : R) :
    ofQuaternion (⟨a₁, a₂, a₃, a₄⟩ : ℍ[R,c₁,c₂]) =
      algebraMap R _ a₁ + a₂ • ι (q c₁ c₂) (1, 0) + a₃ • ι (q c₁ c₂) (0, 1) +
        a₄ • (ι (q c₁ c₂) (1, 0) * ι (q c₁ c₂) (0, 1)) :=
  rfl
#align clifford_algebra_quaternion.of_quaternion_mk CliffordAlgebraQuaternion.ofQuaternion_mk

@[simp]
theorem ofQuaternion_comp_toQuaternion :
    ofQuaternion.comp toQuaternion = AlgHom.id R (CliffordAlgebra (q c₁ c₂)) :=
  by
  ext : 1
  dsimp
  -- before we end up with two goals and have to do this twice
  ext
  all_goals
    dsimp
    rw [to_quaternion_ι]
    dsimp
    simp only [to_quaternion_ι, zero_smul, one_smul, zero_add, add_zero, RingHom.map_zero]
#align clifford_algebra_quaternion.of_quaternion_comp_to_quaternion CliffordAlgebraQuaternion.ofQuaternion_comp_toQuaternion

@[simp]
theorem ofQuaternion_toQuaternion (c : CliffordAlgebra (q c₁ c₂)) :
    ofQuaternion (toQuaternion c) = c :=
  AlgHom.congr_fun (ofQuaternion_comp_toQuaternion : _ = AlgHom.id R (CliffordAlgebra (q c₁ c₂))) c
#align clifford_algebra_quaternion.of_quaternion_to_quaternion CliffordAlgebraQuaternion.ofQuaternion_toQuaternion

@[simp]
theorem toQuaternion_comp_ofQuaternion : toQuaternion.comp ofQuaternion = AlgHom.id R ℍ[R,c₁,c₂] :=
  by
  apply quaternion_algebra.lift.symm.injective
  ext1 <;> dsimp [QuaternionAlgebra.Basis.lift] <;> simp
#align clifford_algebra_quaternion.to_quaternion_comp_of_quaternion CliffordAlgebraQuaternion.toQuaternion_comp_ofQuaternion

@[simp]
theorem toQuaternion_ofQuaternion (q : ℍ[R,c₁,c₂]) : toQuaternion (ofQuaternion q) = q :=
  AlgHom.congr_fun (toQuaternion_comp_ofQuaternion : _ = AlgHom.id R ℍ[R,c₁,c₂]) q
#align clifford_algebra_quaternion.to_quaternion_of_quaternion CliffordAlgebraQuaternion.toQuaternion_ofQuaternion

/-- The clifford algebra over `clifford_algebra_quaternion.Q c₁ c₂` is isomorphic as an `R`-algebra
to `ℍ[R,c₁,c₂]`. -/
@[simps]
protected def equiv : CliffordAlgebra (q c₁ c₂) ≃ₐ[R] ℍ[R,c₁,c₂] :=
  AlgEquiv.ofAlgHom toQuaternion ofQuaternion toQuaternion_comp_ofQuaternion
    ofQuaternion_comp_toQuaternion
#align clifford_algebra_quaternion.equiv CliffordAlgebraQuaternion.equiv

/-- The quaternion conjugate maps to the "clifford conjugate" (aka `star`). -/
@[simp]
theorem ofQuaternion_conj (q : ℍ[R,c₁,c₂]) : ofQuaternion q.conj = star (ofQuaternion q) :=
  CliffordAlgebraQuaternion.equiv.Injective <| by
    rw [equiv_apply, equiv_apply, to_quaternion_star, to_quaternion_of_quaternion,
      to_quaternion_of_quaternion]
#align clifford_algebra_quaternion.of_quaternion_conj CliffordAlgebraQuaternion.ofQuaternion_conj

-- this name is too short for us to want it visible after `open clifford_algebra_quaternion`
attribute [protected] Q

end CliffordAlgebraQuaternion

/-! ### The clifford algebra isomorphic to the dual numbers -/

namespace CliffordAlgebraDualNumber

open DualNumber

open DualNumber TrivSqZeroExt

variable {R M : Type _} [CommRing R] [AddCommGroup M] [Module R M]

theorem ι_mul_ι (r₁ r₂) : ι (0 : QuadraticForm R R) r₁ * ι (0 : QuadraticForm R R) r₂ = 0 := by
  rw [← mul_one r₁, ← mul_one r₂, ← smul_eq_mul R, ← smul_eq_mul R, LinearMap.map_smul,
    LinearMap.map_smul, smul_mul_smul, ι_sq_scalar, QuadraticForm.zero_apply, RingHom.map_zero,
    smul_zero]
#align clifford_algebra_dual_number.ι_mul_ι CliffordAlgebraDualNumber.ι_mul_ι

/-- The clifford algebra over a 1-dimensional vector space with 0 quadratic form is isomorphic to
the dual numbers. -/
protected def equiv : CliffordAlgebra (0 : QuadraticForm R R) ≃ₐ[R] R[ε] :=
  AlgEquiv.ofAlgHom
    (CliffordAlgebra.lift (0 : QuadraticForm R R) ⟨inrHom R _, fun m => inr_mul_inr _ m m⟩)
    (DualNumber.lift ⟨ι _ (1 : R), ι_mul_ι (1 : R) 1⟩)
    (by
      ext x : 1
      dsimp
      rw [lift_apply_eps, Subtype.coe_mk, lift_ι_apply, inr_hom_apply, eps])
    (by
      ext : 2
      dsimp
      rw [lift_ι_apply, inr_hom_apply, ← eps, lift_apply_eps, Subtype.coe_mk])
#align clifford_algebra_dual_number.equiv CliffordAlgebraDualNumber.equiv

@[simp]
theorem equiv_ι (r : R) : CliffordAlgebraDualNumber.equiv (ι _ r) = r • ε :=
  (lift_ι_apply _ _ r).trans (inr_eq_smul_eps _)
#align clifford_algebra_dual_number.equiv_ι CliffordAlgebraDualNumber.equiv_ι

@[simp]
theorem equiv_symm_eps :
    CliffordAlgebraDualNumber.equiv.symm (eps : R[ε]) = ι (0 : QuadraticForm R R) 1 :=
  DualNumber.lift_apply_eps _
#align clifford_algebra_dual_number.equiv_symm_eps CliffordAlgebraDualNumber.equiv_symm_eps

end CliffordAlgebraDualNumber


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import topology.instances.ennreal
import topology.algebra.ordered.monotone_continuity
import data.real.ereal

/-!
# Topological structure on `ereal`

We endow `ereal` with the order topology, and prove basic properties of this topology.

## Main results

* `coe : ℝ → ereal` is an open embedding
* `coe : ℝ≥0∞ → ereal` is an embedding
* The addition on `ereal` is continuous except at `(⊥, ⊤)` and at `(⊤, ⊥)`.
* Negation is a homeomorphism on `ereal`.

## Implementation

Most proofs are adapted from the corresponding proofs on `ℝ≥0∞`.
-/

noncomputable theory

open classical set filter metric topological_space
open_locale classical topological_space ennreal nnreal big_operators filter

variables {α : Type*} [topological_space α]

namespace ereal

instance : topological_space ereal := preorder.topology ereal

instance : order_topology ereal := ⟨rfl⟩

instance : t2_space ereal := by apply_instance

instance : second_countable_topology ereal :=
⟨begin
  refine ⟨⋃ (q : ℚ), {{a : ereal | a < (q : ℝ)}, {a : ereal | ((q : ℝ) : ereal) < a}},
    countable_Union (λ a, (countable_singleton _).insert _), _⟩,
  refine le_antisymm
    (le_generate_from $ by simp [or_imp_distrib, is_open_lt', is_open_gt'] {contextual := tt}) _,
  apply le_generate_from (λ s h, _),
  rcases h with ⟨a, hs | hs⟩;
  [ rw show s = ⋃q∈{q:ℚ | a < (q : ℝ)}, {b | ((q : ℝ) : ereal) < b},
      by { ext x, simpa only [hs, exists_prop, mem_Union] using lt_iff_exists_rat_btwn },
    rw show s = ⋃q∈{q:ℚ | ((q : ℝ) : ereal) < a}, {b | b < ((q : ℝ) : ereal)},
      by { ext x, simpa only [hs, and_comm, exists_prop, mem_Union] using lt_iff_exists_rat_btwn }];
  { apply is_open_Union, intro q,
    apply is_open_Union, intro hq,
    apply generate_open.basic,
    exact mem_Union.2 ⟨q, by simp⟩ },
end⟩

/-! ### Real coercion -/

lemma embedding_coe : embedding (coe : ℝ → ereal) :=
⟨⟨begin
  refine le_antisymm _ _,
  { rw [@order_topology.topology_eq_generate_intervals ereal _,
      ← coinduced_le_iff_le_induced],
    refine le_generate_from (assume s ha, _),
    rcases ha with ⟨a, rfl | rfl⟩,
    show is_open {b : ℝ | a < ↑b},
    { induction a using ereal.rec,
      { simp only [is_open_univ, bot_lt_coe, set_of_true] },
      { simp only [ereal.coe_lt_coe_iff], exact is_open_Ioi },
      { simp only [set_of_false, is_open_empty, not_top_lt] } },
    show is_open {b : ℝ | ↑b < a},
    { induction a using ereal.rec,
      { simp only [not_lt_bot, set_of_false, is_open_empty] },
      { simp only [ereal.coe_lt_coe_iff], exact is_open_Iio },
      { simp only [is_open_univ, coe_lt_top, set_of_true] } } },
  { rw [@order_topology.topology_eq_generate_intervals ℝ _],
    refine le_generate_from (assume s ha, _),
    rcases ha with ⟨a, rfl | rfl⟩,
    exact ⟨Ioi a, is_open_Ioi, by simp [Ioi]⟩,
    exact ⟨Iio a, is_open_Iio, by simp [Iio]⟩ }
  end⟩,
  assume a b, by simp only [imp_self, ereal.coe_eq_coe_iff]⟩

lemma open_embedding_coe : open_embedding (coe : ℝ → ereal) :=
⟨embedding_coe,
begin
  convert @is_open_Ioo ereal _ _ _ ⊥ ⊤,
  ext x,
  induction x using ereal.rec,
  { simp only [left_mem_Ioo, mem_range, coe_ne_bot, exists_false, not_false_iff] },
  { simp only [mem_range_self, mem_Ioo, bot_lt_coe, coe_lt_top, and_self] },
  { simp only [mem_range, right_mem_Ioo, exists_false, coe_ne_top] }
end⟩

@[norm_cast] lemma tendsto_coe {α : Type*} {f : filter α} {m : α → ℝ} {a : ℝ} :
  tendsto (λ a, (m a : ereal)) f (𝓝 ↑a) ↔ tendsto m f (𝓝 a) :=
embedding_coe.tendsto_nhds_iff.symm

lemma _root_.continuous_coe_real_ereal : continuous (coe : ℝ → ereal) :=
embedding_coe.continuous

lemma continuous_coe_iff {f : α → ℝ} :
  continuous (λa, (f a : ereal)) ↔ continuous f :=
embedding_coe.continuous_iff.symm

lemma nhds_coe {r : ℝ} : 𝓝 (r : ereal) = (𝓝 r).map coe :=
(open_embedding_coe.map_nhds_eq r).symm

lemma nhds_coe_coe {r p : ℝ} :
  𝓝 ((r : ereal), (p : ereal)) = (𝓝 (r, p)).map (λp:ℝ × ℝ, (p.1, p.2)) :=
((open_embedding_coe.prod open_embedding_coe).map_nhds_eq (r, p)).symm

lemma tendsto_to_real {a : ereal} (ha : a ≠ ⊤) (h'a : a ≠ ⊥) :
  tendsto ereal.to_real (𝓝 a) (𝓝 a.to_real) :=
begin
  lift a to ℝ using and.intro ha h'a,
  rw [nhds_coe, tendsto_map'_iff],
  exact tendsto_id
end

lemma continuous_on_to_real : continuous_on ereal.to_real ({⊥, ⊤} : set ereal).compl :=
λ a ha, continuous_at.continuous_within_at (tendsto_to_real
  (by { simp [not_or_distrib] at ha, exact ha.2 }) (by { simp [not_or_distrib] at ha, exact ha.1 }))

/-- The set of finite `ereal` numbers is homeomorphic to `ℝ`. -/
def ne_bot_top_homeomorph_real : ({⊥, ⊤} : set ereal).compl ≃ₜ ℝ :=
{ continuous_to_fun := continuous_on_iff_continuous_restrict.1 continuous_on_to_real,
  continuous_inv_fun := continuous_subtype_mk _ continuous_coe_real_ereal,
  .. ne_top_bot_equiv_real }

/-! ### ennreal coercion -/

lemma embedding_coe_ennreal : embedding (coe : ℝ≥0∞ → ereal) :=
⟨⟨begin
  refine le_antisymm _ _,
  { rw [@order_topology.topology_eq_generate_intervals ereal _,
      ← coinduced_le_iff_le_induced],
    refine le_generate_from (assume s ha, _),
    rcases ha with ⟨a, rfl | rfl⟩,
    show is_open {b : ℝ≥0∞ | a < ↑b},
    { induction a using ereal.rec with x,
      { simp only [is_open_univ, bot_lt_coe_ennreal, set_of_true] },
      { rcases le_or_lt 0 x with h|h,
        { have : (x : ereal) = ((id ⟨x, h⟩ : ℝ≥0) : ℝ≥0∞) := rfl,
          rw this,
          simp only [id.def, coe_ennreal_lt_coe_ennreal_iff],
          exact is_open_Ioi, },
        { have : ∀ (y : ℝ≥0∞), (x : ereal) < y := λ y,
            (ereal.coe_lt_coe_iff.2 h).trans_le (coe_ennreal_nonneg _),
          simp only [this, is_open_univ, set_of_true] } },
      { simp only [set_of_false, is_open_empty, not_top_lt] } },
    show is_open {b : ℝ≥0∞ | ↑b < a},
    { induction a using ereal.rec with x,
      { simp only [not_lt_bot, set_of_false, is_open_empty] },
      { rcases le_or_lt 0 x with h|h,
        { have : (x : ereal) = ((id ⟨x, h⟩ : ℝ≥0) : ℝ≥0∞) := rfl,
          rw this,
          simp only [id.def, coe_ennreal_lt_coe_ennreal_iff],
          exact is_open_Iio, },
        { convert is_open_empty,
          apply eq_empty_iff_forall_not_mem.2 (λ y hy, lt_irrefl (x : ereal) _),
          exact ((ereal.coe_lt_coe_iff.2 h).trans_le (coe_ennreal_nonneg y)).trans hy } },
      { simp only [← coe_ennreal_top, coe_ennreal_lt_coe_ennreal_iff],
        exact is_open_Iio } } },
  { rw [@order_topology.topology_eq_generate_intervals ℝ≥0∞ _],
    refine le_generate_from (assume s ha, _),
    rcases ha with ⟨a, rfl | rfl⟩,
    exact ⟨Ioi a, is_open_Ioi, by simp [Ioi]⟩,
    exact ⟨Iio a, is_open_Iio, by simp [Iio]⟩ }
  end⟩,
  assume a b, by simp only [imp_self, coe_ennreal_eq_coe_ennreal_iff]⟩

@[norm_cast] lemma tendsto_coe_ennreal {α : Type*} {f : filter α} {m : α → ℝ≥0∞} {a : ℝ≥0∞} :
  tendsto (λ a, (m a : ereal)) f (𝓝 ↑a) ↔ tendsto m f (𝓝 a) :=
embedding_coe_ennreal.tendsto_nhds_iff.symm

lemma _root_.continuous_coe_ennreal_ereal : continuous (coe : ℝ≥0∞ → ereal) :=
embedding_coe_ennreal.continuous

lemma continuous_coe_ennreal_iff {f : α → ℝ≥0∞} :
  continuous (λa, (f a : ereal)) ↔ continuous f :=
embedding_coe_ennreal.continuous_iff.symm

/-! ### Neighborhoods of infinity -/

lemma nhds_top : 𝓝 (⊤ : ereal) = ⨅ a ≠ ⊤, 𝓟 (Ioi a) :=
nhds_top_order.trans $ by simp [lt_top_iff_ne_top, Ioi]

lemma nhds_top' : 𝓝 (⊤ : ereal) = ⨅ a : ℝ, 𝓟 (Ioi a) :=
begin
  rw [nhds_top],
  apply le_antisymm,
  { exact infi_le_infi2 (λ x, ⟨x, by simp⟩) },
  { refine le_infi (λ r, le_infi (λ hr, _)),
    induction r using ereal.rec,
    { exact (infi_le _ 0).trans (by simp) },
    { exact infi_le _ _ },
    { simpa using hr, } }
end

lemma mem_nhds_top_iff {s : set ereal} :
  s ∈ 𝓝 (⊤ : ereal) ↔ ∃ (y : ℝ), Ioi (y : ereal) ⊆ s :=
begin
  rw [nhds_top', mem_infi_of_directed],
  { refl },
  exact λ x y, ⟨max x y, by simp [le_refl], by simp [le_refl]⟩,
end

lemma tendsto_nhds_top_iff_real {α : Type*} {m : α → ereal} {f : filter α} :
  tendsto m f (𝓝 ⊤) ↔ ∀ x : ℝ, ∀ᶠ a in f, ↑x < m a :=
by simp only [nhds_top', mem_Ioi, tendsto_infi, tendsto_principal]

lemma nhds_bot : 𝓝 (⊥ : ereal) = ⨅ a ≠ ⊥, 𝓟 (Iio a) :=
nhds_bot_order.trans $ by simp [bot_lt_iff_ne_bot]

lemma nhds_bot' : 𝓝 (⊥ : ereal) = ⨅ a : ℝ, 𝓟 (Iio a) :=
begin
  rw [nhds_bot],
  apply le_antisymm,
  { exact infi_le_infi2 (λ x, ⟨x, by simp⟩) },
  { refine le_infi (λ r, le_infi (λ hr, _)),
    induction r using ereal.rec,
    { simpa using hr },
    { exact infi_le _ _ },
    { exact (infi_le _ 0).trans (by simp) } }
end

lemma mem_nhds_bot_iff {s : set ereal} :
  s ∈ 𝓝 (⊥ : ereal) ↔ ∃ (y : ℝ), Iio (y : ereal) ⊆ s :=
begin
  rw [nhds_bot', mem_infi_of_directed],
  { refl },
  exact λ x y, ⟨min x y, by simp [le_refl], by simp [le_refl]⟩,
end

lemma tendsto_nhds_bot_iff_real {α : Type*} {m : α → ereal} {f : filter α} :
  tendsto m f (𝓝 ⊥) ↔ ∀ x : ℝ, ∀ᶠ a in f, m a < x :=
by simp only [nhds_bot', mem_Iio, tendsto_infi, tendsto_principal]

/-! ### Continuity of addition -/

lemma continuous_at_add_coe_coe (a b :ℝ) :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (a, b) :=
by simp only [continuous_at, nhds_coe_coe, ← coe_add, tendsto_map'_iff, (∘),
    tendsto_coe, tendsto_add]

lemma continuous_at_add_top_coe (a : ℝ) :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (⊤, a) :=
begin
  simp only [continuous_at, tendsto_nhds_top_iff_real, top_add, nhds_prod_eq],
  assume r,
  rw eventually_prod_iff,
  refine ⟨λ z, ((r - (a - 1): ℝ) : ereal) < z, Ioi_mem_nhds (coe_lt_top _),
          λ z, ((a - 1 : ℝ) : ereal) < z, Ioi_mem_nhds (by simp [zero_lt_one]),
          λ x hx y hy, _⟩,
  dsimp,
  convert add_lt_add hx hy,
  simp,
end

lemma continuous_at_add_coe_top (a : ℝ) :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (a, ⊤) :=
begin
  change continuous_at ((λ (p : ereal × ereal), p.2 + p.1) ∘ prod.swap) (a, ⊤),
  apply continuous_at.comp _ continuous_swap.continuous_at,
  simp_rw add_comm,
  exact continuous_at_add_top_coe a
end

lemma continuous_at_add_top_top :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (⊤, ⊤) :=
begin
  simp only [continuous_at, tendsto_nhds_top_iff_real, top_add, nhds_prod_eq],
  assume r,
  rw eventually_prod_iff,
  refine ⟨λ z, (r : ereal) < z, Ioi_mem_nhds (coe_lt_top _),
          λ z, ((0 : ℝ) : ereal) < z, Ioi_mem_nhds (by simp [zero_lt_one]),
          λ x hx y hy, _⟩,
  dsimp,
  convert add_lt_add hx hy,
  simp,
end

lemma continuous_at_add_bot_coe (a : ℝ) :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (⊥, a) :=
begin
  simp only [continuous_at, tendsto_nhds_bot_iff_real, nhds_prod_eq, bot_add_coe],
  assume r,
  rw eventually_prod_iff,
  refine ⟨λ z, z < ((r - (a + 1): ℝ) : ereal), Iio_mem_nhds (bot_lt_coe _),
          λ z, z < ((a + 1 : ℝ) : ereal), Iio_mem_nhds (by simp [-coe_add, zero_lt_one]),
          λ x hx y hy, _⟩,
  dsimp,
  convert add_lt_add hx hy,
  dsimp,
  ring,
end

lemma continuous_at_add_coe_bot (a : ℝ) :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (a, ⊥) :=
begin
  change continuous_at ((λ (p : ereal × ereal), p.2 + p.1) ∘ prod.swap) (a, ⊥),
  apply continuous_at.comp _ continuous_swap.continuous_at,
  simp_rw add_comm,
  exact continuous_at_add_bot_coe a
end

lemma continuous_at_add_bot_bot :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) (⊥, ⊥) :=
begin
  simp only [continuous_at, tendsto_nhds_bot_iff_real, nhds_prod_eq, bot_add_bot],
  assume r,
  rw eventually_prod_iff,
  refine ⟨λ z, z < r, Iio_mem_nhds (bot_lt_coe _),
          λ z, z < 0, Iio_mem_nhds (bot_lt_coe _),
          λ x hx y hy, _⟩,
  dsimp,
  convert add_lt_add hx hy,
  simp
end

/-- The addition on `ereal` is continuous except where it doesn't make sense (i.e., at `(⊥, ⊤)`
and at `(⊤, ⊥)`). -/
lemma continuous_at_add {p : ereal × ereal} (h : p.1 ≠ ⊤ ∨ p.2 ≠ ⊥) (h' : p.1 ≠ ⊥ ∨ p.2 ≠ ⊤) :
  continuous_at (λ (p : ereal × ereal), p.1 + p.2) p :=
begin
  rcases p with ⟨x, y⟩,
  induction x using ereal.rec; induction y using ereal.rec,
  { exact continuous_at_add_bot_bot },
  { exact continuous_at_add_bot_coe _ },
  { simpa using h' },
  { exact continuous_at_add_coe_bot _ },
  { exact continuous_at_add_coe_coe _ _ },
  { exact continuous_at_add_coe_top _ },
  { simpa using h },
  { exact continuous_at_add_top_coe _ },
  { exact continuous_at_add_top_top },
end

/-! ### Negation-/

/-- Negation on `ereal` as a homeomorphism -/
def neg_homeo : ereal ≃ₜ ereal :=
neg_order_iso.to_homeomorph

end ereal