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

module Paths where

open import Agda.Prim
open import Data.Unit
open import Data.Bool
open import Data.Nat hiding (_⊔_)
open import Data.Sum
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality

open import PointedTypes

--infix  2  _∎      -- equational reasoning
--infixr 2  _≡⟨_⟩_  -- equational reasoning

------------------------------------------------------------------------------
-- Paths are pi-combinators

data _⇛_ {ℓ : Level} :
  (A• : Set• ℓ) → (B• : Set• ℓ) → Set (lsuc (lsuc ℓ)) where
  -- additive structure
  swap₁₊⇛    : {A B : Set ℓ} {a : A} {b : B} →
               •[ A ⊎ B , inj₁ a ] ⇛ •[ B ⊎ A , inj₂ a ]
  id⇛        : {A : Set ℓ} → (a : A) → •[ A , a ] ⇛ •[ A , a ]
  η⋆⇛        : {A : Set ℓ} {a : A} → •[ A , a ] ⇛ •[ (A → A) , id ]
  equiv⇛     : {A B : Set ℓ} {a : A} {b : B} →
               (f : •[ A , a ] →• •[ B , b ]) →
               (fequiv : isequiv• f) →
               •[ A , a ] ⇛ •[ B , b ]

swap₊ : {ℓ : Level} {A B : Set ℓ} → A ⊎ B → B ⊎ A
swap₊ (inj₁ a) = inj₂ a
swap₊ (inj₂ b) = inj₁ b

eval : {ℓ : Level} {A• B• : Set• ℓ} → A• ⇛ B• → (A• →• B•)
eval swap₁₊⇛ = record { fun = swap₊ ; resp• = refl }
eval (id⇛ _) = id•
eval η⋆⇛ = {!!}
eval (equiv⇛ _ _) = {!!}

pInversion : {ℓ : Level} {A• B• : Set• ℓ} → (c : A• ⇛ B•) → fun (eval c) (• A•) ≡ • B•
pInversion {ℓ} {A•} {B•} c = resp• (eval c)

funext : {ℓ : Level} {A• B• : Set• ℓ} {f g : A• →• B•} →
         (pt f ⇛ pt g) → (f ∼• g)
funext = {!!}

{--
  swap₂₊⇛    : {A• B• : Set• {ℓ}} → (A• ⊎•₂ B•) ⇛ (B• ⊎•₁ A•)
  assocl₁₊⇛  : {A• B• C• : Set• {ℓ}} →
               (A• ⊎•₁ (B• ⊎•₁ C•)) ⇛ ((A• ⊎•₁ B•) ⊎•₁ C•)
  assocl₁₊⇛' : {A• B• C• : Set• {ℓ}} →
               (A• ⊎•₁ (B• ⊎•₂ C•)) ⇛ ((A• ⊎•₁ B•) ⊎•₁ C•)
               •[ A ⊎ (B ⊎ C) , inj₁ a ] ⇛ •[ (A ⊎ B) ⊎ C , inj₁ (inj₁ a) ]
  assocl₂₁₊⇛ : {A B C : Set ℓ} → (b : B) →
               •[ A ⊎ (B ⊎ C) , inj₂ (inj₁ b) ] ⇛
               •[ (A ⊎ B) ⊎ C , inj₁ (inj₂ b) ]
  assocl₂₂₊⇛ : {A B C : Set ℓ} → (c : C) →
               •[ A ⊎ (B ⊎ C) , inj₂ (inj₂ c) ] ⇛ •[ (A ⊎ B) ⊎ C , inj₂ c ]
  assocr₁₁₊⇛ : {A B C : Set ℓ} → (a : A) →
               •[ (A ⊎ B) ⊎ C , inj₁ (inj₁ a) ] ⇛ •[ A ⊎ (B ⊎ C) , inj₁ a ]
  assocr₁₂₊⇛ : {A B C : Set ℓ} → (b : B) →
               •[ (A ⊎ B) ⊎ C , inj₁ (inj₂ b) ] ⇛
               •[ A ⊎ (B ⊎ C) , inj₂ (inj₁ b) ]
  assocr₂₊⇛  : {A B C : Set ℓ} → (c : C) →
               •[ (A ⊎ B) ⊎ C , inj₂ c ] ⇛ •[ A ⊎ (B ⊎ C) , inj₂ (inj₂ c) ]
  -- multiplicative structure
  unite⋆⇛    : {A : Set ℓ} → (a : A) → •[ ⊤ × A , (tt , a) ] ⇛ •[ A , a ]
  uniti⋆⇛    : {A : Set ℓ} → (a : A) → •[ A , a ] ⇛ •[ ⊤ × A , (tt , a) ]
  swap⋆⇛     : {A B : Set ℓ} → (a : A) → (b : B) →
               •[ A × B , (a , b) ] ⇛ •[ B × A , (b , a) ]
  assocl⋆⇛   : {A B C : Set ℓ} → (a : A) → (b : B) → (c : C) →
               •[ A × (B × C) , (a , (b , c)) ] ⇛
               •[ (A × B) × C , ((a , b) , c) ]
  assocr⋆⇛   : {A B C : Set ℓ} → (a : A) → (b : B) → (c : C) →
               •[ (A × B) × C , ((a , b) , c) ] ⇛
               •[ A × (B × C) , (a , (b , c)) ]
  -- distributivity
  dist₁⇛     : {A B C : Set ℓ} → (a : A) → (c : C) →
               •[ (A ⊎ B) × C , (inj₁ a , c) ] ⇛
               •[ (A × C) ⊎ (B × C) , inj₁ (a , c) ]
  dist₂⇛     : {A B C : Set ℓ} → (b : B) → (c : C) →
               •[ (A ⊎ B) × C , (inj₂ b , c) ] ⇛
               •[ (A × C) ⊎ (B × C) , inj₂ (b , c) ]
  factor₁⇛   : {A B C : Set ℓ} → (a : A) → (c : C) →
               •[ (A × C) ⊎ (B × C) , inj₁ (a , c) ] ⇛
               •[ (A ⊎ B) × C , (inj₁ a , c) ]
  factor₂⇛   : {A B C : Set ℓ} → (b : B) → (c : C) →
               •[ (A × C) ⊎ (B × C) , inj₂ (b , c) ] ⇛
               •[ (A ⊎ B) × C , (inj₂ b , c) ]
  -- congruence but without sym which is provable
  id⇛        : {A : Set ℓ} → (a : A) → •[ A , a ] ⇛ •[ A , a ]
  trans⇛     : {A B C : Set ℓ} {a : A} {b : B} {c : C} →
               (•[ A , a ] ⇛ •[ B , b ]) →
               (•[ B , b ] ⇛ •[ C , c ]) →
               (•[ A , a ] ⇛ •[ C , c ])
  plus₁⇛     : {A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
               (•[ A , a ] ⇛ •[ C , c ]) →
               (•[ B , b ] ⇛ •[ D , d ]) →
               (•[ A ⊎ B , inj₁ a ] ⇛ •[ C ⊎ D , inj₁ c ])
  plus₂⇛     : {A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
               (•[ A , a ] ⇛ •[ C , c ]) →
               (•[ B , b ] ⇛ •[ D , d ]) →
               (•[ A ⊎ B , inj₂ b ] ⇛ •[ C ⊎ D , inj₂ d ])
  times⇛     : {A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
               (•[ A , a ] ⇛ •[ C , c ]) → (•[ B , b ] ⇛ •[ D , d ]) →
               (•[ A × B , (a , b) ] ⇛ •[ C × D , (c , d) ])
--}

-- Abbreviations and small examples

{--
Path : {ℓ : Level} {A B : Set ℓ} → (a : A) → (b : B) → Set (lsuc ℓ)
Path {ℓ} {A} {B} a b = •[ A , a ] ⇛ •[ B , b ]

2Path : {ℓ : Level} {A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
  (p : Path a b) → (q : Path c d) → Set (lsuc (lsuc ℓ))
2Path {ℓ} {A} {B} {C} {D} {a} {b} {c} {d} p q = Path p q
  --  •[ Path a b , p ] ⇛ •[ Path c d , q ]
--}
{--
_≡⟨_⟩_ : ∀ {ℓ} → {A B C : Set ℓ} (a : A) {b : B} {c : C} →
         Path a b → Path b c → Path a c
_ ≡⟨ p ⟩ q = trans⇛ p q

_∎ : ∀ {ℓ} → {A : Set ℓ} (a : A) → Path a a
_∎ a = id⇛ a

test3 : {A : Set} {a : A} → Set•
test3 {A} {a} = •[ Path a a , id⇛ a ]

test4 : Set•
test4 = •[ Path ℕ ℕ , id⇛ ℕ ]

test5 : Set•
test5 = •[ Path (ℕ , Bool) (Bool , ℕ) , swap⋆⇛ ℕ Bool ]

test6 : Set•
test6 = •[ Path (tt , ℕ) ℕ , unite⋆⇛ ℕ ]

test7 : {A : Set} {a : A} → Set•
test7 {A} {a} = •[ 2Path (id⇛ a) (id⇛ a) , id⇛ (id⇛ a) ]

test8 : {A B C D : Set} {a : A} {b : B} {c : C} {d : D} →
        (p : Path a b) → (q : Path c d) → Set•
test8 {A} {B} {C} {D} {a} {b} {c} {d} p q =
  •[ Path (a , c) (b , d) , times⇛ p q ]

-- Propositional equality implies a path

≡Path : {ℓ : Level} {A : Set ℓ} {x y : A} → (x ≡ y) → Path x y
≡Path {ℓ} {A} {x} {.x} refl = id⇛ x
--}

------------------------------------------------------------------------------
-- Path induction

{--
pathInd : {ℓ ℓ' : Level} →
  (P : {A• B• : Set• {ℓ}} → (A• ⇛ B•) → Set ℓ') →
  ({A• B• : Set• {ℓ}} → P (swap₁₊⇛ {ℓ} {A•} {B•})) →
pathInd : {ℓ ℓ' : Level} →
  (P : {A B : Set ℓ} {a : A} {b : B} →
    (•[ A , a ] ⇛ •[ B , b ]) → Set ℓ') →
  ({A B : Set ℓ} → (a : A) → P (swap₁₊⇛ {ℓ} {A} {B} a)) →
  ({A B : Set ℓ} → (b : B) → P (swap₂₊⇛ {ℓ} {A} {B} b)) →
  ({A B C : Set ℓ} → (a : A) → P (assocl₁₊⇛ {ℓ} {A} {B} {C} a)) →
  ({A B C : Set ℓ} → (b : B) → P (assocl₂₁₊⇛ {ℓ} {A} {B} {C} b)) →
  ({A B C : Set ℓ} → (c : C) → P (assocl₂₂₊⇛ {ℓ} {A} {B} {C} c)) →
  ({A B C : Set ℓ} → (a : A) → P (assocr₁₁₊⇛ {ℓ} {A} {B} {C} a)) →
  ({A B C : Set ℓ} → (b : B) → P (assocr₁₂₊⇛ {ℓ} {A} {B} {C} b)) →
  ({A B C : Set ℓ} → (c : C) → P (assocr₂₊⇛ {ℓ} {A} {B} {C} c)) →
  ({A : Set ℓ} → (a : A) → P (unite⋆⇛ {ℓ} {A} a)) →
  ({A : Set ℓ} → (a : A) → P (uniti⋆⇛ {ℓ} {A} a)) →
  ({A B : Set ℓ} → (a : A) → (b : B) → P (swap⋆⇛ {ℓ} {A} {B} a b)) →
  ({A B C : Set ℓ} → (a : A) → (b : B) → (c : C) →
    P (assocl⋆⇛ {ℓ} {A} {B} {C} a b c)) →
  ({A B C : Set ℓ} → (a : A) → (b : B) → (c : C) →
    P (assocr⋆⇛ {ℓ} {A} {B} {C} a b c)) →
  ({A B C : Set ℓ} → (a : A) → (c : C) → P (dist₁⇛ {ℓ} {A} {B} {C} a c)) →
  ({A B C : Set ℓ} → (b : B) → (c : C) → P (dist₂⇛ {ℓ} {A} {B} {C} b c)) →
  ({A B C : Set ℓ} → (a : A) → (c : C) → P (factor₁⇛ {ℓ} {A} {B} {C} a c)) →
  ({A B C : Set ℓ} → (b : B) → (c : C) → P (factor₂⇛ {ℓ} {A} {B} {C} b c)) →
  ({A : Set ℓ} → (a : A) → P (id⇛ {ℓ} {A} a)) →
  ({A B C : Set ℓ} {a : A} {b : B} {c : C} →
    (p : (•[ A , a ] ⇛ •[ B , b ])) →
    (q : (•[ B , b ] ⇛ •[ C , c ])) →
    P p → P q → P (trans⇛ p q)) →
  ({A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
    (p : (•[ A , a ] ⇛ •[ C , c ])) →
    (q : (•[ B , b ] ⇛ •[ D , d ])) →
    P p → P q → P (plus₁⇛ {ℓ} {A} {B} {C} {D} {a} {b} {c} {d} p q)) →
  ({A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
    (p : (•[ A , a ] ⇛ •[ C , c ])) →
    (q : (•[ B , b ] ⇛ •[ D , d ])) →
    P p → P q → P (plus₂⇛ {ℓ} {A} {B} {C} {D} {a} {b} {c} {d} p q)) →
  ({A B C D : Set ℓ} {a : A} {b : B} {c : C} {d : D} →
    (p : (•[ A , a ] ⇛ •[ C , c ])) →
    (q : (•[ B , b ] ⇛ •[ D , d ])) →
    P p → P q → P (times⇛ p q)) →
  {A B : Set ℓ} {a : A} {b : B} → (p : •[ A , a ] ⇛ •[ B , b ]) → P p
  {A• B• : Set• {ℓ}} → (p : A• ⇛ B•) → P p
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (swap₁₊⇛ a) = swap₁₊ a
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (swap₂₊⇛ b) = swap₂₊ b
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocl₁₊⇛ a) = assocl₁₊ a
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocl₂₁₊⇛ b) = assocl₂₁₊ b
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocl₂₂₊⇛ c) = assocl₂₂₊ c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocr₁₁₊⇛ a) = assocr₁₁₊ a
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocr₁₂₊⇛ b) = assocr₁₂₊ b
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocr₂₊⇛ c) = assocr₂₊ c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (unite⋆⇛ a) = unite⋆ a
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (uniti⋆⇛ a) = uniti⋆ a
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (swap⋆⇛ a b) = swap⋆ a b
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocl⋆⇛ a b c) = assocl⋆ a b c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (assocr⋆⇛ a b c) = assocr⋆ a b c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (dist₁⇛ a c) = dist₁ a c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (dist₂⇛ b c) = dist₂ b c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (factor₁⇛ a c) = factor₁ a c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (factor₂⇛ b c) = factor₂ b c
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (id⇛ a) = cid a
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (trans⇛ p q) =
    ctrans p q
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times p)
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times q)
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (plus₁⇛ p q) =
    plus₁ p q
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times p)
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times q)
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (plus₂⇛ p q) =
    plus₂ p q
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times p)
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times q)
pathInd P swap₁₊ swap₂₊
  assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
  unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
  cid ctrans plus₁ plus₂ times (times⇛ p q) =
    times p q
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times p)
      (pathInd P swap₁₊ swap₂₊
       assocl₁₊ assocl₂₁₊ assocl₂₂₊ assocr₁₁₊ assocr₁₂₊ assocr₂₊
       unite⋆ uniti⋆ swap⋆ assocl⋆ assocr⋆ dist₁ dist₂ factor₁ factor₂
       cid ctrans plus₁ plus₂ times q)
pathInd P swap₁₊ swap₁₊⇛ = swap₁₊
--}

------------------------------------------------------------------------------
-- Groupoid structure (emerging...)
{--
sym⇛ : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} → Path a b → Path b a
sym⇛ {ℓ} {A} {B} {a} {b} p =
  (pathInd
    (λ {A} {B} {a} {b} p → Path b a)
    swap₂₊⇛ swap₁₊⇛
    assocr₁₁₊⇛ assocr₁₂₊⇛ assocr₂₊⇛ assocl₁₊⇛ assocl₂₁₊⇛ assocl₂₂₊⇛
    uniti⋆⇛ unite⋆⇛ (λ a b → swap⋆⇛ b a)
    assocr⋆⇛ assocl⋆⇛ factor₁⇛ factor₂⇛ dist₁⇛ dist₂⇛
    id⇛ (λ _ _ p' q' → trans⇛ q' p'))
    (λ _ _ p' q' → plus₁⇛ p' q') (λ _ _ p' q' → plus₂⇛ p' q')
    (λ _ _ p' q' → times⇛ p' q')
  {A} {B} {a} {b} p

test9 : {A : Set} {a : A} → Path (a , (tt , a)) ((tt , a) , a)
test9 {A} {a} = sym⇛ (times⇛ (unite⋆⇛ a) (uniti⋆⇛ a))
             -- evaluates to (times⇛ (uniti⋆⇛ a) (unite⋆⇛ a)
--}
{--
idright : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} {p : Path a b} →
          2Path (trans⇛ p (id⇛ b)) p
idright {ℓ} {A} {B} {a} {b} {p} =
  (pathInd
    (λ {A} {B} {a} {b} p → 2Path (trans⇛ p (id⇛ b)) p)
    (λ {A} {B} a₁ → {!!})
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!})
  {A} {B} {a} {b} p

aptransL : {ℓ : Level} {A B C : Set ℓ} {a : A} {b : B} {c : C} →
           (p q : Path a b) → (r : Path b c) → (α : 2Path p q) →
           2Path (trans⇛ p r) (trans⇛ q r)
aptransL {ℓ} {A} {B} {C} {a} {b} {c} p q r α =
  (pathInd
    (λ {B} {C} {b} {c} r → (A : Set ℓ) → (a : A) → (p q : Path a b) →
      (α : 2Path p q) → 2Path (trans⇛ p r) (trans⇛ q r))
    (λ a₁ A₂ a₂ p₁ q₁ α₁ → {!!})
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!}
    {!!})
  {B} {C} {b} {c} r A a p q α

symsym : {ℓ : Level} {A B : Set ℓ} {a : A} {b : B} → (p : Path a b) →
         2Path (sym⇛ (sym⇛ p)) p
symsym {ℓ} {A} {B} {a} {b} p =
  (pathInd
    (λ {A} {B} {a} {b} p → 2Path (sym⇛ (sym⇛ p)) p)
    (λ a → id⇛ (swap₁₊⇛ a))
    (λ b → id⇛ (swap₂₊⇛ b))
    (λ a → id⇛ (assocl₁₊⇛ a))
    (λ b → id⇛ (assocl₂₁₊⇛ b))
    (λ c → id⇛ (assocl₂₂₊⇛ c))
    (λ a → id⇛ (assocr₁₁₊⇛ a))
    (λ b → id⇛ (assocr₁₂₊⇛ b))
    (λ c → id⇛ (assocr₂₊⇛ c))
    (λ a → id⇛ (unite⋆⇛ a))
    (λ a → id⇛ (uniti⋆⇛ a))
    (λ a b → id⇛ (swap⋆⇛ a b))
    (λ a b c → id⇛ (assocl⋆⇛ a b c))
    (λ a b c → id⇛ (assocr⋆⇛ a b c))
    (λ a c → id⇛ (dist₁⇛ a c))
    (λ b c → id⇛ (dist₂⇛ b c))
    (λ a c → id⇛ (factor₁⇛ a c))
    (λ b c → id⇛ (factor₂⇛ b c))
    (λ a → id⇛ (id⇛ a))
    (λ p q α β → {!!})
    (λ p q α β → {!!})
    (λ p q α β → {!!})
    (λ p q α β → {!!}))
  {A} {B} {a} {b} p
--}

------------------------------------------------------------------------------
{-- old stuff which we might need again

idright : {A B : Set} {a : A} {b : B} {p : •[ A , a ] ⇛ •[ B , b ]} →
          (trans⇛ p (id⇛ {B} {b})) 2⇛ p
idright = 2Path id⇛ id⇛

idleft : {A B : Set} {a : A} {b : B} {p : •[ A , a ] ⇛ •[ B , b ]} →
         (trans⇛ (id⇛ {A} {a}) p) 2⇛ p
idleft = 2Path id⇛ id⇛

assoc  : {A B C D : Set} {a : A} {b : B} {c : C} {d : D}
         {p : •[ A , a ] ⇛ •[ B , b ]}
         {q : •[ B , b ] ⇛ •[ C , c ]}
         {r : •[ C , c ] ⇛ •[ D , d ]} →
         (trans⇛ p (trans⇛ q r)) 2⇛ (trans⇛ (trans⇛ p q) r)
assoc = 2Path id⇛ id⇛

bifunctorid⋆ : {A B : Set} {a : A} {b : B} →
  (times⇛ (id⇛ {A} {a}) (id⇛ {B} {b})) 2⇛ (id⇛ {A × B} {(a , b)})
bifunctorid⋆ = 2Path id⇛ id⇛

bifunctorid₊₁ : {A B : Set} {a : A} →
  (plus₁⇛ {A} {B} {A} {B} (id⇛ {A} {a})) 2⇛ (id⇛ {A ⊎ B} {inj₁ a})
bifunctorid₊₁ = 2Path id⇛ id⇛

bifunctorid₊₂ : {A B : Set} {b : B} →
  (plus₂⇛ {A} {B} {A} {B} (id⇛ {B} {b})) 2⇛ (id⇛ {A ⊎ B} {inj₂ b})
bifunctorid₊₂ = 2Path id⇛ id⇛

bifunctorC⋆ : {A B C D E F : Set}
              {a : A} {b : B} {c : C} {d : D} {e : E} {f : F}
              {p : •[ A , a ] ⇛ •[ B , b ]}
              {q : •[ B , b ] ⇛ •[ C , c ]}
              {r : •[ D , d ] ⇛ •[ E , e ]}
              {s : •[ E , e ] ⇛ •[ F , f ]} →
  (trans⇛ (times⇛ p r) (times⇛ q s)) 2⇛ (times⇛ (trans⇛ p q) (trans⇛ r s))
bifunctorC⋆ = 2Path id⇛ id⇛

bifunctorC₊₁₁ : {A B C D E F : Set}
                {a : A} {b : B} {c : C}
                {p : •[ A , a ] ⇛ •[ B , b ]}
                {q : •[ B , b ] ⇛ •[ C , c ]} →
  (trans⇛ (plus₁⇛ {A} {D} {B} {E} p) (plus₁⇛ {B} {E} {C} {F} q)) 2⇛
  (plus₁⇛ {A} {D} {C} {F} (trans⇛ p q))
bifunctorC₊₁₁ = 2Path id⇛ id⇛

bifunctorC₊₂₂ : {A B C D E F : Set}
                {d : D} {e : E} {f : F}
                {r : •[ D , d ] ⇛ •[ E , e ]}
                {s : •[ E , e ] ⇛ •[ F , f ]} →
  (trans⇛ (plus₂⇛ {A} {D} {B} {E} r) (plus₂⇛ {B} {E} {C} {F} s)) 2⇛
  (plus₂⇛ {A} {D} {C} {F} (trans⇛ r s))
bifunctorC₊₂₂ = 2Path id⇛ id⇛

triangle : {A B : Set} {a : A} {b : B} →
  (trans⇛ (assocr⋆⇛ {A} {⊤} {B} {a} {tt} {b}) (times⇛ id⇛ unite⋆⇛)) 2⇛
  (times⇛ (trans⇛ swap⋆⇛ unite⋆⇛) id⇛)
triangle = 2Path id⇛ id⇛

-- Now interpret a path (x ⇛ y) as a value of type (1/x , y)

Recip : {A : Set} → (x : • A) → Set₁
Recip {A} x = (x ⇛ x)

η : {A : Set} {x : • A} → ⊤ → Recip x × • A
η {A} {x} tt = (id⇛ x , x)

lower : {A : Set} {x : • A} → x ⇛ x -> ⊤
lower c = tt

-- The problem here is that we can't assert that y == x.
ε : {A : Set} {x : • A} → Recip x × • A → ⊤
ε {A} {x} (rx , y) = lower (id⇛ ( ↑ (fun (ap rx) (focus y)) )) -- makes insufficient sense

apr : {A B : Set} {x : • A} {y : • B} → (x ⇛ y) → Recip y → Recip x
apr {A} {B} {x} {y} q ry = trans⇛ q (trans⇛ ry (sym⇛ q))
  x
    ≡⟨ q ⟩
  y
    ≡⟨ ry ⟩
  y
    ≡⟨ sym⇛ q ⟩
  x ∎

ε : {A B : Set} {x : A} {y : B} → Recip x → Singleton y → x ⇛ y
ε rx (singleton y) = rx y

pathV : {A B : Set} {x : A} {y : B} → (x ⇛ y) → Recip x × Singleton y
pathV unite₊⇛ = {!!}
pathV uniti₊⇛ = {!!}
--  swap₁₊⇛ : {A B : Set} {x : A} → _⇛_ {A ⊎ B} {B ⊎ A} (inj₁ x) (inj₂ x)
pathV (swap₁₊⇛ {A} {B} {x}) = ((λ x' → {!!}) , singleton (inj₂ x))
pathV swap₂₊⇛ = {!!}
pathV assocl₁₊⇛ = {!!}
pathV assocl₂₁₊⇛ = {!!}
pathV assocl₂₂₊⇛ = {!!}
pathV assocr₁₁₊⇛ = {!!}
pathV assocr₁₂₊⇛ = {!!}
pathV assocr₂₊⇛ = {!!}
pathV unite⋆⇛ = {!!}
pathV uniti⋆⇛ = {!!}
pathV swap⋆⇛ = {!!}
pathV assocl⋆⇛ = {!!}
pathV assocr⋆⇛ = {!!}
pathV dist₁⇛ = {!!}
pathV dist₂⇛ = {!!}
pathV factor₁⇛ = {!!}
pathV factor₂⇛ = {!!}
pathV dist0⇛ = {!!}
pathV factor0⇛ = {!!}
pathV {A} {.A} {x} (id⇛ .x) = {!!}
pathV (sym⇛ p) = {!!}
pathV (trans⇛ p p₁) = {!!}
pathV (plus₁⇛ p) = {!!}
pathV (plus₂⇛ p) = {!!}
pathV (times⇛ p p₁) = {!!}

-- these are individual paths so to speak
-- should we represent a path like swap+ as a family explicitly:
-- swap+ : (x : A) -> x ⇛ swapF x
-- I guess we can: swap+ : (x : A) -> case x of inj1 -> swap1 x else swap2 x

If A={x0,x1,x2}, 1/A has three values:
(x0<-x0, x0<-x1, x0<-x2)
(x1<-x0, x1<-x1, x1<-x2)
(x2<-x0, x2<-x1, x2<-x2)
It is a fake choice between x0, x1, and x2 (some negative information). You base
yourself at x0 for example and enforce that any other value can be mapped to x0.
So think of a value of type 1/A as an uncertainty about which value of A we
have. It could be x0, x1, or x2 but at the end it makes no difference. There is
no choice.

You can manipulate a value of type 1/A (x0<-x0, x0<-x1, x0<-x2) by with a
path to some arbitrary path to b0 for example:

(b0<-x0<-x0, b0<-x0<-x1, b0<-x0<-x2)

eta_3 will give (x0<-x0, x0<-x1, x0<-x2, x0) for example but any other
combination is equivalent.

epsilon_3 will take (x0<-x0, x0<-x1, x0<-x2) and one actual xi which is now
certain; we can resolve our previous uncertainty by following the path from
xi to x0 thus eliminating the fake choice we seemed to have.

Explain connection to negative information.

Knowing head or tails is 1 bits. Giving you a choice between heads and tails
and then cooking this so that heads=tails takes away your choice.

-- transp⇛ : {A B : Set} {x y : • A} →
-- (f : A → B) → x ⇛ y → ↑ (f (focus x)) ⇛ ↑ (f (focus y))

-- Morphism of pointed space: contains a path!
record _⟶_ {A B : Set} (pA : • A) (pB : • B) : Set₁ where
  field
    fun : A → B
    eq : ↑ (fun (focus pA)) ⇛ pB

open _⟶_

_○_ : {A B C : Set} {pA : • A} {pB : • B} {pC : • C} → pA ⟶ pB → pB ⟶ pC → pA ⟶ pC
f ○ g = record { fun = λ x → (fun g) ((fun f) x) ; eq = trans⇛ (transp⇛ (fun g) (eq f)) (eq g)}

mutual

  ap : {A B : Set} {x : • A} {y : • B} → x ⇛ y → x ⟶ y
  ap {y = y} unite₊⇛ = record { fun = λ { (inj₁ ())
                                        ; (inj₂ x) → x } ; eq = id⇛ y }
  ap uniti₊⇛ (singleton x) = singleton (inj₂ x)
  ap (swap₁₊⇛ {A} {B} {x}) (singleton .(inj₁ x)) = singleton (inj₂ x)
  ap (swap₂₊⇛ {A} {B} {y}) (singleton .(inj₂ y)) = singleton (inj₁ y)
  ap (assocl₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ x)) =
    singleton (inj₁ (inj₁ x))
  ap (assocl₂₁₊⇛ {A} {B} {C} {y}) (singleton .(inj₂ (inj₁ y))) =
    singleton (inj₁ (inj₂ y))
  ap (assocl₂₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ (inj₂ z))) =
    singleton (inj₂ z)
  ap (assocr₁₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ (inj₁ x))) =
    singleton (inj₁ x)
  ap (assocr₁₂₊⇛ {A} {B} {C} {y}) (singleton .(inj₁ (inj₂ y))) =
    singleton (inj₂ (inj₁ y))
  ap (assocr₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ z)) =
    singleton (inj₂ (inj₂ z))
  ap {.(⊤ × A)} {A} {.(tt , x)} {x} unite⋆⇛ (singleton .(tt , x)) =
    singleton x
  ap uniti⋆⇛ (singleton x) = singleton (tt , x)
  ap (swap⋆⇛ {A} {B} {x} {y}) (singleton .(x , y)) = singleton (y , x)
  ap (assocl⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .(x , (y , z))) =
    singleton ((x , y) , z)
  ap (assocr⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .((x , y) , z)) =
    singleton (x , (y , z))
  ap (dist₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ x , z)) =
    singleton (inj₁ (x , z))
  ap (dist₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ y , z)) =
    singleton (inj₂ (y , z))
  ap (factor₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ (x , z))) =
    singleton (inj₁ x , z)
  ap (factor₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ (y , z))) =
    singleton (inj₂ y , z)
  ap {.(⊥ × A)} {.⊥} {.(• , x)} {•} (dist0⇛ {A} {.•} {x}) (singleton .(• , x)) =
    singleton •
  ap factor0⇛ (singleton ())
  ap {x = x} (id⇛ .x) = record { fun = λ x → x; eq = id⇛ x }
  ap (sym⇛ c) = apI c
  ap (trans⇛ c₁ c₂) = (ap c₁) ○ (ap c₂)
  ap (transp⇛ f a) = record { fun = λ x → x; eq = transp⇛ f a }

  ap (plus₁⇛ {A} {B} {C} {D} {x} {z} c) (singleton .(inj₁ x))
    with ap c (singleton x)
  ... | singleton .z = singleton (inj₁ z)
  ap (plus₂⇛ {A} {B} {C} {D} {y} {w} c) (singleton .(inj₂ y))
    with ap c (singleton y)
  ... | singleton .w = singleton (inj₂ w)
  ap (times⇛ {A} {B} {C} {D} {x} {y} {z} {w} c₁ c₂) (singleton .(x , y))
    with ap c₁ (singleton x) | ap c₂ (singleton y)
  ... | singleton .z | singleton .w = singleton (z , w)

  apI : {A B : Set} {x : • A} {y : • B} → x ⇛ y → y ⟶ x
  apI {y = y} unite₊⇛ = record { fun = inj₂; eq = id⇛ (↑ (inj₂ (focus y))) }

 apI {A} {.(⊥ ⊎ A)} {x} uniti₊⇛ (singleton .(inj₂ x)) = singleton x
  apI (swap₁₊⇛ {A} {B} {x}) (singleton .(inj₂ x)) = singleton (inj₁ x)
  apI (swap₂₊⇛ {A} {B} {y}) (singleton .(inj₁ y)) = singleton (inj₂ y)
  apI (assocl₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ (inj₁ x))) =
    singleton (inj₁ x)
  apI (assocl₂₁₊⇛ {A} {B} {C} {y}) (singleton .(inj₁ (inj₂ y))) =
    singleton (inj₂ (inj₁ y))
  apI (assocl₂₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ z)) =
    singleton (inj₂ (inj₂ z))
  apI (assocr₁₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ x)) =
    singleton (inj₁ (inj₁ x))
  apI (assocr₁₂₊⇛ {A} {B} {C} {y}) (singleton .(inj₂ (inj₁ y))) =
    singleton (inj₁ (inj₂ y))
  apI (assocr₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ (inj₂ z))) =
    singleton (inj₂ z)
  apI unite⋆⇛ (singleton x) = singleton (tt , x)
  apI {A} {.(⊤ × A)} {x} uniti⋆⇛ (singleton .(tt , x)) = singleton x
  apI (swap⋆⇛ {A} {B} {x} {y}) (singleton .(y , x)) = singleton (x , y)
  apI (assocl⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .((x , y) , z)) =
    singleton (x , (y , z))
  apI (assocr⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .(x , (y , z))) =
    singleton ((x , y) , z)
  apI (dist₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ (x , z))) =
    singleton (inj₁ x , z)
  apI (dist₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ (y , z))) =
    singleton (inj₂ y , z)
  apI (factor₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ x , z)) =
    singleton (inj₁ (x , z))
  apI (factor₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ y , z)) =
    singleton (inj₂ (y , z))
  apI dist0⇛ (singleton ())
  apI {.⊥} {.(⊥ × A)} {•} (factor0⇛ {A} {.•} {x}) (singleton .(• , x)) =
    singleton •

  apI {x = x} (id⇛ .x) = record { fun = λ x → x; eq = id⇛ x }
  apI (sym⇛ c) = ap c
  apI (trans⇛ c₁ c₂) = (apI c₂) ○ (apI c₁)
  apI (transp⇛ f a) = record { fun = λ x → x; eq = transp⇛ f (sym⇛ a) }

  apI (plus₁⇛ {A} {B} {C} {D} {x} {z} c) (singleton .(inj₁ z))
    with apI c (singleton z)
  ... | singleton .x = singleton (inj₁ x)
  apI (plus₂⇛ {A} {B} {C} {D} {y} {w} c) (singleton .(inj₂ w))
    with apI c (singleton w)
  ... | singleton .y = singleton (inj₂ y)
  apI (times⇛ {A} {B} {C} {D} {x} {y} {z} {w} c₁ c₂) (singleton .(z , w))
    with apI c₁ (singleton z) | apI c₂ (singleton w)
  ... | singleton .x | singleton .y = singleton (x , y)

--}

--}


{-# OPTIONS --safe #-}
module STLC.Operational.Base where

open import STLC.Syntax
open import Data.Empty using (⊥-elim)
open import Data.Nat using (ℕ; suc)
open import Data.Fin using (Fin; _≟_; punchOut; punchIn)
  renaming (zero to fzero; suc to fsuc)
open import Relation.Binary.PropositionalEquality using (_≢_; refl; sym)
open import Relation.Nullary using (yes; no)
open import Function.Base using (_∘_)

private
  variable
    n : ℕ
    a : Type
    fin : Fin n

-- | Increments the variables that are free relative to the inserted "pivot" variable.
lift : Term n → Fin (suc n) → Term (suc n)
lift (abs ty body) v = abs ty (lift body (fsuc v))
lift (app f x) v = app (lift f v) (lift x v)
lift (var n) v = var (punchIn v n)
lift ⋆ v = ⋆
lift (pair x y) v = pair (lift x v) (lift y v)
lift (projₗ p) v = projₗ (lift p v)
lift (projᵣ p) v = projᵣ (lift p v)

-- | Inserts a binding in the middle of the context.
liftΓ : Ctx n → Fin (suc n) → Type → Ctx (suc n)
liftΓ Γ fzero t = Γ ,- t
liftΓ (Γ ,- A) (fsuc v) t = (liftΓ Γ v t) ,- A

infix 7 _[_≔_]

_[_≔_] : Term (suc n) → Fin (suc n) → Term n → Term n
(abs ty body) [ v ≔ def ] = abs ty (body [ fsuc v ≔ lift def fzero ])
(app f x)     [ v ≔ def ] = app (f [ v ≔ def ]) (x [ v ≔ def ])
(var n)       [ v ≔ def ] with v ≟ n
... | yes refl = def
... | no neq = var (punchOut {i = v} {j = n} λ { refl → neq (sym refl)})
⋆             [ v ≔ def ] = ⋆
(pair x y)    [ v ≔ def ] = pair (x [ v ≔ def ]) (y [ v ≔ def ])
(projₗ p)     [ v ≔ def ] = projₗ (p [ v ≔ def ])
(projᵣ p)     [ v ≔ def ] = projᵣ (p [ v ≔ def ])


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.AbGroup.TensorProduct where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function hiding (flip)
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels

open import Cubical.Relation.Binary

open import Cubical.Data.Nat as ℕ
open import Cubical.Data.Int using (ℤ)
open import Cubical.Data.List
open import Cubical.Data.Sigma
open import Cubical.Data.Sum hiding (map)

open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.AbGroup.Base

private
  variable
    ℓ ℓ' : Level

module _ (AGr : AbGroup ℓ) (BGr : AbGroup ℓ') where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G_)

    strA = snd AGr
    strB = snd BGr

    A = fst AGr
    B = fst BGr

    0A = 0g strA
    0B = 0g strB

    _+A_ = _+G_ strA
    _+B_ = _+G_ strB

    -A_ = -G_ strA
    -B_ = -G_ strB

  data _⨂₁_ : Type (ℓ-max ℓ ℓ') where
   _⊗_     : (a : A) → (b : B) → _⨂₁_
   _+⊗_    : (w : _⨂₁_) → (u : _⨂₁_) → _⨂₁_

   +⊗Comm   : (x y : _) → x +⊗ y ≡ y +⊗ x
   +⊗Assoc  : (x y z : _) → x +⊗ (y +⊗ z) ≡ (x +⊗ y) +⊗ z
   +⊗IdL    : (x : _) → (0A ⊗ 0B) +⊗ x ≡ x

   ⊗DistR+⊗ : (x : A) (y z : B) → x ⊗ (y +B z) ≡ ((x ⊗ y) +⊗ (x ⊗ z))
   ⊗DistL+⊗ : (x y : A) (z : B) → (x +A y) ⊗ z ≡ ((x ⊗ z) +⊗ (y ⊗ z))

   ⊗squash : isSet _⨂₁_

module _ {AGr : AbGroup ℓ} {BGr : AbGroup ℓ'} where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G_)

    strA = snd AGr
    strB = snd BGr

    A = fst AGr
    B = fst BGr

    0A = 0g strA
    0B = 0g strB

    _+A_ = _+G_ strA
    _+B_ = _+G_ strB

    -A_ = -G_ strA
    -B_ = -G_ strB

  A⊗B = AGr ⨂₁ BGr

  ⊗elimProp : ∀ {ℓ} {C : AGr ⨂₁ BGr → Type ℓ}
           → ((x : _) → isProp (C x))
           → (f : (x : A) (b : B) → C (x ⊗ b))
           → (g : ((x y : _) → C x → C y → C (x +⊗ y)))
           → (x : _) → C x
  ⊗elimProp p f g (a ⊗ b) = f a b
  ⊗elimProp p f g (x +⊗ y) = g x y (⊗elimProp p f g x) (⊗elimProp p f g y)
  ⊗elimProp {C = C} p f g (+⊗Comm x y j) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (g x y (⊗elimProp p f g x) (⊗elimProp p f g y))
      (g y x (⊗elimProp p f g y) (⊗elimProp p f g x)) (+⊗Comm x y) j
  ⊗elimProp {C = C} p f g (+⊗Assoc x y z j) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (g x (y +⊗ z) (⊗elimProp p f g x)
         (g y z (⊗elimProp p f g y) (⊗elimProp p f g z)))
         (g (x +⊗ y) z (g x y (⊗elimProp p f g x)
           (⊗elimProp p f g y)) (⊗elimProp p f g z)) (+⊗Assoc x y z) j
  ⊗elimProp {C = C} p f g (+⊗IdL x i) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (g (0A ⊗ 0B) x (f 0A 0B) (⊗elimProp p f g x))
      (⊗elimProp p f g x)
      (+⊗IdL x) i
  ⊗elimProp {C = C} p f g (⊗DistR+⊗ x y z i) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (f x (y +B z)) (g (x ⊗ y) (x ⊗ z) (f x y) (f x z)) (⊗DistR+⊗ x y z) i
  ⊗elimProp {C = C} p f g (⊗DistL+⊗ x y z i) =
    isOfHLevel→isOfHLevelDep 1 {B = C} p
      (f (x +A y) z) (g (x ⊗ z) (y ⊗ z) (f x z) (f y z)) (⊗DistL+⊗ x y z) i
  ⊗elimProp {C = C} p f g (⊗squash x y q r i j) =
    isOfHLevel→isOfHLevelDep 2 {B = C} (λ x → isProp→isSet (p x))
      _ _ (λ j → ⊗elimProp p f g (q j)) (λ j → ⊗elimProp p f g (r j))
          (⊗squash x y q r) i j

  -- Group structure
  0⊗ : AGr ⨂₁ BGr
  0⊗ = 0A ⊗ 0B

  -⊗ : AGr ⨂₁ BGr → AGr ⨂₁ BGr
  -⊗ (a ⊗ b) = (-A a) ⊗ b
  -⊗ (x +⊗ x₁) = -⊗ x +⊗ -⊗ x₁
  -⊗ (+⊗Comm x y i) = +⊗Comm (-⊗ x) (-⊗ y) i
  -⊗ (+⊗Assoc x y z i) = +⊗Assoc (-⊗ x) (-⊗ y) (-⊗ z) i
  -⊗ (+⊗IdL x i) = ((λ i → (GroupTheory.inv1g (AbGroup→Group AGr) i ⊗ 0B) +⊗ -⊗ x)
                   ∙ +⊗IdL (-⊗ x)) i
  -⊗ (⊗DistR+⊗ x y z i) = ⊗DistR+⊗ (-A x) y z i
  -⊗ (⊗DistL+⊗ x y z i) = ((λ i → (GroupTheory.invDistr (AbGroup→Group AGr) x y
                           ∙ +Comm strA (-A y) (-A x)) i ⊗ z)
                           ∙ ⊗DistL+⊗ (-A x) (-A y) z) i
  -⊗ (⊗squash x y p q i j) = ⊗squash _ _ (λ j → -⊗ (p j)) (λ j → -⊗ (q j)) i j

  +⊗IdR : (x : A⊗B) → x +⊗ 0⊗ ≡ x
  +⊗IdR x = +⊗Comm x 0⊗ ∙ +⊗IdL x

  -------------------------------------------------------------------------------
  -- Useful induction principle, which lets us view elements of A ⨂ B as lists
  -- over (A × B). Used for the right cancellation law
  unlist : List (A × B) → AGr ⨂₁ BGr
  unlist [] = 0A ⊗ 0B
  unlist (x ∷ x₁) = (fst x ⊗ snd x) +⊗ unlist x₁

  unlist++ : (x y : List (A × B))  → unlist (x ++ y) ≡ (unlist x +⊗ unlist y)
  unlist++ [] y = sym (+⊗IdL (unlist y))
  unlist++ (x ∷ x₁) y = (λ i → (fst x ⊗ snd x) +⊗ (unlist++ x₁ y i))
                        ∙ +⊗Assoc (fst x ⊗ snd x) (unlist x₁) (unlist y)

  ∃List : (x : AGr ⨂₁ BGr) → ∃[ l ∈ List (A × B) ] (unlist l ≡ x)
  ∃List = ⊗elimProp (λ _ → squash₁)
          (λ a b → ∣ [ a , b ] , +⊗IdR (a ⊗ b) ∣₁)
          λ x y → rec2 squash₁ λ {(l1 , p) (l2 , q) →
                  ∣ (l1 ++ l2) , unlist++ l1 l2 ∙ cong₂ _+⊗_ p q ∣₁}

  ⊗elimPropUnlist : ∀ {ℓ} {C : AGr ⨂₁ BGr → Type ℓ}
           → ((x : _) → isProp (C x))
           → ((x : _) → C (unlist x))
           → (x : _) → C x
  ⊗elimPropUnlist {C = C} p f =
    ⊗elimProp p (λ x y → subst C (+⊗IdR (x ⊗ y)) (f [ x , y ]))
      λ x y → PT.rec (isPropΠ2 λ _ _ → p _)
                    (PT.rec (isPropΠ3 λ _ _ _ → p _)
                      (λ {(l1 , p) (l2 , q) ind1 ind2
                        → subst C (unlist++ l2 l1 ∙ cong₂ _+⊗_ q p) (f (l2 ++ l1))})
                      (∃List y))
                    (∃List x)
  -----------------------------------------------------------------------------------

  ⊗AnnihilL : (x : B) → (0A ⊗ x) ≡ 0⊗
  ⊗AnnihilL x = sym (+⊗IdR _)
                 ∙∙ cong ((0A ⊗ x) +⊗_) (sym cancelLem)
                 ∙∙ +⊗Assoc (0A ⊗ x) (0A ⊗ x) (0A ⊗ (-B x))
                 ∙∙ cong (_+⊗ (0A ⊗ (-B x))) inner
                 ∙∙ cancelLem
    where
    cancelLem : (0A ⊗ x) +⊗ (0A ⊗ (-B x)) ≡ 0⊗
    cancelLem = sym (⊗DistR+⊗ 0A x (-B x)) ∙ (λ i → 0A ⊗ +InvR strB x i)

    inner : (0A ⊗ x) +⊗ (0A ⊗ x) ≡ 0A ⊗ x
    inner = sym (⊗DistL+⊗ 0A 0A x) ∙ (λ i → +IdR strA 0A i ⊗ x)

  ⊗AnnihilR : (x : A) → (x ⊗ 0B) ≡ 0⊗
  ⊗AnnihilR x = sym (+⊗IdR _)
                ∙∙ cong ((x ⊗ 0B) +⊗_) (sym cancelLem)
                ∙∙ +⊗Assoc (x ⊗ 0B) (x ⊗ 0B) ((-A x) ⊗ 0B)
                ∙∙ cong (_+⊗ ((-A x) ⊗ 0B)) inner
                ∙∙ cancelLem
    where
    cancelLem : (x ⊗ 0B) +⊗ ((-A x) ⊗ 0B) ≡ 0⊗
    cancelLem = sym (⊗DistL+⊗ x (-A x) 0B) ∙ (λ i → +InvR strA x i ⊗ 0B)

    inner : (x ⊗ 0B) +⊗ (x ⊗ 0B) ≡ x ⊗ 0B
    inner = sym (⊗DistR+⊗ x 0B 0B) ∙ (λ i → x ⊗ +IdR strB 0B i)

  flip : (x : A) (b : B) → x ⊗ (-B b) ≡ ((-A x) ⊗ b)
  flip x b = sym (+⊗IdR _)
             ∙ cong ((x ⊗ (-B b)) +⊗_) (sym cancelLemA)
             ∙ +⊗Assoc (x ⊗ (-B b)) (x ⊗ b) ((-A x) ⊗ b)
             ∙ cong (_+⊗ ((-A x) ⊗ b)) cancelLemB
             ∙ +⊗IdL _
    where
    cancelLemA : (x ⊗ b) +⊗ ((-A x) ⊗ b) ≡ 0⊗
    cancelLemA = sym (⊗DistL+⊗ x (-A x) b) ∙ (λ i → +InvR strA x i ⊗ b) ∙ ⊗AnnihilL b

    cancelLemB : (x ⊗ (-B b)) +⊗ (x ⊗ b) ≡ 0⊗
    cancelLemB = sym (⊗DistR+⊗ x (-B b) b) ∙ (λ i → x ⊗ +InvL strB b i) ∙ ⊗AnnihilR x

  +⊗InvR : (x : AGr ⨂₁ BGr) → (x +⊗ -⊗ x) ≡ 0⊗
  +⊗InvR =
    ⊗elimPropUnlist (λ _ → ⊗squash _ _) h
    where
    h : (x : List (A × B)) → (unlist x +⊗ -⊗ (unlist x)) ≡ 0⊗
    h [] = sym (⊗DistL+⊗ 0A (-A 0A) (0B))
            ∙ cong (λ x →  _⊗_ {AGr = AGr} {BGr = BGr} x 0B) (+InvR strA 0A)
    h (x ∷ x₁) = move4 (fst x ⊗ snd x) (unlist x₁) ((-A fst x) ⊗ snd x) (-⊗ (unlist x₁))
                       _+⊗_ +⊗Assoc +⊗Comm
                 ∙∙ cong₂ _+⊗_ (sym (⊗DistL+⊗ (fst x) (-A (fst x)) (snd x))
                               ∙∙ (λ i → +InvR strA (fst x) i ⊗ (snd x))
                               ∙∙ ⊗AnnihilL (snd x))
                               (h x₁)
                 ∙∙ +⊗IdR 0⊗

  +⊗InvL : (x : AGr ⨂₁ BGr) → (-⊗ x +⊗ x) ≡ 0⊗
  +⊗InvL x = +⊗Comm _ _ ∙ +⊗InvR x

module _ where
  open AbGroupStr

  _⨂_ : AbGroup ℓ → AbGroup ℓ' → AbGroup (ℓ-max ℓ ℓ')
  fst (A ⨂ B) = A ⨂₁ B
  0g (snd (A ⨂ B)) = 0⊗
  AbGroupStr._+_ (snd (A ⨂ B)) = _+⊗_
  AbGroupStr.- snd (A ⨂ B) = -⊗
  isAbGroup (snd (A ⨂ B)) = makeIsAbGroup ⊗squash +⊗Assoc +⊗IdR +⊗InvR +⊗Comm

-------------- Elimination principle into AbGroups --------------
module _ {ℓ ℓ' : Level} {A : AbGroup ℓ}  {B : AbGroup ℓ'} where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G)
    _+A_ = _+G_ (snd A)
    _+B_ = _+G_ (snd B)

    0A = 0g (snd A)
    0B = 0g (snd B)

  ⨂→AbGroup-elim : ∀ {ℓ} (C : AbGroup ℓ)
         → (f : (fst A × fst B) → fst C)
         → (f (0A , 0B) ≡ 0g (snd C))
         → (linR : (a : fst A) (x y : fst B)
                 → f (a , x +B y) ≡ _+G_ (snd C) (f (a , x)) (f (a , y)))
         → (linL : (x y : fst A) (b : fst B)
                 → f (x +A y , b) ≡ _+G_ (snd C) (f (x , b)) (f (y , b)))
         → A ⨂₁ B → fst C
  ⨂→AbGroup-elim C f p linR linL (a ⊗ b) = f (a , b)
  ⨂→AbGroup-elim C f p linR linL (x +⊗ x₁) =
    _+G_ (snd C) (⨂→AbGroup-elim C f p linR linL x)
                 (⨂→AbGroup-elim C f p linR linL x₁)
  ⨂→AbGroup-elim C f p linR linL (+⊗Comm x x₁ i) =
    +Comm (snd C) (⨂→AbGroup-elim C f p linR linL x)
                  (⨂→AbGroup-elim C f p linR linL x₁) i
  ⨂→AbGroup-elim C f p linR linL (+⊗Assoc x x₁ x₂ i) =
    +Assoc (snd C) (⨂→AbGroup-elim C f p linR linL x)
                   (⨂→AbGroup-elim C f p linR linL x₁)
                   (⨂→AbGroup-elim C f p linR linL x₂) i
  ⨂→AbGroup-elim C f p linR linL (+⊗IdL x i) =
    (cong (λ y → (snd C +G y) (⨂→AbGroup-elim C f p linR linL x)) p
                     ∙ (+IdL (snd C) (⨂→AbGroup-elim C f p linR linL x))) i
  ⨂→AbGroup-elim C f p linR linL (⊗DistR+⊗ x y z i) = linR x y z i
  ⨂→AbGroup-elim C f p linR linL (⊗DistL+⊗ x y z i) = linL x y z i
  ⨂→AbGroup-elim C f p linR linL (⊗squash x x₁ x₂ y i i₁) =
    is-set (snd C) _ _
           (λ i → ⨂→AbGroup-elim C f p linR linL (x₂ i))
           (λ i → ⨂→AbGroup-elim C f p linR linL (y i)) i i₁

  ⨂→AbGroup-elim-hom : ∀ {ℓ} (C : AbGroup ℓ)
        → (f : (fst A × fst B) → fst C) (linR : _) (linL : _) (p : _)
        → AbGroupHom (A ⨂ B) C
  fst (⨂→AbGroup-elim-hom C f linR linL p) = ⨂→AbGroup-elim C f p linR linL
  snd (⨂→AbGroup-elim-hom C f linR linL p) = makeIsGroupHom (λ x y → refl)

private
  _* = AbGroup→Group

----------- Definition of universal property ------------
tensorFun : (A : Group ℓ) (B : Group ℓ') (T C : AbGroup (ℓ-max ℓ ℓ'))
            (f : GroupHom A (HomGroup B T *))
            → GroupHom (T *) (C *)
            → GroupHom A (HomGroup B C *)
fst (fst (tensorFun A B T C (f , p) (g , q)) a) b = g (fst (f a) b)
snd (fst (tensorFun A B T C (f , p) (g , q)) a) =
     makeIsGroupHom
     λ x y → cong g (IsGroupHom.pres· (snd (f a)) x y)
              ∙ IsGroupHom.pres· q _ _
snd (tensorFun A B T C (f , p) (g , q)) =
     makeIsGroupHom
     λ x y → Σ≡Prop (λ _ → isPropIsGroupHom _ _)
                     (funExt λ b → cong g (funExt⁻ (cong fst (IsGroupHom.pres· p x y)) b)
                                    ∙ IsGroupHom.pres· q _ _)

isTensorProductOf_and_ : AbGroup ℓ → AbGroup ℓ' → AbGroup (ℓ-max ℓ ℓ')→ Type _
isTensorProductOf_and_ {ℓ} {ℓ'} A B T =
  Σ[ f ∈ GroupHom (A *) ((HomGroup (B *) T) *) ]
    ((C : AbGroup (ℓ-max ℓ ℓ')) → isEquiv {A = GroupHom (T *) (C *)}
                                           {B = GroupHom (A *) ((HomGroup (B *) C) *)}
                                           (tensorFun (A *) (B *) T C f))

------ _⨂_ satisfies the universal property --------
module UP (AGr : AbGroup ℓ) (BGr : AbGroup ℓ') where
  private
    open AbGroupStr renaming (_+_ to _+G_ ; -_ to -G_)

    strA = snd AGr
    strB = snd BGr

    A = fst AGr
    B = fst BGr

    0A = 0g strA
    0B = 0g strB

    _+A_ = _+G_ strA
    _+B_ = _+G_ strB

    -A_ = -G_ strA
    -B_ = -G_ strB

  mainF : GroupHom (AGr *) (HomGroup (BGr *) (AGr ⨂ BGr) *)
  fst (fst mainF a) b = a ⊗ b
  snd (fst mainF a) = makeIsGroupHom (⊗DistR+⊗ a)
  snd mainF = makeIsGroupHom
              λ x y → Σ≡Prop (λ _ → isPropIsGroupHom _ _)
                              (funExt (⊗DistL+⊗ x y))

  isTensorProduct⨂ : (isTensorProductOf AGr and BGr) (AGr ⨂ BGr)
  fst isTensorProduct⨂ = mainF
  snd isTensorProduct⨂ C = isoToIsEquiv mainIso
    where
    invF : GroupHom (AGr *) (HomGroup (BGr *) C *) → GroupHom ((AGr ⨂ BGr) *) (C *)
    fst (invF (f , p)) = F
      where
      lem : f (0g (snd AGr)) .fst (0g (snd BGr)) ≡ 0g (snd C)
      lem = funExt⁻ (cong fst (IsGroupHom.pres1 p)) (0g (snd BGr))
      F : ((AGr ⨂ BGr) *) .fst → (C *) .fst
      F (a ⊗ b) = f a .fst b
      F (x +⊗ x₁) = _+G_ (snd C) (F x) (F x₁)
      F (+⊗Comm x x₁ i) = +Comm (snd C) (F x) (F x₁) i
      F (+⊗Assoc x y z i) = +Assoc (snd C) (F x) (F y) (F z) i
      F (+⊗IdL x i) = (cong (λ y → _+G_ (snd C) y (F x)) lem ∙ +IdL (snd C) (F x)) i
      F (⊗DistR+⊗ x y z i) = IsGroupHom.pres· (f x .snd) y z i
      F (⊗DistL+⊗ x y z i) = fst (IsGroupHom.pres· p x y i) z
      F (⊗squash x x₁ x₂ y i i₁) = is-set (snd C) (F x) (F x₁)
                                   (λ i → F (x₂ i)) (λ i → F (y i)) i i₁
    snd (invF (f , p)) = makeIsGroupHom λ x y → refl

    mainIso : Iso (GroupHom ((AGr ⨂ BGr) *) (C *))
                  (GroupHom (AGr *) (HomGroup (BGr *) C *))
    Iso.fun mainIso = _
    Iso.inv mainIso = invF
    Iso.rightInv mainIso (f , p) = Σ≡Prop (λ _ → isPropIsGroupHom _ _)
                                   (funExt λ a → Σ≡Prop (λ _ → isPropIsGroupHom _ _) refl)
    Iso.leftInv mainIso (f , p) =
        Σ≡Prop (λ _ → isPropIsGroupHom _ _)
                (funExt (⊗elimProp (λ _ → is-set (snd C) _ _)
                                   (λ _ _ → refl)
                                    λ x y ind1 ind2 → cong₂ (_+G_ (snd C)) ind1 ind2
                                                       ∙ sym (IsGroupHom.pres· p x y)))

-------------------- Commutativity ------------------------
commFun : ∀ {ℓ ℓ'} {A : AbGroup ℓ}  {B : AbGroup ℓ'} → A ⨂₁ B → B ⨂₁ A
commFun (a ⊗ b) = b ⊗ a
commFun (x +⊗ x₁) = commFun x +⊗ commFun x₁
commFun (+⊗Comm x x₁ i) = +⊗Comm (commFun x) (commFun x₁) i
commFun (+⊗Assoc x x₁ x₂ i) = +⊗Assoc (commFun x) (commFun x₁) (commFun x₂) i
commFun (+⊗IdL x i) = +⊗IdL (commFun x) i
commFun (⊗DistR+⊗ x y z i) = ⊗DistL+⊗ y z x i
commFun (⊗DistL+⊗ x y z i) = ⊗DistR+⊗ z x y i
commFun (⊗squash x x₁ x₂ y i i₁) = ⊗squash (commFun x) (commFun x₁)
                                           (λ i → commFun (x₂ i)) (λ i → commFun (y i)) i i₁

commFun²≡id : ∀ {ℓ ℓ'} {A : AbGroup ℓ}  {B : AbGroup ℓ'} (x : A ⨂₁ B)
               → commFun (commFun x) ≡ x
commFun²≡id = ⊗elimProp (λ _ → ⊗squash _ _)
                        (λ _ _ → refl)
                        (λ _ _ p q → cong₂ _+⊗_ p q)

⨂-commIso : ∀ {ℓ ℓ'} {A : AbGroup ℓ} {B : AbGroup ℓ'}
          → GroupIso ((A ⨂ B) *) ((B ⨂ A) *)
Iso.fun (fst ⨂-commIso) = commFun
Iso.inv (fst ⨂-commIso) = commFun
Iso.rightInv (fst ⨂-commIso) = commFun²≡id
Iso.leftInv (fst ⨂-commIso) = commFun²≡id
snd ⨂-commIso = makeIsGroupHom λ x y → refl

⨂-comm : ∀ {ℓ ℓ'} {A : AbGroup ℓ} {B : AbGroup ℓ'} → AbGroupEquiv (A ⨂ B) (B ⨂ A)
fst ⨂-comm = isoToEquiv (fst (⨂-commIso))
snd ⨂-comm = snd ⨂-commIso

open AbGroupStr

-------------------- Associativity ------------------------
module _ {ℓ ℓ' ℓ'' : Level} {A : AbGroup ℓ} {B : AbGroup ℓ'} {C : AbGroup ℓ''} where
  private
    f : (c : fst C) → AbGroupHom (A ⨂ B) (A ⨂ (B ⨂ C))
    f c = ⨂→AbGroup-elim-hom (A ⨂ (B ⨂ C))
                               (λ ab → (fst ab) ⊗ ((snd ab) ⊗ c))
                               (λ a b b' → (λ i → a ⊗ (⊗DistL+⊗ b b' c i)) ∙ ⊗DistR+⊗ a (b ⊗ c) (b' ⊗ c))
                               (λ a a' b → ⊗DistL+⊗ a a' (b ⊗ c))
                               (⊗AnnihilL _ ∙ sym (⊗AnnihilL _))

  assocHom : AbGroupHom ((A ⨂ B) ⨂ C) (A ⨂ (B ⨂ C))
  assocHom = ⨂→AbGroup-elim-hom (A ⨂ (B ⨂ C))
                                  (λ x → f (snd x) .fst (fst x))
                                  helper
                                  (λ x y b → IsGroupHom.pres· (snd (f b)) x y)
                                  refl
    where
    helper : _
    helper = ⊗elimProp (λ _ → isPropΠ2 λ _ _ → ⊗squash _ _)
                       (λ a b x y → (λ i → a ⊗ (⊗DistR+⊗ b x y i))
                                     ∙∙ ⊗DistR+⊗ a (b ⊗ x) (b ⊗ y)
                                     ∙∙ refl)
                       λ a b ind1 ind2 x y → cong₂ _+⊗_ (ind1 x y) (ind2 x y)
                                              ∙∙ move4 (f x .fst a) (f y .fst a) (f x .fst b) (f y .fst b)
                                                       _+⊗_ +⊗Assoc +⊗Comm
                                              ∙∙ cong₂ _+⊗_
                                                       (sym (IsGroupHom.pres· (snd (f x)) a b))
                                                       (IsGroupHom.pres· (snd (f y)) a b)

module _ {ℓ ℓ' ℓ'' : Level} {A : AbGroup ℓ} {B : AbGroup ℓ'} {C : AbGroup ℓ''} where
  private
    f' : (a : fst A) → AbGroupHom (B ⨂ C) ((A ⨂ B) ⨂ C)
    f' a = ⨂→AbGroup-elim-hom
               ((A ⨂ B) ⨂ C)
               (λ bc → (a ⊗ fst bc) ⊗ snd bc)
               (λ x y b → ⊗DistR+⊗ (a ⊗ x) y b)
               (λ x y b → (λ i → (⊗DistR+⊗ a x y i) ⊗ b)
                           ∙ ⊗DistL+⊗ (a ⊗ x) (a ⊗ y) b)
               λ i → ⊗AnnihilR a i ⊗ (0g (snd C))

  assocHom⁻ : AbGroupHom (A ⨂ (B ⨂ C)) ((A ⨂ B) ⨂ C)
  assocHom⁻ = ⨂→AbGroup-elim-hom
                  ((A ⨂ B) ⨂ C)
                  (λ abc → f' (fst abc) .fst (snd abc))
                  (λ a → IsGroupHom.pres· (snd (f' a)))
                  helper
                  refl
       where
       helper : _
       helper = λ x y → ⊗elimProp
                         (λ _ → ⊗squash _ _)
                         (λ b c → (λ i → ⊗DistL+⊗ x y b i ⊗ c)
                                           ∙ ⊗DistL+⊗ (x ⊗ b) (y ⊗ b) c)
                          λ a b ind1 ind2 → cong₂ _+⊗_ ind1 ind2
                                             ∙∙ move4 _ _ _ _ _+⊗_ +⊗Assoc +⊗Comm
                                             ∙∙ cong₂ _+⊗_ (IsGroupHom.pres· (snd (f' x)) a b)
                                                (IsGroupHom.pres· (snd (f' y)) a b)

  ⨂assocIso : Iso (A ⨂₁ (B ⨂ C)) ((A ⨂ B) ⨂₁ C)
  Iso.fun ⨂assocIso = fst assocHom⁻
  Iso.inv ⨂assocIso = fst assocHom
  Iso.rightInv ⨂assocIso =
    ⊗elimProp (λ _ → ⊗squash _ _)
               (⊗elimProp (λ _ → isPropΠ (λ _ → ⊗squash _ _))
                           (λ a b c → refl)
                           λ a b ind1 ind2 c → cong₂ _+⊗_ (ind1 c) (ind2 c)
                                                ∙ sym (⊗DistL+⊗ a b c))
                λ x y p q → cong (fst assocHom⁻) (IsGroupHom.pres· (snd assocHom) x y)
                             ∙∙ IsGroupHom.pres· (snd assocHom⁻) (fst assocHom x) (fst assocHom y)
                             ∙∙ cong₂ _+⊗_ p q
  Iso.leftInv ⨂assocIso =
    ⊗elimProp (λ _ → ⊗squash _ _)
               (λ a → ⊗elimProp (λ _ → ⊗squash _ _)
                                  (λ b c → refl)
                                   λ x y ind1 ind2 →
                                        cong (fst assocHom ∘ fst assocHom⁻) (⊗DistR+⊗ a x y)
                                     ∙∙ cong (fst assocHom) (IsGroupHom.pres· (snd assocHom⁻) (a ⊗ x) (a ⊗ y))
                                     ∙∙ IsGroupHom.pres· (snd assocHom) (fst assocHom⁻ (a ⊗ x)) (fst assocHom⁻ (a ⊗ y))
                                     ∙∙ cong₂ _+⊗_ ind1 ind2
                                     ∙∙ sym (⊗DistR+⊗ a x y))
                λ x y p q → cong (fst assocHom) (IsGroupHom.pres· (snd assocHom⁻) x y)
                             ∙∙ IsGroupHom.pres· (snd assocHom) (fst assocHom⁻ x) (fst assocHom⁻ y)
                             ∙∙ cong₂ _+⊗_ p q

  ⨂assoc : AbGroupEquiv (A ⨂ (B ⨂ C)) ((A ⨂ B) ⨂ C)
  fst ⨂assoc = isoToEquiv ⨂assocIso
  snd ⨂assoc = snd assocHom⁻


------------------------------------------------------------------------------
-- Common definitions
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module Common.DefinitionsATP where

open import Common.FOL.FOL using ( ¬_ ; D )
open import Common.FOL.Relation.Binary.PropositionalEquality using ( _≡_ )

infix 4 _≢_

------------------------------------------------------------------------------
-- Inequality.
_≢_ : D → D → Set
x ≢ y = ¬ x ≡ y
{-# ATP definition _≢_ #-}


------------------------------------------------------------------------------
-- Well-founded induction on the natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Data.Nat.Induction.Acc.WF-I where

open import FOTC.Base
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.Type
open import FOTC.Induction.WF

------------------------------------------------------------------------------
-- The relation _<_ is well-founded.
module <-WF where
  <-wf : WellFounded _<_
  <-wf Nn = acc (helper Nn)
    where
    -- N.B. The helper function is the same that the function used by
    -- FOTC.Data.Nat.Induction.NonAcc.WellFoundedInductionATP.
    helper : ∀ {n m} → N n → N m → m < n → Acc N _<_ m
    helper nzero Nm m<0  = ⊥-elim (x<0→⊥ Nm m<0)
    helper (nsucc _) nzero 0<Sn = acc (λ Nm' m'<0 → ⊥-elim (x<0→⊥ Nm' m'<0))
    helper (nsucc {n} Nn) (nsucc {m} Nm) Sm<Sn =
      acc (λ {m'} Nm' m'<Sm →
             let m<n : m < n
                 m<n = Sx<Sy→x<y Sm<Sn

                 m'<n : m' < n
                 m'<n = case (λ m'<m → <-trans Nm' Nm Nn m'<m m<n)
                             (λ m'≡m → x≡y→y<z→x<z m'≡m m<n)
                             (x<Sy→x<y∨x≡y Nm' Nm m'<Sm)

             in  helper Nn Nm' m'<n
          )

  -- Well-founded induction on the natural numbers.
  <-wfind : (A : D → Set) →
             (∀ {n} → N n → (∀ {m} → N m → m < n → A m) → A n) →
             ∀ {n} → N n → A n
  <-wfind A = WellFoundedInduction <-wf

------------------------------------------------------------------------------
-- The relation _<_ is well-founded (a different proof).
module <-WF' where

  <-wf : WellFounded {N} _<_
  <-wf nzero      = acc (λ Nm m<0 → ⊥-elim (x<0→⊥ Nm m<0))
  <-wf (nsucc Nn) = acc (λ Nm m<Sn → helper Nm Nn (<-wf Nn)
                                          (x<Sy→x≤y Nm Nn m<Sn))
    where
    helper : ∀ {n m} → N n → N m → Acc N _<_ m → n ≤ m → Acc N _<_ n
    helper {n} {m} Nn Nm (acc h) n≤m = case (λ n<m → h Nn n<m)
                                            (λ n≡m → helper₁ (sym n≡m) (acc h))
                                            (x≤y→x<y∨x≡y Nn Nm n≤m)
      where
      helper₁ : ∀ {a b} → a ≡ b → Acc N _<_ a → Acc N _<_ b
      helper₁ refl h = h


abstract

  data D : Set where
    d : D

  data P : D → Set where
    p : P d

  d′ : D
  d′ = d

  d₂ : D
  d₂ = d

private
  abstract
    p′ : P d
    p′ = p

A : P d′
A = p′

-- A : Set₁ -- P d′
-- A = Set -- p′
--   where

--   abstract

--     p′ : P d
--     p′ = p


module Issue18 where

postulate
  D : Set

data ∃ (A : D → Set) : Set where
  _,_ : (witness : D) → A witness → ∃ A


------------------------------------------------------------------------
-- Colists
------------------------------------------------------------------------

{-# OPTIONS --without-K --sized-types #-}

open import Equality

module Colist {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

private
  open module E = Derived-definitions-and-properties eq using (_≡_)

open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

open import Conat eq as Conat using (Conat; zero; suc; force; infinity)
open import Function-universe eq hiding (id; _∘_)
import Nat eq as Nat

------------------------------------------------------------------------
-- The type

-- Colists.

mutual

  infixr 5 _∷_

  data Colist {a} (A : Type a) (i : Size) : Type a where
    []  : Colist A i
    _∷_ : A → Colist′ A i → Colist A i

  record Colist′ {a} (A : Type a) (i : Size) : Type a where
    coinductive
    field
      force : {j : Size< i} → Colist A j

open Colist′ public

------------------------------------------------------------------------
-- Some operations

-- A variant of cons.

infixr 5 _∷′_

_∷′_ : ∀ {i a} {A : Type a} → A → Colist A i → Colist A i
x ∷′ xs = x ∷ λ { .force → xs }

-- The colist's tail, if any.

tail : ∀ {a} {A : Type a} {i} → Colist A i → Colist′ A i
tail xs@[]    = λ { .force → xs }
tail (x ∷ xs) = xs

-- A map function.

map : ∀ {a b i} {A : Type a} {B : Type b} →
      (A → B) → Colist A i → Colist B i
map f []       = []
map f (x ∷ xs) = f x ∷ λ { .force → map f (force xs) }

-- The length of a colist.

length : ∀ {a i} {A : Type a} → Colist A i → Conat i
length []       = zero
length (n ∷ ns) = suc λ { .force → length (force ns) }

-- The colist replicate n x contains exactly n copies of x (and
-- nothing else).

replicate : ∀ {a i} {A : Type a} → Conat i → A → Colist A i
replicate zero    x = []
replicate (suc n) x = x ∷ λ { .force → replicate (force n) x }

-- Repeats the given element indefinitely.

repeat : ∀ {a i} {A : Type a} → A → Colist A i
repeat = replicate infinity

-- Appends one colist to another.

infixr 5 _++_

_++_ : ∀ {a i} {A : Type a} → Colist A i → Colist A i → Colist A i
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ λ { .force → force xs ++ ys }

-- The colist cycle x xs is an endless cycle of repetitions of the
-- colist x ∷ xs.

cycle : ∀ {a i} {A : Type a} → A → Colist′ A i → Colist A i
cycle x xs = x ∷ λ { .force → force xs ++ cycle x xs }

-- "Scan left".

scanl : ∀ {a b i} {A : Type a} {B : Type b} →
        (A → B → A) → A → Colist B i → Colist A i
scanl c n []       = n ∷ λ { .force → [] }
scanl c n (x ∷ xs) = n ∷ λ { .force → scanl c (c n x) (force xs) }

-- The natural numbers in strictly increasing order.

nats : ∀ {i} → Colist ℕ i
nats = 0 ∷ λ { .force → map suc nats }

-- The colist nats-from n is the natural numbers greater than or equal
-- to n, in strictly increasing order.

nats-from : ∀ {i} → ℕ → Colist ℕ i
nats-from n = n ∷ λ { .force → nats-from (suc n) }

-- The list take n xs is the longest possible prefix of xs that
-- contains at most n elements.

take : ∀ {a} {A : Type a} → ℕ → Colist A ∞ → List A
take zero    _        = []
take _       []       = []
take (suc n) (x ∷ xs) = x ∷ take n (force xs)

-- The sum of the successor of every element in the list.

sum-of-successors : ∀ {i} → Colist (Conat ∞) i → Conat i
sum-of-successors []       = zero
sum-of-successors (n ∷ ns) = suc λ { .force →
  n Conat.+ sum-of-successors (ns .force) }

------------------------------------------------------------------------
-- Bisimilarity

module _ {a} {A : Type a} where

  -- [ ∞ ] xs ∼ ys means that xs and ys are "equal".

  mutual

    infix 4 [_]_∼_ [_]_∼′_

    data [_]_∼_ (i : Size) : Colist A ∞ → Colist A ∞ → Type a where
      []  : [ i ] [] ∼ []
      _∷_ : ∀ {x y xs ys} →
            x ≡ y → [ i ] force xs ∼′ force ys → [ i ] x ∷ xs ∼ y ∷ ys

    record [_]_∼′_ (i : Size) (xs ys : Colist A ∞) : Type a where
      coinductive
      field
        force : {j : Size< i} → [ j ] xs ∼ ys

  open [_]_∼′_ public

  -- Bisimilarity is an equivalence relation.

  reflexive-∼ : ∀ {i} xs → [ i ] xs ∼ xs
  reflexive-∼ []       = []
  reflexive-∼ (x ∷ xs) =
    E.refl _ ∷ λ { .force → reflexive-∼ (force xs) }

  symmetric-∼ : ∀ {i xs ys} →
                [ i ] xs ∼ ys → [ i ] ys ∼ xs
  symmetric-∼ []        = []
  symmetric-∼ (p₁ ∷ p₂) =
    E.sym p₁ ∷ λ { .force → symmetric-∼ (force p₂) }

  transitive-∼ : ∀ {i xs ys zs} →
                 [ i ] xs ∼ ys → [ i ] ys ∼ zs → [ i ] xs ∼ zs
  transitive-∼ []        []        = []
  transitive-∼ (p₁ ∷ p₂) (q₁ ∷ q₂) =
    E.trans p₁ q₁ ∷ λ { .force → transitive-∼ (force p₂) (force q₂) }

  -- Equational reasoning combinators.

  infix  -1 _∎
  infixr -2 step-∼ step-≡ _∼⟨⟩_

  _∎ : ∀ {i} xs → [ i ] xs ∼ xs
  _∎ = reflexive-∼

  step-∼ : ∀ {i} xs {ys zs} →
           [ i ] ys ∼ zs → [ i ] xs ∼ ys → [ i ] xs ∼ zs
  step-∼ _ ys∼zs xs∼ys = transitive-∼ xs∼ys ys∼zs

  syntax step-∼ xs ys∼zs xs∼ys = xs ∼⟨ xs∼ys ⟩ ys∼zs

  step-≡ : ∀ {i} xs {ys zs} → [ i ] ys ∼ zs → xs ≡ ys → [ i ] xs ∼ zs
  step-≡ {i} _ ys∼zs xs≡ys = E.subst ([ i ]_∼ _) (E.sym xs≡ys) ys∼zs

  syntax step-≡ xs ys∼zs xs≡ys = xs ≡⟨ xs≡ys ⟩ ys∼zs

  _∼⟨⟩_ : ∀ {i} xs {ys} → [ i ] xs ∼ ys → [ i ] xs ∼ ys
  _ ∼⟨⟩ xs∼ys = xs∼ys

  -- A property relating Colist._∷_ and _∷′_.

  ∷∼∷′ : ∀ {i} {x : A} {xs} →
         [ i ] x ∷ xs ∼ x ∷′ force xs
  ∷∼∷′ = E.refl _ ∷ λ { .force → reflexive-∼ _ }

-- Functor laws.

map-id :
  ∀ {a i} {A : Type a} (xs : Colist A ∞) →
  [ i ] map id xs ∼ xs
map-id []       = []
map-id (_ ∷ xs) = E.refl _ ∷ λ { .force → map-id (force xs) }

map-∘ :
  ∀ {a b c i} {A : Type a} {B : Type b} {C : Type c}
    {f : B → C} {g : A → B}
  (xs : Colist A ∞) →
  [ i ] map (f ∘ g) xs ∼ map f (map g xs)
map-∘ []       = []
map-∘ (_ ∷ xs) = E.refl _ ∷ λ { .force → map-∘ (force xs) }

-- If two non-empty colists are bisimilar, then their heads are
-- bisimilar.

head-cong : ∀ {a i} {A : Type a} {x y : A} {xs ys} →
            [ i ] x ∷ xs ∼ y ∷ ys → x ≡ y
head-cong (p ∷ _) = p

-- Some preservation lemmas.

tail-cong :
  ∀ {a i} {A : Type a} {xs ys : Colist A ∞} →
  [ i ] xs ∼ ys → [ i ] force (tail xs) ∼′ force (tail ys)
tail-cong []       = λ { .force → [] }
tail-cong (_ ∷ ps) = ps

map-cong :
  ∀ {a b i} {A : Type a} {B : Type b} {f g : A → B} {xs ys} →
  (∀ x → f x ≡ g x) → [ i ] xs ∼ ys → [ i ] map f xs ∼ map g ys
map-cong             f≡g []                           = []
map-cong {f = f} {g} f≡g (_∷_ {x = x} {y = y} x≡y ps) =
  (f x  E.≡⟨ E.cong f x≡y ⟩
   f y  E.≡⟨ f≡g y ⟩∎
   g y  ∎) ∷ λ { .force →
  map-cong f≡g (force ps) }

length-cong :
  ∀ {a i} {A : Type a} {xs ys : Colist A ∞} →
  [ i ] xs ∼ ys → Conat.[ i ] length xs ∼ length ys
length-cong []       = zero
length-cong (_ ∷ ps) = suc λ { .force → length-cong (force ps) }

replicate-cong :
  ∀ {a i} {A : Type a} {m n} {x : A} →
  Conat.[ i ] m ∼ n → [ i ] replicate m x ∼ replicate n x
replicate-cong zero    = []
replicate-cong (suc p) =
  E.refl _ ∷ λ { .force → replicate-cong (force p) }

infixr 5 _++-cong_

_++-cong_ :
  ∀ {a i} {A : Type a} {xs₁ xs₂ ys₁ ys₂ : Colist A ∞} →
  [ i ] xs₁ ∼ ys₁ → [ i ] xs₂ ∼ ys₂ → [ i ] xs₁ ++ xs₂ ∼ ys₁ ++ ys₂
[]       ++-cong qs = qs
(p ∷ ps) ++-cong qs = p ∷ λ { .force → force ps ++-cong qs }

cycle-cong :
  ∀ {a i} {A : Type a} {x : A} {xs ys} →
  [ i ] force xs ∼′ force ys → [ i ] cycle x xs ∼ cycle x ys
cycle-cong p = E.refl _ ∷ λ { .force → force p ++-cong cycle-cong p }

scanl-cong :
  ∀ {a b i} {A : Type a} {B : Type b} {c : A → B → A} {n : A} {xs ys} →
  [ i ] xs ∼ ys → [ i ] scanl c n xs ∼ scanl c n ys
scanl-cong [] = E.refl _ ∷ λ { .force → [] }

scanl-cong {c = c} {n}
           (_∷_ {x = x} {y = y} {xs = xs} {ys = ys} x≡y ps) =
  E.refl n ∷ λ { .force →
    scanl c (c n x) (force xs)  ≡⟨ E.cong (λ x → scanl _ (c _ x) _) x≡y ⟩
    scanl c (c n y) (force xs)  ∼⟨ scanl-cong (force ps) ⟩
    scanl c (c n y) (force ys)  ∎ }

take-cong :
  ∀ {a} {A : Type a} n {xs ys : Colist A ∞} →
  [ ∞ ] xs ∼ ys → take n xs ≡ take n ys
take-cong n       []       = E.refl _
take-cong zero    (p ∷ ps) = E.refl _
take-cong (suc n) (p ∷ ps) = E.cong₂ _∷_ p (take-cong n (force ps))

sum-of-successors-cong :
  ∀ {i ms ns} →
  [ i ] ms ∼ ns →
  Conat.[ i ] sum-of-successors ms ∼ sum-of-successors ns
sum-of-successors-cong []       = zero
sum-of-successors-cong (p ∷ ps) = suc λ { .force →
  E.subst (Conat.[ _ ] _ ∼_) p (Conat.reflexive-∼ _)
    Conat.+-cong
  sum-of-successors-cong (ps .force) }

-- The length of replicate n x is bisimilar to n.

length-replicate :
  ∀ {a i} {A : Type a} {x : A} n →
  Conat.[ i ] length (replicate n x) ∼ n
length-replicate zero    = zero
length-replicate (suc n) =
  suc λ { .force → length-replicate (force n) }

-- A lemma relating nats and nats-from n.

map-+-nats∼nats-from :
  ∀ {i} n → [ i ] map (n +_) nats ∼ nats-from n
map-+-nats∼nats-from n = Nat.+-right-identity ∷ λ { .force →
  map (n +_) (map suc nats)  ∼⟨ symmetric-∼ (map-∘ _) ⟩
  map ((n +_) ∘ suc) nats    ∼⟨ map-cong (λ _ → E.sym (Nat.suc+≡+suc _)) (_ ∎) ⟩
  map (suc n +_) nats        ∼⟨ map-+-nats∼nats-from (suc n) ⟩
  nats-from (suc n)          ∎ }

-- The colist nats is bisimilar to nats-from 0.

nats∼nats-from-0 : ∀ {i} → [ i ] nats ∼ nats-from 0
nats∼nats-from-0 =
  nats             ∼⟨ symmetric-∼ (map-id _) ⟩
  map id nats      ∼⟨⟩
  map (0 +_) nats  ∼⟨ map-+-nats∼nats-from _ ⟩
  nats-from 0      ∎

------------------------------------------------------------------------
-- The ◇ predicate

-- ◇ ∞ P xs means that P holds for some element in xs.

data ◇ {a p} {A : Type a} (i : Size)
       (P : A → Type p) : Colist A ∞ → Type (a ⊔ p) where
  here  : ∀ {x xs} → P x → ◇ i P (x ∷ xs)
  there : ∀ {x xs} {j : Size< i} → ◇ j P (force xs) → ◇ i P (x ∷ xs)

-- ◇ respects bisimilarity.

◇-∼ :
  ∀ {a p i} {A : Type a} {P : A → Type p} {xs ys} →
  [ ∞ ] xs ∼ ys → ◇ i P xs → ◇ i P ys
◇-∼ (x≡y ∷ _) (here p)  = here (E.subst _ x≡y p)
◇-∼ (_   ∷ b) (there p) = there (◇-∼ (force b) p)

-- A map function for ◇.

◇-map : ∀ {a p q i} {A : Type a} {P : A → Type p} {Q : A → Type q} →
        (∀ {x} → P x → Q x) →
        (∀ {xs} → ◇ i P xs → ◇ i Q xs)
◇-map f (here p)  = here (f p)
◇-map f (there p) = there (◇-map f p)

-- A variant of ◇-map.

◇-map′ : ∀ {a b c p q i} {A : Type a} {B : Type b} {C : Type c}
           {P : B → Type p} {Q : C → Type q}
           {f : A → B} {g : A → C} →
         (∀ {x} → P (f x) → Q (g x)) →
         (∀ {xs} → ◇ i P (map f xs) → ◇ i Q (map g xs))
◇-map′ g {_ ∷ _} (here p)  = here (g p)
◇-map′ g {_ ∷ _} (there p) = there (◇-map′ g p)
◇-map′ g {[]}    ()

-- If a predicate holds for some element in a colist, then it holds
-- for some value.

◇-witness : ∀ {a p i} {A : Type a} {P : A → Type p} {xs} →
            ◇ i P xs → ∃ P
◇-witness (here p)  = _ , p
◇-witness (there p) = ◇-witness p

-- If const P holds for some element, then P holds.

◇-const : ∀ {a p i} {A : Type a} {P : Type p} {xs : Colist A ∞} →
          ◇ i (const P) xs → P
◇-const = proj₂ ∘ ◇-witness

-- Colist membership.

infix 4 [_]_∈_

[_]_∈_ : ∀ {a} {A : Type a} → Size → A → Colist A ∞ → Type a
[ i ] x ∈ xs = ◇ i (x ≡_) xs

-- A generalisation of "◇ ∞ P xs holds iff P holds for some element in
-- xs".

◇⇔∈× : ∀ {a p i} {A : Type a} {P : A → Type p} {xs} →
       ◇ i P xs ⇔ ∃ λ x → [ i ] x ∈ xs × P x
◇⇔∈× {P = P} = record { to = to; from = from }
  where
  to : ∀ {i xs} → ◇ i P xs → ∃ λ x → [ i ] x ∈ xs × P x
  to (here p)  = _ , here (E.refl _) , p
  to (there p) = Σ-map id (Σ-map there id) (to p)

  from : ∀ {i xs} → (∃ λ x → [ i ] x ∈ xs × P x) → ◇ i P xs
  from (x , here eq   , p) = here (E.subst P eq p)
  from (x , there x∈xs , p) = there (from (x , x∈xs , p))

-- If P holds for some element in replicate (suc n) x, then it also
-- holds for x, and vice versa.

◇-replicate-suc⇔ :
  ∀ {a p i} {A : Type a} {P : A → Type p} {x : A} {n} →
  ◇ i P (replicate (suc n) x) ⇔ P x
◇-replicate-suc⇔ {P = P} {x} = record
  { to   = to _
  ; from = here
  }
  where
  to : ∀ {i} n → ◇ i P (replicate n x) → P x
  to zero    ()
  to (suc n) (here p)  = p
  to (suc n) (there p) = to (force n) p

-- If P holds for some element in cycle x xs, then it also holds for
-- some element in x ∷ xs, and vice versa.

◇-cycle⇔ :
  ∀ {a p i} {A : Type a} {P : A → Type p} {x : A} {xs} →
  ◇ i P (cycle x xs) ⇔ ◇ i P (x ∷ xs)
◇-cycle⇔ {i = i} {P = P} {x} {xs} = record
  { to   = ◇ i P (cycle x xs)               ↝⟨ ◇-∼ (transitive-∼ ∷∼∷′ (symmetric-∼ ∷∼∷′)) ⟩
           ◇ i P ((x ∷ xs) ++ cycle x xs)   ↝⟨ to _ ⟩
           ◇ i P (x ∷ xs) ⊎ ◇ i P (x ∷ xs)  ↝⟨ [ id , id ] ⟩□
           ◇ i P (x ∷ xs)                   □
  ; from = ◇ i P (x ∷ xs)                  ↝⟨ from ⟩
           ◇ i P ((x ∷ xs) ++ cycle x xs)  ↝⟨ ◇-∼ (transitive-∼ ∷∼∷′ (symmetric-∼ ∷∼∷′)) ⟩□
           ◇ i P (cycle x xs)              □
  }
  where
  to : ∀ {i} ys → ◇ i P (ys ++ cycle x xs) → ◇ i P ys ⊎ ◇ i P (x ∷ xs)
  to []       (here p)  = inj₂ (here p)
  to []       (there p) = case to (force xs) p of
                            [ inj₂ ∘ there , inj₂ ]
  to (y ∷ ys) (here p)  = inj₁ (here p)
  to (y ∷ ys) (there p) = ⊎-map there id (to (force ys) p)

  from : ∀ {i ys} → ◇ i P ys → ◇ i P (ys ++ cycle x xs)
  from (here p)   = here p
  from (there ps) = there (from ps)

------------------------------------------------------------------------
-- The □ predicate

-- □ ∞ P xs means that P holds for every element in xs.

mutual

  data □ {a p} {A : Type a} (i : Size)
         (P : A → Type p) : Colist A ∞ → Type (a ⊔ p) where
    []  : □ i P []
    _∷_ : ∀ {x xs} → P x → □′ i P (force xs) → □ i P (x ∷ xs)

  record □′ {a p} {A : Type a} (i : Size)
            (P : A → Type p) (xs : Colist A ∞) : Type (a ⊔ p) where
    coinductive
    field
      force : {j : Size< i} → □ j P xs

open □′ public

-- Some projections.

□-head : ∀ {a p i} {A : Type a} {P : A → Type p} {x xs} →
         □ i P (x ∷ xs) → P x
□-head (p ∷ _) = p

□-tail : ∀ {a p i} {j : Size< i} {A : Type a} {P : A → Type p} {x xs} →
         □ i P (x ∷ xs) → □ j P (force xs)
□-tail (_ ∷ ps) = force ps

-- □ respects bisimilarity.

□-∼ :
  ∀ {i a p} {A : Type a} {P : A → Type p} {xs ys} →
  [ i ] xs ∼ ys → □ i P xs → □ i P ys
□-∼ []       _        = []
□-∼ (eq ∷ b) (p ∷ ps) =
  E.subst _ eq p ∷ λ { .force →
  □-∼ (force b) (force ps) }

-- A generalisation of "□ ∞ P xs holds iff P is true for every element
-- in xs".

□⇔∈→ : ∀ {a p i} {A : Type a} {P : A → Type p} {xs} →
       □ i P xs ⇔ (∀ x → [ i ] x ∈ xs → P x)
□⇔∈→ {P = P} = record { to = to; from = from _ }
  where
  to : ∀ {i xs} → □ i P xs → (∀ x → [ i ] x ∈ xs → P x)
  to (p ∷ ps) x (here eq)    = E.subst P (E.sym eq) p
  to (p ∷ ps) x (there x∈xs) = to (force ps) x x∈xs

  from : ∀ {i} xs → (∀ x → [ i ] x ∈ xs → P x) → □ i P xs
  from []       f = []
  from (x ∷ xs) f =
    f x (here (E.refl _)) ∷ λ { .force →
    from (force xs) (λ x → f x ∘ there) }

-- If P is universally true, then □ i P is also universally true.

□-replicate : ∀ {a p i} {A : Type a} {P : A → Type p} →
              (∀ x → P x) →
              (∀ xs → □ i P xs)
□-replicate f _ = _⇔_.from □⇔∈→ (λ x _ → f x)

-- Something resembling applicative functor application for □.

infixl 4 _□-⊛_

_□-⊛_ :
  ∀ {i a p q} {A : Type a} {P : A → Type p} {Q : A → Type q} {xs} →
  □ i (λ x → P x → Q x) xs → □ i P xs → □ i Q xs
[]       □-⊛ _        = []
(f ∷ fs) □-⊛ (p ∷ ps) = f p ∷ λ { .force → force fs □-⊛ force ps }

-- A map function for □.

□-map : ∀ {a p q i} {A : Type a} {P : A → Type p} {Q : A → Type q} →
        (∀ {x} → P x → Q x) →
        (∀ {xs} → □ i P xs → □ i Q xs)
□-map f ps = □-replicate (λ _ → f) _ □-⊛ ps

-- A variant of □-map.

□-map′ : ∀ {a b c p q i} {A : Type a} {B : Type b} {C : Type c}
           {P : B → Type p} {Q : C → Type q}
           {f : A → B} {g : A → C} →
         (∀ {x} → P (f x) → Q (g x)) →
         (∀ {xs} → □ i P (map f xs) → □ i Q (map g xs))
□-map′ g {[]}    []       = []
□-map′ g {_ ∷ _} (p ∷ ps) = g p ∷ λ { .force → □-map′ g (force ps) }

-- Something resembling applicative functor application for □ and ◇.

infixl 4 _□◇-⊛_

_□◇-⊛_ :
  ∀ {a p q i} {A : Type a} {P : A → Type p} {Q : A → Type q} {xs} →
  □ i (λ x → P x → Q x) xs → ◇ i P xs → ◇ i Q xs
(f ∷ _)  □◇-⊛ (here p)  = here (f p)
(_ ∷ fs) □◇-⊛ (there p) = there (force fs □◇-⊛ p)

-- A combination of some of the combinators above.

□◇-witness :
  ∀ {a p q i} {A : Type a} {P : A → Type p} {Q : A → Type q} {xs} →
  □ i P xs → ◇ i Q xs → ∃ λ x → P x × Q x
□◇-witness p q = ◇-witness (□-map _,_ p □◇-⊛ q)

-- If P holds for every element in replicate (suc n) x, then it also holds
-- for x, and vice versa.

□-replicate-suc⇔ :
  ∀ {a p i} {A : Type a} {P : A → Type p} {x : A} {n} →
  □ i P (replicate (suc n) x) ⇔ P x
□-replicate-suc⇔ {P = P} {x} = record
  { to   = □-head
  ; from = from _
  }
  where
  from : ∀ {i} n → P x → □ i P (replicate n x)
  from zero    p = []
  from (suc n) p = p ∷ λ { .force → from (force n) p }

-- If P holds for every element in cycle x xs, then it also holds for
-- every element in x ∷ xs, and vice versa.

□-cycle⇔ :
  ∀ {a p i} {A : Type a} {P : A → Type p} {x : A} {xs} →
  □ i P (cycle x xs) ⇔ □ i P (x ∷ xs)
□-cycle⇔ {i = i} {P = P} {x} {xs} = record
  { to   = □ i P (cycle x xs)              ↝⟨ (λ { (p ∷ ps) → p ∷ ps }) ⟩
           □ i P ((x ∷ xs) ++ cycle x xs)  ↝⟨ to _ ⟩□
           □ i P (x ∷ xs)                  □
  ; from = □ i P (x ∷ xs)                  ↝⟨ (λ hyp → from hyp hyp) ⟩
           □ i P ((x ∷ xs) ++ cycle x xs)  ↝⟨ (λ { (p ∷ ps) → p ∷ ps }) ⟩□
           □ i P (cycle x xs)              □
  }
  where
  to : ∀ {i} ys → □ i P (ys ++ cycle x xs) → □ i P ys
  to []       _        = []
  to (y ∷ ys) (p ∷ ps) = p ∷ λ { .force → to (force ys) (force ps) }

  from : ∀ {i ys} →
         □ i P (x ∷ xs) → □ i P ys → □ i P (ys ++ cycle x xs)
  from ps       (q ∷ qs) = q ∷ λ { .force → from ps (force qs) }
  from (p ∷ ps) []       = p ∷ λ { .force → from (p ∷ ps) (force ps) }

------------------------------------------------------------------------
-- A variant of ◇ with a sized predicate

-- ◇ˢ ∞ P xs means that (some instance of) P holds for some element in
-- xs.

data ◇ˢ {a p} {A : Type a} (i : Size)
        (P : Size → A → Type p) : Colist A ∞ → Type (a ⊔ p) where
  here  : ∀ {x xs} → P i x → ◇ˢ i P (x ∷ xs)
  there : ∀ {x xs} {j : Size< i} → ◇ˢ j P (force xs) → ◇ˢ i P (x ∷ xs)

-- ◇ˢ respects bisimilarity.

◇ˢ-∼ :
  ∀ {a p i} {A : Type a} {P : Size → A → Type p} {xs ys} →
  [ ∞ ] xs ∼ ys → ◇ˢ i P xs → ◇ˢ i P ys
◇ˢ-∼ (eq ∷ _) (here p)  = here (E.subst _ eq p)
◇ˢ-∼ (_  ∷ b) (there p) = there (◇ˢ-∼ (force b) p)

-- If P is upwards closed, then flip ◇ˢ P is upwards closed.

◇ˢ-upwards-closed :
  ∀ {a p} {A : Type a} {P : Size → A → Type p} →
  (∀ {i} {j : Size< i} {x} → P j x → P i x) →
  (∀ {i} {j : Size< i} {xs} → ◇ˢ j P xs → ◇ˢ i P xs)
◇ˢ-upwards-closed P-closed (here p)  = here (P-closed p)
◇ˢ-upwards-closed P-closed (there p) =
  there (◇ˢ-upwards-closed P-closed p)

-- A variant of the previous lemma.

◇ˢ-upwards-closed-∞ :
  ∀ {a p} {A : Type a} {P : Size → A → Type p} →
  (∀ {i x} → P i x → P ∞ x) →
  (∀ {i xs} → ◇ˢ i P xs → ◇ˢ ∞ P xs)
◇ˢ-upwards-closed-∞ P-closed-∞ (here p)  = here (P-closed-∞ p)
◇ˢ-upwards-closed-∞ P-closed-∞ (there p) =
  there (◇ˢ-upwards-closed-∞ P-closed-∞ p)

-- A map function for ◇ˢ.

◇ˢ-map :
  ∀ {a p q i}
    {A : Type a} {P : Size → A → Type p} {Q : Size → A → Type q} →
  (∀ {i x} → P i x → Q i x) →
  (∀ {xs} → ◇ˢ i P xs → ◇ˢ i Q xs)
◇ˢ-map f (here p)  = here (f p)
◇ˢ-map f (there p) = there (◇ˢ-map f p)

-- A variant of ◇ˢ-map.

◇ˢ-map′ : ∀ {a b c p q i} {A : Type a} {B : Type b} {C : Type c}
            {P : Size → B → Type p} {Q : Size → C → Type q}
            {f : A → B} {g : A → C} →
          (∀ {i x} → P i (f x) → Q i (g x)) →
          (∀ {xs} → ◇ˢ i P (map f xs) → ◇ˢ i Q (map g xs))
◇ˢ-map′ g {_ ∷ _} (here p)  = here (g p)
◇ˢ-map′ g {_ ∷ _} (there p) = there (◇ˢ-map′ g p)
◇ˢ-map′ g {[]}    ()

-- If a predicate holds for some element in a colist, then it holds
-- for some value (assuming that P is upwards closed).

◇ˢ-witness : ∀ {a p i} {A : Type a} {P : Size → A → Type p} {xs} →
             (∀ {i} {j : Size< i} {x} → P j x → P i x) →
             ◇ˢ i P xs → ∃ (P i)
◇ˢ-witness closed (here p)  = _ , p
◇ˢ-witness closed (there p) = Σ-map id closed (◇ˢ-witness closed p)

-- If P ∞ holds for some element in xs, then ◇ˢ ∞ P xs holds.

∈×∞→◇ˢ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {x xs} →
         [ ∞ ] x ∈ xs → P ∞ x → ◇ˢ ∞ P xs
∈×∞→◇ˢ (here eq)    p = here (E.subst _ eq p)
∈×∞→◇ˢ (there x∈xs) p = there (∈×∞→◇ˢ x∈xs p)

-- If P i x implies P ∞ x for any i and x, then ◇ˢ ∞ P xs holds iff
-- P ∞ holds for some element in xs.

◇ˢ⇔∈× : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs} →
        (∀ {i x} → P i x → P ∞ x) →
        ◇ˢ ∞ P xs ⇔ (∃ λ x → [ ∞ ] x ∈ xs × P ∞ x)
◇ˢ⇔∈× {P = P} →∞ = record
  { to   = to
  ; from = λ { (_ , x∈xs , p) → ∈×∞→◇ˢ x∈xs p }
  }
  where
  to : ∀ {i xs} → ◇ˢ i P xs → ∃ λ x → [ ∞ ] x ∈ xs × P ∞ x
  to (here p)  = _ , here (E.refl _) , →∞ p
  to (there p) = Σ-map id (Σ-map there id) (to p)

-- Sized variants of the previous lemma.

◇ˢ→∈× : ∀ {a p} {A : Type a} {P : Size → A → Type p} →
        (∀ {i} {j : Size< i} {x} → P j x → P i x) →
        ∀ {i xs} → ◇ˢ i P xs → ∃ λ x → [ i ] x ∈ xs × P i x
◇ˢ→∈× closed (here p)  = _ , here (E.refl _) , p
◇ˢ→∈× closed (there p) = Σ-map id (Σ-map there closed) (◇ˢ→∈× closed p)

∈×→◇ˢ : ∀ {a p} {A : Type a} {P : Size → A → Type p} →
        (∀ {i} {j : Size< i} {x} → P i x → P j x) →
        ∀ {i x xs} → [ i ] x ∈ xs → P i x → ◇ˢ i P xs
∈×→◇ˢ closed (here eq)    p = here (E.subst _ eq p)
∈×→◇ˢ closed (there x∈xs) p = there (∈×→◇ˢ closed x∈xs (closed p))

-- ◇ ∞ (P ∞) is "contained in" ◇ˢ ∞ P.

◇∞→◇ˢ∞ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs} →
         ◇ ∞ (P ∞) xs → ◇ˢ ∞ P xs
◇∞→◇ˢ∞ {P = P} {xs} =
  ◇ ∞ (P ∞) xs                    ↝⟨ _⇔_.to ◇⇔∈× ⟩
  (∃ λ x → [ ∞ ] x ∈ xs × P ∞ x)  ↝⟨ (λ { (_ , x∈xs , p) → ∈×∞→◇ˢ x∈xs p }) ⟩□
  ◇ˢ ∞ P xs                       □

-- If P i x implies P ∞ x for any i and x, then ◇ˢ ∞ P is pointwise
-- logically equivalent to ◇ ∞ (P ∞).

◇ˢ∞⇔◇∞ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs} →
         (∀ {i x} → P i x → P ∞ x) →
         ◇ˢ ∞ P xs ⇔ ◇ ∞ (P ∞) xs
◇ˢ∞⇔◇∞ {P = P} {xs} →∞ =
  ◇ˢ ∞ P xs                       ↝⟨ ◇ˢ⇔∈× →∞ ⟩
  (∃ λ x → [ ∞ ] x ∈ xs × P ∞ x)  ↝⟨ inverse ◇⇔∈× ⟩□
  ◇ ∞ (P ∞) xs                    □

-- ◇ˢ i (const P) is pointwise logically equivalent to ◇ i P.

◇ˢ⇔◇ : ∀ {a p i} {A : Type a} {P : A → Type p} {xs} →
       ◇ˢ i (λ _ → P) xs ⇔ ◇ i P xs
◇ˢ⇔◇ {P = P} {xs} = record { to = to; from = from }
  where
  to : ∀ {i xs} → ◇ˢ i (λ _ → P) xs → ◇ i P xs
  to (here p)  = here p
  to (there p) = there (to p)

  from : ∀ {i xs} → ◇ i P xs → ◇ˢ i (λ _ → P) xs
  from (here p)  = here p
  from (there p) = there (from p)

-- If ◇ˢ i P (x ∷ xs) holds, then ◇ˢ i P (cycle x xs) also holds.

◇ˢ-cycle← :
  ∀ {a p i} {A : Type a} {P : Size → A → Type p} {x : A} {xs} →
  ◇ˢ i P (x ∷ xs) → ◇ˢ i P (cycle x xs)
◇ˢ-cycle← {i = i} {P = P} {x} {xs} =
  ◇ˢ i P (x ∷ xs)                  ↝⟨ from ⟩
  ◇ˢ i P ((x ∷ xs) ++ cycle x xs)  ↝⟨ ◇ˢ-∼ (transitive-∼ ∷∼∷′ (symmetric-∼ ∷∼∷′)) ⟩□
  ◇ˢ i P (cycle x xs)              □
  where
  from : ∀ {i ys} → ◇ˢ i P ys → ◇ˢ i P (ys ++ cycle x xs)
  from (here p)   = here p
  from (there ps) = there (from ps)

-- If P i x implies P ∞ x for any i and x, then ◇ˢ ∞ P (cycle x xs) is
-- logically equivalent to ◇ˢ ∞ P (x ∷ xs).

◇ˢ-cycle⇔ :
  ∀ {a p} {A : Type a} {P : Size → A → Type p} {x : A} {xs} →
  (∀ {i x} → P i x → P ∞ x) →
  ◇ˢ ∞ P (cycle x xs) ⇔ ◇ˢ ∞ P (x ∷ xs)
◇ˢ-cycle⇔ {P = P} {x} {xs} →∞ = record
  { to   = ◇ˢ ∞ P (cycle x xs)                ↝⟨ ◇ˢ-∼ (transitive-∼ ∷∼∷′ (symmetric-∼ ∷∼∷′)) ⟩
           ◇ˢ ∞ P ((x ∷ xs) ++ cycle x xs)    ↝⟨ to _ ⟩
           ◇ˢ ∞ P (x ∷ xs) ⊎ ◇ˢ ∞ P (x ∷ xs)  ↝⟨ [ id , id ] ⟩□
           ◇ˢ ∞ P (x ∷ xs)                    □
  ; from = ◇ˢ-cycle←
  }
  where
  to :
    ∀ {i} ys → ◇ˢ i P (ys ++ cycle x xs) → ◇ˢ ∞ P ys ⊎ ◇ˢ ∞ P (x ∷ xs)
  to []       (here p)  = inj₂ (here (→∞ p))
  to []       (there p) = case to (force xs) p of
                            [ inj₂ ∘ there , inj₂ ]
  to (y ∷ ys) (here p)  = inj₁ (here (→∞ p))
  to (y ∷ ys) (there p) = ⊎-map there id (to (force ys) p)

------------------------------------------------------------------------
-- A variant of □ with a sized predicate

-- □ˢ ∞ P xs means that (some instance of) P holds for every element
-- in xs.

mutual

  data □ˢ {a p} {A : Type a} (i : Size)
          (P : Size → A → Type p) : Colist A ∞ → Type (a ⊔ p) where
    []  : □ˢ i P []
    _∷_ : ∀ {x xs} → P i x → □ˢ′ i P (force xs) → □ˢ i P (x ∷ xs)

  record □ˢ′ {a p} {A : Type a} (i : Size)
             (P : Size → A → Type p) (xs : Colist A ∞) :
             Type (a ⊔ p) where
    coinductive
    field
      force : {j : Size< i} → □ˢ j P xs

open □ˢ′ public

-- Some projections.

□ˢ-head : ∀ {a p i} {A : Type a} {P : Size → A → Type p} {x xs} →
          □ˢ i P (x ∷ xs) → P i x
□ˢ-head (p ∷ _) = p

□ˢ-tail : ∀ {a p i} {j : Size< i}
            {A : Type a} {P : Size → A → Type p} {x xs} →
          □ˢ i P (x ∷ xs) → □ˢ j P (force xs)
□ˢ-tail (_ ∷ ps) = force ps

-- □ˢ respects bisimilarity.

□ˢ-∼ :
  ∀ {i a p} {A : Type a} {P : Size → A → Type p} {xs ys} →
  [ i ] xs ∼ ys → □ˢ i P xs → □ˢ i P ys
□ˢ-∼ []       _        = []
□ˢ-∼ (eq ∷ b) (p ∷ ps) =
  E.subst _ eq p ∷ λ { .force →
  □ˢ-∼ (force b) (force ps) }

-- If P is downwards closed, then flip □ˢ P is downwards closed.

□ˢ-downwards-closed :
  ∀ {a p} {A : Type a} {P : Size → A → Type p} →
  (∀ {i} {j : Size< i} {x} → P i x → P j x) →
  (∀ {i} {j : Size< i} {xs} → □ˢ i P xs → □ˢ j P xs)
□ˢ-downwards-closed P-closed []       = []
□ˢ-downwards-closed P-closed (p ∷ ps) =
  P-closed p ∷ λ { .force → □ˢ-downwards-closed P-closed (force ps) }

-- A variant of the previous lemma.

□ˢ-downwards-closed-∞ :
  ∀ {a p} {A : Type a} {P : Size → A → Type p} →
  (∀ {i x} → P ∞ x → P i x) →
  (∀ {i xs} → □ˢ ∞ P xs → □ˢ i P xs)
□ˢ-downwards-closed-∞ P-closed-∞ []       = []
□ˢ-downwards-closed-∞ P-closed-∞ (p ∷ ps) =
  P-closed-∞ p ∷ λ { .force →
  □ˢ-downwards-closed-∞ P-closed-∞ (force ps) }

-- If □ˢ ∞ P xs holds, then P ∞ holds for every element in xs.

□ˢ∞∈→ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs x} →
        □ˢ ∞ P xs → [ ∞ ] x ∈ xs → P ∞ x
□ˢ∞∈→ (p ∷ ps) (here eq)    = E.subst _ (E.sym eq) p
□ˢ∞∈→ (p ∷ ps) (there x∈xs) = □ˢ∞∈→ (force ps) x∈xs

-- If P ∞ x implies P i x for any i and x, then □ˢ ∞ P xs holds iff P ∞
-- holds for every element in xs.

□ˢ⇔∈→ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs} →
        (∀ {i x} → P ∞ x → P i x) →
        □ˢ ∞ P xs ⇔ (∀ x → [ ∞ ] x ∈ xs → P ∞ x)
□ˢ⇔∈→ {P = P} ∞→ = record { to = λ p _ → □ˢ∞∈→ p; from = from _ }
  where
  from : ∀ {i} xs → (∀ x → [ ∞ ] x ∈ xs → P ∞ x) → □ˢ i P xs
  from []       f = []
  from (x ∷ xs) f =
    ∞→ (f x (here (E.refl _))) ∷ λ { .force →
    from (force xs) (λ x → f x ∘ there) }

-- Sized variants of the previous lemma.

□ˢ∈→ : ∀ {a p} {A : Type a} {P : Size → A → Type p} →
       (∀ {i} {j : Size< i} {x} → P j x → P i x) →
       ∀ {i x xs} → □ˢ i P xs → [ i ] x ∈ xs → P i x
□ˢ∈→ closed (p ∷ ps) (here eq)    = E.subst _ (E.sym eq) p
□ˢ∈→ closed (p ∷ ps) (there x∈xs) = closed (□ˢ∈→ closed (force ps) x∈xs)

∈→→□ˢ : ∀ {a p} {A : Type a} {P : Size → A → Type p} →
        (∀ {i} {j : Size< i} {x} → P i x → P j x) →
        ∀ {i} xs → (∀ x → [ i ] x ∈ xs → P i x) → □ˢ i P xs
∈→→□ˢ closed []       f = []
∈→→□ˢ closed (x ∷ xs) f =
  f x (here (E.refl _)) ∷ λ { .force →
  ∈→→□ˢ closed (force xs) (λ x → closed ∘ f x ∘ there) }

-- □ˢ ∞ P is "contained in" □ ∞ (P ∞).

□ˢ∞→□∞ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs} →
         □ˢ ∞ P xs → □ ∞ (P ∞) xs
□ˢ∞→□∞ {P = P} {xs} =
  □ˢ ∞ P xs                     ↝⟨ (λ p _ → □ˢ∞∈→ p) ⟩
  (∀ x → [ ∞ ] x ∈ xs → P ∞ x)  ↝⟨ _⇔_.from □⇔∈→ ⟩□
  □ ∞ (P ∞) xs                  □

-- If P ∞ x implies P i x for any i and x, then □ˢ ∞ P is pointwise
-- logically equivalent to □ ∞ (P ∞).

□ˢ∞⇔□∞ : ∀ {a p} {A : Type a} {P : Size → A → Type p} {xs} →
         (∀ {i x} → P ∞ x → P i x) →
         □ˢ ∞ P xs ⇔ □ ∞ (P ∞) xs
□ˢ∞⇔□∞ {P = P} {xs} ∞→ =
  □ˢ ∞ P xs                     ↝⟨ □ˢ⇔∈→ ∞→ ⟩
  (∀ x → [ ∞ ] x ∈ xs → P ∞ x)  ↝⟨ inverse □⇔∈→ ⟩□
  □ ∞ (P ∞) xs                  □

-- □ˢ i (const P) is pointwise logically equivalent to □ i P.

□ˢ⇔□ : ∀ {a p i} {A : Type a} {P : A → Type p} {xs} →
       □ˢ i (λ _ → P) xs ⇔ □ i P xs
□ˢ⇔□ {P = P} {xs} = record { to = to; from = from }
  where
  to : ∀ {i xs} → □ˢ i (λ _ → P) xs → □ i P xs
  to []       = []
  to (p ∷ ps) = p ∷ λ { .force → to (force ps) }

  from : ∀ {i xs} → □ i P xs → □ˢ i (λ _ → P) xs
  from []       = []
  from (p ∷ ps) = p ∷ λ { .force → from (force ps) }

-- If P is universally true, then □ˢ i P is also universally true.

□ˢ-replicate : ∀ {a p i} {A : Type a} {P : Size → A → Type p} →
               (∀ {i} x → P i x) →
               (∀ xs → □ˢ i P xs)
□ˢ-replicate f []       = []
□ˢ-replicate f (x ∷ xs) = f x ∷ λ { .force → □ˢ-replicate f (force xs) }

-- Something resembling applicative functor application for □ˢ.

infixl 4 _□ˢ-⊛_

_□ˢ-⊛_ : ∀ {i a p q} {A : Type a}
           {P : Size → A → Type p} {Q : Size → A → Type q} {xs} →
         □ˢ i (λ j x → P j x → Q j x) xs → □ˢ i P xs → □ˢ i Q xs
[]       □ˢ-⊛ _        = []
(f ∷ fs) □ˢ-⊛ (p ∷ ps) = f p ∷ λ { .force → force fs □ˢ-⊛ force ps }

-- A map function for □ˢ.

□ˢ-map :
  ∀ {a p q i}
    {A : Type a} {P : Size → A → Type p} {Q : Size → A → Type q} →
  (∀ {i x} → P i x → Q i x) →
  (∀ {xs} → □ˢ i P xs → □ˢ i Q xs)
□ˢ-map f ps = □ˢ-replicate (λ _ → f) _ □ˢ-⊛ ps

-- A variant of □ˢ-map.

□ˢ-map′ : ∀ {a b c p q i} {A : Type a} {B : Type b} {C : Type c}
            {P : Size → B → Type p} {Q : Size → C → Type q}
            {f : A → B} {g : A → C} →
          (∀ {i x} → P i (f x) → Q i (g x)) →
          (∀ {xs} → □ˢ i P (map f xs) → □ˢ i Q (map g xs))
□ˢ-map′ g {[]}    []       = []
□ˢ-map′ g {_ ∷ _} (p ∷ ps) = g p ∷ λ { .force → □ˢ-map′ g (force ps) }

-- Something resembling applicative functor application for □ˢ and ◇ˢ.

infixl 4 _□ˢ◇ˢ-⊛_

_□ˢ◇ˢ-⊛_ : ∀ {a p q i} {A : Type a}
             {P : Size → A → Type p} {Q : Size → A → Type q} {xs} →
           □ˢ i (λ j x → P j x → Q j x) xs → ◇ˢ i P xs → ◇ˢ i Q xs
(f ∷ _)  □ˢ◇ˢ-⊛ (here p)  = here (f p)
(_ ∷ fs) □ˢ◇ˢ-⊛ (there p) = there (force fs □ˢ◇ˢ-⊛ p)

-- A combination of some of the combinators above.

□ˢ◇ˢ-witness :
  ∀ {a p q i}
    {A : Type a} {P : Size → A → Type p} {Q : Size → A → Type q} {xs} →
  (∀ {i} {j : Size< i} {x} → P j x → P i x) →
  (∀ {i} {j : Size< i} {x} → Q j x → Q i x) →
  □ˢ i P xs → ◇ˢ i Q xs → ∃ λ x → P i x × Q i x
□ˢ◇ˢ-witness P-closed Q-closed p q =
  ◇ˢ-witness (λ { {_} {_} → Σ-map P-closed Q-closed })
             (□ˢ-map _,_ p □ˢ◇ˢ-⊛ q)

-- If □ˢ i P (cycle x xs) holds, then □ˢ i P (x ∷ xs) also holds.

□ˢ-cycle→ :
  ∀ {a p i} {A : Type a} {P : Size → A → Type p} {x : A} {xs} →
  □ˢ i P (cycle x xs) → □ˢ i P (x ∷ xs)
□ˢ-cycle→ {i = i} {P = P} {x} {xs} =
  □ˢ i P (cycle x xs)              ↝⟨ (λ { (p ∷ ps) → p ∷ ps }) ⟩
  □ˢ i P ((x ∷ xs) ++ cycle x xs)  ↝⟨ to _ ⟩□
  □ˢ i P (x ∷ xs)                  □
  where
  to : ∀ {i} ys → □ˢ i P (ys ++ cycle x xs) → □ˢ i P ys
  to []       _        = []
  to (y ∷ ys) (p ∷ ps) = p ∷ λ { .force → to (force ys) (force ps) }

-- If P ∞ x implies P i x for any i and x, then □ˢ ∞ P (cycle x xs) is
-- logically equivalent to □ˢ ∞ P (x ∷ xs).

□ˢ-cycle⇔ :
  ∀ {a p} {A : Type a} {P : Size → A → Type p} {x : A} {xs} →
  (∀ {i x} → P ∞ x → P i x) →
  □ˢ ∞ P (cycle x xs) ⇔ □ˢ ∞ P (x ∷ xs)
□ˢ-cycle⇔ {P = P} {x} {xs} ∞→ = record
  { to   = □ˢ-cycle→
  ; from = □ˢ ∞ P (x ∷ xs)                  ↝⟨ (λ hyp → from hyp hyp) ⟩
           □ˢ ∞ P ((x ∷ xs) ++ cycle x xs)  ↝⟨ (λ { (p ∷ ps) → p ∷ ps }) ⟩□
           □ˢ ∞ P (cycle x xs)              □
  }
  where
  from : ∀ {i ys} →
         □ˢ ∞ P (x ∷ xs) → □ˢ i P ys → □ˢ i P (ys ++ cycle x xs)
  from ps       (q ∷ qs) = q ∷ λ { .force → from ps (force qs) }
  from (p ∷ ps) []       = ∞→ p ∷ λ { .force →
                           from (p ∷ ps) (force ps) }


------------------------------------------------------------------------
-- Groupoids
------------------------------------------------------------------------

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

open import Equality

module Groupoid
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Prelude hiding (id; _∘_; _^_)

open import Bijection eq hiding (id; _∘_)
open Derived-definitions-and-properties eq
open import Integer.Basics eq as Int using (ℤ; +_; -[1+_])
import Nat eq as Nat

private
  variable
    a       : Level
    A       : Type a
    w x y z : A
    n       : ℕ
    j       : ℤ

-- Groupoids using _≡_ as the underlying equality.

record Groupoid o ℓ : Type (lsuc (o ⊔ ℓ)) where
  infix  8 _⁻¹
  infixr 7 _∘_
  infix  4 _∼_
  field
    Object : Type o
    _∼_    : Object → Object → Type ℓ

    id  : x ∼ x
    _∘_ : y ∼ z → x ∼ y → x ∼ z
    _⁻¹ : x ∼ y → y ∼ x

    left-identity  : (p : x ∼ y) → id ∘ p ≡ p
    right-identity : (p : x ∼ y) → p ∘ id ≡ p
    assoc          : (p : y ∼ z) (q : x ∼ y) (r : w ∼ x) →
                     p ∘ (q ∘ r) ≡ (p ∘ q) ∘ r
    left-inverse   : (p : x ∼ y) → p ⁻¹ ∘ p ≡ id
    right-inverse  : (p : x ∼ y) → p ∘ p ⁻¹ ≡ id

  -- Note that this definition should perhaps contain more coherence
  -- properties: we have not assumed that _≡_ is proof-irrelevant.

  private
    variable
      p p₁ p₂ q q₁ q₂ r : x ∼ y

  -- Some derived properties.

  abstract

    -- The identity is an identity for the inverse operator as well.

    identity : id {x = x} ⁻¹ ≡ id
    identity =
      id ⁻¹       ≡⟨ sym $ right-identity (id ⁻¹) ⟩
      id ⁻¹ ∘ id  ≡⟨ left-inverse id ⟩∎
      id          ∎

    -- If p is idempotent with respect to _∘_, then p is equal to the
    -- identity element.

    idempotent⇒≡id : p ∘ p ≡ p → p ≡ id
    idempotent⇒≡id {p = p} p∘p≡p =
      p               ≡⟨ sym $ left-identity _ ⟩
      id ∘ p          ≡⟨ cong (_∘ _) $ sym $ left-inverse _ ⟩
      (p ⁻¹ ∘ p) ∘ p  ≡⟨ sym $ assoc _ _ _ ⟩
      p ⁻¹ ∘ (p ∘ p)  ≡⟨ cong (p ⁻¹ ∘_) p∘p≡p ⟩
      p ⁻¹ ∘ p        ≡⟨ left-inverse _ ⟩∎
      id              ∎

    -- Groupoids are left-cancellative and right-cancellative.

    left-cancellative :
      p ∘ q₁ ≡ p ∘ q₂ → q₁ ≡ q₂
    left-cancellative {p = p} {q₁ = q₁} {q₂ = q₂} p∘q₁≡p∘q₂ =
      q₁               ≡⟨ sym $ left-identity _ ⟩
      id ∘ q₁          ≡⟨ cong (_∘ _) $ sym $ left-inverse _ ⟩
      (p ⁻¹ ∘ p) ∘ q₁  ≡⟨ sym $ assoc _ _ _ ⟩
      p ⁻¹ ∘ (p ∘ q₁)  ≡⟨ cong (p ⁻¹ ∘_) p∘q₁≡p∘q₂ ⟩
      p ⁻¹ ∘ (p ∘ q₂)  ≡⟨ assoc _ _ _ ⟩
      (p ⁻¹ ∘ p) ∘ q₂  ≡⟨ cong (_∘ _) $ left-inverse _ ⟩
      id ∘ q₂          ≡⟨ left-identity _ ⟩∎
      q₂               ∎

    right-cancellative :
      p₁ ∘ q ≡ p₂ ∘ q → p₁ ≡ p₂
    right-cancellative {p₁ = p₁} {q = q} {p₂ = p₂} p₁∘q≡p₂∘q =
      p₁               ≡⟨ sym $ right-identity _ ⟩
      p₁ ∘ id          ≡⟨ cong (_ ∘_) $ sym $ right-inverse _ ⟩
      p₁ ∘ (q ∘ q ⁻¹)  ≡⟨ assoc _ _ _ ⟩
      (p₁ ∘ q) ∘ q ⁻¹  ≡⟨ cong (_∘ q ⁻¹) p₁∘q≡p₂∘q ⟩
      (p₂ ∘ q) ∘ q ⁻¹  ≡⟨ sym $ assoc _ _ _ ⟩
      p₂ ∘ (q ∘ q ⁻¹)  ≡⟨ cong (_ ∘_) $ right-inverse _ ⟩
      p₂ ∘ id          ≡⟨ right-identity _ ⟩∎
      p₂               ∎

    -- The inverse operator is involutive.

    involutive : (p : x ∼ y) → p ⁻¹ ⁻¹ ≡ p
    involutive p =
      p ⁻¹ ⁻¹               ≡⟨ sym $ right-identity (p ⁻¹ ⁻¹) ⟩
      p ⁻¹ ⁻¹ ∘ id          ≡⟨ sym $ cong (_∘_ (p ⁻¹ ⁻¹)) (left-inverse p) ⟩
      p ⁻¹ ⁻¹ ∘ (p ⁻¹ ∘ p)  ≡⟨ assoc _ _ _ ⟩
      (p ⁻¹ ⁻¹ ∘ p ⁻¹) ∘ p  ≡⟨ cong (λ q → q ∘ p) (left-inverse (p ⁻¹)) ⟩
      id ∘ p                ≡⟨ left-identity p ⟩∎
      p                     ∎

    -- A lemma that can be used to move something from one side of an
    -- equality to the other.

    ⁻¹∘≡→≡∘ : p ⁻¹ ∘ q ≡ r → q ≡ p ∘ r
    ⁻¹∘≡→≡∘ {p = p} {q = q} {r = r} hyp =
      q               ≡⟨ sym $ left-identity _ ⟩
      id ∘ q          ≡⟨ cong (_∘ _) $ sym $ right-inverse _ ⟩
      (p ∘ p ⁻¹) ∘ q  ≡⟨ sym $ assoc _ _ _ ⟩
      p ∘ (p ⁻¹ ∘ q)  ≡⟨ cong (_ ∘_) hyp ⟩∎
      p ∘ r           ∎

    -- A corollary.

    ⁻¹∘≡id→≡ : p ⁻¹ ∘ q ≡ id → q ≡ p
    ⁻¹∘≡id→≡ {p = p} {q = q} hyp =
      q       ≡⟨ ⁻¹∘≡→≡∘ hyp ⟩
      p ∘ id  ≡⟨ right-identity _ ⟩∎
      p       ∎

    -- Another lemma that can be used to move something from one side
    -- of an equality to the other.

    ∘⁻¹≡→≡∘ : p ∘ q ⁻¹ ≡ r → p ≡ r ∘ q
    ∘⁻¹≡→≡∘ {p = p} {q = q} {r = r} hyp =
      p               ≡⟨ sym $ right-identity _ ⟩
      p ∘ id          ≡⟨ cong (_ ∘_) $ sym $ left-inverse _ ⟩
      p ∘ (q ⁻¹ ∘ q)  ≡⟨ assoc _ _ _ ⟩
      (p ∘ q ⁻¹) ∘ q  ≡⟨ cong (_∘ _) hyp ⟩∎
      r ∘ q           ∎

    -- A corollary.

    ∘⁻¹≡id→≡ : p ∘ q ⁻¹ ≡ id → p ≡ q
    ∘⁻¹≡id→≡ {p = p} {q = q} hyp =
      p       ≡⟨ ∘⁻¹≡→≡∘ hyp ⟩
      id ∘ q  ≡⟨ left-identity _ ⟩∎
      q       ∎

    -- A lemma relating _∘_ and _⁻¹.

    ∘⁻¹ : (p ∘ q) ⁻¹ ≡ q ⁻¹ ∘ p ⁻¹
    ∘⁻¹ {p = p} {q = q} = right-cancellative
      ((p ∘ q) ⁻¹ ∘ (p ∘ q)     ≡⟨ left-inverse _ ⟩
       id                       ≡⟨ sym $ left-inverse _ ⟩
       q ⁻¹ ∘ q                 ≡⟨ cong (q ⁻¹ ∘_) $ sym $ left-identity _ ⟩
       q ⁻¹ ∘ (id ∘ q)          ≡⟨ cong (q ⁻¹ ∘_) $ cong (_∘ _) $ sym $ left-inverse _ ⟩
       q ⁻¹ ∘ ((p ⁻¹ ∘ p) ∘ q)  ≡⟨ cong (q ⁻¹ ∘_) $ sym $ assoc _ _ _ ⟩
       q ⁻¹ ∘ (p ⁻¹ ∘ (p ∘ q))  ≡⟨ assoc _ _ _ ⟩∎
       (q ⁻¹ ∘ p ⁻¹) ∘ (p ∘ q)  ∎)

    -- If p ∘ q is equal to id, then q is equal to p ⁻¹.

    ⁻¹-unique-right : p ∘ q ≡ id → q ≡ p ⁻¹
    ⁻¹-unique-right {p = p} {q = q} ∘≡id = ⁻¹∘≡id→≡
      (p ⁻¹ ⁻¹ ∘ q  ≡⟨ cong (_∘ _) $ involutive _ ⟩
       p ∘ q        ≡⟨ ∘≡id ⟩∎
       id           ∎)

    -- If p ∘ q is equal to id, then p is equal to q ⁻¹.

    ⁻¹-unique-left : p ∘ q ≡ id → p ≡ q ⁻¹
    ⁻¹-unique-left {p = p} {q = q} ∘≡id = ∘⁻¹≡id→≡
      (p ∘ q ⁻¹ ⁻¹  ≡⟨ cong (_ ∘_) $ involutive _ ⟩
       p ∘ q        ≡⟨ ∘≡id ⟩∎
       id           ∎)

  -- The inverse operator is a bijection.

  ⁻¹-bijection : x ∼ y ↔ y ∼ x
  ⁻¹-bijection = record
    { surjection = record
      { logical-equivalence = record
        { to   = _⁻¹
        ; from = _⁻¹
        }
      ; right-inverse-of = involutive
      }
    ; left-inverse-of = involutive
    }

  -- Exponentiation.

  infixl 8 _^+_
  infixr 8 _^_

  _^+_ : x ∼ x → ℕ → x ∼ x
  p ^+ 0     = id
  p ^+ suc n = p ∘ p ^+ n

  _^_ : x ∼ x → ℤ → x ∼ x
  p ^ + n      = p ^+ n
  p ^ -[1+ n ] = (p ⁻¹) ^+ suc n

  -- _^+_ is homomorphic with respect to _∘_/_+_.

  ^+∘^+ : ∀ m → p ^+ m ∘ p ^+ n ≡ p ^+ (m + n)
  ^+∘^+ {p = p} {n = n} zero =
    id ∘ p ^+ n  ≡⟨ left-identity _ ⟩∎
    p ^+ n       ∎
  ^+∘^+ {p = p} {n = n} (suc m) =
    (p ∘ p ^+ m) ∘ p ^+ n  ≡⟨ sym $ assoc _ _ _ ⟩
    p ∘ (p ^+ m ∘ p ^+ n)  ≡⟨ cong (_ ∘_) $ ^+∘^+ m ⟩∎
    p ∘ p ^+ (m + n)       ∎

  -- Some rearrangement lemmas for _^+_.

  ∘^+≡^+∘ :
    p ∘ q ≡ q ∘ p →
    ∀ n → p ∘ q ^+ n ≡ q ^+ n ∘ p
  ∘^+≡^+∘ {p = p} _ zero =
    p ∘ id  ≡⟨ right-identity _ ⟩
    p       ≡⟨ sym $ left-identity _ ⟩∎
    id ∘ p  ∎
  ∘^+≡^+∘ {p = p} {q = q} comm (suc n) =
    p ∘ (q ∘ q ^+ n)  ≡⟨ assoc _ _ _ ⟩
    (p ∘ q) ∘ q ^+ n  ≡⟨ cong (_∘ q ^+ n) comm ⟩
    (q ∘ p) ∘ q ^+ n  ≡⟨ sym $ assoc _ _ _ ⟩
    q ∘ (p ∘ q ^+ n)  ≡⟨ cong (q ∘_) $ ∘^+≡^+∘ comm n ⟩
    q ∘ (q ^+ n ∘ p)  ≡⟨ assoc _ _ _ ⟩∎
    (q ∘ q ^+ n) ∘ p  ∎

  ^+∘^+≡^+∘^+ : ∀ m n → p ^+ m ∘ p ^+ n ≡ p ^+ n ∘ p ^+ m
  ^+∘^+≡^+∘^+ {p = p} m n =
    p ^+ m ∘ p ^+ n  ≡⟨ ^+∘^+ m ⟩
    p ^+ (m + n)     ≡⟨ cong (p ^+_) $ Nat.+-comm m ⟩
    p ^+ (n + m)     ≡⟨ sym $ ^+∘^+ n ⟩∎
    p ^+ n ∘ p ^+ m  ∎

  private

    -- Some lemmas which are used to define ^∘^ below.

    lemma₁ : ∀ n → (p ∘ p ^+ n) ∘ (p ⁻¹ ∘ q) ≡ p ^+ n ∘ q
    lemma₁ {p = p} {q = q} n =
      (p ∘ p ^+ n) ∘ (p ⁻¹ ∘ q)  ≡⟨ cong (_∘ (p ⁻¹ ∘ q)) $ ∘^+≡^+∘ (refl _) n ⟩
      (p ^+ n ∘ p) ∘ (p ⁻¹ ∘ q)  ≡⟨ sym $ assoc _ _ _ ⟩
      p ^+ n ∘ (p ∘ (p ⁻¹ ∘ q))  ≡⟨ cong (p ^+ n ∘_) $ assoc _ _ _ ⟩
      p ^+ n ∘ ((p ∘ p ⁻¹) ∘ q)  ≡⟨ cong (p ^+ n ∘_) $ cong (_∘ q) $ right-inverse _ ⟩
      p ^+ n ∘ (id ∘ q)          ≡⟨ cong (p ^+ n ∘_) $ left-identity _ ⟩∎
      p ^+ n ∘ q                 ∎

    lemma₂ : ∀ n → (p ⁻¹ ∘ (p ⁻¹) ^+ n) ∘ (p ∘ q) ≡ (p ⁻¹) ^+ n ∘ q
    lemma₂ {p = p} {q = q} n =
      (p ⁻¹ ∘ (p ⁻¹) ^+ n) ∘ (p ∘ q)        ≡⟨ cong (λ r → (p ⁻¹ ∘ (p ⁻¹) ^+ n) ∘ (r ∘ q)) $ sym $ involutive _ ⟩
      (p ⁻¹ ∘ (p ⁻¹) ^+ n) ∘ (p ⁻¹ ⁻¹ ∘ q)  ≡⟨ lemma₁ n ⟩∎
      (p ⁻¹) ^+ n ∘ q                       ∎

    lemma₃ : ∀ m n → p ^+ m ∘ (p ⁻¹) ^+ suc n ≡ p ^ Int.+ m +-[1+ n ]
    lemma₃ {p = p} zero n =
      id ∘ (p ⁻¹) ^+ suc n  ≡⟨ left-identity _ ⟩∎
      (p ⁻¹) ^+ suc n       ∎
    lemma₃ {p = p} (suc m) zero =
      (p ∘ p ^+ m) ∘ p ⁻¹ ∘ id  ≡⟨ lemma₁ m ⟩
      p ^+ m ∘ id               ≡⟨ right-identity _ ⟩∎
      p ^+ m                    ∎
    lemma₃ {p = p} (suc m) (suc n) =
      (p ∘ p ^+ m) ∘ (p ⁻¹ ∘ (p ⁻¹) ^+ suc n)  ≡⟨ lemma₁ m ⟩
      p ^+ m ∘ (p ⁻¹) ^+ suc n                 ≡⟨ lemma₃ m n ⟩∎
      p ^ Int.+ m +-[1+ n ]                    ∎

    lemma₄ : ∀ m n → (p ⁻¹) ^+ suc m ∘ p ^+ n ≡ p ^ Int.+ n +-[1+ m ]
    lemma₄ {p = p} m zero =
      (p ⁻¹) ^+ suc m ∘ id  ≡⟨ right-identity _ ⟩∎
      (p ⁻¹) ^+ suc m       ∎
    lemma₄ {p = p} zero (suc n) =
      (p ⁻¹ ∘ id) ∘ p ∘ p ^+ n  ≡⟨ lemma₂ zero ⟩
      id ∘ p ^+ n               ≡⟨ left-identity _ ⟩∎
      p ^+ n                    ∎
    lemma₄ {p = p} (suc m) (suc n) =
      (p ⁻¹ ∘ (p ⁻¹) ^+ suc m) ∘ (p ∘ p ^+ n)  ≡⟨ lemma₂ (suc m) ⟩
      (p ⁻¹) ^+ suc m ∘ p ^+ n                 ≡⟨ lemma₄ m n ⟩∎
      p ^ Int.+ n +-[1+ m ]                    ∎

  -- _^_ is homomorphic with respect to _∘_/Int._+_.

  ^∘^ : ∀ i → p ^ i ∘ p ^ j ≡ p ^ (i Int.+ j)
  ^∘^ {j = + _}      (+ m)            = ^+∘^+ m
  ^∘^ {j = -[1+ n ]} (+ m)            = lemma₃ m n
  ^∘^ {j = + n}      -[1+ m ]         = lemma₄ m n
  ^∘^ {p = p} {j = -[1+ n ]} -[1+ m ] =
    (p ⁻¹) ^+ suc m ∘ (p ⁻¹) ^+ suc n  ≡⟨ ^+∘^+ (suc m) ⟩
    (p ⁻¹) ^+ (suc m + suc n)          ≡⟨ cong ((p ⁻¹) ^+_) $ cong suc $ sym $ Nat.suc+≡+suc m ⟩∎
    (p ⁻¹) ^+ (2 + m + n)              ∎

  -- _^+ n commutes with _⁻¹.

  ^+⁻¹ : ∀ n → (p ^+ n) ⁻¹ ≡ (p ⁻¹) ^+ n
  ^+⁻¹         zero    = identity
  ^+⁻¹ {p = p} (suc n) =
    (p ∘ p ^+ n) ⁻¹     ≡⟨ ∘⁻¹ ⟩
    (p ^+ n) ⁻¹ ∘ p ⁻¹  ≡⟨ cong (_∘ p ⁻¹) $ ^+⁻¹ n ⟩
    (p ⁻¹) ^+ n ∘ p ⁻¹  ≡⟨ sym $ ∘^+≡^+∘ (refl _) n ⟩∎
    p ⁻¹ ∘ (p ⁻¹) ^+ n  ∎

  -- _^ i commutes with _⁻¹.

  ^⁻¹ : ∀ i → (p ^ i) ⁻¹ ≡ (p ⁻¹) ^ i
  ^⁻¹ (+ n)    = ^+⁻¹ n
  ^⁻¹ -[1+ n ] = ^+⁻¹ (suc n)

  -- Any power of id is equal to id.

  id^+ : ∀ n → id ^+ n ≡ id {x = x}
  id^+ zero    = refl _
  id^+ (suc n) =
    id ∘ id ^+ n  ≡⟨ left-identity _ ⟩
    id ^+ n       ≡⟨ id^+ n ⟩∎
    id            ∎

  id^ : ∀ i → id ^ i ≡ id {x = x}
  id^ (+ n) = id^+ n
  id^ -[1+ n ] =
    (id ⁻¹) ^+ suc n  ≡⟨ sym $ ^+⁻¹ (suc n) ⟩
    (id ^+ suc n) ⁻¹  ≡⟨ cong _⁻¹ $ id^+ (suc n) ⟩
    id ⁻¹             ≡⟨ identity ⟩∎
    id                ∎

  private

    lemma₅ : ∀ m n → p ^+ suc m ^+ n ≡ p ^+ n ∘ p ^+ m ^+ n
    lemma₅ _ zero =
      id       ≡⟨ sym $ left-identity _ ⟩∎
      id ∘ id  ∎
    lemma₅ {p = p} m (suc n) =
      p ^+ suc m ∘ p ^+ suc m ^+ n           ≡⟨ cong (p ^+ suc m ∘_) $ lemma₅ m n ⟩
      p ^+ suc m ∘ (p ^+ n ∘ p ^+ m ^+ n)    ≡⟨ assoc _ _ _ ⟩
      (p ^+ suc m ∘ p ^+ n) ∘ p ^+ m ^+ n    ≡⟨⟩
      ((p ∘ p ^+ m) ∘ p ^+ n) ∘ p ^+ m ^+ n  ≡⟨ cong (_∘ p ^+ m ^+ n) $ sym $ assoc _ _ _ ⟩
      (p ∘ p ^+ m ∘ p ^+ n) ∘ p ^+ m ^+ n    ≡⟨ cong (_∘ p ^+ m ^+ n) $ cong (p ∘_) $ ^+∘^+≡^+∘^+ m n ⟩
      (p ∘ p ^+ n ∘ p ^+ m) ∘ p ^+ m ^+ n    ≡⟨ cong (_∘ p ^+ m ^+ n) $ assoc _ _ _ ⟩
      ((p ∘ p ^+ n) ∘ p ^+ m) ∘ p ^+ m ^+ n  ≡⟨ sym $ assoc _ _ _ ⟩∎
      (p ∘ p ^+ n) ∘ p ^+ m ∘ p ^+ m ^+ n    ∎

  -- More rearrangement lemmas for _^+_.

  ^+^+≡^+* : ∀ m → p ^+ m ^+ n ≡ p ^+ (m * n)
  ^+^+≡^+* {n = n} zero =
    id ^+ n  ≡⟨ id^+ n ⟩∎
    id       ∎
  ^+^+≡^+* {p = p} {n = n} (suc m) =
    p ^+ suc m ^+ n        ≡⟨ lemma₅ m n ⟩
    p ^+ n ∘ p ^+ m ^+ n   ≡⟨ cong (p ^+ n ∘_) $ ^+^+≡^+* m ⟩
    p ^+ n ∘ p ^+ (m * n)  ≡⟨ ^+∘^+ n ⟩
    p ^+ (n + m * n)       ≡⟨⟩
    p ^+ (suc m * n)       ∎

  ∘^+≡^+∘^+ :
    p ∘ q ≡ q ∘ p →
    ∀ n →
    (p ∘ q) ^+ n ≡ p ^+ n ∘ q ^+ n
  ∘^+≡^+∘^+ _ zero =
    id       ≡⟨ sym $ left-identity _ ⟩∎
    id ∘ id  ∎
  ∘^+≡^+∘^+ {p = p} {q = q} comm (suc n) =
    (p ∘ q) ^+ suc n             ≡⟨⟩
    (p ∘ q) ∘ (p ∘ q) ^+ n       ≡⟨ cong ((p ∘ q) ∘_) $ ∘^+≡^+∘^+ comm n ⟩
    (p ∘ q) ∘ (p ^+ n ∘ q ^+ n)  ≡⟨ sym $ assoc _ _ _ ⟩
    p ∘ (q ∘ p ^+ n ∘ q ^+ n)    ≡⟨ cong (p ∘_) $ assoc _ _ _ ⟩
    p ∘ ((q ∘ p ^+ n) ∘ q ^+ n)  ≡⟨ cong (p ∘_) $ cong (_∘ (q ^+ n)) $ ∘^+≡^+∘ (sym comm) n ⟩
    p ∘ ((p ^+ n ∘ q) ∘ q ^+ n)  ≡⟨ cong (p ∘_) $ sym $ assoc _ _ _ ⟩
    p ∘ (p ^+ n ∘ q ∘ q ^+ n)    ≡⟨ assoc _ _ _ ⟩
    (p ∘ p ^+ n) ∘ q ∘ q ^+ n    ≡⟨⟩
    p ^+ suc n ∘ q ^+ suc n      ∎