{-# OPTIONS --without-K #-}

module Examples.Traced where

open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂; subst; module ≡-Reasoning)

open import Singleton
open import PiFrac
open import Trace
open import Reasoning

open import Examples.BooleanCircuits

------------------------------------------------------------------

-- Example in Sec. 4.3 from Abramsky's paper
-- http://www.cs.ox.ac.uk/files/341/calco05.pdf

q : {A1 A2 A3 A4 B1 B2 B3 B4 : 𝕌} →
  (f1 : A1 ⟷ B2) →
  (f2 : A2 ⟷ B4) →
  (f3 : A3 ⟷ B3) →
  (f4 : A4 ⟷ B1) →
  A1 ×ᵤ (A2 ×ᵤ (A3 ×ᵤ A4)) ⟷ B1 ×ᵤ (B2 ×ᵤ (B3 ×ᵤ B4))
q {A1} {A2} {A3} {A4} {B1} {B2} {B3} {B4} f1 f2 f3 f4 =
  (A1 ×ᵤ A2 ×ᵤ A3 ×ᵤ A4)     ⟷⟨ f1 ⊗ (f2 ⊗ (f3 ⊗ f4)) ⟩
  (B2 ×ᵤ B4 ×ᵤ B3 ×ᵤ B1)     ⟷⟨ assocl⋆ ⟩
  (B2 ×ᵤ B4) ×ᵤ (B3 ×ᵤ B1)   ⟷⟨ swap⋆ ⟩
  (B3 ×ᵤ B1) ×ᵤ (B2 ×ᵤ B4)   ⟷⟨ swap⋆ ⊗ id⟷ ⟩
  (B1 ×ᵤ B3) ×ᵤ (B2 ×ᵤ B4)   ⟷⟨ assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⟩
  B1 ×ᵤ ((B3 ×ᵤ B2) ×ᵤ B4)   ⟷⟨ id⟷ ⊗ ((swap⋆ ⊗ id⟷) ⊚ assocr⋆) ⟩
  B1 ×ᵤ (B2 ×ᵤ (B3 ×ᵤ B4)) □

q' : {A1 U2 U3 U4 B1 : 𝕌} →
  (f1 : A1 ⟷ U2) →
  (f2 : U2 ⟷ U4) →
  (f3 : U3 ⟷ U3) →
  (f4 : U4 ⟷ B1) → (v : ⟦ A1 ⟧) (u3 : ⟦ U3 ⟧)  → (u3-fix : eval f3 u3 ≡ u3) →
  let u2 = eval f1 v in
  let u4 = eval f2 u2 in
  ● A1 [ v ] ⟷ ● B1 [ proj₁ (eval (q f1 f2 f3 f4) (v , u2 , u3 , u4)) ]
q' f1 f2 f3 f4 v u3 u3fix =
  trace v (q f1 f2 f3 f4) (( u2 , ( u3 , u4 ) ), cong₂ _,_ refl (cong₂ _,_ u3fix refl))
  where
    u2 = eval f1 v
    u3′ = eval f3 u3
    u4 = eval f2 u2

-- The point is that q' acts in a very particular way:
q'-closed-form : {A1 U2 U3 U4 B1 : 𝕌} →
  (f1 : A1 ⟷ U2) →
  (f2 : U2 ⟷ U4) →
  (f3 : U3 ⟷ U3) →
  (f4 : U4 ⟷ B1) → (u3 : ⟦ U3 ⟧) (u3-fix : eval f3 u3 ≡ u3) → (v : ⟦ A1 ⟧) →
  proj₁ (eval (q' f1 f2 f3 f4 v u3 u3-fix) (v , refl)) ≡ eval (f1 ⊚ f2 ⊚ f4) v
q'-closed-form f1 f2 f3 f4 u3 u3fix v = refl

---------------------------------------------------------------------------------
-- I think the examples below are 'obsolete', in the sense that the one above
-- is more faithful to the original, and more general too.  Delete?
p : {A1 A2 A3 A4 : 𝕌} →
    (A1 ×ᵤ A2) ×ᵤ (A3 ×ᵤ A4) ⟷ (A2 ×ᵤ A4) ×ᵤ (A3 ×ᵤ A1)
p = (swap⋆ ⊗ swap⋆) ⊚
       assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⊚ (id⟷ ⊗ (swap⋆ ⊗ id⟷)) ⊚
       (id⟷ ⊗ assocr⋆) ⊚ assocl⋆ ⊚ (id⟷ ⊗ swap⋆)

p' : {A1 A2 A3 A4 : 𝕌} →
    ((A1 ×ᵤ A2) ×ᵤ A4) ×ᵤ A3 ⟷ ((A2 ×ᵤ A4) ×ᵤ A1) ×ᵤ A3
p' = assocr⋆ ⊚ (id⟷ ⊗ swap⋆) ⊚ p ⊚ (id⟷ ⊗ swap⋆) ⊚ assocl⋆

p2 : 𝔹 ×ᵤ (𝔹 ×ᵤ (𝔹 ×ᵤ 𝔹)) ⟷ 𝔹 ×ᵤ (𝔹 ×ᵤ (𝔹 ×ᵤ 𝔹))
p2 = assocl⋆ ⊚ (swap⋆ ⊗ swap⋆) ⊚
       assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⊚ (id⟷ ⊗ (swap⋆ ⊗ id⟷)) ⊚
       (id⟷ ⊗ assocr⋆) ⊚ assocl⋆ ⊚ (id⟷ ⊗ swap⋆) ⊚ assocr⋆

p2' : (v : ⟦ 𝔹 ⟧) →
      ● 𝔹 [ v ] ⟷ ● 𝔹 [ proj₁ (proj₁ (eval p ((v , v) , (v , v)))) ]
p2' v = trace v p2 ((v , (v , v)) , refl)

---------------------------------------------------------------------------------
-- Examples inspired by compact closed categories and fractional numbers.

-- Intuition:
-- 1/A x B is a space transformer; takes A space and returns B space
-- denote space transformers as A ⊸ B

-- Best we can do:
-- we need Singletons, so |a ⊸ b| is 1 component of a function.

_⊸_ : {A : 𝕌} → (a : ⟦ A ⟧) → {B : 𝕌} → (b : ⟦ B ⟧) → 𝕌
_⊸_ {A} a {B} b = 𝟙/● A [ a ] ×ᵤ ● B [ b ]

id⊸ : {A : 𝕌} {a : ⟦ A ⟧} → (a ⊸ a) ⟷ 𝟙
id⊸ {A} {a} =
  (𝟙/● A [ a ] ×ᵤ ● A [ a ]) ⟷⟨ swap⋆ ⟩
  (● A [ a ] ×ᵤ 𝟙/● A [ a ]) ⟷⟨ ε a ⟩
  𝟙 □

comp⊸ : {A B C : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧} →
        (a ⊸ b) ×ᵤ (b ⊸ c) ⟷ (a ⊸ c)
comp⊸ {A} {B} {C} {a} {b} {c} =
  (𝟙/● A [ a ] ×ᵤ ● B [ b ]) ×ᵤ (𝟙/● B [ b ] ×ᵤ ● C [ c ]) ⟷⟨ assocr⋆ ⟩
  𝟙/● A [ a ] ×ᵤ (● B [ b ] ×ᵤ (𝟙/● B [ b ] ×ᵤ ● C [ c ])) ⟷⟨ id⟷ ⊗ assocl⋆ ⟩
  𝟙/● A [ a ] ×ᵤ (● B [ b ] ×ᵤ 𝟙/● B [ b ]) ×ᵤ ● C [ c ]   ⟷⟨ id⟷ ⊗ (ε b ⊗ id⟷) ⟩
  𝟙/● A [ a ] ×ᵤ (𝟙 ×ᵤ ● C [ c ])                          ⟷⟨ id⟷ ⊗ unite⋆l ⟩
  𝟙/● A [ a ] ×ᵤ ● C [ c ] □

app : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} → (a ⊸ b) ×ᵤ ● A [ a ] ⟷ ● B [ b ]
app {A} {B} {a} {b} =
  (𝟙/● A [ a ] ×ᵤ ● B [ b ]) ×ᵤ ● A [ a ] ⟷⟨ swap⋆ ⊗ id⟷ ⟩
  (● B [ b ] ×ᵤ 𝟙/● A [ a ]) ×ᵤ ● A [ a ] ⟷⟨ assocr⋆ ⊚ (id⟷ ⊗ (swap⋆ ⊚ ε a)) ⟩
  ● B [ b ] ×ᵤ 𝟙                          ⟷⟨ unite⋆r ⟩
  ● B [ b ] □

-- B/A × D/C ⟷ B × D / A × C
dist×/ : {A B C D : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧} {d : ⟦ D ⟧}
       → (a ⊸ b) ×ᵤ (c ⊸ d) ⟷ ((a , c) ⊸ (b , d))
dist×/ {A} {B} {C} {D} {a} {b} {c} {d} =
  (𝟙/● A [ a ] ×ᵤ ● B [ b ]) ×ᵤ (𝟙/● C [ c ] ×ᵤ ● D [ d ]) ⟷⟨ assocr⋆ ⊚ (id⟷ ⊗ assocl⋆) ⟩
  (𝟙/● A [ a ] ×ᵤ (● B [ b ] ×ᵤ 𝟙/● C [ c ]) ×ᵤ ● D [ d ]) ⟷⟨ id⟷ ⊗ (swap⋆ ⊗ id⟷) ⟩
  (𝟙/● A [ a ] ×ᵤ (𝟙/● C [ c ] ×ᵤ ● B [ b ]) ×ᵤ ● D [ d ]) ⟷⟨ (id⟷ ⊗ assocr⋆) ⊚ assocl⋆ ⟩
  (𝟙/● A [ a ] ×ᵤ 𝟙/● C [ c ]) ×ᵤ (● B [ b ] ×ᵤ ● D [ d ]) ⟷⟨ fracr ⊗ tensorr ⟩
  (𝟙/● A ×ᵤ C [ a , c ]) ×ᵤ (● B ×ᵤ D [ b , d ]) □

-- 1/A x 1/B <-> 1 / (A x B)
rev× : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧}
     → (a ⊸ tt) ×ᵤ (b ⊸ tt) ⟷ ((a , b) ⊸ tt)
rev× {A} {B} {a} {b} =
  (𝟙/● A [ a ] ×ᵤ ● 𝟙 [ tt ]) ×ᵤ (𝟙/● B [ b ] ×ᵤ ● 𝟙 [ tt ]) ⟷⟨ dist×/ ⟩
  (𝟙/● A ×ᵤ B [ a , b ] ×ᵤ ● 𝟙 ×ᵤ 𝟙 [ tt , tt ]) ⟷⟨ id⟷ ⊗ lift unite⋆l ⟩
  (𝟙/● A ×ᵤ B [ a , b ] ×ᵤ ● 𝟙 [ tt ]) □

{--
trivial : ● 𝟙 [ tt ] ⟷ 𝟙
trivial = {!!}
--}

-- (A <-> B) -> (1/A <-> 1/B)
--rev : {A B : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧}
--     → ● A [ a ] ⟷ ● B [ b ] → (b ⊸ tt) ⟷ (a ⊸ tt)
--  (𝟙/● A [ a ] ×ᵤ ● 𝟙 [ tt ]) ⟷⟨ {!!} ⟩
--  (𝟙/● B [ b ] ×ᵤ ● 𝟙 [ tt ]) □

rev : {A B : 𝕌} {a : ⟦ A ⟧}
     → (f : A ⟷ B) → (𝟙/● B [ eval f a ] ⟷ 𝟙/● A [ a ])
rev {A} {B} {a} f = dual f a

-- A <-> 1 / (1/A)
revrev : {A : 𝕌} {a : ⟦ A ⟧} {a⋆ : ⟦ 𝟙/● A [ a ] ⟧} →
         ● A [ a ] ⟷ 𝟙/● (𝟙/● A [ a ]) [ a⋆ ]
revrev {A} {a} {a⋆} =
  ● A [ a ] ⟷⟨ uniti⋆r ⟩
  ● A [ a ] ×ᵤ 𝟙 ⟷⟨ {!id⟷ ⊗ η a⋆!} ⟩
  ● A [ a ] ×ᵤ (𝟙/● A [ a ] ×ᵤ 𝟙/● (𝟙/● A [ a ]) [ a⋆ ]) ⟷⟨ {!!} ⟩
  𝟙/● (𝟙/● A [ a ]) [ a⋆ ] □

-- this is strange
-- A/C + B/C <-> (A + B) / C
-- factor+/l : {A B C : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧}
--           → (c ⊸ a) +ᵤ (c ⊸ b) ⟷ (_⊸_ {C} c {A +ᵤ B} (inj₁ a))
-- factor+/l {A} {B} {C} {a} {b} {c} =
--   (𝟙/● C [ c ] ×ᵤ ● A [ a ] +ᵤ 𝟙/● C [ c ] ×ᵤ ● B [ b ]) ⟷⟨ factorl ⟩
--   (𝟙/● C [ c ] ×ᵤ (● A [ a ] +ᵤ ● B [ b ])) ⟷⟨ id⟷ ⊗ {!!} ⟩
--   (𝟙/● C [ c ] ×ᵤ ● A +ᵤ B [ inj₁ a ]) □

-- same issue here with the +
-- A/B + C/D <-> (A x D + B x C) / (B x D)

-- SAT solver Sec. 5 from https://www.cs.indiana.edu/~sabry/papers/rational.pdf

-- can we do this?
-- curry⊸ : {A B C : 𝕌} {a : ⟦ A ⟧} {b : ⟦ B ⟧} {c : ⟦ C ⟧}
--        → (● A [ a ] ×ᵤ (b ⊸ c)) ⟷ (a ⊸ {!!}) -- what do we put here?
-- curry⊸ {A} {B} {C} {a} {b} {c} = {!!}


{-# OPTIONS --without-K --rewriting #-}

open import lib.Basics
open import lib.types.Bool
open import lib.types.FunctionSeq
open import lib.types.Pointed
open import lib.types.Suspension.Core
open import lib.types.Suspension.Iterated
open import lib.types.Suspension.Trunc
open import lib.types.TLevel
open import lib.types.Truncation

module lib.types.Suspension.IteratedTrunc where

module _ {i} (A : Type i) (m : ℕ₋₂) where

  Susp^-Trunc-swap : ∀ (n : ℕ)
    → Susp^ n (Trunc m A)
    → Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n A)
  Susp^-Trunc-swap O = idf _
  Susp^-Trunc-swap (S n) =
    Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m) ∘
    Susp-fmap (Susp^-Trunc-swap n)

  private
    to : ∀ n → Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n (Trunc m A)) → Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n A)
    to n = Trunc-rec {{Trunc-level}} (Susp^-Trunc-swap n)

    from : ∀ n → Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n A) → Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n (Trunc m A))
    from n = Trunc-fmap (Susp^-fmap n [_])

    abstract
      from-Susp^-Trunc-swap : ∀ n → from n ∘ Susp^-Trunc-swap n ∼ [_]
      from-Susp^-Trunc-swap O =
        Trunc-elim
          {P = λ s → from 0 (Susp^-Trunc-swap 0 s) == [ s ]}
          {{λ s → =-preserves-level Trunc-level}}
          (λ a → idp)
      from-Susp^-Trunc-swap (S n) x =
        (from (S n) $
         Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m) $
         Susp-fmap (Susp^-Trunc-swap n) x)
          =⟨ ! $ Susp-Trunc-swap-natural (Susp^-fmap n [_]) (⟨ n ⟩₋₂ +2+ m) $
             Susp-fmap (Susp^-Trunc-swap n) x ⟩
        (Susp-Trunc-swap (Susp^ n (Trunc m A)) (⟨ n ⟩₋₂ +2+ m) $
         Susp-fmap (Trunc-fmap (Susp^-fmap n [_])) $
         Susp-fmap (Susp^-Trunc-swap n) x)
          =⟨ ap (Susp-Trunc-swap (Susp^ n (Trunc m A)) (⟨ n ⟩₋₂ +2+ m)) $
             ! $ Susp-fmap-∘ (Trunc-fmap (Susp^-fmap n [_])) (Susp^-Trunc-swap n) x ⟩
        (Susp-Trunc-swap (Susp^ n (Trunc m A)) (⟨ n ⟩₋₂ +2+ m) $
         Susp-fmap (from n ∘ Susp^-Trunc-swap n) x)
          =⟨ ap (Susp-Trunc-swap (Susp^ n (Trunc m A)) (⟨ n ⟩₋₂ +2+ m)) $
             ap (λ f → Susp-fmap f x) (λ= (from-Susp^-Trunc-swap n)) ⟩
        Susp-Trunc-swap (Susp^ n (Trunc m A)) (⟨ n ⟩₋₂ +2+ m) (Susp-fmap [_] x)
          =⟨ Susp-Trunc-swap-Susp-fmap-trunc (Susp^ n (Trunc m A)) (⟨ n ⟩₋₂ +2+ m) x ⟩
        [ x ] =∎

      from-to : ∀ n → from n ∘ to n ∼ idf _
      from-to n =
        Trunc-elim
          {P = λ t → from n (to n t) == t}
          {{λ t → =-preserves-level Trunc-level}}
          (from-Susp^-Trunc-swap n)

      Susp^-Trunc-swap-Susp^-fmap-trunc : ∀ n →
        Susp^-Trunc-swap n ∘ Susp^-fmap n [_] ∼ [_]
      Susp^-Trunc-swap-Susp^-fmap-trunc 0 s = idp
      Susp^-Trunc-swap-Susp^-fmap-trunc (S n) s =
        (Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m) $
         Susp-fmap (Susp^-Trunc-swap n) $
         Susp^-fmap (S n) [_] s)
          =⟨ ap (Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m)) $
             ! $ Susp-fmap-∘ (Susp^-Trunc-swap n) (Susp^-fmap n [_]) s ⟩
        (Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m) $
         Susp-fmap (Susp^-Trunc-swap n ∘ Susp^-fmap n [_]) s)
          =⟨ ap (Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m)) $
             app= (ap Susp-fmap (λ= (Susp^-Trunc-swap-Susp^-fmap-trunc n))) s ⟩
        Susp-Trunc-swap (Susp^ n A) (⟨ n ⟩₋₂ +2+ m) (Susp-fmap [_] s)
          =⟨ Susp-Trunc-swap-Susp-fmap-trunc (Susp^ n A) (⟨ n ⟩₋₂ +2+ m) s ⟩
        [ s ] =∎

      to-from : ∀ n → to n ∘ from n ∼ idf _
      to-from n = Trunc-elim {{λ t → =-preserves-level Trunc-level}}
                             (Susp^-Trunc-swap-Susp^-fmap-trunc n)

  Susp^-Trunc-equiv : ∀ (n : ℕ)
    → Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n (Trunc m A)) ≃ Trunc (⟨ n ⟩₋₂ +2+ m) (Susp^ n A)
  Susp^-Trunc-equiv n = equiv (to n) (from n) (to-from n) (from-to n)

module _ {i} (X : Ptd i) (m : ℕ₋₂) where

  Susp^-Trunc-swap-pt : ∀ (n : ℕ)
    → Susp^-Trunc-swap (de⊙ X) m n (pt (⊙Susp^ n (⊙Trunc m X))) ==
      pt (⊙Trunc (⟨ n ⟩₋₂ +2+ m) (⊙Susp^ n X))
  Susp^-Trunc-swap-pt O = idp
  Susp^-Trunc-swap-pt (S n) = idp

  ⊙Susp^-Trunc-swap : ∀ (n : ℕ)
    → ⊙Susp^ n (⊙Trunc m X) ⊙→ ⊙Trunc (⟨ n ⟩₋₂ +2+ m) (⊙Susp^ n X)
  ⊙Susp^-Trunc-swap n = Susp^-Trunc-swap (de⊙ X) m n , Susp^-Trunc-swap-pt n

  ⊙Susp^-⊙Trunc-equiv : ∀ (n : ℕ)
    → ⊙Trunc (⟨ n ⟩₋₂ +2+ m) (⊙Susp^ n (⊙Trunc m X)) ⊙≃ ⊙Trunc (⟨ n ⟩₋₂ +2+ m) (⊙Susp^ n X)
  ⊙Susp^-⊙Trunc-equiv n =
    ⊙to , snd (Susp^-Trunc-equiv (de⊙ X) m n)
    where
    ⊙to : ⊙Trunc (⟨ n ⟩₋₂ +2+ m) (⊙Susp^ n (⊙Trunc m X))
       ⊙→ ⊙Trunc (⟨ n ⟩₋₂ +2+ m) (⊙Susp^ n X)
    ⊙to = ⊙Trunc-rec {{Trunc-level}} (⊙Susp^-Trunc-swap n)

module _ {i} {X Y : Ptd i} (f : X ⊙→ Y) (m : ℕ₋₂) where

  ⊙Susp^-Trunc-swap-natural : ∀ (n : ℕ)
    → ⊙Susp^-Trunc-swap Y m n ◃⊙∘
      ⊙Susp^-fmap n (⊙Trunc-fmap f) ◃⊙idf
      =⊙∘
      ⊙Trunc-fmap (⊙Susp^-fmap n f) ◃⊙∘
      ⊙Susp^-Trunc-swap X m n ◃⊙idf
  ⊙Susp^-Trunc-swap-natural O = =⊙∘-in (⊙λ= (⊙∘-unit-l _))
  ⊙Susp^-Trunc-swap-natural (S n) =
    ⊙Susp^-Trunc-swap Y m (S n) ◃⊙∘
    ⊙Susp^-fmap (S n) (⊙Trunc-fmap f) ◃⊙idf
      =⊙∘⟨ 0 & 1 & ⊙expand $
           ⊙Susp-Trunc-swap (Susp^ n (de⊙ Y)) (⟨ n ⟩₋₂ +2+ m) ◃⊙∘
           ⊙Susp-fmap (Susp^-Trunc-swap (de⊙ Y) m n) ◃⊙idf ⟩
    ⊙Susp-Trunc-swap (Susp^ n (de⊙ Y)) (⟨ n ⟩₋₂ +2+ m) ◃⊙∘
    ⊙Susp-fmap (Susp^-Trunc-swap (de⊙ Y) m n) ◃⊙∘
    ⊙Susp^-fmap (S n) (⊙Trunc-fmap f) ◃⊙idf
      =⊙∘⟨ 1 & 2 & ⊙Susp-fmap-seq-=⊙∘ $
           de⊙-seq-=⊙∘ $ ⊙Susp^-Trunc-swap-natural n ⟩
    ⊙Susp-Trunc-swap (Susp^ n (de⊙ Y)) (⟨ n ⟩₋₂ +2+ m) ◃⊙∘
    ⊙Susp-fmap (Trunc-fmap (Susp^-fmap n (fst f))) ◃⊙∘
    ⊙Susp-fmap (Susp^-Trunc-swap (de⊙ X) m n) ◃⊙idf
      =⊙∘⟨ 0 & 2 & =⊙∘-in
           {gs = ⊙Trunc-fmap (⊙Susp-fmap (Susp^-fmap n (fst f))) ◃⊙∘
                 ⊙Susp-Trunc-swap (Susp^ n (de⊙ X)) (⟨ n ⟩₋₂ +2+ m) ◃⊙idf} $
           ⊙Susp-Trunc-swap-natural (Susp^-fmap n (fst f)) (⟨ n ⟩₋₂ +2+ m) ⟩
    ⊙Trunc-fmap (⊙Susp-fmap (Susp^-fmap n (fst f))) ◃⊙∘
    ⊙Susp-Trunc-swap (Susp^ n (de⊙ X)) (⟨ n ⟩₋₂ +2+ m) ◃⊙∘
    ⊙Susp-fmap (Susp^-Trunc-swap (de⊙ X) m n) ◃⊙idf
      =⊙∘⟨ 1 & 2 & ⊙contract ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap (S n) f) ◃⊙∘
    ⊙Susp^-Trunc-swap X m (S n) ◃⊙idf ∎⊙∘

  ⊙Susp^-⊙Trunc-equiv-natural : ∀ (n : ℕ)
    → ⊙–> (⊙Susp^-⊙Trunc-equiv Y m n) ◃⊙∘
      ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Trunc-fmap f)) ◃⊙idf
      =⊙∘
      ⊙Trunc-fmap (⊙Susp^-fmap n f) ◃⊙∘
      ⊙–> (⊙Susp^-⊙Trunc-equiv X m n) ◃⊙idf
  ⊙Susp^-⊙Trunc-equiv-natural n = =⊙∘-in $
    ⊙–> (⊙Susp^-⊙Trunc-equiv Y m n) ⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Trunc-fmap f))
      =⟨ ⊙Trunc-rec-⊙Trunc-fmap {{Trunc-level}}
           (⊙Susp^-Trunc-swap Y m n)
           (⊙Susp^-fmap n (⊙Trunc-fmap f)) ⟩
    ⊙Trunc-rec {{Trunc-level}} (⊙Susp^-Trunc-swap Y m n ⊙∘ ⊙Susp^-fmap n (⊙Trunc-fmap f))
      =⟨ ap (⊙Trunc-rec {{Trunc-level}}) $
         =⊙∘-out $ ⊙Susp^-Trunc-swap-natural n ⟩
    ⊙Trunc-rec {{Trunc-level}} (⊙Trunc-fmap (⊙Susp^-fmap n f) ⊙∘ ⊙Susp^-Trunc-swap X m n)
      =⟨ ⊙Trunc-rec-post-⊙∘ {{Trunc-level}} {{Trunc-level}}
           (⊙Trunc-fmap (⊙Susp^-fmap n f))
           (⊙Susp^-Trunc-swap X m n) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n f) ⊙∘ ⊙–> (⊙Susp^-⊙Trunc-equiv X m n) =∎

  ⊙Susp^-⊙Trunc-equiv-natural' : ∀ (n : ℕ)
    → ⊙<– (⊙Susp^-⊙Trunc-equiv Y m n) ◃⊙∘
      ⊙Trunc-fmap (⊙Susp^-fmap n f) ◃⊙idf
      =⊙∘
      ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Trunc-fmap f)) ◃⊙∘
      ⊙<– (⊙Susp^-⊙Trunc-equiv X m n) ◃⊙idf
  ⊙Susp^-⊙Trunc-equiv-natural' n =
    ⊙<– (⊙Susp^-⊙Trunc-equiv Y m n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n f) ◃⊙idf
      =⊙∘⟨ 2 & 0 & !⊙∘ $ ⊙<–-inv-r-=⊙∘ (⊙Susp^-⊙Trunc-equiv X m n) ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv Y m n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n f) ◃⊙∘
    ⊙–> (⊙Susp^-⊙Trunc-equiv X m n) ◃⊙∘
    ⊙<– (⊙Susp^-⊙Trunc-equiv X m n) ◃⊙idf
      =⊙∘⟨ 1 & 2 & !⊙∘ $ ⊙Susp^-⊙Trunc-equiv-natural n ⟩
    ⊙<– (⊙Susp^-⊙Trunc-equiv Y m n) ◃⊙∘
    ⊙–> (⊙Susp^-⊙Trunc-equiv Y m n) ◃⊙∘
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Trunc-fmap f)) ◃⊙∘
    ⊙<– (⊙Susp^-⊙Trunc-equiv X m n) ◃⊙idf
      =⊙∘⟨ 0 & 2 & ⊙<–-inv-l-=⊙∘ (⊙Susp^-⊙Trunc-equiv Y m n) ⟩
    ⊙Trunc-fmap (⊙Susp^-fmap n (⊙Trunc-fmap f)) ◃⊙∘
    ⊙<– (⊙Susp^-⊙Trunc-equiv X m n) ◃⊙idf ∎⊙∘


-- Σ type (also used as existential) and
-- cartesian product (also used as conjunction).

{-# OPTIONS --without-K --safe #-}

module Tools.Product where

open import Data.Product public using (Σ; ∃; ∃₂; _×_; _,_; proj₁; proj₂)


{-

The goal of this file is to prove the iso π₄S³≅ℤ/β
where β is a natural number (aka "the Brunerie number",
defined below).

-}
{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Homotopy.Group.Pi4S3.BrunerieNumber where

open import Cubical.Homotopy.Loopspace
open import Cubical.Homotopy.Group.Base
open import Cubical.Homotopy.HopfInvariant.Base
open import Cubical.Homotopy.Group.Pi3S2
open import Cubical.Homotopy.Group.PinSn
open import Cubical.Homotopy.BlakersMassey
open import Cubical.Homotopy.Whitehead
open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.Group.LES
open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2
open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv

open import Cubical.Data.Unit
open import Cubical.Data.Sigma
open import Cubical.Data.Nat
open import Cubical.Data.Int
  renaming (ℤ to Z ; _·_ to _·Z_ ; _+_ to _+Z_)

open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.Wedge
open import Cubical.HITs.Pushout
open import Cubical.HITs.PropositionalTruncation
  renaming (rec to pRec ; elim to pElim ; map to pMap)
open import Cubical.HITs.SetTruncation
  renaming (rec to sRec ; rec2 to sRec2
          ; elim to sElim ; elim2 to sElim2 ; elim3 to sElim3
          ; map to sMap)
open import Cubical.HITs.Truncation renaming
  (rec to trRec ; elim to trElim ; elim2 to trElim2 ; map to trMap)

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Exact
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Instances.IntMod
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Unit
open import Cubical.Algebra.Group.GroupPath

open Iso
open Exact4

-- The Brunerie number (see Corollary 3.4.5 in Brunerie's PhD thesis)
Brunerie : ℕ
Brunerie =
  abs (HopfInvariant-π' 0  [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π')

-- First we need to define the following maps.
W : S₊ 3 → (S₊∙ 2 ⋁ S₊∙ 2)
W = joinTo⋁ {A = S₊∙ 1} {B = S₊∙ 1} ∘ Iso.inv (IsoSphereJoin 1 1)

fold∘W : S₊ 3 → S₊ 2
fold∘W = fold⋁ ∘ W

{-
We will now instantiate Blakers Massey to get a square:

         fold∘W
 S³ --------------> S²
 |\              ↗ |
 |  \         ↗    |
 |    \    ↗       |
 |      X           |  inr
 |    /             |
 |   /              |
 |  /               |
 v /                v
 1 -----------> coFib fold∘W
         inl

where X is the pullback of inl and inr and the map S³ → X is
surjective on π₃. This will give us a sequence
π₃ S³ --ᶠ→ π₃ S² → π₃ (coFib fold∘W) → π₂ X ≅ 0, where f is
the function induced by fold∘W. From this, we can deduce that
π₃ (coFib fold∘W) ≅ ℤ/ f(1) where f(1) is interpreted as an
integer via the isos π₃ S³ ≅ π₃ S² ≅ ℤ

(Recall that π₃(coFib fold∘W) ≅ π₄S³)

For clarity:
X, above will have two names (via a trivial iso) below:

TotalPushoutPath× (the version the falls out of BM)
P = fiber inr (Same name as in Brunerie's prop 4.3.4.)
-}

-- Before instantiating, we need to show that
-- any map S³ → S² is 0-connected
isConnectedS3→S2 : (f : S₊ 3 → S₊ 2) → isConnectedFun 2 f
isConnectedS3→S2 f p =
  trRec (isProp→isOfHLevelSuc 1 isPropIsContr)
    (J (λ p _ → isConnected 2 (fiber f p))
      (∣ north , refl ∣
     , (trElim (λ _ → isOfHLevelPath 2 (isOfHLevelTrunc 2) _ _)
         (uncurry
           (sphereElim 2
             (λ _ → isOfHLevelΠ 3
               λ _ → isOfHLevelPath 3
                 (isOfHLevelSuc 2 (isOfHLevelTrunc 2)) _ _)
           λ p → trRec (isOfHLevelTrunc 2 _ _)
             (λ r → cong ∣_∣ₕ (ΣPathP (refl , r)))
            (fun (PathIdTruncIso 1)
              (isContr→isProp
                (isConnectedPath 2 (sphereConnected 2)
                  (f north) (f north)) ∣ refl ∣ ∣ p ∣)))))))
    (fun (PathIdTruncIso 2)
      (isContr→isProp (sphereConnected 2) ∣ f north ∣ ∣ p ∣))

-- We get our square
module BM-inst =
  BlakersMassey□
   (λ _ → tt) fold∘W 3 1
   (λ _ → subst (isConnected 4)
            (isoToPath (invIso fiberUnitIso))
            (sphereConnected 3))
   (isConnectedS3→S2 fold∘W)

open BM-inst

-- The central types
coFib-fold∘W : Type
coFib-fold∘W = Pushout (λ _ → tt) fold∘W

coFib-fold∘W∙ : Pointed₀
coFib-fold∘W∙ = coFib-fold∘W , inl tt

TotalPushoutPath×∙ : Pointed ℓ-zero
fst TotalPushoutPath×∙ = Σ (Unit × S₊ 2) PushoutPath×
snd TotalPushoutPath×∙ = (tt , north) , push north

S³→TotalPushoutPath× : S₊ 3 → Σ (Unit × S₊ 2) PushoutPath×
S³→TotalPushoutPath× = toPullback

private
  inr' : S₊ 2 → coFib-fold∘W
  inr' = inr

  inr∙ : S₊∙ 2 →∙ coFib-fold∘W∙
  fst inr∙ = inr'
  snd inr∙ = sym (push north)

  fiberinr'Iso' : Iso (fiber inr' (inl tt))
                      (Σ (Unit × S₊ 2) PushoutPath×)
  fiberinr'Iso' =
    compIso (Σ-cong-iso-snd (λ x → symIso))
            (Σ-cong-iso-fst (invIso lUnit×Iso))

  fiberinr'Iso : Iso (fiber inr' (inl tt))
                     (Σ (Unit × S₊ 2) PushoutPath×)
  fun fiberinr'Iso (x , p) = (tt , x) , (sym p)
  inv fiberinr'Iso ((tt , x) , p) = x , (sym p)
  rightInv fiberinr'Iso _ = refl
  leftInv fiberinr'Iso _ = refl

  P : Pointed₀
  P = (fiber inr' (inl tt) , north , (sym (push north)))

π'P→π'TotalPath× : (n : ℕ)
  → GroupEquiv (π'Gr n TotalPushoutPath×∙) (π'Gr n P)
fst (fst (π'P→π'TotalPath× n)) =
  π'eqFun n ((invEquiv (isoToEquiv fiberinr'Iso)) , refl)
snd (fst (π'P→π'TotalPath× n)) = π'eqFunIsEquiv n _
snd (π'P→π'TotalPath× n) = π'eqFunIsHom n _

-- Time to invoke the long exact sequence of homotopy groups on
-- inr : S² → coFib-fold∘W
module LESinst = πLES {A = S₊∙ 2} {B = coFib-fold∘W∙} inr∙

-- We instantiate the sequence
-- π₃ P → π₃ S² → π₃ coFib-fold∘W∙ → π₂ P
P→S²→Pushout :
  Exact4 (πGr 2 P) (πGr 2 (S₊∙ 2)) (πGr 2 coFib-fold∘W∙) (πGr 1 P)
        (LESinst.fib→A 2)
        (LESinst.A→B 2)
        (LESinst.B→fib 1)
Exact4.ImG→H⊂KerH→L P→S²→Pushout = LESinst.Im-fib→A⊂Ker-A→B 2
Exact4.KerH→L⊂ImG→H P→S²→Pushout = LESinst.Ker-A→B⊂Im-fib→A 2
Exact4.ImH→L⊂KerL→R P→S²→Pushout = LESinst.Im-A→B⊂Ker-B→fib 1
Exact4.KerL→R⊂ImH→L P→S²→Pushout = LESinst.Ker-B→fib⊂Im-A→B 1

-- The goal now is to rewrite it as
-- π₃ S³ → π₃ S² → π₃ coFib-fold∘W∙ → Unit using the
-- "functions from spheres"-definition of πₙ.
-- Here, the first map is the one induced by fold∘W. We do this by:
-- (1) showing that π₂ P is trivial
-- (2) extending the sequence by appending surjections
-- π₃ S³ → π₃ TotalPushoutPath×∙ → π₃ P on the left.
-- (3) proving that this new composition is indeed the appropriate map

-- Step 1: π₂ P is trivial
π₂P≅0 : GroupEquiv (πGr 1 P) UnitGroup₀
π₂P≅0 = compGroupEquiv (πIso (isoToEquiv fiberinr'Iso , refl) 1)
         (GroupIso→GroupEquiv
           (contrGroupIsoUnit
             (isOfHLevelRetractFromIso 0 (invIso iso₂) isContrπ₂S³)))
  where
  iso₁ : Iso (hLevelTrunc 4 (S₊ 3))
             (hLevelTrunc 4 (Σ (Unit × S₊ 2) PushoutPath×))
  iso₁ = connectedTruncIso 4 S³→TotalPushoutPath× isConnected-toPullback

  iso₂ : Iso (π 2 (hLevelTrunc∙ 4 (S₊∙ 3)))
              (π 2 TotalPushoutPath×∙)
  iso₂ =
    (compIso (setTruncIso
      (equivToIso (_ ,
        (isEquivΩ^→ 2 (fun iso₁ , refl) (isoToIsEquiv iso₁)))))
     (invIso (πTruncIso 2)))

  isContrπ₂S³ : isContr (π 2 (hLevelTrunc∙ 4 (S₊∙ 3)))
  isContrπ₂S³ =
    subst (λ x → isContr (π 2 x))
      (λ i → ((sym (isContr→≡Unit (sphereConnected 3))) i)
            , transp (λ j → isContr→≡Unit
              (sphereConnected 3) (~ i ∧ j)) i ∣ north ∣)
      (∣ refl ∣₂ , sElim (λ _ → isSetPathImplicit)
                  λ p → cong ∣_∣₂
                          (isProp→isSet
                           (isOfHLevelPath 1 isPropUnit _ _) _ _ _ p))

-- Step 2. We transform our original sequence to one for the
-- the "maps from spheres" definition of πₙ and where π₂ P is
-- replaced by the trivial group:
-- π₃ P → π₃ S² → π₃ coFib-fold∘W∙ → 0
P→S²→Pushout→P' :
  Exact4 (π'Gr 2 P) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀
         (π'∘∙Hom 2 (fst , refl))
         (π'∘∙Hom 2 inr∙)
         (→UnitHom _)
P→S²→Pushout→P' =
  transportExact4
  (sym (GroupPath _ _ .fst ((GroupIso→GroupEquiv (π'Gr≅πGr 2 P)))))
  (sym (GroupPath _ _ .fst ((GroupIso→GroupEquiv (π'Gr≅πGr 2 (S₊∙ 2))))))
  (sym (GroupPath _ _ .fst ((GroupIso→GroupEquiv (π'Gr≅πGr 2 coFib-fold∘W∙)))))
  (sym (GroupPath _ _ .fst π₂P≅0))
  _ _ _ _ _
  P→S²→Pushout
  (ΣPathPProp (λ _ → isPropIsGroupHom _ _)
    λ i → fst (π∘∙fib→A-PathP 2 inr∙ i))
  (ΣPathPProp (λ _ → isPropIsGroupHom _ _)
    λ i → fst (π∘∙A→B-PathP 2 inr∙ i))

-- The two surjections in question
π₃S³→π₃P : GroupHom (π'Gr 2 (S₊∙ 3)) (π'Gr 2 TotalPushoutPath×∙)
π₃S³→π₃P = π'∘∙Hom 2 (S³→TotalPushoutPath× , refl)

TotalPushoutPath×∙→P : TotalPushoutPath×∙ →∙ P -- Surjective, and in particular on π₃
fst TotalPushoutPath×∙→P x = (snd (fst x)) , (sym (snd x))
snd TotalPushoutPath×∙→P = refl

-- This surjectivity is where Blakers-Massey is used
-- In particular, it uses isConnected-toPullback
isSurjective-π₃S³→π₃TotalPushoutPath× : isSurjective π₃S³→π₃P
isSurjective-π₃S³→π₃TotalPushoutPath× =
  transport (λ i → isSurjective (transportLem i))
              isSurjective-π₃S³→π₃TotalPushoutPath×'
  where
  π₃S³→π₃TotalPushoutPath× : GroupHom (πGr 2 (S₊∙ 3)) (πGr 2 TotalPushoutPath×∙)
  π₃S³→π₃TotalPushoutPath× = πHom 2 (S³→TotalPushoutPath× , refl)

  isSurjective-π₃S³→π₃TotalPushoutPath×' : isSurjective π₃S³→π₃TotalPushoutPath×
  isSurjective-π₃S³→π₃TotalPushoutPath×' =
    sElim (λ _ → isProp→isSet squash₁)
      λ p → trRec squash₁
        (λ s → ∣ ∣ fst s ∣₂ , (cong ∣_∣₂ (snd s)) ∣₁)
        (((isConnectedΩ^→ 3 3 (S³→TotalPushoutPath× , refl)
          isConnected-toPullback) p) .fst)

  transportLem : PathP (λ i → GroupHomπ≅π'PathP (S₊∙ 3) TotalPushoutPath×∙ 2 i)
                       π₃S³→π₃TotalPushoutPath× π₃S³→π₃P
  transportLem =
    toPathP (Σ≡Prop (λ _ → isPropIsGroupHom _ _)
       (π'∘∙Hom'≡π'∘∙fun {A = S₊∙ 3} {B = TotalPushoutPath×∙}
         2 (S³→TotalPushoutPath× , refl)))

-- We get a sequence on the right form π₃S³ → π₃S² → π₃ Pushout → Unit
S³→S²→Pushout→Unit'' :
  Exact4 (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀
        (compGroupHom π₃S³→π₃P
          (compGroupHom
            (π'∘∙Hom 2 TotalPushoutPath×∙→P) (π'∘∙Hom 2 (fst , refl))))
        (π'∘∙Hom 2 inr∙)
        (→UnitHom (π'Gr 2 coFib-fold∘W∙))
S³→S²→Pushout→Unit'' =
  extendExact4Surjective _ _ _ _ _ _ _ _ _
    isSurjective-π₃S³→π₃TotalPushoutPath×
    (extendExact4Surjective _ _ _ _ _ _ _ _ _
      ((sElim (λ _ → isProp→isSet squash₁)
      (λ f → ∣ ∣ (λ x → (tt , fst f x .fst) , sym (fst f x .snd))
      , ΣPathP ((ΣPathP (refl , cong fst (snd f)))
                       , λ j i → snd f j  .snd (~ i)) ∣₂
              , cong ∣_∣₂ (ΣPathP (refl , sym (rUnit _))) ∣₁)))
      P→S²→Pushout→P')

-- Step 3: We need to show that the map π₃S³ → π₃S² in the above sequence
-- indeed comes from fold∘W
tripleComp≡ :
    (compGroupHom π₃S³→π₃P
     (compGroupHom
      (π'∘∙Hom 2 TotalPushoutPath×∙→P) (π'∘∙Hom 2 (fst , refl))))
  ≡ π'∘∙Hom 2 (fold∘W , refl)
tripleComp≡ =
  Σ≡Prop (λ _ → isPropIsGroupHom _ _)
    (funExt (sElim (λ _ → isSetPathImplicit)
     λ f → cong ∣_∣₂ (ΣPathP (refl , (cong (_∙ refl)
     (λ j → cong fst (rUnit (cong (fst TotalPushoutPath×∙→P)
               (rUnit (cong S³→TotalPushoutPath× (snd f)) (~ j))) (~ j))))))))

-- We finally get the correct sequence
S³→S²→Pushout→Unit :
  Exact4 (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀
        (π'∘∙Hom 2 (fold∘W , refl))
        (π'∘∙Hom 2 inr∙)
        (→UnitHom (π'Gr 2 coFib-fold∘W∙))
S³→S²→Pushout→Unit =
  subst
   (λ F → Exact4 (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙) UnitGroup₀
            F (π'∘∙Hom 2 inr∙)
            (→UnitHom (π'Gr 2 coFib-fold∘W∙)))
            tripleComp≡
   S³→S²→Pushout→Unit''

-- We need to throw around some pushouts
module _ where
  Pushout-coFibW-fold⋁≃coFib-fold∘W :
    Pushout {B = (Pushout W (λ _ → tt))} inl fold⋁ ≃ fst coFib-fold∘W∙
  Pushout-coFibW-fold⋁≃coFib-fold∘W = compEquiv
          (compEquiv pushoutSwitchEquiv
            (isoToEquiv (PushoutDistr.PushoutDistrIso fold⋁ W λ _ → tt)))
          pushoutSwitchEquiv

  coFibW≅coFibW' : Pushout W (λ _ → tt) ≃ cofibW S¹ S¹ base base
  coFibW≅coFibW' = pushoutEquiv W (λ _ → tt) joinTo⋁ (λ _ → tt)
           (isoToEquiv (invIso (IsoSphereJoin 1 1)))
           (idEquiv _)
           (idEquiv _)
           refl
           refl

  Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁ :
      Pushout {B = (Pushout W (λ _ → tt))} inl fold⋁
    ≃ fst (Pushout⋁↪fold⋁∙ (S₊∙ 2))
  Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁ = pushoutEquiv inl _ ⋁↪ fold⋁
          (idEquiv _)
          (compEquiv coFibW≅coFibW'
            (isoToEquiv (invIso (Iso-Susp×Susp-cofibJoinTo⋁ S¹ S¹ base base))))
          (idEquiv _)
          (Susp×Susp→cofibW≡ S¹ S¹ base base)
          refl

  Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ :
       (Pushout {B = (Pushout W (λ _ → tt))} inl fold⋁ , inr north)
    ≃∙ (Pushout⋁↪fold⋁∙ (S₊∙ 2))
  fst Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ =
    Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁
  snd Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙ =
    sym (push (inl north))

π₄S³≅π₃coFib-fold∘W∙ : GroupEquiv (π'Gr 3 (S₊∙ 3)) (π'Gr 2 coFib-fold∘W∙)
π₄S³≅π₃coFib-fold∘W∙ =
  compGroupEquiv
    (GroupIso→GroupEquiv
      (compGroupIso
        (π'Gr≅πGr 3 (S₊∙ 3))
        (compGroupIso
          π₄S³≅π₃PushS²
          (invGroupIso (π'Gr≅πGr 2 (Pushout⋁↪fold⋁∙ (S₊∙ 2)))))))
    (compGroupEquiv
      (invGroupEquiv (π'Iso 2 Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁∙))
      (π'Iso 2 (Pushout-coFibW-fold⋁≃coFib-fold∘W , sym (push north))))

-- We get the iso
-- For type checking reasons, let's first prove it for the abstract
-- definition of ℤ/_

-- To get everything on the same form as in Brunerie's thesis, we
-- first need the following:
fold∘W≡Whitehead :
        fst (π'∘∙Hom 2 (fold∘W , refl)) ∣ idfun∙ (S₊∙ 3) ∣₂
      ≡ ∣ [ idfun∙ (S₊∙ 2) ∣ idfun∙ (S₊∙ 2) ]₂ ∣₂
fold∘W≡Whitehead =
  pRec (squash₂ _ _)
    (cong ∣_∣₂)
    (indΠ₃S₂ _ _
      (funExt (λ x → funExt⁻ (sym (cong fst (id∨→∙id {A = S₊∙ 2}))) (W x))))
  where
  indΠ₃S₂ : ∀ {ℓ} {A : Pointed ℓ}
    → (f g : A →∙ S₊∙ 2)
      → fst f ≡ fst g → ∥ f ≡ g ∥₁
  indΠ₃S₂ {A = A} f g p =
    trRec squash₁
     (λ r → ∣ ΣPathP (p , r) ∣₁)
      (isConnectedPathP 1 {A = (λ i → p i (snd A) ≡ north)}
        (isConnectedPathSⁿ 1 (fst g (pt A)) north) (snd f) (snd g) .fst )

BrunerieIsoAbstract : GroupEquiv (π'Gr 3 (S₊∙ 3)) (abstractℤGroup/ Brunerie)
BrunerieIsoAbstract =
  compGroupEquiv π₄S³≅π₃coFib-fold∘W∙
    (invGroupEquiv
      (GroupEquiv-abstractℤ/abs-gen
        (π'Gr 2 (S₊∙ 3)) (π'Gr 2 (S₊∙ 2)) (π'Gr 2 coFib-fold∘W∙)
          (GroupIso→GroupEquiv (invGroupIso (πₙ'Sⁿ≅ℤ 2)))
          (invGroupEquiv hopfInvariantEquiv)
          (π'∘∙Hom 2 (fold∘W , refl))
          _
          S³→S²→Pushout→Unit Brunerie main))
  where
  mainPath :
    fst (π'∘∙Hom 2 (fold∘W , refl))
         (Iso.inv (fst (πₙ'Sⁿ≅ℤ 2)) 1)
     ≡ [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π'
  mainPath =
      cong (fst (π'∘∙Hom 2 (fold∘W , refl)))
           (cong (Iso.inv (fst (πₙ'Sⁿ≅ℤ 2))) (sym (πₙ'Sⁿ≅ℤ-idfun∙ 2))
           ∙ (Iso.leftInv (fst (πₙ'Sⁿ≅ℤ 2)) ∣ idfun∙ (S₊∙ 3) ∣₂))
    ∙ fold∘W≡Whitehead
    ∙ cong ∣_∣₂ (sym ([]≡[]₂ (idfun∙ (S₊∙ 2)) (idfun∙ (S₊∙ 2))))

  main : _ ≡ Brunerie
  main i = abs (HopfInvariant-π' 0 (mainPath i))

-- And, finally, we get the actual iso
-- (as in Corollary 3.4.5 in Brunerie's thesis)
BrunerieIso : GroupEquiv (π'Gr 3 (S₊∙ 3)) (ℤGroup/ Brunerie)
BrunerieIso =
  compGroupEquiv BrunerieIsoAbstract (abstractℤ/≅ℤ Brunerie)


{-# OPTIONS --without-K #-}

open import library.Basics hiding (Type ; Σ ; S)
open import library.types.Sigma

open import Sec2preliminaries
open import Sec3hedberg
open import Sec4hasConstToSplit
open import Sec5factorConst
open import Sec6hasConstToDecEq
open import Sec7populatedness

module Sec8taboos where

-- Subsection 8.1

all-hasConst : Type₁
all-hasConst = (X : Type) → hasConst X

-- Theorem 8.1
module functional-subrelation (ac : all-hasConst) (X : Type) (R : X × X → Type) where

  all-sets : (Y : Type) → is-set Y
  all-sets Y = pathHasConst→isSet (λ y₁ y₂ → ac _)

  R₋ : (x : X) → Type
  R₋ x = Σ X λ y → R(x , y)

  k : (x : X) → (R₋ x) → (R₋ x)
  k x = fst (ac _)

  kc : (x : X) → const (k x)
  kc x = snd (ac _)

  S : X × X → Type
  S (x , y) = Σ (R(x , y)) λ a →
                (y , a) == k x (y , a)

  -- the relation S
  S₋ : (x : X) → Type
  S₋ x = Σ X λ y → S(x , y)

  -- fix kₓ is equivalent to Sₓ
  -- This is just Σ-assoc. We try to make it more readable by adding some (trivial) steps.
  fixk-S : (x : X) → (fix (k x)) ≃ S₋ x
  fixk-S x =
      (fix (k x))                                           ≃⟨ ide _ ⟩
      (Σ (Σ X λ y → R(x , y)) λ a → a == k x a)             ≃⟨ Σ-assoc ⟩
      (Σ X λ y → Σ (R(x , y)) λ r → (y , r) == k x (y , r)) ≃⟨ ide _ ⟩
      (S₋ x)                                                ≃∎

  -- claim (0)
  subrelation : (x y : X) → S(x , y) →  R(x , y)
  subrelation x y (r , _) = r

   -- claim (1)
  prop-Sx : (x : X) → is-prop (S₋ x)
  prop-Sx x = equiv-preserves-level {A = fix (k x)} {B = (S₋ x)} (fixk-S x) (fixed-point _ (kc x))

  -- claim (2)
  same-domain : (x : X) → (R₋ x) ↔ (S₋ x)
  same-domain x = rs , sr where
    rs : (R₋ x) → (S₋ x)
    rs a = –> (fixk-S x) (to-fix (k x) (kc x) a)
    sr : (S₋ x) → (R₋ x)
    sr (y , r , _) = y , r

  -- claim (3)
  prop-S : (x y : X) → is-prop (S (x , y))
  prop-S x y = all-paths-is-prop all-paths where
    all-paths : (s₁ s₂ : S(x , y)) → s₁ == s₂
    all-paths s₁ s₂ = ss where

      yss : (y , s₁) == (y , s₂)
      yss = prop-has-all-paths (prop-Sx x) _ _

      ss : s₁ == s₂
      ss = set-lemma (all-sets _) y s₁ s₂ yss

-- intermediate definition
-- see the caveat about the notion 'epimorphism' in the article
is-split-epimorphism : {U V : Type} → (U → V) → Type
is-split-epimorphism {U} {V} e = Σ (V → U) λ s → (v : V) → e (s v) == v

is-epimorphism : {U V : Type} → (U → V) → Type₁
is-epimorphism {U} {V} e = (W : Type) → (f g : V → W) → ((u : U) → f (e u) == g (e u)) → (v : V) → f v == g v

-- Lemma 8.2
path-trunc-epi→set : {Y : Type} → ((y₁ y₂ : Y) → is-epimorphism (∣_∣ {X = y₁ == y₂})) → is-set Y
path-trunc-epi→set {Y} path-epi = reminder special-case where

  f : (y₁ y₂ : Y) → Trunc (y₁ == y₂) → Y
  f y₁ _ _ = y₁

  g : (y₁ y₂ : Y) → Trunc (y₁ == y₂) → Y
  g _ y₂ _ = y₂

  special-case : (y₁ y₂ : Y) → Trunc (y₁ == y₂) → y₁ == y₂
  special-case y₁ y₂ = path-epi y₁ y₂ Y (f y₁ y₂) (g y₁ y₂) (idf _)

  reminder : hseparated Y → is-set Y
  reminder = fst set-characterizations ∘ snd (snd set-characterizations)

-- Theorem 8.3 (1)
all-split→all-deceq : ((X : Type) → is-split-epimorphism (∣_∣ {X = X})) → (X : Type) → has-dec-eq X
all-split→all-deceq all-split = all-hasConst→dec-eq ac where
  ac : (X : Type) → hasConst X
  ac X = snd hasConst↔splitSup (fst (all-split X))

-- Theorem 8.3 (2)
all-epi→all-set : ((X : Type) → is-epimorphism (∣_∣ {X = X})) → (X : Type) → is-set X
all-epi→all-set all-epi X = path-trunc-epi→set (λ y₁ y₂ → all-epi (y₁ == y₂))

-- Subsection 8.2

-- Lemma 8.4, first proof
pop-splitSup-1 : {X : Type} → Pop (splitSup X)
pop-splitSup-1 {X} f c = to-fix f c (hasConst→splitSup (g , gc)) where

  g : X → X
  g x = f (λ _ → x) ∣ x ∣

  gc : const g
  gc x₁ x₂ =
    g x₁               =⟨ idp ⟩
    f (λ _ → x₁) ∣ x₁ ∣ =⟨ ap (λ k → k ∣ x₁ ∣) (c (λ _ → x₁) (λ _ → x₂)) ⟩
    f (λ _ → x₂) ∣ x₁ ∣ =⟨ ap (f (λ _ → x₂)) (prop-has-all-paths (h-tr X) ∣ x₁ ∣ ∣ x₂ ∣) ⟩
    f (λ _ → x₂) ∣ x₂ ∣ =⟨ idp ⟩
    g x₂               ∎

-- Lemma 8.4, second proof
pop-splitSup-2 : {X : Type} → Pop (splitSup X)
pop-splitSup-2 {X} = snd (pop-alt₂ {splitSup X}) get-P where
  get-P : (P : Type) → is-prop P → splitSup X ↔ P → P
  get-P P pp (hstp , phst) = hstp free-hst where

    xp : X → P
    xp x = hstp (λ _ → x)

    zp : Trunc X → P
    zp = rec pp xp

    free-hst : splitSup X
    free-hst z = phst (zp z) z

-- Lemma 8.5, third proof
pop-splitSup-3 : {X : Type} → Pop (splitSup X)
pop-splitSup-3 {X} = snd pop-alt translation where

  translation-aux : splitSup (splitSup X) → splitSup X
  translation-aux = λ hsthst z → hsthst (trunc-functorial {X = X} {Y = splitSup X} (λ x _ → x) z) z

  translation : Trunc (splitSup (splitSup X)) → Trunc (splitSup X)
  translation = trunc-functorial translation-aux

-- Theorem 8.5
module thm85 where

  One = (X : Type) → Pop X → Trunc X

  Two = (X : Type) → Trunc (splitSup X)

  Three = (P : Type) → is-prop P → (Y : P → Type) → ((p : P) → Trunc (Y p)) → Trunc ((p : P) → Y p)

  Four = (X Y : Type) → (X → Y) → (Pop X → Pop Y)

  One→Two : One → Two
  One→Two poptr X = poptr (splitSup X) pop-splitSup-1

  Two→One : Two → One
  Two→One trhst X pop = fst pop-alt pop (trhst X)

  One→Four : One → Four
  One→Four poptr X Y f = Trunc→Pop ∘ (trunc-functorial f) ∘ (poptr X)

  Four→One : Four → One
  Four→One funct X px = prop-pop (h-tr _) pz where
    pz : Pop (Trunc X)
    pz  =  funct X (Trunc X) ∣_∣ px

  -- only very slightly different to the proof in the article
  One→Three : One → Three
  One→Three poptr P pp Y = λ py → poptr _ (snd pop-alt' (λ hst p₀ → hst (contr-trick p₀ py) p₀)) where
    contr-trick : (p₀ : P) → ((p : P) → Trunc (Y p)) → Trunc ((p : P) → Y p)
    contr-trick p₀ py = rec {X = Y p₀}
                            {P = Trunc ((p : P) → Y p)}
                            (h-tr _)
                            (λ y₀ → ∣ <– (thm55aux.neutral-contr-exp {P = P} {Y = Y} pp p₀) y₀ ∣) (py p₀)

  Three→Two : Three → Two
  Three→Two proj X = proj (Trunc X) (h-tr _) (λ _ → X) (idf _)

-- Subsection 8.3

-- Some very simple lemmata

-- If P is a proposition, so is P + ¬ P
dec-is-prop : {P : Type} → (Funext {X = P} {Y = Empty}) → is-prop P → is-prop (P + ¬ P)
dec-is-prop {P} fext pp = all-paths-is-prop (λ { (inl p₁) (inl p₂) → ap inl (prop-has-all-paths pp _ _) ;
                                (inl p₁) (inr np₂) → Empty-elim {A = λ _ → inl p₁ == inr np₂} (np₂ p₁) ;
                                (inr np₁) (inl p₂) → Empty-elim {A = λ _ → inr np₁ == inl p₂} (np₁ p₂) ;
                                (inr np₁) (inr np₂) → ap inr (fext np₁ np₂ (λ p → prop-has-all-paths (λ ()) _ _)) })

-- Theorem 8.7
nonempty-pop→lem : ((X : Type) → Funext {X} {Empty})
                         → ((X : Type) → (¬(¬ X) → Pop X)) → LEM
nonempty-pop→lem fext nn-pop P pp = from-fix {X = dec} (idf _) (nn-pop dec nndec (idf _) idc) where
  dec : Type
  dec = P + ¬ P

  idc : const (idf dec)
  idc = λ _ _ → prop-has-all-paths (dec-is-prop {P} (fext P) pp) _ _

  nndec : ¬(¬ dec)
  nndec ndec = (λ np → ndec (inr np)) λ p → ndec (inl p)

-- Corollary 8.8
nonempty-pop↔lem : ((X : Type) → Funext {X} {Empty})
                         → ((X : Type) → (¬(¬ X) → Pop X)) ↔₁₁ LEM
nonempty-pop↔lem fext = nonempty-pop→lem fext , other where
  other : LEM → ((X : Type) → (¬(¬ X) → Pop X))
  other lem X nnX = p where
    pnp : Pop X + ¬ (Pop X)
    pnp = lem (Pop X) pop-property₂

    p : Pop X
    p = match pnp withl idf _ withr (λ np → Empty-elim {A = λ _ → Pop X} (nnX (λ x → np (pop-property₁ x))))


open import Level using () renaming (_⊔_ to _⊔ˡ_)

open import Data.Product using (_,_; proj₁)
open import Data.Sum using (_⊎_; inj₁; inj₂)

open import Relation.Nullary using (yes; no; ¬_)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary using (Reflexive; Symmetric; Transitive; Setoid; Tri)
open Tri
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_) renaming (refl to ≡-refl; sym to ≡-sym)
open import Algebra.Bundles using (RawRing)
open import AKS.Algebra.Bundles using (DecField)

module AKS.Polynomial.Base {c ℓ} (F : DecField c ℓ)  where

open import Data.Unit using (⊤; tt)
open import Agda.Builtin.FromNat using (Number)
open import AKS.Nat using (ℕ; _∸_; _≤_; _<_; lte; pred) renaming (_+_ to _+ℕ_; _⊔_ to _⊔ℕ_)
open ℕ
open import AKS.Nat using (≢⇒¬≟; <-cmp; ≤-totalOrder; m<n⇒n∸m≢0)
open import AKS.Nat using (ℕ⁺; ⟅_⇓⟆; ⟅_⇑⟆)
open import AKS.Nat.WellFounded using (Acc; acc; <-well-founded)

open DecField F
  using (0#; 1#; _+_; _*_; -_; _-_; _⁻¹; _/_; C/0)
  renaming (Carrier to C)
open DecField F using (_≈_; _≈?_; setoid)
open Setoid setoid using (refl; sym; trans)
open DecField F
  using (*-commutativeMonoid; 1#-nonzero; -1#-nonzero; _*-nonzero_; _/-nonzero_)
open import AKS.Exponentiation *-commutativeMonoid using (_^_; _^⁺_)

data Spine : Set (c ⊔ˡ ℓ) where
  K : C/0 → Spine
  _+x^_∙_ : C/0 → ℕ⁺ → Spine → Spine

data Polynomial : Set (c ⊔ˡ ℓ) where
  0ᵖ : Polynomial
  x^_∙_ : ℕ → Spine → Polynomial

⟦_⟧ˢ : Spine → C → C
⟦ K c ⟧ˢ x = proj₁ c
⟦ c +x^ n ∙ p ⟧ˢ x = proj₁ c + x ^⁺ n * ⟦ p ⟧ˢ x

⟦_⟧ : Polynomial → C → C
⟦ 0ᵖ ⟧ x = 0#
⟦ x^ n ∙ p ⟧ x = x ^ n * ⟦ p ⟧ˢ x

1ᵖ : Polynomial
1ᵖ = x^ 0 ∙ K 1#-nonzero

_+?_ : ∀ (k₁ k₂ : C/0) → (proj₁ k₁ + proj₁ k₂ ≈ 0#) ⊎ C/0
k₁ +? k₂ with proj₁ k₁ + proj₁ k₂ ≈? 0#
... | yes k₁+k₂≈0 = inj₁ k₁+k₂≈0
... | no  k₁+k₂≉0 = inj₂ (proj₁ k₁ + proj₁ k₂ , k₁+k₂≉0)

+ᵖ-spine-≡-K : ℕ → C/0 → Spine → Polynomial
+ᵖ-spine-≡-K n c₁ (K c₂) with c₁ +? c₂
... | inj₁ _ = 0ᵖ
... | inj₂ c₁+c₂ = x^ n ∙ K c₁+c₂
+ᵖ-spine-≡-K n c₁ (c₂ +x^ i₂ ∙ q) with c₁ +? c₂
... | inj₁ _ = x^ (n +ℕ ⟅ i₂ ⇓⟆) ∙ q
... | inj₂ c₁+c₂ = x^ n ∙ (c₁+c₂ +x^ i₂ ∙ q)

+ᵖ-spine-≡ : ℕ → Spine → Spine → Polynomial
+ᵖ-spine-< : (n : ℕ) → Spine → (m : ℕ) → Spine → n < m → Polynomial
+ᵖ-spine : ℕ → Spine → ℕ → Spine → Polynomial

+ᵖ-spine-≡ n (K c₁) q = +ᵖ-spine-≡-K n c₁ q
+ᵖ-spine-≡ n (c₁ +x^ i₁ ∙ p) (K c₂) = +ᵖ-spine-≡-K n c₂ (c₁ +x^ i₁ ∙ p)
+ᵖ-spine-≡ n (c₁ +x^ i₁ ∙ p) (c₂ +x^ i₂ ∙ q) with c₁ +? c₂
... | inj₁ _ = +ᵖ-spine (n +ℕ ⟅ i₁ ⇓⟆) p (n +ℕ ⟅ i₂ ⇓⟆) q
... | inj₂ c₁+c₂ with +ᵖ-spine ⟅ i₁ ⇓⟆ p ⟅ i₂ ⇓⟆ q
...   | 0ᵖ = x^ n ∙ K c₁+c₂
...   | x^ zero ∙ r = +ᵖ-spine-≡-K n c₁+c₂ r
...   | x^ suc n₃ ∙ r = x^ n ∙ (c₁+c₂ +x^ ⟅ suc n₃ ⇑⟆ ∙ r)

+ᵖ-spine-< n₁ (K c₁) n₂ q n₁<n₂ = x^ n₁ ∙ (c₁ +x^ ⟅ n₂ ∸ n₁ ⇑⟆ {≢⇒¬≟ (m<n⇒n∸m≢0 n₁<n₂)} ∙ q)
+ᵖ-spine-< n₁ (c₁ +x^ i₁ ∙ p) n₂ q n₁<n₂ with +ᵖ-spine ⟅ i₁ ⇓⟆ p (n₂ ∸ n₁) q
... | 0ᵖ = x^ n₁ ∙ K c₁
... | x^ zero ∙ r = +ᵖ-spine-≡-K n₁ c₁ r
... | x^ suc n₃ ∙ r = x^ n₁ ∙ (c₁ +x^ ⟅ suc n₃ ⇑⟆ ∙ r)

+ᵖ-spine n₁ p n₂ q with <-cmp n₁ n₂
... | tri< n₁<n₂ _ _ = +ᵖ-spine-< n₁ p n₂ q n₁<n₂
... | tri≈ _ n₁≡n₂ _ = +ᵖ-spine-≡ n₁ p q
... | tri> _ _ n₁>n₂ = +ᵖ-spine-< n₂ q n₁ p n₁>n₂

infixl 6 _+ᵖ_
_+ᵖ_ : Polynomial → Polynomial → Polynomial
0ᵖ +ᵖ q = q
(x^ n₁ ∙ p) +ᵖ 0ᵖ = x^ n₁ ∙ p
(x^ n₁ ∙ p) +ᵖ (x^ n₂ ∙ q) = +ᵖ-spine n₁ p n₂ q

_∙𝑋^_ : C/0 → ℕ → Polynomial
c ∙𝑋^ n = x^ n ∙ K c

𝑋^_ : ℕ → Polynomial
𝑋^ n = 1#-nonzero ∙𝑋^ n

𝑋 : Polynomial
𝑋 = 𝑋^ 1

𝐾 : C → Polynomial
𝐾 c with c ≈? 0#
... | yes _  = 0ᵖ
... | no c≉0 = (c , c≉0) ∙𝑋^ 0

∙ᵖ-spine : C/0 → Spine → Spine
∙ᵖ-spine c₁ (K c₂) = K (c₁ *-nonzero c₂)
∙ᵖ-spine c₁ (c₂ +x^ n ∙ p) = (c₁ *-nonzero c₂) +x^ n ∙ (∙ᵖ-spine c₁ p)

infixl 7 _∙ᵖ_
_∙ᵖ_ : C/0 → Polynomial → Polynomial
c ∙ᵖ 0ᵖ = 0ᵖ
c ∙ᵖ (x^ n ∙ p) = x^ n ∙ (∙ᵖ-spine c p)

*ᵖ-spine : ℕ → Spine → ℕ → Spine → Polynomial
*ᵖ-spine o₁ (K c₁) o₂ q = x^ (o₁ +ℕ o₂) ∙ (∙ᵖ-spine c₁ q)
*ᵖ-spine o₁ (c₁ +x^ n₁ ∙ p) o₂ (K c₂) = x^ (o₁ +ℕ o₂) ∙ (∙ᵖ-spine c₂ (c₁ +x^ n₁ ∙ p))
*ᵖ-spine o₁ (c₁ +x^ n₁ ∙ p) o₂ (c₂ +x^ n₂ ∙ q) =
  x^ (o₁ +ℕ o₂) ∙ K (c₁ *-nonzero c₂) +ᵖ
  c₁ ∙ᵖ x^ (o₁ +ℕ o₂ +ℕ ⟅ n₂ ⇓⟆) ∙ q +ᵖ
  c₂ ∙ᵖ (x^ (o₁ +ℕ o₂ +ℕ ⟅ n₁ ⇓⟆) ∙ p) +ᵖ
  *ᵖ-spine (o₁ +ℕ ⟅ n₁ ⇓⟆) p (o₂ +ℕ ⟅ n₂ ⇓⟆) q
-- (c₁ + x ^ n₁ * p[x]) * (c₂ + x ^ n₂ * q[x]) = (c₁ * c₂) + (c₁ * x ^ n₂ * q[x]) + (x ^ n₁ * p[x] * c₂) + (x ^ n₁ * p[x] * x ^ n₂ * q[x])

infixl 7 _*ᵖ_
_*ᵖ_ : Polynomial → Polynomial → Polynomial
0ᵖ *ᵖ q = 0ᵖ
(x^ n₁ ∙ p) *ᵖ 0ᵖ = 0ᵖ
(x^ n₁ ∙ p) *ᵖ (x^ n₂ ∙ q) = *ᵖ-spine n₁ p n₂ q

infix 6 -ᵖ_
-ᵖ_ : Polynomial → Polynomial
-ᵖ p = -1#-nonzero ∙ᵖ p

infixl 6 _-ᵖ_
_-ᵖ_ : Polynomial → Polynomial → Polynomial
p -ᵖ q = p +ᵖ (-ᵖ q)

data Polynomialⁱ : Set c where
  0ⁱ    : Polynomialⁱ
  _+x∙_ : C → Polynomialⁱ → Polynomialⁱ

1ⁱ : Polynomialⁱ
1ⁱ = 1# +x∙ 0ⁱ

infixl 6 _+ⁱ_
_+ⁱ_ : Polynomialⁱ → Polynomialⁱ → Polynomialⁱ
0ⁱ +ⁱ q = q
(c₁ +x∙ p) +ⁱ 0ⁱ = c₁ +x∙ p
(c₁ +x∙ p) +ⁱ (c₂ +x∙ q) = (c₁ + c₂) +x∙ (p +ⁱ q)

infixl 7 _∙ⁱ_
_∙ⁱ_ : C → Polynomialⁱ → Polynomialⁱ
a ∙ⁱ 0ⁱ = 0ⁱ
a ∙ⁱ (c +x∙ p) = (a * c) +x∙ (a ∙ⁱ p)

infix 8 x∙_
x∙_ : Polynomialⁱ → Polynomialⁱ
x∙ p = 0# +x∙ p

infixl 7 _*ⁱ_
_*ⁱ_ : Polynomialⁱ → Polynomialⁱ → Polynomialⁱ
0ⁱ *ⁱ q = 0ⁱ
(c₁ +x∙ p) *ⁱ 0ⁱ = 0ⁱ
(c₁ +x∙ p) *ⁱ (c₂ +x∙ q) = (c₁ * c₂) +x∙ (c₁ ∙ⁱ q +ⁱ c₂ ∙ⁱ p +ⁱ x∙ (p *ⁱ q))

-ⁱ_ : Polynomialⁱ → Polynomialⁱ
-ⁱ p = (- 1#) ∙ⁱ p

infixl 6 _-ⁱ_
_-ⁱ_ : Polynomialⁱ → Polynomialⁱ → Polynomialⁱ
p -ⁱ q = p +ⁱ (-ⁱ q)

expandˢ : ℕ → Spine → Polynomialⁱ
expandˢ zero (K c) = proj₁ c +x∙ 0ⁱ
expandˢ zero (c +x^ n ∙ s) = proj₁ c +x∙ expandˢ (pred ⟅ n ⇓⟆) s
expandˢ (suc n) s = 0# +x∙ expandˢ n s

expand : Polynomial → Polynomialⁱ
expand 0ᵖ = 0ⁱ
expand (x^ n ∙ p) = expandˢ n p

constant : C → Polynomial
constant c with c ≈? 0#
... | yes _   = 0ᵖ
... | no  c≉0 = (c , c≉0) ∙𝑋^ 0

simplify : Polynomialⁱ → Polynomial
simplify 0ⁱ = 0ᵖ
simplify (c₁ +x∙ p) with c₁ ≈? 0# | simplify p
... | yes _   | 0ᵖ       = 0ᵖ
... | yes _   | x^ n ∙ q = x^ suc n ∙ q
... | no c₁≉0 | 0ᵖ       = x^ 0 ∙ (K (c₁ , c₁≉0))
... | no c₁≉0 | x^ n ∙ q = x^ 0 ∙ ((c₁ , c₁≉0) +x^ ⟅ suc n ⇑⟆ ∙ q)

data _≈ˢ_ : Spine → Spine → Set (c ⊔ˡ ℓ) where
  K≈ : ∀ {c₁ c₂} → proj₁ c₁ ≈ proj₁ c₂ → K c₁ ≈ˢ K c₂
  +≈ : ∀ {c₁ c₂} {n₁ n₂} {p q} → proj₁ c₁ ≈ proj₁ c₂ → n₁ ≡ n₂ → p ≈ˢ q → (c₁ +x^ n₁ ∙ p) ≈ˢ (c₂ +x^ n₂ ∙ q)

infix 4 _≈ᵖ_
data _≈ᵖ_ : Polynomial → Polynomial → Set (c ⊔ˡ ℓ) where
  0ᵖ≈ : 0ᵖ ≈ᵖ 0ᵖ
  0ᵖ≉ : ∀ {o₁ o₂} {p q} → o₁ ≡ o₂ → p ≈ˢ q → x^ o₁ ∙ p ≈ᵖ x^ o₂ ∙ q

infix 4 _≉ᵖ_
_≉ᵖ_ : Polynomial → Polynomial → Set (c ⊔ˡ ℓ)
p ≉ᵖ q = ¬ (p ≈ᵖ q)

≈ᵖ-refl : Reflexive _≈ᵖ_
≈ᵖ-refl {0ᵖ} = 0ᵖ≈
≈ᵖ-refl {x^ n ∙ p} = 0ᵖ≉ ≡-refl ≈ˢ-refl
  where
  ≈ˢ-refl : Reflexive _≈ˢ_
  ≈ˢ-refl {K c} = K≈ refl
  ≈ˢ-refl {c +x^ n ∙ p} = +≈ refl ≡-refl ≈ˢ-refl

≈ᵖ-sym : Symmetric _≈ᵖ_
≈ᵖ-sym {0ᵖ} {0ᵖ} 0ᵖ≈ = 0ᵖ≈
≈ᵖ-sym {x^ n ∙ p} {x^ n ∙ q} (0ᵖ≉ ≡-refl p≈ˢq) = 0ᵖ≉ ≡-refl (≈ˢ-sym p≈ˢq)
  where
  ≈ˢ-sym : Symmetric _≈ˢ_
  ≈ˢ-sym {K c₁} {K c₂} (K≈ c₁≈c₂) = K≈ (sym c₁≈c₂)
  ≈ˢ-sym {c₁ +x^ n ∙ p} {c₂ +x^ n ∙ q} (+≈ c₁≈c₂ ≡-refl p≈ˢq) = +≈ (sym c₁≈c₂) ≡-refl (≈ˢ-sym p≈ˢq)

≈ᵖ-trans : Transitive _≈ᵖ_
≈ᵖ-trans {0ᵖ} {0ᵖ} {0ᵖ} 0ᵖ≈ 0ᵖ≈ = 0ᵖ≈
≈ᵖ-trans {_}  {_}  {_} (0ᵖ≉ ≡-refl p≈ˢq) (0ᵖ≉ ≡-refl q≈ˢr) = 0ᵖ≉ ≡-refl (≈ˢ-trans p≈ˢq q≈ˢr)
  where
  ≈ˢ-trans : Transitive _≈ˢ_
  ≈ˢ-trans (K≈ c₁≈c₂) (K≈ c₂≈c₃) = K≈ (trans c₁≈c₂ c₂≈c₃)
  ≈ˢ-trans (+≈ c₁≈c₂ ≡-refl p≈ˢq) (+≈ c₂≈c₃ ≡-refl q≈ˢr) = +≈ (trans c₁≈c₂ c₂≈c₃) ≡-refl (≈ˢ-trans p≈ˢq q≈ˢr)

infix 4 _≈ⁱ_
data _≈ⁱ_ : Polynomialⁱ → Polynomialⁱ → Set (c ⊔ˡ ℓ) where
  0≈0 : 0ⁱ ≈ⁱ 0ⁱ
  0≈+ : ∀ {c} {p} → c ≈ 0# → 0ⁱ ≈ⁱ p → 0ⁱ ≈ⁱ c +x∙ p
  +≈0 : ∀ {c} {p} → c ≈ 0# → 0ⁱ ≈ⁱ p → c +x∙ p ≈ⁱ 0ⁱ
  +≈+ : ∀ {c₁ c₂} {p q} → c₁ ≈ c₂ → p ≈ⁱ q → c₁ +x∙ p ≈ⁱ c₂ +x∙ q

infix 4 _≉ⁱ_
_≉ⁱ_ : Polynomialⁱ → Polynomialⁱ → Set (c ⊔ˡ ℓ)
p ≉ⁱ q = ¬ (p ≈ⁱ q)

≈ⁱ-refl : Reflexive _≈ⁱ_
≈ⁱ-refl {0ⁱ} = 0≈0
≈ⁱ-refl {c +x∙ p} = +≈+ refl ≈ⁱ-refl

≈ⁱ-sym : Symmetric _≈ⁱ_
≈ⁱ-sym 0≈0 = 0≈0
≈ⁱ-sym (0≈+ c≈0 0≈p) = +≈0 c≈0 0≈p
≈ⁱ-sym (+≈0 c≈0 0≈p) = 0≈+ c≈0 0≈p
≈ⁱ-sym (+≈+ c₁≈c₂ p≈q) = +≈+ (sym c₁≈c₂) (≈ⁱ-sym p≈q)

≈ⁱ-trans : Transitive _≈ⁱ_
≈ⁱ-trans 0≈0 q = q
≈ⁱ-trans (0≈+ c₁≈0 0≈p) (+≈0 c₂≈0 0≈q) = 0≈0
≈ⁱ-trans (0≈+ c₁≈0 0≈p) (+≈+ c₁≈c₂ p≈q) = 0≈+ (trans (sym c₁≈c₂) c₁≈0) (≈ⁱ-trans 0≈p p≈q)
≈ⁱ-trans (+≈0 c₁≈0 0≈p) 0≈0 = +≈0 c₁≈0 0≈p
≈ⁱ-trans (+≈0 c₁≈0 0≈p) (0≈+ c₂≈0 0≈q) = +≈+ (trans c₁≈0 (sym c₂≈0)) (≈ⁱ-trans (≈ⁱ-sym 0≈p) 0≈q)
≈ⁱ-trans (+≈+ c₁≈c₂ p≈q) (+≈0 c₂≈0 0≈q) = +≈0 (trans c₁≈c₂ c₂≈0) (≈ⁱ-trans 0≈q (≈ⁱ-sym p≈q))
≈ⁱ-trans (+≈+ c₁≈c₂ p≈q) (+≈+ c₂≈c₃ q≈r) = +≈+ (trans c₁≈c₂ c₂≈c₃) (≈ⁱ-trans p≈q q≈r)

+ᵖ-*ᵖ-rawRing : RawRing (c ⊔ˡ ℓ) (c ⊔ˡ ℓ)
+ᵖ-*ᵖ-rawRing = record
  { Carrier = Polynomial
  ; _≈_ = _≈ᵖ_
  ; _+_ = _+ᵖ_
  ; _*_ = _*ᵖ_
  ; -_ = -ᵖ_
  ; 0# = 0ᵖ
  ; 1# = 1ᵖ
  }

+ⁱ-*ⁱ-rawRing : RawRing c (c ⊔ˡ ℓ)
+ⁱ-*ⁱ-rawRing = record
  { Carrier = Polynomialⁱ
  ; _≈_ = _≈ⁱ_
  ; _+_ = _+ⁱ_
  ; _*_ = _*ⁱ_
  ; -_ = -ⁱ_
  ; 0# = 0ⁱ
  ; 1# = 1ⁱ
  }

open import AKS.Extended ≤-totalOrder
  using (module ≤ᵉ-Reasoning)
  renaming
  ( Extended to Degree
  ; _≤ᵉ_ to _≤ᵈ_
  ; ≤ᵉ-refl to ≤ᵈ-refl
  ; ≤ᵉ-trans to ≤ᵈ-trans
  )
  public
open Degree public
open _≤ᵈ_ public

module ≤ᵈ-Reasoning where
  open ≤ᵉ-Reasoning renaming (_∼⟨_⟩_ to _≤ᵈ⟨_⟩_; _∎ to _∎ᵈ; _≡⟨_⟩_ to _≡ᵈ⟨_⟩_) public

instance
  Degree-number : Number Degree
  Degree-number = record
    { Constraint = λ _ → ⊤
    ; fromNat = λ n → ⟨ n ⟩
    }

infixl 5 _⊔ᵈ_
_⊔ᵈ_ : Degree → Degree → Degree
-∞ ⊔ᵈ d₂ = d₂
⟨ d₁ ⟩ ⊔ᵈ -∞ = ⟨ d₁ ⟩
⟨ d₁ ⟩ ⊔ᵈ ⟨ d₂ ⟩ = ⟨ d₁ ⊔ℕ d₂ ⟩

infixl 5 _+ᵈ_
_+ᵈ_ : Degree → Degree → Degree
-∞ +ᵈ d₂ = -∞
⟨ d₁ ⟩ +ᵈ -∞ = -∞
⟨ d₁ ⟩ +ᵈ ⟨ d₂ ⟩ = ⟨ d₁ +ℕ d₂ ⟩

degreeˢ : Spine → ℕ
degreeˢ (K c) = 0
degreeˢ (c +x^ n ∙ p) = ⟅ n ⇓⟆ +ℕ degreeˢ p

degree : Polynomial → Degree
degree 0ᵖ = -∞
degree (x^ n ∙ p) = ⟨ n +ℕ degreeˢ p ⟩

deg : ∀ p {p≉0 : p ≉ᵖ 0ᵖ} → ℕ
deg 0ᵖ {p≉0} = contradiction ≈ᵖ-refl p≉0
deg (x^ n ∙ p) {p≉0} = n +ℕ degreeˢ p

degreeⁱ : Polynomialⁱ → Degree
degreeⁱ 0ⁱ = -∞
degreeⁱ (c +x∙ p) with degreeⁱ p
... | ⟨ n ⟩ = ⟨ suc n ⟩
... | -∞ with c ≈? 0#
...   | yes _ = -∞
...   | no  _ = 0

open import Data.String using (String; _++_)
open import Data.Nat.Show using () renaming (show to show-ℕ)

show-Polynomial : (C → String) → Polynomial → String
show-Polynomial show-c 0ᵖ = "0"
show-Polynomial show-c (x^ n ∙ p) = loop n p
  where
  loop : ℕ → Spine → String
  loop zero (K c) = show-c (proj₁ c)
  loop zero (c +x^ n ∙ p) = show-c (proj₁ c) ++ " + " ++ loop ⟅ n ⇓⟆ p
  loop (suc n) (K c) = show-c (proj₁ c) ++ " * X^" ++ show-ℕ (suc n)
  loop (suc n) (c +x^ m ∙ p) = show-c (proj₁ c) ++ " * X^" ++ show-ℕ (suc n) ++ " + " ++ loop (suc n +ℕ ⟅ m ⇓⟆) p


-- Andreas, 2018-10-18, re issue #2757
--
-- Extracted this snippet from the standard library
-- as it caused problems during work in #2757
-- (runtime erasue using 0-quantity).

-- {-# OPTIONS -v tc.lhs.unify:65 -v tc.irr:50 #-}

open import Agda.Builtin.Size

data ⊥ : Set where

mutual
  data Conat (i : Size) : Set where
    zero : Conat i
    suc : ∞Conat i → Conat i

  record ∞Conat (i : Size) : Set where
    coinductive
    field force : ∀{j : Size< i} → Conat j
open ∞Conat

infinity : ∀ {i} → Conat i
infinity = suc λ where .force → infinity

data Finite : Conat ∞ → Set where
  zero : Finite zero
  suc  : ∀ {n} → Finite (n .force) → Finite (suc n)

¬Finite∞ : Finite infinity → ⊥
¬Finite∞ (suc p) = ¬Finite∞ p

-- The problem was that the usableMod check in the
-- unifier (LHS.Unify) refuted this pattern match
-- because a runtime-erased argument ∞ (via meta-variable)
-- the the extended lambda.


{-# OPTIONS --cubical --no-import-sorts  #-}

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)-- ¬ᵗ_
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
open import Function.Base using (_∋_; _$_; it; typeOf)
open import Cubical.Foundations.Logic renaming
  ( inl to inlᵖ
  ; inr to inrᵖ
  ; _⇒_ to infixr 0 _⇒_                  -- shifting by -6
  ; _⇔_ to infixr -2 _⇔_                 --
  ; ∃[]-syntax  to infix -4 ∃[]-syntax   --
  ; ∃[∶]-syntax to infix -4 ∃[∶]-syntax  --
  ; ∀[∶]-syntax to infix -4 ∀[∶]-syntax  --
  ; ∀[]-syntax  to infix -4 ∀[]-syntax   --
  )
-- open import Cubical.Data.Unit.Base using (Unit)
open import Cubical.HITs.PropositionalTruncation.Base -- ∣_∣

open import Utils
open import MoreLogic.Reasoning
open import MoreLogic.Definitions renaming
  ( _ᵗ⇒_ to infixr 0 _ᵗ⇒_
  ; ∀ᵖ[∶]-syntax  to infix -4 ∀ᵖ[∶]-syntax
  ; ∀ᵖ〚∶〛-syntax  to infix -4 ∀ᵖ〚∶〛-syntax
  ; ∀ᵖ!〚∶〛-syntax to infix -4 ∀ᵖ!〚∶〛-syntax
  ; ∀〚∶〛-syntax   to infix -4 ∀〚∶〛-syntax
  ; Σᵖ[]-syntax   to infix -4 Σᵖ[]-syntax
  ; Σᵖ[∶]-syntax  to infix -4 Σᵖ[∶]-syntax
  ) hiding (≡ˢ-syntax)
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions hiding (_≤''_)
open import MorePropAlgebra.Consequences
open import MorePropAlgebra.Structures
open import MorePropAlgebra.Bundles

module MorePropAlgebra.Properties.PartiallyOrderedField {ℓ ℓ'} (assumptions : PartiallyOrderedField {ℓ} {ℓ'})
  (let _≡ˢ_ = λ(x y : PartiallyOrderedField.Carrier assumptions) → MoreLogic.Definitions.≡ˢ-syntax x y {PartiallyOrderedField.is-set assumptions}
       infixl 4 _≡ˢ_
  ) where

import MorePropAlgebra.Properties.AlmostPartiallyOrderedField
module AlmostPartiallyOrderedField'Properties  = MorePropAlgebra.Properties.AlmostPartiallyOrderedField   record { PartiallyOrderedField assumptions }
module AlmostPartiallyOrderedField'            =                            AlmostPartiallyOrderedField   record { PartiallyOrderedField assumptions }
-- (      AlmostPartiallyOrderedField')           =                            AlmostPartiallyOrderedField ∋ record { PartiallyOrderedField assumptions }

-- open PartiallyOrderedField assumptions renaming (Carrier to F; _-_ to _-_)

import MorePropAlgebra.Booij2020
open MorePropAlgebra.Booij2020.Chapter4 (record { PartiallyOrderedField assumptions })
open +-<-ext+·-preserves-<⇒ (PartiallyOrderedField.+-<-ext assumptions) (PartiallyOrderedField.·-preserves-< assumptions)
-- open AlmostPartiallyOrderedField'
open MorePropAlgebra.Properties.AlmostPartiallyOrderedField (record { PartiallyOrderedField assumptions })
open AlmostPartiallyOrderedField' using (_#_; _≤_)
open PartiallyOrderedField assumptions renaming (Carrier to F; _-_ to _-_) hiding (_#_; _≤_)

abstract
  #-tight : ∀ a b → [ ¬(a # b) ] → a ≡ b; _ : [ isTightˢ''' _#_ is-set ]; _ = #-tight
  #-tight = isTightˢ'''⇔isAntisymˢ _<_ is-set <-asym .snd ≤-antisym

  +-#-ext : ∀ w x y z → [ (w + x) # (y + z) ] → [ (w # y) ⊔ (x # z) ]; _ : [ is-+-#-Extensional _+_ _#_ ]; _ = +-#-ext
  -- Consider the case w + x < y + z, so that we can use (†) to obtain w < y ∨ x < z,
  --   which gives w # y ∨ x # z in either case.
  +-#-ext w x y z (inl w+x<y+z) = case +-<-ext _ _ _ _ w+x<y+z as (w < y) ⊔ (x < z) ⇒ ((w # y) ⊔ (x # z)) of λ
    { (inl w<y) → inlᵖ (inl w<y)
    ; (inr x<z) → inrᵖ (inl x<z) }
  -- The case w + x > y + z is similar.
  +-#-ext w x y z (inr y+z<w+x) = case +-<-ext _ _ _ _ y+z<w+x as (y < w) ⊔ (z < x) ⇒ ((w # y) ⊔ (x # z)) of λ
    { (inl y<w) → inlᵖ (inr y<w)
    ; (inr z<x) → inrᵖ (inr z<x) }

  ¬≤⇒≢ : ∀ x y → [ ¬(x ≤ y) ] → [ ¬(x ≡ˢ y) ]
  ¬≤⇒≢ x y ¬x≤y x≡y = ¬x≤y (subst (λ p → [ x ≤ p ]) x≡y (≤-refl x))

  ≢⇒¬¬# : ∀ x y → [ ¬(x ≡ˢ y) ] → [ ¬ ¬(x # y) ]
  ≢⇒¬¬# x y x≢y = contraposition (¬ (x # y)) (x ≡ˢ y) (#-tight x y) x≢y

  -- x ≤ y → x # y → x < y
  -- x ≤ y ≡ ¬(y ≤ x)
  -- ¬(x # y) → x ≡ y

  ¬≤⇒¬¬# : ∀ x y → [ (¬(x ≤ y)) ⇒ ¬ ¬ (x # y) ]
  ¬≤⇒¬¬# x y ¬x≤y = ≢⇒¬¬# x y $ ¬≤⇒≢ x y ¬x≤y

  ¬≤≡¬¬< : ∀ x y → ¬(x ≤ y) ≡ ¬ ¬ (y < x)
  ¬≤≡¬¬< x y = refl

  min-≤' : ∀ x y → [ (min x y ≤ x) ⊓ (min x y ≤ y) ]
  min-≤' x y = is-min x y (min x y) .fst (≤-refl (min x y))

  ¬¬<-trans : ∀ x y z → [ ¬ ¬ (x < y) ] → [ ¬ ¬ (y < z) ] → [ ¬ ¬ (x < z) ]
  ¬¬<-trans x y z ¬¬x<y ¬¬y<z = ( contraposition (¬ (x < z)) (¬ ((x < y) ⊓ (y < z)))
                                $ contraposition ((x < y) ⊓ (y < z)) (x < z)
                                $ uncurryₚ (x < y) (y < z) (x < z) (<-trans x y z)
                                ) (⊓¬¬⇒¬¬⊓ (x < y) (y < z) ¬¬x<y ¬¬y<z)

  ¬¬<-irrefl : ∀ x → [ ¬ ¬ ¬(x < x) ]
  ¬¬<-irrefl x = ¬¬-intro (¬(x < x)) (<-irrefl x)

  -- lem : ∀ (x y z : F) → {!   !}
  -- lem x y z = let f : [ x < y ] → [ (x < z) ⊔ (z < y) ]
  --                 f p = <-cotrans x y p z -- contraposition ((z ≤ x) ⊓ (y ≤ z)) (y ≤ x) $
  --                 _ = {!    !}
  --             in {! contraposition (x < y) ((x < z) ⊔ (z < y)) f ∘ deMorgan₂-back (x < z) (z < y)  !}

  -- foo : ∀(x y z w : F) → [ w < min (x · z) (y · z) ] → [ w < min x y · z ]
  -- foo x y z w = {! <-cotrans w (min x y) ? x   !}

  -- foo : ∀(x y z w : F) → [ w < min (x · z) (y · z) ] → [ w < min x y · z ]

  min-<-⊔ : ∀ x y z → [ min x y < z ] → [ (x < z) ⊔ (y < z) ]
  min-<-⊔ x y z mxy<z = case <-cotrans (min x y) z mxy<z x as (min x y < x) ⊔ (x < z) ⇒ (x < z) ⊔ (y < z) of λ
    { (inl p) → case <-cotrans (min x y) z mxy<z y as (min x y < y) ⊔ (y < z) ⇒ (x < z) ⊔ (y < z) of λ
      { (inl q) → -- We know that
                  --   x ≤ min(x, y) ⇔ x ≤ x ∧ x ≤ y,
                  --   y ≤ min(x, y) ⇔ y ≤ x ∧ y ≤ y.
                  -- By the fact that min(x, y) < x and min(x, y) < y, the left hand sides of these claims are false,
                  -- and hence we have ¬(x ≤ y) and ¬(y ≤ x), which together contradict that < is transitive and
                  -- irreflexive.
                  let (mxy≤x , mxy≤y) = is-min x y (min x y) .fst (<-irrefl (min x y))
                      r = contraposition ((x ≤ x) ⊓ (x ≤ y)) (¬ (min x y < x)) (is-min x y x .snd) (¬¬-intro (min x y < x) p)
                      ¬x≤y = implication (x ≤ x) (x ≤ y) r (≤-refl x)
                      s = contraposition ((y ≤ x) ⊓ (y ≤ y)) (¬ (min x y < y)) (is-min x y y .snd) (¬¬-intro (min x y < y) q)
                      ¬y≤x = ¬-⊓-distrib (y ≤ x) (y ≤ y) s .snd (≤-refl y)
                  in  ⊥-elim {A = λ _ → [ (x < z) ⊔ (y < z) ]} $ ¬¬<-irrefl x (¬¬<-trans x y x ¬y≤x ¬x≤y)
      ; (inr q) → inrᵖ q
      }
    ; (inr p) → inlᵖ p
    }

  -- is this provable?
  -- min-≤-⊔ : ∀ x y z → [ min x y ≤ z ] → [ (x ≤ z) ⊔ (y ≤ z) ]
  -- min-≤-⊔ x y z mxy≤z = {!   !}

  -- lem : ∀ w x y z → [ w ≤ (x + z) ] → [ w ≤ (y + z) ] → [ w ≤ (min x y + z) ]
  -- lem w x y z w≤x+z w≤y+z mxy+z<w = {! +-<-ext (min x y) z 0f w  !}

-- Properties.PartiallyOrderedField assumptions
--   opens PartiallyOrderedField assumptions
--     opens IsPartiallyOrderedField is-PartiallyOrderedField public
--       opens IsAlmostPartiallyOrderedField is-AlmostPartiallyOrderedField public
--         contains definition of _#_
--           becomes `_#_`
--   opens MorePropAlgebra.Properties.AlmostPartiallyOrderedField assumptions
--     opens AlmostPartiallyOrderedField assumptions
--       opens IsAlmostPartiallyOrderedField is-AlmostPartiallyOrderedField public
--         contains definition of _#_
--           becomes `AlmostPartiallyOrderedField'._#_`

-- all these become `_#_`
--   _#_
--   PartiallyOrderedField._#_ assumptions
--   IsPartiallyOrderedField._#_ (PartiallyOrderedField.is-PartiallyOrderedField assumptions)
--   IsAlmostPartiallyOrderedField._#_ (IsPartiallyOrderedField.is-AlmostPartiallyOrderedField (PartiallyOrderedField.is-PartiallyOrderedField assumptions))
-- but
--   PartiallyOrderedField._#_ (record { PartiallyOrderedField assumptions })
-- becomes
--   PartiallyOrderedField._#_ record { Carrier = F ; 0f = 0f ; 1f = 1f ; _+_ = _+_ ; -_ = -_ ; _·_ = _·_ ; min = min ; max = max ; _<_ = _<_ ; is-PartiallyOrderedField = is-PartiallyOrderedField }
-- when we define
--   foo = PartiallyOrderedField ∋ (record { PartiallyOrderedField assumptions })
-- then
--   PartiallyOrderedField._#_ foo
-- becomes
--   (foo PartiallyOrderedField.# x)

-- foo = PartiallyOrderedField ∋ (record { PartiallyOrderedField assumptions })
--
-- test : ∀ x y → [ (PartiallyOrderedField._#_ foo) x y ]
-- test = {! ·-inv''  !}


{-# OPTIONS --safe #-}

module Cubical.Data.Queue where

open import Cubical.Data.Queue.Base public
open import Cubical.Data.Queue.Finite public


module InstanceArguments where

postulate A₁ A₂ B : Set
          f₁ : {{a : A₁}} → B
          f₂ : {{a : A₂}} → B
          a₁ : A₁

-- resolve from signature
test₁ : B
test₁ = f₁

-- resolve from context
test₂ : {{a : A₂}} → B
test₂ = f₂

postulate F : Set → Set
          fA₁ : F A₁
          fA₂ : F A₂
          f₃ : {A : Set} → {{fA : F A}} → A → B

test₃ : B
test₃ = f₃ a₁

record Rec (t : Set) : Set₁ where
       field
         v : t

open module RecWI {t : Set} {{r : Rec t}} = Rec r

postulate testT₁ : Set
          testV₁ : testT₁
          testT₂ : Set
          testV₂ : testT₂

testRec₁ : Rec testT₁
testRec₁ = record { v = testV₁ }
testRec₂ : Rec testT₂
testRec₂ = record { v = testV₂ }

-- needs constraint checking in instance argument resolution
test : testT₂
test = v


{-# OPTIONS --without-K --safe #-}

module Cham.Context where

open import Cham.Name
open import Cham.Label
open import Data.Product

infix 5 _⊢_
data Context : Set where
  ∅  : Context
  _⊢_ : Context → Label → Context
  _,_ : Context → Context → Context

rename : (Name → Label) → Context → Context
rename ϕ ∅           = ∅
rename ϕ (Γ ⊢ (N ⁺)) = rename ϕ Γ ⊢ ϕ N
rename ϕ (Γ ⊢ (N ⁻)) = rename ϕ Γ ⊢ ϕ N
rename ϕ (Γ₁ , Γ₂)   = rename ϕ Γ₁ , rename ϕ Γ₂

permeate : Context → Context → Context
permeate ∅ Γ₂        = Γ₂
permeate (Γ₁ ⊢ N) Γ₂ = permeate Γ₁ (Γ₂ ⊢ N)
permeate (Γ₁ , Γ₂) Γ₃ = Γ₁ , Γ₂ , Γ₃


{-# OPTIONS --prop --rewriting #-}

open import Examples.Sorting.Parallel.Comparable

module Examples.Sorting.Parallel.Core (M : Comparable) where

open import Calf.CostMonoid
open ParCostMonoid parCostMonoid
  hiding (costMonoid)
  renaming (
    _≤_ to _≤ₚ_;
    ≤-refl to ≤ₚ-refl;
    ≤-trans to ≤ₚ-trans;
    module ≤-Reasoning to ≤ₚ-Reasoning
  ) public

open import Examples.Sorting.Core costMonoid fromℕ M public


{-# OPTIONS --without-K --rewriting #-}

open import HoTT
open import cohomology.Theory
open import groups.ExactSequence
open import groups.Exactness
open import groups.HomSequence
open import groups.KernelImageUniqueFactorization
import cw.cohomology.GridPtdMap as GPM

open import cw.CW

module cw.cohomology.HigherCohomologyGroupsOnDiag {i} (OT : OrdinaryTheory i)
  {n} (⊙skel : ⊙Skeleton {i} (S (S n))) (ac : ⊙has-cells-with-choice 0 ⊙skel i) where

private
  n≤SSn : n ≤ S (S n)
  n≤SSn = lteSR lteS

  ⊙skel₋₁ = ⊙cw-init ⊙skel
  ac₋₁ = ⊙init-has-cells-with-choice ⊙skel ac

  ⊙skel₋₂ = ⊙cw-take n≤SSn ⊙skel
  ac₋₂ = ⊙take-has-cells-with-choice n≤SSn ⊙skel ac

open OrdinaryTheory OT
open import cw.cohomology.Descending OT
open import cw.cohomology.WedgeOfCells OT
open import cw.cohomology.HigherCoboundary OT ⊙skel
open import cw.cohomology.HigherCoboundaryGrid OT ⊙skel ac

{-

   Coker ≃ C(X₂/X₀) ≃ C(X)
              ^
              |
              |
           C(X₁/X₀)
             WoC

    WoC := Wedges of Cells
-}

private

  C-apex : Group i
  C-apex = C (ℕ-to-ℤ (S (S n))) (⊙Cofiber (⊙cw-incl-tail n≤SSn ⊙skel))

  open import cohomology.LongExactSequence cohomology-theory
    (ℕ-to-ℤ (S n)) (⊙cw-incl-tail n≤SSn ⊙skel)

  C-apex-iso-C-cw : C-apex ≃ᴳ C (ℕ-to-ℤ (S (S n))) ⊙⟦ ⊙skel ⟧
  C-apex-iso-C-cw = Exact2.G-trivial-and-L-trivial-implies-H-iso-K
    (exact-seq-index 1 C-cofiber-exact-seq)
    (exact-seq-index 2 C-cofiber-exact-seq)
    (C-cw-at-higher ⊙skel₋₂ ltS ac₋₂)
    (C-cw-at-higher ⊙skel₋₂ (ltSR ltS) ac₋₂)

open import groups.KernelImage (cst-hom {H = Lift-group {j = i} Unit-group}) cw-co∂-last
  (CXₙ/Xₙ₋₁-is-abelian ⊙skel (ℕ-to-ℤ (S (S n))))
open import groups.KernelCstImage (Lift-group {j = i} Unit-group) cw-co∂-last
  (CXₙ/Xₙ₋₁-is-abelian ⊙skel (ℕ-to-ℤ (S (S n))))

C-cw-iso-ker/im : C (ℕ-to-ℤ (S (S n))) ⊙⟦ ⊙skel ⟧ ≃ᴳ Ker/Im
C-cw-iso-ker/im = (C-apex-iso-C-cw ∘eᴳ Coker-cw-co∂-last ∘eᴳ Ker-cst-quot-Im) ⁻¹ᴳ


{-# OPTIONS --without-K --rewriting #-}

open import HoTT renaming (pt to pt⊙)
open import cw.CW

module cw.FinCW where

record AttachedFinSkeleton n (Skel : Type₀) (Real : Skel → Skeleton n) : Type₀ where
  constructor attached-fin-skeleton
  field
    skel : Skel
    numCells : ℕ
    attaching : Attaching ⟦ Real skel ⟧ (Fin numCells) (Sphere n)

FinSkeleton : ℕ → Type₀
FinSkeleton-realize : {n : ℕ} → FinSkeleton n → Skeleton n

FinSkeleton O = ℕ
FinSkeleton (S n) = AttachedFinSkeleton n (FinSkeleton n) FinSkeleton-realize

FinSkeleton-realize {n = O} n = Fin n , Fin-is-set
FinSkeleton-realize {n = S n} (attached-fin-skeleton _ s α) =
  attached-skeleton _ (Fin s , Fin-is-set) α

⦉_⦊ = FinSkeleton-realize

-- Pointedness

-- this function is needed for pointedness
fcw-head : ∀ {n : ℕ} → FinSkeleton n → Type₀
fcw-head = cw-head ∘ FinSkeleton-realize

fcw-head-has-dec-eq : ∀ {n : ℕ} (fin-skel : FinSkeleton n)
  → has-dec-eq (fcw-head fin-skel)
fcw-head-has-dec-eq {n = 0} _ = Fin-has-dec-eq
fcw-head-has-dec-eq {n = S n} (attached-fin-skeleton skel _ _) =
  fcw-head-has-dec-eq skel

-- this function is needed for pointedness
fcw-incl^ : ∀ {n : ℕ} (skel : FinSkeleton n)
  → fcw-head skel → ⟦ ⦉ skel ⦊ ⟧
fcw-incl^ fin-skel = incl^ (FinSkeleton-realize fin-skel)

-- disjointly pointed skeletons
record ⊙FinSkeleton (n : ℕ) : Type₁ where
  constructor ⊙fin-skeleton
  field
    skel : FinSkeleton n
    pt : fcw-head skel

⊙FinSkeleton-realize : {n : ℕ} → ⊙FinSkeleton n → ⊙Skeleton {i = lzero} n
⊙FinSkeleton-realize (⊙fin-skeleton skel pt) =
  ⊙skeleton (FinSkeleton-realize skel) pt (fcw-head-has-dec-eq skel pt)

⊙⦉_⦊ : {n : ℕ} → ⊙FinSkeleton n → ⊙Skeleton {i = lzero} n
⊙⦉_⦊ = ⊙FinSkeleton-realize

-- Take a prefix of a skeleton

fcw-init : ∀ {n} → FinSkeleton (S n) → FinSkeleton n
fcw-init (attached-fin-skeleton skel _ _) = skel

⊙fcw-init : ∀ {n} → ⊙FinSkeleton (S n) → ⊙FinSkeleton n
⊙fcw-init (⊙fin-skeleton skel pt) = ⊙fin-skeleton (fcw-init skel) pt

-- Extra conditions on CW complexes

-- 1. decidable equalities

FinSkeleton-has-cells-with-dec-eq : ∀ {n} (fin-skel : FinSkeleton n)
  → has-cells-with-dec-eq (FinSkeleton-realize fin-skel)
FinSkeleton-has-cells-with-dec-eq {n = O} fin-skel = Fin-has-dec-eq
FinSkeleton-has-cells-with-dec-eq {n = S n} fin-skel =
  FinSkeleton-has-cells-with-dec-eq (fcw-init fin-skel) , Fin-has-dec-eq

⊙FinSkeleton-has-cells-with-dec-eq : ∀ {n} (⊙fin-skel : ⊙FinSkeleton n)
  → ⊙has-cells-with-dec-eq (⊙FinSkeleton-realize ⊙fin-skel)
⊙FinSkeleton-has-cells-with-dec-eq ⊙fin-skel = FinSkeleton-has-cells-with-dec-eq _

-- 2. choice

FinSkeleton-has-cells-with-choice : ∀ t {n} (fin-skel : FinSkeleton n) j
  → has-cells-with-choice t (FinSkeleton-realize fin-skel) j
FinSkeleton-has-cells-with-choice t {n = O} fin-skel j = Fin-has-choice t j
FinSkeleton-has-cells-with-choice t {n = S n} fin-skel j =
  FinSkeleton-has-cells-with-choice t (fcw-init fin-skel) j , Fin-has-choice t j

⊙FinSkeleton-has-cells-with-choice : ∀ t {n} (fin-skel : ⊙FinSkeleton n) j
  → ⊙has-cells-with-choice t (⊙FinSkeleton-realize fin-skel) j
⊙FinSkeleton-has-cells-with-choice t fin-skel j = FinSkeleton-has-cells-with-choice t _ j


module LC.Reasoning where

open import LC.Base
open import LC.Reduction

open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties using (preorder)
open import Relation.Binary.Reasoning.Preorder (preorder _β→_)
open import Relation.Binary.Reasoning.Preorder (preorder _β→_) using (begin_; step-≡; _∎; _≡⟨⟩_) public

infixr 2 _→*⟨_⟩_
_→*⟨_⟩_ : ∀ (x : Term) {y z} → x β→* y → y IsRelatedTo z → x IsRelatedTo z
x →*⟨ P ⟩ y = x ∼⟨ P ⟩ y

infixr 2 _→⟨_⟩_
_→⟨_⟩_ : ∀ (x : Term) {y z} → x β→ y → y IsRelatedTo z → x IsRelatedTo z
x →⟨ P ⟩ y = x ∼⟨ return P ⟩ y

infixr 2 _→⟨⟩_
_→⟨⟩_ : ∀ (x : Term) {y} → x IsRelatedTo y → x IsRelatedTo y
x →⟨⟩ y = x ∼⟨ ε ⟩ y


open import Common.Level

postulate
  ℓ : Level

data D : Set (lsuc ℓ) where
  c : (ℓ : Level) → Set ℓ → D

-- Bad error:
-- The type of the constructor does not fit in the sort of the
-- datatype, since Set (lsuc ℓ) is not less or equal than Set (lsuc ℓ)
-- when checking the constructor c in the declaration of D


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Groups.Torus where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.Groups.Prelims

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv

open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +Comm to +ℤ-comm ; +Assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.Data.Unit
open import Cubical.Algebra.Group renaming (ℤ to ℤGroup ; Bool to BoolGroup ; Unit to UnitGroup)

open import Cubical.HITs.Pushout
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2) hiding (map)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim2 to pElim2 ; ∣_∣ to ∣_∣₁) hiding (map)
open import Cubical.HITs.Nullification
open import Cubical.HITs.Truncation renaming (elim to trElim ; elim2 to trElim2 ; map to trMap ; rec to trRec)
open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.Loopspace

open IsGroupHom
open Iso

-- The following section contains stengthened induction principles for cohomology groups of T². They are particularly useful for showing that
-- that some Isos are morphisms. They make things type-check faster, but should probably not be used for computations.

-- We first need some functions
elimFunT² : (n : ℕ) (p q : typ (Ω (coHomK-ptd (suc n))))
                  → Square q q p p
                  → S¹ × S¹ → coHomK (suc n)
elimFunT² n p q P (base , base) = ∣ ptSn (suc n) ∣
elimFunT² n p q P (base , loop i) = q i
elimFunT² n p q P (loop i , base) = p i
elimFunT² n p q P (loop i , loop j) = P i j

elimFunT²' : (n : ℕ) → Square (refl {ℓ-zero} {coHomK (suc n)} {∣ ptSn (suc n) ∣}) refl refl refl
           → S¹ × S¹ → coHomK (suc n)
elimFunT²' n P (x , base) = ∣ ptSn (suc n) ∣
elimFunT²' n P (base , loop j) = ∣ ptSn (suc n) ∣
elimFunT²' n P (loop i , loop j) = P i j

elimFunT²'≡elimFunT² : (n : ℕ) → (P : _) → elimFunT²' n P ≡ elimFunT² n refl refl P
elimFunT²'≡elimFunT² n P i (base , base) = ∣ ptSn (suc n) ∣
elimFunT²'≡elimFunT² n P i (base , loop k) = ∣ ptSn (suc n) ∣
elimFunT²'≡elimFunT² n P i (loop j , base) = ∣ ptSn (suc n) ∣
elimFunT²'≡elimFunT² n P i (loop j , loop k) = P j k

{-
The first induction principle says that when proving a proposition for some x : Hⁿ(T²), n ≥ 1, it suffices to show that it holds for
(elimFunT² p q P) for any paths p q : ΩKₙ, and square P : Square q q p p. This is useful because elimFunT² p q P (base , base) recudes to 0
-}

coHomPointedElimT² : ∀ {ℓ} (n : ℕ) {B : coHom (suc n) (S¹ × S¹) → Type ℓ}
                 → ((x : coHom (suc n) (S¹ × S¹)) → isProp (B x))
                 → ((p q : _) (P : _) → B ∣ elimFunT² n p q P ∣₂)
                 → (x : coHom (suc n) (S¹ × S¹)) → B x
coHomPointedElimT² n {B = B} isprop indp =
  coHomPointedElim _ (base , base) isprop
    λ f fId → subst B (cong ∣_∣₂ (funExt (λ { (base , base) → sym fId
                                           ; (base , loop i) j → helper f fId i1 i (~ j)
                                           ; (loop i , base) j → helper f fId i i1 (~ j)
                                           ; (loop i , loop j) k → helper f fId i j (~ k)})))
                       (indp (λ i → helper f fId i i1 i1)
                             (λ i → helper f fId i1 i i1)
                              λ i j → helper f fId i j i1)
    where
    helper : (f : S¹ × S¹ → coHomK (suc n)) → f (base , base) ≡ ∣ ptSn (suc n) ∣
           → I → I → I → coHomK (suc n)
    helper f fId i j k =
      hfill (λ k → λ {(i = i0) → doubleCompPath-filler (sym fId) (cong f (λ i → (base , loop i))) fId k j
                     ; (i = i1) → doubleCompPath-filler (sym fId) (cong f (λ i → (base , loop i))) fId k j
                     ; (j = i0) → doubleCompPath-filler (sym fId) (cong f (λ i → (loop i , base))) fId k i
                     ; (j = i1) → doubleCompPath-filler (sym fId) (cong f (λ i → (loop i , base))) fId k i})
            (inS (f ((loop i) , (loop j))))
            k

private
  lem : ∀ {ℓ} (n : ℕ) {B : coHom (2 + n) (S¹ × S¹) → Type ℓ}
                   → ((P : _) → B ∣ elimFunT² (suc n) refl refl P ∣₂)
                   → (p : _) → (refl ≡ p)
                   → (q : _) → (refl ≡ q)
                   → (P : _)
                   → B ∣ elimFunT² (suc n) p q P ∣₂
  lem n {B = B} elimP p =
    J (λ p _ → (q : _) → (refl ≡ q)
             → (P : _)
             → B ∣ elimFunT² (suc n) p q P ∣₂)
      λ q →
        J (λ q _ → (P : _) → B ∣ elimFunT² (suc n) refl q P ∣₂)
           elimP

{- When working with Hⁿ(T²) , n ≥ 2, we are, in the case described above, allowed to assume that any f : Hⁿ(T²) is
   elimFunT² n refl refl P -}
coHomPointedElimT²' : ∀ {ℓ} (n : ℕ) {B : coHom (2 + n) (S¹ × S¹) → Type ℓ}
                 → ((x : coHom (2 + n) (S¹ × S¹)) → isProp (B x))
                 → ((P : _) → B ∣ elimFunT² (suc n) refl refl P ∣₂)
                 → (x : coHom (2 + n) (S¹ × S¹)) → B x
coHomPointedElimT²' n {B = B} prop ind =
  coHomPointedElimT² (suc n) prop
    λ p q P → trRec (isProp→isOfHLevelSuc n (prop _))
      (λ p-refl → trRec (isProp→isOfHLevelSuc n (prop _))
                         (λ q-refl → lem n {B = B} ind p (sym p-refl) q (sym q-refl) P)
      (isConnectedPath _ (isConnectedPathKn (suc n) _ _) q refl .fst))
      (isConnectedPath _ (isConnectedPathKn (suc n) _ _) p refl .fst)

{- A slight variation of the above which gives definitional equalities for all points (x , base) -}
private
  coHomPointedElimT²'' : ∀ {ℓ} (n : ℕ) {B : coHom (2 + n) (S¹ × S¹) → Type ℓ}
                   → ((x : coHom (2 + n) (S¹ × S¹)) → isProp (B x))
                   → ((P : _) → B ∣ elimFunT²' (suc n) P ∣₂)
                   → (x : coHom (2 + n) (S¹ × S¹)) → B x
  coHomPointedElimT²'' n {B = B} prop ind =
    coHomPointedElimT²' n prop λ P → subst (λ x → B ∣ x ∣₂)
                        (elimFunT²'≡elimFunT² (suc n) P) (ind P)

--------- H⁰(T²) ------------
H⁰-T²≅ℤ : GroupIso (coHomGr 0 (S₊ 1 × S₊ 1)) ℤGroup
H⁰-T²≅ℤ =
  H⁰-connected (base , base)
    λ (a , b) → pRec isPropPropTrunc
                     (λ id1 → pRec isPropPropTrunc
                                   (λ id2 → ∣ ΣPathP (id1 , id2) ∣₁)
                                   (Sn-connected 0 b) )
                     (Sn-connected 0 a)

--------- H¹(T²) -------------------------------

H¹-T²≅ℤ×ℤ : GroupIso (coHomGr 1 ((S₊ 1) × (S₊ 1))) (DirProd ℤGroup ℤGroup)
H¹-T²≅ℤ×ℤ = theIso □ GroupIsoDirProd (Hⁿ-Sⁿ≅ℤ 0) (H⁰-Sⁿ≅ℤ 0)
  where
  typIso : Iso _ _
  typIso = setTruncIso (curryIso ⋄ codomainIso S1→K₁≡S1×ℤ ⋄ toProdIso)
                      ⋄ setTruncOfProdIso

  theIso : GroupIso _ _
  fst theIso = typIso
  snd theIso =
    makeIsGroupHom
      (coHomPointedElimT² _ (λ _ → isPropΠ λ _ → isSet× isSetSetTrunc isSetSetTrunc _ _)
        λ pf qf Pf →
        coHomPointedElimT² _ (λ _ → isSet× isSetSetTrunc isSetSetTrunc _ _)
          λ pg qg Pg i → ∣ funExt (helperFst pf qf pg qg Pg Pf) i  ∣₂
                        , ∣ funExt (helperSnd pf qf pg qg Pg Pf) i ∣₂)
     where
       module _ (pf qf pg qg : 0ₖ 1 ≡ 0ₖ 1) (Pg : Square qg qg pg pg) (Pf : Square qf qf pf pf) where
         helperFst : (x : S¹)
                → fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pf qf Pf (x , y) +ₖ elimFunT² 0 pg qg  Pg (x , y)) .fst
                 ≡ fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pf qf Pf (x , y)) .fst
                +ₖ fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pg qg  Pg (x , y)) .fst
         helperFst base = refl
         helperFst (loop i) j = loopLem j i
           where
           loopLem : cong (λ x → fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pf qf Pf (x , y) +ₖ elimFunT² 0 pg qg  Pg (x , y)) .fst) loop
                   ≡ cong (λ x → fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pf qf Pf (x , y)) .fst
                               +ₖ fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pg qg  Pg (x , y)) .fst) loop
           loopLem = (λ i j → S¹map-id (pf j +ₖ pg j) i)
                   ∙ (λ i j → S¹map-id (pf j) (~ i) +ₖ S¹map-id (pg j) (~ i))

         helperSnd : (x : S¹)
                → fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pf qf Pf (x , y) +ₖ elimFunT² 0 pg qg  Pg (x , y)) .snd
                ≡ fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pf qf Pf (x , y)) .snd +ℤ fun S1→K₁≡S1×ℤ (λ y → elimFunT² 0 pg qg  Pg (x , y)) .snd
         helperSnd =
           toPropElim (λ _ → isSetℤ _ _)
                      ((λ i → winding (basechange2⁻ base λ j → S¹map (∙≡+₁ qf qg (~ i) j)))
                    ∙∙ cong (winding ∘ basechange2⁻ base) (congFunct S¹map qf qg)
                    ∙∙ (cong winding (basechange2⁻-morph base (cong S¹map qf) (cong S¹map qg))
                      ∙ winding-hom (basechange2⁻ base (cong S¹map qf)) (basechange2⁻ base (cong S¹map qg))))

----------------------- H²(T²) ------------------------------

H²-T²≅ℤ : GroupIso (coHomGr 2 (S₊ 1 × S₊ 1)) ℤGroup
H²-T²≅ℤ = compGroupIso helper2 (Hⁿ-Sⁿ≅ℤ 0)
  where
  helper : Iso (∥ ((a : S¹) → coHomK 2) ∥₂ × ∥ ((a : S¹) → coHomK 1) ∥₂) (coHom 1 S¹)
  inv helper s = 0ₕ _ , s
  fun helper = snd
  leftInv helper _ =
    ΣPathP (isOfHLevelSuc 0 (isOfHLevelRetractFromIso 0 (fst (Hⁿ-S¹≅0 0)) (isContrUnit)) _ _
          , refl)
  rightInv helper _ = refl
  theIso : Iso (coHom 2 (S¹ × S¹)) (coHom 1 S¹)
  theIso = setTruncIso (curryIso ⋄ codomainIso S1→K2≡K2×K1 ⋄ toProdIso)
         ⋄ setTruncOfProdIso
         ⋄ helper

  helper2 : GroupIso (coHomGr 2 (S¹ × S¹)) (coHomGr 1 S¹)
  helper2 .fst = theIso
  helper2 .snd = makeIsGroupHom (
    coHomPointedElimT²'' 0 (λ _ → isPropΠ λ _ → isSetSetTrunc _ _)
      λ P → coHomPointedElimT²'' 0 (λ _ → isSetSetTrunc _ _)
      λ Q → ((λ i → ∣ (λ a → ΩKn+1→Kn 1 (sym (rCancel≡refl 0 i)
                                        ∙∙ cong (λ x → (elimFunT²' 1 P (a , x) +ₖ elimFunT²' 1 Q (a , x)) -ₖ ∣ north ∣) loop
                                        ∙∙ rCancel≡refl 0 i)) ∣₂))
          ∙∙ (λ i → ∣ (λ a → ΩKn+1→Kn 1 (rUnit (cong (λ x → rUnitₖ 2 (elimFunT²' 1 P (a , x) +ₖ elimFunT²' 1 Q (a , x)) i) loop) (~ i))) ∣₂)
          ∙∙ (λ i → ∣ (λ a → ΩKn+1→Kn 1 (∙≡+₂ 0 (cong (λ x → elimFunT²' 1 P (a , x)) loop) (cong (λ x → elimFunT²' 1 Q (a , x)) loop) (~ i))) ∣₂)
          ∙∙ (λ i → ∣ (λ a → ΩKn+1→Kn-hom 1 (cong (λ x → elimFunT²' 1 P (a , x)) loop) (cong (λ x → elimFunT²' 1 Q (a , x)) loop) i) ∣₂)
          ∙∙ (λ i → ∣ ((λ a → ΩKn+1→Kn 1 (rUnit (cong (λ x → rUnitₖ 2 (elimFunT²' 1 P (a , x)) (~ i)) loop) i)
                                           +ₖ ΩKn+1→Kn 1 (rUnit (cong (λ x → rUnitₖ 2 (elimFunT²' 1 Q (a , x)) (~ i)) loop) i))) ∣₂)
           ∙ (λ i → ∣ ((λ a → ΩKn+1→Kn 1 (sym (rCancel≡refl 0 (~ i))
                                                         ∙∙ cong (λ x → elimFunT²' 1 P (a , x) +ₖ ∣ north ∣) loop
                                                         ∙∙ rCancel≡refl 0 (~ i))
                                           +ₖ ΩKn+1→Kn 1 (sym (rCancel≡refl 0 (~ i))
                                                         ∙∙ cong (λ x → elimFunT²' 1 Q (a , x) +ₖ ∣ north ∣) loop
                                                         ∙∙ rCancel≡refl 0 (~ i)))) ∣₂))
-- >>>>>>> master

private
  to₂ : coHom 2 (S₊ 1 × S₊ 1) → ℤ
  to₂ = fun (fst H²-T²≅ℤ)

  from₂ : ℤ → coHom 2 (S₊ 1 × S₊ 1)
  from₂ = inv (fst H²-T²≅ℤ)

  to₁ : coHom 1 (S₊ 1 × S₊ 1) → ℤ × ℤ
  to₁ = fun (fst H¹-T²≅ℤ×ℤ)

  from₁ : ℤ × ℤ → coHom 1 (S₊ 1 × S₊ 1)
  from₁ = inv (fst H¹-T²≅ℤ×ℤ)

  to₀ : coHom 0 (S₊ 1 × S₊ 1) → ℤ
  to₀ = fun (fst H⁰-T²≅ℤ)

  from₀ : ℤ → coHom 0 (S₊ 1 × S₊ 1)
  from₀ = inv (fst H⁰-T²≅ℤ)

{-
-- Compute fast:
test : to₁ (from₁ (0 , 1) +ₕ from₁ (1 , 0)) ≡ (1 , 1)
test = refl

test2 : to₁ (from₁ (5 , 1) +ₕ from₁ (-2 , 3)) ≡ (3 , 4)
test2 = refl

-- Compute pretty fast

test3 : to₂ (from₂ 1) ≡ 1
test3 = refl

test4 : to₂ (from₂ 2) ≡ 2
test4 = refl

test5 : to₂ (from₂ 3) ≡ 3
test5 = refl

-- Compute, but slower

test6 : to₂ (from₂ 0 +ₕ from₂ 0) ≡ 0
test6 = refl

test6 : to₂ (from₂ 0 +ₕ from₂ 1) ≡ 1
test6 = refl

-- Does not compute
test7 : to₂ (from₂ 1 +ₕ from₂ 0) ≡ 1
test7 = refl
-}


module PiQ.SAT where
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Data.Nat
open import Data.Nat.Properties
open import Data.List as L
open import Data.Maybe
open import Relation.Binary.PropositionalEquality
open import PiQ.Syntax
open import PiQ.Eval
open import PiQ.Examples

-- Given reversible F : 𝔹^n ↔ 𝔹^n, generate a circuit to find x̅ such that F(x̅) = (𝔽,…)
-- via running (LOOP F)(𝔽,𝔽̅).
-- (id↔ ⊗ F)((LOOP F)(𝔽,𝔽̅)) = (𝔽,𝔽,…)
LOOP : ∀ {n} → 𝔹^ n ↔ 𝔹^ n → 𝔹 ×ᵤ 𝔹^ n ↔ 𝔹 ×ᵤ 𝔹^ n
LOOP {0} F = id↔
LOOP {1} F = id↔ ⊗ F
LOOP {suc (suc n)} F = trace₊ ((dist ⊕ id↔) ⨾ [A+B]+C=[A+C]+B ⨾ (factor ⊕ id↔) ⨾
                               ((RESET ⨾ (id↔ ⊗ F) ⨾ COPY ⨾ (id↔ ⊗ ! F)) ⊕ id↔) ⨾
                               (dist ⊕ id↔) ⨾ [A+B]+C=[A+C]+B ⨾ (factor ⊕ (id↔ ⊗ INCR)))

MERGE : (n m : ℕ) → 𝔹^ n ×ᵤ 𝔹^ m ↔ 𝔹^ (n + m)
MERGE 0 m = unite⋆l
MERGE 1 0 = unite⋆r
MERGE 1 (suc m) = id↔
MERGE (suc (suc n)) m = assocr⋆ ⨾ (id↔ ⊗ MERGE (suc n) m)

SPLIT : (n m : ℕ) → 𝔹^ (n + m) ↔ 𝔹^ n ×ᵤ 𝔹^ m
SPLIT n m = ! MERGE n m

~_ : ∀ {n} → 𝔹^ (1 + n) ↔ 𝔹^ (1 + n) → 𝔹^ (1 + n) ↔ 𝔹^ (1 + n)
~_ {zero} F = F
~_ {suc n} F = F ⨾ NOT ⊗ id↔

-- Given a function G : 𝔹^n → 𝔹 there exists a reversible Gʳ : 𝔹^(1+n) ↔ 𝔹^(1+n) such that Gʳ(𝔽,xⁿ) = (F(xⁿ),…)
-- SAT(Gʳ) = tt iff ∃ xⁿ . G(xⁿ) = 𝕋
SAT : ∀ {n} → 𝔹^ (1 + n) ↔ 𝔹^ (1 + n) → 𝟙 ↔ 𝟙
SAT {n} Gʳ = trace⋆ (𝔽^ (3 + n)) (id↔ ⊗ ((id↔ ⊗ (LOOP (~ Gʳ) ⨾ (id↔ ⊗ SPLIT 1 n))) ⨾
                                         (id↔ ⊗ (assocl⋆ ⨾ (COPY ⊗ id↔) ⨾ assocr⋆)) ⨾
                                         assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                                         (id↔ ⊗ ((id↔ ⊗ MERGE 1 n) ⨾ LOOP⁻¹ (~ Gʳ)))))
    where
    LOOP⁻¹ : ∀ {n} → 𝔹^ n ↔ 𝔹^ n → 𝔹 ×ᵤ 𝔹^ n ↔ 𝔹 ×ᵤ 𝔹^ n
    LOOP⁻¹ F = ! (LOOP F)

module SAT_test where
  -- Examples
  -- AND(𝔽,a,b) = AND(a∧b,a,b)
  AND : 𝔹^ 3 ↔ 𝔹^ 3
  AND = FST2LAST ⨾ (dist ⨾ (id↔ ⊕ (id↔ ⊗ (dist ⨾ (id↔ ⊕ (id↔ ⊗ swap₊)) ⨾ factor))) ⨾ factor) ⨾ FST2LAST⁻¹

  NAND : 𝔹^ 3 ↔ 𝔹^ 3
  NAND = AND ⨾ (NOT ⊗ id↔)

  -- OR(𝔽,a,b) = OR(a∨b,a,b)
  OR : 𝔹^ 3 ↔ 𝔹^ 3
  OR = FST2LAST ⨾ (dist ⨾ ((id↔ ⊗ (dist ⨾ (id↔ ⊕ (id↔ ⊗ swap₊)) ⨾ factor)) ⊕ (id↔ ⊗ (id↔ ⊗ swap₊))) ⨾ factor) ⨾ FST2LAST⁻¹

  NOR : 𝔹^ 3 ↔ 𝔹^ 3
  NOR = OR ⨾ (NOT ⊗ id↔)

  -- XOR(a,b) = XOR(a xor b,b)
  XOR : 𝔹^ 2 ↔ 𝔹^ 2
  XOR = distl ⨾ (id↔ ⊕ (swap₊ ⊗ id↔)) ⨾ factorl

  tests : List ⟦ 𝔹^ 3 ⟧
  tests = (𝔽 , 𝔽 , 𝔽) ∷ (𝔽 , 𝔽 , 𝕋) ∷ (𝔽 , 𝕋 , 𝔽) ∷ (𝔽 , 𝕋 , 𝕋) ∷ (𝕋 , 𝔽 , 𝔽) ∷ (𝕋 , 𝔽 , 𝕋) ∷ (𝕋 , 𝕋 , 𝔽) ∷ (𝕋 , 𝕋 , 𝕋) ∷ []

  -- Ex₁(𝔽,a,b) = ((a∧b) xor (a∧b),_,_)
  -- ¬∃a,b . Ex₁(𝔽,a,b) = (𝕋,…)
  Ex₁ : 𝔹^ 3 ↔ 𝔹^ 3
  Ex₁ = trace⋆ (𝔽^ 1) (swap⋆ ⨾
                       (id↔ ⊗ AND) ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       (id↔ ⊗ AND) ⨾
                       assocl⋆ ⨾ (XOR ⊗ id↔) ⨾ assocr⋆ ⨾
                       (id↔ ⊗ ! AND) ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       swap⋆ )
  tests₁ = L.map (eval' Ex₁) tests

  -- Ex₂(𝔽,a,b) = ((a∧b) xor (a∨b),_,_)
  -- ∃a,b . Ex₂(𝔽,a,b) = (𝕋,…)
  Ex₂ : 𝔹^ 3 ↔ 𝔹^ 3
  Ex₂ = trace⋆ (𝔽^ 1) (swap⋆ ⨾
                       (id↔ ⊗ AND) ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       (id↔ ⊗ OR) ⨾
                       assocl⋆ ⨾ (XOR ⊗ id↔) ⨾ assocr⋆ ⨾
                       (id↔ ⊗ ! OR) ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       swap⋆ )
  tests₂ = L.map (eval' Ex₂) tests

  -- Ex₃(𝔽,a,b) = (((a∧b) ∧ (a xor b)),_,_)
  -- ¬∃a,b . Ex₃(𝔽,a,b) = (𝕋,…)
  Ex₃ : 𝔹^ 3 ↔ 𝔹^ 3
  Ex₃ = trace⋆ (𝔽^ 1) (swap⋆ ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       id↔ ⊗ F ⨾
                       (id↔ ⊗ assocl⋆) ⨾ assocl⋆ ⨾
                       (AND ⊗ id↔) ⨾
                       assocr⋆ ⨾ (id↔ ⊗ assocr⋆) ⨾
                       id↔ ⊗ ! F ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       swap⋆)
     where
     F : 𝔹^ 3 ↔ 𝔹^ 3
     F = AND ⨾ (id↔ ⊗ XOR)
  tests₃ = L.map (eval' Ex₃) tests

  -- Ex₄(𝔽,a,b) = (((a∨b) ∧ (a xor b)),_,_)
  -- ∃a,b . Ex₄(𝔽,a,b) = (𝕋,…)
  Ex₄ : 𝔹^ 3 ↔ 𝔹^ 3
  Ex₄ = trace⋆ (𝔽^ 1) (swap⋆ ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       id↔ ⊗ F ⨾
                       (id↔ ⊗ assocl⋆) ⨾ assocl⋆ ⨾
                       (AND ⊗ id↔) ⨾
                       assocr⋆ ⨾ (id↔ ⊗ assocr⋆) ⨾
                       id↔ ⊗ ! F ⨾
                       assocl⋆ ⨾ (swap⋆ ⊗ id↔) ⨾ assocr⋆ ⨾
                       swap⋆)
     where
     F : 𝔹^ 3 ↔ 𝔹^ 3
     F = OR ⨾ (id↔ ⊗ XOR)
  tests₄ = L.map (eval' Ex₄) tests

  SAT-tests : List (𝟙 ↔ 𝟙)
  SAT-tests = (SAT AND) ∷ (SAT OR) ∷ (SAT XOR) ∷ (SAT Ex₁) ∷ (SAT Ex₂) ∷ (SAT Ex₃) ∷ (SAT Ex₄) ∷ []

  results : List (Maybe (Σ[ t ∈ 𝕌 ] ⟦ t ⟧) × ℕ)
  results = L.map (λ c → eval' c tt) SAT-tests
  -- (just (𝟙 , tt) , 3923) ∷
  -- (just (𝟙 , tt) , 2035) ∷
  -- (just (𝟙 , tt) , 1347) ∷
  -- (nothing , 10386) ∷
  -- (just (𝟙 , tt) , 4307) ∷
  -- (nothing , 11442) ∷
  -- (just (𝟙 , tt) , 4827) ∷ []


{-# OPTIONS --without-K --safe #-}

module Categories.Bicategory where

open import Level
open import Data.Product using (Σ; _,_)
open import Relation.Binary using (Rel)

open import Categories.Category
open import Categories.Category.Monoidal.Instance.Cats using (module Product)
open import Categories.Category.Instance.Cats
open import Categories.Enriched.Category renaming (Category to Enriched)
open import Categories.Functor using (Functor)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Bifunctor.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism using (NaturalIsomorphism)
import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR

-- https://ncatlab.org/nlab/show/bicategory
-- notice that some axioms in nLab is inconsistent. they have been fixed in this definition.
record Bicategory o ℓ e t : Set (suc (o ⊔ ℓ ⊔ e ⊔ t)) where
  field
    enriched : Enriched (Product.Cats-Monoidal {o} {ℓ} {e}) t

  open Enriched enriched public
  module hom {A B} = Category (hom A B)

  open Functor

  module ⊚ {A B C}          = Functor (⊚ {A} {B} {C})
  module ⊚-assoc {A B C D}  = NaturalIsomorphism (⊚-assoc {A} {B} {C} {D})
  module unitˡ {A B}        = NaturalIsomorphism (unitˡ {A} {B})
  module unitʳ {A B}        = NaturalIsomorphism (unitʳ {A} {B})
  module id {A}             = Functor (id {A})

  infix 4 _⇒₁_ _⇒₂_ _≈_
  infixr 7 _∘ᵥ_ _∘ₕ_
  infixr 9 _▷_
  infixl 9 _◁_
  infixr 11 _⊚₀_ _⊚₁_

  _⇒₁_ : Obj → Obj → Set o
  A ⇒₁ B = Category.Obj (hom A B)

  _⇒₂_ : {A B : Obj} → A ⇒₁ B → A ⇒₁ B → Set ℓ
  _⇒₂_ = hom._⇒_

  _⊚₀_ : {A B C : Obj} → B ⇒₁ C → A ⇒₁ B → A ⇒₁ C
  f ⊚₀ g = ⊚.F₀ (f , g)

  _⊚₁_ : {A B C : Obj} {f h : B ⇒₁ C} {g i : A ⇒₁ B} → f ⇒₂ h → g ⇒₂ i → f ⊚₀ g ⇒₂ h ⊚₀ i
  α ⊚₁ β = ⊚.F₁ (α , β)

  _≈_ : {A B : Obj} {f g : A ⇒₁ B} → Rel (f ⇒₂ g) e
  _≈_ = hom._≈_

  id₁ : {A : Obj} → A ⇒₁ A
  id₁ {_} = id.F₀ _

  id₂ : {A B : Obj} {f : A ⇒₁ B} → f ⇒₂ f
  id₂ = hom.id

  -- horizontal composition
  _∘ₕ_ : {A B C : Obj} → B ⇒₁ C → A ⇒₁ B → A ⇒₁ C
  _∘ₕ_ = _⊚₀_

  -- vertical composition
  _∘ᵥ_ : {A B : Obj} {f g h : A ⇒₁ B} (α : g ⇒₂ h) (β : f ⇒₂ g) → f ⇒₂ h
  _∘ᵥ_ = hom._∘_

  _◁_ : {A B C : Obj} {g h : B ⇒₁ C} (α : g ⇒₂ h) (f : A ⇒₁ B) → g ∘ₕ f ⇒₂ h ∘ₕ f
  α ◁ f = α ⊚₁ id₂

  _▷_ : {A B C : Obj} {f g : A ⇒₁ B} (h : B ⇒₁ C) (α : f ⇒₂ g) → h ∘ₕ f ⇒₂ h ∘ₕ g
  h ▷ α = id₂ ⊚₁ α

  unitorˡ : {A B : Obj} {f : A ⇒₁ B} → Mor._≅_ (hom A B) (id₁ ∘ₕ f) f
  unitorˡ {_} {_} {f} = record
    { from = unitˡ.⇒.η (_ , f)
    ; to   = unitˡ.⇐.η (_ , f)
    ; iso  = unitˡ.iso (_ , f)
    }

  module unitorˡ {A B f} = Mor._≅_ (unitorˡ {A} {B} {f})

  unitorʳ : {A B : Obj} {f : A ⇒₁ B} → Mor._≅_ (hom A B) (f ∘ₕ id₁) f
  unitorʳ {_} {_} {f} = record
    { from = unitʳ.⇒.η (f , _)
    ; to   = unitʳ.⇐.η (f , _)
    ; iso  = unitʳ.iso (f , _)
    }

  module unitorʳ {A B f} = Mor._≅_ (unitorʳ {A} {B} {f})

  associator : {A B C D : Obj} {f : D ⇒₁ B} {g : C ⇒₁ D} {h : A ⇒₁ C} →  Mor._≅_ (hom A B) ((f ∘ₕ g) ∘ₕ h) (f ∘ₕ g ∘ₕ h)
  associator {_} {_} {_} {_} {f} {g} {h} = record
    { from = ⊚-assoc.⇒.η ((f , g) , h)
    ; to   = ⊚-assoc.⇐.η ((f , g) , h)
    ; iso  = ⊚-assoc.iso ((f , g) , h)
    }

  module associator {A B C D} {f : C ⇒₁ B} {g : D ⇒₁ C} {h} = Mor._≅_ (associator {A = A} {B = B} {f = f} {g = g} {h = h})

  open hom.Commutation

  field
    triangle : {A B C : Obj} {f : A ⇒₁ B} {g : B ⇒₁ C} →
                 [ (g ∘ₕ id₁) ∘ₕ f ⇒ g ∘ₕ f ]⟨
                   associator.from          ⇒⟨ g ∘ₕ id₁ ∘ₕ f ⟩
                   g ▷ unitorˡ.from
                 ≈ unitorʳ.from ◁ f
                 ⟩
    pentagon : {A B C D E : Obj} {f : A ⇒₁ B} {g : B ⇒₁ C} {h : C ⇒₁ D} {i : D ⇒₁ E} →
                 [ ((i ∘ₕ h) ∘ₕ g) ∘ₕ f ⇒ i ∘ₕ h ∘ₕ g ∘ₕ f ]⟨
                   associator.from ◁ f                     ⇒⟨ (i ∘ₕ h ∘ₕ g) ∘ₕ f ⟩
                   associator.from                         ⇒⟨ i ∘ₕ (h ∘ₕ g) ∘ₕ f ⟩
                   i ▷ associator.from
                 ≈ associator.from                         ⇒⟨ (i ∘ₕ h) ∘ₕ g ∘ₕ f ⟩
                   associator.from
                 ⟩

  private
    variable
      A B C D : Obj
      f g h i : A ⇒₁ B
      α β γ : f ⇒₂ g

  -⊚_ : C ⇒₁ A → Functor (hom A B) (hom C B)
  -⊚_ = appʳ ⊚

  _⊚- : B ⇒₁ C → Functor (hom A B) (hom A C)
  _⊚- = appˡ ⊚

  identity₂ˡ : id₂ ∘ᵥ α ≈ α
  identity₂ˡ = hom.identityˡ

  identity₂ʳ : α ∘ᵥ id₂ ≈ α
  identity₂ʳ = hom.identityʳ

  assoc₂ : (α ∘ᵥ β) ∘ᵥ γ ≈ α ∘ᵥ β ∘ᵥ γ
  assoc₂ = hom.assoc

  id₂◁ : id₂ {f = g} ◁ f ≈ id₂
  id₂◁ = ⊚.identity

  ▷id₂ : f ▷ id₂ {f = g} ≈ id₂
  ▷id₂ = ⊚.identity

  open hom.HomReasoning
  private
    module MR′ {A} {B} where
      open MR (hom A B) public
      open Mor (hom A B) public
    open MR′

  ∘ᵥ-distr-◁ : (α ◁ f) ∘ᵥ (β ◁ f) ≈ (α ∘ᵥ β) ◁ f
  ∘ᵥ-distr-◁ {f = f} = ⟺ (Functor.homomorphism (-⊚ f))

  ∘ᵥ-distr-▷ : (f ▷ α) ∘ᵥ (f ▷ β) ≈ f ▷ (α ∘ᵥ β)
  ∘ᵥ-distr-▷ {f = f} = ⟺ (Functor.homomorphism (f ⊚-))

  ρ-∘ᵥ-▷ : unitorˡ.from ∘ᵥ (id₁ ▷ α) ≈ α ∘ᵥ unitorˡ.from
  ρ-∘ᵥ-▷ {α = α} = begin
    unitorˡ.from ∘ᵥ (id₁ ▷ α)    ≈˘⟨ hom.∘-resp-≈ʳ (⊚.F-resp-≈ (id.identity , refl)) ⟩
    unitorˡ.from ∘ᵥ id.F₁ _ ⊚₁ α ≈⟨ unitˡ.⇒.commute (_ , α) ⟩
    α ∘ᵥ unitorˡ.from            ∎

  ▷-∘ᵥ-ρ⁻¹ : (id₁ ▷ α) ∘ᵥ unitorˡ.to ≈ unitorˡ.to ∘ᵥ α
  ▷-∘ᵥ-ρ⁻¹ = conjugate-to (≅.sym unitorˡ) (≅.sym unitorˡ) ρ-∘ᵥ-▷

  λ-∘ᵥ-◁ : unitorʳ.from ∘ᵥ (α ◁ id₁) ≈ α ∘ᵥ unitorʳ.from
  λ-∘ᵥ-◁ {α = α} = begin
    unitorʳ.from ∘ᵥ (α ◁ id₁)      ≈˘⟨ hom.∘-resp-≈ʳ (⊚.F-resp-≈ (refl , id.identity)) ⟩
    unitorʳ.from ∘ᵥ (α ⊚₁ id.F₁ _) ≈⟨ unitʳ.⇒.commute (α , _) ⟩
    α ∘ᵥ unitorʳ.from              ∎

  ◁-∘ᵥ-λ⁻¹ : (α ◁ id₁) ∘ᵥ unitorʳ.to ≈ unitorʳ.to ∘ᵥ α
  ◁-∘ᵥ-λ⁻¹ = conjugate-to (≅.sym unitorʳ) (≅.sym unitorʳ) λ-∘ᵥ-◁

  assoc⁻¹-◁-∘ₕ : associator.to ∘ᵥ (α ◁ (g ∘ₕ f)) ≈ ((α ◁ g) ◁ f) ∘ᵥ associator.to
  assoc⁻¹-◁-∘ₕ {α = α} {g = g} {f = f} = begin
    associator.to ∘ᵥ (α ◁ (g ∘ₕ f))    ≈˘⟨ hom.∘-resp-≈ʳ (⊚.F-resp-≈ (refl , ⊚.identity)) ⟩
    associator.to ∘ᵥ (α ⊚₁ id₂ ⊚₁ id₂) ≈⟨ ⊚-assoc.⇐.commute ((α , id₂) , id₂) ⟩
    ((α ◁ g) ◁ f) ∘ᵥ associator.to     ∎

  assoc⁻¹-▷-◁ : associator.to ∘ᵥ (f ▷ (α ◁ g)) ≈ ((f ▷ α) ◁ g) ∘ᵥ associator.to
  assoc⁻¹-▷-◁ {f = f} {α = α} {g = g} = ⊚-assoc.⇐.commute ((id₂ , α) , id₂)

  assoc⁻¹-▷-∘ₕ : associator.to ∘ᵥ (g ▷ (f ▷ α)) ≈ ((g ∘ₕ f) ▷ α) ∘ᵥ associator.to
  assoc⁻¹-▷-∘ₕ {g = g} {f = f} {α = α} = begin
    associator.to ∘ᵥ (g ▷ (f ▷ α))       ≈⟨ ⊚-assoc.⇐.commute ((id₂ , id₂) , α) ⟩
    ((id₂ ⊚₁ id₂) ⊚₁ α) ∘ᵥ associator.to ≈⟨ hom.∘-resp-≈ˡ (⊚.F-resp-≈ (⊚.identity , refl)) ⟩
    ((g ∘ₕ f) ▷ α) ∘ᵥ associator.to      ∎

  ◁-▷-exchg : ∀ {α : f ⇒₂ g} {β : h ⇒₂ i} → (i ▷ α) ∘ᵥ (β ◁ f) ≈ (β ◁ g) ∘ᵥ (h ▷ α)
  ◁-▷-exchg = [ ⊚ ]-commute


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Groups.Definition
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Order
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Rings.IntegralDomains.Definition
open import Orders.Total.Definition

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Rings.EuclideanDomains.Definition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open import Rings.Divisible.Definition R
open Setoid S
open Equivalence eq
open Ring R
open Group additiveGroup

record DivisionAlgorithmResult (norm : {a : A} → ((a ∼ 0R) → False) → ℕ) {x y : A} (x!=0 : (x ∼ 0R) → False) (y!=0 : (y ∼ 0R) → False) : Set (a ⊔ b) where
  field
    quotient : A
    rem : A
    remSmall : (rem ∼ 0R) || Sg ((rem ∼ 0R) → False) (λ rem!=0 → (norm rem!=0) <N (norm y!=0))
    divAlg : x ∼ ((quotient * y) + rem)

record DivisionAlgorithmResult' (norm : (a : A) → ℕ) (x y : A) : Set (a ⊔ b) where
  field
    quotient : A
    rem : A
    remSmall : (rem ∼ 0R) || ((norm rem) <N (norm y))
    divAlg : x ∼ ((quotient * y) + rem)

record EuclideanDomain : Set (a ⊔ lsuc b) where
  field
    isIntegralDomain : IntegralDomain R
    norm : {a : A} → ((a ∼ 0R) → False) → ℕ
    normSize : {a b : A} → (a!=0 : (a ∼ 0R) → False) → (b!=0 : (b ∼ 0R) → False) → (c : A) → b ∼ (a * c) → (norm a!=0) ≤N (norm b!=0)
    divisionAlg : {a b : A} → (a!=0 : (a ∼ 0R) → False) → (b!=0 : (b ∼ 0R) → False) → DivisionAlgorithmResult norm a!=0 b!=0
  normWellDefined : {a : A} → (p1 p2 : (a ∼ 0R) → False) → norm p1 ≡ norm p2
  normWellDefined {a} p1 p2 with normSize p1 p2 1R (symmetric (transitive *Commutative identIsIdent))
  normWellDefined {a} p1 p2 | inl n1<n2 with normSize p2 p1 1R (symmetric (transitive *Commutative identIsIdent))
  normWellDefined {a} p1 p2 | inl n1<n2 | inl n2<n1 = exFalso (TotalOrder.irreflexive ℕTotalOrder (TotalOrder.<Transitive ℕTotalOrder n1<n2 n2<n1))
  normWellDefined {a} p1 p2 | inl n1<n2 | inr n2=n1 = equalityCommutative n2=n1
  normWellDefined {a} p1 p2 | inr n1=n2 = n1=n2
  normWellDefined' : {a b : A} → (a ∼ b) → (a!=0 : (a ∼ 0R) → False) → (b!=0 : (b ∼ 0R) → False) → norm a!=0 ≡ norm b!=0
  normWellDefined' a=b a!=0 b!=0 with normSize a!=0 b!=0 1R (symmetric (transitive *Commutative (transitive identIsIdent a=b)))
  normWellDefined' a=b a!=0 b!=0 | inl a<b with normSize b!=0 a!=0 1R (symmetric (transitive *Commutative (transitive identIsIdent (symmetric a=b))))
  normWellDefined' a=b a!=0 b!=0 | inl a<b | inl b<a = exFalso (TotalOrder.irreflexive ℕTotalOrder (TotalOrder.<Transitive ℕTotalOrder a<b b<a))
  normWellDefined' a=b a!=0 b!=0 | inl a<b | inr n= = equalityCommutative n=
  normWellDefined' a=b a!=0 b!=0 | inr n= = n=

record EuclideanDomain' : Set (a ⊔ lsuc b) where
  field
    isIntegralDomain : IntegralDomain R
    norm : A → ℕ
    normWellDefined : {a b : A} → (a ∼ b) → norm a ≡ norm b
    normSize : (a b : A) → (a ∣ b) → ((b ∼ 0R) → False) → norm a ≤N (norm b)
    divisionAlg : (a b : A) → ((b ∼ 0R) → False) → DivisionAlgorithmResult' norm a b

normEquiv : (e : EuclideanDomain) (decidableZero : (a : A) → (a ∼ 0R) || ((a ∼ 0R) → False)) → A → ℕ
normEquiv e decidableZero a with decidableZero a
... | inl a=0 = 0
... | inr a!=0 = EuclideanDomain.norm e a!=0

normSizeEquiv : (e : EuclideanDomain) (decidableZero : (a : A) → (a ∼ 0R) || ((a ∼ 0R) → False)) (a b : A) → (a ∣ b) → ((b ∼ 0R) → False) → normEquiv e decidableZero a ≤N normEquiv e decidableZero b
normSizeEquiv e decidableZero a b (c , ac=b) b!=0 = ans
  where
    abstract
      a!=0 : (a ∼ 0R) → False
      a!=0 a=0 = b!=0 (transitive (symmetric ac=b) (transitive (*WellDefined a=0 reflexive) (transitive *Commutative timesZero)))
    normIs : normEquiv e decidableZero a ≡ EuclideanDomain.norm e a!=0
    normIs with decidableZero a
    normIs | inl a=0 = exFalso (a!=0 a=0)
    normIs | inr a!=0' = EuclideanDomain.normWellDefined e a!=0' a!=0
    normIs' : normEquiv e decidableZero b ≡ EuclideanDomain.norm e b!=0
    normIs' with decidableZero b
    normIs' | inl b=0 = exFalso (b!=0 b=0)
    normIs' | inr b!=0' = EuclideanDomain.normWellDefined e b!=0' b!=0
    ans : (normEquiv e decidableZero a) ≤N (normEquiv e decidableZero b)
    ans with EuclideanDomain.normSize e a!=0 b!=0 c (symmetric ac=b)
    ans | inl n<Nn = inl (identityOfIndiscernablesLeft _<N_ (identityOfIndiscernablesRight _<N_ n<Nn (equalityCommutative normIs')) (equalityCommutative normIs))
    ans | inr n=n = inr (transitivity normIs (transitivity n=n (equalityCommutative normIs')))

divisionAlgEquiv : (e : EuclideanDomain) (decidableZero : (a : A) → (a ∼ 0R) || ((a ∼ 0R) → False)) → (a b : A) → ((b ∼ 0R) → False) → DivisionAlgorithmResult' (normEquiv e decidableZero) a b
divisionAlgEquiv e decidableZero a b b!=0 with decidableZero a
divisionAlgEquiv e decidableZero a b b!=0 | inl a=0 = record { quotient = 0R ; rem = 0R ; remSmall = inl reflexive ; divAlg = transitive a=0 (transitive (symmetric identLeft) (+WellDefined (symmetric (transitive *Commutative timesZero)) reflexive)) }
divisionAlgEquiv e decidableZero a b b!=0 | inr a!=0 with EuclideanDomain.divisionAlg e a!=0 b!=0
divisionAlgEquiv e decidableZero a b b!=0 | inr a!=0 | record { quotient = quotient ; rem = rem ; remSmall = inl x ; divAlg = divAlg } = record { quotient = quotient ; rem = rem ; remSmall = inl x ; divAlg = divAlg }
divisionAlgEquiv e decidableZero a b b!=0 | inr a!=0 | record { quotient = quotient ; rem = rem ; remSmall = inr (rem!=0 , pr) ; divAlg = divAlg } = record { quotient = quotient ; rem = rem ; remSmall = inr (identityOfIndiscernablesLeft _<N_ (identityOfIndiscernablesRight _<N_ pr (equalityCommutative normIs')) (equalityCommutative normIs)) ; divAlg = divAlg }
  where
    normIs : normEquiv e decidableZero rem ≡ EuclideanDomain.norm e rem!=0
    normIs with decidableZero rem
    normIs | inl rem=0 = exFalso (rem!=0 rem=0)
    normIs | inr rem!=0' = EuclideanDomain.normWellDefined e rem!=0' rem!=0
    normIs' : normEquiv e decidableZero b ≡ EuclideanDomain.norm e b!=0
    normIs' with decidableZero b
    normIs' | inl b=0 = exFalso (b!=0 b=0)
    normIs' | inr b!=0' = EuclideanDomain.normWellDefined e b!=0' b!=0

normWellDefined : (e : EuclideanDomain) (decidableZero : (a : A) → (a ∼ 0R) || ((a ∼ 0R) → False)) {a b : A} (a=b : a ∼ b) → normEquiv e decidableZero a ≡ normEquiv e decidableZero b
normWellDefined e decidableZero {a} {b} a=b with decidableZero a
normWellDefined e decidableZero {a} {b} a=b | inl a=0 with decidableZero b
normWellDefined e decidableZero {a} {b} a=b | inl a=0 | inl b=0 = refl
normWellDefined e decidableZero {a} {b} a=b | inl a=0 | inr b!=0 = exFalso (b!=0 (transitive (symmetric a=b) a=0))
normWellDefined e decidableZero {a} {b} a=b | inr a!=0 with decidableZero b
normWellDefined e decidableZero {a} {b} a=b | inr a!=0 | inl b=0 = exFalso (a!=0 (transitive a=b b=0))
normWellDefined e decidableZero {a} {b} a=b | inr a!=0 | inr b!=0 = EuclideanDomain.normWellDefined' e a=b a!=0 b!=0

eucDomsEquiv : (decidableZero : (a : A) → (a ∼ 0R) || ((a ∼ 0R) → False)) → EuclideanDomain → EuclideanDomain'
eucDomsEquiv decidableZero e = record { isIntegralDomain = EuclideanDomain.isIntegralDomain e ; norm = normEquiv e decidableZero ; normSize = normSizeEquiv e decidableZero ; divisionAlg = divisionAlgEquiv e decidableZero ; normWellDefined = normWellDefined e decidableZero }


open import Agda.Builtin.Nat

postulate P : Nat → Set

record R : Set where
  field
    f : P zero

foo : R → Set
foo (record { f = f0 }) with zero
foo r | x = Nat