/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.polynomial.scale_roots
import Mathlib.ring_theory.localization
import Mathlib.PostPort

universes u_1 u_4 u_2

namespace Mathlib

/-!
# Rational root theorem and integral root theorem

This file contains the rational root theorem and integral root theorem.
The rational root theorem for a unique factorization domain `A`
with localization `S`, states that the roots of `p : polynomial A` in `A`'s
field of fractions are of the form `x / y` with `x y : A`, `x ∣ p.coeff 0` and
`y ∣ p.leading_coeff`.
The corollary is the integral root theorem `is_integer_of_is_root_of_monic`:
if `p` is monic, its roots must be integers.
Finally, we use this to show unique factorization domains are integrally closed.

## References

 * https://en.wikipedia.org/wiki/Rational_root_theorem
-/

theorem scale_roots_aeval_eq_zero_of_aeval_mk'_eq_zero {A : Type u_1} {S : Type u_4} [integral_domain A] [comm_ring S] {M : submonoid A} {f : localization_map M S} {p : polynomial A} {r : A} {s : ↥M} (hr : coe_fn (polynomial.aeval (localization_map.mk' f r s)) p = 0) : coe_fn (polynomial.aeval (coe_fn (localization_map.to_map f) r)) (scale_roots p ↑s) = 0 := sorry

theorem num_is_root_scale_roots_of_aeval_eq_zero {A : Type u_1} {K : Type u_2} [integral_domain A] [field K] [unique_factorization_monoid A] (g : fraction_map A K) {p : polynomial A} {x : localization_map.codomain g} (hr : coe_fn (polynomial.aeval x) p = 0) : polynomial.is_root (scale_roots p ↑(fraction_map.denom g x)) (fraction_map.num g x) := sorry

/-- Rational root theorem part 1:
if `r : f.codomain` is a root of a polynomial over the ufd `A`,
then the numerator of `r` divides the constant coefficient -/
theorem num_dvd_of_is_root {A : Type u_1} {K : Type u_2} [integral_domain A] [unique_factorization_monoid A] [field K] {f : fraction_map A K} {p : polynomial A} {r : localization_map.codomain f} (hr : coe_fn (polynomial.aeval r) p = 0) : fraction_map.num f r ∣ polynomial.coeff p 0 := sorry

/-- Rational root theorem part 2:
if `r : f.codomain` is a root of a polynomial over the ufd `A`,
then the denominator of `r` divides the leading coefficient -/
theorem denom_dvd_of_is_root {A : Type u_1} {K : Type u_2} [integral_domain A] [unique_factorization_monoid A] [field K] {f : fraction_map A K} {p : polynomial A} {r : localization_map.codomain f} (hr : coe_fn (polynomial.aeval r) p = 0) : ↑(fraction_map.denom f r) ∣ polynomial.leading_coeff p := sorry

/-- Integral root theorem:
if `r : f.codomain` is a root of a monic polynomial over the ufd `A`,
then `r` is an integer -/
theorem is_integer_of_is_root_of_monic {A : Type u_1} {K : Type u_2} [integral_domain A] [unique_factorization_monoid A] [field K] {f : fraction_map A K} {p : polynomial A} (hp : polynomial.monic p) {r : localization_map.codomain f} (hr : coe_fn (polynomial.aeval r) p = 0) : localization_map.is_integer f r :=
  fraction_map.is_integer_of_is_unit_denom f
    (is_unit_of_dvd_one (↑(fraction_map.denom f r)) (hp ▸ denom_dvd_of_is_root hr))

namespace unique_factorization_monoid

theorem integer_of_integral {A : Type u_1} {K : Type u_2} [integral_domain A] [unique_factorization_monoid A] [field K] {f : fraction_map A K} {x : localization_map.codomain f} : is_integral A x → localization_map.is_integer f x := sorry

theorem integrally_closed {A : Type u_1} {K : Type u_2} [integral_domain A] [unique_factorization_monoid A] [field K] {f : fraction_map A K} : integral_closure A (localization_map.codomain f) = ⊥ :=
  iff.mpr eq_bot_iff
    fun (x : localization_map.codomain f) (hx : x ∈ ↑(integral_closure A (localization_map.codomain f))) =>
      iff.mpr algebra.mem_bot (integer_of_integral hx)


import data.real.basic
import tactic.suggest
import game.Completeness.completeness_level01
import game.Completeness.completeness_level02
import game.Completeness.completeness_level03
import game.Completeness.completeness_level06
import game.Completeness.completeness_level07
import game.Completeness.completeness_level08
import game.sup_inf.level01
import game.sup_inf.level02
import game.sup_inf.level03
import game.sup_inf.level04
import game.Completeness.completeness_level10
namespace xena

noncomputable theory
open_locale classical

lemma thing1 {d n : ℕ} (hd : 0 < d) (nd : d ≤ n) : (1 / n : ℝ) ≤ (1 / d : ℝ) :=
begin

sorry,

end

lemma thing2 {d n : ℕ} (hd : 0 < d) (nd : d ≤ n) : (1 / n : ℝ) ≤ (1 / d : ℝ) → (1 / (n + 1) : ℝ) < (1 / d : ℝ) :=
begin
  sorry,
end

lemma thing3 {x : ℝ} {n : ℕ} : x < x + 1 / (n + 1)  :=
begin
sorry,
end

lemma thing4 {n N : ℕ} {a : ℕ → ℝ} (h : ∀n : ℕ, a n ≤ a (n + 1)) (h2 : N ≤ n) :  a N ≤ a n :=
begin
  intro j,
  induction j with t ht,
  refl,
  sorry,

end

end xena


import data.complex.basic
import data.fintype.basic
import data.matrix.basic
import .unitary
import linear_algebra.determinant
import linear_algebra.nonsingular_inverse
import tactic

noncomputable theory
open_locale classical
open_locale matrix

universes u u'
variables {m n l : Type u} [fintype m] [fintype n] [fintype l]

local notation `Euc` := (n → ℂ)

section upper_triangular
def matrix.upper_triangular [linear_order n] (A : matrix n n ℂ) :=
  ∀ i j, (i < j) → (A i j = 0)

end upper_triangular

section normal
def matrix.normal (A : matrix n n ℂ) :=
  A * A.complex_transpose = A.complex_transpose * A

theorem diagonal_of_upper_triangular_normal [linear_order n] {A : matrix n n ℂ}
  (hAu : A.upper_triangular) (hAn : A.normal) : ∃ D : n → ℂ, A = matrix.diagonal D
:= sorry

end normal

/--

todo later:

@[ext]
structure unitary_matrices (n : Type u) [fintype n]:=
(val : matrix n n ℂ)
(is_unitary : val.unitary)

instance : group (unitary_matrices n) :=
{ mul := λ A B,
  { val := A.val ⬝ B.val,
  is_unitary := unitary.has_mul A.is_unitary B.is_unitary},
  mul_assoc := λ A B C, sorry ,
  one := { val := (1 : matrix n n ℂ),
    is_unitary := unitary.has_one},
  one_mul := λ A, by { },
  mul_one := sorry,
  inv := sorry,
  mul_left_inv := sorry}

section symmetric

end symmetric

section skew_symmtric

end skew_symmtric

section hermitian
def hermitian (A : matrix n n ℂ) :=
  A = A.complex_transpose
end hermitian

section anti_hermitian

end anti_hermitian
-- structure units (ℂ : Type u) [monoid ℂ] :=
-- (val : ℂ)
-- (inv : ℂ)
-- (val_inv : val * inv = 1)
-- (inv_val : inv * val = 1)

theorem normal_of_hermitian {A : matrix n n ℂ} (hh : hermitian A) : normal A :=
  by {unfold normal, unfold hermitian at hh, rw ←hh,}

theorem normal_of_unitary {A : matrix n n ℂ} (hu : A.unitary) : normal A :=
sorry
end normal

-/


import ring_theory.fractional_ideal

open_locale big_operators
open polynomial finset module units fractional_ideal submodule

-- TODO redefine span_singleton as a monoid hom so we get this for free?

-- TODO this really shouldn't be necessary either?
@[simp]
lemma fractional_ideal.span_singleton_prod {R : Type*} {P ι : Type*} [comm_ring R] {S : submonoid R} [comm_ring P]
  [algebra R P] [loc : is_localization S P] (T : finset ι) (I : ι → P) :
  span_singleton S (∏ t in T, I t) = ∏ t in T, span_singleton S (I t) :=
begin
  classical,
  induction T using finset.induction with i T hiT ih,
  { simp, },
  simp [hiT, span_singleton_mul_span_singleton, ih.symm],
end


import GroundZero.HITs.Suspension
import GroundZero.Theorems.Equiv
import GroundZero.Types.Integer

open GroundZero.HITs.Interval
open GroundZero.Types.Equiv
open GroundZero.Structures
open GroundZero.Types.Id
open GroundZero.Types

/-
  Circle S¹ as Higher Inductive Type.
  * HoTT 6.4

  π₁(S¹) = ℤ proof.
  * HoTT 8.1
-/

namespace GroundZero
namespace HITs

universe u v w

hott def suspEmpty : ∑ 𝟎 ≃ 𝟐 :=
let f : ∑ 𝟎 → 𝟐 :=
Suspension.rec false true Proto.Empty.elim
let g : 𝟐 → ∑ 𝟎 :=
λ | false => Suspension.north
  | true  => Suspension.south;
begin
  existsi f; apply Prod.mk <;> existsi g;
  { intro z; induction z; reflexivity; reflexivity;
    apply Proto.Empty.elim; assumption };
  { intro b; induction b using Bool.casesOn <;> reflexivity }
end

namespace Loop
  variable {A : Type u} {a : A}

  def pos (p : a = a) : ℕ → a = a
  | Nat.zero   => idp a
  | Nat.succ n => pos p n ⬝ p

  def neg (p : a = a) : ℕ → a = a
  | Nat.zero   => p⁻¹
  | Nat.succ n => neg p n ⬝ p⁻¹

  def power (p : a = a) : ℤ → a = a
  | Integer.pos n => pos p n
  | Integer.neg n => neg p n

  hott def powerComp (p : a = a) : Π z, power p z ⬝ p = power p (Integer.succ z)
  | Integer.neg Nat.zero     => Id.invComp _
  | Integer.neg (Nat.succ n) => (Id.assoc _ _ _)⁻¹ ⬝ Id.map (neg p n ⬝ ·) (Id.invComp _) ⬝ Id.reflRight _
  | Integer.pos _            => idp _

  hott def powerCompPred (p : a = a) : Π z, power p z ⬝ p⁻¹ = power p (Integer.pred z)
  | Integer.neg _            => idp _
  | Integer.pos Nat.zero     => idp _
  | Integer.pos (Nat.succ n) => (Id.assoc _ _ _)⁻¹ ⬝ Id.map (pos p n ⬝ ·) (Id.compInv _) ⬝ Id.reflRight _

  hott def compPowerPos (p : a = a) : Π n, p ⬝ power p (Integer.pos n) = power p (Integer.succ (Integer.pos n))
  | Nat.zero   => Id.reflRight _
  | Nat.succ n => Id.assoc _ _ _ ⬝ Id.map (· ⬝ p) (compPowerPos p n)

  hott def compPowerNeg (p : a = a) : Π n, p ⬝ power p (Integer.neg n) = power p (Integer.succ (Integer.neg n))
  | Nat.zero   => Id.compInv _
  | Nat.succ n => begin
    transitivity; apply Id.assoc;
    symmetry; apply Equiv.invCompRewrite;
    symmetry; transitivity; apply compPowerNeg p n;
    symmetry; apply powerComp
  end

  hott def compPower (p : a = a) : Π z, p ⬝ power p z = power p (Integer.succ z)
  | Integer.neg n => compPowerNeg p n
  | Integer.pos m => compPowerPos p m

  hott def compPowerPred (p : a = a) : Π z, p⁻¹ ⬝ power p z = power p (Integer.pred z)
  | Integer.neg Nat.zero     => idp _
  | Integer.neg (Nat.succ n) => begin apply Equiv.rewriteComp; symmetry; apply compPower end
  | Integer.pos Nat.zero     => Id.reflRight _
  | Integer.pos (Nat.succ n) => begin apply Equiv.rewriteComp; symmetry; apply compPower end

  hott def compPowerComm (p : a = a) (z : ℤ) :
    p ⬝ power p z = power p z ⬝ p :=
  compPower p z ⬝ (powerComp p z)⁻¹

  hott def invCompPowerComm (p : a = a) (z : ℤ) :
    p⁻¹ ⬝ power p z = power p z ⬝ p⁻¹ :=
  compPowerPred p z ⬝ (powerCompPred p z)⁻¹

  hott def powerComm (p : a = a) (x y : ℤ) : power p x ⬝ power p y = power p y ⬝ power p x :=
  begin
    fapply @Integer.indsp (λ x, Π y, power p x ⬝ power p y = power p y ⬝ power p x) _ _ _ x <;> clear x;
    { intro y; symmetry; apply Id.reflRight };
    { intros x ih y; transitivity; apply Id.map (· ⬝ power p y);
      symmetry; apply compPower;
      transitivity; symmetry; apply Id.assoc;
      transitivity; apply Id.map; apply ih;
      transitivity; apply Id.assoc;
      transitivity; apply Id.map (· ⬝ power p x); apply compPowerComm;
      transitivity; symmetry; apply Id.assoc;
      apply Id.map; apply compPower };
    { intros x ih y; transitivity; apply Id.map (· ⬝ power p y);
      symmetry; apply compPowerPred;
      transitivity; symmetry; apply Id.assoc;
      transitivity; apply Id.map; apply ih;
      transitivity; apply Id.assoc;
      transitivity; apply Id.map (· ⬝ power p x);
      apply invCompPowerComm;
      transitivity; symmetry; apply Id.assoc;
      apply Id.map; apply compPowerPred }
  end
end Loop

hott def S : ℕ → Type
| Nat.zero   => 𝟐
| Nat.succ n => ∑ (S n)

def S.lift : Π n, S n → S (n + 1)
| Nat.zero,   false => Suspension.north
| Nat.zero,   true  => Suspension.south
| Nat.succ _, z     => Suspension.rec Suspension.north Suspension.south (λ _, Suspension.merid z) z

macro:max "S" n:superscript : term => do `(GroundZero.HITs.S $(← Meta.Notation.parseSuperscript n))
instance (n : ℕ) : Id.dotted Sⁿ :=
⟨match n with
 | Nat.zero   => false
 | Nat.succ _ => Suspension.north⟩

macro:max "S" : term => `(GroundZero.HITs.S)

def Circle := S¹

namespace Circle
  -- https://github.com/leanprover/lean2/blob/master/hott/homotopy/Circle.hlean

  def base₁ : S¹ := Suspension.north
  def base₂ : S¹ := Suspension.south

  def seg₁ : base₁ = base₂ := Suspension.merid false
  def seg₂ : base₁ = base₂ := Suspension.merid true

  hott def ind₂ {B : S¹ → Type u} (b₁ : B base₁) (b₂ : B base₂)
    (ℓ₁ : b₁ =[seg₁] b₂) (ℓ₂ : b₁ =[seg₂] b₂) : Π x, B x :=
  Suspension.ind b₁ b₂ (λ | false => ℓ₁ | true => ℓ₂)

  def base : S¹ := base₁
  def loop : base = base := seg₂ ⬝ seg₁⁻¹

  hott def rec {B : Type u} (b : B) (ℓ : b = b) : S¹ → B :=
  Suspension.rec b b (λ | false => idp b | true => ℓ)

  hott def recβrule₁ {B : Type u} (b : B) (ℓ : b = b) : rec b ℓ base = b :=
  idp b

  -- why this doesn’t require “noncomputable” attribute as it was in Lean 3?
  -- looks pretty strange
  hott def recβrule₂ {B : Type u} (b : B) (ℓ : b = b) := calc
          Id.map (rec b ℓ) loop
        = Id.map (rec b ℓ) seg₂ ⬝ Id.map (rec b ℓ) seg₁⁻¹   : Equiv.mapFunctoriality _
    ... = Id.map (rec b ℓ) seg₂ ⬝ (Id.map (rec b ℓ) seg₁)⁻¹ : Id.map (_ ⬝ ·) (Id.mapInv _ _)
    ... = ℓ ⬝ Id.refl⁻¹                                     : bimap (· ⬝ ·⁻¹) (Suspension.recβrule _ _ _ _) (Suspension.recβrule _ _ _ _)
    ... = ℓ                                                 : Id.reflRight _

  hott def recβrule₃ {B : Type u} (b : B) (ℓ : b = b) := calc
            Id.map (rec b ℓ) loop⁻¹
          = (Id.map (rec b ℓ) loop)⁻¹ : Id.mapInv _ _
      ... = ℓ⁻¹                       : Id.map Id.inv (recβrule₂ _ _)

  hott def ind {B : S¹ → Type u} (b : B base) (ℓ : b =[loop] b) : Π (x : S¹), B x :=
  ind₂ b (Equiv.subst seg₁ b) Id.refl (depPathTransSymm ℓ)

  attribute [eliminator] ind

  hott def indβrule₁ {B : S¹ → Type u} (b : B base) (ℓ : b =[loop] b) : ind b ℓ base = b :=
  idp b

  hott def indβrule₂ {B : S¹ → Type u} (b : B base) (ℓ : b =[loop] b) : apd (ind b ℓ) loop = ℓ :=
  begin
    dsimp [ind, ind₂];
    transitivity; apply apdFunctoriality;
    transitivity; apply bimap depTrans; apply Suspension.indβrule;
    transitivity; apply apdInv; apply Id.map;
    apply Suspension.indβrule; apply depPathTransSymmCoh
  end

  hott def indΩ {B : S¹ → Type u} (b : B base) (H : Π x, prop (B x)) : Π x, B x :=
  begin fapply ind; exact b; apply H end

  noncomputable hott def loopEqReflImplsUip {A : Type u} (H : loop = idp base) : K A :=
  begin
    intros a p; transitivity;
    symmetry; apply Circle.recβrule₂ a p;
    change _ = Id.map (rec a p) (idp _);
    apply Id.map; apply H
  end

  noncomputable hott def loopNeqRefl : ¬(loop = idp base) :=
  begin
    intro H; apply ua.universeNotASet;
    intros A B p q; apply (KIffSet Type).left;
    apply loopEqReflImplsUip; assumption
  end

  namespace map
    def trivial    : S¹ → S¹ := rec base (idp base)
    def nontrivial : S¹ → S¹ := rec base loop

    noncomputable hott def trivialNotHmtpy : ¬(trivial = id) :=
    begin
      intro p; apply loopNeqRefl; transitivity; symmetry; apply idmap;
      apply transport (λ f, Id.map f loop = idp (f base)) p; apply Circle.recβrule₂
    end

    noncomputable hott def trivialHmtpy : trivial ~ (λ _, base) :=
    begin
      intro x; induction x; reflexivity; apply Id.trans; apply transportOverContrMap;
      transitivity; apply Id.map (· ⬝ idp base); transitivity; apply Id.mapInv;
      apply Id.map; apply recβrule₂; reflexivity
    end

    noncomputable hott def nontrivialHmtpy : nontrivial ~ id :=
    begin
      intro x; induction x; reflexivity;
      apply Id.trans; apply transportOverInvolution;
      transitivity; apply Id.map (· ⬝ idp base ⬝ loop);
      transitivity; apply Id.mapInv; apply Id.map; apply recβrule₂;
      transitivity; symmetry; apply Id.assoc; apply Id.invComp
    end

    noncomputable hott def nontrivialNotHmtpy : ¬(nontrivial = (λ _, base)) :=
    λ p, trivialNotHmtpy (Theorems.funext trivialHmtpy ⬝ p⁻¹ ⬝
                          Theorems.funext nontrivialHmtpy)
  end map

  def succ (l : Ω¹(S¹)) : Ω¹(S¹) := l ⬝ loop
  def pred (l : Ω¹(S¹)) : Ω¹(S¹) := l ⬝ loop⁻¹

  def zero   := idp base
  def one    := succ zero
  def two    := succ one
  def three  := succ two
  def fourth := succ three

  hott def helix : S¹ → Type :=
  rec ℤ (ua Integer.succEquiv)

  def power : ℤ → Ω¹(S¹) := Loop.power loop

  hott def encode (x : S¹) (p : base = x) : helix x :=
  transport helix p (Integer.pos 0)

  example : power 2 = loop ⬝ loop :=
  by reflexivity

  hott def winding : base = base → ℤ := encode base

  noncomputable hott def transportThere (x : ℤ) := calc
          transport helix loop x
        = transportconst (Id.map helix loop) x    : Equiv.transportComp id helix loop x
    ... = transportconst (ua Integer.succEquiv) x : Id.map (transportconst · x) (recβrule₂ _ _)
    ... = Integer.succ x                          : ua.transportRule _ _

  noncomputable hott def transportBack (x : ℤ) := calc
           transport helix loop⁻¹ x
         = transportconst (Id.map helix loop⁻¹) x    : Equiv.transportComp id helix loop⁻¹ x
     ... = transportconst (Id.map helix loop)⁻¹ x    : Id.map (transportconst · x) (Id.mapInv _ _)
     ... = transportconst (ua Integer.succEquiv)⁻¹ x : Id.map (transportconst ·⁻¹ x) (recβrule₂ _ _)
     ... = Integer.pred x                            : ua.transportInvRule _ _

  noncomputable hott def decode (x : S¹) : helix x → base = x :=
  begin
    induction x; exact power; apply Theorems.funext; intro x;
    transitivity; apply Homotopy.Id (transportCharacterization power loop) x;
    transitivity; apply transportComposition;
    transitivity; apply Id.map (power · ⬝ loop); apply transportBack;
    transitivity; apply Id.map (· ⬝ loop);
    transitivity; symmetry; apply Loop.compPowerPred; apply Loop.invCompPowerComm;
    apply Id.cancelInvComp
  end

  noncomputable hott def decodeEncode (x : S¹) (p : base = x) : decode x (encode x p) = p :=
  begin induction p; reflexivity end

  noncomputable hott def powerOfWinding : power ∘ winding ~ id :=
  decodeEncode base

  noncomputable hott def windingPos : Π n, winding (power (Integer.pos n)) = Integer.pos n
  | Nat.zero   => idp _
  | Nat.succ n => substOverPathComp _ _ _ ⬝ transportThere _ ⬝ Id.map _ (windingPos n)

  noncomputable hott def windingNeg : Π n, winding (power (Integer.neg n)) = Integer.neg n
  | Nat.zero   => transportBack _
  | Nat.succ n => substOverPathComp _ _ _ ⬝ transportBack _ ⬝ Id.map _ (windingNeg n)

  noncomputable hott def windingPower : Π z, winding (power z) = z
  | Integer.neg n => windingNeg n
  | Integer.pos n => windingPos n

  noncomputable hott def encodeDecode (x : S¹) : Π c, encode x (decode x c) = c :=
  begin induction x; intro c; apply windingPower; apply Theorems.funext; intro z; apply Integer.set end

  noncomputable hott def family (x : S¹) : (base = x) ≃ helix x :=
  ⟨encode x, (⟨decode x, decodeEncode x⟩, ⟨decode x, encodeDecode x⟩)⟩

  noncomputable hott def fundamentalGroup : Ω¹(S¹) = ℤ := ua (family base)

  noncomputable hott def loopHset : hset (base = base) :=
  transport hset fundamentalGroup⁻¹ Integer.set

  noncomputable example : winding (loop ⬝ loop) = 2 := windingPower 2
  noncomputable example : winding loop = 1          := windingPower 1
  noncomputable example : winding loop⁻¹ = -1       := windingPower (Integer.neg 0)

  hott def rot : Π (x : S¹), x = x :=
  Circle.ind Circle.loop (begin
    apply Id.trans; apply transportInvCompComp; change _ = idp _ ⬝ loop;
    apply Id.map (· ⬝ loop); apply Id.invComp
  end)

  def μₑ : S¹ → S¹ ≃ S¹ :=
  Circle.rec (ideqv S¹) (Sigma.prod (Theorems.funext rot) (Theorems.Equiv.biinvProp _ _ _))

  def μ (x : S¹) : S¹ → S¹ := (μₑ x).forward

  noncomputable hott def μLoop : Id.map μ loop = Theorems.funext rot :=
  begin
    transitivity; apply mapOverComp;
    transitivity; apply Id.map; apply recβrule₂;
    apply Sigma.mapFstOverProd
  end

  hott def inv : S¹ → S¹ := Circle.rec base loop⁻¹

  noncomputable hott def invInv (x : S¹) : inv (inv x) = x :=
  let invₚ := @Id.map S¹ S¹ base base (inv ∘ inv);
  begin
    induction x; reflexivity; apply calc
              transport (λ x, inv (inv x) = x) loop Id.refl
            = invₚ loop⁻¹ ⬝ Id.refl ⬝ loop          : transportOverInvolution _ _ _
        ... = invₚ loop⁻¹ ⬝ (Id.refl ⬝ loop)        : (Id.assoc _ _ _)⁻¹
        ... = Id.map inv (Id.map inv loop⁻¹) ⬝ loop : Id.map (· ⬝ loop) (mapOverComp _ _ _)
        ... = Id.map inv (Id.map inv loop)⁻¹ ⬝ loop : Id.map (· ⬝ loop) (Id.map (Id.map inv) (Id.mapInv inv loop))
        ... = Id.map inv loop⁻¹⁻¹ ⬝ loop            : @Id.map Ω¹(S¹) _ _ _ (Id.map inv ·⁻¹ ⬝ loop) (Circle.recβrule₂ base loop⁻¹)
        ... = Id.map inv loop ⬝ loop                : @Id.map Ω¹(S¹) _ _ _ (Id.map inv · ⬝ loop) (Id.invInv _)
        ... = loop⁻¹ ⬝ loop                         : Id.map (· ⬝ loop) (Circle.recβrule₂ _ _)
        ... = idp base                              : Id.invComp _
  end

  hott def unitLeft (x : S¹) : μ base x = x := idp x

  hott def μRight : Id.map (μ base) loop = loop := Equiv.idmap _

  noncomputable hott def μLeft := calc
          Id.map (μ · base) loop
        = happly (Id.map μ loop) base         : Interval.mapHapply _ _
    ... = (happly ∘ Theorems.funext) rot base : Id.map (λ f, happly f base) μLoop
    ... = loop                                : happly (Theorems.happlyFunext _ _ rot) base

  noncomputable hott def unitRight (x : S¹) : μ x base = x :=
  begin
    induction x; reflexivity; change _ = _;
    transitivity; apply transportOverInvolution (μ · base);
    transitivity; apply Id.map (· ⬝ idp base ⬝ loop);
    transitivity; apply Id.mapInv; apply Id.map;
    apply μLeft; transitivity; apply Id.map (· ⬝ loop);
    apply Id.reflRight; apply Id.invComp
  end

  hott def μLeftApLem {x : S¹} (p : base = x) :
    Id.map (μ · base) p = transport (base = ·) (unitRight x)⁻¹ p :=
  begin induction p; reflexivity end

  hott def μLeftAp  (p : Ω¹(S¹)) : Id.map (μ · base) p = p := μLeftApLem p
  hott def μRightAp (p : Ω¹(S¹)) : Id.map (μ base)   p = p := Equiv.idmap p

  noncomputable hott def unitComm (x : S¹) : μ base x = μ x base := (unitRight x)⁻¹

  noncomputable hott def mulInv (x : S¹) : base = μ x (inv x) :=
  begin
    induction x; exact loop; change _ = _;
    transitivity; apply transportComp (base = ·) (AS μ inv) loop;
    transitivity; apply transportComposition;
    transitivity; apply Id.map; apply Equiv.mapOverAS;
    transitivity; apply Id.map; apply Id.map; apply Circle.recβrule₂;
    transitivity; apply Id.map (· ⬝ Equiv.bimap μ loop loop⁻¹);
    symmetry; apply μRight; symmetry; transitivity;
    symmetry; apply μLeft; apply bimapComp
  end

  -- https://github.com/mortberg/cubicaltt/blob/master/examples/helix.ctt#L207
  hott def lemSetTorus {π : S¹ → S¹ → Type u} (setπ : hset (π base base))
    (f : Π y, π base y) (g : Π x, π x base) (p : f base = g base) : Π x y, π x y :=
  begin
    intro x; induction x; exact f; change _ = _; transitivity;
    apply transportOverPi; apply Theorems.funext; intro y; induction y;
    transitivity; apply Id.map; exact p; transitivity; apply apd; exact p⁻¹; apply setπ
  end

  noncomputable hott def isGroupoid : groupoid S¹ :=
  begin
    intros a b; change hset (a = b);
    fapply @indΩ (λ a, Π b, hset (a = b)) _ _ a <;> clear a;
    { intro b; fapply @indΩ (λ b, hset (base = b)) _ _ b <;> clear b;
      apply loopHset; intro; apply Structures.setIsProp };
    intro; apply piProp; intro; apply Structures.setIsProp
  end

  noncomputable hott def mulComm (x y : S¹) : μ x y = μ y x :=
  begin
    fapply @lemSetTorus (λ x y, μ x y = μ y x); apply loopHset;
    { intro z; symmetry; apply unitRight };
    { intro z; apply unitRight }; reflexivity
  end

  noncomputable hott def mulAssoc : Π x y z, μ x (μ y z) = μ (μ x y) z :=
  begin
    intro x; fapply @lemSetTorus (λ y z, μ x (μ y z) = μ (μ x y) z); apply isGroupoid;
    { intro z; apply Id.map (μ · z); exact (unitRight x)⁻¹ };
    { intro z; transitivity; apply Id.map; apply unitRight; symmetry; apply unitRight };
    { induction x; reflexivity; apply isGroupoid }
  end

  noncomputable hott def mulTrans (p q : Ω¹(S¹)) : bimap μ p q = p ⬝ q :=
  begin
    transitivity; apply bimapCharacterization;
    apply bimap; apply μLeftAp; apply μRightAp
  end

  noncomputable hott def mulTrans' (p q : Ω¹(S¹)) : bimap μ p q = q ⬝ p :=
  begin
    transitivity; apply bimapCharacterization';
    apply bimap; apply μRightAp; apply μLeftAp
  end

  noncomputable hott def comm (x y : Ω¹(S¹)) : x ⬝ y = y ⬝ x :=
  (mulTrans x y)⁻¹ ⬝ (mulTrans' x y)

  noncomputable hott def comm' (x y : Ω¹(S¹)) : x ⬝ y = y ⬝ x :=
    Equiv.bimap Id.trans (powerOfWinding x)⁻¹ (powerOfWinding y)⁻¹
  ⬝ Loop.powerComm Circle.loop (winding x) (winding y)
  ⬝ Equiv.bimap Id.trans (powerOfWinding y) (powerOfWinding x)

  noncomputable hott def Ωind₁ {π : Ω¹(S¹) → Type u}
    (zeroπ : π (idp base)) (succπ : Π x, π x → π (x ⬝ loop))
    (predπ : Π x, π x → π (x ⬝ loop⁻¹)) : Π x, π x :=
  begin
    intro x; apply transport π; apply powerOfWinding;
    fapply @Types.Integer.indsp (π ∘ power) _ _ _ (winding x);
    { exact zeroπ };
    { intros x ih; apply transport π;
      apply Loop.powerComp Circle.loop;
      apply succπ; exact ih };
    { intros x ih; apply transport π;
      apply Loop.powerCompPred;
      apply predπ; exact ih }
  end

  noncomputable hott def Ωind₂ {π : Ω¹(S¹) → Type u}
    (zeroπ : π Id.refl) (succπ : Π x, π x → π (loop ⬝ x))
    (predπ : Π x, π x → π (loop⁻¹ ⬝ x)) : Π x, π x :=
  begin
    fapply Ωind₁; exact zeroπ;
    { intros x ih; apply transport π; apply comm; apply succπ; exact ih };
    { intros x ih; apply transport π; apply comm; apply predπ; exact ih }
  end

  noncomputable hott def transComm {z : S¹} : Π (p q : z = z), p ⬝ q = q ⬝ p :=
  begin
    induction z; apply comm;
    apply Theorems.funext; intro;
    apply Theorems.funext; intro;
    apply isGroupoid
  end

  noncomputable hott def transportOverCircle {z : S¹} {f g : S¹ → S¹} {p : f = g}
    (μ : f z = f z) (η : f z = g z) : @transport (S¹ → S¹) (λ φ, φ z = φ z) f g p μ = η⁻¹ ⬝ μ ⬝ η :=
  begin induction p; symmetry; apply idConjIfComm; apply transComm end

  def halfway.φ : I → S¹ :=
  λ i, Interval.elim loop (i ∧ Interval.neg i)

  def halfway : base = base :=
  Interval.lam halfway.φ

  hott def halfway.const : halfway.φ ~ λ _, base :=
  begin
    intro x; induction x; reflexivity; reflexivity; change _ = _;
    transitivity; apply transportOverContrMap;
    transitivity; apply Id.reflRight;
    transitivity; apply Id.mapInv;
    transitivity; apply Id.map; apply mapOverComp;
    transitivity; apply Id.map; apply Id.map (map (elim loop));
    change _ = idp 0; apply Structures.propIsSet;
    apply Interval.intervalProp; reflexivity
  end

  hott def halfway.trivial : halfway = idp base :=
  begin
    transitivity; apply Equiv.mapWithHomotopy; apply halfway.const;
    transitivity; apply Id.reflRight; apply constmap
  end

  def natPow (x : S¹) : ℕ → S¹
  | Nat.zero   => base
  | Nat.succ n => μ x (natPow x n)

  def pow (x : S¹) : ℤ → S¹
  | Integer.pos n => natPow x n
  | Integer.neg n => natPow (inv x) (n + 1)

  def uarec {A : Type u} (φ : A ≃ A) : S¹ → Type u := rec A (ua φ)

  hott def Ωrec {A : Type u} (zero : A) (succ pred : A → A)
    (p : succ ∘ pred ~ id) (q : pred ∘ succ ~ id) : Ω¹(S¹) → A :=
  λ r, @transport S¹ (uarec ⟨succ, (⟨pred, q⟩, ⟨pred, p⟩)⟩) base base r zero

  section
    variable {A : Type u} (zero : A) (succ pred : A → A)
             (p : succ ∘ pred ~ id) (q : pred ∘ succ ~ id)

    hott def Ωrecβ₁ : Ωrec zero succ pred p q (idp base) = zero :=
    by reflexivity

    noncomputable hott def Ωrecβ₂ (r : Ω¹(S¹)) :
        Ωrec zero succ pred p q (r ⬝ loop)
      = succ (Ωrec zero succ pred p q r) :=
    begin
      transitivity; apply transportToTransportconst;
      transitivity; apply Id.map (transportconst · zero);
      transitivity; apply mapFunctoriality; apply Id.map; apply recβrule₂;
      transitivity; apply transportconstOverComposition;
      transitivity; apply ua.transportRule; apply Id.map succ;
      symmetry; apply transportToTransportconst
    end

    noncomputable hott def Ωrecβ₃ (r : Ω¹(S¹)) :
        Ωrec zero succ pred p q (r ⬝ loop⁻¹)
      = pred (Ωrec zero succ pred p q r) :=
    begin
      transitivity; apply transportToTransportconst;
      transitivity; apply Id.map (transportconst · zero);
      transitivity; apply mapFunctoriality; apply Id.map;
      transitivity; apply Id.mapInv; apply Id.map Id.symm; apply recβrule₂;
      transitivity; apply transportconstOverComposition;
      transitivity; apply transportconstOverInv;
      transitivity; apply ua.transportInvRule; apply Id.map pred;
      symmetry; apply transportToTransportconst
    end
  end

  hott def mult (p q : Ω¹(S¹)) : Ω¹(S¹) :=
  Id.map (rec base p) q

  hott def multZero (p : Ω¹(S¹)) : mult p (idp base) = idp base :=
  idp (idp base)

  hott def multSucc (p q : Ω¹(S¹)) : mult p (succ q) = mult p q ⬝ p :=
  begin transitivity; apply mapFunctoriality; apply Id.map; apply recβrule₂ end

  hott def multDistrRight (p q r : Ω¹(S¹)) : mult p (q ⬝ r) = mult p q ⬝ mult p r :=
  by apply mapFunctoriality

  hott def recComp (p q : Ω¹(S¹)) : rec base p ∘ rec base q ~ rec base (mult p q) :=
  begin
    fapply ind; reflexivity; change _ = _; transitivity;
    apply Equiv.transportOverHmtpy; transitivity;
    apply Id.map (· ⬝ _ ⬝ _); transitivity; apply mapInv;
    apply Id.map; transitivity; apply mapOverComp; apply Id.map (mult p); apply recβrule₂;
    transitivity; apply bimap; apply Id.reflRight; apply recβrule₂; apply Id.invComp
  end

  hott def multAssoc (p q r : Ω¹(S¹)) : mult (mult p q) r = mult p (mult q r) :=
  begin
    symmetry; transitivity; symmetry; apply mapOverComp (rec base q) (rec base p) r;
    transitivity; apply Equiv.mapWithHomotopy; apply recComp; apply Id.reflRight
  end

  hott def mulNegRight (p q : Ω¹(S¹)) : mult p q⁻¹ = (mult p q)⁻¹ :=
  by apply Id.mapInv

  hott def mapExt {B : Type u} (φ : S¹ → B) : φ ~ rec (φ base) (Id.map φ loop) :=
  begin
    fapply ind; reflexivity; change _ = _; transitivity; apply Equiv.transportOverHmtpy;
    transitivity; apply bimap; transitivity; apply Id.reflRight; apply Id.mapInv;
    apply recβrule₂; apply Id.invComp
  end

  section
    variable {B : Type u} (b : B) (p q : b = b) (H : p ⬝ q = q ⬝ p)

    hott def birec : S¹ → S¹ → B :=
    @rec (S¹ → B) (rec b p) (Theorems.funext (Circle.ind q (begin
      change _ = _; transitivity; apply Equiv.transportOverHmtpy;
      transitivity; apply bimap (· ⬝ q ⬝ ·);
      apply recβrule₃; apply recβrule₂;
      apply Id.idConjIfComm; exact H⁻¹
    end)))

    hott def birecβrule₁ : Id.map (birec b p q H base) loop = p :=
    by apply recβrule₂

    hott def birecβrule₂ : Id.map (birec b p q H · base) loop = q :=
    begin
      transitivity; apply Interval.mapHapply;
      transitivity; apply Id.map (happly · base); apply recβrule₂;
      apply happly (Theorems.happlyFunext _ _ _) base
    end

    hott def birecBimap : bimap (birec b p q H) loop loop = p ⬝ q :=
    begin
      transitivity; apply Equiv.bimapCharacterization';
      apply bimap; apply birecβrule₁; apply birecβrule₂
    end
  end

  open GroundZero.Types.Coproduct

  noncomputable hott def succNeqIdp : ua (Integer.succEquiv) ≠ idp ℤ :=
  begin
    intro H; apply @ua.succNeqZero 0; apply @inl.encode ℕ ℕ _ (inl 0);
    transitivity; symmetry; apply ua.transportRule Integer.succEquiv 0;
    apply ap (transportconst · 0) H
  end

  noncomputable hott def helixNontriv : helix ≠ (λ _, ℤ) :=
  begin
    intro H; apply succNeqIdp; transitivity; symmetry; apply recβrule₂;
    apply transport (λ φ, ap φ loop = idp (φ base)) H⁻¹; apply constmap
  end

  noncomputable hott def loopSpaceNontriv : ¬(Π (x y : S¹), (x = y) ≃ ℤ) :=
  begin
    intro H; apply helixNontriv; apply Theorems.funext; intro y;
    apply ua; transitivity; symmetry; apply family; apply H
  end

  hott def funextPath {A : Type u} {B : Type v} {a b c : A} (f : a = b → B) (g : a = c → B)
    (p : b = c) (η : Π q, f (q ⬝ p⁻¹) = g q) : f =[λ x, a = x → B, p] g :=
  begin
    induction p; apply Theorems.funext; intro; transitivity;
    apply Id.map; apply Id.symm; apply Id.reflRight; apply η
  end

  hott def transportPathMap {A : Type u} {B : Type v} {a b c : A} (φ : a = b → B) (p : b = c) (q : a = c) :
    transport (λ x, a = x → B) p φ q = φ (q ⬝ p⁻¹) :=
  begin induction p; induction q; reflexivity end

  section
    variable {A : Type u} {B : Type v} {a b c : A} {f : a = b → B} {g : a = c → B} {p : b = c} (φ : Π r, f (r ⬝ p⁻¹) = g r)

    hott def happlyFunextPath {q : a = c} : happly (funextPath f g p φ) q = transportPathMap f p q ⬝ φ q :=
    begin induction p; induction q; apply Interval.happly (Theorems.happlyFunext _ _ _) end

    hott def happlyRevFunextPath {q : b = a} :
        happly (depSymm p (funextPath f g p φ)) q⁻¹
      = transportPathMap g p⁻¹ q⁻¹ ⬝ (φ (q⁻¹ ⬝ p⁻¹⁻¹))⁻¹ ⬝ Id.map f (cancelInvComp _ _) :=
    begin
      induction p; induction q; transitivity; apply Interval.happly (Interval.happlyRev _);
      transitivity; apply Id.map Id.symm; apply Interval.happly (Theorems.happlyFunext _ _ _);
      symmetry; apply Id.reflRight
    end
  end

  hott def transportMeet {A : Type u} {a : A} (B : Π x, a = x → Type v)
    (w : B a (idp a)) {b : A} (p : a = b) : transport (λ x, a = x → Type v) p (B a) p :=
  begin induction p; exact w end

  hott def meetTransportCoh {A : Type u} {a b : A} (B : Π x, a = x → Type v) (w : B a (idp a)) (p : a = b) :
    transportconst (transportPathMap (B a) p p) (transportMeet B w p) = subst (compInv p)⁻¹ w :=
  begin induction p; reflexivity end

  section
    variable {A : Type u} {a : A} (B : Π x, a = x → Type v) (w : B a (idp a)) {b : A} (p : a = b)

    hott def ΩJ :=
    transportconst (Interval.happly (apd B p) p) (transportMeet B w p)

    noncomputable hott def ΩJDef : J₁ B w p = ΩJ B w p :=
    begin induction p; reflexivity end
  end

  section
    variable {x : S¹} (π : x = base → Type u)
             (succπ : Π z, π z → π (z ⬝ loop)) (predπ : Π z, π z → π (z ⬝ loop⁻¹))
             (coh₁ : Π p z, predπ _ (succπ p z) =[cancelCompInv _ _] z)
             (coh₂ : Π p z, succπ _ (predπ p z) =[cancelInvComp _ _] z)

    noncomputable hott def ΩEquivSuccInj {z : x = base} {w₁ w₂ : π z} (H : succπ z w₁ = succπ z w₂) : w₁ = w₂ :=
    begin
      transitivity; apply Id.symm; apply coh₁;
      transitivity; apply Id.map (subst _ ∘ predπ _);
      apply H; apply coh₁
    end

    noncomputable hott def ΩEquivPredInj {z : x = base} {w₁ w₂ : π z} (H : predπ z w₁ = predπ z w₂) : w₁ = w₂ :=
    begin
      transitivity; apply Id.symm; apply coh₂;
      transitivity; apply Id.map (subst _ ∘ succπ _);
      apply H; apply coh₂
    end

    noncomputable hott def ΩSuccEquiv (z : x = base) : π (z ⬝ loop⁻¹) ≃ π z :=
    ⟨λ H, subst (cancelInvComp z loop) (succπ _ H),
     (⟨predπ z, λ _, ΩEquivSuccInj π succπ predπ coh₁
      ((transportForwardAndBack (cancelInvComp _ _) _)⁻¹ ⬝
        Id.map (subst _) (coh₂ _ _) ⬝ transportForwardAndBack _ _)⟩,
      ⟨predπ z, coh₂ _⟩)⟩

    noncomputable hott def ΩHelix : Π y, x = y → Type u :=
    Circle.ind π (funextPath π π loop (λ z, ua (ΩSuccEquiv π succπ predπ coh₁ coh₂ z)))

    noncomputable hott def ΩHelixSucc {z : x = base} (w : π (z ⬝ idp base)) :
        J₁ (λ y r, ΩHelix π succπ predπ coh₁ coh₂ y (z ⬝ r)) w loop
      = succπ z (subst (reflRight _) w) :=
    begin
      induction z using J₂; transitivity; apply ΩJDef;
      transitivity; apply Id.map (transportconst · _);
      transitivity; apply Id.map (happly · _); apply indβrule₂; apply happlyFunextPath;
      transitivity; apply transportconstOverComposition;
      transitivity; apply Id.map (transportconst _); apply meetTransportCoh (ΩHelix π succπ predπ coh₁ coh₂);
      transitivity; apply ua.transportRule; show subst _ _ = _; transitivity;

      apply Id.map (subst _); transitivity; transitivity; apply happly;
      symmetry; apply apd succπ (compInv loop)⁻¹; apply happly;
      apply transportImpl; apply Id.map (subst _); apply Id.map (succπ _);
      apply transportForwardAndBack; apply compInvCancelCoh
    end

    noncomputable hott def ΩHelixPred {z : x = base} (w : π (z ⬝ idp base)) :
        J₁ (λ y r, ΩHelix π succπ predπ coh₁ coh₂ y (z ⬝ r)) w loop⁻¹
      = predπ z (subst (reflRight _) w) :=
    begin
      induction z using J₂; transitivity; apply ΩJDef;
      transitivity; apply Id.map (transportconst · _);
      transitivity; apply Id.map (happly · _);
      transitivity; apply apdInv; apply Id.map (depSymm _); apply indβrule₂; apply happlyRevFunextPath;
      transitivity; apply transportconstOverComposition;
      transitivity; apply Id.map (transportconst _);
      transitivity; apply transportconstOverComposition;
      transitivity; apply Id.map (transportconst _); apply meetTransportCoh (ΩHelix π succπ predπ coh₁ coh₂);
      apply ua.transportInvRule; transitivity; symmetry; apply transportToTransportconst;

      show transport _ _ (predπ _ _) = _; transitivity;
      apply Id.map (subst _); transitivity; transitivity; apply happly;
      symmetry; apply apd predπ (compInv loop⁻¹)⁻¹; apply happly;
      apply transportImpl; apply Id.map (subst _); apply Id.map (predπ _);
      apply transportForwardAndBack; apply compInvCancelCoh
    end
  end

  section
    variable {π : Ω¹(S¹) → Type u} (zeroπ : π (idp base))
             (succπ : Π x, π x → π (x ⬝ loop)) (predπ : Π x, π x → π (x ⬝ loop⁻¹))
             (coh₁ : Π p z, predπ _ (succπ p z) =[cancelCompInv _ _] z)
             (coh₂ : Π p z, succπ _ (predπ p z) =[cancelInvComp _ _] z)

    -- https://github.com/ncfavier/cubical-experiments/blob/998602175a25def84b927b5071dac208aea38d7d/Shapes.agda#L52-L68
    noncomputable hott def Ωind (z : Ω¹(S¹)) : π z :=
    J₁ (ΩHelix π succπ predπ coh₁ coh₂) zeroπ z

    noncomputable hott def Ωindβ₁ : Ωind zeroπ succπ predπ coh₁ coh₂ (idp base) = zeroπ :=
    by reflexivity

    noncomputable hott def Ωindβ₂ (z : Ω¹(S¹)) :
        Ωind zeroπ succπ predπ coh₁ coh₂ (z ⬝ loop)
      = succπ z (Ωind zeroπ succπ predπ coh₁ coh₂ z) :=
    begin
      transitivity; apply JTrans;
      transitivity; apply ΩHelixSucc;
      apply Id.map; apply transportBackAndForward
    end

    noncomputable hott def Ωindβ₃ (z : Ω¹(S¹)) :
        Ωind zeroπ succπ predπ coh₁ coh₂ (z ⬝ loop⁻¹)
      = predπ z (Ωind zeroπ succπ predπ coh₁ coh₂ z) :=
    begin
      transitivity; apply JTrans;
      transitivity; apply ΩHelixPred;
      apply Id.map; apply transportBackAndForward
    end
  end
end Circle

def Torus := S¹ × S¹
notation "T²" => Torus

namespace Torus
  open Types.Product
  def b : T² := ⟨Circle.base, Circle.base⟩

  def inj₁ : S¹ → T² := Prod.mk Circle.base
  def inj₂ : S¹ → T² := (Prod.mk · Circle.base)

  -- poloidal and toroidal directions
  def p : b = b := prod (idp Circle.base) Circle.loop
  def q : b = b := prod Circle.loop (idp Circle.base)

  hott def Φ {π : Type u} {x x' y y' : π}
    (α : x = x') (β : y = y') :
    prod (idp x) β ⬝ prod α (idp y') =
    prod α (idp y) ⬝ prod (idp x') β :=
  begin induction α; induction β; reflexivity end

  hott def t : p ⬝ q = q ⬝ p :=
  Φ Circle.loop Circle.loop
end Torus

namespace Sphere
end Sphere

namespace Glome
end Glome

end HITs

namespace Types.Integer
  noncomputable def succPath := GroundZero.ua Integer.succEquiv

  noncomputable def shift : ℤ → ℤ = ℤ :=
  HITs.Loop.power succPath

  noncomputable hott def shiftComp (z : ℤ) :
    shift z ⬝ succPath = shift (Integer.succ z) :=
  HITs.Loop.powerComp succPath z
end Types.Integer

end GroundZero


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.set.intervals.basic
import data.set.lattice
import data.set_like.basic

/-!
# Order intervals

This file defines (nonempty) closed intervals in an order (see `set.Icc`). This is a prototype for
interval arithmetic.

## Main declarations

* `nonempty_interval`: Nonempty intervals. Pairs where the second element is greater than the first.
* `interval`: Intervals. Either `∅` or a nonempty interval.
-/

open function order_dual set

variables {α β γ δ : Type*} {ι : Sort*} {κ : ι → Sort*}

/-- The nonempty closed intervals in an order.

We define intervals by the pair of endpoints `fst`, `snd`. To convert intervals to the set of
elements between these endpoints, use the coercion `nonempty_interval α → set α`. -/
@[ext] structure nonempty_interval (α : Type*) [has_le α] extends α × α :=
(fst_le_snd : fst ≤ snd)

namespace nonempty_interval
section has_le
variables [has_le α] {s t : nonempty_interval α}

lemma to_prod_injective : injective (to_prod : nonempty_interval α → α × α) :=
λ s t, (ext_iff _ _).2

/-- The injection that induces the order on intervals. -/
def to_dual_prod : nonempty_interval α → αᵒᵈ × α := to_prod

@[simp] lemma to_dual_prod_apply (s : nonempty_interval α) :
  s.to_dual_prod = (to_dual s.fst, s.snd) := prod.mk.eta.symm

lemma to_dual_prod_injective : injective (to_dual_prod : nonempty_interval α → αᵒᵈ × α) :=
to_prod_injective

instance [is_empty α] : is_empty (nonempty_interval α) := ⟨λ s, is_empty_elim s.fst⟩
instance [subsingleton α] : subsingleton (nonempty_interval α) :=
to_dual_prod_injective.subsingleton

instance : has_le (nonempty_interval α) := ⟨λ s t, t.fst ≤ s.fst ∧ s.snd ≤ t.snd⟩

lemma le_def : s ≤ t ↔ t.fst ≤ s.fst ∧ s.snd ≤ t.snd := iff.rfl

/-- `to_dual_prod` as an order embedding. -/
@[simps] def to_dual_prod_hom : nonempty_interval α ↪o αᵒᵈ × α :=
{ to_fun := to_dual_prod,
  inj' := to_dual_prod_injective,
  map_rel_iff' := λ _ _, iff.rfl }

/-- Turn an interval into an interval in the dual order. -/
def dual : nonempty_interval α ≃ nonempty_interval αᵒᵈ :=
{ to_fun := λ s, ⟨s.to_prod.swap, s.fst_le_snd⟩,
  inv_fun := λ s, ⟨s.to_prod.swap, s.fst_le_snd⟩,
  left_inv := λ s, ext _ _ $ prod.swap_swap _,
  right_inv := λ s, ext _ _ $ prod.swap_swap _ }

@[simp]

end has_le

section preorder
variables [preorder α] [preorder β] [preorder γ] [preorder δ] {s : nonempty_interval α} {x : α × α}
  {a : α}

instance : preorder (nonempty_interval α) := preorder.lift to_dual_prod

instance : has_coe_t (nonempty_interval α) (set α) := ⟨λ s, Icc s.fst s.snd⟩
@[priority 100] instance : has_mem α (nonempty_interval α) := ⟨λ a s, a ∈ (s : set α)⟩

@[simp] lemma mem_mk {hx : x.1 ≤ x.2} : a ∈ mk x hx ↔ x.1 ≤ a ∧ a ≤ x.2 := iff.rfl
lemma mem_def : a ∈ s ↔ s.fst ≤ a ∧ a ≤ s.snd := iff.rfl

@[simp] lemma coe_nonempty (s : nonempty_interval α) : (s : set α).nonempty :=
nonempty_Icc.2 s.fst_le_snd

/-- `{a}` as an interval. -/
@[simps] def pure (a : α) : nonempty_interval α := ⟨⟨a, a⟩, le_rfl⟩

lemma mem_pure_self (a : α) : a ∈ pure a := ⟨le_rfl, le_rfl⟩

lemma pure_injective : injective (pure : α → nonempty_interval α) :=
λ s t, congr_arg $ prod.fst ∘ to_prod

@[simp] lemma dual_pure (a : α) : (pure a).dual = pure (to_dual a) := rfl

instance [inhabited α] : inhabited (nonempty_interval α) := ⟨pure default⟩
instance : ∀ [nonempty α], nonempty (nonempty_interval α) := nonempty.map pure
instance [nontrivial α] : nontrivial (nonempty_interval α) := pure_injective.nontrivial

/-- Pushforward of nonempty intervals. -/
@[simps] def map (f : α →o β) (a : nonempty_interval α) : nonempty_interval β :=
⟨a.to_prod.map f f, f.mono a.fst_le_snd⟩

@[simp] lemma map_pure (f : α →o β) (a : α) : (pure a).map f = pure (f a) := rfl
@[simp] lemma map_map (g : β →o γ) (f : α →o β) (a : nonempty_interval α) :
  (a.map f).map g = a.map (g.comp f) := rfl

@[simp] lemma dual_map (f : α →o β) (a : nonempty_interval α) :
  (a.map f).dual = a.dual.map f.dual := rfl

/-- Binary pushforward of nonempty intervals. -/
@[simps]
def map₂ (f : α → β → γ) (h₀ : ∀ b, monotone (λ a, f a b)) (h₁ : ∀ a, monotone (f a)) :
  nonempty_interval α → nonempty_interval β → nonempty_interval γ :=
λ s t, ⟨(f s.fst t.fst, f s.snd t.snd), (h₀ _ s.fst_le_snd).trans $ h₁ _ t.fst_le_snd⟩

@[simp] lemma map₂_pure (f : α → β → γ) (h₀ h₁) (a : α) (b : β) :
  map₂ f h₀ h₁ (pure a) (pure b) = pure (f a b) := rfl

@[simp] lemma dual_map₂ (f : α → β → γ) (h₀ h₁ s t) :
  (map₂ f h₀ h₁ s t).dual = map₂ (λ a b, to_dual $ f (of_dual a) $ of_dual b)
    (λ _, (h₀ _).dual) (λ _, (h₁ _).dual) s.dual t.dual := rfl

variables [bounded_order α]

instance : order_top (nonempty_interval α) :=
{ top := ⟨⟨⊥, ⊤⟩, bot_le⟩,
  le_top := λ a, ⟨bot_le, le_top⟩ }

@[simp] lemma dual_top : (⊤ : nonempty_interval α).dual = ⊤ := rfl

end preorder

section partial_order
variables [partial_order α] [partial_order β] {s t : nonempty_interval α} {x : α × α} {a b : α}

instance : partial_order (nonempty_interval α) := partial_order.lift _ to_dual_prod_injective

/-- Consider a nonempty interval `[a, b]` as the set `[a, b]`. -/
def coe_hom : nonempty_interval α ↪o set α :=
order_embedding.of_map_le_iff (λ s, Icc s.fst s.snd) (λ s t, Icc_subset_Icc_iff s.fst_le_snd)

instance : set_like (nonempty_interval α) α :=
{ coe := λ s, Icc s.fst s.snd,
  coe_injective' := coe_hom.injective }

@[simp, norm_cast] lemma coe_subset_coe : (s : set α) ⊆ t ↔ s ≤ t := (@coe_hom α _).le_iff_le
@[simp, norm_cast] lemma coe_ssubset_coe : (s : set α) ⊂ t ↔ s < t := (@coe_hom α _).lt_iff_lt

@[simp] lemma coe_coe_hom : (coe_hom : nonempty_interval α → set α) = coe := rfl

@[simp, norm_cast] lemma coe_pure (a : α) : (pure a : set α) = {a} := Icc_self _

@[simp] lemma mem_pure : b ∈ pure a ↔ b = a :=
by rw [←set_like.mem_coe, coe_pure, mem_singleton_iff]

@[simp, norm_cast]
lemma coe_top [bounded_order α] : ((⊤ : nonempty_interval α) : set α) = univ := Icc_bot_top

@[simp, norm_cast]
lemma coe_dual (s : nonempty_interval α) : (s.dual : set αᵒᵈ) = of_dual ⁻¹' s := dual_Icc

lemma subset_coe_map (f : α →o β) (s : nonempty_interval α) : f '' s ⊆ s.map f :=
image_subset_iff.2 $ λ a ha, ⟨f.mono ha.1, f.mono ha.2⟩

end partial_order

section lattice
variables [lattice α]

instance : has_sup (nonempty_interval α) :=
⟨λ s t, ⟨⟨s.fst ⊓ t.fst, s.snd ⊔ t.snd⟩, inf_le_left.trans $ s.fst_le_snd.trans le_sup_left⟩⟩

instance : semilattice_sup (nonempty_interval α) :=
to_dual_prod_injective.semilattice_sup _ $ λ _ _, rfl

@[simp] lemma fst_sup (s t : nonempty_interval α) : (s ⊔ t).fst = s.fst ⊓ t.fst := rfl
@[simp] lemma snd_sup (s t : nonempty_interval α) : (s ⊔ t).snd = s.snd ⊔ t.snd := rfl

end lattice
end nonempty_interval

/-- The closed intervals in an order.

We represent intervals either as `⊥` or a nonempty interval given by its endpoints `fst`, `snd`.
To convert intervals to the set of elements between these endpoints, use the coercion
`interval α → set α`. -/
@[derive [inhabited, has_le, order_bot]]
def interval (α : Type*) [has_le α] := with_bot (nonempty_interval α)

namespace interval
section has_le
variables [has_le α] {s t : interval α}

instance : has_coe_t (nonempty_interval α) (interval α) := with_bot.has_coe_t
instance can_lift : can_lift (interval α) (nonempty_interval α) coe (λ r, r ≠ ⊥) :=
with_bot.can_lift

lemma coe_injective : injective (coe : nonempty_interval α → interval α) := with_bot.coe_injective
@[simp, norm_cast] lemma coe_inj {s t : nonempty_interval α} : (s : interval α) = t ↔ s = t :=
with_bot.coe_inj

@[protected] lemma «forall» {p : interval α → Prop} :
  (∀ s, p s) ↔ p ⊥ ∧ ∀ s : nonempty_interval α, p s := option.forall
@[protected] lemma «exists» {p : interval α → Prop} :
  (∃ s, p s) ↔ p ⊥ ∨ ∃ s : nonempty_interval α, p s := option.exists

instance [is_empty α] : unique (interval α) := option.unique

/-- Turn an interval into an interval in the dual order. -/
def dual : interval α ≃ interval αᵒᵈ := nonempty_interval.dual.option_congr

end has_le

section preorder
variables [preorder α] [preorder β] [preorder γ]

instance : preorder (interval α) := with_bot.preorder

/-- `{a}` as an interval. -/
def pure (a : α) : interval α := nonempty_interval.pure a

lemma pure_injective : injective (pure : α → interval α) :=
coe_injective.comp nonempty_interval.pure_injective

@[simp] lemma dual_pure (a : α) : (pure a).dual = pure (to_dual a) := rfl
@[simp] lemma dual_bot : (⊥ : interval α).dual = ⊥ := rfl
@[simp] lemma pure_ne_bot {a : α} : pure a ≠ ⊥ := with_bot.coe_ne_bot
@[simp] lemma bot_ne_pure {a : α} : ⊥ ≠ pure a := with_bot.bot_ne_coe

instance [nonempty α] : nontrivial (interval α) := option.nontrivial

/-- Pushforward of intervals. -/
def map (f : α →o β) : interval α → interval β := with_bot.map (nonempty_interval.map f)

@[simp] lemma map_pure (f : α →o β) (a : α) : (pure a).map f = pure (f a) := rfl
@[simp] lemma map_map (g : β →o γ) (f : α →o β) (s : interval α) :
  (s.map f).map g = s.map (g.comp f) := option.map_map _ _ _

@[simp] lemma dual_map (f : α →o β) (s : interval α) : (s.map f).dual = s.dual.map f.dual :=
by { cases s, { refl }, { exact with_bot.map_comm rfl _ } }

variables [bounded_order α]

instance : bounded_order (interval α) := with_bot.bounded_order

@[simp] lemma dual_top : (⊤ : interval α).dual = ⊤ := rfl

end preorder

section partial_order
variables [partial_order α] [partial_order β] {s t : interval α} {a b : α}

instance : partial_order (interval α) := with_bot.partial_order

/-- Consider a interval `[a, b]` as the set `[a, b]`. -/
def coe_hom : interval α ↪o set α :=
order_embedding.of_map_le_iff (λ s, match s with
    | ⊥ := ∅
    | some s := s
  end) (λ s t, match s, t with
  | ⊥, t := iff_of_true bot_le bot_le
  | some s, ⊥ := iff_of_false (λ h, s.coe_nonempty.ne_empty $ le_bot_iff.1 h)
                   (with_bot.not_coe_le_bot _)
  | some s, some t := (@nonempty_interval.coe_hom α _).le_iff_le.trans with_bot.some_le_some.symm
  end)

instance : set_like (interval α) α :=
{ coe := coe_hom,
  coe_injective' := coe_hom.injective }

@[simp, norm_cast] lemma coe_subset_coe : (s : set α) ⊆ t ↔ s ≤ t := (@coe_hom α _).le_iff_le
@[simp, norm_cast] lemma coe_ssubset_coe : (s : set α) ⊂ t ↔ s < t := (@coe_hom α _).lt_iff_lt
@[simp, norm_cast] lemma coe_pure (a : α) : (pure a : set α) = {a} := Icc_self _
@[simp, norm_cast] lemma coe_coe (s : nonempty_interval α) : ((s : interval α) : set α) = s := rfl
@[simp, norm_cast] lemma coe_bot : ((⊥  : interval α) : set α) = ∅ := rfl
@[simp, norm_cast] lemma coe_top [bounded_order α] : ((⊤ : interval α) : set α) = univ :=
Icc_bot_top
@[simp, norm_cast] lemma coe_dual (s : interval α) : (s.dual : set αᵒᵈ) = of_dual ⁻¹' s :=
by { cases s, { refl }, exact s.coe_dual }

lemma subset_coe_map (f : α →o β) : ∀ s : interval α, f '' s ⊆ s.map f
| ⊥ := by simp
| (s : nonempty_interval α) := s.subset_coe_map _

@[simp] lemma mem_pure : b ∈ pure a ↔ b = a :=
by rw [←set_like.mem_coe, coe_pure, mem_singleton_iff]
lemma mem_pure_self (a : α) : a ∈ pure a := mem_pure.2 rfl

end partial_order

section lattice
variables [lattice α]

instance : semilattice_sup (interval α) := with_bot.semilattice_sup

section decidable
variables [@decidable_rel α (≤)]

instance : lattice (interval α) :=
{ inf := λ s t, match s, t with
    | ⊥, t := ⊥
    | s, ⊥ := ⊥
    | some s, some t := if h : s.fst ≤ t.snd ∧ t.fst ≤ s.snd then some
      ⟨⟨s.fst ⊔ t.fst, s.snd ⊓ t.snd⟩, sup_le (le_inf s.fst_le_snd h.1) $ le_inf h.2 t.fst_le_snd⟩
      else ⊥
  end,
  inf_le_left := λ s t, match s, t with
    | ⊥, ⊥ := bot_le
    | ⊥, some t := bot_le
    | some s, ⊥ := bot_le
    | some s, some t := begin
      change dite _ _ _ ≤ _,
      split_ifs,
      { exact with_bot.some_le_some.2 ⟨le_sup_left, inf_le_left⟩ },
      { exact bot_le }
    end
  end,
  inf_le_right := λ s t, match s, t with
    | ⊥, ⊥ := bot_le
    | ⊥, some t := bot_le
    | some s, ⊥ := bot_le
    | some s, some t := begin
      change dite _ _ _ ≤ _,
      split_ifs,
      { exact with_bot.some_le_some.2 ⟨le_sup_right, inf_le_right⟩ },
      { exact bot_le }
    end
  end,
  le_inf := λ s t c, match s, t, c with
    | ⊥, t, c := λ _ _, bot_le
    | some s, t, c := λ hb hc, begin
      lift t to nonempty_interval α using ne_bot_of_le_ne_bot with_bot.coe_ne_bot hb,
      lift c to nonempty_interval α using ne_bot_of_le_ne_bot with_bot.coe_ne_bot hc,
      change _ ≤ dite _ _ _,
      simp only [with_bot.some_eq_coe, with_bot.coe_le_coe] at ⊢ hb hc,
      rw [dif_pos, with_bot.coe_le_coe],
      exact ⟨sup_le hb.1 hc.1, le_inf hb.2 hc.2⟩,
      exact ⟨hb.1.trans $ s.fst_le_snd.trans hc.2, hc.1.trans $ s.fst_le_snd.trans hb.2⟩,
    end
  end,
  ..interval.semilattice_sup }

@[simp, norm_cast] lemma coe_inf (s t : interval α) : (↑(s ⊓ t) : set α) = s ∩ t :=
begin
  cases s,
  { rw [with_bot.none_eq_bot, bot_inf_eq],
    exact (empty_inter _).symm },
  cases t,
  { rw [with_bot.none_eq_bot, inf_bot_eq],
    exact (inter_empty _).symm },
  refine (_ : coe (dite _ _ _) = _).trans Icc_inter_Icc.symm,
  split_ifs,
  { refl },
  { exact (Icc_eq_empty $ λ H,
      h ⟨le_sup_left.trans $ H.trans inf_le_right, le_sup_right.trans $ H.trans inf_le_left⟩).symm }
end

end decidable

@[simp, norm_cast]
lemma disjoint_coe (s t : interval α) : disjoint (s : set α) t ↔ disjoint s t :=
begin
  classical,
  rw [disjoint_iff_inf_le, disjoint_iff_inf_le, le_eq_subset, ←coe_subset_coe, coe_inf], refl
end

end lattice
end interval

namespace nonempty_interval
section preorder
variables [preorder α] {s : nonempty_interval α} {a : α}

@[simp, norm_cast] lemma coe_pure_interval (a : α) : (pure a : interval α) = interval.pure a := rfl
@[simp, norm_cast] lemma coe_eq_pure : (s : interval α) = interval.pure a ↔ s = pure a :=
by rw [←interval.coe_inj, coe_pure_interval]

@[simp, norm_cast]
lemma coe_top_interval [bounded_order α] : ((⊤ : nonempty_interval α) : interval α) = ⊤ := rfl

end preorder

@[simp, norm_cast]
lemma mem_coe_interval [partial_order α] {s : nonempty_interval α} {x : α} :
  x ∈ (s : interval α) ↔ x ∈ s := iff.rfl

@[simp, norm_cast] lemma coe_sup_interval [lattice α] (s t : nonempty_interval α) :
  (↑(s ⊔ t) : interval α) = s ⊔ t := rfl

end nonempty_interval

namespace interval
section complete_lattice
variables [complete_lattice α]

noncomputable instance [@decidable_rel α (≤)] : complete_lattice (interval α) :=
by classical; exact { Sup := λ S, if h : S ⊆ {⊥} then ⊥ else some
    ⟨⟨⨅ (s : nonempty_interval α) (h : ↑s ∈ S), s.fst,
      ⨆ (s : nonempty_interval α) (h : ↑s ∈ S), s.snd⟩, begin
        obtain ⟨s, hs, ha⟩ := not_subset.1 h,
        lift s to nonempty_interval α using ha,
        exact infi₂_le_of_le s hs (le_supr₂_of_le s hs s.fst_le_snd)
      end⟩,
  le_Sup := λ s s ha, begin
    split_ifs,
    { exact (h ha).le },
    cases s,
    { exact bot_le },
    { exact with_bot.some_le_some.2 ⟨infi₂_le _ ha, le_supr₂_of_le _ ha le_rfl⟩ }
  end,
  Sup_le := λ s s ha, begin
    split_ifs,
    { exact bot_le },
    obtain ⟨b, hs, hb⟩ := not_subset.1 h,
    lift s to nonempty_interval α using ne_bot_of_le_ne_bot hb (ha _ hs),
    exact with_bot.coe_le_coe.2 ⟨le_infi₂ $ λ c hc, (with_bot.coe_le_coe.1 $ ha _ hc).1,
      supr₂_le $ λ c hc, (with_bot.coe_le_coe.1 $ ha _ hc).2⟩,
  end,
  Inf := λ S, if h : ⊥ ∉ S ∧ ∀ ⦃s : nonempty_interval α⦄, ↑s ∈ S → ∀ ⦃t : nonempty_interval α⦄,
    ↑t ∈ S → s.fst ≤ t.snd then some
      ⟨⟨⨆ (s : nonempty_interval α) (h : ↑s ∈ S), s.fst,
        ⨅ (s : nonempty_interval α) (h : ↑s ∈ S), s.snd⟩,
          supr₂_le $ λ s hs, le_infi₂ $ h.2 hs⟩ else ⊥,
  Inf_le := λ s s ha, begin
    split_ifs,
    { lift s to nonempty_interval α using ne_of_mem_of_not_mem ha h.1,
      exact with_bot.coe_le_coe.2 ⟨le_supr₂ s ha, infi₂_le s ha⟩ },
    { exact bot_le }
  end,
  le_Inf := λ S s ha, begin
    cases s,
    { exact bot_le },
    split_ifs,
    { exact with_bot.some_le_some.2 ⟨supr₂_le $ λ t hb, (with_bot.coe_le_coe.1 $ ha _ hb).1,
        le_infi₂ $ λ t hb, (with_bot.coe_le_coe.1 $ ha _ hb).2⟩ },
    rw [not_and_distrib, not_not] at h,
    cases h,
    { exact ha _ h },
    cases h (λ t hb c hc, (with_bot.coe_le_coe.1 $ ha _ hb).1.trans $ s.fst_le_snd.trans
      (with_bot.coe_le_coe.1 $ ha _ hc).2),
  end,
  ..interval.lattice, ..interval.bounded_order }

@[simp, norm_cast] lemma coe_Inf [@decidable_rel α (≤)] (S : set (interval α)) :
  ↑(Inf S) = ⋂ s ∈ S, (s : set α) :=
begin
  change coe (dite _ _ _) = _,
  split_ifs,
  { ext,
    simp [with_bot.some_eq_coe, interval.forall, h.1, ←forall_and_distrib,
      ←nonempty_interval.mem_def] },
  simp_rw [not_and_distrib, not_not] at h,
  cases h,
  { refine (eq_empty_of_subset_empty _).symm,
    exact Inter₂_subset_of_subset _ h subset.rfl },
  { refine (not_nonempty_iff_eq_empty.1 _).symm,
    rintro ⟨x, hx⟩,
    rw mem_Inter₂ at hx,
    exact h (λ s ha t hb, (hx _ ha).1.trans (hx _ hb).2) }
end

@[simp, norm_cast] lemma coe_infi [@decidable_rel α (≤)] (f : ι → interval α) :
  ↑(⨅ i, f i) = ⋂ i, (f i : set α) :=
by simp [infi]

@[simp, norm_cast] lemma coe_infi₂ [@decidable_rel α (≤)] (f : Π i, κ i → interval α) :
  ↑(⨅ i j, f i j) = ⋂ i j, (f i j : set α) :=
by simp_rw [coe_infi]

end complete_lattice
end interval