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

module Pi1 where

open import Data.List
open import Data.Nat
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Groupoid

infix  2  _□
infixr 2  _⟷⟨_⟩_
infix  2  _▤
infixr 2  _⇔⟨_⟩_
infixr 10 _◎_
infix 30 _⟷_
infix  4  _∼_   -- homotopy between two paths
infix  4  _≃_   -- type of equivalences

-- Work on ch. on sets and n-levels and n=-2 and n=-1
-- then work on ch. on equivalences
-- then go back to functions are functors; type families are fibrations
-- then work on int construction
-- then work on example from popl

------------------------------------------------------------------------------
-- Level 0:
-- Types at this level are just plain sets with no interesting path structure.
-- The path structure is defined at levels 1 and beyond.

data U : Set where
  ZERO  : U
  ONE   : U
  PLUS  : U → U → U
  TIMES : U → U → U

⟦_⟧ : U → Set
⟦ ZERO ⟧        = ⊥
⟦ ONE ⟧         = ⊤
⟦ PLUS t₁ t₂ ⟧  = ⟦ t₁ ⟧ ⊎ ⟦ t₂ ⟧
⟦ TIMES t₁ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧

-- Programs
-- We use pointed types; programs are "fibers" from functions that map a
-- pointed type to another. In other words, each program takes one particular
-- value to another; if we want to work on another value, we generally use
-- another program.
--
-- We can recover a regular function by collecting all the fibers that
-- compose to the identity permutation.

record U• : Set where
  constructor •[_,_]
  field
    ∣_∣ : U
    • : ⟦ ∣_∣ ⟧

open U•

-- examples of plain types, values, and pointed types

ZERO• : {absurd : ⟦ ZERO ⟧} →  U•
ZERO• {absurd} = •[ ZERO , absurd ]

ONE• : U•
ONE• = •[ ONE , tt ]

BOOL : U
BOOL = PLUS ONE ONE

BOOL² : U
BOOL² = TIMES BOOL BOOL

TRUE : ⟦ BOOL ⟧
TRUE = inj₁ tt

FALSE : ⟦ BOOL ⟧
FALSE = inj₂ tt

BOOL•F : U•
BOOL•F = •[ BOOL , FALSE ]

BOOL•T : U•
BOOL•T = •[ BOOL , TRUE ]

-- The actual programs are the commutative semiring isomorphisms between
-- pointed types.

data _⟷_ : U• → U• → Set where
  unite₊  : ∀ {t v} → •[ PLUS ZERO t , inj₂ v ] ⟷ •[ t , v ]
  uniti₊  : ∀ {t v} → •[ t , v ] ⟷ •[ PLUS ZERO t , inj₂ v ]
  swap1₊  : ∀ {t₁ t₂ v₁} →
            •[ PLUS t₁ t₂ , inj₁ v₁ ] ⟷ •[ PLUS t₂ t₁ , inj₂ v₁ ]
  swap2₊  : ∀ {t₁ t₂ v₂} →
            •[ PLUS t₁ t₂ , inj₂ v₂ ] ⟷ •[ PLUS t₂ t₁ , inj₁ v₂ ]
  assocl1₊ : ∀ {t₁ t₂ t₃ v₁} →
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₁ v₁ ] ⟷
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ]
  assocl2₊ : ∀ {t₁ t₂ t₃ v₂} →
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₁ v₂) ] ⟷
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ]
  assocl3₊ : ∀ {t₁ t₂ t₃ v₃} →
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₂ v₃) ] ⟷
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₂ v₃ ]
  assocr1₊ : ∀ {t₁ t₂ t₃ v₁} →
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ] ⟷
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₁ v₁ ]
  assocr2₊ : ∀ {t₁ t₂ t₃ v₂} →
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ] ⟷
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₁ v₂) ]
  assocr3₊ : ∀ {t₁ t₂ t₃ v₃} →
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₂ v₃ ] ⟷
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₂ v₃) ]
  unite⋆  : ∀ {t v} → •[ TIMES ONE t , (tt , v) ] ⟷ •[ t , v ]
  uniti⋆  : ∀ {t v} → •[ t , v ] ⟷ •[ TIMES ONE t , (tt , v) ]
  swap⋆   : ∀ {t₁ t₂ v₁ v₂} → •[ TIMES t₁ t₂ , (v₁ , v₂) ] ⟷
                              •[ TIMES t₂ t₁ , (v₂ , v₁) ]
  assocl⋆ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
            •[ TIMES t₁ (TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ] ⟷
            •[ TIMES (TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ]
  assocr⋆ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
            •[ TIMES (TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ] ⟷
            •[ TIMES t₁ (TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ]
  distz : ∀ {t v absurd} →
            •[ TIMES ZERO t , (absurd , v) ] ⟷ •[ ZERO , absurd ]
  factorz : ∀ {t v absurd} →
            •[ ZERO , absurd ] ⟷ •[ TIMES ZERO t , (absurd , v) ]
  dist1   : ∀ {t₁ t₂ t₃ v₁ v₃} →
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ] ⟷
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₁ (v₁ , v₃) ]
  dist2   : ∀ {t₁ t₂ t₃ v₂ v₃} →
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ] ⟷
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₂ (v₂ , v₃) ]
  factor1   : ∀ {t₁ t₂ t₃ v₁ v₃} →
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₁ (v₁ , v₃) ] ⟷
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ]
  factor2   : ∀ {t₁ t₂ t₃ v₂ v₃} →
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₂ (v₂ , v₃) ] ⟷
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ]
  id⟷    : ∀ {t v} → •[ t , v ] ⟷ •[ t , v ]
  _◎_ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
           (•[ t₁ , v₁ ] ⟷ •[ t₂ , v₂ ]) →
           (•[ t₂ , v₂ ] ⟷ •[ t₃ , v₃ ]) →
           (•[ t₁ , v₁ ] ⟷ •[ t₃ , v₃ ])
  ⊕1   : ∀ {t₁ t₂ t₃ t₄ v₁ v₃} →
           (•[ t₁ , v₁ ] ⟷ •[ t₃ , v₃ ]) →
           (•[ PLUS t₁ t₂ , inj₁ v₁ ] ⟷ •[ PLUS t₃ t₄ , inj₁ v₃ ])
  ⊕2   : ∀ {t₁ t₂ t₃ t₄ v₂ v₄} →
           (•[ t₂ , v₂ ] ⟷ •[ t₄ , v₄ ]) →
           (•[ PLUS t₁ t₂ , inj₂ v₂ ] ⟷ •[ PLUS t₃ t₄ , inj₂ v₄ ])
  _⊗_     : ∀ {t₁ t₂ t₃ t₄ v₁ v₂ v₃ v₄} →
           (•[ t₁ , v₁ ] ⟷ •[ t₃ , v₃ ]) →
           (•[ t₂ , v₂ ] ⟷ •[ t₄ , v₄ ]) →
           (•[ TIMES t₁ t₂ , (v₁ , v₂) ] ⟷ •[ TIMES t₃ t₄ , (v₃ , v₄) ])

-- Nicer syntax that shows intermediate values instead of point-free
-- combinators

_⟷⟨_⟩_ : (t₁ : U•) {t₂ : U•} {t₃ : U•} →
          (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
_ ⟷⟨ α ⟩ β = α ◎ β

_□ : (t : U•) → {t : U•} → (t ⟷ t)
_□ t = id⟷

-- trace
-- first every combinator (t + t1) <-> (t + t2) can be decomposed into
-- four relations (or injective partial functions):
-- r11 : t1 -> t2
-- r12 : t1 -> t
-- r21 : t -> t2
-- r22 : t -> t
-- c = r11 ∪ (r12 ◎ r22⋆ ◎ r21)

eval : ∀ {t₁ t₂ v₁ v₂} → (•[ t₁ , v₁ ] ⟷ •[ t₂ , v₂ ]) → List U•
eval {t₁ = ZERO} {v₁ = ()} _
eval {t₂ = ZERO} {v₂ = ()} _
eval {t} {PLUS .ZERO .t} {v} {inj₂ .v} uniti₊ =
  •[ t , v ] ∷ •[ PLUS ZERO t , inj₂ v ] ∷ []
eval {PLUS .ZERO .t} {t} {inj₂ .v} {v} unite₊ =
  •[ PLUS ZERO t , inj₂ v ] ∷ •[ t , v ] ∷ []
eval {PLUS t₁ t₂} {PLUS .t₂ .t₁} {inj₁ v₁} {inj₂ .v₁} swap1₊ =
  •[ PLUS t₁ t₂ , inj₁ v₁ ] ∷ •[ PLUS t₂ t₁ , inj₂ v₁ ] ∷ []
eval {PLUS t₁ t₂} {PLUS .t₂ .t₁} {inj₂ v₂} {inj₁ .v₂} swap2₊ =
  •[ PLUS t₁ t₂ , inj₂ v₂ ] ∷ •[ PLUS t₂ t₁ , inj₁ v₂ ] ∷ []
eval {PLUS t₁ (PLUS t₂ t₃)} {PLUS (PLUS .t₁ .t₂) .t₃}
     {inj₁ v₁} {inj₁ (inj₁ .v₁)} assocl1₊ =
  •[ PLUS t₁ (PLUS t₂ t₃) , inj₁ v₁ ] ∷
  •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ] ∷ []
eval {PLUS t₁ (PLUS t₂ t₃)} {PLUS (PLUS .t₁ .t₂) .t₃}
     {inj₂ (inj₁ v₂)} {inj₁ (inj₂ .v₂)} assocl2₊ =
  •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₁ v₂) ] ∷
  •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ] ∷ []
eval {PLUS t₁ (PLUS t₂ t₃)} {PLUS (PLUS .t₁ .t₂) .t₃}
     {inj₂ (inj₂ v₃)} {inj₂ .v₃} assocl3₊ =
  •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₂ v₃) ] ∷
  •[ PLUS (PLUS t₁ t₂) t₃ , inj₂ v₃ ] ∷ []
eval {PLUS (PLUS .t₁ .t₂) .t₃} {PLUS t₁ (PLUS t₂ t₃)}
     {inj₁ (inj₁ .v₁)} {inj₁ v₁} assocr1₊ =
  •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ] ∷
  •[ PLUS t₁ (PLUS t₂ t₃) , inj₁ v₁ ] ∷ []
eval {PLUS (PLUS .t₁ .t₂) .t₃} {PLUS t₁ (PLUS t₂ t₃)}
     {inj₁ (inj₂ .v₂)} {inj₂ (inj₁ v₂)} assocr2₊ =
  •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ] ∷
  •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₁ v₂) ] ∷ []
eval {PLUS (PLUS .t₁ .t₂) .t₃} {PLUS t₁ (PLUS t₂ t₃)}
     {inj₂ .v₃} {inj₂ (inj₂ v₃)} assocr3₊ =
  •[ PLUS (PLUS t₁ t₂) t₃ , inj₂ v₃ ] ∷
  •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₂ v₃) ] ∷ []
eval {t} {TIMES .ONE .t} {v} {(tt , .v)} uniti⋆ =
  •[ t , v ] ∷ •[ TIMES ONE t , (tt , v) ] ∷ []
eval {TIMES .ONE .t} {t} {(tt , .v)} {v} unite⋆ =
  •[ TIMES ONE t , (tt , v) ] ∷ •[ t , v ] ∷ []
eval {TIMES t₁ t₂} {TIMES .t₂ .t₁} {(v₁ , v₂)} {(.v₂ , .v₁)} swap⋆ =
  •[ TIMES t₁ t₂ , (v₁ , v₂) ] ∷ •[ TIMES t₂ t₁ , (v₂ , v₁) ] ∷ []
eval {TIMES t₁ (TIMES t₂ t₃)} {TIMES (TIMES .t₁ .t₂) .t₃}
     {(v₁ , (v₂ , v₃))} {((.v₁ , .v₂) , .v₃)} assocl⋆ =
  •[ TIMES t₁ (TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ] ∷
  •[ TIMES (TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ] ∷ []
eval {TIMES (TIMES .t₁ .t₂) .t₃} {TIMES t₁ (TIMES t₂ t₃)}
     {((.v₁ , .v₂) , .v₃)} {(v₁ , (v₂ , v₃))} assocr⋆ =
  •[ TIMES (TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ] ∷
  •[ TIMES t₁ (TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ] ∷ []
eval {TIMES (PLUS t₁ t₂) t₃} {PLUS (TIMES .t₁ .t₃) (TIMES .t₂ .t₃)}
     {(inj₁ v₁ , v₃)} {inj₁ (.v₁ , .v₃)} dist1 =
  •[ TIMES (PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ] ∷
  •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₁ (v₁ , v₃) ] ∷ []
eval {TIMES (PLUS t₁ t₂) t₃} {PLUS (TIMES .t₁ .t₃) (TIMES .t₂ .t₃)}
     {(inj₂ v₂ , v₃)} {inj₂ (.v₂ , .v₃)} dist2 =
  •[ TIMES (PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ] ∷
  •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₂ (v₂ , v₃) ] ∷ []
eval {PLUS (TIMES .t₁ .t₃) (TIMES .t₂ .t₃)} {TIMES (PLUS t₁ t₂) t₃}
     {inj₁ (.v₁ , .v₃)} {(inj₁ v₁ , v₃)} factor1 =
  •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₁ (v₁ , v₃) ] ∷
  •[ TIMES (PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ] ∷ []
eval {PLUS (TIMES .t₁ .t₃) (TIMES .t₂ .t₃)} {TIMES (PLUS t₁ t₂) t₃}
     {inj₂ (.v₂ , .v₃)} {(inj₂ v₂ , v₃)} factor2 =
  •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₂ (v₂ , v₃) ] ∷
  •[ TIMES (PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ] ∷ []
eval {t} {.t} {v} {.v} id⟷ = •[ t , v ] ∷ •[ t , v ] ∷ []
eval {t₁} {t₃} {v₁} {v₃} (_◎_ {t₂ = t₂} {v₂ = v₂} c₁ c₂) =
  eval {t₁} {t₂} {v₁} {v₂} c₁ ++ eval {t₂} {t₃} {v₂} {v₃} c₂
eval {PLUS t₁ t₂} {PLUS t₃ t₄} {inj₁ v₁} {inj₁ v₃} (⊕1 c) =
  eval {t₁} {t₃} {v₁} {v₃} c -- tag
eval {PLUS t₁ t₂} {PLUS t₃ t₄} {inj₂ v₂} {inj₂ v₄} (⊕2 c) =
  eval {t₂} {t₄} {v₂} {v₄} c -- tag
eval {TIMES t₁ t₂} {TIMES t₃ t₄} {(v₁ , v₂)} {(v₃ , v₄)} (c₁ ⊗ c₂) =
  (eval {t₁} {t₃} {v₁} {v₃} c₁) ++ (eval {t₂} {t₄} {v₂} {v₄} c₂)
  -- zip

test = eval (•[ BOOL² , (TRUE , TRUE) ]
               ⟷⟨ dist1 ⟩
             •[ PLUS (TIMES ONE BOOL) (TIMES ONE BOOL) , inj₁ (tt , TRUE) ]
               ⟷⟨ ⊕1 (id⟷ ⊗ swap1₊)⟩
             •[ PLUS (TIMES ONE BOOL) (TIMES ONE BOOL) , inj₁ (tt , FALSE) ]
               ⟷⟨ factor1 ⟩
             •[ BOOL² , (TRUE , FALSE) ] □)

-- The above are "fibers". We collect the fibers into functions.

data SWAP₊ {t₁ t₂ v₁ v₂} :
  (•[ PLUS t₁ t₂ , inj₁ v₁ ] ⟷ •[ PLUS t₂ t₁ , inj₂ v₁ ]) →
  (•[ PLUS t₁ t₂ , inj₂ v₂ ] ⟷ •[ PLUS t₂ t₁ , inj₁ v₂ ]) →
  Set where
  swap₊ : SWAP₊ swap1₊ swap2₊

Fun : (t₁ t₂ : U) → Set
Fun t₁ t₂ = (v₁ : ⟦ t₁ ⟧) → Σ[ v₂ ∈ ⟦ t₂ ⟧ ] (•[ t₁ , v₁ ] ⟷ •[ t₂ , v₂ ])

NOT : Fun BOOL BOOL
NOT (inj₁ tt) = (FALSE , swap1₊)
NOT (inj₂ tt) = (TRUE  , swap2₊)

-- Note that functions are not reversible!!
Squash : Fun BOOL BOOL
Squash (inj₁ x) = inj₂ x , swap1₊
Squash (inj₂ y) = inj₂ y , id⟷

CNOT : Fun BOOL² BOOL²
CNOT (inj₂ tt , b) =
  ((FALSE , b) , dist2 ◎ (⊕2 id⟷) ◎ factor2)
CNOT (inj₁ tt , inj₂ tt) =
  ((TRUE , TRUE) , dist1 ◎ (⊕1 (id⟷ ⊗ swap2₊)) ◎ factor1)
CNOT (inj₁ tt , inj₁ tt) =
  ((TRUE , FALSE) ,
   (•[ BOOL² , (TRUE , TRUE) ]
      ⟷⟨ dist1 ⟩
    •[ PLUS (TIMES ONE BOOL) (TIMES ONE BOOL) , inj₁ (tt , TRUE) ]
      ⟷⟨ ⊕1 (id⟷ ⊗ swap1₊)⟩
    •[ PLUS (TIMES ONE BOOL) (TIMES ONE BOOL) , inj₁ (tt , FALSE) ]
      ⟷⟨ factor1 ⟩
    •[ BOOL² , (TRUE , FALSE) ] □))

-- The universe of types is a groupoid. The objects of this groupoid are the
-- pointed types; the morphisms are the programs; and the equivalence of
-- programs is the degenerate observational equivalence that equates every
-- two programs that are extensionally equivalent.

! : {t₁ t₂ : U•} → (t₁ ⟷ t₂) → (t₂ ⟷ t₁)
! unite₊ = uniti₊
! uniti₊ = unite₊
! swap1₊ = swap2₊
! swap2₊ = swap1₊
! assocl1₊ = assocr1₊
! assocl2₊ = assocr2₊
! assocl3₊ = assocr3₊
! assocr1₊ = assocl1₊
! assocr2₊ = assocl2₊
! assocr3₊ = assocl3₊
! unite⋆ = uniti⋆
! uniti⋆ = unite⋆
! swap⋆ = swap⋆
! assocl⋆ = assocr⋆
! assocr⋆ = assocl⋆
! distz = factorz
! factorz = distz
! dist1 = factor1
! dist2 = factor2
! factor1 = dist1
! factor2 = dist2
! id⟷ = id⟷
! (c₁ ◎ c₂) = ! c₂ ◎ ! c₁
! (⊕1 c₁) = ⊕1 (! c₁)
! (⊕2 c₂) = ⊕2 (! c₂)
! (c₁ ⊗ c₂) = ! c₁ ⊗ ! c₂

_obs≅_ : {t₁ t₂ : U•} → (c₁ c₂ : t₁ ⟷ t₂) → Set
c₁ obs≅ c₂ = ⊤

UG : 1Groupoid
UG = record
       { set = U•
       ; _↝_ = _⟷_
       ; _≈_ = _obs≅_
       ; id = id⟷
       ; _∘_ = λ y⟷z x⟷y → x⟷y ◎ y⟷z
       ; _⁻¹ = !
       ; lneutr = λ _ → tt
       ; rneutr = λ _ → tt
       ; assoc = λ _ _ _ → tt
       ; equiv = record { refl = tt
                        ; sym = λ _ → tt
                        ; trans = λ _ _ → tt
                        }
       ; linv = λ _ → tt
       ; rinv = λ _ → tt
       ; ∘-resp-≈ = λ _ _ → tt
       }

-- Now let us talk about homotopies and equivalences

-- Two paths starting at the same point are homotopic if they map that point
-- to related points (of course, related by another path)

_∼_ : {t₁ t₂ t₂' : U•} → (p : t₁ ⟷ t₂) → (q : t₁ ⟷ t₂') → Set
_∼_ {t₁} {t₂} {t₂'} p q = (t₂ ⟷ t₂')

refl∼ : {t₁ t₂ : U•} → (p : t₁ ⟷ t₂) → (p ∼ p)
refl∼ {t₁} {t₂} p = id⟷

sym∼ : {t₁ t₂ t₂' : U•} {p : t₁ ⟷ t₂} {q : t₁ ⟷ t₂'} → (p ∼ q) → (q ∼ p)
sym∼ p∼q = ! p∼q

trans∼ : {t₁ t₂ t₂' t₂'' : U•} {p : t₁ ⟷ t₂} {q : t₁ ⟷ t₂'} {r : t₁ ⟷ t₂''} →
         (p ∼ q) → (q ∼ r) → (p ∼ r)
trans∼ p∼q q∼r = p∼q ◎ q∼r

module T where
  -- Note that paths mapping a point FALSE and TRUE can be homotopic

  p : •[ BOOL , FALSE ] ⟷ •[ BOOL , FALSE ]
  p = id⟷

  q : •[ BOOL , FALSE ] ⟷ •[ BOOL , TRUE ]
  q = swap2₊

  p∼q : p ∼ q
  p∼q = swap2₊

-- equivalences

-- the following makes no sense because I can use id⟷ for α and β

record qinv {t₁ t₂ : U•} (p : t₁ ⟷ t₂) : Set where
  constructor mkqinv
  field
    q : t₂ ⟷ t₁
    α : (p ◎ q) ∼ id⟷
    β : (q ◎ p) ∼ id⟷

idqinv : {t : U•} → qinv {t} {t} id⟷
idqinv = record {
           q = id⟷ ;
           α = id⟷ ;
           β = id⟷
         }

record isequiv {t₁ t₂ : U•} (p : t₁ ⟷ t₂) : Set where
  constructor mkisequiv
  field
    q : t₂ ⟷ t₁
    α : (p ◎ q) ∼ id⟷
    r : t₂ ⟷ t₁
    β : (r ◎ p) ∼ id⟷

equiv₁ : {t₁ t₂ : U•} {p : t₁ ⟷ t₂} → qinv p → isequiv p
equiv₁ (mkqinv iq iα iβ) = mkisequiv iq iα iq iβ

_≃_ : (t₁ t₂ : U•) → Set
t₁ ≃ t₂ = Σ[ p ∈ t₁ ⟷ t₂ ] (isequiv p)

id≃ : {t : U•} → t ≃ t
id≃ = (id⟷ , equiv₁ idqinv)

------------------------------------------------------------------------------
-- Level 1:
-- Types are sets of paths. The paths are defined at level 0.  At level 1,
-- there is no interesting 2path structure. From the perspective of level 0,
-- we have points with non-trivial paths between them, i.e., we have a
-- groupoid. The paths cross type boundaries, i.e., we have heterogeneous
-- equality

-- types

data 1U : Set where
  1ZERO  : 1U              -- empty set of paths
  1ONE   : 1U              -- a trivial path
  1PLUS  : 1U → 1U → 1U      -- disjoint union of paths
  1TIMES : 1U → 1U → 1U      -- pairs of paths
  PATH  : (t₁ t₂ : U•) → 1U -- level 0 paths between values

-- values

data Path (t₁ t₂ : U•) : Set where
  path : (c : t₁ ⟷ t₂) → Path t₁ t₂

1⟦_⟧ : 1U → Set
1⟦ 1ZERO ⟧             = ⊥
1⟦ 1ONE ⟧              = ⊤
1⟦ 1PLUS t₁ t₂ ⟧       = 1⟦ t₁ ⟧ ⊎ 1⟦ t₂ ⟧
1⟦ 1TIMES t₁ t₂ ⟧      = 1⟦ t₁ ⟧ × 1⟦ t₂ ⟧
1⟦ PATH t₁ t₂ ⟧ = Path t₁ t₂

-- examples

T⟷F : Set
T⟷F = Path BOOL•T BOOL•F

F⟷T : Set
F⟷T = Path BOOL•F BOOL•T

p₁ p₂ p₃ p₄ p₅ : T⟷F
p₁ = path swap1₊
p₂ = path (id⟷ ◎ swap1₊)
p₃ = path (swap1₊ ◎ swap2₊ ◎ swap1₊)
p₄ = path (swap1₊ ◎ id⟷)
p₅ = path (uniti⋆ ◎ swap⋆ ◎ (swap1₊ ⊗ id⟷) ◎ swap⋆ ◎ unite⋆)

p₆ : (T⟷F × T⟷F) ⊎ F⟷T
p₆ = inj₁ (p₁ , p₂)

-- Programs map paths to paths. We also use pointed types.

record 1U• : Set where
  constructor 1•[_,_]
  field
    1∣_∣ : 1U
    1• : 1⟦ 1∣_∣ ⟧

open 1U•

data _⇔_ : 1U• → 1U• → Set where
  unite₊  : ∀ {t v} → 1•[ 1PLUS 1ZERO t , inj₂ v ] ⇔ 1•[ t , v ]
  uniti₊  : ∀ {t v} → 1•[ t , v ] ⇔ 1•[ 1PLUS 1ZERO t , inj₂ v ]
  swap1₊  : ∀ {t₁ t₂ v₁} →
            1•[ 1PLUS t₁ t₂ , inj₁ v₁ ] ⇔ 1•[ 1PLUS t₂ t₁ , inj₂ v₁ ]
  swap2₊  : ∀ {t₁ t₂ v₂} →
            1•[ 1PLUS t₁ t₂ , inj₂ v₂ ] ⇔ 1•[ 1PLUS t₂ t₁ , inj₁ v₂ ]
  assocl1₊ : ∀ {t₁ t₂ t₃ v₁} →
             1•[ 1PLUS t₁ (1PLUS t₂ t₃) , inj₁ v₁ ] ⇔
             1•[ 1PLUS (1PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ]
  assocl2₊ : ∀ {t₁ t₂ t₃ v₂} →
             1•[ 1PLUS t₁ (1PLUS t₂ t₃) , inj₂ (inj₁ v₂) ] ⇔
             1•[ 1PLUS (1PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ]
  assocl3₊ : ∀ {t₁ t₂ t₃ v₃} →
             1•[ 1PLUS t₁ (1PLUS t₂ t₃) , inj₂ (inj₂ v₃) ] ⇔
             1•[ 1PLUS (1PLUS t₁ t₂) t₃ , inj₂ v₃ ]
  assocr1₊ : ∀ {t₁ t₂ t₃ v₁} →
             1•[ 1PLUS (1PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ] ⇔
             1•[ 1PLUS t₁ (1PLUS t₂ t₃) , inj₁ v₁ ]
  assocr2₊ : ∀ {t₁ t₂ t₃ v₂} →
             1•[ 1PLUS (1PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ] ⇔
             1•[ 1PLUS t₁ (1PLUS t₂ t₃) , inj₂ (inj₁ v₂) ]
  assocr3₊ : ∀ {t₁ t₂ t₃ v₃} →
             1•[ 1PLUS (1PLUS t₁ t₂) t₃ , inj₂ v₃ ] ⇔
             1•[ 1PLUS t₁ (1PLUS t₂ t₃) , inj₂ (inj₂ v₃) ]
  unite⋆  : ∀ {t v} → 1•[ 1TIMES 1ONE t , (tt , v) ] ⇔ 1•[ t , v ]
  uniti⋆  : ∀ {t v} → 1•[ t , v ] ⇔ 1•[ 1TIMES 1ONE t , (tt , v) ]
  swap⋆   : ∀ {t₁ t₂ v₁ v₂} →
              1•[ 1TIMES t₁ t₂ , (v₁ , v₂) ] ⇔ 1•[ 1TIMES t₂ t₁ , (v₂ , v₁) ]
  assocl⋆ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
            1•[ 1TIMES t₁ (1TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ] ⇔
            1•[ 1TIMES (1TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ]
  assocr⋆ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
            1•[ 1TIMES (1TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ] ⇔
            1•[ 1TIMES t₁ (1TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ]
  distz : ∀ {t v absurd} →
            1•[ 1TIMES 1ZERO t , (absurd , v) ] ⇔ 1•[ 1ZERO , absurd ]
  factorz : ∀ {t v absurd} →
            1•[ 1ZERO , absurd ] ⇔ 1•[ 1TIMES 1ZERO t , (absurd , v) ]
  dist1   : ∀ {t₁ t₂ t₃ v₁ v₃} →
            1•[ 1TIMES (1PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ] ⇔
            1•[ 1PLUS (1TIMES t₁ t₃) (1TIMES t₂ t₃) , inj₁ (v₁ , v₃) ]
  dist2   : ∀ {t₁ t₂ t₃ v₂ v₃} →
            1•[ 1TIMES (1PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ] ⇔
            1•[ 1PLUS (1TIMES t₁ t₃) (1TIMES t₂ t₃) , inj₂ (v₂ , v₃) ]
  factor1   : ∀ {t₁ t₂ t₃ v₁ v₃} →
            1•[ 1PLUS (1TIMES t₁ t₃) (1TIMES t₂ t₃) , inj₁ (v₁ , v₃) ] ⇔
            1•[ 1TIMES (1PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ]
  factor2   : ∀ {t₁ t₂ t₃ v₂ v₃} →
            1•[ 1PLUS (1TIMES t₁ t₃) (1TIMES t₂ t₃) , inj₂ (v₂ , v₃) ] ⇔
            1•[ 1TIMES (1PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ]
  id⇔    : ∀ {t v} → 1•[ t , v ] ⇔ 1•[ t , v ]
  _◎_    : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} → (1•[ t₁ , v₁ ] ⇔ 1•[ t₂ , v₂ ]) →
           (1•[ t₂ , v₂ ] ⇔ 1•[ t₃ , v₃ ]) →
           (1•[ t₁ , v₁ ] ⇔ 1•[ t₃ , v₃ ])
  ⊕1   : ∀ {t₁ t₂ t₃ t₄ v₁ v₃} →
           (1•[ t₁ , v₁ ] ⇔ 1•[ t₃ , v₃ ]) →
           (1•[ 1PLUS t₁ t₂ , inj₁ v₁ ] ⇔ 1•[ 1PLUS t₃ t₄ , inj₁ v₃ ])
  ⊕2   : ∀ {t₁ t₂ t₃ t₄ v₂ v₄} →
           (1•[ t₂ , v₂ ] ⇔ 1•[ t₄ , v₄ ]) →
           (1•[ 1PLUS t₁ t₂ , inj₂ v₂ ] ⇔ 1•[ 1PLUS t₃ t₄ , inj₂ v₄ ])
  _⊗_     : ∀ {t₁ t₂ t₃ t₄ v₁ v₂ v₃ v₄} →
           (1•[ t₁ , v₁ ] ⇔ 1•[ t₃ , v₃ ]) → (1•[ t₂ , v₂ ] ⇔ 1•[ t₄ , v₄ ]) →
          (1•[ 1TIMES t₁ t₂ , (v₁ , v₂) ] ⇔ 1•[ 1TIMES t₃ t₄ , (v₃ , v₄) ])
  lidl : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂} →
        1•[ PATH t₁ t₂ , path (id⟷ ◎ c) ] ⇔ 1•[ PATH t₁ t₂ , path c ]
  lidr : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂} →
        1•[ PATH t₁ t₂ , path c ] ⇔ 1•[ PATH t₁ t₂ , path (id⟷ ◎ c) ]
  ridl : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂} →
        1•[ PATH t₁ t₂ , path (c ◎ id⟷) ] ⇔ 1•[ PATH t₁ t₂ , path c ]
  ridr : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂} →
        1•[ PATH t₁ t₂ , path c ] ⇔ 1•[ PATH t₁ t₂ , path (c ◎ id⟷) ]
  assocl : ∀ {t₁ t₂ t₃ t₄}  →
          {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} {c₃ : t₃ ⟷ t₄} →
          1•[ PATH t₁ t₄ , path (c₁ ◎ (c₂ ◎ c₃)) ] ⇔
          1•[ PATH t₁ t₄ , path ((c₁ ◎ c₂) ◎ c₃) ]
  assocr : ∀ {t₁ t₂ t₃ t₄}  →
          {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} {c₃ : t₃ ⟷ t₄} →
          1•[ PATH t₁ t₄ , path ((c₁ ◎ c₂) ◎ c₃) ] ⇔
          1•[ PATH t₁ t₄ , path (c₁ ◎ (c₂ ◎ c₃)) ]
  linv◎l : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂ } →
          1•[ PATH t₁ t₁ , path (c ◎ ! c)] ⇔
          1•[ PATH t₁ t₁ , path id⟷ ]
  linv◎r : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂ } →
          1•[ PATH t₁ t₁ , path id⟷ ] ⇔
          1•[ PATH t₁ t₁ , path (c ◎ ! c) ]
  rinv◎l : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂ } →
          1•[ PATH t₂ t₂ , path (! c ◎ c)] ⇔
          1•[ PATH t₂ t₂ , path id⟷ ]
  rinv◎r : ∀ {t₁ t₂} → {c : t₁ ⟷ t₂ } →
          1•[ PATH t₂ t₂ , path id⟷ ] ⇔
          1•[ PATH t₂ t₂ , path (! c ◎ c) ]
  resp◎   : ∀ {t₁ t₂ t₃} →
           {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} {c₃ : t₁ ⟷ t₂} {c₄ : t₂ ⟷ t₃} →
           (1•[ PATH t₁ t₂ , path c₁ ] ⇔ 1•[ PATH t₁ t₂ , path c₃ ]) →
           (1•[ PATH t₂ t₃ , path c₂ ] ⇔ 1•[ PATH t₂ t₃ , path c₄ ]) →
           1•[ PATH t₁ t₃ , path (c₁ ◎ c₂) ] ⇔ 1•[ PATH t₁ t₃ , path (c₃ ◎ c₄) ]

1! : {t₁ t₂ : 1U•} → (t₁ ⇔ t₂) → (t₂ ⇔ t₁)
1! unite₊ = uniti₊
1! uniti₊ = unite₊
1! swap1₊ = swap2₊
1! swap2₊ = swap1₊
1! assocl1₊ = assocr1₊
1! assocl2₊ = assocr2₊
1! assocl3₊ = assocr3₊
1! assocr1₊ = assocl1₊
1! assocr2₊ = assocl2₊
1! assocr3₊ = assocl3₊
1! unite⋆ = uniti⋆
1! uniti⋆ = unite⋆
1! swap⋆ = swap⋆
1! assocl⋆ = assocr⋆
1! assocr⋆ = assocl⋆
1! distz = factorz
1! factorz = distz
1! dist1 = factor1
1! dist2 = factor2
1! factor1 = dist1
1! factor2 = dist2
1! id⇔ = id⇔
1! (c₁ ◎ c₂) = 1! c₂ ◎ 1! c₁
1! (⊕1 c₁) = ⊕1 (1! c₁)
1! (⊕2 c₂) = ⊕2 (1! c₂)
1! (c₁ ⊗ c₂) = 1! c₁ ⊗ 1! c₂
1! (resp◎ c₁ c₂) = resp◎ (1! c₁) (1! c₂)
1! ridl = ridr
1! ridr = ridl
1! lidl = lidr
1! lidr = lidl
1! assocl = assocr
1! assocr = assocl
1! linv◎l = linv◎r
1! linv◎r = linv◎l
1! rinv◎l = rinv◎r
1! rinv◎r = rinv◎l

1!≡ : {t₁ t₂ : 1U•} → (c : t₁ ⇔ t₂) → 1! (1! c) ≡ c
1!≡ unite₊ = refl
1!≡ uniti₊ = refl
1!≡ swap1₊ = refl
1!≡ swap2₊ = refl
1!≡ assocl1₊ = refl
1!≡ assocl2₊ = refl
1!≡ assocl3₊ = refl
1!≡ assocr1₊ = refl
1!≡ assocr2₊ = refl
1!≡ assocr3₊ = refl
1!≡ unite⋆ = refl
1!≡ uniti⋆ = refl
1!≡ swap⋆ = refl
1!≡ assocl⋆ = refl
1!≡ assocr⋆ = refl
1!≡ distz = refl
1!≡ factorz = refl
1!≡ dist1 = refl
1!≡ dist2 = refl
1!≡ factor1 = refl
1!≡ factor2 = refl
1!≡ id⇔ = refl
1!≡ (c₁ ◎ c₂) = cong₂ (λ c₁ c₂ → c₁ ◎ c₂) (1!≡ c₁) (1!≡ c₂)
1!≡ (⊕1 c₁) = cong (λ c₁ → ⊕1 c₁) (1!≡ c₁)
1!≡ (⊕2 c₂) = cong (λ c₂ → ⊕2 c₂) (1!≡ c₂)
1!≡ (c₁ ⊗ c₂) = cong₂ (λ c₁ c₂ → c₁ ⊗ c₂) (1!≡ c₁) (1!≡ c₂)
1!≡ lidl = refl
1!≡ lidr = refl
1!≡ ridl = refl
1!≡ ridr = refl
1!≡ (resp◎ c₁ c₂) = cong₂ (λ c₁ c₂ → resp◎ c₁ c₂) (1!≡ c₁) (1!≡ c₂)
1!≡ assocl = refl
1!≡ assocr = refl
1!≡ linv◎l = refl
1!≡ linv◎r = refl
1!≡ rinv◎l = refl
1!≡ rinv◎r = refl

-- better syntax for writing 2paths

_⇔⟨_⟩_ : {t₁ t₂ : U•} (c₁ : t₁ ⟷ t₂) {c₂ : t₁ ⟷ t₂} {c₃ : t₁ ⟷ t₂} →
         (1•[ PATH t₁ t₂ , path c₁ ] ⇔ 1•[ PATH t₁ t₂ , path c₂ ]) →
         (1•[ PATH t₁ t₂ , path c₂ ] ⇔ 1•[ PATH t₁ t₂ , path c₃ ]) →
         (1•[ PATH t₁ t₂ , path c₁ ] ⇔ 1•[ PATH t₁ t₂ , path c₃ ])
_ ⇔⟨ α ⟩ β = α ◎ β

_▤ : {t₁ t₂ : U•} → (c : t₁ ⟷ t₂) →
     1•[ PATH t₁ t₂ , path c ] ⇔ 1•[ PATH t₁ t₂ , path c ]
_▤ c = id⇔

α₁ : 1•[ PATH BOOL•T BOOL•F , p₁ ] ⇔ 1•[ PATH BOOL•T BOOL•F , p₁ ]
α₁ = id⇔

α₂ : 1•[ PATH BOOL•T BOOL•F , p₁ ] ⇔ 1•[ PATH BOOL•T BOOL•F , p₂ ]
α₂ = lidr

-- level 0 is a groupoid with a non-trivial path equivalence the various inv*
-- rules are not justified by the groupoid proof; they are justified by the
-- need for computational rules. So it is important to have not just a
-- groupoid structure but a groupoid structure that we can compute with. So
-- if we say that we want p ◎ p⁻¹ to be id, we must have computational rules
-- that allow us to derive this for any path p, and similarly for all the
-- other groupoid rules. (cf. The canonicity for 2D type theory by Licata and
-- Harper)

G : 1Groupoid
G = record
        { set = U•
        ; _↝_ = _⟷_
        ; _≈_ = λ {t₁} {t₂} c₀ c₁ →
                1•[ PATH t₁ t₂ , path c₀ ] ⇔ 1•[ PATH t₁ t₂ , path c₁ ]
        ; id = id⟷
        ; _∘_ = λ c₀ c₁ → c₁ ◎ c₀
        ; _⁻¹ = !
        ; lneutr = λ _ → ridl
        ; rneutr = λ _ → lidl
        ; assoc = λ _ _ _ → assocl
        ; equiv = record { refl = id⇔
                                ; sym = λ c → 1! c
                                ; trans = λ c₀ c₁ → c₀ ◎ c₁ }
        ; linv = λ {t₁} {t₂} c → linv◎l
        ; rinv = λ {t₁} {t₂} c → rinv◎l
        ; ∘-resp-≈ = λ f⟷h g⟷i → resp◎ g⟷i f⟷h
        }

-- We can now ask whether a given space is a set (Def. 3.1.1)

isSet : U → Set
isSet t = (v v' : ⟦ t ⟧) → (p q : •[ t , v ] ⟷ •[ t , v' ]) →
          (1•[ PATH •[ t , v ] •[ t , v' ] , path p ] ⇔
           1•[ PATH •[ t , v ] •[ t , v' ] , path q ])

0isSet : isSet ZERO
0isSet ()

1isSet : isSet ONE
1isSet tt tt id⟷ id⟷ = id⇔
1isSet tt tt id⟷ (uniti₊ ◎ unite₊) =
  id⟷
    ⇔⟨ rinv◎r ⟩
  uniti₊ ◎ unite₊ ▤
1isSet tt tt id⟷ (uniti₊ ◎ (q₂ ◎ q₃)) =
  id⟷
    ⇔⟨ {!!} ⟩
  (uniti₊ ◎ (q₂ ◎ q₃)) ▤
1isSet tt tt id⟷ (uniti⋆ ◎ unite⋆) = {!!}
1isSet tt tt id⟷ (uniti⋆ ◎ (q₂ ◎ q₃)) = {!!}
1isSet tt tt id⟷ (id⟷ ◎ id⟷) = {!!}
1isSet tt tt id⟷ (id⟷ ◎ (q₂ ◎ q₃)) = {!!}
1isSet tt tt id⟷ ((q₁ ◎ q₂) ◎ unite₊) = {!!}
1isSet tt tt id⟷ ((q₁ ◎ q₂) ◎ unite⋆) = {!!}
1isSet tt tt id⟷ ((q₁ ◎ q₂) ◎ id⟷) = {!!}
1isSet tt tt id⟷ ((q₁ ◎ q₂) ◎ (q₃ ◎ q₄)) = {!!}
1isSet tt tt (p₁ ◎ p₂) id⟷ = {!!}
1isSet tt tt (p₁ ◎ p₂) (q₁ ◎ q₂) = {!!}

------------------------------------------------------------------------------
-- Level 2 etc.

data 2U : Set where
  2ZERO  : 2U
  2ONE   : 2U
  2PLUS  : 2U → 2U → 2U
  2TIMES : 2U → 2U → 2U
  1PATH  : (t₁ t₂ : 1U•) → 2U

data 1Path (t₁ t₂ : 1U•) : Set where
  1path : (c : t₁ ⇔ t₂) → 1Path t₁ t₂

2⟦_⟧ : 2U → Set
2⟦ 2ZERO ⟧             = ⊥
2⟦ 2ONE ⟧              = ⊤
2⟦ 2PLUS t₁ t₂ ⟧       = 2⟦ t₁ ⟧ ⊎ 2⟦ t₂ ⟧
2⟦ 2TIMES t₁ t₂ ⟧      = 2⟦ t₁ ⟧ × 2⟦ t₂ ⟧
2⟦ 1PATH t₁ t₂ ⟧ = 1Path t₁ t₂

record 2U• : Set where
  constructor 2•[_,_]
  field
    2∣_∣ : 2U
    2•   : 2⟦ 2∣_∣ ⟧

data _2⇔_ : 2U• → 2U• → Set where
  id2⇔    : ∀ {t v} → 2•[ t , v ] 2⇔ 2•[ t , v ]
 -- and all the remaining combinators...

-- Eckmann-Hilton

Ω : (t : U) → {v : ⟦ t ⟧} → 1U•
Ω t {v} = 1•[ PATH t• t• , path id⟷ ]
  where t• = •[ t , v ]

Ω² : (t : U) → {v : ⟦ t ⟧} → 2U•
Ω² t {v} = 2•[ 1PATH t• t• , 1path id⇔ ]
  where t• = Ω t {v}

eckmann-hilton : {t : U} {v : ⟦ t ⟧} (α β : (Ω t {v}) ⇔ (Ω t {v})) →
  (2•[ 1PATH (Ω t {v}) (Ω t {v}) , 1path (α ◎ β) ] 2⇔
   2•[ 1PATH (Ω t {v}) (Ω t {v}) , 1path (β ◎ α) ])
eckmann-hilton {t} {v} α β = {!!}

------------------------------------------------------------------------------
-- Int construction

-- Types are of the form t - t'

record Uℤ : Set where
  constructor _-_
  field
    pos  : U
    neg  : U

open Uℤ

ZEROℤ ONEℤ : Uℤ
ZEROℤ = ZERO - ZERO
ONEℤ  = ONE  - ZERO

PLUSℤ : Uℤ → Uℤ → Uℤ
PLUSℤ (pos₁ - neg₁) (pos₂ - neg₂) = PLUS pos₁ pos₂ - PLUS neg₁ neg₂

TIMESℤ : Uℤ → Uℤ → Uℤ
TIMESℤ (pos₁ - neg₁) (pos₂ - neg₂) =
  PLUS (TIMES pos₁ pos₂) (TIMES neg₁ neg₂) -
  PLUS (TIMES pos₁ neg₂) (TIMES neg₁ pos₂)

FLIPℤ : Uℤ → Uℤ
FLIPℤ (pos - neg) = neg - pos

LOLLIℤ : Uℤ → Uℤ → Uℤ
LOLLIℤ (pos₁ - neg₁) (pos₂ - neg₂) = PLUS neg₁ pos₂ - PLUS pos₁ neg₂

-- Pointed types

data Uℤ• : Set where
  pos• : (t : Uℤ) → ⟦ pos t ⟧ → Uℤ•
  neg• : (t : Uℤ) → ⟦ neg t ⟧ → Uℤ•

ZEROℤ+• : {t : U} {v : ⟦ t ⟧} → Uℤ•
ZEROℤ+• {t} {v} = pos• (t - t) v

ZEROℤ-• : {t : U} {v : ⟦ t ⟧} → Uℤ•
ZEROℤ-• {t} {v} = neg• (t - t) v

PLUS1ℤ• : Uℤ• → Uℤ → Uℤ•
PLUS1ℤ• (pos• t₁ v₁) t₂ = pos• (PLUSℤ t₁ t₂) (inj₁ v₁)
PLUS1ℤ• (neg• t₁ v₁) t₂ = neg• (PLUSℤ t₁ t₂) (inj₁ v₁)

PLUS2ℤ• : Uℤ → Uℤ• → Uℤ•
PLUS2ℤ• t₁ (pos• t₂ v₂) = pos• (PLUSℤ t₁ t₂) (inj₂ v₂)
PLUS2ℤ• t₁ (neg• t₂ v₂) = neg• (PLUSℤ t₁ t₂) (inj₂ v₂)

-- Combinators on pointed types

data _⇄_ : Uℤ• → Uℤ• → Set where
  Fwd : ∀ {t₁ t₂ t₃ t₄ v₁ v₃} →
        •[ PLUS t₁ t₄ , inj₁ v₁ ] ⟷ •[ PLUS t₂ t₃ , inj₂ v₃ ] →
        pos• (t₁ - t₂) v₁ ⇄ pos• (t₃ - t₄) v₃
  Bck : ∀ {t₁ t₂ t₃ t₄ v₂ v₄} →
        •[ PLUS t₁ t₄ , inj₂ v₄ ] ⟷ •[ PLUS t₂ t₃ , inj₁ v₂ ] →
        neg• (t₁ - t₂) v₂ ⇄ neg• (t₃ - t₄) v₄
  B2F : ∀ {t v} → neg• (t - t) v ⇄ pos• (t - t) v
  F2B : ∀ {t v} → pos• (t - t) v ⇄ neg• (t - t) v

unite₊⇄ : {t : Uℤ•} → PLUS2ℤ• ZEROℤ t ⇄ t
unite₊⇄ {pos• t v} =
  Fwd (•[ PLUS (PLUS ZERO (pos t)) (neg t) , inj₁ (inj₂ v) ]
         ⟷⟨ assocr2₊ ⟩
       •[ PLUS ZERO (PLUS (pos t) (neg t)) , inj₂ (inj₁ v) ]
         ⟷⟨ unite₊ ◎ swap1₊ ⟩
       •[ PLUS (neg t) (pos t) , inj₂ v ]
         ⟷⟨ uniti₊ ⟩
       •[ PLUS ZERO (PLUS (neg t) (pos t)) , inj₂ (inj₂ v) ]
         ⟷⟨ assocl3₊ ⟩
       •[ PLUS (PLUS ZERO (neg t)) (pos t) , inj₂ v ] □)
unite₊⇄ {neg• t v} =
  Bck (•[ PLUS (PLUS ZERO (pos t)) (neg t) , inj₂ v ]
         ⟷⟨ assocr3₊ ⟩
       •[ PLUS ZERO (PLUS (pos t) (neg t)) , inj₂ (inj₂ v) ]
         ⟷⟨ unite₊ ◎ swap2₊ ◎ uniti₊ ⟩
       •[ PLUS ZERO (PLUS (neg t) (pos t)) , inj₂ (inj₁ v) ]
         ⟷⟨ assocl2₊ ⟩
       •[ PLUS (PLUS ZERO (neg t)) (pos t) , inj₁ (inj₂ v) ] □)

uniti₊⇄ : {t : Uℤ•} → t ⇄ PLUS2ℤ• ZEROℤ t
uniti₊⇄ {pos• t v} =
  Fwd (•[ PLUS (pos t) (PLUS ZERO (neg t)) , inj₁ v ]
        ⟷⟨ assocl1₊ ⟩
       •[ PLUS (PLUS (pos t) ZERO) (neg t) , inj₁ (inj₁ v) ]
        ⟷⟨ swap1₊ ⟩
       •[ PLUS (neg t) (PLUS (pos t) ZERO) , inj₂ (inj₁ v) ]
        ⟷⟨ ⊕2 swap1₊ ⟩
       •[ PLUS (neg t) (PLUS ZERO (pos t)) , inj₂ (inj₂ v) ] □)
uniti₊⇄ {neg• t v} =
  Bck (•[ PLUS (pos t) (PLUS ZERO (neg t)) , inj₂ (inj₂ v) ]
        ⟷⟨ ⊕2 swap2₊ ⟩
       •[ PLUS (pos t) (PLUS (neg t) ZERO) , inj₂ (inj₁ v) ]
        ⟷⟨ swap2₊ ⟩
       •[ PLUS (PLUS (neg t) ZERO) (pos t) , inj₁ (inj₁ v) ]
        ⟷⟨ assocr1₊ ⟩
       •[ PLUS (neg t) (PLUS ZERO (pos t)) , inj₁ v ] □)

swap1₊⇄ : {t₁ : Uℤ•} {t₂ : Uℤ} → PLUS1ℤ• t₁ t₂ ⇄ PLUS2ℤ• t₂ t₁
swap1₊⇄ {pos• t₁ v₁} {t₂} =
  Fwd (•[ PLUS (PLUS (pos t₁) (pos t₂)) (PLUS (neg t₂) (neg t₁)) ,
          inj₁ (inj₁ v₁) ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (PLUS (neg t₁) (neg t₂)) (PLUS (pos t₂) (pos t₁)) ,
          inj₂ (inj₂ v₁) ] □)
swap1₊⇄ {neg• t₁ v₁} {t₂} =
  Bck (•[ PLUS (PLUS (pos t₁) (pos t₂)) (PLUS (neg t₂) (neg t₁)) ,
          inj₂ (inj₂ v₁) ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (PLUS (neg t₁) (neg t₂)) (PLUS (pos t₂) (pos t₁)) ,
          inj₁ (inj₁ v₁) ] □)

swap2₊⇄ : {t₁ : Uℤ} {t₂ : Uℤ•} → PLUS2ℤ• t₁ t₂ ⇄ PLUS1ℤ• t₂ t₁
swap2₊⇄ {t₁} {pos• t₂ v₂} =
  Fwd (•[ PLUS (PLUS (pos t₁) (pos t₂)) (PLUS (neg t₂) (neg t₁)) ,
          inj₁ (inj₂ v₂) ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (PLUS (neg t₁) (neg t₂)) (PLUS (pos t₂) (pos t₁)) ,
          inj₂ (inj₁ v₂) ] □)
swap2₊⇄ {t₁} {neg• t₂ v₂} =
  Bck (•[ PLUS (PLUS (pos t₁) (pos t₂)) (PLUS (neg t₂) (neg t₁)) ,
          inj₂ (inj₁ v₂) ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (PLUS (neg t₁) (neg t₂)) (PLUS (pos t₂) (pos t₁)) ,
          inj₁ (inj₂ v₂) ] □)

assocl1₊⇄ : {t₁ : Uℤ•} {t₂ t₃ : Uℤ} →
            PLUS1ℤ• t₁ (PLUSℤ t₂ t₃) ⇄ PLUS1ℤ• (PLUS1ℤ• t₁ t₂) t₃
assocl1₊⇄ {pos• t₁ v₁} {t₂} {t₃} =
  Fwd (•[ PLUS (PLUS (pos t₁) (pos (PLUSℤ t₂ t₃)))
               (PLUS (neg (PLUSℤ t₁ t₂)) (neg t₃)) ,
          inj₁ (inj₁ v₁) ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (PLUS (neg t₁) (neg (PLUSℤ t₂ t₃)))
               (PLUS (pos (PLUSℤ t₁ t₂)) (pos t₃)) ,
          inj₂ (inj₁ (inj₁ v₁)) ] □)
assocl1₊⇄ {neg• t₁ v₁} {t₂} {t₃} =
  Bck (•[ PLUS (PLUS (pos t₁) (pos (PLUSℤ t₂ t₃)))
               (PLUS (neg (PLUSℤ t₁ t₂)) (neg t₃)) ,
          inj₂ (inj₁ (inj₁ v₁)) ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (PLUS (neg t₁) (neg (PLUSℤ t₂ t₃)))
               (PLUS (pos (PLUSℤ t₁ t₂)) (pos t₃)) ,
          inj₁ (inj₁ v₁) ] □)

{--
  assocl2₊ : ∀ {t₁ t₂ t₃ v₂} →
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₁ v₂) ] ⟷
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ]
  assocl3₊ : ∀ {t₁ t₂ t₃ v₃} →
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₂ v₃) ] ⟷
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₂ v₃ ]
  assocr1₊ : ∀ {t₁ t₂ t₃ v₁} →
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₁ v₁) ] ⟷
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₁ v₁ ]
  assocr2₊ : ∀ {t₁ t₂ t₃ v₂} →
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₁ (inj₂ v₂) ] ⟷
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₁ v₂) ]
  assocr3₊ : ∀ {t₁ t₂ t₃ v₃} →
             •[ PLUS (PLUS t₁ t₂) t₃ , inj₂ v₃ ] ⟷
             •[ PLUS t₁ (PLUS t₂ t₃) , inj₂ (inj₂ v₃) ]
  unite⋆  : ∀ {t v} → •[ TIMES ONE t , (tt , v) ] ⟷ •[ t , v ]
  uniti⋆  : ∀ {t v} → •[ t , v ] ⟷ •[ TIMES ONE t , (tt , v) ]
  swap⋆   : ∀ {t₁ t₂ v₁ v₂} →
              •[ TIMES t₁ t₂ , (v₁ , v₂) ] ⟷ •[ TIMES t₂ t₁ , (v₂ , v₁) ]
  assocl⋆ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
            •[ TIMES t₁ (TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ] ⟷
            •[ TIMES (TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ]
  assocr⋆ : ∀ {t₁ t₂ t₃ v₁ v₂ v₃} →
            •[ TIMES (TIMES t₁ t₂) t₃ , ((v₁ , v₂) , v₃) ] ⟷
            •[ TIMES t₁ (TIMES t₂ t₃) , (v₁ , (v₂ , v₃)) ]
  distz : ∀ {t v absurd} →
            •[ TIMES ZERO t , (absurd , v) ] ⟷ •[ ZERO , absurd ]
  factorz : ∀ {t v absurd} →
            •[ ZERO , absurd ] ⟷ •[ TIMES ZERO t , (absurd , v) ]
  dist1   : ∀ {t₁ t₂ t₃ v₁ v₃} →
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ] ⟷
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₁ (v₁ , v₃) ]
  dist2   : ∀ {t₁ t₂ t₃ v₂ v₃} →
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ] ⟷
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₂ (v₂ , v₃) ]
  factor1   : ∀ {t₁ t₂ t₃ v₁ v₃} →
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₁ (v₁ , v₃) ] ⟷
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₁ v₁ , v₃) ]
  factor2   : ∀ {t₁ t₂ t₃ v₂ v₃} →
            •[ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) , inj₂ (v₂ , v₃) ] ⟷
            •[ TIMES (PLUS t₁ t₂) t₃ , (inj₂ v₂ , v₃) ]
--}

id⇄ : {t : Uℤ•} → t ⇄ t
id⇄ {pos• t p} = Fwd swap1₊
id⇄ {neg• t n} = Bck swap2₊

{--
_◎⇄_ : {t₁ t₂ t₃ : Uℤ•} → (t₁ ⇄ t₂) → (t₂ ⇄ t₃) → (t₁ ⇄ t₃)
_◎⇄_ {pos• t₁ v₁} {pos• t₂ v₂} {pos• t₃ v₃} (Fwd c₁) (Fwd c₂) =
  Fwd (•[ PLUS (pos t₁) (neg t₃) , inj₁ v₁ ]
        ⟷⟨ {!!} ⟩
       •[ PLUS (neg t₁) (pos t₃) , inj₂ v₃ ] □)
-- c₁ : •[ PLUS (pos t₁) (neg t₂) , inj₁ v₁ ] ⟷
--      •[ PLUS (neg t₁) (pos t₂) , inj₂ v₂ ]
-- c₂ : •[ PLUS (pos t₂) (neg t₃) , inj₁ v₂ ] ⟷
--      •[ PLUS (neg t₂) (pos t₃) , inj₂ v₃ ]
_◎⇄_ {pos• (t₁ - t₂) v₁} {pos• (t₃ - .t₃) v₃} {neg• (.t₃ - .t₃) .v₃}
     (Fwd c) F2B = {!!}
-- ?7 : pos• (t₁ - t₂) v₁ ⇄ neg• (t₃ - t₃) v₃
Bck c₁ ◎⇄ Bck c₂ = Bck {!!}
Bck c ◎⇄ B2F     = {!!}
B2F ◎⇄ Fwd c     = {!!}
B2F ◎⇄ F2B       = id⇄
F2B ◎⇄ Bck c     = {!!}
F2B ◎⇄ B2F       = id⇄
--}

{--
  _⊕1_   : ∀ {t₁ t₂ t₃ t₄ v₁ v₂ v₃ v₄} →
           (•[ t₁ , v₁ ] ⟷ •[ t₃ , v₃ ]) → (•[ t₂ , v₂ ] ⟷ •[ t₄ , v₄ ]) →
           (•[ PLUS t₁ t₂ , inj₁ v₁ ] ⟷ •[ PLUS t₃ t₄ , inj₁ v₃ ])
  _⊕2_   : ∀ {t₁ t₂ t₃ t₄ v₁ v₂ v₃ v₄} →
           (•[ t₁ , v₁ ] ⟷ •[ t₃ , v₃ ]) → (•[ t₂ , v₂ ] ⟷ •[ t₄ , v₄ ]) →
           (•[ PLUS t₁ t₂ , inj₂ v₂ ] ⟷ •[ PLUS t₃ t₄ , inj₂ v₄ ])
  _⊗_     : ∀ {t₁ t₂ t₃ t₄ v₁ v₂ v₃ v₄} →
           (•[ t₁ , v₁ ] ⟷ •[ t₃ , v₃ ]) → (•[ t₂ , v₂ ] ⟷ •[ t₄ , v₄ ]) →
          (•[ TIMES t₁ t₂ , (v₁ , v₂) ] ⟷ •[ TIMES t₃ t₄ , (v₃ , v₄) ])
--}

-- trace

η : ∀ {t v} → ZEROℤ+• {t} {v} ⇄ ZEROℤ-• {t} {v}
η = F2B

ε : ∀ {t v} → ZEROℤ-• {t} {v} ⇄ ZEROℤ+• {t} {v}
ε = B2F

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


------------------------------------------------------------------------
-- The Agda standard library
--
-- Which Maybe type which calls out to Haskell via the FFI
------------------------------------------------------------------------

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

module Foreign.Haskell.Maybe where

open import Level
open import Data.Maybe.Base as Data using (just; nothing)

private
  variable
    a : Level
    A : Set a

------------------------------------------------------------------------
-- Definition

data Maybe (A : Set a) : Set a where
  just    : A → Maybe A
  nothing : Maybe A

{-# FOREIGN GHC type AgdaMaybe l a = Maybe a #-}
{-# COMPILE GHC Maybe = data AgdaMaybe (Just | Nothing) #-}

------------------------------------------------------------------------
-- Conversion

toForeign : Data.Maybe A → Maybe A
toForeign (just x) = just x
toForeign nothing = nothing

fromForeign : Maybe A → Data.Maybe A
fromForeign (just x) = just x
fromForeign nothing = nothing


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

module Cubical.Algebra.Group.EilenbergMacLane1 where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.GroupoidLaws renaming (assoc to ∙assoc)
open import Cubical.Foundations.Path
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Data.Unit
open import Cubical.Data.Sigma
open import Cubical.Relation.Binary.Base
open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Nullification as Null hiding (rec; elim)
open import Cubical.HITs.Truncation.FromNegOne as Trunc renaming (rec to trRec; elim to trElim)
open import Cubical.HITs.EilenbergMacLane1

private
  variable ℓ : Level

module _ (G : Group {ℓ}) where

  open Group G

  emloop-id : emloop 0g ≡ refl
  emloop-id =
    -- emloop 0g ≡⟨ rUnit (emloop 0g) ⟩
    emloop 0g ≡⟨ rUnit (emloop 0g) ⟩
    emloop 0g ∙ refl ≡⟨ cong (emloop 0g ∙_) (rCancel (emloop 0g) ⁻¹) ⟩
    emloop 0g ∙ (emloop 0g ∙ (emloop 0g) ⁻¹) ≡⟨ ∙assoc _ _ _ ⟩
    (emloop 0g ∙ emloop 0g) ∙ (emloop 0g) ⁻¹ ≡⟨ cong (_∙ emloop 0g ⁻¹) ((emloop-comp G 0g 0g) ⁻¹) ⟩
    emloop (0g + 0g) ∙ (emloop 0g) ⁻¹ ≡⟨ cong (λ g → emloop {G = G} g ∙ (emloop 0g) ⁻¹)  (rid 0g) ⟩
    emloop 0g ∙ (emloop 0g) ⁻¹ ≡⟨ rCancel (emloop 0g) ⟩
    refl ∎

  emloop-inv : (g : Carrier) → emloop (- g) ≡ (emloop g) ⁻¹
  emloop-inv g =
    emloop (- g) ≡⟨ rUnit (emloop (- g)) ⟩
    emloop (- g) ∙ refl ≡⟨ cong (emloop (- g) ∙_) (rCancel (emloop g) ⁻¹) ⟩
    emloop (- g) ∙ (emloop g ∙ (emloop g) ⁻¹) ≡⟨ ∙assoc _ _ _ ⟩
    (emloop (- g) ∙ emloop g) ∙ (emloop g) ⁻¹ ≡⟨ cong (_∙ emloop g ⁻¹) ((emloop-comp G (- g) g) ⁻¹) ⟩
    emloop (- g + g) ∙ (emloop g) ⁻¹ ≡⟨ cong (λ h → emloop {G = G} h ∙ (emloop g) ⁻¹) (invl g) ⟩
    emloop 0g ∙ (emloop g) ⁻¹ ≡⟨ cong (_∙ (emloop g) ⁻¹) emloop-id ⟩
    refl ∙ (emloop g) ⁻¹ ≡⟨ (lUnit ((emloop g) ⁻¹)) ⁻¹ ⟩
    (emloop g) ⁻¹ ∎

  EM₁Groupoid : isGroupoid (EM₁ G)
  EM₁Groupoid = emsquash

  EM₁Connected : isConnected 2 (EM₁ G)
  EM₁Connected = ∣ embase ∣ , h
    where
      h : (y : hLevelTrunc 2 (EM₁ G)) → ∣ embase ∣ ≡ y
      h = trElim (λ y → isOfHLevelSuc 1 (isOfHLevelTrunc 2 ∣ embase ∣ y))
            (elimProp G (λ x → isOfHLevelTrunc 2 ∣ embase ∣ ∣ x ∣) refl)

  {- since we write composition in diagrammatic order,
     and function composition in the other order,
     we need right multiplication here -}
  rightEquiv : (g : Carrier) → Carrier ≃ Carrier
  rightEquiv g = isoToEquiv (iso (_+ g) (_+ - g)
    (λ h → (h + - g) + g ≡⟨ (assoc h (- g) g) ⁻¹ ⟩
             h + - g + g ≡⟨ cong (h +_) (invl g) ⟩
                  h + 0g ≡⟨ rid h ⟩ h ∎)
    λ h → (h + g) + - g ≡⟨ (assoc h g (- g)) ⁻¹ ⟩
            h + g + - g ≡⟨ cong (h +_) (invr g) ⟩
                 h + 0g ≡⟨ rid h ⟩ h ∎)

  compRightEquiv : (g h : Carrier)
    → compEquiv (rightEquiv g) (rightEquiv h) ≡ rightEquiv (g + h)
  compRightEquiv g h = equivEq _ _ (funExt (λ x → (assoc x g h) ⁻¹))

  CodesSet : EM₁ G → hSet ℓ
  CodesSet = rec G (isOfHLevelTypeOfHLevel 2) (Carrier , is-set) RE REComp
    where
      RE : (g : Carrier) → Path (hSet ℓ) (Carrier , is-set) (Carrier , is-set)
      RE g = Σ≡Prop (λ X → isPropIsOfHLevel {A = X} 2) (ua (rightEquiv g))

      lemma₁ : (g h : Carrier) → Square
        (ua (rightEquiv g)) (ua (rightEquiv (g + h)))
        refl (ua (rightEquiv h))
      lemma₁ g h = invEq
                   (Square≃doubleComp (ua (rightEquiv g)) (ua (rightEquiv (g + h)))
                     refl (ua (rightEquiv h)))
                   (ua (rightEquiv g) ∙ ua (rightEquiv h)
                       ≡⟨ (uaCompEquiv (rightEquiv g) (rightEquiv h)) ⁻¹ ⟩
                    ua (compEquiv (rightEquiv g) (rightEquiv h))
                       ≡⟨ cong ua (compRightEquiv g h) ⟩
                    ua (rightEquiv (g + h)) ∎)

      lemma₂ : {A₀₀ A₀₁ : hSet ℓ} (p₀₋ : A₀₀ ≡ A₀₁)
               {A₁₀ A₁₁ : hSet ℓ} (p₁₋ : A₁₀ ≡ A₁₁)
               (p₋₀ : A₀₀ ≡ A₁₀) (p₋₁ : A₀₁ ≡ A₁₁)
                 (s : Square (cong fst p₀₋) (cong fst p₁₋) (cong fst p₋₀) (cong fst p₋₁))
               → Square p₀₋ p₁₋ p₋₀ p₋₁
      fst (lemma₂ p₀₋ p₁₋ p₋₀ p₋₁ s i j) = s i j
      snd (lemma₂ p₀₋ p₁₋ p₋₀ p₋₁ s i j) =
        isSet→isSetDep (λ X → isProp→isSet (isPropIsOfHLevel {A = X} 2))
          (cong fst p₀₋) (cong fst p₁₋) (cong fst p₋₀) (cong fst p₋₁) s
          (cong snd p₀₋) (cong snd p₁₋) (cong snd p₋₀) (cong snd p₋₁) i j

      REComp : (g h : Carrier) → Square (RE g) (RE (g + h)) refl (RE h)
      REComp g h = lemma₂ (RE g) (RE (g + h)) refl (RE h) (lemma₁ g h)

  Codes : EM₁ G → Type ℓ
  Codes x = CodesSet x .fst

  encode : (x : EM₁ G) → embase ≡ x → Codes x
  encode x p = subst Codes p 0g

  decode : (x : EM₁ G) → Codes x → embase ≡ x
  decode = elimSet G (λ x → isOfHLevelΠ 2 (λ c → EM₁Groupoid (embase) x))
    emloop lem₂
    where
      module _ (g : Carrier) where
        lem₁ : (h : Carrier) → PathP (λ i → embase ≡ emloop g i) (emloop h) (emloop (h + g))
        lem₁ h = emcomp h g
        lem₂ : PathP (λ i → Codes (emloop g i) → embase ≡ emloop g i) emloop emloop
        lem₂ = ua→ {A₀ = Carrier} {A₁ = Carrier} {e = rightEquiv g} lem₁

  decode-encode : (x : EM₁ G) (p : embase ≡ x) → decode x (encode x p) ≡ p
  decode-encode x p = J (λ y q → decode y (encode y q) ≡ q)
    (emloop (transport refl 0g) ≡⟨ cong emloop (transportRefl 0g) ⟩
     emloop 0g ≡⟨ emloop-id ⟩ refl ∎) p

  encode-decode : (x : EM₁ G) (c : Codes x) → encode x (decode x c) ≡ c
  encode-decode = elimProp G (λ x → isOfHLevelΠ 1 (λ c → CodesSet x .snd _ _))
    λ g → encode embase (decode embase g) ≡⟨ refl ⟩
          encode embase (emloop g) ≡⟨ refl ⟩
          transport (ua (rightEquiv g)) 0g ≡⟨ uaβ (rightEquiv g) 0g ⟩
          0g + g ≡⟨ lid g ⟩
          g ∎

  ΩEM₁Iso : Iso (Path (EM₁ G) embase embase) Carrier
  Iso.fun ΩEM₁Iso = encode embase
  Iso.inv ΩEM₁Iso = emloop
  Iso.rightInv ΩEM₁Iso = encode-decode embase
  Iso.leftInv ΩEM₁Iso = decode-encode embase

  ΩEM₁≡ : (Path (EM₁ G) embase embase) ≡ Carrier
  ΩEM₁≡ = isoToPath ΩEM₁Iso


{-# OPTIONS --safe --cubical #-}

module Relation.Binary.Bool where

open import Prelude

-- record TotalOrder {e} (E : Type e) : Type e where
--   field
--     _≤?_ : E → E → Bool

--   _≤_ : E → E → Type


-- 2014-05-26 Andrea & Andreas
-- hasBadRigids (in pruning) should reduce term before checking.

open import Common.Equality

postulate
  Fence : Set → Set

id : ∀{a}{A : Set a}(x : A) → A
id x = x

test : let H : Set; H = _; M : Set → Set; M = _ in
       (A : Set) → H ≡ Fence (M (id A))
test A = refl

-- Expected output:
-- M remains unsolved,
-- but H is solved by pruning the argument of M!


module Sets.IterativeUSet where

open import Data renaming (Empty to EmptyType)
open import Functional
import      Lvl
import      Lvl.Decidable as Lvl
open import Structure.Setoid renaming (_≡_ to _≡ₛ_)
open import Syntax.Function
open import Type
open import Type.Dependent

private variable ℓ ℓₒ ℓₑ ℓ₁ ℓ₂ : Lvl.Level
private variable T Indexₗ Indexᵣ : Type{ℓ}
private variable a b c x y z : T

-- A model of constructive set theory with atoms/urelements (CZFU) by iterative sets.
-- The definition states that an instance of IUset is either an atom or a set.
-- An atom is an instance of the atoms/urelements.
-- A set is an instance of a set container which is a function from a type of indices (which depends on the set) to an IUset. The function should be interpreted as pointing to every element of the set, and the image of this function is how a single set is represented.
module _ (T : Type{ℓₒ}) ⦃ equiv : Equiv{ℓₑ}(T) ⦄ {ℓ} where
  data IUset : Type{Lvl.𝐒(ℓ) Lvl.⊔ ℓₒ}
  SetContainer : Type{Lvl.𝐒(ℓ) Lvl.⊔ ℓₒ}
  SetContainer = Σ(Type{ℓ}) (_→ᶠ IUset)
  data IUset where
    atom : T → IUset
    set  : SetContainer → IUset

module _ {T : Type{ℓₒ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ {ℓ} where
  pattern setc {Index} elem = set(intro Index elem)

  module SetContainer where
    -- The projection of the index type for a set container.
    Index : (SC : SetContainer(T){ℓ}) → Type.of(Σ.left SC)
    Index = Σ.left

    -- The projection of the elements' function for a set container.
    elem : (SC : SetContainer(T){ℓ}) → Type.of(Σ.right SC)
    elem = Σ.right

  -- The projection of the index type for an IUset's set container if it is a set.
  -- It is non-existant otherwise (modeled by the empty type with no inhabitants).
  Index : IUset(T){ℓ} → Type{ℓ}
  Index (atom x) = EmptyType
  Index (set SC) = SetContainer.Index SC

  -- The projection of the elements' function for an IUset's set container it if it a set.
  -- It is non-existant otherwise (modeled by the empty function which is interpreted as the empty set).
  elem : (A : IUset(T){ℓ}) → (Index(A) → IUset(T){ℓ})
  elem (atom _) ()
  elem (set SC) = SetContainer.elem SC

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  open import Functional
  open import Logic.Propositional
  open import Logic.Propositional.Theorems
  open import Logic.Predicate

  private variable SC SCₗ SCᵣ : SetContainer(T) ⦃ equiv ⦄ {ℓ}

  -- The predicate stating that an IUset is a set.
  data IsSet {ℓ} : IUset(T){ℓ} → Type{Lvl.of(T) Lvl.⊔ Lvl.𝐒(ℓ)} where
    intro : IsSet(set(SC))

  -- The predicate stating that an IUset is an atom.
  data IsAtom {ℓ} : IUset(T){ℓ} → Type{Lvl.of(T) Lvl.⊔ Lvl.𝐒(ℓ)} where
    intro : IsAtom(atom(x))

  data _≡_ {ℓ₁ ℓ₂} : IUset(T){ℓ₁} → IUset(T){ℓ₂} → Type{Lvl.𝐒(ℓ₁ Lvl.⊔ ℓ₂) Lvl.⊔ ℓₑ Lvl.⊔ Lvl.of(T)}
  data _⊆_ {ℓ₁ ℓ₂} : IUset(T){ℓ₁} → IUset(T){ℓ₂} → Type{Lvl.𝐒(ℓ₁ Lvl.⊔ ℓ₂) Lvl.⊔ ℓₑ Lvl.⊔ Lvl.of(T)}

  _⊇_ : IUset(T){ℓ₁} → IUset(T){ℓ₂} → Type
  A ⊇ B = B ⊆ A

  -- Equality is either equivalence on its atoms or by definition the antisymmetric property of the subset relation.
  data _≡_ where
    atom : (a ≡ₛ b) → (atom a ≡ atom b)
    set  : (set SCₗ ⊇ set SCᵣ) → (set SCₗ ⊆ set SCᵣ) → (set SCₗ ≡ set SCᵣ)

  -- Set membership is the existence of an index in the set that points to a set equal element to the element.
  -- Note: This is never satisfied for an atom on the right.
  data _∈_ {ℓ₁ ℓ₂} (x : IUset(T){ℓ₁}) : IUset(T){ℓ₂} → Type{Lvl.𝐒(ℓ₁ Lvl.⊔ ℓ₂) Lvl.⊔ ℓₑ Lvl.⊔ Lvl.of(T)} where
    set : ∃{Obj = SetContainer.Index(SC)} (i ↦ x ≡ SetContainer.elem(SC) i) → (x ∈ set SC)
  [∈]-proof : (x ∈ set SC) → ∃{Obj = SetContainer.Index(SC)} (i ↦ x ≡ SetContainer.elem(SC) i)
  [∈]-proof (set p) = p
  [∈]-index : (x ∈ set SC) → SetContainer.Index(SC)
  [∈]-index (set ([∃]-intro i)) = i
  [∈]-elem : (p : (x ∈ set SC)) → (x ≡ SetContainer.elem(SC) ([∈]-index p))
  [∈]-elem (set ([∃]-intro _ ⦃ p ⦄)) = p

  -- Set subset is a mapping between the indices such that they point to the same element in both sets.
  -- Note: This is never satisfied for an atom on the right.
  data _⊆_ where
    set : (map : SetContainer.Index(SCₗ) → SetContainer.Index(SCᵣ)) → (∀{i} → (SetContainer.elem(SCₗ) i ≡ SetContainer.elem(SCᵣ) (map i))) → (set SCₗ ⊆ set SCᵣ)
  [⊆]-map : (set SCₗ ⊆ set SCᵣ) → (SetContainer.Index(SCₗ) → SetContainer.Index(SCᵣ))
  [⊆]-map (set map _) = map
  [⊆]-proof : (p : (set SCₗ ⊆ set SCᵣ)) → (∀{i} → (SetContainer.elem(SCₗ) i ≡ SetContainer.elem(SCᵣ) ([⊆]-map p i)))
  [⊆]-proof (set _ p) = p

  -- The binary relation of non-membership.
  _∉_ : IUset(T){ℓ₁} → IUset(T){ℓ₂} → Type
  a ∉ B = ¬(a ∈ B)

  -- The predicate stating that an IUset contains no elements (in other words, is empty).
  Empty : ∀{ℓ₁ ℓ₂ : Lvl.Level} → IUset(T){ℓ₂} → Type
  Empty{ℓ₁}(A) = ∀{x : IUset(T){ℓ₁}} → (x ∉ A)

  open import Logic.Classical

  private variable A B C : IUset(T) ⦃ equiv ⦄ {ℓ}

  instance
    -- An IUset is exclusively either an atom or a set.
    atom-xor-set : IsAtom(A) ⊕ IsSet(A)
    atom-xor-set {A = atom _} = [⊕]-introₗ intro \()
    atom-xor-set {A = set  _} = [⊕]-introᵣ intro \()

  instance
    IsAtom-classical : Classical₁(IsAtom{ℓ})
    IsAtom-classical = classical-from-xorₗ

  instance
    IsSet-classical : Classical₁(IsSet{ℓ})
    IsSet-classical = classical-from-xorᵣ

  -- An IUset containing something is always a set.
  set-if-membership : (x ∈ A) → IsSet(A)
  set-if-membership (set _) = intro

  -- An IUset which is an atom is always "empty" when interpreted as a set.
  atom-is-empty : IsAtom(A) → Empty{ℓ}(A)
  atom-is-empty p = contrapositiveᵣ set-if-membership ([⊕]-not-left atom-xor-set p)

  open import Functional
  open import Structure.Relator.Equivalence
  open import Structure.Relator.Properties

  [≡]-reflexivity-raw : (A ≡ A)
  [⊆]-reflexivity-raw : (set SC ⊆ set SC)
  [⊇]-reflexivity-raw : (set SC ⊇ set SC)
  [⊇]-reflexivity-raw = [⊆]-reflexivity-raw

  {-# TERMINATING #-} -- TODO: Passed the termination checker before Agda 2.6.2-caeadac-dirty
  [≡]-reflexivity-raw {A = atom x} = atom(reflexivity(_≡ₛ_))
  [≡]-reflexivity-raw {A = set x}  = set [⊇]-reflexivity-raw [⊆]-reflexivity-raw

  [⊆]-reflexivity-raw {SC = SC} = set id \{i} → [≡]-reflexivity-raw {A = SetContainer.elem(SC)(i)}

  [≡]-transitivity-raw : (A ≡ B) → (B ≡ C) → (A ≡ C)
  [⊆]-transitivity-raw : (A ⊆ B) → (B ⊆ C) → (A ⊆ C)
  [⊇]-transitivity-raw : (A ⊇ B) → (B ⊇ C) → (A ⊇ C)
  [⊇]-transitivity-raw {A = A}{B = B}{C = C} ab bc = [⊆]-transitivity-raw {A = C}{B = B}{C = A} bc ab

  [≡]-transitivity-raw (atom ab)  (atom bc) = atom (transitivity(_≡ₛ_) ab bc)
  [≡]-transitivity-raw (set lab rab) (set lbc rbc) = set ([⊇]-transitivity-raw lab lbc) ([⊆]-transitivity-raw rab rbc)

  [⊆]-transitivity-raw (set {SCₗ = SC₁} {SCᵣ = SC₂} mapₗ pₗ) (set {SCᵣ = SC₃} mapᵣ pᵣ) = set (mapᵣ ∘ mapₗ) \{i} → [≡]-transitivity-raw {A = SetContainer.elem(SC₁) i}{B = SetContainer.elem(SC₂)(mapₗ i)} {C = SetContainer.elem(SC₃)(mapᵣ(mapₗ i))} pₗ pᵣ

  instance
    [≡]-reflexivity : Reflexivity(_≡_ {ℓ})
    [≡]-reflexivity = intro [≡]-reflexivity-raw
  instance
    [⊆]-reflexivity : Reflexivity{T = SetContainer(T){ℓ}} ((_⊆_) on₂ set)
    [⊆]-reflexivity = intro [⊆]-reflexivity-raw
  instance
    [⊇]-reflexivity : Reflexivity{T = SetContainer(T){ℓ}} ((_⊇_) on₂ set)
    [⊇]-reflexivity = intro [⊇]-reflexivity-raw
  instance
    [≡]-symmetry : Symmetry(_≡_ {ℓ})
    Symmetry.proof [≡]-symmetry (atom ab) = atom (symmetry(_≡ₛ_) ab)
    Symmetry.proof [≡]-symmetry (set l r) = set r l
  instance
    [⊆]-antisymmetry : Antisymmetry(_⊆_ {ℓ})(_≡_)
    Antisymmetry.proof [⊆]-antisymmetry l@(set _ _) r@(set _ _) = set r l
  instance
    [⊇]-antisymmetry : Antisymmetry(_⊇_ {ℓ})(_≡_)
    Antisymmetry.proof [⊇]-antisymmetry l@(set _ _) r@(set _ _) = set l r
  instance
    [≡]-transitivity : Transitivity(_≡_ {ℓ})
    [≡]-transitivity = intro [≡]-transitivity-raw
  instance
    [⊆]-transitivity : Transitivity(_⊆_ {ℓ})
    [⊆]-transitivity = intro [⊆]-transitivity-raw
  instance
    [⊇]-transitivity : Transitivity(_⊇_ {ℓ})
    [⊇]-transitivity = intro [⊇]-transitivity-raw
  instance
    [≡]-equivalence : Equivalence(_≡_ {ℓ})
    [≡]-equivalence = intro
  instance
    Iset-equiv : Equiv(IUset(T){ℓ})
    Equiv._≡_ Iset-equiv = _≡_
    Equiv.equivalence Iset-equiv = [≡]-equivalence

  [≡]-to-[⊆] : (set SCₗ ≡ set SCᵣ) → (set SCₗ ⊆ set SCᵣ)
  [≡]-to-[⊆] (set l r) = r

  [≡]-to-[⊇] : (set SCₗ ≡ set SCᵣ) → (set SCₗ ⊇ set SCᵣ)
  [≡]-to-[⊇] (set l r) = l

  [∈]-of-elem : ∀{A : IUset(T){ℓ}}{ia : Index(A)} → (elem(A)(ia) ∈ A)
  [∈]-of-elem {A = setc {Index} elem} {ia} = set ([∃]-intro ia ⦃ [≡]-reflexivity-raw ⦄)

  [⊆]-membership : ((_⊆_ on₂ set) SCₗ SCᵣ) ← (∀{x : IUset(T)} → (x ∈ set SCₗ) → (x ∈ set SCᵣ))
  [⊆]-membership {SCₗ = SCₗ} {SCᵣ = SCᵣ} proof = set
    (ia    ↦ [∃]-witness ([∈]-proof(proof {elem(set SCₗ)(ia)} ([∈]-of-elem {A = set SCₗ}))))
    (\{ia} → [∃]-proof   ([∈]-proof(proof {elem(set SCₗ)(ia)} ([∈]-of-elem {A = set SCₗ}))))

module Oper ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  open import Data renaming (Empty to EmptyType)
  open import Data.Boolean
  open import Data.Boolean.Stmt
  open import Data.Either as Either using (_‖_)
  open import Functional
  open import Logic
  open import Logic.Classical
  open import Type.Dependent
  open import Type.Dependent.Functions
  open import Type.Properties.Decidable
  open import Type.Properties.Decidable.Proofs
  open import Syntax.Function
  instance _ = classical-to-decidable

  -- TODO: Many of these operations are simply copy-pasted from Sets.IterativeSet with small modifications.

  -- The operation converting an IUset from a lower universe level to a higher universe level.
  IUset-level-up : let _ = ℓ₁ in IUset(T){ℓ₂} → IUset(T){ℓ₁ Lvl.⊔ ℓ₂}
  IUset-level-up          (atom x) = atom x
  IUset-level-up {ℓ₁}{ℓ₂} (setc {Index} elem) = setc {Lvl.Up{ℓ₁}{ℓ₂}(Index)} \{(Lvl.up i) → IUset-level-up{ℓ₁}{ℓ₂}(elem(i))}

  -- The empty set, consisting of no elements.
  -- Index is the empty type, which means that there are no objects pointing to elements in the set.
  ∅ : IUset(T){ℓ}
  ∅ = setc empty

  -- Lifts an unary operation on set containers to an unary operation on IUsets.
  set-operator₁ : (SetContainer(T){ℓ₁} → SetContainer(T){ℓ₂}) → (IUset(T){ℓ₁} → IUset(T){ℓ₂})
  set-operator₁ op (atom _) = ∅
  set-operator₁ op (set  A) = set (op A)

  -- Lifts a binary operation on set containers to a binary operation on IUsets.
  set-operator₂ : (SetContainer(T){ℓ} → SetContainer(T){ℓ} → SetContainer(T){ℓ}) → (IUset(T){ℓ} → IUset(T){ℓ} → IUset(T){ℓ})
  set-operator₂ op (atom _) (atom _) = ∅
  set-operator₂ op (atom _) (set  B) = set B
  set-operator₂ op (set  A) (atom _) = set A
  set-operator₂ op (set  A) (set  B) = set (op A B)

  -- Filters a set to only contain set elements.
  sets-of : IUset(T){ℓ} → IUset(T){ℓ}
  sets-of{ℓ} = set-operator₁(A ↦ intro (Σ(SetContainer.Index(A)) (ia ↦ Lvl.Convert(IsSet(SetContainer.elem(A)(ia))){ℓ})) \{(intro ia p) → SetContainer.elem(A)(ia)})

  -- Filters a set to only contain atomic elements.
  atoms-of : IUset(T){ℓ} → IUset(T){ℓ}
  atoms-of{ℓ} = set-operator₁(A ↦ intro (Σ(SetContainer.Index(A)) (ia ↦ Lvl.Convert(IsAtom(SetContainer.elem(A)(ia))){ℓ})) \{(intro ia p) → SetContainer.elem(A)(ia)})

  -- The singleton set, consisting of one element.
  -- Index is the unit type, which means that there are a single object pointing to a single element in the set.
  singleton : IUset(T){ℓ} → IUset(T){ℓ}
  singleton = setc{Index = Unit} ∘ const

  -- The pair set, consisting of two elements.
  -- Index is the boolean type, which means that there are two objects pointing to two elements in the set.
  pair : IUset(T){ℓ} → IUset(T){ℓ} → IUset(T){ℓ}
  pair A B = setc{Index = Lvl.Up(Bool)} ((if_then B else A) ∘ Lvl.Up.obj)

  -- The union operator.
  -- Index(A ∪ B) is the either type of two indices, which means that both objects from the A and the B index point to elements in the set.
  _∪_ : IUset(T){ℓ} → IUset(T){ℓ} → IUset(T){ℓ}
  A ∪ B = setc{Index = Index(A) ‖ Index(B)} (Either.map1 (elem(A)) (elem(B)))
  -- _∪_ = set-operator₂([ℰ]-map₂ Either.map1)

  -- The big union operator.
  -- Index(⋃ A) is the dependent sum type of an Index(A) and the index of the element this index points to.
  ⋃ : IUset(T){ℓ} → IUset(T){ℓ}
  ⋃ A = setc{Index = Σ(Index(A)) (ia ↦ Index(elem(A)(ia)))} (\{(intro ia i) → elem(elem(A)(ia))(i)})

  indexFilter : (A : IUset(T){ℓ}) → (Index(A) → Stmt{ℓ}) → IUset(T){ℓ}
  indexFilter A P = setc{Index = Σ(Index(A)) P} (elem(A) ∘ Σ.left)

  filter : (A : IUset(T){ℓ}) → (IUset(T){ℓ} → Stmt{ℓ}) → IUset(T){ℓ}
  filter{ℓ} A P = indexFilter A (P ∘ elem(A))

  indexFilterBool : (A : IUset(T){ℓ}) → (Index(A) → Bool) → IUset(T){ℓ}
  indexFilterBool A f = indexFilter A (Lvl.Up ∘ IsTrue ∘ f)

  filterBool : (A : IUset(T){ℓ}) → (IUset(T){ℓ} → Bool) → IUset(T){ℓ}
  filterBool A f = indexFilterBool A (f ∘ elem(A))

  map : (IUset(T){ℓ} → IUset(T){ℓ}) → (IUset(T){ℓ} → IUset(T){ℓ})
  map f(A) = setc{Index = Index(A)} (f ∘ elem(A))

  -- The power set operator.
  -- Index(℘(A)) is a function type. An instance of such a function represents a subset, and essentially maps every element in A to a boolean which is interpreted as "in the subset of not".
  -- Note: This only works properly in a classical setting. Trying to use indexFilter instead result in universe level problems.
  ℘ : IUset(T){ℓ} → IUset(T){ℓ}
  ℘(A) = setc{Index = Index(A) → Bool} (indexFilterBool A)

  -- The set of ordinal numbers of the first order.
  ω : IUset(T){ℓ}
  ω = setc{Index = Lvl.Up ℕ} (N ∘ Lvl.Up.obj) where
    open import Numeral.Natural
    N : ℕ → IUset(T){ℓ}
    N(𝟎)    = ∅
    N(𝐒(n)) = N(n) ∪ singleton(N(n))

  module Proofs where
    open import Data.Boolean
    open import Data.Tuple as Tuple using ()
    open import Logic.Propositional
    open import Logic.Predicate
    open import Structure.Function
    open import Structure.Relator.Properties

    instance
      atom-function : Function(atom{T = T}{ℓ})
      Function.congruence atom-function = atom

    {-instance
      set-function : Function(set{T = T}{ℓ})
      Function.congruence set-function = ?
    -}

    -- If there is an element in the empty set, then there exists an instance of the empty type by definition, and that is false by definition.
    ∅-membership : ∀{x : IUset(T){ℓ₁}} → (x ∉ ∅ {ℓ₂})
    ∅-membership (set())

    -- There is a bijection between (A ‖ B) and ∃{Lvl.Up Bool}(\{(Lvl.up 𝐹) → A ; (Lvl.up 𝑇) → B}).
    pair-membership : ∀{a b x : IUset(T){ℓ}} → (x ∈ pair a b) ↔ (x ≡ a)∨(x ≡ b)
    Tuple.left (pair-membership {x = x}) ([∨]-introₗ p) = set ([∃]-intro (Lvl.up 𝐹) ⦃ p ⦄)
    Tuple.left (pair-membership {x = x}) ([∨]-introᵣ p) = set ([∃]-intro (Lvl.up 𝑇) ⦃ p ⦄)
    Tuple.right pair-membership (set ([∃]-intro (Lvl.up 𝐹) ⦃ atom p ⦄)) = [∨]-introₗ (atom p)
    Tuple.right pair-membership (set ([∃]-intro (Lvl.up 𝑇) ⦃ atom p ⦄)) = [∨]-introᵣ (atom p)
    Tuple.right pair-membership (set ([∃]-intro (Lvl.up 𝐹) ⦃ set l r ⦄)) = [∨]-introₗ (set l r)
    Tuple.right pair-membership (set ([∃]-intro (Lvl.up 𝑇) ⦃ set l r ⦄)) = [∨]-introᵣ (set l r)

    -- There is a bijection between (A) and ∃{Unit}(\{<> → A}).
    singleton-membership : ∀{a x : IUset(T){ℓ}} → (x ∈ singleton(a)) ↔ (x ≡ a)
    Tuple.left singleton-membership xin = set ([∃]-intro <> ⦃ xin ⦄)
    Tuple.right singleton-membership (set ([∃]-intro _ ⦃ eq ⦄)) = eq

    [∪]-membership : ∀{A B x : IUset(T){ℓ}} → (x ∈ (A ∪ B)) ↔ (x ∈ A)∨(x ∈ B)
    Tuple.left [∪]-membership ([∨]-introₗ (set ([∃]-intro ia))) = set ([∃]-intro (Either.Left  ia))
    Tuple.left [∪]-membership ([∨]-introᵣ (set ([∃]-intro ib))) = set ([∃]-intro (Either.Right ib))
    Tuple.right ([∪]-membership {A = set x}) (set ([∃]-intro ([∨]-introₗ ia))) = [∨]-introₗ (set ([∃]-intro ia))
    {-# CATCHALL #-}
    Tuple.right ([∪]-membership {B = set x}) (set ([∃]-intro ([∨]-introᵣ ib))) = [∨]-introᵣ (set ([∃]-intro ib))

    [⊆]-with-elem : ∀{SCₗ SCᵣ : SetContainer(T){ℓ}} → (xy : set SCₗ ⊆ set SCᵣ) → ∀{ix} → (elem (set SCₗ) ix ≡ elem (set SCᵣ) ([⊆]-map xy ix))
    [⊆]-with-elem (set map proof) {ix} = proof{ix}

{-
    open import Lang.Inspect
    import      Relator.Equals as Equals
    import      Relator.Equals.Proofs.Equivalence as Equals
    [⋃]-membership : ∀{A x : IUset(T){ℓ}} → (x ∈ (⋃ A)) ↔ ∃(a ↦ (a ∈ A) ∧ (x ∈ a))
    Tuple.left ([⋃]-membership {A = A@(set _)}) ([∃]-intro a@(set _) ⦃ [∧]-intro aA xa ⦄) with elem A ([∈]-index aA) | [∈]-elem aA | inspect ⦃ Equals.[≡]-equiv ⦄ (elem A) ([∈]-index aA)
    ... | set _ | (set aA-mapₗ aA-mapᵣ) | intro pp = set ([∃]-intro (intro ([∈]-index aA) (Equals.[≡]-substitutionₗ pp {f = Index} ([⊆]-map aA-mapᵣ ([∈]-index xa)))) ⦃ [≡]-transitivity-raw ([∈]-elem xa) ([⊆]-with-elem ([≡]-to-[⊆] ([≡]-transitivity-raw ([∈]-elem aA) ([≡]-transitivity-raw (sub₂(Equals._≡_)(_≡_) pp) {!!}))) {[∈]-index xa}) ⦄)
    Tuple.right ([⋃]-membership {A = A@(atom _)}) (set ([∃]-intro (intro iA ia))) = {!!}
    ∃.witness (Tuple.right ([⋃]-membership {A = A@(set _)}) (set ([∃]-intro (intro iA ia)))) = elem(A) iA
    ∃.proof (Tuple.right ([⋃]-membership {A = A@(set _)}) (set ([∃]-intro (intro iA ia) ⦃ proof ⦄))) = [∧]-intro ([∈]-of-elem {A = A}) {!set([∃]-intro ia ⦃ proof ⦄)!}
-}

{-  Σ.left  (∃.witness (Tuple.left ([⋃]-membership {A = A} {x}) ([∃]-intro a ⦃ [∧]-intro ([∃]-intro iA) _ ⦄))) = iA
  Σ.right (∃.witness (Tuple.left ([⋃]-membership {A = A} {x}) ([∃]-intro a ⦃ [∧]-intro ([∃]-intro iA ⦃ aA ⦄) ([∃]-intro ia) ⦄))) = _⊆_.map (_≡_.right aA) ia

  ∃.proof (Tuple.left ([⋃]-membership {A = A} {x}) ([∃]-intro a ⦃ [∧]-intro ([∃]-intro iA ⦃ aA ⦄) ([∃]-intro ia ⦃ xa ⦄) ⦄)) = [≡]-transitivity-raw xa ([⊆]-with-elem (sub₂(_≡_)(_⊆_) aA) {ia})

  ∃.witness (Tuple.right ([⋃]-membership {A = A} {x}) ([∃]-intro (intro iA ia) ⦃ proof ⦄)) = elem(A)(iA)
  Tuple.left (∃.proof (Tuple.right ([⋃]-membership {A = A} {x}) ([∃]-intro (intro iA ia) ⦃ proof ⦄))) = [∈]-of-elem {A = A}
  ∃.witness (Tuple.right (∃.proof (Tuple.right ([⋃]-membership {A = A} {x}) ([∃]-intro (intro iA ia) ⦃ proof ⦄)))) = ia
  ∃.proof (Tuple.right (∃.proof (Tuple.right ([⋃]-membership {A = A} {x}) ([∃]-intro (intro iA ia) ⦃ proof ⦄)))) = proof
-}


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

module Experiment.Omniscience where

open import Level using () renaming (zero to lzero)
open import Data.Nat using (ℕ; zero; suc; _≤_; _+_)
open import Data.Nat.Properties using (≤-refl; +-identityʳ)
open import Data.Product using (Σ; _,_; proj₁; proj₂; ∃; _×_)
open import Data.Bool using (Bool; true; false; _∧_; not)
open import Data.Bool.Properties using (∧-assoc; ∧-idem)
open import Function.Base using (_$_)
open import Relation.Binary using (Rel)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; subst; sym; _≢_; cong; module ≡-Reasoning)

infix 5 _≤ᵇ_

_≤ᵇ_ : Bool → Bool → Bool
false ≤ᵇ false = true
true  ≤ᵇ false = false
false ≤ᵇ true  = true
true  ≤ᵇ true  = true

x≤ᵇtrue≡true : ∀ x → x ≤ᵇ true ≡ true
x≤ᵇtrue≡true false = refl
x≤ᵇtrue≡true true  = refl

Decrease : (ℕ → Bool) → Set
Decrease α = ∀ i → α (suc i) ≤ᵇ α i ≡ true

ℕ∞ : Set
ℕ∞ = Σ (ℕ → Bool) Decrease

-- less n i ≡ true <=> n > i
less : ℕ → ℕ → Bool
less zero    zero    = false
less zero    (suc n) = false
less (suc m) zero    = true
less (suc m) (suc n) = less m n

less-decrease : ∀ n → Decrease (less n)
less-decrease zero     zero   = refl
less-decrease zero    (suc i) = refl
less-decrease (suc n) zero    = x≤ᵇtrue≡true (less n 0)
less-decrease (suc n) (suc i) = less-decrease n i

toℕ∞ : ℕ → ℕ∞
toℕ∞ n = less n , less-decrease n

_≈C_ : Rel (ℕ → Bool) lzero
α ≈C β = ∀ i → α i ≡ β i

_≈_ : Rel ℕ∞ lzero
x ≈ y = proj₁ x ≈C proj₁ y

_#C_ : Rel (ℕ → Bool) lzero
α #C β = ∃ λ i → α i ≢ β i

_#_ : Rel ℕ∞ lzero
x # y = proj₁ x #C proj₁ y

-- retract
𝓇 : (ℕ → Bool) → (ℕ → Bool)
𝓇 α zero    = α 0
𝓇 α (suc n) = α (suc n) ∧ 𝓇 α n

𝓇-decrease : ∀ α → Decrease (𝓇 α)
𝓇-decrease α i = lemma (α (suc i)) (𝓇 α i)
  where
  lemma : ∀ x y → x ∧ y ≤ᵇ y ≡ true
  lemma false false = refl
  lemma false true  = refl
  lemma true  false = refl
  lemma true  true  = refl

𝓇-idem : ∀ α → 𝓇 (𝓇 α) ≈C 𝓇 α
𝓇-idem α zero    = refl
𝓇-idem α (suc i) = begin
  (α (suc i) ∧ 𝓇 α i) ∧ 𝓇 (𝓇 α) i
    ≡⟨ cong (λ v → (α (suc i) ∧ 𝓇 α i) ∧ v) $ 𝓇-idem α i ⟩
  (α (suc i) ∧ 𝓇 α i) ∧ 𝓇 α i
    ≡⟨ ∧-assoc (α (suc i)) (𝓇 α i) (𝓇 α i) ⟩
  α (suc i) ∧ (𝓇 α i ∧ 𝓇 α i)
    ≡⟨ cong (λ v → α (suc i) ∧ v) $ ∧-idem (𝓇 α i) ⟩
  α (suc i) ∧ 𝓇 α i ∎
  where open ≡-Reasoning

⟦_⟧ : ℕ∞ → (ℕ → Bool)
⟦_⟧ = proj₁

private
  contraposition-Bool : ∀ {x y z} → (x ≡ z → y ≡ z) → y ≡ not z → x ≡ not z
  contraposition-Bool {false} {false} {true} f e = refl
  contraposition-Bool {false} {true} {false} f e = (λ ()) $ f refl
  contraposition-Bool {true}  {false} {true} f e = (λ ()) $ f refl
  contraposition-Bool {true}  {true} {false} f e = refl

  ≤ᵇ-to-fun : ∀ {x y} → x ≤ᵇ y ≡ true → x ≡ true → y ≡ true
  ≤ᵇ-to-fun {true} {true} _ _ = refl

lemma-3-2-lemma : ∀ (x : ℕ∞) m n → ⟦ x ⟧ n ≡ false → ⟦ x ⟧ (m + n) ≡ false
lemma-3-2-lemma x@(α , d) zero    n αn≡false = αn≡false
lemma-3-2-lemma x@(α , d) (suc m) n αn≡false =
  contraposition-Bool (≤ᵇ-to-fun (d (m + n))) (lemma-3-2-lemma x m n αn≡false)

lemma-3-2 : ∀ (x : ℕ∞) n → ⟦ x ⟧ n ≡ false → ∃ λ k → k ≤ n × x ≈ toℕ∞ k
lemma-3-2 x@(α , d) zero    αn≡false = 0 , (≤-refl , f)
  where
  f : ∀ i → α i ≡ less 0 i
  f zero    = αn≡false
  f (suc i) = subst (λ v → α (suc v) ≡ false) (+-identityʳ i) $
                lemma-3-2-lemma x (suc i) 0 αn≡false
lemma-3-2 (α , d) (suc n) αn≡false = {!   !}

-- α i ≡ less 0 i


module Languages.ILL.TypeSyntax where

open import bool

open import Utils.HaskellTypes

{-# IMPORT Languages.ILL.TypeSyntax #-}

data Type : Set where
  TVar : String → Type
  Top : Type
  Imp : Type → Type → Type
  Tensor : Type → Type → Type
  Bang : Type → Type

{-# COMPILED_DATA Type Languages.ILL.TypeSyntax.Type
                       Languages.ILL.TypeSyntax.TVar
                       Languages.ILL.TypeSyntax.Top
                       Languages.ILL.TypeSyntax.Imp
                       Languages.ILL.TypeSyntax.Tensor
                       Languages.ILL.TypeSyntax.Bang #-}

_eq-type_ : Type → Type → 𝔹
(TVar _) eq-type (TVar _) = tt
Top eq-type Top = tt
(Imp A C) eq-type (Imp B D) = (A eq-type B) && (C eq-type D)
(Tensor A C) eq-type (Tensor B D) = (A eq-type B) && (C eq-type D)
(Bang A) eq-type (Bang B) = A eq-type B
_ eq-type _ = ff


-- Andreas, 2014-08-19, issue reported by zcarterc
-- {-# OPTIONS -v tc.meta.assign:10 -v tc.constr.findInScope:10 #-}
-- {-# OPTIONS -v tc.constr.findInScope:49 #-}
-- {-# OPTIONS --show-implicit #-}
module Issue1254 where

open import Agda.Primitive

record Inhabited {i : Level} (carrier : Set i) : Set i where
  field
    elem : carrier

open Inhabited {{...}}

record Wrap {i : Level} (carrier : Set i) : Set i where
  field
    wrap-inhabited : Inhabited carrier

instance
  wrap-as-inhabited : ∀ {i : Level} {carrier : Set i} → Wrap carrier → Inhabited carrier
  wrap-as-inhabited cat = Wrap.wrap-inhabited cat

postulate
  Nat : Set
  one : Nat

instance
  monoid-Nat : Wrap Nat
  monoid-Nat = record { wrap-inhabited = record { elem = one } }

-- This is what caused the crash.
op : Nat
op = elem


{-# OPTIONS --universe-polymorphism #-}
-- in a lot of cases we have a relation that is already reflexive and symmetric
-- and we want to make it symmetric
module Categories.Support.ZigZag where

open import Level
open import Relation.Binary
open import Relation.Binary.Construct.On using () renaming (isEquivalence to on-preserves-equivalence)

open import Categories.Support.Equivalence using () renaming (Setoid to ISetoid; module Setoid to ISetoid)

data Direction : Set where
  ↘ ↗ : Direction

rotate : Direction → Direction
rotate ↘ = ↗
rotate ↗ = ↘

data ZigZag′ {c ℓ₂} {Carrier : Set c} (_∼_ : Carrier -> Carrier -> Set ℓ₂) : (x y : Carrier) (begin end : Direction) → Set (c ⊔ ℓ₂) where
  zig : ∀ {x y z e} (first : x ∼ y) (rest : ZigZag′ _∼_ y z ↗ e) → ZigZag′ _∼_ x z ↘ e
  zag : ∀ {x y z e} (first : y ∼ x) (rest : ZigZag′ _∼_ y z ↘ e) → ZigZag′ _∼_ x z ↗ e
  slish : ∀ {x y} (last : x ∼ y) → ZigZag′ _∼_ x y ↘ ↘
  slash : ∀ {x y} (last : y ∼ x) → ZigZag′ _∼_ x y ↗ ↗

ZigZag : ∀ {c ℓ₁ ℓ₂} (Base : Preorder c ℓ₁ ℓ₂) → (x y : Preorder.Carrier Base) (begin end : Direction) → Set (c ⊔ ℓ₂)
ZigZag Base = ZigZag′ (Preorder._∼_ Base)

zz-sym′ : ∀ {c ℓ₁ ℓ₂} {Base : Preorder c ℓ₁ ℓ₂} {x y z begin middle end} → ZigZag Base y z middle end → ZigZag Base y x middle begin → ZigZag Base z x (rotate end) begin
zz-sym′ {Base = Base} (zig first rest) accum = zz-sym′ {Base = Base} rest (zag first accum)
zz-sym′ {Base = Base} (zag first rest) accum = zz-sym′ {Base = Base} rest (zig first accum)
zz-sym′ (slish last) accum = zag last accum
zz-sym′ (slash last) accum = zig last accum

zz-sym : ∀ {c ℓ₁ ℓ₂} {Base : Preorder c ℓ₁ ℓ₂} {x y begin end} → ZigZag Base x y begin end → ZigZag Base y x (rotate end) (rotate begin)
zz-sym {Base = Base} (zig first rest) = zz-sym′ {Base = Base} rest (slash first)
zz-sym {Base = Base} (zag first rest) = zz-sym′ {Base = Base} rest (slish first)
zz-sym (slish last) = slash last
zz-sym (slash last) = slish last

zz-trans : ∀ {c ℓ₁ ℓ₂} {Base : Preorder c ℓ₁ ℓ₂} {x y z begin end begin′ end′} → ZigZag Base x y begin end → ZigZag Base y z begin′ end′ → ZigZag Base x z begin end′
zz-trans {Base = Base} (zig first rest) yz = zig first (zz-trans {Base = Base} rest yz)
zz-trans {Base = Base} (zag first rest) yz = zag first (zz-trans {Base = Base} rest yz)
zz-trans {Base = Base} (slish last) (zig first rest) = zig (Preorder.trans Base last first) rest
zz-trans (slish last) (zag first rest) = zig last (zag first rest)
zz-trans {Base = Base} (slish last) (slish only) = slish (Preorder.trans Base last only)
zz-trans (slish last) (slash only) = zig last (slash only)
zz-trans (slash last) (zig first rest) = zag last (zig first rest)
zz-trans {Base = Base} (slash last) (zag first rest) = zag (Preorder.trans Base first last) rest
zz-trans (slash last) (slish only) = zag last (slish only)
zz-trans {Base = Base} (slash last) (slash only) = slash (Preorder.trans Base only last)

data Alternating′ {c ℓ₂} {Carrier : Set c} (_∼_ : Carrier -> Carrier -> Set ℓ₂) (x y : Carrier) : Set (c ⊔ ℓ₂) where
  disorient : ∀ {begin end} (zz : ZigZag′ _∼_ x y begin end) → Alternating′ _∼_ x y

Alternating : ∀ {c ℓ₁ ℓ₂} (Base : Preorder c ℓ₁ ℓ₂) → (x y : Preorder.Carrier Base) → Set (c ⊔ ℓ₂)
Alternating Base = Alternating′ (Preorder._∼_ Base)

is-equivalence : ∀ {c ℓ₁ ℓ₂} (Base : Preorder c ℓ₁ ℓ₂) → IsEquivalence (Alternating Base)
is-equivalence Base = record
  { refl = disorient (slash (Base.refl))
  ; sym = my-sym
  ; trans = my-trans
  }
  where
  module Base = Preorder Base
  my-sym : ∀ {i j} → Alternating Base i j → Alternating Base j i
  my-sym (disorient zz) = disorient (zz-sym {Base = Base} zz)
  my-trans : ∀ {i j k} → Alternating Base i j → Alternating Base j k → Alternating Base i k
  my-trans (disorient ij) (disorient jk) = disorient (zz-trans {Base = Base} ij jk)

setoid : ∀ {c ℓ₁ ℓ₂} (Base : Preorder c ℓ₁ ℓ₂) → Setoid c (c ⊔ ℓ₂)
setoid Base = record
  { Carrier = Preorder.Carrier Base
  ; _≈_ = Alternating Base
  ; isEquivalence = is-equivalence Base }

isetoid : ∀ {c ℓ₁ ℓ₂} (Base : Preorder c ℓ₁ ℓ₂) → ISetoid c (c ⊔ ℓ₂)
isetoid Base = record
  { Carrier = Preorder.Carrier Base
  ; _≈_ = Alternating Base
  ; isEquivalence = is-equivalence Base }

-- the main eliminators for Alternating -- they prove that any equivalence that
-- respects the base preorder also respects its Alternating completion.

locally-minimal : ∀ {c ℓ₁ ℓ₂ ℓ′} (Base : Preorder c ℓ₁ ℓ₂) {_≈_ : Rel (Preorder.Carrier Base) ℓ′} (≈-isEquivalence : IsEquivalence _≈_) → (Preorder._∼_ Base ⇒ _≈_) → (Alternating Base ⇒ _≈_)
locally-minimal Base {_≋_} isEq inj (disorient zz) = impl zz
  where
  open IsEquivalence isEq renaming (trans to _>trans>_)

  impl : ∀ {i j b e} → ZigZag Base i j b e → i ≋ j
  impl (zig first rest) = inj first >trans> impl rest
  impl (zag first rest) = sym (inj first) >trans> impl rest
  impl (slish last) = inj last
  impl (slash last) = sym (inj last)

minimal : ∀ {c ℓ₁ ℓ₂ c′ ℓ′} (Base : Preorder c ℓ₁ ℓ₂) (Dest : Setoid c′ ℓ′) (f : Preorder.Carrier Base → Setoid.Carrier Dest) → (Preorder._∼_ Base =[ f ]⇒ Setoid._≈_ Dest) → (Alternating Base =[ f ]⇒ Setoid._≈_ Dest)
minimal Base Dest f inj = locally-minimal Base (on-preserves-equivalence f (Setoid.isEquivalence Dest)) inj

.iminimal : ∀ {c ℓ₁ ℓ₂ c′ ℓ′} (Base : Preorder c ℓ₁ ℓ₂) (Dest : ISetoid c′ ℓ′) (f : Preorder.Carrier Base → ISetoid.Carrier Dest) → (Preorder._∼_ Base =[ f ]⇒ ISetoid._≈_ Dest) → (Alternating Base =[ f ]⇒ ISetoid._≈_ Dest)
iminimal Base Dest f inj = locally-minimal Base (on-preserves-equivalence f (ISetoid.isEquivalence Dest)) inj


module Optics.Prism where
open import Agda.Primitive using (Level; _⊔_; lsuc)
open import Data.Product using (_×_; _,_; ∃-syntax; Σ-syntax)
open import Data.Sum using (_⊎_; inj₁; inj₂; fromInj₂)
open import Data.Empty using (⊥-elim)
open import Function.Inverse using (_↔_; inverse)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; module ≡-Reasoning; cong; cong₂; sym)

open import Category.Functor.Arr
open import Category.Functor.Either
open import Category.Profunctor.Star
open import Category.Profunctor.Joker
open import Category.Choice
open import Optics

Prism : ∀ {l} (S T A B : Set l) → Set (lsuc l)
Prism = Optic ChoiceImp

module Prism {l} {S T A B : Set l} (prism : Prism S T A B) where
  matching : S → A ⊎ T
  matching = matchingOptic S T A B (starChoice eitherApplicative) prism
  put : B → T
  put = putOptic S T A B (jokerChoice arrFunctor) prism

record LawfulPrism {l} {S A : Set l} (prism' : Prism S S A A) : Set (lsuc l) where
  open Prism prism' public
  prism : Prism S S A A
  prism = prism'
  field
    matchingput : ∀ (a : A) → matching (put a) ≡ inj₁ a
    putmatching : ∀ (s : S) (a : A) → matching s ≡ inj₁ a → put a ≡ s
    matchingmatching : ∀ (s t : S) → matching s ≡ inj₂ t → matching t ≡ inj₂ s

  matchingWithWitness : (s : S) → (Σ[ a ∈ A ] matching s ≡ inj₁ a) ⊎ (Σ[ t ∈ S ] matching s ≡ inj₂ t)
  matchingWithWitness s with matching s
  ...                      | inj₁ a = inj₁ (a , refl)
  ...                      | inj₂ t = inj₂ (t , refl)

uninjed₁ : ∀ {l₁ l₂} {A : Set l₁} {B : Set l₂} {x x₁ : A} → inj₁ {l₁} {l₂} {A} {B} x ≡ inj₁ {l₁} {l₂} {A} {B} x₁ → x ≡ x₁
uninjed₁ refl = refl

uninjed₂ : ∀ {l₁ l₂} {A : Set l₁} {B : Set l₂} {x x₁ : B} → inj₂ {l₁} {l₂} {A} {B} x ≡ inj₂ {l₁} {l₂} {A} {B} x₁ → x ≡ x₁
uninjed₂ refl = refl

inj₁≢inj₂ : ∀ {l₁ l₂} {A : Set l₁} {B : Set l₂} {x : A} {x₁ : B} → inj₁ x ≢ inj₂ x₁
inj₁≢inj₂ ()

prismIso : ∀ {l} {S A : Set l} {prism : Prism S S A A} → (lawful : LawfulPrism prism) → S ↔ (A ⊎ ∃[ s ] ∃[ t ] (Prism.matching prism s ≡ inj₂ t))
prismIso {_} {S} {A} lawful = inverse to from from∘to to∘from
   where
     open LawfulPrism lawful
     to : S → A ⊎ ∃[ s ] ∃[ t ] (matching s ≡ inj₂ t)
     to s with matchingWithWitness s
     ...     | inj₁ (a , _)          = inj₁ a
     ...     | inj₂ (t , w)          = inj₂ (s , t , w)
     from : A ⊎ ∃[ s ] ∃[ t ] (matching s ≡ inj₂ t) → S
     from (inj₁ x) = put x
     from (inj₂ (s , t , matchs≡injt)) = s
     from∘to : (s : S) → from (to s) ≡ s
     from∘to s with matchingWithWitness s
     ...          | inj₁ (a , w) = putmatching s a w
     ...          | inj₂ (t , _) = refl
     congΣ : ∀ {l₁ l₂} {T : Set l₁} {cmp : Set l₂} (W : T → cmp) (x : cmp) (t t' : T) (w : x ≡ W t) (w' : x ≡ W t') → t ≡ t' → (t , w) ≡ (t' , w')
     congΣ _ _ _ _ refl refl refl = refl
     to∘from : (elem : A ⊎ ∃[ s ] ∃[ t ] (matching s ≡ inj₂ t)) → to (from elem) ≡ elem
     open ≡-Reasoning
     to∘from (inj₁ x) with matchingWithWitness (put x)
     ...                 | inj₁ ( x₁ , w ) = cong inj₁ (uninjed₁ (inj₁ x₁ ≡⟨ sym w ⟩ matching (put x) ≡⟨ matchingput x ⟩ inj₁ x ∎))
     ...                 | inj₂ ( x₁ , w ) = ⊥-elim (inj₁≢inj₂ (inj₁ x ≡⟨ sym (matchingput x) ⟩ matching (put x) ≡⟨ w ⟩ inj₂ x₁ ∎))
     to∘from (inj₂ (s , t , w)) with matchingWithWitness s
     ...                           | inj₂ (t₁ , w₁) = cong inj₂ (cong (s ,_) (congΣ (λ tᵢ → inj₂ tᵢ) (matching s) t₁ t w₁ w (uninjed₂ (inj₂ t₁ ≡⟨ sym w₁ ⟩ matching s ≡⟨ w ⟩ inj₂ t ∎))))
     ...                           | inj₁ (a  , w₁) = ⊥-elim (inj₁≢inj₂ (inj₁ a ≡⟨ sym w₁ ⟩ matching s ≡⟨ w ⟩ inj₂ t ∎))


module Implicits.Resolution.Infinite.Undecidable where

open import Prelude hiding (Bool; Dec)

open import Data.Fin.Substitution
open import Function.Equivalence using (_⇔_; equivalence)
open import Relation.Nullary.Decidable as DecM using ()
open import Relation.Nullary

open import Extensions.ListFirst
open import SystemF.Everything as F using ()

open import Implicits.Resolution.Ambiguous.Resolution as A
open import Implicits.Resolution.Deterministic.Resolution as D
open import Implicits.Resolution.Infinite.Resolution as I
open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Resolution.Ambiguous.Undecidable using () renaming (module Undecidable to AUndec)
open import Implicits.Resolution.Infinite.Expressiveness

private
  -- type of inhabitation problem decider
  ?:-dec : Set
  ?:-dec = ∀ {n ν} (Γ : F.Ctx ν n) (a : F.Type ν) → Dec (∃ λ t → Γ F.⊢ t ∈ a)

-- assuming that System F have an EBNF form
-- and assuming that System F type inhabitation is undecidable,
-- we prove that Infinite resolution is undecidable
module Undecidable
  (?:-undec : ¬ ?:-dec)
  (nf : ∀ {ν n} {Γ : F.Ctx ν n} {t a} → Γ F.⊢ t ∈ a → ∃ λ (t₂ : F.Term ν n) → Γ F.⊢ t₂ ⇑ a)
  where

  open Infinite⇔Ambiguous nf
  open AUndec ?:-undec using () renaming (undecidable to ⊢ᵣᵃ-undec; ⊢ᵣ-Dec to ⊢ᵣᵃ-Dec)

  -- type of decider for infinite resolution
  ⊢ᵣ-Dec : Set
  ⊢ᵣ-Dec = ∀ {ν} (Δ : ICtx ν) (a : Type ν) → Dec (Δ I.⊢ᵣ a)

  -- proof that such a decider would imply a decider for ambiguous resolution
  reduction : ⊢ᵣ-Dec → ⊢ᵣᵃ-Dec
  reduction f Δ x = DecM.map (equivalent Δ x) (f Δ x)

  -- completing the proof
  undecidable : ¬ ⊢ᵣ-Dec
  undecidable f =  ⊢ᵣᵃ-undec (reduction f)


module Data.Bin.Addition where

  open import Data.List using ([]; _∷_)
  open import Data.Bin using(addBits; addBitLists; addCarryToBitList)
  open import Relation.Binary.PropositionalEquality
  private
    module PropEq = Relation.Binary.PropositionalEquality
  open import Data.Fin using (zero; suc) renaming (toℕ to bitToℕ; _+_ to _+F_)
  open import Data.Fin.Properties using (_+′_)
  open import Data.Digit using (fromDigits)
  open import Data.Product
  import Data.Nat.Properties

  open import Data.Bin.Bijection using (fromℕ-bijection)

  module Solving where

   open Relation.Binary.PropositionalEquality

   open ≡-Reasoning
   open import Algebra
--   open Algebra.Structures
   open CommutativeSemiring Data.Nat.Properties.commutativeSemiring hiding (sym; refl)

   open Data.Product

   open Data.Nat.Properties.SemiringSolver

   lem : ∀ {a b c as bs b' c' r}
          → c' * 2 + b' ≡ c + a + b
          → r ≡ c' + (as + bs)
          → b' + r * 2 ≡ c + (a + as * 2 + (b + bs * 2))
   lem {a} {b} {c} {as} {bs} {b'} {c'} {r} eq1 eq2 =
     begin
      b' + r * 2
       ≡⟨ cong (λ x → b' + x * 2) eq2 ⟩
      b' + (c' + (as + bs))  * 2
       ≡⟨ cong (λ x → b' + x) (proj₂ distrib 2 c' (as + bs)) ⟩
      b' + (c' * 2 + (as + bs) * 2)
       ≡⟨ sym (+-assoc b' (c' * 2) ((as + bs) * 2)) ⟩
      b' + c' * 2 + (as + bs) * 2
       ≡⟨  +-cong (+-comm b' (c' * 2)) refl ⟩
      c' * 2 + b' + (as + bs) * 2
       ≡⟨  +-cong eq1 refl ⟩
      c + a + b + (as + bs) * 2
       ≡⟨ solve 5 (λ a b c as bs →
            c :+ a :+ b :+ (as :+ bs) :* con 2
         := c :+ (a :+ as :* con 2 :+ (b :+ bs :* con 2))
           ) refl a b c as bs ⟩
      c + (a + as * 2 + (b + bs * 2))
     ∎

  open import Data.Nat using () renaming (_+_ to _+_; _*_ to _*_)
  open Data.Bin using (toℕ; toBits)

  addBits-is-addition : ∀ {c a b} → bitToℕ (proj₁ (addBits c a b)) * 2 + bitToℕ (proj₂ (addBits c a b)) ≡ bitToℕ c + bitToℕ a + bitToℕ b
  -- Brute force!!! (LOL)
  addBits-is-addition {zero} {zero} {zero} = refl
  addBits-is-addition {zero} {zero} {suc zero} = refl
  addBits-is-addition {zero} {suc zero} {zero} = refl
  addBits-is-addition {zero} {suc zero} {suc zero} = refl
  addBits-is-addition {suc zero} {zero} {zero} = refl
  addBits-is-addition {suc zero} {zero} {suc zero} = refl
  addBits-is-addition {suc zero} {suc zero} {zero} = refl
  addBits-is-addition {suc zero} {suc zero} {suc zero} = refl
  addBits-is-addition {suc (suc ())}
  addBits-is-addition {_} {suc (suc ())}
  addBits-is-addition {_} {_} {suc (suc ())}

  addCarryToBitLists-is-addition : ∀ c b → fromDigits (addCarryToBitList c b) ≡ bitToℕ c + fromDigits b
  addCarryToBitLists-is-addition zero _ = refl
  addCarryToBitLists-is-addition (suc zero) [] = refl
  addCarryToBitLists-is-addition (suc zero) (zero ∷ t) = refl
  addCarryToBitLists-is-addition (suc zero) (suc zero ∷ t) = cong (λ x → x * 2) (addCarryToBitLists-is-addition (suc zero) t)
  addCarryToBitLists-is-addition (suc (suc ())) _
  addCarryToBitLists-is-addition _ ((suc (suc ())) ∷ _)

  open import Data.Nat.Properties using (isCommutativeSemiring)
  open import Algebra.Structures
     using (module IsCommutativeSemiring;
            module IsCommutativeMonoid)
  open IsCommutativeSemiring isCommutativeSemiring
     using (+-isCommutativeMonoid)
  open IsCommutativeMonoid +-isCommutativeMonoid using (identity; comm) renaming (∙-cong to +-cong)

  addBitLists-is-addition : ∀ c a b → fromDigits (addBitLists c a b) ≡ bitToℕ c + (fromDigits a + fromDigits b)
  addBitLists-is-addition c [] b = addCarryToBitLists-is-addition c b
  addBitLists-is-addition c (a ∷ as) [] = trans (addCarryToBitLists-is-addition c (a ∷ as)) (+-cong {bitToℕ c} refl (sym (proj₂ identity (fromDigits (a ∷ as)))))
  addBitLists-is-addition c (a ∷ as) (b ∷ bs) with addBits c a b | addBits-is-addition {c} {a} {b}
  ... | (c' , b') | abia with addBitLists c' as bs | addBitLists-is-addition c' as bs
  ... | r | ria = Solving.lem {bitToℕ a} {bitToℕ b} {bitToℕ c} {fromDigits as} {fromDigits bs} {bitToℕ b'} {bitToℕ c'} abia ria

  open import Function.Inverse using (Inverse)
  open import Function.Equality
  open import Data.Bin.BitListBijection using () renaming (toℕ⟶ to bits-to-ℕ)
  open import Data.Bin.Bijection using (Bits-inverse-Bin)

  simplify-fromBits-to-ℕ : ∀ a → toℕ (Data.Bin.fromBits a) ≡ bits-to-ℕ ⟨$⟩ a
  simplify-fromBits-to-ℕ a = Π.cong bits-to-ℕ (Inverse.left-inverse-of Bits-inverse-Bin a )

  +-is-addition : ∀ a b → toℕ (Data.Bin._+_ a b) ≡ toℕ a + toℕ b
  +-is-addition a b =
    trans
      (simplify-fromBits-to-ℕ (addBitLists zero (toBits a) (toBits b)))
      (addBitLists-is-addition zero as bs)
      where
    as = toBits a
    bs = toBits b

  import Algebra.Lifting
  open import Data.Nat using (ℕ)
  open import Data.Bin using (Bin; 0#)
  open import Algebra.Structures using (IsCommutativeMonoid)
  private module Lifting = Algebra.Lifting _ _ fromℕ-bijection

  is-commutativeMonoid : IsCommutativeMonoid _≡_ Data.Bin._+_ 0#
  is-commutativeMonoid = lift-isCommutativeMonoid 0 +-isCommutativeMonoid
   where
     open Lifting.WithOp₂ _+_ Data.Bin._+_ +-is-addition


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.SingleSubst {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Weakening using (id)
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Conversion
open import Definition.LogicalRelation.Substitution.Weakening

open import Tools.Embedding
open import Tools.Product
import Tools.PropositionalEquality as PE

-- Validity of substitution of single variable in types.
substS : ∀ {F G t Γ l} ([Γ] : ⊩ᵛ Γ)
         ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
         ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
         ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
       → Γ ⊩ᵛ⟨ l ⟩ G [ t ] / [Γ]
substS {F} {G} {t} [Γ] [F] [G] [t] {σ = σ} ⊢Δ [σ] =
  let Geq = substConsId G
      G[t] = proj₁ ([G] ⊢Δ ([σ] , (proj₁ ([t] ⊢Δ [σ]))))
      G[t]′ = irrelevance′ Geq G[t]
  in  G[t]′
  ,   (λ {σ′} [σ′] [σ≡σ′] →
         irrelevanceEq″ Geq
                         (substConsId G)
                         G[t] G[t]′
                         (proj₂ ([G] ⊢Δ
                                     ([σ] , proj₁ ([t] ⊢Δ [σ])))
                                     ([σ′] , proj₁ ([t] ⊢Δ [σ′]))
                                     (([σ≡σ′] , (proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′])))))

-- Validity of substitution of single variable in type equality.
substSEq : ∀ {F F′ G G′ t t′ Γ l} ([Γ] : ⊩ᵛ Γ)
           ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
           ([F′] : Γ ⊩ᵛ⟨ l ⟩ F′ / [Γ])
           ([F≡F′] : Γ ⊩ᵛ⟨ l ⟩ F ≡ F′ / [Γ] / [F])
           ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
           ([G′] : Γ ∙ F′ ⊩ᵛ⟨ l ⟩ G′ / ([Γ] ∙″ [F′]))
           ([G≡G′] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G ≡ G′ / [Γ] ∙″ [F] / [G])
           ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
           ([t′] : Γ ⊩ᵛ⟨ l ⟩ t′ ∷ F′ / [Γ] / [F′])
           ([t≡t′] : Γ ⊩ᵛ⟨ l ⟩ t ≡ t′ ∷ F / [Γ] / [F])
         → Γ ⊩ᵛ⟨ l ⟩ G [ t ] ≡ G′ [ t′ ] / [Γ]
                   / substS {F} {G} {t} [Γ] [F] [G] [t]
substSEq {F} {F′} {G} {G′} {t} {t′}
         [Γ] [F] [F′] [F≡F′] [G] [G′] [G≡G′] [t] [t′] [t≡t′] {σ = σ} ⊢Δ [σ] =
  let Geq = substConsId G
      G′eq = substConsId G′
      G[t] = (proj₁ ([G] ⊢Δ ([σ] , (proj₁ ([t] ⊢Δ [σ])))))
      G[t]′ = irrelevance′ Geq G[t]
      [t]′ = convᵛ {t} {F} {F′} [Γ] [F] [F′] [F≡F′] [t]
      G′[t] = (proj₁ ([G′] ⊢Δ ([σ] , proj₁ ([t]′ ⊢Δ [σ]))))
      G[t]≡G′[t] = irrelevanceEq′ Geq G[t] G[t]′
                                  ([G≡G′] ⊢Δ ([σ] , proj₁ ([t] ⊢Δ [σ])))
      G′[t]≡G′[t′] = irrelevanceEq″ PE.refl G′eq G′[t] G′[t]
                       (proj₂ ([G′] ⊢Δ ([σ] , proj₁ ([t]′ ⊢Δ [σ])))
                              ([σ] , proj₁ ([t′] ⊢Δ [σ]))
                              (reflSubst [Γ] ⊢Δ [σ] ,
                                convEqᵛ {t} {t′} {F} {F′}
                                        [Γ] [F] [F′] [F≡F′] [t≡t′] ⊢Δ [σ]))
      G′[t′] = (proj₁ ([G′] ⊢Δ ([σ] , proj₁ ([t′] ⊢Δ [σ]))))
      G′[t′]′ = irrelevance′ G′eq G′[t′]
  in  transEq G[t]′ G′[t] G′[t′]′ G[t]≡G′[t] G′[t]≡G′[t′]

-- Validity of substitution of single variable in terms.
substSTerm : ∀ {F G t f Γ l} ([Γ] : ⊩ᵛ Γ)
             ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
             ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
             ([f] : Γ ∙ F ⊩ᵛ⟨ l ⟩ f ∷ G / ([Γ] ∙″ [F]) / [G])
             ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
           → Γ ⊩ᵛ⟨ l ⟩ f [ t ] ∷ G [ t ] / [Γ]
                      / substS {F} {G} {t} [Γ] [F] [G] [t]
substSTerm {F} {G} {t} {f} [Γ] [F] [G] [f] [t] {σ = σ} ⊢Δ [σ] =
  let prfG = substConsId G
      prff = substConsId f
      G[t] = proj₁ ([G] ⊢Δ ([σ] , proj₁ ([t] ⊢Δ [σ])))
      G[t]′ = irrelevance′ prfG G[t]
      f[t] = proj₁ ([f] ⊢Δ ([σ] , proj₁ ([t] ⊢Δ [σ])))
      f[t]′ = irrelevanceTerm″ prfG prff G[t] G[t]′ f[t]
  in  f[t]′
  ,   (λ {σ′} [σ′] [σ≡σ′] →
         irrelevanceEqTerm″
           prff
           (substConsId f)
           prfG G[t] G[t]′
           (proj₂ ([f] ⊢Δ ([σ] , proj₁ ([t] ⊢Δ [σ])))
                  ([σ′] , proj₁ ([t] ⊢Δ [σ′]))
                  ([σ≡σ′] , proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′])))

-- Validity of substitution of single lifted variable in types.
subst↑S : ∀ {F G t Γ l} ([Γ] : ⊩ᵛ Γ)
          ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
          ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
          ([t] : Γ ∙ F ⊩ᵛ⟨ l ⟩ t ∷ wk1 F / ([Γ] ∙″ [F])
                              / wk1ᵛ {F} {F} [Γ] [F] [F])
        → Γ ∙ F ⊩ᵛ⟨ l ⟩ G [ t ]↑ / ([Γ] ∙″ [F])
subst↑S {F} {G} {t} [Γ] [F] [G] [t] {σ = σ} ⊢Δ [σ] =
  let [wk1F] = wk1ᵛ {F} {F} [Γ] [F] [F]
      [σwk1F] = proj₁ ([wk1F] {σ = σ} ⊢Δ [σ])
      [σwk1F]′ = proj₁ ([F] {σ = tail σ} ⊢Δ (proj₁ [σ]))
      [t]′ = irrelevanceTerm′ (subst-wk F) [σwk1F] [σwk1F]′ (proj₁ ([t] ⊢Δ [σ]))
      G[t] = proj₁ ([G] {σ = consSubst (tail σ) (subst σ t)} ⊢Δ
                               (proj₁ [σ] , [t]′))
      G[t]′ = irrelevance′ (substConsTailId {G} {t} {σ}) G[t]
  in  G[t]′
  ,   (λ {σ′} [σ′] [σ≡σ′] →
         let [σ′t] = irrelevanceTerm′ (subst-wk F)
                                      (proj₁ ([wk1F] {σ = σ′} ⊢Δ [σ′]))
                                      (proj₁ ([F] ⊢Δ (proj₁ [σ′])))
                                      (proj₁ ([t] ⊢Δ [σ′]))
             [σt≡σ′t] = irrelevanceEqTerm′ (subst-wk F) [σwk1F] [σwk1F]′
                                           (proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′])
             [σG[t]≡σ′G[t]] = proj₂ ([G] ⊢Δ (proj₁ [σ] , [t]′))
                                    (proj₁ [σ′] , [σ′t])
                                    (proj₁ [σ≡σ′] , [σt≡σ′t])
         in irrelevanceEq″ (substConsTailId {G} {t} {σ}) (substConsTailId {G} {t} {σ′})
                            G[t] G[t]′ [σG[t]≡σ′G[t]])

-- Validity of substitution of single lifted variable in type equality.
subst↑SEq : ∀ {F G G′ t t′ Γ l} ([Γ] : ⊩ᵛ Γ)
            ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
            ([G] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G / ([Γ] ∙″ [F]))
            ([G′] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G′ / ([Γ] ∙″ [F]))
            ([G≡G′] : Γ ∙ F ⊩ᵛ⟨ l ⟩ G ≡ G′ / [Γ] ∙″ [F] / [G])
            ([t] : Γ ∙ F ⊩ᵛ⟨ l ⟩ t ∷ wk1 F / [Γ] ∙″ [F]
                                / wk1ᵛ {F} {F} [Γ] [F] [F])
            ([t′] : Γ ∙ F ⊩ᵛ⟨ l ⟩ t′ ∷ wk1 F / [Γ] ∙″ [F]
                                 / wk1ᵛ {F} {F} [Γ] [F] [F])
            ([t≡t′] : Γ ∙ F ⊩ᵛ⟨ l ⟩ t ≡ t′ ∷ wk1 F / [Γ] ∙″ [F]
                                   / wk1ᵛ {F} {F} [Γ] [F] [F])
          → Γ ∙ F ⊩ᵛ⟨ l ⟩ G [ t ]↑ ≡ G′ [ t′ ]↑ / [Γ] ∙″ [F]
                        / subst↑S {F} {G} {t} [Γ] [F] [G] [t]
subst↑SEq {F} {G} {G′} {t} {t′}
          [Γ] [F] [G] [G′] [G≡G′] [t] [t′] [t≡t′] {σ = σ} ⊢Δ [σ] =
  let [wk1F] = wk1ᵛ {F} {F} [Γ] [F] [F]
      [σwk1F] = proj₁ ([wk1F] {σ = σ} ⊢Δ [σ])
      [σwk1F]′ = proj₁ ([F] {σ = tail σ} ⊢Δ (proj₁ [σ]))
      [t]′ = irrelevanceTerm′ (subst-wk F) [σwk1F] [σwk1F]′ (proj₁ ([t] ⊢Δ [σ]))
      [t′]′ = irrelevanceTerm′ (subst-wk F) [σwk1F] [σwk1F]′ (proj₁ ([t′] ⊢Δ [σ]))
      [t≡t′]′ = irrelevanceEqTerm′ (subst-wk F) [σwk1F] [σwk1F]′ ([t≡t′] ⊢Δ [σ])
      G[t] = proj₁ ([G] ⊢Δ (proj₁ [σ] , [t]′))
      G[t]′ = irrelevance′ (substConsTailId {G} {t} {σ}) G[t]
      G′[t] = proj₁ ([G′] ⊢Δ (proj₁ [σ] , [t]′))
      G′[t]′ = irrelevance′ (substConsTailId {G′} {t} {σ}) G′[t]
      G′[t′] = proj₁ ([G′] ⊢Δ (proj₁ [σ] , [t′]′))
      G′[t′]′ = irrelevance′ (substConsTailId {G′} {t′} {σ}) G′[t′]
      G[t]≡G′[t] = irrelevanceEq″ (substConsTailId {G} {t} {σ}) (substConsTailId {G′} {t} {σ})
                                   G[t] G[t]′ ([G≡G′] ⊢Δ (proj₁ [σ] , [t]′))
      G′[t]≡G′[t′] = irrelevanceEq″ (substConsTailId {G′} {t} {σ})
                                     (substConsTailId {G′} {t′} {σ})
                                     G′[t] G′[t]′
                                     (proj₂ ([G′] ⊢Δ (proj₁ [σ] , [t]′))
                                            (proj₁ [σ] , [t′]′)
                                            (reflSubst [Γ] ⊢Δ (proj₁ [σ]) , [t≡t′]′))
  in  transEq G[t]′ G′[t]′ G′[t′]′ G[t]≡G′[t] G′[t]≡G′[t′]

-- Helper function for reducible substitution of Π-types with specific typing derivations.
substSΠ₁′ : ∀ {F G t Γ l l′}
           ([ΠFG] : Γ ⊩⟨ l ⟩Π Π F ▹ G)
           ([F] : Γ ⊩⟨ l′ ⟩ F)
           ([t] : Γ ⊩⟨ l′ ⟩ t ∷ F / [F])
         → Γ ⊩⟨ l ⟩ G [ t ]
substSΠ₁′ {t = t} (noemb (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)) [F]₁ [t] =
  let F≡F′ , G≡G′ = Π-PE-injectivity (whnfRed* (red D) Πₙ)
      Feq = PE.trans F≡F′ (PE.sym (wk-id _))
      Geq = PE.cong (λ x → x [ _ ]) (PE.trans (wk-lift-id _) (PE.sym G≡G′))
      ⊢Γ = wf (escape [F]₁)
      [t]′ = irrelevanceTerm′ Feq [F]₁ ([F] id ⊢Γ) [t]
  in  irrelevance′ Geq ([G] id ⊢Γ [t]′)
substSΠ₁′ (emb 0<1 x) [F]₁ [t] = emb′ 0<1 (substSΠ₁′ x [F]₁ [t])

-- Reducible substitution of Π-types.
substSΠ₁ : ∀ {F G t Γ l l′}
           ([ΠFG] : Γ ⊩⟨ l ⟩ Π F ▹ G)
           ([F] : Γ ⊩⟨ l′ ⟩ F)
           ([t] : Γ ⊩⟨ l′ ⟩ t ∷ F / [F])
         → Γ ⊩⟨ l ⟩ G [ t ]
substSΠ₁ [ΠFG] [F] [t] = substSΠ₁′ (Π-elim [ΠFG]) [F] [t]

-- Helper function for reducible substitution of Π-congurence with specific typing derivations.
substSΠ₂′ : ∀ {F F′ G G′ t t′ Γ l l′ l″ l‴}
           ([ΠFG] : Γ ⊩⟨ l ⟩Π Π F ▹ G)
           ([ΠFG≡ΠF′G′] : Γ ⊩⟨ l ⟩ Π F ▹ G ≡ Π F′ ▹ G′ / Π-intr [ΠFG])
           ([F] : Γ ⊩⟨ l′ ⟩ F)
           ([F′] : Γ ⊩⟨ l′ ⟩ F′)
           ([t] : Γ ⊩⟨ l′ ⟩ t ∷ F / [F])
           ([t′] : Γ ⊩⟨ l′ ⟩ t′ ∷ F′ / [F′])
           ([t≡t′] : Γ ⊩⟨ l′ ⟩ t ≡ t′ ∷ F / [F])
           ([G[t]] : Γ ⊩⟨ l″ ⟩ G [ t ])
           ([G′[t′]] : Γ ⊩⟨ l‴ ⟩ G′ [ t′ ])
         → Γ ⊩⟨ l″ ⟩ G [ t ] ≡ G′ [ t′ ] / [G[t]]
substSΠ₂′ (noemb (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext))
          (Π₌ F″ G″ D′ A≡B [F≡F′] [G≡G′])
          [F]₁ [F′] [t] [t′] [t≡t′] [G[t]] [G′[t′]] =
  let F≡F′ , G≡G′ = Π-PE-injectivity (whnfRed* (red D) Πₙ)
      F′≡F″ , G′≡G″ = Π-PE-injectivity (whnfRed* D′ Πₙ)
      Feq = PE.trans F≡F′ (PE.sym (wk-id _))
      F′eq = PE.trans F′≡F″ (PE.sym (wk-id _))
      Geq = PE.cong (λ x → x [ _ ]) (PE.trans (wk-lift-id _) (PE.sym G≡G′))
      Geq′ = PE.cong (λ x → x [ _ ]) (PE.trans G′≡G″ (PE.sym (wk-lift-id _)))
      ⊢Γ = wf (escape [F]₁)
      [t]′ = irrelevanceTerm′ Feq [F]₁ ([F] id ⊢Γ) [t]
      [t′]′ = convTerm₂′ F′eq ([F] id ⊢Γ) [F′] ([F≡F′] id ⊢Γ) [t′]
      [t≡t′]′ = irrelevanceEqTerm′ Feq [F]₁ ([F] id ⊢Γ) [t≡t′]
      [Gt≡Gt′] = G-ext id ⊢Γ [t]′ [t′]′ [t≡t′]′
      [Gt′≡G′t′] = [G≡G′] id ⊢Γ [t′]′
  in  irrelevanceEq′ Geq ([G] id ⊢Γ [t]′) [G[t]]
        (transEq′ PE.refl Geq′ ([G] id ⊢Γ [t]′) ([G] id ⊢Γ [t′]′)
                  [G′[t′]] [Gt≡Gt′] [Gt′≡G′t′])
substSΠ₂′ (emb 0<1 x) (ιx y) = substSΠ₂′ x y

-- Reducible substitution of Π-congurence.
substSΠ₂ : ∀ {F F′ G G′ t t′ Γ l l′ l″ l‴}
           ([ΠFG] : Γ ⊩⟨ l ⟩ Π F ▹ G)
           ([ΠFG≡ΠF′G′] : Γ ⊩⟨ l ⟩ Π F ▹ G ≡ Π F′ ▹ G′ / [ΠFG])
           ([F] : Γ ⊩⟨ l′ ⟩ F)
           ([F′] : Γ ⊩⟨ l′ ⟩ F′)
           ([t] : Γ ⊩⟨ l′ ⟩ t ∷ F / [F])
           ([t′] : Γ ⊩⟨ l′ ⟩ t′ ∷ F′ / [F′])
           ([t≡t′] : Γ ⊩⟨ l′ ⟩ t ≡ t′ ∷ F / [F])
           ([G[t]] : Γ ⊩⟨ l″ ⟩ G [ t ])
           ([G′[t′]] : Γ ⊩⟨ l‴ ⟩ G′ [ t′ ])
         → Γ ⊩⟨ l″ ⟩ G [ t ] ≡ G′ [ t′ ] / [G[t]]
substSΠ₂ [ΠFG] [ΠFG≡ΠF′G′] =
  let [ΠFG≡ΠF′G′]′ = irrelevanceEq [ΠFG] (Π-intr (Π-elim [ΠFG])) [ΠFG≡ΠF′G′]
  in  substSΠ₂′ (Π-elim [ΠFG]) [ΠFG≡ΠF′G′]′

-- Valid substitution of Π-types.
substSΠ : ∀ {F G t Γ l}
          ([Γ] : ⊩ᵛ Γ)
          ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
          ([ΠFG] : Γ ⊩ᵛ⟨ l ⟩ Π F ▹ G / [Γ])
          ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
        → Γ ⊩ᵛ⟨ l ⟩ G [ t ] / [Γ]
substSΠ {F} {G} {t} [Γ] [F] [ΠFG] [t] ⊢Δ [σ] =
  let [σG[t]] = substSΠ₁ (proj₁ ([ΠFG] ⊢Δ [σ])) (proj₁ ([F] ⊢Δ [σ]))
                         (proj₁ ([t] ⊢Δ [σ]))
      [σG[t]]′ = irrelevance′ (PE.sym (singleSubstLift G t))
                          [σG[t]]
  in  [σG[t]]′
  ,   (λ [σ′] [σ≡σ′] →
         irrelevanceEq″ (PE.sym (singleSubstLift G t))
                         (PE.sym (singleSubstLift G t))
                         [σG[t]] [σG[t]]′
                         (substSΠ₂ (proj₁ ([ΠFG] ⊢Δ [σ]))
                                   (proj₂ ([ΠFG] ⊢Δ [σ]) [σ′] [σ≡σ′])
                                   (proj₁ ([F] ⊢Δ [σ])) (proj₁ ([F] ⊢Δ [σ′]))
                                   (proj₁ ([t] ⊢Δ [σ])) (proj₁ ([t] ⊢Δ [σ′]))
                                   (proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′]) [σG[t]]
                                   (substSΠ₁ (proj₁ ([ΠFG] ⊢Δ [σ′]))
                                             (proj₁ ([F] ⊢Δ [σ′]))
                                             (proj₁ ([t] ⊢Δ [σ′])))))

-- Valid substitution of Π-congurence.
substSΠEq : ∀ {F G F′ G′ t u Γ l}
            ([Γ] : ⊩ᵛ Γ)
            ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
            ([F′] : Γ ⊩ᵛ⟨ l ⟩ F′ / [Γ])
            ([ΠFG] : Γ ⊩ᵛ⟨ l ⟩ Π F ▹ G / [Γ])
            ([ΠF′G′] : Γ ⊩ᵛ⟨ l ⟩ Π F′ ▹ G′ / [Γ])
            ([ΠFG≡ΠF′G′] : Γ ⊩ᵛ⟨ l ⟩ Π F ▹ G ≡ Π F′ ▹ G′ / [Γ] / [ΠFG])
            ([t]   : Γ ⊩ᵛ⟨ l ⟩ t ∷ F / [Γ] / [F])
            ([u]   : Γ ⊩ᵛ⟨ l ⟩ u ∷ F′ / [Γ] / [F′])
            ([t≡u] : Γ ⊩ᵛ⟨ l ⟩ t ≡ u ∷ F / [Γ] / [F])
          → Γ ⊩ᵛ⟨ l ⟩ G [ t ] ≡ G′ [ u ] / [Γ]
                    / substSΠ {F} {G} {t} [Γ] [F] [ΠFG] [t]
substSΠEq {F} {G} {F′} {G′} {t} {u} [Γ] [F] [F′] [ΠFG] [ΠF′G′] [ΠFG≡ΠF′G′]
           [t] [u] [t≡u] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [σΠFG] = proj₁ ([ΠFG] ⊢Δ [σ])
      Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁ = extractMaybeEmbΠ (Π-elim [σΠFG])
      F≡F₁ , G≡G₁ = Π-PE-injectivity (whnfRed* (red D₁) Πₙ)
      [σΠF′G′] = proj₁ ([ΠF′G′] ⊢Δ [σ])
      Πᵣ F₂ G₂ D₂ ⊢F₂ ⊢G₂ A≡A₂ [F]₂ [G]₂ G-ext₂ = extractMaybeEmbΠ (Π-elim [σΠF′G′])
      F′≡F₂ , G′≡G₂ = Π-PE-injectivity (whnfRed* (red D₂) Πₙ)
      [σF] = proj₁ ([F] ⊢Δ [σ])
      [σF′] = proj₁ ([F′] ⊢Δ [σ])
      [σt] = proj₁ ([t] ⊢Δ [σ])
      [σu] = proj₁ ([u] ⊢Δ [σ])
      [σt]′ = irrelevanceTerm′ (PE.trans F≡F₁ (PE.sym (wk-id F₁)))
                               [σF] ([F]₁ id ⊢Δ) [σt]
      [σu]′ = irrelevanceTerm′ (PE.trans F′≡F₂ (PE.sym (wk-id F₂)))
                               [σF′] ([F]₂ id ⊢Δ) [σu]
      [σt≡σu] = [t≡u] ⊢Δ [σ]
      [G[t]] = irrelevance′ (PE.cong (λ x → x [ subst σ t ])
                                     (PE.trans (wk-lift-id G₁) (PE.sym G≡G₁)))
                            ([G]₁ id ⊢Δ [σt]′)
      [G′[u]] = irrelevance′ (PE.cong (λ x → x [ subst σ u ])
                                      (PE.trans (wk-lift-id G₂) (PE.sym G′≡G₂)))
                             ([G]₂ id ⊢Δ [σu]′)
  in  irrelevanceEq″ (PE.sym (singleSubstLift G t))
                      (PE.sym (singleSubstLift G′ u))
                      [G[t]]
                        (proj₁ (substSΠ {F} {G} {t} [Γ] [F] [ΠFG] [t] ⊢Δ [σ]))
                      (substSΠ₂ {subst σ F} {subst σ F′}
                                {subst (liftSubst σ) G}
                                {subst (liftSubst σ) G′}
                                (proj₁ ([ΠFG] ⊢Δ [σ]))
                                ([ΠFG≡ΠF′G′] ⊢Δ [σ])
                                [σF] [σF′] [σt] [σu] [σt≡σu] [G[t]] [G′[u]])


-- Andreas, 2019-09-13, AIM XXX, test for #4050 by gallais

-- Jesper, 2019-12-19, moved to test/Fail after unfix of #3823

record Wrap : Set₂ where
  field wrapped : Set₁

f : Wrap
f = record { M }
  module M where
    wrapped : Set₁
    wrapped = Set

-- Should be accepted.


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Maybe where

open import Cubical.Data.Maybe.Base public
open import Cubical.Data.Maybe.Properties public