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

module A where

open import Data.Nat
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product

infix  4  _≡_   -- propositional equality
infixr 10 _◎_
infixr 30 _⟷_

------------------------------------------------------------------------------
-- Our own version of refl that makes 'a' explicit

data _≡_ {ℓ} {A : Set ℓ} : (a b : A) → Set ℓ where
  refl : (a : A) → (a ≡ a)

sym : ∀ {ℓ} {A : Set ℓ} {a b : A} → (a ≡ b) → (b ≡ a)
sym {a = a} {b = .a} (refl .a) = refl a

{--

Just confirming that the following does not typecheck!

proof-irrelevance : {A : Set} {x y : A} (p q : x ≡ y) →  p ≡ q
proof-irrelevance (refl x) (refl .x) = refl (refl x)

--}

------------------------------------------------------------------------------
{--
Types are higher groupoids:
- 0 is empty
- 1 has one element and one path refl
- sum type is disjoint union; paths are component wise
- product type is cartesian product; paths are pairs of paths
--}

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

-- Points

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

BOOL : U
BOOL = PLUS ONE ONE

BOOL² : U
BOOL² = TIMES BOOL BOOL

TRUE : ⟦ BOOL ⟧
TRUE = inj₁ tt

FALSE : ⟦ BOOL ⟧
FALSE = inj₂ tt

NOT : ⟦ BOOL ⟧ → ⟦ BOOL ⟧
NOT (inj₁ tt) = FALSE
NOT (inj₂ tt) = TRUE

CNOT : ⟦ BOOL ⟧ → ⟦ BOOL ⟧ → ⟦ BOOL ⟧ × ⟦ BOOL ⟧
CNOT (inj₁ tt) b = (TRUE , NOT b)
CNOT (inj₂ tt) b = (FALSE , b)

------------------------------------------------------------------------------
-- Paths connect points in t₁ and t₂ if there is an isomorphism between the
-- types t₁ and t₂. The family ⟷ plays the role of identity types in HoTT

data _⟷_ : U → U → Set where
  unite₊  : {t : U} → PLUS ZERO t ⟷ t
  uniti₊  : {t : U} → t ⟷ PLUS ZERO t
  swap₊   : {t₁ t₂ : U} → PLUS t₁ t₂ ⟷ PLUS t₂ t₁
  assocl₊ : {t₁ t₂ t₃ : U} → PLUS t₁ (PLUS t₂ t₃) ⟷ PLUS (PLUS t₁ t₂) t₃
  assocr₊ : {t₁ t₂ t₃ : U} → PLUS (PLUS t₁ t₂) t₃ ⟷ PLUS t₁ (PLUS t₂ t₃)
  unite⋆  : {t : U} → TIMES ONE t ⟷ t
  uniti⋆  : {t : U} → t ⟷ TIMES ONE t
  swap⋆   : {t₁ t₂ : U} → TIMES t₁ t₂ ⟷ TIMES t₂ t₁
  assocl⋆ : {t₁ t₂ t₃ : U} → TIMES t₁ (TIMES t₂ t₃) ⟷ TIMES (TIMES t₁ t₂) t₃
  assocr⋆ : {t₁ t₂ t₃ : U} → TIMES (TIMES t₁ t₂) t₃ ⟷ TIMES t₁ (TIMES t₂ t₃)
  distz   : {t : U} → TIMES ZERO t ⟷ ZERO
  factorz : {t : U} → ZERO ⟷ TIMES ZERO t
  dist    : {t₁ t₂ t₃ : U} →
            TIMES (PLUS t₁ t₂) t₃ ⟷ PLUS (TIMES t₁ t₃) (TIMES t₂ t₃)
  factor  : {t₁ t₂ t₃ : U} →
            PLUS (TIMES t₁ t₃) (TIMES t₂ t₃) ⟷ TIMES (PLUS t₁ t₂) t₃
  id⟷    : {t : U} → t ⟷ t
  sym⟷   : {t₁ t₂ : U} → (t₁ ⟷ t₂) → (t₂ ⟷ t₁)
  _◎_     : {t₁ t₂ t₃ : U} → (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
  _⊕_     : {t₁ t₂ t₃ t₄ : U} →
            (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (PLUS t₁ t₂ ⟷ PLUS t₃ t₄)
  _⊗_     : {t₁ t₂ t₃ t₄ : U} →
            (t₁ ⟷ t₃) → (t₂ ⟷ t₄) → (TIMES t₁ t₂ ⟷ TIMES t₃ t₄)

cond : {t₁ t₂ : U} → (t₁ ⟷ t₂) → (t₁ ⟷ t₂) →
       ((TIMES BOOL t₁) ⟷ (TIMES BOOL t₂))
cond f g = dist ◎ ((id⟷ ⊗ f) ⊕ (id⟷ ⊗ g)) ◎ factor

controlled : {t : U} → (t ⟷ t) → ((TIMES BOOL t) ⟷ (TIMES BOOL t))
controlled f = cond f id⟷

cnot : BOOL² ⟷ BOOL²
cnot = controlled swap₊

-- Paths: each combinator defines a space of paths between its end points

mutual

  Paths : {t₁ t₂ : U} → (t₁ ⟷ t₂) → ⟦ t₁ ⟧ → ⟦ t₂ ⟧ → Set
  Paths unite₊ (inj₁ ())
  Paths unite₊ (inj₂ v) v' = (v ≡ v')
  Paths uniti₊ v (inj₁ ())
  Paths uniti₊ v (inj₂ v') = (v ≡ v')
  Paths swap₊ (inj₁ v) (inj₁ v') = ⊥
  Paths swap₊ (inj₁ v) (inj₂ v') = (v ≡ v')
  Paths swap₊ (inj₂ v) (inj₁ v') = (v ≡ v')
  Paths swap₊ (inj₂ v) (inj₂ v') = ⊥
  Paths assocl₊ (inj₁ v) (inj₁ (inj₁ v')) = (v ≡ v')
  Paths assocl₊ (inj₁ v) (inj₁ (inj₂ v')) = ⊥
  Paths assocl₊ (inj₁ v) (inj₂ v') = ⊥
  Paths assocl₊ (inj₂ (inj₁ v)) (inj₁ (inj₁ v')) = ⊥
  Paths assocl₊ (inj₂ (inj₁ v)) (inj₁ (inj₂ v')) = (v ≡ v')
  Paths assocl₊ (inj₂ (inj₁ v)) (inj₂ v') = ⊥
  Paths assocl₊ (inj₂ (inj₂ v)) (inj₁ v') = ⊥
  Paths assocl₊ (inj₂ (inj₂ v)) (inj₂ v') = (v ≡ v')
  Paths assocr₊ (inj₁ (inj₁ v)) (inj₁ v') = (v ≡ v')
  Paths assocr₊ (inj₁ (inj₁ v)) (inj₂ v') = ⊥
  Paths assocr₊ (inj₁ (inj₂ v)) (inj₁ v') = ⊥
  Paths assocr₊ (inj₁ (inj₂ v)) (inj₂ (inj₁ v')) = (v ≡ v')
  Paths assocr₊ (inj₁ (inj₂ v)) (inj₂ (inj₂ v')) = ⊥
  Paths assocr₊ (inj₂ v) (inj₁ v') = ⊥
  Paths assocr₊ (inj₂ v) (inj₂ (inj₁ v')) = ⊥
  Paths assocr₊ (inj₂ v) (inj₂ (inj₂ v')) = (v ≡ v')
  Paths unite⋆ (tt , v) v' = (v ≡ v')
  Paths uniti⋆ v (tt , v') = (v ≡ v')
  Paths swap⋆ (v₁ , v₂) (v₂' , v₁') = (v₁ ≡ v₁') × (v₂ ≡ v₂')
  Paths assocl⋆ (v₁ , (v₂ , v₃)) ((v₁' , v₂') , v₃') =
    (v₁ ≡ v₁') × (v₂ ≡ v₂') × (v₃ ≡ v₃')
  Paths assocr⋆ ((v₁ , v₂) , v₃) (v₁' , (v₂' , v₃')) =
    (v₁ ≡ v₁') × (v₂ ≡ v₂') × (v₃ ≡ v₃')
  Paths distz (() , v)
  Paths factorz ()
  Paths dist (inj₁ v₁ , v₃) (inj₁ (v₁' , v₃')) = (v₁ ≡ v₁') × (v₃ ≡ v₃')
  Paths dist (inj₁ v₁ , v₃) (inj₂ (v₂' , v₃')) = ⊥
  Paths dist (inj₂ v₂ , v₃) (inj₁ (v₁' , v₃')) = ⊥
  Paths dist (inj₂ v₂ , v₃) (inj₂ (v₂' , v₃')) = (v₂ ≡ v₂') × (v₃ ≡ v₃')
  Paths factor (inj₁ (v₁ , v₃)) (inj₁ v₁' , v₃') =
    (v₁ ≡ v₁') × (v₃ ≡ v₃')
  Paths factor (inj₁ (v₁ , v₃)) (inj₂ v₂' , v₃') = ⊥
  Paths factor (inj₂ (v₂ , v₃)) (inj₁ v₁' , v₃') = ⊥
  Paths factor (inj₂ (v₂ , v₃)) (inj₂ v₂' , v₃') =
    (v₂ ≡ v₂') × (v₃ ≡ v₃')
  Paths {t} id⟷ v v' = (v ≡ v')
  Paths (sym⟷ c) v v' = PathsB c v v'
  Paths (_◎_ {t₁} {t₂} {t₃} c₁ c₂) v v' =
    Σ[ u ∈ ⟦ t₂ ⟧ ] (Paths c₁ v u × Paths c₂ u v')
  Paths (c₁ ⊕ c₂) (inj₁ v) (inj₁ v') = Paths c₁ v v'
  Paths (c₁ ⊕ c₂) (inj₁ v) (inj₂ v') = ⊥
  Paths (c₁ ⊕ c₂) (inj₂ v) (inj₁ v') = ⊥
  Paths (c₁ ⊕ c₂) (inj₂ v) (inj₂ v') = Paths c₂ v v'
  Paths (c₁ ⊗ c₂) (v₁ , v₂) (v₁' , v₂') =
    Paths c₁ v₁ v₁' × Paths c₂ v₂ v₂'

  PathsB : {t₁ t₂ : U} → (t₁ ⟷ t₂) → ⟦ t₂ ⟧ → ⟦ t₁ ⟧ → Set
  PathsB unite₊ v (inj₁ ())
  PathsB unite₊ v (inj₂ v') = (v ≡ v')
  PathsB uniti₊ (inj₁ ())
  PathsB uniti₊ (inj₂ v) v' = (v ≡ v')
  PathsB swap₊ (inj₁ v) (inj₁ v') = ⊥
  PathsB swap₊ (inj₁ v) (inj₂ v') = (v ≡ v')
  PathsB swap₊ (inj₂ v) (inj₁ v') = (v ≡ v')
  PathsB swap₊ (inj₂ v) (inj₂ v') = ⊥
  PathsB assocl₊ (inj₁ (inj₁ v)) (inj₁ v') = (v ≡ v')
  PathsB assocl₊ (inj₁ (inj₁ v)) (inj₂ v') = ⊥
  PathsB assocl₊ (inj₁ (inj₂ v)) (inj₁ v') = ⊥
  PathsB assocl₊ (inj₁ (inj₂ v)) (inj₂ (inj₁ v')) = (v ≡ v')
  PathsB assocl₊ (inj₁ (inj₂ v)) (inj₂ (inj₂ v')) = ⊥
  PathsB assocl₊ (inj₂ v) (inj₁ v') = ⊥
  PathsB assocl₊ (inj₂ v) (inj₂ (inj₁ v')) = ⊥
  PathsB assocl₊ (inj₂ v) (inj₂ (inj₂ v')) = (v ≡ v')
  PathsB assocr₊ (inj₁ v) (inj₁ (inj₁ v')) = (v ≡ v')
  PathsB assocr₊ (inj₁ v) (inj₁ (inj₂ v')) = ⊥
  PathsB assocr₊ (inj₁ v) (inj₂ v') = ⊥
  PathsB assocr₊ (inj₂ (inj₁ v)) (inj₁ (inj₁ v')) = ⊥
  PathsB assocr₊ (inj₂ (inj₁ v)) (inj₁ (inj₂ v')) = (v ≡ v')
  PathsB assocr₊ (inj₂ (inj₁ v)) (inj₂ v') = ⊥
  PathsB assocr₊ (inj₂ (inj₂ v)) (inj₁ v') = ⊥
  PathsB assocr₊ (inj₂ (inj₂ v)) (inj₂ v') = (v ≡ v')
  PathsB unite⋆ v (tt , v') = (v ≡ v')
  PathsB uniti⋆ (tt , v) v' = (v ≡ v')
  PathsB swap⋆ (v₁ , v₂) (v₂' , v₁') = (v₁ ≡ v₁') × (v₂ ≡ v₂')
  PathsB assocl⋆ ((v₁ , v₂) , v₃) (v₁' , (v₂' , v₃')) =
    (v₁ ≡ v₁') × (v₂ ≡ v₂') × (v₃ ≡ v₃')
  PathsB assocr⋆ (v₁ , (v₂ , v₃)) ((v₁' , v₂') , v₃') =
    (v₁ ≡ v₁') × (v₂ ≡ v₂') × (v₃ ≡ v₃')
  PathsB distz ()
  PathsB factorz (() , v)
  PathsB dist (inj₁ (v₁ , v₃)) (inj₁ v₁' , v₃') =
    (v₁ ≡ v₁') × (v₃ ≡ v₃')
  PathsB dist (inj₁ (v₁ , v₃)) (inj₂ v₂' , v₃') = ⊥
  PathsB dist (inj₂ (v₂ , v₃)) (inj₁ v₁' , v₃') = ⊥
  PathsB dist (inj₂ (v₂ , v₃)) (inj₂ v₂' , v₃') =
    (v₂ ≡ v₂') × (v₃ ≡ v₃')
  PathsB factor (inj₁ v₁ , v₃) (inj₁ (v₁' , v₃')) =
    (v₁ ≡ v₁') × (v₃ ≡ v₃')
  PathsB factor (inj₁ v₁ , v₃) (inj₂ (v₂' , v₃')) = ⊥
  PathsB factor (inj₂ v₂ , v₃) (inj₁ (v₁' , v₃')) = ⊥
  PathsB factor (inj₂ v₂ , v₃) (inj₂ (v₂' , v₃')) =
    (v₂ ≡ v₂') × (v₃ ≡ v₃')
  PathsB {t} id⟷ v v' = (v ≡ v')
  PathsB (sym⟷ c) v v' = Paths c v v'
  PathsB (_◎_ {t₁} {t₂} {t₃} c₁ c₂) v v' =
    Σ[ u ∈ ⟦ t₂ ⟧ ] (PathsB c₂ v u × PathsB c₁ u v')
  PathsB (c₁ ⊕ c₂) (inj₁ v) (inj₁ v') = PathsB c₁ v v'
  PathsB (c₁ ⊕ c₂) (inj₁ v) (inj₂ v') = ⊥
  PathsB (c₁ ⊕ c₂) (inj₂ v) (inj₁ v') = ⊥
  PathsB (c₁ ⊕ c₂) (inj₂ v) (inj₂ v') = PathsB c₂ v v'
  PathsB (c₁ ⊗ c₂) (v₁ , v₂) (v₁' , v₂') =
    PathsB c₁ v₁ v₁' × PathsB c₂ v₂ v₂'

-- Given a combinator c : t₁ ⟷ t₂ and values v₁ : ⟦ t₁ ⟧ and v₂ : ⟦ t₂ ⟧,
-- Paths c v₁ v₂ gives us the space of paths that could connect v₁ and v₂
-- Examples:

pathIdtt : Paths id⟷ tt tt
pathIdtt = refl tt

-- four different ways of relating F to F:

pathIdFF : Paths id⟷ FALSE FALSE
pathIdFF = refl FALSE

pathIdIdFF : Paths (id⟷ ◎ id⟷) FALSE FALSE
pathIdIdFF = (FALSE , refl FALSE , refl FALSE)

pathNotNotFF : Paths (swap₊ ◎ swap₊) FALSE FALSE
pathNotNotFF = TRUE , refl tt , refl tt

pathPlusFF : Paths (id⟷ ⊕ id⟷) FALSE FALSE
pathPlusFF = refl tt

-- are there 2-paths between the above 3 paths???

-- space of paths is empty; cannot produce any path; can
-- use pattern matching to confirm that the space is empty
pathIdFT : Paths id⟷ FALSE TRUE → ⊤
pathIdFT ()

-- three different ways of relating (F,F) to (F,F)

pathIdFFFF : Paths id⟷ (FALSE , FALSE) (FALSE , FALSE)
pathIdFFFF = refl (FALSE , FALSE)

pathTimesFFFF : Paths (id⟷ ⊗ id⟷) (FALSE , FALSE) (FALSE , FALSE)
pathTimesFFFF = (refl FALSE , refl FALSE)

pathTimesPlusFFFF : Paths
                      ((id⟷ ⊕ id⟷) ⊗ (id⟷ ⊕ id⟷))
                      (FALSE , FALSE) (FALSE , FALSE)
pathTimesPlusFFFF = (refl tt , refl tt)

pathSwap₊FT : Paths swap₊ FALSE TRUE
pathSwap₊FT = refl tt

pathSwap₊TF : Paths swap₊ TRUE FALSE
pathSwap₊TF = refl tt

-- no path
pathSwap₊FF : Paths swap₊ FALSE FALSE → ⊤
pathSwap₊FF ()

-- intuitively the two paths below should not be related by a 2-path because
-- pathCnotTF is "essentially" cnot which would map (F,F) to (F,F) but
-- pathIdNotTF would map (F,F) to (F,T).

pathIdNotFF : Paths (id⟷ ⊗ swap₊) (FALSE , FALSE) (FALSE , TRUE)
pathIdNotFF = refl FALSE , refl tt

pathIdNotFT : Paths (id⟷ ⊗ swap₊) (FALSE , TRUE) (FALSE , FALSE)
pathIdNotFT = refl FALSE , refl tt

pathIdNotTF : Paths (id⟷ ⊗ swap₊) (TRUE , FALSE) (TRUE , TRUE)
pathIdNotTF = refl TRUE , refl tt

pathIdNotTT : Paths (id⟷ ⊗ swap₊) (TRUE , TRUE) (TRUE , FALSE)
pathIdNotTT = refl TRUE , refl tt

pathIdNotb : {b₁ b₂ : ⟦ BOOL ⟧} → Paths (id⟷ ⊗ swap₊) (b₁ , b₂) (b₁ , NOT b₂)
pathIdNotb {b₁} {inj₁ tt} = refl b₁ , refl tt
pathIdNotb {b₁} {inj₂ tt} = refl b₁ , refl tt

pathCnotbb : {b₁ b₂ : ⟦ BOOL ⟧} → Paths cnot (b₁ , b₂) (CNOT b₁ b₂)
pathCnotbb {inj₁ tt} {inj₁ tt} = inj₁ (tt , TRUE) ,
                                 (refl tt , refl TRUE) ,
                                 (inj₁ (tt , FALSE) ,
                                 (refl tt , refl tt) ,
                                 (refl tt , refl FALSE))
pathCnotbb {inj₁ tt} {inj₂ tt} = inj₁ (tt , FALSE) ,
                                 (refl tt , refl FALSE) ,
                                 (inj₁ (tt , TRUE) ,
                                 (refl tt , refl tt) ,
                                 (refl tt , refl TRUE))
pathCnotbb {inj₂ tt} {b₂} = inj₂ (tt , b₂) ,
                            (refl tt , refl b₂) ,
                            (inj₂ (tt , b₂) ,
                            (refl tt , refl b₂) ,
                            (refl tt , refl b₂))

pathCnotFF : Paths cnot (FALSE , FALSE) (FALSE , FALSE)
pathCnotFF = inj₂ (tt , FALSE) ,
             (refl tt , refl FALSE) ,
             (inj₂ (tt , FALSE) ,
             (refl tt , refl FALSE) ,
             (refl tt , refl FALSE))

pathCnotFT : Paths cnot (FALSE , TRUE) (FALSE , TRUE)
pathCnotFT = inj₂ (tt , TRUE) ,
             (refl tt , refl TRUE) ,
             (inj₂ (tt , TRUE) ,
             (refl tt , refl TRUE) ,
             (refl tt , refl TRUE))

pathCnotTF : Paths cnot (TRUE , FALSE) (TRUE , TRUE)
pathCnotTF = inj₁ (tt , FALSE) , -- first intermediate value
             -- path using dist from (T,F) to (inj₁ (tt , F))
             (refl tt , refl FALSE) ,
             -- path from (inj₁ (tt , F)) to (T,T)
             (inj₁ (tt , TRUE) , -- next intermediate value
             (refl tt , refl tt) ,
             (refl tt , refl TRUE))

pathCnotTT : Paths cnot (TRUE , TRUE) (TRUE , FALSE)
pathCnotTT = inj₁ (tt , TRUE) ,
             (refl tt , refl TRUE) ,
             (inj₁ (tt , FALSE) ,
             (refl tt , refl tt) ,
             (refl tt , refl FALSE))

pathUnite₊ : {t : U} {v v' : ⟦ t ⟧} → (v ≡ v') → Paths unite₊ (inj₂ v) v'
pathUnite₊ p = p

-- Higher groupoid structure

-- For every path between v₁ and v₂ there is a path between v₂ and v₁

mutual

  pathInv : {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} {c : t₁ ⟷ t₂} →
            Paths c v₁ v₂ → Paths (sym⟷ c) v₂ v₁
  pathInv {v₁ = inj₁ ()} {v₂ = v} {unite₊}
  pathInv {v₁ = inj₂ v} {v₂ = v'} {unite₊} p = sym p
  pathInv {v₁ = v} {v₂ = inj₁ ()} {uniti₊}
  pathInv {v₁ = v} {v₂ = inj₂ v'} {uniti₊} p = sym p
  pathInv {v₁ = inj₁ v} {v₂ = inj₁ v'} {swap₊} ()
  pathInv {v₁ = inj₁ v} {v₂ = inj₂ v'} {swap₊} p = sym p
  pathInv {v₁ = inj₂ v} {v₂ = inj₁ v'} {swap₊} p = sym p
  pathInv {v₁ = inj₂ v} {v₂ = inj₂ v'} {swap₊} ()
  pathInv {v₁ = inj₁ v} {v₂ = inj₁ (inj₁ v')} {assocl₊} p = sym p
  pathInv {v₁ = inj₁ v} {v₂ = inj₁ (inj₂ v')} {assocl₊} ()
  pathInv {v₁ = inj₁ v} {v₂ = inj₂ v'} {assocl₊} ()
  pathInv {v₁ = inj₂ (inj₁ v)} {v₂ = inj₁ (inj₁ v')} {assocl₊} ()
  pathInv {v₁ = inj₂ (inj₁ v)} {v₂ = inj₁ (inj₂ v')} {assocl₊} p = sym p
  pathInv {v₁ = inj₂ (inj₁ v)} {v₂ = inj₂ v'} {assocl₊} ()
  pathInv {v₁ = inj₂ (inj₂ v)} {v₂ = inj₁ v'} {assocl₊} ()
  pathInv {v₁ = inj₂ (inj₂ v)} {v₂ = inj₂ v'} {assocl₊} p = sym p
  pathInv {v₁ = inj₁ (inj₁ v)} {v₂ = inj₁ v'} {assocr₊} p = sym p
  pathInv {v₁ = inj₁ (inj₁ v)} {v₂ = inj₂ v'} {assocr₊} ()
  pathInv {v₁ = inj₁ (inj₂ v)} {v₂ = inj₁ v'} {assocr₊} ()
  pathInv {v₁ = inj₁ (inj₂ v)} {v₂ = inj₂ (inj₁ v')} {assocr₊} p = sym p
  pathInv {v₁ = inj₁ (inj₂ v)} {v₂ = inj₂ (inj₂ v')} {assocr₊} ()
  pathInv {v₁ = inj₂ v} {v₂ = inj₁ v'} {assocr₊} ()
  pathInv {v₁ = inj₂ v} {v₂ = inj₂ (inj₁ v')} {assocr₊} ()
  pathInv {v₁ = inj₂ v} {v₂ = inj₂ (inj₂ v')} {assocr₊} p = sym p
  pathInv {v₁ = (tt , v)} {v₂ = v'} {unite⋆} p = sym p
  pathInv {v₁ = v} {v₂ = (tt , v')} {uniti⋆} p = sym p
  pathInv {v₁ = (u , v)} {v₂ = (v' , u')} {swap⋆} (p₁ , p₂) = (sym p₂ , sym p₁)
  pathInv {v₁ = (u , (v , w))} {v₂ = ((u' , v') , w')} {assocl⋆} (p₁ , p₂ , p₃)
    = (sym p₁ , sym p₂ , sym p₃)
  pathInv {v₁ = ((u , v) , w)} {v₂ = (u' , (v' , w'))} {assocr⋆} (p₁ , p₂ , p₃)
    = (sym p₁ , sym p₂ , sym p₃)
  pathInv {v₁ = _} {v₂ = ()} {distz}
  pathInv {v₁ = ()} {v₂ = _} {factorz}
  pathInv {v₁ = (inj₁ v₁ , v₃)} {v₂ = inj₁ (v₁' , v₃')} {dist} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathInv {v₁ = (inj₁ v₁ , v₃)} {v₂ = inj₂ (v₂' , v₃')} {dist} ()
  pathInv {v₁ = (inj₂ v₂ , v₃)} {v₂ = inj₁ (v₁' , v₃')} {dist} ()
  pathInv {v₁ = (inj₂ v₂ , v₃)} {v₂ = inj₂ (v₂' , v₃')} {dist} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathInv {v₁ = inj₁ (v₁ , v₃)} {v₂ = (inj₁ v₁' , v₃')} {factor} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathInv {v₁ = inj₁ (v₁ , v₃)} {v₂ = (inj₂ v₂' , v₃')} {factor} ()
  pathInv {v₁ = inj₂ (v₂ , v₃)} {v₂ = (inj₁ v₁' , v₃')} {factor} ()
  pathInv {v₁ = inj₂ (v₂ , v₃)} {v₂ = (inj₂ v₂' , v₃')} {factor} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathInv {v₁ = v} {v₂ = v'} {id⟷} p = sym p
  pathInv {v₁ = v} {v₂ = v'} {sym⟷ c} p = pathBInv {v₁ = v'} {v₂ = v} {c} p
  pathInv {v₁ = v} {v₂ = v'} {c₁ ◎ c₂} (u , (p₁ , p₂)) =
    (u , (pathInv {c = c₂} p₂  , pathInv {c = c₁} p₁))
  pathInv {v₁ = inj₁ v} {v₂ = inj₁ v'} {c₁ ⊕ c₂} p = pathInv {c = c₁} p
  pathInv {v₁ = inj₁ v} {v₂ = inj₂ v'} {c₁ ⊕ c₂} ()
  pathInv {v₁ = inj₂ v} {v₂ = inj₁ v'} {c₁ ⊕ c₂} ()
  pathInv {v₁ = inj₂ v} {v₂ = inj₂ v'} {c₁ ⊕ c₂} p = pathInv {c = c₂} p
  pathInv {v₁ = (u , v)} {v₂ = (u' , v')} {c₁ ⊗ c₂} (p₁ , p₂) =
    (pathInv {c = c₁} p₁ , pathInv {c = c₂} p₂)

  pathBInv : {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} {c : t₁ ⟷ t₂} →
             PathsB c v₂ v₁ → PathsB (sym⟷ c) v₁ v₂
  pathBInv {v₁ = inj₁ ()} {v₂ = v} {unite₊}
  pathBInv {v₁ = inj₂ v} {v₂ = v'} {unite₊} p = sym p
  pathBInv {v₁ = v} {v₂ = inj₁ ()} {uniti₊}
  pathBInv {v₁ = v} {v₂ = inj₂ v'} {uniti₊} p = sym p
  pathBInv {v₁ = inj₁ v} {v₂ = inj₁ v'} {swap₊} ()
  pathBInv {v₁ = inj₁ v} {v₂ = inj₂ v'} {swap₊} p = sym p
  pathBInv {v₁ = inj₂ v} {v₂ = inj₁ v'} {swap₊} p = sym p
  pathBInv {v₁ = inj₂ v} {v₂ = inj₂ v'} {swap₊} ()

  pathBInv {v₁ = inj₁ v} {v₂ = inj₁ (inj₁ v')} {assocl₊} p = sym p
  pathBInv {v₁ = inj₂ v} {v₂ = inj₁ (inj₁ v')} {assocl₊} ()
  pathBInv {v₁ = inj₁ v} {v₂ = inj₁ (inj₂ v')} {assocl₊} ()
  pathBInv {v₁ = inj₂ (inj₁ v)} {v₂ = inj₁ (inj₂ v')} {assocl₊} p = sym p
  pathBInv {v₁ = inj₂ (inj₂ v)} {v₂ = inj₁ (inj₂ v')} {assocl₊} ()
  pathBInv {v₁ = inj₁ v} {v₂ = inj₂ v'} {assocl₊} ()
  pathBInv {v₁ = inj₂ (inj₁ v)} {v₂ = inj₂ v'} {assocl₊} ()
  pathBInv {v₁ = inj₂ (inj₂ v)} {v₂ = inj₂ v'} {assocl₊} p = sym p
  pathBInv {v₁ = inj₁ (inj₁ v)} {v₂ = inj₁ v'} {assocr₊} p = sym p
  pathBInv {v₁ = inj₁ (inj₂ v)} {v₂ = inj₁ v'} {assocr₊} ()
  pathBInv {v₁ = inj₂ v} {v₂ = inj₁ v'} {assocr₊} ()
  pathBInv {v₁ = inj₁ (inj₁ v)} {v₂ = inj₂ (inj₁ v')} {assocr₊} ()
  pathBInv {v₁ = inj₁ (inj₂ v)} {v₂ = inj₂ (inj₁ v')} {assocr₊} p = sym p
  pathBInv {v₁ = inj₂ v} {v₂ = inj₂ (inj₁ v')} {assocr₊} ()
  pathBInv {v₁ = inj₁ v} {v₂ = inj₂ (inj₂ v')} {assocr₊} ()
  pathBInv {v₁ = inj₂ v} {v₂ = inj₂ (inj₂ v')} {assocr₊} p = sym p
  pathBInv {v₁ = (tt , v)} {v₂ = v'} {unite⋆} p = sym p
  pathBInv {v₁ = v} {v₂ = (tt , v')} {uniti⋆} p = sym p
  pathBInv {v₁ = (u , v)} {v₂ = (v' , u')} {swap⋆} (p₁ , p₂) = (sym p₂ , sym p₁)
  pathBInv {v₁ = (u , (v , w))} {v₂ = ((u' , v') , w')} {assocl⋆} (p₁ , p₂ , p₃)
    = (sym p₁ , sym p₂ , sym p₃)
  pathBInv {v₁ = ((u , v) , w)} {v₂ = (u' , (v' , w'))} {assocr⋆} (p₁ , p₂ , p₃)
    = (sym p₁ , sym p₂ , sym p₃)
  pathBInv {v₁ = _} {v₂ = ()} {distz}
  pathBInv {v₁ = ()} {v₂ = _} {factorz}
  pathBInv {v₁ = (inj₁ v₁ , v₃)} {v₂ = inj₁ (v₁' , v₃')} {dist} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathBInv {v₁ = (inj₁ v₁ , v₃)} {v₂ = inj₂ (v₂' , v₃')} {dist} ()
  pathBInv {v₁ = (inj₂ v₂ , v₃)} {v₂ = inj₁ (v₁' , v₃')} {dist} ()
  pathBInv {v₁ = (inj₂ v₂ , v₃)} {v₂ = inj₂ (v₂' , v₃')} {dist} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathBInv {v₁ = inj₁ (v₁ , v₃)} {v₂ = (inj₁ v₁' , v₃')} {factor} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathBInv {v₁ = inj₁ (v₁ , v₃)} {v₂ = (inj₂ v₂' , v₃')} {factor} ()
  pathBInv {v₁ = inj₂ (v₂ , v₃)} {v₂ = (inj₁ v₁' , v₃')} {factor} ()
  pathBInv {v₁ = inj₂ (v₂ , v₃)} {v₂ = (inj₂ v₂' , v₃')} {factor} (p₁ , p₂) =
    (sym p₁ , sym p₂)
  pathBInv {v₁ = v} {v₂ = v'} {id⟷} p = sym p
  pathBInv {v₁ = v} {v₂ = v'} {sym⟷ c} p = pathInv {v₁ = v'} {v₂ = v} {c} p
  pathBInv {t₁} {t₂} {v₁} {v₂} {c₁ ◎ c₂} (u , (p₂ , p₁)) =
    (u , (pathBInv {v₁ = v₁} {v₂ = u} {c = c₁} p₁ ,
          pathBInv {v₁ = u} {v₂ = v₂} {c = c₂} p₂))
  pathBInv {v₁ = inj₁ v} {v₂ = inj₁ v'} {c₁ ⊕ c₂} p = pathBInv {c = c₁} p
  pathBInv {v₁ = inj₁ v} {v₂ = inj₂ v'} {c₁ ⊕ c₂} ()
  pathBInv {v₁ = inj₂ v} {v₂ = inj₁ v'} {c₁ ⊕ c₂} ()
  pathBInv {v₁ = inj₂ v} {v₂ = inj₂ v'} {c₁ ⊕ c₂} p = pathBInv {c = c₂} p
  pathBInv {v₁ = (u , v)} {v₂ = (u' , v')} {c₁ ⊗ c₂} (p₁ , p₂) =
    (pathBInv {c = c₁} p₁ , pathBInv {c = c₂} p₂)

-- for every paths from v1 to v2 and from v2 to v3, there is a path from v1
-- to v3 that (obviously) goes through v2

pathTrans : {t₁ t₂ t₃ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} {v₃ : ⟦ t₃ ⟧}
            {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} →
            Paths c₁ v₁ v₂ → Paths c₂ v₂ v₃ → Paths (c₁ ◎ c₂) v₁ v₃
pathTrans {v₂ = v₂} p q = (v₂ , p , q)

pathBTrans : {t₁ t₂ t₃ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} {v₃ : ⟦ t₃ ⟧}
             {c₁ : t₁ ⟷ t₂} {c₂ : t₂ ⟷ t₃} →
             PathsB c₁ v₂ v₁ → PathsB c₂ v₃ v₂ → PathsB (c₁ ◎ c₂) v₃ v₁
pathBTrans {v₂ = v₂} p q = (v₂ , q , p)

-- we always have a canonical path from v to v
pathId : {t : U} {v : ⟦ t ⟧} → Paths id⟷ v v
pathId {v = v} = refl v

------------------------------------------------------------------------------
-- Int construction
-- this will allow us to represents paths as values and then define 2paths
-- between them

data DU : Set where
  diff : U → U → DU

pos : DU → U
pos (diff t₁ t₂) = t₁

neg : DU → U
neg (diff t₁ t₂) = t₂

zeroD : DU
zeroD = diff ZERO ZERO

oneD : DU
oneD = diff ONE ZERO

plusD : DU → DU → DU
plusD (diff t₁ t₂) (diff t₁' t₂') = diff (PLUS t₁ t₁') (PLUS t₂ t₂')

timesD : DU → DU → DU
timesD (diff t₁ t₂) (diff t₁' t₂') =
  diff (PLUS (TIMES t₁ t₁') (TIMES t₂ t₂'))
       (PLUS (TIMES t₂ t₁') (TIMES t₁ t₂'))

dualD : DU → DU
dualD (diff t₁ t₂) = diff t₂ t₁

lolliD : DU → DU → DU
lolliD (diff t₁ t₂) (diff t₁' t₂') = diff (PLUS t₂ t₁') (PLUS t₁ t₂')

_≤=>_ : DU → DU → Set
d₁ ≤=> d₂ = PLUS (pos d₁) (neg d₂) ⟷ PLUS (neg d₁) (pos d₂)

idD : {d : DU} → d ≤=> d
idD = swap₊

--curryD : {d₁ d₂ d₃ : DU} → (plusD d₁ d₂ ≤=> d₃) → (d₁ ≤=> lolliD d₂ d₃)
--curryD f = assocl₊ ◎ f ◎ assocr₊
-- take a path and represent it as a value of type lolli and then use
-- ≤=> between these values as the definition of 2paths???

------------------------------------------------------------------------------
-- Can we show:
-- p : Paths c v₁ v₂ == pathTrans p (refl v₂)

-- Groupoid structure (i.e. laws), for 2Paths.  Some of the rest of
-- the structure is given above already
-- If the following is right, we can come up with syntax (like _[_]⟺[_]_ ) for  p₁ [c₁]⟺[c₂] p₂ .  We really do
-- need to index the ⟺ by the combinators 'explicitly' as Agda can never infer them.
data 2P {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧ } : {c₁ c₂ : t₁ ⟷ t₂} → Paths c₁ v₁ v₂ → Paths c₂ v₁ v₂ → Set where
  id2 : {c : t₁ ⟷ t₂} {p : Paths c v₁ v₂} → 2P {c₁ = c} {c} p p
  inv2  : {c₁ c₂ : t₁ ⟷ t₂} {p₁ : Paths c₁ v₁ v₂} {p₂ : Paths c₂ v₁ v₂} → 2P {c₁ = c₁} {c₂} p₁ p₂ → 2P {c₁ = c₂} {c₁} p₂ p₁
  comp2 : {c₁ c₂ c₃ : t₁ ⟷ t₂} {p₁ : Paths c₁ v₁ v₂} {p₂ : Paths c₂ v₁ v₂} {p₃ : Paths c₃ v₁ v₂} →
    2P {c₁ = c₁} {c₂} p₁ p₂ → 2P {c₁ = c₂} {c₃} p₂ p₃ → 2P {c₁ = c₁} {c₃} p₁ p₃
  -- should define composition which effectively does as below??
  lid : {c : t₁ ⟷ t₂} {p : Paths c v₁ v₂} → 2P {c₁ = id⟷ ◎ c} {c} (pathTrans {c₁ = id⟷} {c} pathId p) p
  rid : {c : t₁ ⟷ t₂} {p : Paths c v₁ v₂} → 2P {c₁ = c ◎ id⟷} {c} (pathTrans {c₁ = c} {id⟷} p pathId) p
-- also need:
-- assoc
--  linv : {c : t₁ ⟷ t₂} {p : Paths c v₁ v₂} → 2P {c₁ = c}
-- linv
-- rinv
-- and perhaps cong, i.e. ◎-resp-2P

mutual
  2Paths :  {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧ } {c₁ c₂ : t₁ ⟷ t₂} {p₁ : Paths c₁ v₁ v₂} {p₂ : Paths c₂ v₁ v₂} → 2P {c₁ = c₁} {c₂} p₁ p₂ → Paths c₁ v₁ v₂ → Paths c₂ v₁ v₂ → Set
  2Paths id2 p₁ p₂ = p₁ ≡ p₂
  2Paths (inv2 p) p₁ p₂ = 2PathsB p p₁ p₂
  2Paths {t₁} {t₂} {v₁} {v₂} (comp2 {c₁ = c₁} {c₂} {c₃} {p₁} {p₂} {p₃} p q) α₁ α₂ =
      Σ[ r ∈ Paths c₂ v₁ v₂ ] (2P {c₁ = c₁} {c₂} α₁ r × 2P {c₁ = c₂} {c₃} r α₂)
  2Paths lid (a , refl .a , p₂) p₃ = p₂ ≡ p₃
  2Paths rid (a , p₂ , refl .a) p₃ = p₂ ≡ p₃

  2PathsB : {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧ } {c₁ c₂ : t₁ ⟷ t₂} {p₁ : Paths c₁ v₁ v₂} {p₂ : Paths c₂ v₁ v₂} → 2P {c₁ = c₁} {c₂} p₁ p₂ → Paths c₂ v₁ v₂ → Paths c₁ v₁ v₂ → Set
  2PathsB id2 p q = q ≡ p
  2PathsB (inv2 p) p₁ p₂ = 2PathsB p p₂ p₁
  2PathsB (comp2 p q) p₁ p₂ = {!!}
  2PathsB lid p (a , refl .a , p₃) = p ≡ p₃
  2PathsB rid p (a , p₂ , refl .a) = p ≡ p₂

example : 2Paths {t₁ = BOOL} {t₂ = BOOL} {v₁ = FALSE} {v₂ = FALSE}
          {c₁ = id⟷ ◎ id⟷} {c₂ = id⟷} {p₁ = pathIdIdFF}
          lid pathIdIdFF pathIdFF
example = refl (refl FALSE)

{--
2Paths : {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} {c₁ c₂ : t₁ ⟷ t₂} →
         Paths c₁ v₁ v₂ → Paths c₂ v₁ v₂ → Set
2Paths p q = {!!}

reflR : {t₁ t₂ : U} {v₁ : ⟦ t₁ ⟧} {v₂ : ⟦ t₂ ⟧} {c : t₁ ⟷ t₂}
        {p : Paths c v₁ v₂} → {q : Paths (c ◎ id⟷) v₁ v₂} →
        2Paths {t₁} {t₂} {v₁} {v₂} {c} {c ◎ id⟷} p q
reflR {c = unite₊} = {!!}
-- p : Paths unite₊ .v₁ .v₂
-- q : Paths (unite₊ ◎ id⟷) .v₁ .v₂
-- 2Paths p q
reflR {c = uniti₊} = {!!}
reflR {c = swap₊} = {!!}
reflR {c = assocl₊} = {!!}
reflR {c = assocr₊} = {!!}
reflR {c = unite⋆} = {!!}
reflR {c = uniti⋆} = {!!}
reflR {c = swap⋆} = {!!}
reflR {c = assocl⋆} = {!!}
reflR {c = assocr⋆} = {!!}
reflR {c = distz} = {!!}
reflR {c = factorz} = {!!}
reflR {c = dist} = {!!}
reflR {c = factor} = {!!}
reflR {c = id⟷} = {!!}
reflR {c = sym⟷ c} = {!!}
reflR {c = c₁ ◎ c₂} = {!!}
reflR {c = c₁ ⊕ c₂} = {!!}
reflR {c = c₁ ⊗ c₂} = {!!}
--}

{--
-- If we have a path between v₁ and v₁' and a combinator that connects v₁ to
-- v₂, then the combinator also connects v₁' to some v₂' such that there is
-- path between v₂ and v₂'

pathFunctor : {t₁ t₂ : U} {v₁ v₁' : ⟦ t₁ ⟧} {v₂ v₂' : ⟦ t₂ ⟧} {c : t₁ ⟷ t₂} →
  (v₁ ≡ v₁') → Paths c v₁ v₂ → (v₂ ≡ v₂') → Paths c v₁' v₂'
pathFunctor = {!!}

All kind of structure to investigate in the HoTT book. Let's push forward
with cubical types though...
--}

------------------------------------------------------------------------------
-- N dimensional version

{-
data C : ℕ → Set where
  ZD   : U → C 0
  Node : {n : ℕ} → C n → C n → C (suc n)

⟦_⟧N : {n : ℕ} → C n → Set
⟦ ZD t ⟧N = ⟦ t ⟧
⟦ Node c₁ c₂ ⟧N = ⟦ c₁ ⟧N ⊎ ⟦ c₂ ⟧N

liftN : (n : ℕ) → (t : U) → C n
liftN 0 t = ZD t
liftN (suc n) t = Node (liftN n t) (liftN n ZERO)

zeroN : (n : ℕ) → C n
zeroN n = liftN n ZERO

oneN : (n : ℕ) → C n
oneN n = liftN n ONE

plus : {n : ℕ} → C n → C n → C n
plus (ZD t₁) (ZD t₂) = ZD (PLUS t₁ t₂)
plus (Node c₁ c₂) (Node c₁' c₂') = Node (plus c₁ c₁') (plus c₂ c₂')

times : {m n : ℕ} → C m → C n → C (m + n)
times (ZD t₁) (ZD t₂) = ZD (TIMES t₁ t₂)
times (ZD t) (Node c₁ c₂) = Node (times (ZD t) c₁) (times (ZD t) c₂)
times (Node c₁ c₂) c = Node (times c₁ c) (times c₂ c)

-- N-dimensional paths connect points in c₁ and c₂ if there is an isomorphism
-- between the types c₁ and c₂.

data _⟺_ : {n : ℕ} → C n → C n → Set where
  baseC : {t₁ t₂ : U} → (t₁ ⟷ t₂) → ((ZD t₁) ⟺ (ZD t₂))
  nodeC : {n : ℕ} {c₁ : C n} {c₂ : C n} {c₃ : C n} {c₄ : C n} →
          (c₁ ⟺ c₂) → (c₃ ⟺ c₄) → ((Node c₁ c₃) ⟺ (Node c₂ c₄))
--  zerolC : {n : ℕ} {c : C n} → ((Node c c) ⟺ (zeroN (suc n)))
--  zerorC : {n : ℕ} {c : C n} → ((zeroN (suc n)) ⟺ (Node c c))

NPaths : {n : ℕ} {c₁ c₂ : C n} → (c₁ ⟺ c₂) → ⟦ c₁ ⟧N → ⟦ c₂ ⟧N → Set
NPaths (baseC c) v₁ v₂ = Paths c v₁ v₂
NPaths (nodeC α₁ α₂) (inj₁ v₁) (inj₁ v₂) = NPaths α₁ v₁ v₂
NPaths (nodeC α₁ α₂) (inj₁ v₁) (inj₂ v₂) = ⊥
NPaths (nodeC α₁ α₂) (inj₂ v₁) (inj₁ v₂) = ⊥
NPaths (nodeC α₁ α₂) (inj₂ v₁) (inj₂ v₂) = NPaths α₂ v₁ v₂
--NPaths zerolC v₁ v₂ = {!!}
--NPaths zerorC v₁ v₂ = {!!}

-}
------------------------------------------------------------------------------


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Neutral {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Symmetry

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

-- Neutral reflexive types are reducible.
neu : ∀ {l Γ A} (neA : Neutral A)
    → Γ ⊢ A
    → Γ ⊢ A ~ A ∷ U
    → Γ ⊩⟨ l ⟩ A
neu neA A A~A = ne′ _ (idRed:*: A) neA A~A

  -- Helper function for reducible neutral equality of a specific type of derivation.
neuEq′ : ∀ {l Γ A B} ([A] : Γ ⊩⟨ l ⟩ne A)
         (neA : Neutral A)
         (neB : Neutral B)
       → Γ ⊢ A → Γ ⊢ B
       → Γ ⊢ A ~ B ∷ U
       → Γ ⊩⟨ l ⟩ A ≡ B / ne-intr [A]
neuEq′ (noemb (ne K [ ⊢A , ⊢B , D ] neK K≡K)) neA neB A B A~B =
  let A≡K = whnfRed* D (ne neA)
  in  ιx (ne₌ _ (idRed:*: B) neB (PE.subst (λ x → _ ⊢ x ~ _ ∷ _) A≡K A~B))
neuEq′ (emb 0<1 x) neA neB A B A~B  = ιx (neuEq′ x neA neB A B A~B)

-- Neutrally equal types are of reducible equality.
neuEq : ∀ {l Γ A B} ([A] : Γ ⊩⟨ l ⟩ A)
        (neA : Neutral A)
        (neB : Neutral B)
      → Γ ⊢ A → Γ ⊢ B
      → Γ ⊢ A ~ B ∷ U
      → Γ ⊩⟨ l ⟩ A ≡ B / [A]
neuEq [A] neA neB A B A~B =
  irrelevanceEq (ne-intr (ne-elim neA [A]))
                [A]
                (neuEq′ (ne-elim neA [A]) neA neB A B A~B)

mutual
  -- Neutral reflexive terms are reducible.
  neuTerm : ∀ {l Γ A n} ([A] : Γ ⊩⟨ l ⟩ A) (neN : Neutral n)
          → Γ ⊢ n ∷ A
          → Γ ⊢ n ~ n ∷ A
          → Γ ⊩⟨ l ⟩ n ∷ A / [A]
  neuTerm (Uᵣ′ .⁰ 0<1 ⊢Γ) neN n n~n =
    Uₜ _ (idRedTerm:*: n) (ne neN) (~-to-≅ₜ n~n) (neu neN (univ n) n~n)
  neuTerm (ℕᵣ [ ⊢A , ⊢B , D ]) neN n n~n =
    let A≡ℕ  = subset* D
        n~n′ = ~-conv n~n A≡ℕ
        n≡n  = ~-to-≅ₜ n~n′
    in ιx (ℕₜ _ (idRedTerm:*: (conv n A≡ℕ)) n≡n (ne (neNfₜ neN (conv n A≡ℕ) n~n′)))
  neuTerm (ne′ K [ ⊢A , ⊢B , D ] neK K≡K) neN n n~n =
    let A≡K = subset* D
    in ιx (neₜ _ (idRedTerm:*: (conv n A≡K)) (neNfₜ neN (conv n A≡K)
            (~-conv n~n A≡K)))
  neuTerm (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n =
    let A≡ΠFG = subset* (red D)
    in  Πₜ _ (idRedTerm:*: (conv n A≡ΠFG)) (ne neN) (~-to-≅ₜ (~-conv n~n A≡ΠFG))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let A≡ΠFG = subset* (red D)
                  ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  G[a]≡G[b] = escapeEq ([G] [ρ] ⊢Δ [b])
                                          (symEq ([G] [ρ] ⊢Δ [a]) ([G] [ρ] ⊢Δ [b])
                                                 (G-ext [ρ] ⊢Δ [a] [b] [a≡b]))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  b = escapeTerm ([F] [ρ] ⊢Δ) [b]
                  a≡b = escapeTermEq ([F] [ρ] ⊢Δ) [a≡b]
                  ρn = conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG
                  neN∘a = ∘ₙ (wkNeutral ρ neN)
                  neN∘b = ∘ₙ (wkNeutral ρ neN)
              in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∘a neN∘b
                            (ρn ∘ⱼ a)
                            (conv (ρn ∘ⱼ b) (≅-eq G[a]≡G[b]))
                            (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡b))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  a≡a = escapeTermEq ([F] [ρ] ⊢Δ) (reflEqTerm ([F] [ρ] ⊢Δ) [a])
              in  neuTerm ([G] [ρ] ⊢Δ [a]) (∘ₙ (wkNeutral ρ neN))
                          (conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG ∘ⱼ a)
                          (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡a))
  neuTerm (emb′ 0<1 x) neN n n~n = ιx (neuTerm x neN n n~n)

  -- Neutrally equal terms are of reducible equality.
  neuEqTerm : ∀ {l Γ A n n′} ([A] : Γ ⊩⟨ l ⟩ A)
              (neN : Neutral n) (neN′ : Neutral n′)
            → Γ ⊢ n  ∷ A
            → Γ ⊢ n′ ∷ A
            → Γ ⊢ n ~ n′ ∷ A
            → Γ ⊩⟨ l ⟩ n ≡ n′ ∷ A / [A]
  neuEqTerm (Uᵣ′ .⁰ 0<1 ⊢Γ) neN neN′ n n′ n~n′ =
    let [n]  = neu neN  (univ n) (~-trans n~n′ (~-sym n~n′))
        [n′] = neu neN′ (univ n′) (~-trans (~-sym n~n′) n~n′)
    in  Uₜ₌ _ _ (idRedTerm:*: n) (idRedTerm:*: n′) (ne neN) (ne neN′)
            (~-to-≅ₜ n~n′) [n] [n′] (neuEq [n] neN neN′ (univ n) (univ n′) n~n′)
  neuEqTerm (ℕᵣ [ ⊢A , ⊢B , D ]) neN neN′ n n′ n~n′ =
    let A≡ℕ = subset* D
        n~n′₁ = ~-conv n~n′ A≡ℕ
        n≡n′ = ~-to-≅ₜ n~n′₁
    in ιx (ℕₜ₌ _ _ (idRedTerm:*: (conv n A≡ℕ)) (idRedTerm:*: (conv n′ A≡ℕ))
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁)))
  neuEqTerm (ne′ K [ ⊢A , ⊢B , D ] neK K≡K) neN neN′ n n′ n~n′ =
    let A≡K = subset* D
    in ιx (neₜ₌ _ _ (idRedTerm:*: (conv n A≡K)) (idRedTerm:*: (conv n′ A≡K))
             (neNfₜ₌ neN neN′ (~-conv n~n′ A≡K)))
  neuEqTerm (Πᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let [ΠFG] = Πᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΠFG = subset* D
        n~n′₁ = ~-conv n~n′ A≡ΠFG
        n≡n′ = ~-to-≅ₜ n~n′₁
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′
    in  Πₜ₌ _ _ (idRedTerm:*: (conv n A≡ΠFG)) (idRedTerm:*: (conv n′ A≡ΠFG))
            (ne neN) (ne neN′) n≡n′
            (neuTerm [ΠFG] neN n n~n) (neuTerm [ΠFG] neN′ n′ n′~n′)
            (λ {ρ} [ρ] ⊢Δ [a] →
               let ρA≡ρΠFG = wkEq [ρ] ⊢Δ A≡ΠFG
                   ρn = wkTerm [ρ] ⊢Δ n
                   ρn′ = wkTerm [ρ] ⊢Δ n′
                   a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                   a≡a = escapeTermEq ([F] [ρ] ⊢Δ)
                                          (reflEqTerm ([F] [ρ] ⊢Δ) [a])
                   neN∙a   = ∘ₙ (wkNeutral ρ neN)
                   neN′∙a′ = ∘ₙ (wkNeutral ρ neN′)
               in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∙a neN′∙a′
                             (conv ρn  ρA≡ρΠFG ∘ⱼ a)
                             (conv ρn′ ρA≡ρΠFG ∘ⱼ a)
                             (~-app (~-wk [ρ] ⊢Δ n~n′₁) a≡a))
  neuEqTerm (emb′ 0<1 x) neN neN′ n n′ n~n′ = ιx (neuEqTerm x neN neN′ n n′ n~n′)


open import Data.Product using ( _×_ ; _,_ )
open import Relation.Nullary using ( ¬_ )
open import Relation.Unary using ( _∈_ ; ∅ ; _∪_ )
open import Web.Semantic.DL.ABox using
  ( ABox ; Assertions ; ε ; _,_ ; _∼_ ; _∈₁_ ; _∈₂_ )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; ⌊_⌋ ; ind )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.Concept using
  ( Concept ; ⟨_⟩ ; ⊤ ; ⊥ ; _⊓_ ; _⊔_ ; ∀[_]_ ; ∃⟨_⟩_ ; ≤1 )
open import Web.Semantic.DL.KB using ( KB ; tbox ; abox )
open import Web.Semantic.DL.Role using ( Role ; ⟨_⟩ ; ⟨_⟩⁻¹ )
open import Web.Semantic.DL.TBox using
  ( TBox ; Axioms ; ε ; _,_ ;_⊑₁_ ; _⊑₂_ ; Ref ; Tra )
open import Web.Semantic.DL.TBox.Interp using ( Δ ; _⊨_≈_ ; con ; rol )
open import Web.Semantic.Util using ( _⊕_⊕_ ; inode ; bnode ; enode )

module Web.Semantic.DL.Sequent {Σ : Signature} {W X Y : Set} where

infix 2 _⊕_⊢_∼_ _⊕_⊢_∈₁_ _⊕_⊢_∈₂_

Γ : (Interp Σ X) → (KB Σ (X ⊕ W ⊕ Y)) → Set
Γ I K = Δ ⌊ I ⌋ ⊕ W ⊕ Y

γ : ∀ I K → (X ⊕ W ⊕ Y) → Γ I K
γ I K (inode x) = inode (ind I x)
γ I K (bnode w) = bnode w
γ I K (enode y) = enode y

mutual

  data _⊕_⊢_∼_ I K : Γ I K → Γ I K → Set where
    ∼-assert : ∀ {x y} → ((x ∼ y) ∈ Assertions (abox K)) → (I ⊕ K ⊢ γ I K x ∼ γ I K y)
    ∼-import : ∀ {x y} → (⌊ I ⌋ ⊨ x ≈ y) → (I ⊕ K ⊢ inode x ∼ inode y)
    ∼-refl : ∀ {x} → (I ⊕ K ⊢ x ∼ x)
    ∼-sym : ∀ {x y} → (I ⊕ K ⊢ x ∼ y) → (I ⊕ K ⊢ y ∼ x)
    ∼-trans : ∀ {x y z} → (I ⊕ K ⊢ x ∼ y) → (I ⊕ K ⊢ y ∼ z) → (I ⊕ K ⊢ x ∼ z)
    ∼-≤1 : ∀ {x y z R} → (I ⊕ K ⊢ x ∈₁ (≤1 R)) → (I ⊕ K ⊢ (x , y) ∈₂ R) → (I ⊕ K ⊢ (x , z) ∈₂ R) → (I ⊕ K ⊢ y ∼ z)

  data  _⊕_⊢_∈₁_ I K : Γ I K → Concept Σ → Set where
    ∈₁-assert : ∀ {x c} → ((x ∈₁ c) ∈ Assertions (abox K)) → (I ⊕ K ⊢ γ I K x ∈₁ ⟨ c ⟩)
    ∈₁-import : ∀ {x c} → (x ∈ con ⌊ I ⌋ c) → (I ⊕ K ⊢ inode x ∈₁ ⟨ c ⟩)
    ∈₁-resp-∼ : ∀ {x y C} → (I ⊕ K ⊢ x ∈₁ C) → (I ⊕ K ⊢ x ∼ y) → (I ⊕ K ⊢ y ∈₁ C)
    ∈₁-subsum : ∀ {x C D} → (I ⊕ K ⊢ x ∈₁ C) → ((C ⊑₁ D) ∈ Axioms (tbox K)) → (I ⊕ K ⊢ x ∈₁ D)
    ∈₁-⊤-I : ∀ {x} → (I ⊕ K ⊢ x ∈₁ ⊤)
    ∈₁-⊓-I : ∀ {x C D} → (I ⊕ K ⊢ x ∈₁ C) → (I ⊕ K ⊢ x ∈₁ D) → (I ⊕ K ⊢ x ∈₁ (C ⊓ D))
    ∈₁-⊓-E₁ : ∀ {x C D} → (I ⊕ K ⊢ x ∈₁ (C ⊓ D)) → (I ⊕ K ⊢ x ∈₁ C)
    ∈₁-⊓-E₂ : ∀ {x C D} → (I ⊕ K ⊢ x ∈₁ (C ⊓ D)) → (I ⊕ K ⊢ x ∈₁ D)
    ∈₁-⊔-I₁ : ∀ {x C D} → (I ⊕ K ⊢ x ∈₁ C) → (I ⊕ K ⊢ x ∈₁ (C ⊔ D))
    ∈₁-⊔-I₂ : ∀ {x C D} → (I ⊕ K ⊢ x ∈₁ D) → (I ⊕ K ⊢ x ∈₁ (C ⊔ D))
    ∈₁-∀-E : ∀ {x y R C} → (I ⊕ K ⊢ x ∈₁ (∀[ R ] C)) → (I ⊕ K ⊢ (x , y) ∈₂ R) → (I ⊕ K ⊢ y ∈₁ C)
    ∈₁-∃-I : ∀ {x y R C} → (I ⊕ K ⊢ (x , y) ∈₂ R) → (I ⊕ K ⊢ y ∈₁ C)  → (I ⊕ K ⊢ x ∈₁ (∃⟨ R ⟩ C))

  data _⊕_⊢_∈₂_ I K : (Γ I K × Γ I K) → Role Σ → Set where
    ∈₂-assert : ∀ {x y r} → (((x , y) ∈₂ r) ∈ Assertions (abox K)) → (I ⊕ K ⊢ (γ I K x , γ I K y) ∈₂ ⟨ r ⟩)
    ∈₂-import : ∀ {x y r} → ((x , y) ∈ rol ⌊ I ⌋ r) → (I ⊕ K ⊢ (inode x , inode y) ∈₂ ⟨ r ⟩)
    ∈₂-resp-∼ : ∀ {w x y z R} → (I ⊕ K ⊢ w ∼ x) → (I ⊕ K ⊢ (x , y) ∈₂ R) → (I ⊕ K ⊢ y ∼ z) → (I ⊕ K ⊢ (w , z) ∈₂ R)
    ∈₂-subsum : ∀ {xy R S} → (I ⊕ K ⊢ xy ∈₂ R) → ((R ⊑₂ S) ∈ Axioms (tbox K)) → (I ⊕ K ⊢ xy ∈₂ S)
    ∈₂-refl : ∀ x {R} → ((Ref R) ∈ Axioms (tbox K)) → (I ⊕ K ⊢ (x , x) ∈₂ R)
    ∈₂-trans : ∀ {x y z R} → (I ⊕ K ⊢ (x , y) ∈₂ R) → (I ⊕ K ⊢ (y , z) ∈₂ R) → ((Tra R) ∈ Axioms (tbox K)) → (I ⊕ K ⊢ (x , z) ∈₂ R)
    ∈₂-inv-I : ∀ {x y r} → (I ⊕ K ⊢ (x , y) ∈₂ ⟨ r ⟩) → (I ⊕ K ⊢ (y , x) ∈₂ ⟨ r ⟩⁻¹)
    ∈₂-inv-E : ∀ {x y r} → (I ⊕ K ⊢ (x , y) ∈₂ ⟨ r ⟩⁻¹) → (I ⊕ K ⊢ (y , x) ∈₂ ⟨ r ⟩)


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

module Cubical.Data.Fin.Recursive.Properties where

open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence

open import Cubical.Functions.Embedding

import Cubical.Data.Empty as Empty
open Empty hiding (rec; elim)
open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.Nat.Order.Recursive
open import Cubical.Data.Sigma
import Cubical.Data.Sum as Sum
open Sum using (_⊎_; _⊎?_; inl; inr)

open import Cubical.Data.Fin.Recursive.Base

open import Cubical.Relation.Nullary

private
  variable
    ℓ : Level
    m n : ℕ
    A : Type ℓ
    x y : A

isPropFin0 : isProp (Fin 0)
isPropFin0 = isProp⊥

isContrFin1 : isContr (Fin 1)
isContrFin1 .fst = zero
isContrFin1 .snd zero = refl

Unit≡Fin1 : Unit ≡ Fin 1
Unit≡Fin1 = ua (const zero , ctr)
  where
  fibr : fiber (const zero) zero
  fibr = tt , refl

  fibr! : ∀ f → fibr ≡ f
  fibr! (tt , p) i .fst = tt
  fibr! (tt , p) i .snd = J (λ{ zero q → refl ≡ q }) refl p i

  ctr : isEquiv (const zero)
  ctr .equiv-proof zero .fst = fibr
  ctr .equiv-proof zero .snd = fibr!

module Cover where
  Cover : FinF A → FinF A → Type _
  Cover zero zero = Unit
  Cover (suc x) (suc y) = x ≡ y
  Cover _ _ = ⊥

  crefl : Cover x x
  crefl {x = zero} = _
  crefl {x = suc x} = refl

  cover : x ≡ y → Cover x y
  cover p = transport (λ i → Cover (p i0) (p i)) crefl

  predp : Path (FinF A) (suc x) (suc y) → x ≡ y
  predp {x = x} p = transport (λ i → Cover (suc x) (p i)) refl

  suc-predp-refl
    : Path (Path (FinF A) (suc x) (suc x))
        (λ i → suc (predp (λ _ → suc x) i)) refl
  suc-predp-refl {x = x} i j
    = suc (transportRefl (refl {x = x}) i j)

  suc-retract : (p : Path (FinF A) (suc x) (suc y)) → (λ i → suc (predp p i)) ≡ p
  suc-retract
    = J (λ{ (suc m) q → (λ i → suc (predp q i)) ≡ q ; zero _ → ⊥}) suc-predp-refl

  isEmbedding-suc : isEmbedding {B = FinF A} suc
  isEmbedding-suc w x = isoToIsEquiv theIso
    where
    open Iso
    theIso : Iso (w ≡ x) (suc w ≡ suc x)
    theIso .fun = cong suc
    theIso .inv p = predp p
    theIso .rightInv = suc-retract
    theIso .leftInv
      = J (λ _ q → transport (λ i → w ≡ q i) refl ≡ q) (transportRefl refl)

private
  zK : (p : Path (FinF A) zero zero) → p ≡ refl
  zK = J (λ{ zero q → q ≡ refl ; one _ → ⊥ }) refl

  isSetFinF : isSet A → isSet (FinF A)
  isSetFinF Aset zero zero p
    = J (λ{ zero q → p ≡ q ; _ _ → ⊥ }) (zK p)
  isSetFinF Aset (suc x) (suc y)
    = isOfHLevelRetract 1 Cover.predp (cong suc) Cover.suc-retract (Aset x y)
  isSetFinF Aset zero (suc _) p = Empty.rec (Cover.cover p)
  isSetFinF Aset (suc _) zero p = Empty.rec (Cover.cover p)

isSetFin : isSet (Fin m)
isSetFin {zero} = isProp→isSet isPropFin0
isSetFin {suc m} = isSetFinF isSetFin

discreteFin : Discrete (Fin m)
discreteFin {suc m} zero zero = yes refl
discreteFin {suc m} (suc i) (suc j) with discreteFin i j
... | yes p = yes (cong suc p)
... | no ¬p = no (¬p ∘ Cover.predp)
discreteFin {suc m} zero (suc _) = no Cover.cover
discreteFin {suc m} (suc _) zero = no Cover.cover

inject< : m < n → Fin m → Fin n
inject< {suc m} {suc n} _ zero = zero
inject< {suc m} {suc n} m<n (suc i) = suc (inject< m<n i)

inject≤ : m ≤ n → Fin m → Fin n
inject≤ {suc m} {suc n} _ zero = zero
inject≤ {suc m} {suc n} m≤n (suc i) = suc (inject≤ m≤n i)

any? : {P : Fin m → Type ℓ} → (∀ i → Dec (P i)) → Dec (Σ _ P)
any? {zero} P? = no fst
any? {suc m} P? with P? zero ⊎? any? (P? ∘ suc)
... | yes (inl p) = yes (zero , p)
... | yes (inr (i , p)) = yes (suc i , p)
... | no k = no λ where
  (zero , p) → k (inl p)
  (suc x , p) → k (inr (x , p))

_#_ : Fin m → Fin m → Type₀
_#_ {m = suc m} zero zero = ⊥
_#_ {m = suc m} (suc i) zero = Unit
_#_ {m = suc m} zero (suc j) = Unit
_#_ {m = suc m} (suc i) (suc j) = i # j

#→≢ : ∀{i j : Fin m} → i # j → ¬ i ≡ j
#→≢ {suc _} {zero} {suc j} _ = Cover.cover
#→≢ {suc _} {suc i} {zero} _ = Cover.cover
#→≢ {suc m} {suc i} {suc j} ap p = #→≢ ap (Cover.predp p)

≢→# : ∀{i j : Fin m} → ¬ i ≡ j → i # j
≢→# {suc m} {zero}  {zero}  ¬p = ¬p refl
≢→# {suc m} {zero}  {suc j}  _ = _
≢→# {suc m} {suc i} {zero}   _ = _
≢→# {suc m} {suc i} {suc j} ¬p = ≢→# {m} {i} {j} (¬p ∘ cong suc)

#-inject< : ∀{l : m < n} (i j : Fin m) → i # j → inject< {m} {n} l i # inject< l j
#-inject< {suc m} {suc n} zero    (suc _) _ = _
#-inject< {suc m} {suc n} (suc _) zero    _ = _
#-inject< {suc m} {suc n} (suc i) (suc j) a = #-inject< {m} {n} i j a

punchOut : (i j : Fin (suc m)) → i # j → Fin m
punchOut {suc m} zero (suc j) _ = j
punchOut {suc m} (suc i) zero _ = zero
punchOut {suc m} (suc i) (suc j) ap = suc (punchOut i j ap)

punchOut-inj
  : ∀{i j k : Fin (suc m)}
  → (i#j : i # j) (i#k : i # k)
  → punchOut i j i#j ≡ punchOut i k i#k
  → j ≡ k
punchOut-inj {suc m} {suc i} {zero} {zero} i#j i#k p = refl
punchOut-inj {suc m} {zero} {suc j} {suc k} i#j i#k p = cong suc p
punchOut-inj {suc m} {suc i} {suc j} {suc k} i#j i#k p
  = cong suc (punchOut-inj {m} {i} {j} {k} i#j i#k (Cover.predp p))
punchOut-inj {suc m} {suc i} {zero} {suc x} i#j i#k p
  = Empty.rec (Cover.cover p)
punchOut-inj {suc m} {suc i} {suc j} {zero} i#j i#k p
  = Empty.rec (Cover.cover p)

_⊕_ : (m : ℕ) → Fin n → Fin (m + n)
zero  ⊕ i = i
suc m ⊕ i = suc (m ⊕ i)

toFin : (n : ℕ) → Fin (suc n)
toFin zero = zero
toFin (suc n) = suc (toFin n)

inject<#toFin : ∀(i : Fin n) → inject< (≤-refl (suc n)) i # toFin n
inject<#toFin {suc n} zero = _
inject<#toFin {suc n} (suc i) = inject<#toFin {n} i

inject≤#⊕ : ∀(i : Fin m) (j : Fin n) → inject≤ (k≤k+n m) i # (m ⊕ j)
inject≤#⊕ {suc m} {suc n} zero    j = _
inject≤#⊕ {suc m} {suc n} (suc i) j = inject≤#⊕ i j

split : (m : ℕ) → Fin (m + n) → Fin m ⊎ Fin n
split zero    j = inr j
split (suc m) zero = inl zero
split (suc m) (suc i) with split m i
... | inl k = inl (suc k)
... | inr j = inr j

pigeonhole
  : m < n
  → (f : Fin n → Fin m)
  → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] (i # j) × (f i ≡ f j)
pigeonhole {zero} {suc n} m<n f = Empty.rec (f zero)
pigeonhole {suc m} {suc n} m<n f with any? (λ i → discreteFin (f zero) (f (suc i)))
... | yes (j , p) = zero , suc j , _ , p
... | no ¬p = let i , j , ap , p = pigeonhole {m} {n} m<n g
               in suc i , suc j , ap
                , punchOut-inj {i = f zero} (apart i) (apart j) p
  where
  apart : (i : Fin n) → f zero # f (suc i)
  apart i = ≢→# {suc m} {f zero} (¬p ∘ _,_ i)

  g : Fin n → Fin m
  g i = punchOut (f zero) (f (suc i)) (apart i)

Fin-inj₀ : m < n → ¬ Fin n ≡ Fin m
Fin-inj₀ m<n P with pigeonhole m<n (transport P)
... | i , j , i#j , p = #→≢ i#j i≡j
  where
  i≡j : i ≡ j
  i≡j = transport (λ k → transport⁻Transport P i k ≡ transport⁻Transport P j k)
          (cong (transport⁻ P) p)

Fin-inj : (m n : ℕ) → Fin m ≡ Fin n → m ≡ n
Fin-inj m n P with m ≟ n
... | eq p   = p
... | lt m<n = Empty.rec (Fin-inj₀ m<n (sym P))
... | gt n<m = Empty.rec (Fin-inj₀ n<m P)

module Isos where
  open Iso

  up : Fin m → Fin (m + n)
  up {m} = inject≤ (k≤k+n m)

  resplit-identᵣ₀ : ∀ m (i : Fin n) → Sum.⊎Path.Cover (split m (m ⊕ i)) (inr i)
  resplit-identᵣ₀ zero    i = lift refl
  resplit-identᵣ₀ (suc m) i with split m (m ⊕ i) | resplit-identᵣ₀ m i
  ... | inr j | p = p

  resplit-identᵣ : ∀ m (i : Fin n) → split m (m ⊕ i) ≡ inr i
  resplit-identᵣ m i = Sum.⊎Path.decode _ _ (resplit-identᵣ₀ m i)

  resplit-identₗ₀ : ∀ m (i : Fin m) → Sum.⊎Path.Cover (split {n} m (up i)) (inl i)
  resplit-identₗ₀ (suc m) zero = lift refl
  resplit-identₗ₀ {n} (suc m) (suc i)
    with split {n} m (up i) | resplit-identₗ₀ {n} m i
  ... | inl j | lift p = lift (cong suc p)

  resplit-identₗ : ∀ m (i : Fin m) → split {n} m (up i) ≡ inl i
  resplit-identₗ m i = Sum.⊎Path.decode _ _ (resplit-identₗ₀ m i)

  desplit-ident : ∀ m → (i : Fin (m + n)) → Sum.rec up (m ⊕_) (split m i) ≡ i
  desplit-ident zero i = refl
  desplit-ident (suc m) zero = refl
  desplit-ident (suc m) (suc i) with split m i | desplit-ident m i
  ... | inl j | p = cong suc p
  ... | inr j | p = cong suc p

  sumIso : Iso (Fin m ⊎ Fin n) (Fin (m + n))
  sumIso {m} .fun = Sum.rec up (m ⊕_)
  sumIso {m} .inv i = split m i
  sumIso {m} .rightInv i = desplit-ident m i
  sumIso {m} .leftInv (inr j) = resplit-identᵣ m j
  sumIso {m} .leftInv (inl i) = resplit-identₗ m i

sum≡ : Fin m ⊎ Fin n ≡ Fin (m + n)
sum≡ = isoToPath Isos.sumIso


module HelloWorld where

open import IO
open import Data.String
open import Data.Unit
open import Level using (0ℓ)

main = run {0ℓ} (putStrLn "Hello World!")


{-# OPTIONS --cubical-compatible #-}

module _ where

module M where
  data D : Set where

record R₁ : Set where
  field
    x : let module M′ = M in M′.D

variable
  A : Set

record R₂ (A : Set) : Set where

_ : (r : R₂ A) → let open R₂ r in Set₁
_ = λ _ → Set


{-# OPTIONS --no-qualified-instances #-}

module NoQualifiedInstances-ParameterizedImport where

postulate
  T : Set

open import NoQualifiedInstances.ParameterizedImport.A T as A

postulate
  f : {{A.I}} → A.I

test : A.I
test = f


module Category.Monad.Maybe.Typeclass where

open import Category.Monad
open import Data.Maybe

record MaybeMonad (M : Set → Set) : Set₁ where
  field
    no  : ∀ {A} → M A
    yes : ∀ {A} → A → M A

open MaybeMonad
maybe-monad-ops : MaybeMonad Maybe
no  maybe-monad-ops = nothing
yes maybe-monad-ops = just


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

module Data.Maybe where

open import Data.Maybe.Base public


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

module Data.Unit.UniversePolymorphic where

open import Level

record ⊤ {ℓ} : Type ℓ where constructor tt


-- Reported by nad 2018-01-23
{-# OPTIONS --sized-types #-}

module Issue3517 where

import Issue3517.S
import Issue3517.M


-- Andreas, 2013-05-02 This ain't a bug, it is a feature.
-- {-# OPTIONS -v scope.name:10 #-}
module _ where

open import Common.Equality

module M where

  record R' : Set₁ where
    field
      X : Set

open M renaming (R' to R)

X : R → Set
X = R.X

-- Nisse:
-- The open directive did not mention the /module/ R, so (I think
-- that) the code above should be rejected.

-- Andreas:
-- NO, it is a feature that projections can also be accessed via
-- the record /type/.

-- Ulf:
-- According to the suggestion in 836, if you rename the module explicitly
-- the code above breaks (test/fail/Issue836.agda).


module empty where

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

data ⊥ : Set where

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

----------------------------------------------------------------------
-- theorems
----------------------------------------------------------------------
⊥-elim : ⊥ → ∀ {P : Set} → P
⊥-elim ()


module bstd.bake where

open import Agda.Builtin.Nat
open import Agda.Builtin.String
open import Data.Word8.Primitive
open import Data.ByteString.Primitive.Strict
open import Data.Tuple.Base

module bpace
  (Scalar : Set)
  (Point : Set)
  (scalarMul : Scalar → Point → Point)
  (2ᴸ : Set)
  (Key : Set)
  (enc dec : Key → 2ᴸ → 2ᴸ)
  (swu : 2ᴸ → 2ᴸ → Point)
  (Hello : Set)
  (I : Set) (i₀ i₁ : I)
  (kdf : (K Vᵃ Vᵇ : Point) (helloᵃ helloᵇ : Hello) → I → Key)
  (Tag : Set)
  (mac : Key → I → Tag)
  where

  s₂ : (K₂ : Key)
    → (Rᵇ : 2ᴸ)
    → 2ᴸ
  s₂ K₂ Rᵇ = Yᵇ where
    Yᵇ = enc K₂ Rᵇ

  s₃ : (K₂ : Key)
    → (Rᵃ : 2ᴸ) → (uᵃ : Scalar)
    → (Yᵇ : 2ᴸ)
    → 2ᴸ ∥ Point
  s₃ K₂ Rᵃ uᵃ Yᵇ = Yᵃ , Vᵃ where
    Rᵇ = dec K₂ Yᵇ
    Yᵃ = enc K₂ Rᵃ
    W = swu Rᵃ Rᵇ
    Vᵃ = scalarMul uᵃ W

  s₄ : (K₂ : Key)
    → (Rᵇ : 2ᴸ) → (uᵇ : Scalar) → (helloᵇ : Hello)
    → (Yᵃ : 2ᴸ) → (Vᵃ : Point) → (helloᵃ : Hello)
    → Point ∥ Tag
  s₄ K₂ Rᵇ uᵇ helloᵇ Yᵃ Vᵃ helloᵃ = Vᵇ , Tᵇ where
    Rᵃ = dec K₂ Yᵃ
    W = swu Rᵃ Rᵇ
    Vᵇ = scalarMul uᵇ W
    K = scalarMul uᵇ Vᵃ
    K₀ = kdf K Vᵃ Vᵇ helloᵃ helloᵇ i₀
    K₁ = kdf K Vᵃ Vᵇ helloᵃ helloᵇ i₁
    Tᵇ = mac K₁ i₁

  s₅ : (Vᵇ : Point) → (helloᵇ : Hello)
    → (uᵃ : Scalar) → (Vᵃ : Point) → (helloᵃ : Hello)
    → Tag
  s₅ Vᵇ helloᵇ uᵃ Vᵃ helloᵃ = Tᵃ where
    K = scalarMul uᵃ Vᵇ
    K₀ = kdf K Vᵃ Vᵇ helloᵃ helloᵇ i₀
    K₁ = kdf K Vᵃ Vᵇ helloᵃ helloᵇ i₁
    Tᵃ = mac K₁ i₀


------------------------------------------------------------------------
-- Lemmas related to application of substitutions
------------------------------------------------------------------------

-- The record below allows the application operation to be
-- "heterogeneous", applying substitutions containing one kind of term
-- to another kind of term. TODO: This results in some extra
-- complication—is it worth it?

open import Data.Universe.Indexed

module deBruijn.Substitution.Data.Application.Application21
  {i u e} {Uni : IndexedUniverse i u e} where

import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Data.Application.Application
open import deBruijn.Substitution.Data.Basics
open import deBruijn.Substitution.Data.Map
open import deBruijn.Substitution.Data.Simple
open import Function using (_$_)
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

-- Lemmas and definitions related to application.

record Application₂₁
  {t₁} {T₁ : Term-like t₁}
  {t₂} {T₂ : Term-like t₂}

  -- Simple substitutions for the first kind of terms.
  (simple₁ : Simple T₁)

  -- Simple substitutions for the second kind of terms.
  (simple₂ : Simple T₂)

  -- A translation from the first to the second kind of terms.
  (trans : [ T₁ ⟶⁼ T₂ ])
  : Set (i ⊔ u ⊔ e ⊔ t₁ ⊔ t₂) where

  open Term-like T₁ using () renaming (_⊢_ to _⊢₁_; _≅-⊢_ to _≅-⊢₁_)
  open Term-like T₂ using ([_]) renaming (_⊢_ to _⊢₂_; _≅-⊢_ to _≅-⊢₂_)
  open Simple simple₁
    using ()
    renaming ( id to id₁; sub to sub₁; var to var₁
             ; weaken[_] to weaken₁[_]; wk to wk₁
             ; wk-subst to wk-subst₁; wk-subst[_] to wk-subst₁[_]
             ; _↑ to _↑₁; _↑_ to _↑₁_; _↑⁺_ to _↑⁺₁_; _↑₊_ to _↑₊₁_
             ; _↑⋆_ to _↑⋆₁_; _↑⁺⋆_ to _↑⁺⋆₁_; _↑₊⋆_ to _↑₊⋆₁_
             )
  open Simple simple₂
    using ()
    renaming ( id to id₂; id[_] to id₂[_]; var to var₂
             ; weaken to weaken₂; weaken[_] to weaken₂[_]; wk to wk₂
             ; wk-subst to wk-subst₂; wk-subst[_] to wk-subst₂[_]
             ; _↑ to _↑₂; _↑_ to _↑₂_
             )

  field
    application : Application T₁ T₂

  open Application application

  field
    -- The two weakening functions coincide.
    trans-weaken : ∀ {Γ σ τ} (t : Γ ⊢₁ τ) →
                   trans · (weaken₁[ σ ] · t) ≅-⊢₂
                   weaken₂[ σ ] · (trans · t)

    -- The two variable inclusion functions coincide.
    trans-var : ∀ {Γ σ} (x : Γ ∋ σ) → trans · (var₁ · x) ≅-⊢₂ var₂ · x

    -- _/⊢_ and _/∋₁_ coincide for variables.
    var-/⊢ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ σ) (ρ : Sub T₁ ρ̂) →
             var₂ · x /⊢ ρ ≅-⊢₂ trans · (x /∋ ρ)

  -- Application of multiple substitutions to variables.
  --
  -- TODO: Remove?

  app∋⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Subs T₁ ρ̂ → [ Var ⟶ T₂ ] ρ̂
  app∋⋆ ε        = var₂
  app∋⋆ (ε ▻ ρ)  = trans [∘] app∋ ρ
  app∋⋆ (ρs ▻ ρ) = app ρ [∘] app∋⋆ ρs

  infixl 8 _/∋⋆_

  _/∋⋆_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Γ ∋ σ → Subs T₁ ρ̂ → Δ ⊢₂ σ /̂ ρ̂
  x /∋⋆ ρs = app∋⋆ ρs · x

  -- Composition of multiple substitutions.
  --
  -- TODO: Remove?

  ∘⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Subs T₁ ρ̂ → Sub T₂ ρ̂
  ∘⋆ ε        = id₂
  ∘⋆ (ρs ▻ ρ) = ∘⋆ ρs ∘ ρ

  -- Some congruence lemmas.

  trans-cong : ∀ {Γ₁ σ₁} {t₁ : Γ₁ ⊢₁ σ₁}
                 {Γ₂ σ₂} {t₂ : Γ₂ ⊢₁ σ₂} →
               t₁ ≅-⊢₁ t₂ → trans · t₁ ≅-⊢₂ trans · t₂
  trans-cong P.refl = P.refl

  app∋⋆-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T₁ ρ̂₁}
                 {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T₁ ρ̂₂} →
               ρs₁ ≅-⇨⋆ ρs₂ → app∋⋆ ρs₁ ≅-⟶ app∋⋆ ρs₂
  app∋⋆-cong P.refl = [ P.refl ]

  /∋⋆-cong :
    ∀ {Γ₁ Δ₁ σ₁} {x₁ : Γ₁ ∋ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T₁ ρ̂₁}
      {Γ₂ Δ₂ σ₂} {x₂ : Γ₂ ∋ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T₁ ρ̂₂} →
    x₁ ≅-∋ x₂ → ρs₁ ≅-⇨⋆ ρs₂ → x₁ /∋⋆ ρs₁ ≅-⊢₂ x₂ /∋⋆ ρs₂
  /∋⋆-cong P.refl P.refl = P.refl

  ∘⋆-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T₁ ρ̂₁}
              {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T₁ ρ̂₂} →
            ρs₁ ≅-⇨⋆ ρs₂ → ∘⋆ ρs₁ ≅-⇨ ∘⋆ ρs₂
  ∘⋆-cong P.refl = P.refl

  abstract

    -- Applying a composed substitution to a variable is equivalent to
    -- applying all the substitutions one after another.
    --
    -- TODO: Remove this lemma?

    /∋-∘⋆ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ σ) (ρs : Subs T₁ ρ̂) →
            x /∋ ∘⋆ ρs ≅-⊢₂ var₂ · x /⊢⋆ ρs
    /∋-∘⋆ x ε = begin
      [ x /∋ id₂ ]  ≡⟨ Simple./∋-id simple₂ x ⟩
      [ var₂ · x ]  ∎
    /∋-∘⋆ x (ρs ▻ ρ) = begin
      [ x /∋ ∘⋆ ρs ∘ ρ       ]  ≡⟨ /∋-∘ x (∘⋆ ρs) ρ ⟩
      [ x /∋ ∘⋆ ρs /⊢ ρ      ]  ≡⟨ /⊢-cong (/∋-∘⋆ x ρs) P.refl ⟩
      [ var₂ · x /⊢⋆ ρs /⊢ ρ ]  ∎

    -- x /∋⋆ ρs is synonymous with var₂ · x /⊢⋆ ρs.
    --
    -- TODO: Remove?

    var-/⊢⋆ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (x : Γ ∋ σ) (ρs : Subs T₁ ρ̂) →
              var₂ · x /⊢⋆ ρs ≅-⊢₂ x /∋⋆ ρs
    var-/⊢⋆ x ε       = P.refl
    var-/⊢⋆ x (ε ▻ ρ) = begin
      [ var₂ · x /⊢ ρ    ]  ≡⟨ var-/⊢ x ρ ⟩
      [ trans · (x /∋ ρ) ]  ∎
    var-/⊢⋆ x (ρs ▻ ρ₁ ▻ ρ₂) = begin
      [ var₂ · x /⊢⋆ (ρs ▻ ρ₁) /⊢ ρ₂ ]  ≡⟨ /⊢-cong (var-/⊢⋆ x (ρs ▻ ρ₁)) P.refl ⟩
      [ x /∋⋆ (ρs ▻ ρ₁) /⊢ ρ₂        ]  ∎

    -- A helper lemma.

    /∋-≅-⊢-var : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ}
                 (x : Γ ∋ σ) (ρ : Sub T₁ ρ̂) {y : Δ ∋ σ / ρ} →
                 x /∋ ρ ≅-⊢₁ var₁ · y →
                 var₂ · x /⊢ ρ ≅-⊢₂ var₂ · y
    /∋-≅-⊢-var x ρ {y} hyp = begin
      [ var₂ · x /⊢ ρ      ]  ≡⟨ var-/⊢ x ρ ⟩
      [ trans · (x /∋ ρ)   ]  ≡⟨ trans-cong hyp ⟩
      [ trans · (var₁ · y) ]  ≡⟨ trans-var y ⟩
      [ var₂ · y           ]  ∎

    -- A variant of /∋-id.

    var-/⊢-id : ∀ {Γ σ} (x : Γ ∋ σ) → var₂ · x /⊢ id₁ ≅-⊢₂ var₂ · x
    var-/⊢-id x = /∋-≅-⊢-var x id₁ (Simple./∋-id simple₁ x)

    -- A variant of /∋-wk-↑⁺.

    var-/⊢-wk-↑⁺ : ∀ {Γ σ} Γ⁺ {τ} (x : Γ ++⁺ Γ⁺ ∋ τ) →
                   var₂ · x /⊢ wk₁ {σ = σ} ↑⁺₁ Γ⁺ ≅-⊢₂
                   var₂ · (lift weaken∋[ σ ] Γ⁺ · x)
    var-/⊢-wk-↑⁺ Γ⁺ x =
      /∋-≅-⊢-var x (wk₁ ↑⁺₁ Γ⁺) (Simple./∋-wk-↑⁺ simple₁ Γ⁺ x)

    -- A variant of /∋-wk-↑⁺-↑⁺.

    var-/⊢-wk-↑⁺-↑⁺ : ∀ {Γ σ} Γ⁺ Γ⁺⁺ {τ} (x : Γ ++⁺ Γ⁺ ++⁺ Γ⁺⁺ ∋ τ) →
                      var₂ · x /⊢ wk₁ {σ = σ} ↑⁺₁ Γ⁺ ↑⁺₁ Γ⁺⁺ ≅-⊢₂
                      var₂ · (lift (lift weaken∋[ σ ] Γ⁺) Γ⁺⁺ · x)
    var-/⊢-wk-↑⁺-↑⁺ Γ⁺ Γ⁺⁺ x =
      /∋-≅-⊢-var x (wk₁ ↑⁺₁ Γ⁺ ↑⁺₁ Γ⁺⁺)
                 (Simple./∋-wk-↑⁺-↑⁺ simple₁ Γ⁺ Γ⁺⁺ x)

    -- Variants of zero-/∋-↑.

    zero-/⊢-↑ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} σ (ρ : Sub T₁ ρ̂) →
                var₂ · zero /⊢ ρ ↑₁ σ ≅-⊢₂ var₂ · zero[ σ / ρ ]
    zero-/⊢-↑ σ ρ =
      /∋-≅-⊢-var zero (ρ ↑₁ σ) (Simple.zero-/∋-↑ simple₁ σ ρ)

    zero-/⊢⋆-↑⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} σ (ρs : Subs T₁ ρ̂) →
                  var₂ · zero /⊢⋆ ρs ↑⋆₁ σ ≅-⊢₂
                  var₂ · zero[ σ /⋆ ρs ]
    zero-/⊢⋆-↑⋆ σ ε        = P.refl
    zero-/⊢⋆-↑⋆ σ (ρs ▻ ρ) = begin
      [ var₂ · zero /⊢⋆ ρs ↑⋆₁ σ /⊢ ρ ↑₁ ]  ≡⟨ /⊢-cong (zero-/⊢⋆-↑⋆ σ ρs) (P.refl {x = [ ρ ↑₁ (σ /⋆ ρs) ]}) ⟩
      [ var₂ · zero /⊢ ρ ↑₁ (σ /⋆ ρs)    ]  ≡⟨ zero-/⊢-↑ (σ /⋆ ρs) ρ ⟩
      [ var₂ · zero                      ]  ∎

    -- Corollaries of ε-↑⁺⋆ and ε-↑₊⋆.

    /⊢⋆-ε-↑⁺⋆ : ∀ {Γ} Γ⁺ {σ} (t : Γ ++⁺ Γ⁺ ⊢₂ σ) →
                t /⊢⋆ ε ↑⁺⋆₁ Γ⁺ ≅-⊢₂ t
    /⊢⋆-ε-↑⁺⋆ Γ⁺ t = begin
      [ t /⊢⋆ ε ↑⁺⋆₁ Γ⁺ ]  ≡⟨ /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.ε-↑⁺⋆ simple₁ Γ⁺) ⟩
      [ t /⊢⋆ ε         ]  ≡⟨ P.refl ⟩
      [ t               ]  ∎

    /⊢⋆-ε-↑₊⋆ : ∀ {Γ} Γ₊ {σ} (t : Γ ++₊ Γ₊ ⊢₂ σ) →
                t /⊢⋆ ε ↑₊⋆₁ Γ₊ ≅-⊢₂ t
    /⊢⋆-ε-↑₊⋆ Γ₊ t = begin
      [ t /⊢⋆ ε ↑₊⋆₁ Γ₊ ]  ≡⟨ /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.ε-↑₊⋆ simple₁ Γ₊) ⟩
      [ t /⊢⋆ ε         ]  ≡⟨ P.refl ⟩
      [ t               ]  ∎

    -- Corollaries of ▻-↑⁺⋆ and ▻-↑₊⋆.

    /⊢⋆-▻-↑⁺⋆ :
      ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} Γ⁺ {σ}
      (t : Γ ++⁺ Γ⁺ ⊢₂ σ) (ρs : Subs T₁ ρ̂₁) (ρ : Sub T₁ ρ̂₂) →
      t /⊢⋆ (ρs ▻ ρ) ↑⁺⋆₁ Γ⁺ ≅-⊢₂ t /⊢⋆ ρs ↑⁺⋆₁ Γ⁺ /⊢ ρ ↑⁺₁ (Γ⁺ /⁺⋆ ρs)
    /⊢⋆-▻-↑⁺⋆ Γ⁺ t ρs ρ =
      /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.▻-↑⁺⋆ simple₁ ρs ρ Γ⁺)

    /⊢⋆-▻-↑₊⋆ :
      ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} Γ₊ {σ}
      (t : Γ ++₊ Γ₊ ⊢₂ σ) (ρs : Subs T₁ ρ̂₁) (ρ : Sub T₁ ρ̂₂) →
      t /⊢⋆ (ρs ▻ ρ) ↑₊⋆₁ Γ₊ ≅-⊢₂ t /⊢⋆ ρs ↑₊⋆₁ Γ₊ /⊢ ρ ↑₊₁ (Γ₊ /₊⋆ ρs)
    /⊢⋆-▻-↑₊⋆ Γ₊ t ρs ρ =
      /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.▻-↑₊⋆ simple₁ ρs ρ Γ₊)

    -- Corollaries of ε-↑⁺⋆/ε-↑₊⋆ and ▻-↑⁺⋆/▻-↑₊⋆.

    /⊢⋆-ε-▻-↑⁺⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} Γ⁺ {σ}
                  (t : Γ ++⁺ Γ⁺ ⊢₂ σ) (ρ : Sub T₁ ρ̂) →
                  t /⊢⋆ (ε ▻ ρ) ↑⁺⋆₁ Γ⁺ ≅-⊢₂ t /⊢ ρ ↑⁺₁ Γ⁺
    /⊢⋆-ε-▻-↑⁺⋆ Γ⁺ t ρ = begin
      [ t /⊢⋆ (ε ▻ ρ) ↑⁺⋆₁ Γ⁺               ]  ≡⟨ /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.▻-↑⁺⋆ simple₁ ε ρ Γ⁺) ⟩
      [ t /⊢⋆ ε ↑⁺⋆₁ Γ⁺ /⊢ ρ ↑⁺₁ (Γ⁺ /̂⁺ îd) ]  ≡⟨ /⊢-cong (/⊢⋆-ε-↑⁺⋆ Γ⁺ t) (Simple.↑⁺-cong simple₁ P.refl (/̂⁺-îd Γ⁺)) ⟩
      [ t               /⊢ ρ ↑⁺₁ Γ⁺         ]  ∎

    /⊢⋆-ε-▻-▻-↑⁺⋆ :
      ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} Γ⁺ {σ}
      (t : Γ ++⁺ Γ⁺ ⊢₂ σ) (ρ₁ : Sub T₁ ρ̂₁) (ρ₂ : Sub T₁ ρ̂₂) →
      t /⊢⋆ (ε ▻ ρ₁ ▻ ρ₂) ↑⁺⋆₁ Γ⁺ ≅-⊢₂
      t /⊢ ρ₁ ↑⁺₁ Γ⁺ /⊢ ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁)
    /⊢⋆-ε-▻-▻-↑⁺⋆ Γ⁺ t ρ₁ ρ₂ = begin
      [ t /⊢⋆ (ε ▻ ρ₁ ▻ ρ₂) ↑⁺⋆₁ Γ⁺                 ]  ≡⟨ /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.▻-↑⁺⋆ simple₁ (ε ▻ ρ₁) ρ₂ Γ⁺) ⟩
      [ t /⊢⋆ (ε ▻ ρ₁) ↑⁺⋆₁ Γ⁺ /⊢ ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁) ]  ≡⟨ /⊢-cong (/⊢⋆-ε-▻-↑⁺⋆ Γ⁺ t ρ₁) P.refl ⟩
      [ t /⊢ ρ₁ ↑⁺₁ Γ⁺ /⊢ ρ₂ ↑⁺₁ (Γ⁺ /⁺ ρ₁)         ]  ∎

    /⊢⋆-ε-▻-↑₊⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} Γ₊ {σ}
                  (t : Γ ++₊ Γ₊ ⊢₂ σ) (ρ : Sub T₁ ρ̂) →
                  t /⊢⋆ (ε ▻ ρ) ↑₊⋆₁ Γ₊ ≅-⊢₂ t /⊢ ρ ↑₊₁ Γ₊
    /⊢⋆-ε-▻-↑₊⋆ Γ₊ t ρ = begin
      [ t /⊢⋆ (ε ▻ ρ) ↑₊⋆₁ Γ₊               ]  ≡⟨ /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.▻-↑₊⋆ simple₁ ε ρ Γ₊) ⟩
      [ t /⊢⋆ ε ↑₊⋆₁ Γ₊ /⊢ ρ ↑₊₁ (Γ₊ /̂₊ îd) ]  ≡⟨ /⊢-cong (/⊢⋆-ε-↑₊⋆ Γ₊ t) (Simple.↑₊-cong simple₁ P.refl (/̂₊-îd Γ₊)) ⟩
      [ t               /⊢ ρ ↑₊₁ Γ₊         ]  ∎

    /⊢⋆-ε-▻-▻-↑₊⋆ :
      ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} Γ₊ {σ}
      (t : Γ ++₊ Γ₊ ⊢₂ σ) (ρ₁ : Sub T₁ ρ̂₁) (ρ₂ : Sub T₁ ρ̂₂) →
      t /⊢⋆ (ε ▻ ρ₁ ▻ ρ₂) ↑₊⋆₁ Γ₊ ≅-⊢₂
      t /⊢ ρ₁ ↑₊₁ Γ₊ /⊢ ρ₂ ↑₊₁ (Γ₊ /₊ ρ₁)
    /⊢⋆-ε-▻-▻-↑₊⋆ Γ₊ t ρ₁ ρ₂ = begin
      [ t /⊢⋆ (ε ▻ ρ₁ ▻ ρ₂) ↑₊⋆₁ Γ₊                 ]  ≡⟨ /⊢⋆-cong (P.refl {x = [ t ]}) (Simple.▻-↑₊⋆ simple₁ (ε ▻ ρ₁) ρ₂ Γ₊) ⟩
      [ t /⊢⋆ (ε ▻ ρ₁) ↑₊⋆₁ Γ₊ /⊢ ρ₂ ↑₊₁ (Γ₊ /₊ ρ₁) ]  ≡⟨ /⊢-cong (/⊢⋆-ε-▻-↑₊⋆ Γ₊ t ρ₁) P.refl ⟩
      [ t /⊢ ρ₁ ↑₊₁ Γ₊ /⊢ ρ₂ ↑₊₁ (Γ₊ /₊ ρ₁)         ]  ∎

    -- Application of sub cancels one occurrence of suc.

    suc-/⊢-sub : ∀ {Γ σ τ} (x : Γ ∋ σ) (t : Γ ⊢₁ τ) →
                 var₂ · suc x /⊢ sub₁ t ≅-⊢₂ var₂ · x
    suc-/⊢-sub x t = begin
      [ var₂ · suc x /⊢ sub₁ t    ]  ≡⟨ var-/⊢ (suc x) (sub₁ t) ⟩
      [ trans · (suc x /∋ sub₁ t) ]  ≡⟨ P.refl ⟩
      [ trans · (x /∋ id₁)        ]  ≡⟨ trans-cong (Simple./∋-id simple₁ x) ⟩
      [ trans · (var₁ · x)        ]  ≡⟨ trans-var x ⟩
      [ var₂ · x                  ]  ∎

    -- First weakening and then substituting something for the first
    -- variable is equivalent to doing nothing.

    wk-∘-sub : ∀ {Γ σ} (t : Γ ⊢₁ σ) → wk₂ ∘ sub₁ t ≅-⇨ id₂[ Γ ]
    wk-∘-sub t = extensionality P.refl λ x → begin
      [ x /∋ wk₂ ∘ sub₁ t      ]  ≡⟨ /∋-∘ x wk₂ (sub₁ t) ⟩
      [ x /∋ wk₂ /⊢ sub₁ t     ]  ≡⟨ /⊢-cong (Simple./∋-wk simple₂ x) P.refl ⟩
      [ var₂ · suc x /⊢ sub₁ t ]  ≡⟨ suc-/⊢-sub x t ⟩
      [ var₂ · x               ]  ≡⟨ P.sym $ Simple./∋-id simple₂ x ⟩
      [ x /∋ id₂               ]  ∎

    -- id is a left identity of _∘_ (more or less).

    id-∘ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₁ ρ̂) → id₂ ∘ ρ ≅-⇨ map trans ρ
    id-∘ ρ = extensionality P.refl λ x → begin
      [ x /∋ id₂ ∘ ρ     ]  ≡⟨ /∋-∘ x id₂ ρ ⟩
      [ x /∋ id₂ /⊢ ρ    ]  ≡⟨ /⊢-cong (Simple./∋-id simple₂ x) (P.refl {x = [ ρ ]}) ⟩
      [ var₂ · x /⊢ ρ    ]  ≡⟨ var-/⊢ x ρ ⟩
      [ trans · (x /∋ ρ) ]  ≡⟨ P.sym $ /∋-map x trans ρ ⟩
      [ x /∋ map trans ρ ]  ∎

    -- One can translate a substitution either before or after
    -- weakening it.

    map-trans-wk-subst : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₁ ρ̂) →
                         map trans (wk-subst₁[ σ ] ρ) ≅-⇨
                         wk-subst₂[ σ ] (map trans ρ)
    map-trans-wk-subst {σ = σ} ρ = begin
      [ map trans (wk-subst₁[ σ ] ρ)   ]  ≡⟨ P.sym $ map-[∘] trans weaken₁[ σ ] ρ ⟩
      [ map (trans [∘] weaken₁[ σ ]) ρ ]  ≡⟨ map-cong-ext₁ P.refl trans-weaken (P.refl {x = [ ρ ]}) ⟩
      [ map (weaken₂ [∘] trans) ρ      ]  ≡⟨ map-[∘] weaken₂ trans ρ ⟩
      [ wk-subst₂ (map trans ρ)        ]  ∎

    -- One can translate a substitution either before or after lifting
    -- it.

    map-trans-↑ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} (ρ : Sub T₁ ρ̂) →
                  map trans (ρ ↑₁ σ) ≅-⇨ map trans ρ ↑₂ σ
    map-trans-↑ {σ = σ} ρ = begin
      [ map trans (ρ ↑₁ σ)                                       ]  ≡⟨ map-cong (trans ∎-⟶) (Simple.unfold-↑ simple₁ ρ) ⟩
      [ map trans (wk-subst₁[ σ / ρ ] ρ ▻ var₁ · zero)           ]  ≡⟨ map-▻ trans (wk-subst₁ ρ) _ ⟩
      [ map trans (wk-subst₁[ σ / ρ ] ρ) ▻ trans · (var₁ · zero) ]  ≡⟨ ▻⇨-cong P.refl (map-trans-wk-subst ρ) (trans-var zero) ⟩
      [ wk-subst₂ (map trans ρ) ▻ var₂ · zero                    ]  ≡⟨ P.sym $ Simple.unfold-↑ simple₂ (map trans ρ) ⟩
      [ map trans ρ ↑₂                                           ]  ∎

  open Application application public


------------------------------------------------------------------------
-- A sequential colimit for which everything except for the "base
-- case" is erased
------------------------------------------------------------------------

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

-- The definition of sequential colimits and the statement of the
-- non-dependent universal property are based on those in van Doorn's
-- "Constructing the Propositional Truncation using Non-recursive
-- HITs".

-- The module is parametrised by a notion of equality. The higher
-- constructor of the HIT defining sequential colimits uses path
-- equality, but the supplied notion of equality is used for many
-- other things.

import Equality.Path as P

module Colimit.Sequential.Very-erased
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

open import Prelude hiding ([_,_])

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Erased.Cubical eq

private
  variable
    a b p₀ p₊ q : Level
    A B P₀      : Type a
    P₊          : A → Type p₊
    n           : ℕ
    e step₀ x   : A

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

-- A sequential colimit for which everything except for the "base
-- case" is erased.

data Colimitᴱ
       (P₀ : Type p₀)
       (@0 P₊ : ℕ → Type p₊)
       (@0 step₀ : P₀ → P₊ zero)
       (@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)) :
       Type (p₀ ⊔ p₊) where
  ∣_∣₀        : P₀ → Colimitᴱ P₀ P₊ step₀ step₊
  @0 ∣_∣₊     : P₊ n → Colimitᴱ P₀ P₊ step₀ step₊
  @0 ∣∣₊≡∣∣₀ᴾ : (x : P₀) → ∣ step₀ x ∣₊ P.≡ ∣ x ∣₀
  @0 ∣∣₊≡∣∣₊ᴾ : (x : P₊ n) → ∣ step₊ x ∣₊ P.≡ ∣ x ∣₊

-- A variant of ∣∣₊≡∣∣₀ᴾ.

@0 ∣∣₊≡∣∣₀ :
  {step₊ : ∀ {n} → P₊ n → P₊ (suc n)} (x : P₀) →
  _≡_ {A = Colimitᴱ P₀ P₊ step₀ step₊} ∣ step₀ x ∣₊ ∣ x ∣₀
∣∣₊≡∣∣₀ x = _↔_.from ≡↔≡ (∣∣₊≡∣∣₀ᴾ x)

-- A variant of ∣∣₊≡∣∣₊ᴾ.

@0 ∣∣₊≡∣∣₊ :
  {step₊ : ∀ {n} → P₊ n → P₊ (suc n)} (x : P₊ n) →
  _≡_ {A = Colimitᴱ P₀ P₊ step₀ step₊} ∣ step₊ x ∣₊ ∣ x ∣₊
∣∣₊≡∣∣₊ x = _↔_.from ≡↔≡ (∣∣₊≡∣∣₊ᴾ x)

------------------------------------------------------------------------
-- Eliminators

-- A dependent eliminator, expressed using paths.

record Elimᴾ
         {P₀ : Type p₀}
         {@0 P₊ : ℕ → Type p₊}
         {@0 step₀ : P₀ → P₊ zero}
         {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
         (Q : Colimitᴱ P₀ P₊ step₀ step₊ → Type q) :
         Type (p₀ ⊔ p₊ ⊔ q) where
  no-eta-equality
  field
    ∣∣₀ʳ        : (x : P₀) → Q ∣ x ∣₀
    @0 ∣∣₊ʳ     : (x : P₊ n) → Q ∣ x ∣₊
    @0 ∣∣₊≡∣∣₀ʳ : (x : P₀) →
                  P.[ (λ i → Q (∣∣₊≡∣∣₀ᴾ x i)) ] ∣∣₊ʳ (step₀ x) ≡ ∣∣₀ʳ x
    @0 ∣∣₊≡∣∣₊ʳ : (x : P₊ n) →
                  P.[ (λ i → Q (∣∣₊≡∣∣₊ᴾ x i)) ] ∣∣₊ʳ (step₊ x) ≡ ∣∣₊ʳ x

open Elimᴾ public

elimᴾ :
  {@0 P₊ : ℕ → Type p₊}
  {@0 step₀ : P₀ → P₊ zero}
  {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
  {Q : Colimitᴱ P₀ P₊ step₀ step₊ → Type q} →
  Elimᴾ Q → (x : Colimitᴱ P₀ P₊ step₀ step₊) → Q x
elimᴾ {P₀ = P₀} {P₊ = P₊} {step₀ = step₀} {step₊ = step₊} {Q = Q} e =
  helper
  where
  module E = Elimᴾ e

  helper : (x : Colimitᴱ P₀ P₊ step₀ step₊) → Q x
  helper ∣ x ∣₀         = E.∣∣₀ʳ x
  helper ∣ x ∣₊         = E.∣∣₊ʳ x
  helper (∣∣₊≡∣∣₀ᴾ x i) = E.∣∣₊≡∣∣₀ʳ x i
  helper (∣∣₊≡∣∣₊ᴾ x i) = E.∣∣₊≡∣∣₊ʳ x i

-- A non-dependent eliminator, expressed using paths.

record Recᴾ
         (P₀ : Type p₀)
         (@0 P₊ : ℕ → Type p₊)
         (@0 step₀ : P₀ → P₊ zero)
         (@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n))
         (B : Type b) : Type (p₀ ⊔ p₊ ⊔ b) where
  no-eta-equality
  field
    ∣∣₀ʳ        : P₀ → B
    @0 ∣∣₊ʳ     : P₊ n → B
    @0 ∣∣₊≡∣∣₀ʳ : (x : P₀) → ∣∣₊ʳ (step₀ x) P.≡ ∣∣₀ʳ x
    @0 ∣∣₊≡∣∣₊ʳ : (x : P₊ n) → ∣∣₊ʳ (step₊ x) P.≡ ∣∣₊ʳ x

open Recᴾ public

recᴾ :
  {@0 P₊ : ℕ → Type p₊}
  {@0 step₀ : P₀ → P₊ zero}
  {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)} →
  Recᴾ P₀ P₊ step₀ step₊ B → Colimitᴱ P₀ P₊ step₀ step₊ → B
recᴾ r = elimᴾ λ where
    .∣∣₀ʳ     → R.∣∣₀ʳ
    .∣∣₊ʳ     → R.∣∣₊ʳ
    .∣∣₊≡∣∣₀ʳ → R.∣∣₊≡∣∣₀ʳ
    .∣∣₊≡∣∣₊ʳ → R.∣∣₊≡∣∣₊ʳ
  where
  module R = Recᴾ r

-- A dependent eliminator.

record Elim
         {P₀ : Type p₀}
         {@0 P₊ : ℕ → Type p₊}
         {@0 step₀ : P₀ → P₊ zero}
         {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
         (Q : Colimitᴱ P₀ P₊ step₀ step₊ → Type q) :
         Type (p₀ ⊔ p₊ ⊔ q) where
  no-eta-equality
  field
    ∣∣₀ʳ        : (x : P₀) → Q ∣ x ∣₀
    @0 ∣∣₊ʳ     : (x : P₊ n) → Q ∣ x ∣₊
    @0 ∣∣₊≡∣∣₀ʳ : (x : P₀) →
                  subst Q (∣∣₊≡∣∣₀ x) (∣∣₊ʳ (step₀ x)) ≡ ∣∣₀ʳ x
    @0 ∣∣₊≡∣∣₊ʳ : (x : P₊ n) →
                  subst Q (∣∣₊≡∣∣₊ x) (∣∣₊ʳ (step₊ x)) ≡ ∣∣₊ʳ x

open Elim public

elim :
  {@0 P₊ : ℕ → Type p₊}
  {@0 step₀ : P₀ → P₊ zero}
  {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
  {Q : Colimitᴱ P₀ P₊ step₀ step₊ → Type q} →
  Elim Q → (x : Colimitᴱ P₀ P₊ step₀ step₊) → Q x
elim e = elimᴾ λ where
    .∣∣₀ʳ       → E.∣∣₀ʳ
    .∣∣₊ʳ       → E.∣∣₊ʳ
    .∣∣₊≡∣∣₀ʳ x → subst≡→[]≡ (E.∣∣₊≡∣∣₀ʳ x)
    .∣∣₊≡∣∣₊ʳ x → subst≡→[]≡ (E.∣∣₊≡∣∣₊ʳ x)
  where
  module E = Elim e

-- Two "computation" rules.

@0 elim-∣∣₊≡∣∣₀ : dcong (elim e) (∣∣₊≡∣∣₀ x) ≡ Elim.∣∣₊≡∣∣₀ʳ e x
elim-∣∣₊≡∣∣₀ = dcong-subst≡→[]≡ (refl _)

@0 elim-∣∣₊≡∣∣₊ : dcong (elim e) (∣∣₊≡∣∣₊ x) ≡ Elim.∣∣₊≡∣∣₊ʳ e x
elim-∣∣₊≡∣∣₊ = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator.

record Rec
         (P₀ : Type p₀)
         (@0 P₊ : ℕ → Type p₊)
         (@0 step₀ : P₀ → P₊ zero)
         (@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n))
         (B : Type b) : Type (p₀ ⊔ p₊ ⊔ b) where
  no-eta-equality
  field
    ∣∣₀ʳ        : P₀ → B
    @0 ∣∣₊ʳ     : P₊ n → B
    @0 ∣∣₊≡∣∣₀ʳ : (x : P₀) → ∣∣₊ʳ (step₀ x) ≡ ∣∣₀ʳ x
    @0 ∣∣₊≡∣∣₊ʳ : (x : P₊ n) → ∣∣₊ʳ (step₊ x) ≡ ∣∣₊ʳ x

open Rec public

rec :
  {@0 P₊ : ℕ → Type p₊}
  {@0 step₀ : P₀ → P₊ zero}
  {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)} →
  Rec P₀ P₊ step₀ step₊ B → Colimitᴱ P₀ P₊ step₀ step₊ → B
rec r = recᴾ λ where
    .∣∣₀ʳ       → R.∣∣₀ʳ
    .∣∣₊ʳ       → R.∣∣₊ʳ
    .∣∣₊≡∣∣₀ʳ x → _↔_.to ≡↔≡ (R.∣∣₊≡∣∣₀ʳ x)
    .∣∣₊≡∣∣₊ʳ x → _↔_.to ≡↔≡ (R.∣∣₊≡∣∣₊ʳ x)
  where
  module R = Rec r

-- Two "computation" rules.

@0 rec-∣∣₊≡∣∣₀ :
  {step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
  {r : Rec P₀ P₊ step₀ step₊ B}
  {x : P₀} →
  cong (rec r) (∣∣₊≡∣∣₀ x) ≡ Rec.∣∣₊≡∣∣₀ʳ r x
rec-∣∣₊≡∣∣₀ = cong-≡↔≡ (refl _)

@0 rec-∣∣₊≡∣∣₊ :
  {step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
  {r : Rec P₀ P₊ step₀ step₊ B}
  {x : P₊ n} →
  cong (rec r) (∣∣₊≡∣∣₊ x) ≡ Rec.∣∣₊≡∣∣₊ʳ r x
rec-∣∣₊≡∣∣₊ = cong-≡↔≡ (refl _)

------------------------------------------------------------------------
-- The universal property

-- The universal property of the sequential colimit.

universal-property :
  {@0 P₊ : ℕ → Type p₊}
  {@0 step₀ : P₀ → P₊ zero}
  {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)} →
  (Colimitᴱ P₀ P₊ step₀ step₊ → B)
    ≃
  (∃ λ (f₀ : P₀ → B) →
     Erased (∃ λ (f₊ : ∀ n → P₊ n → B) →
               (∀ x → f₊ zero (step₀ x) ≡ f₀ x) ×
               (∀ n x → f₊ (suc n) (step₊ x) ≡ f₊ n x)))
universal-property
  {P₀ = P₀} {B = B} {P₊ = P₊} {step₀ = step₀} {step₊ = step₊} =
  Eq.↔→≃ to from to∘from from∘to
  where
  to :
    (Colimitᴱ P₀ P₊ step₀ step₊ → B) →
    ∃ λ (f₀ : P₀ → B) →
      Erased (∃ λ (f₊ : ∀ n → P₊ n → B) →
                (∀ x → f₊ zero (step₀ x) ≡ f₀ x) ×
                (∀ n x → f₊ (suc n) (step₊ x) ≡ f₊ n x))
  to h = h ∘ ∣_∣₀
       , [ (λ _ → h ∘ ∣_∣₊)
         , (λ x →
              h ∣ step₀ x ∣₊  ≡⟨ cong h (∣∣₊≡∣∣₀ x) ⟩∎
              h ∣ x ∣₀        ∎)
         , (λ _ x →
              h ∣ step₊ x ∣₊  ≡⟨ cong h (∣∣₊≡∣∣₊ x) ⟩∎
              h ∣ x ∣₊        ∎)
         ]

  from :
    (∃ λ (f₀ : P₀ → B) →
       Erased (∃ λ (f₊ : ∀ n → P₊ n → B) →
                 (∀ x → f₊ zero (step₀ x) ≡ f₀ x) ×
                 (∀ n x → f₊ (suc n) (step₊ x) ≡ f₊ n x))) →
    Colimitᴱ P₀ P₊ step₀ step₊ → B
  from (f₀ , [ f₊ , g₀ , g₊ ]) = rec λ where
    .∣∣₀ʳ     → f₀
    .∣∣₊ʳ     → f₊ _
    .∣∣₊≡∣∣₀ʳ → g₀
    .∣∣₊≡∣∣₊ʳ → g₊ _

  to∘from : ∀ p → to (from p) ≡ p
  to∘from (f₀ , [ f₊ , g₀ , g₊ ]) =
    cong (f₀ ,_) $ []-cong
      [ cong (f₊ ,_) $ cong₂ _,_
          (⟨ext⟩ λ x →
             cong (rec _) (∣∣₊≡∣∣₀ x)  ≡⟨ rec-∣∣₊≡∣∣₀ ⟩∎
             g₀ x                      ∎)
          (⟨ext⟩ λ n → ⟨ext⟩ λ x →
             cong (rec _) (∣∣₊≡∣∣₊ x)  ≡⟨ rec-∣∣₊≡∣∣₊ ⟩∎
             g₊ n x                    ∎)
      ]

  from∘to : ∀ h → from (to h) ≡ h
  from∘to h = ⟨ext⟩ $ elim λ where
    .∣∣₀ʳ _     → refl _
    .∣∣₊ʳ _     → refl _
    .∣∣₊≡∣∣₀ʳ x →
      subst (λ z → from (to h) z ≡ h z) (∣∣₊≡∣∣₀ x) (refl _)  ≡⟨ subst-in-terms-of-trans-and-cong ⟩

      trans (sym (cong (from (to h)) (∣∣₊≡∣∣₀ x)))
        (trans (refl _) (cong h (∣∣₊≡∣∣₀ x)))                 ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                   rec-∣∣₊≡∣∣₀
                                                                   (trans-reflˡ _) ⟩

      trans (sym (cong h (∣∣₊≡∣∣₀ x))) (cong h (∣∣₊≡∣∣₀ x))   ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                  ∎
    .∣∣₊≡∣∣₊ʳ x →
      subst (λ z → from (to h) z ≡ h z) (∣∣₊≡∣∣₊ x) (refl _)  ≡⟨ subst-in-terms-of-trans-and-cong ⟩

      trans (sym (cong (from (to h)) (∣∣₊≡∣∣₊ x)))
        (trans (refl _) (cong h (∣∣₊≡∣∣₊ x)))                 ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                   rec-∣∣₊≡∣∣₊
                                                                   (trans-reflˡ _) ⟩

      trans (sym (cong h (∣∣₊≡∣∣₊ x))) (cong h (∣∣₊≡∣∣₊ x))   ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                  ∎

-- A dependently typed variant of the sequential colimit's universal
-- property.

universal-property-Π :
  {@0 P₊ : ℕ → Type p₊}
  {@0 step₀ : P₀ → P₊ zero}
  {@0 step₊ : ∀ {n} → P₊ n → P₊ (suc n)}
  {Q : Colimitᴱ P₀ P₊ step₀ step₊ → Type q} →
  ((x : Colimitᴱ P₀ P₊ step₀ step₊) → Q x)
    ≃
  (∃ λ (f₀ : (x : P₀) → Q ∣ x ∣₀) →
     Erased (∃ λ (f₊ : ∀ n (x : P₊ n) → Q ∣ x ∣₊) →
               (∀ x → subst Q (∣∣₊≡∣∣₀ x) (f₊ zero (step₀ x)) ≡ f₀ x) ×
               (∀ n x → subst Q (∣∣₊≡∣∣₊ x) (f₊ (suc n) (step₊ x)) ≡
                        f₊ n x)))
universal-property-Π
  {P₀ = P₀} {P₊ = P₊} {step₀ = step₀} {step₊ = step₊} {Q = Q} =
  Eq.↔→≃ to from to∘from from∘to
  where
  RHS =
    ∃ λ (f₀ : (x : P₀) → Q ∣ x ∣₀) →
      Erased (∃ λ (f₊ : ∀ n (x : P₊ n) → Q ∣ x ∣₊) →
                (∀ x → subst Q (∣∣₊≡∣∣₀ x) (f₊ zero (step₀ x)) ≡ f₀ x) ×
                (∀ n x → subst Q (∣∣₊≡∣∣₊ x) (f₊ (suc n) (step₊ x)) ≡
                         f₊ n x))

  to : ((x : Colimitᴱ P₀ P₊ step₀ step₊) → Q x) → RHS
  to h = h ∘ ∣_∣₀
       , [ (λ _ → h ∘ ∣_∣₊)
         , (λ x →
              subst Q (∣∣₊≡∣∣₀ x) (h ∣ step₀ x ∣₊)  ≡⟨ dcong h (∣∣₊≡∣∣₀ x) ⟩∎
              h ∣ x ∣₀                              ∎)
         , (λ _ x →
              subst Q (∣∣₊≡∣∣₊ x) (h ∣ step₊ x ∣₊)  ≡⟨ dcong h (∣∣₊≡∣∣₊ x) ⟩∎
              h ∣ x ∣₊                              ∎)
         ]

  from :
    RHS → (x : Colimitᴱ P₀ P₊ step₀ step₊) → Q x
  from (f₀ , [ f₊ , g₀ , g₊ ]) = elim λ where
    .∣∣₀ʳ     → f₀
    .∣∣₊ʳ     → f₊ _
    .∣∣₊≡∣∣₀ʳ → g₀
    .∣∣₊≡∣∣₊ʳ → g₊ _

  to∘from : ∀ p → to (from p) ≡ p
  to∘from (f₀ , [ f₊ , g₀ , g₊ ]) =
    cong (f₀ ,_) $ []-cong
      [ cong (f₊ ,_) $ cong₂ _,_
          (⟨ext⟩ λ x →
             dcong (elim _) (∣∣₊≡∣∣₀ x)  ≡⟨ elim-∣∣₊≡∣∣₀ ⟩∎
             g₀ x                        ∎)
          (⟨ext⟩ λ n → ⟨ext⟩ λ x →
             dcong (elim _) (∣∣₊≡∣∣₊ x)  ≡⟨ elim-∣∣₊≡∣∣₊ ⟩∎
             g₊ n x                      ∎)
      ]

  from∘to : ∀ h → from (to h) ≡ h
  from∘to h = ⟨ext⟩ $ elim λ where
    .∣∣₀ʳ _     → refl _
    .∣∣₊ʳ _     → refl _
    .∣∣₊≡∣∣₀ʳ x →
      subst (λ z → from (to h) z ≡ h z) (∣∣₊≡∣∣₀ x) (refl _)   ≡⟨ subst-in-terms-of-trans-and-dcong ⟩

      trans (sym (dcong (from (to h)) (∣∣₊≡∣∣₀ x)))
        (trans (cong (subst Q (∣∣₊≡∣∣₀ x)) (refl _))
           (dcong h (∣∣₊≡∣∣₀ x)))                              ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                    elim-∣∣₊≡∣∣₀
                                                                    (trans (cong (flip trans _) $ cong-refl _) $
                                                                     trans-reflˡ _) ⟩

      trans (sym (dcong h (∣∣₊≡∣∣₀ x))) (dcong h (∣∣₊≡∣∣₀ x))  ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                   ∎
    .∣∣₊≡∣∣₊ʳ x →
      subst (λ z → from (to h) z ≡ h z) (∣∣₊≡∣∣₊ x) (refl _)   ≡⟨ subst-in-terms-of-trans-and-dcong ⟩

      trans (sym (dcong (from (to h)) (∣∣₊≡∣∣₊ x)))
        (trans (cong (subst Q (∣∣₊≡∣∣₊ x)) (refl _))
           (dcong h (∣∣₊≡∣∣₊ x)))                              ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                    elim-∣∣₊≡∣∣₊
                                                                    (trans (cong (flip trans _) $ cong-refl _) $
                                                                     trans-reflˡ _) ⟩

      trans (sym (dcong h (∣∣₊≡∣∣₊ x))) (dcong h (∣∣₊≡∣∣₊ x))  ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                   ∎


module Selective.Examples.PingPong where

open import Selective.ActorMonad public
open import Prelude

-- An example including three actors: spawner, pinger, ponger
--
-- Spawner is the actor that starts it all.
-- Spawner spawns both pinger and ponger.
-- Then spawner send the reference of ponger to pinger,
-- and the reference of pinger to ponger.
--
-- Pinger is an actor that can receive Bool messages.
-- Pinger counts the number of 'false' messages it receives, until it receives a 'true'
--
-- Ponger is an actor that can receive Nat messages.
-- Ponger keeps sending 'false' until it receives a message containing 10.

Spawnbox : InboxShape
Spawnbox = []

ℕ₁ : Set₁
ℕ₁ = Lift (lsuc lzero) ℕ

Bool₁ : Set₁
Bool₁ = Lift (lsuc lzero) Bool

mutual
  PingValues = [ Bool ]ˡ
  PongValues = [ ℕ ]ˡ

  PingRefs : TypingContext
  PingRefs = [ ⊠-of-values PongValues ]ˡ
  PongRefs : TypingContext
  PongRefs = [ ⊠-of-values PingValues ]ˡ

  PongReferenceMessage : MessageType
  PongReferenceMessage = [ ReferenceType (⊠-of-values PongValues) ]ˡ

  BoolMessage : MessageType
  BoolMessage = [ ValueType Bool ]ˡ

  Pingbox : InboxShape
  Pingbox = BoolMessage ∷ [ PongReferenceMessage ]ˡ

  PingReferenceMessage : MessageType
  PingReferenceMessage = [ ReferenceType (⊠-of-values PingValues) ]ˡ

  NatMessage : MessageType
  NatMessage = [ ValueType ℕ ]ˡ

  Pongbox : InboxShape
  Pongbox = NatMessage ∷ [ PingReferenceMessage ]ˡ

constPingrefs : {A : Set₁} → (A → TypingContext)
constPingrefs _ =  PingRefs

pingMainActor : (i : Size) (A : Set₁) → Set₂
pingMainActor i A = ∞ActorM i Pingbox A PingRefs constPingrefs

pinger : ∀ {i} → ∞ActorM (↑ i) Pingbox ⊤₁ [] constPingrefs
pinger .force = waitForPong ∞>> pingMain 0
  where
    waitForPong : ∀ {i} → ∞ActorM i Pingbox ⊤₁ [] constPingrefs
    waitForPong = selective-receive (λ {
      (Msg Z _) → false
      ; (Msg (S Z) _) → true
      ; (Msg (S (S ())) _)
      }) >>= λ {
        record { msg = (Msg Z _) ; msg-ok = () }
        ; record { msg = (Msg (S Z) _) ; msg-ok = refl } → return _
        ; record { msg = (Msg (S (S ())) x₁) }
      }
    waitForPingValue : ∀ {i Γ} → ∞ActorM i Pingbox Bool₁ Γ (λ _ → Γ)
    waitForPingValue = selective-receive (λ {
      (Msg Z _) → true
      ; (Msg (S Z) _) → false
      ; (Msg (S (S ())) _)
      }) >>= λ {
      record { msg = (Msg Z (b ∷ [])) ; msg-ok = refl } → return b
      ; record { msg = (Msg (S Z) _) ; msg-ok = () }
      ; record { msg = (Msg (S (S ())) x₁) }
      }
    pingMain : ∀ {i} → ℕ → pingMainActor i ⊤₁
    pingMain n .force = waitForPingValue ∞>>= λ
      { (lift false) → (Z ![t: Z ] ([ lift n ]ᵃ)) >> pingMain (suc n)
      ; (lift true) → return _}

constPongrefs : {A : Set₁} → (A → TypingContext)
constPongrefs _ = PongRefs

pongMainActor : (i : Size) (A : Set₁) → Set₂
pongMainActor i A = ∞ActorM i Pongbox A PongRefs constPongrefs

ponger : ∀ {i} → ∞ActorM (↑ i) Pongbox ⊤₁ [] constPongrefs
ponger .force = waitForPing ∞>> ((Z ![t: Z ] ([ lift false ]ᵃ)) >> pongMain)
  where
    waitForPing : ∀ {i} → ∞ActorM i Pongbox ⊤₁ [] constPongrefs
    waitForPing = selective-receive (λ {
      (Msg Z _) → false
      ; (Msg (S Z) _) → true
      ; (Msg (S (S ())) _)
      }) >>= λ {
        record { msg = (Msg Z _) ; msg-ok = () }
        ; record { msg = (Msg (S Z) x₁) ; msg-ok = refl } → return _
        ; record { msg = (Msg (S (S ())) x₁) }
        }
    waitForPongValue : ∀ {i Γ} → ∞ActorM i Pongbox ℕ₁ Γ (λ _ → Γ)
    waitForPongValue = selective-receive (λ {
      (Msg Z _) → true
      ; (Msg (S Z) _) → false
      ; (Msg (S (S ())) _)
      }) >>= λ {
        record { msg = (Msg Z (n ∷ [])) ; msg-ok = refl } → return n
        ; record { msg = (Msg (S Z) x₁) ; msg-ok = () }
        ; record { msg = (Msg (S (S ())) x₁) }
        }
    pongMain : ∀ {i} → pongMainActor i ⊤₁
    pongMain .force = waitForPongValue ∞>>= λ {
      (lift 10) → Z ![t: Z ] [ lift true ]ᵃ
      ; (lift n) → Z ![t: Z ] [ lift false ]ᵃ >> pongMain
      }

spawner : ∀ {i} → ∞ActorM i Spawnbox ⊤₁ [] (λ _ → Pingbox ∷ [ Pongbox ]ˡ)
spawner = do
  spawn∞ ponger
  spawn∞ pinger
  Z ![t: S Z ] [ [ S Z ]>: [ Z ]ᵐ ]ᵃ
  S Z ![t: S Z ] [ [ Z ]>: [ Z ]ᵐ ]ᵃ


------------------------------------------------------------------------
-- A parser for PBM images; illustrates "essential" use of bind
------------------------------------------------------------------------

-- Note that I am using the simple "Plain PBM" format, and I try to
-- adhere to the following statement from the pbm man page:
--
--   "Programs that read this format should be as lenient as possible,
--   accepting anything that looks remotely like a bitmap."

-- I got the idea to write this particular parser from "The Power of
-- Pi" by Oury and Swierstra.

module TotalParserCombinators.Examples.PBM where

open import Data.Bool
open import Data.Char as Char using (Char; _==_)
open import Data.List as List using (List)
open import Data.Maybe hiding (_>>=_)
open import Data.Nat hiding (_^_)
import Data.Nat.Show as ℕ
open import Data.String as String
  using (String) renaming (_++_ to _<+>_)
open import Data.Unit
open import Data.Vec as Vec using (Vec; _++_; [_])
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open import TotalParserCombinators.BreadthFirst
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser

open Token Char Char._≟_

------------------------------------------------------------------------
-- PBM images

module PBM where

  -- Colours.

  data Colour : Set where
    white : Colour
    black : Colour

  -- Matrices.

  Matrix : Set → ℕ → ℕ → Set
  Matrix A rows cols = Vec (Vec A cols) rows

  -- PBM images.

  record PBM : Set where
    constructor toPBM
    field
      {rows cols} : ℕ
      matrix      : Matrix Colour rows cols

  open PBM public

  -- Showing PBM images.

  showColour : Colour → Char
  showColour white = '0'
  showColour black = '1'

  show : PBM → String
  show i = "P1\n" <+>
           ℕ.show (cols i) <+> " " <+> ℕ.show (rows i) <+> "\n" <+>
           showMatrix (matrix i)
    where
    showMatrix = String.fromList ∘
                 Vec.toList ∘
                 Vec.concat ∘
                 Vec.map ((λ xs → xs ++ [ '\n' ]) ∘ Vec.map showColour)

open PBM

------------------------------------------------------------------------
-- Parsing PBM images

comment : Parser Char ⊤ _
comment =
  tok '#'                  >>= λ _ →
  sat′ (not ∘ _==_ '\n') ⋆ >>= λ _ →
  tok '\n'                 >>= λ _ →
  return tt

colour : Parser Char Colour _
colour = const white <$> tok '0'
       ∣ const black <$> tok '1'

pbm : Parser Char PBM _
pbm =
  w∣c ⋆                                  >>= λ _ →
  tok 'P' >>= λ _ → tok '1'              >>= λ _ →
  w∣c ⋆                                  >>= λ _ →
  number                                 >>= λ cols →
  w∣c +                                  >>= λ _ →
  number                                 >>= λ rows →
  w∣c                                    >>= λ _ →
  (w∣c ⋆ >>= λ _ → colour) ^ cols ^ rows >>= λ m →
  token ⋆                                >>= λ _ →
  return (toPBM m)
  where
  w∣c = whitespace ∣ comment

-- The example is commented out, because it takes ages to run this
-- parser.

-- module Example where

--   open Vec.Vec

--   image = toPBM ((white ∷ black ∷ []) ∷
--                  (black ∷ white ∷ []) ∷
--                  (black ∷ black ∷ []) ∷ [])

--   ex : parse pbm (String.toList $ show image) ≡ List.[_] image
--   ex = P.refl


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat

{-# BUILTIN REWRITE _≡_ #-}

not : Bool → Bool
not true = false
not false = true

data Unit : Set where
  unit : Unit

postulate
  X : Unit → Set
  X-Nat : X unit ≡ Nat
  X-Bool : (u : Unit) → X u ≡ Bool
{-# REWRITE X-Nat #-}

0' : (u : Unit) → X u
0' unit = 0

{-# REWRITE X-Bool #-}

test : (u : Unit) → not (0' u) ≡ true
test unit = refl


------------------------------------------------------------------------------
-- All the predicate logic modules
------------------------------------------------------------------------------

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

module FOL.Everything where

open import FOL.Base
open import FOL.ExclusiveDisjunction.Base
open import FOL.ExclusiveDisjunction.TheoremsATP
open import FOL.ExclusiveDisjunction.TheoremsI
open import FOL.NonEmptyDomain.TheoremsATP
open import FOL.NonEmptyDomain.TheoremsI
open import FOL.NonIntuitionistic.TheoremsATP
open import FOL.NonIntuitionistic.TheoremsI
open import FOL.PropositionalLogic.TheoremsATP
open import FOL.PropositionalLogic.TheoremsI
open import FOL.SchemataATP
open import FOL.TheoremsATP
open import FOL.TheoremsI


{-# OPTIONS --universe-polymorphism #-}

module Issue203 where

open import Imports.Level

-- shouldn't work
data Bad {a b} (A : Set a) : Set b where
  [_] : (x : A) → Bad A


-- Andreas, 2019-03-25, issue #3640, reported by gallais

{-# OPTIONS --sized-types #-}

-- {-# OPTIONS -v tc.polarity:40 #-}

module _ where

open import Agda.Builtin.Size

module M (_ : Set) where
  data U : Size → Set where
    node : ∀ {i} → U (↑ i)

module L (A B : Set) where
  open M A

-- WAS: crash because of number of parameters in size-index checki
-- of L.U was wrongly calculated.

-- Should succeed.


------------------------------------------------------------------------
-- Substitutions
------------------------------------------------------------------------

module RecursiveTypes.Substitution where

open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
import Data.Fin.Substitution.List as ListSubst
open import Data.Nat
open import Data.List
open import Data.Vec as Vec
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; sym; cong₂)
open PropEq.≡-Reasoning
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (Star; ε; _◅_; _▻_)

open import RecursiveTypes.Syntax

-- Code for applying substitutions.

module TyApp {T : ℕ → Set} (l : Lift T Ty) where
  open Lift l hiding (var)

  -- Applies a substitution to a recursive type.

  infixl 8 _/_

  _/_ : ∀ {m n} → Ty m → Sub T m n → Ty n
  ⊥       / ρ = ⊥
  ⊤       / ρ = ⊤
  var x   / ρ = lift (Vec.lookup ρ x)
  σ ⟶ τ   / ρ = (σ / ρ) ⟶ (τ / ρ)
  μ σ ⟶ τ / ρ = μ (σ / ρ ↑) ⟶ (τ / ρ ↑)

  open Application (record { _/_ = _/_ }) using (_/✶_)

  -- Some lemmas about _/_.

  ⊥-/✶-↑✶ : ∀ k {m n} (ρs : Subs T m n) → ⊥ /✶ ρs ↑✶ k ≡ ⊥
  ⊥-/✶-↑✶ k ε        = refl
  ⊥-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (⊥-/✶-↑✶ k ρs) refl

  ⊤-/✶-↑✶ : ∀ k {m n} (ρs : Subs T m n) → ⊤ /✶ ρs ↑✶ k ≡ ⊤
  ⊤-/✶-↑✶ k ε        = refl
  ⊤-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (⊤-/✶-↑✶ k ρs) refl

  ⟶-/✶-↑✶ : ∀ k {m n σ τ} (ρs : Subs T m n) →
            σ ⟶ τ /✶ ρs ↑✶ k ≡ (σ /✶ ρs ↑✶ k) ⟶ (τ /✶ ρs ↑✶ k)
  ⟶-/✶-↑✶ k ε        = refl
  ⟶-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (⟶-/✶-↑✶ k ρs) refl

  μ⟶-/✶-↑✶ : ∀ k {m n σ τ} (ρs : Subs T m n) →
             μ σ ⟶ τ /✶ ρs ↑✶ k ≡
             μ (σ /✶ ρs ↑✶ suc k) ⟶ (τ /✶ ρs ↑✶ suc k)
  μ⟶-/✶-↑✶ k ε        = refl
  μ⟶-/✶-↑✶ k (ρ ◅ ρs) = cong₂ _/_ (μ⟶-/✶-↑✶ k ρs) refl

tySubst : TermSubst Ty
tySubst = record { var = var; app = TyApp._/_ }

open TermSubst tySubst hiding (var)

-- σ [0≔ τ ] replaces all occurrences of variable 0 in σ with τ.

infix 8 _[0≔_]

_[0≔_] : ∀ {n} → Ty (suc n) → Ty n → Ty n
σ [0≔ τ ] = σ / sub τ

-- The unfolding of a fixpoint.

unfold[μ_⟶_] : ∀ {n} → Ty (suc n) → Ty (suc n) → Ty n
unfold[μ σ ⟶ τ ] = σ ⟶ τ [0≔ μ σ ⟶ τ ]

-- Substitution lemmas.

tyLemmas : TermLemmas Ty
tyLemmas = record
  { termSubst = tySubst
  ; app-var   = refl
  ; /✶-↑✶     = Lemma./✶-↑✶
  }
  where
  module Lemma {T₁ T₂} {lift₁ : Lift T₁ Ty} {lift₂ : Lift T₂ Ty} where

    open Lifted lift₁ using () renaming (_↑✶_ to _↑✶₁_; _/✶_ to _/✶₁_)
    open Lifted lift₂ using () renaming (_↑✶_ to _↑✶₂_; _/✶_ to _/✶₂_)

    /✶-↑✶ : ∀ {m n} (ρs₁ : Subs T₁ m n) (ρs₂ : Subs T₂ m n) →
            (∀ k x → var x /✶₁ ρs₁ ↑✶₁ k ≡ var x /✶₂ ρs₂ ↑✶₂ k) →
            ∀ k t → t /✶₁ ρs₁ ↑✶₁ k ≡ t /✶₂ ρs₂ ↑✶₂ k
    /✶-↑✶ ρs₁ ρs₂ hyp k ⊥ = begin
      ⊥ /✶₁ ρs₁ ↑✶₁ k  ≡⟨ TyApp.⊥-/✶-↑✶ _ k ρs₁ ⟩
      ⊥                ≡⟨ sym (TyApp.⊥-/✶-↑✶ _ k ρs₂) ⟩
      ⊥ /✶₂ ρs₂ ↑✶₂ k  ∎
    /✶-↑✶ ρs₁ ρs₂ hyp k ⊤ = begin
      ⊤ /✶₁ ρs₁ ↑✶₁ k  ≡⟨ TyApp.⊤-/✶-↑✶ _ k ρs₁ ⟩
      ⊤                ≡⟨ sym (TyApp.⊤-/✶-↑✶ _ k ρs₂) ⟩
      ⊤ /✶₂ ρs₂ ↑✶₂ k  ∎
    /✶-↑✶ ρs₁ ρs₂ hyp k (var x) = hyp k x
    /✶-↑✶ ρs₁ ρs₂ hyp k (σ ⟶ τ) = begin
      σ ⟶ τ /✶₁ ρs₁ ↑✶₁ k                    ≡⟨ TyApp.⟶-/✶-↑✶ _ k ρs₁ ⟩
      (σ /✶₁ ρs₁ ↑✶₁ k) ⟶ (τ /✶₁ ρs₁ ↑✶₁ k)  ≡⟨ cong₂ _⟶_ (/✶-↑✶ ρs₁ ρs₂ hyp k σ)
                                                          (/✶-↑✶ ρs₁ ρs₂ hyp k τ) ⟩
      (σ /✶₂ ρs₂ ↑✶₂ k) ⟶ (τ /✶₂ ρs₂ ↑✶₂ k)  ≡⟨ sym (TyApp.⟶-/✶-↑✶ _ k ρs₂) ⟩
      σ ⟶ τ /✶₂ ρs₂ ↑✶₂ k                    ∎
    /✶-↑✶ ρs₁ ρs₂ hyp k (μ σ ⟶ τ) = begin
      μ σ ⟶ τ /✶₁ ρs₁ ↑✶₁ k                            ≡⟨ TyApp.μ⟶-/✶-↑✶ _ k ρs₁ ⟩
      μ (σ /✶₁ ρs₁ ↑✶₁ suc k) ⟶ (τ /✶₁ ρs₁ ↑✶₁ suc k)  ≡⟨ cong₂ μ_⟶_ (/✶-↑✶ ρs₁ ρs₂ hyp (suc k) σ)
                                                                     (/✶-↑✶ ρs₁ ρs₂ hyp (suc k) τ) ⟩
      μ (σ /✶₂ ρs₂ ↑✶₂ suc k) ⟶ (τ /✶₂ ρs₂ ↑✶₂ suc k)  ≡⟨ sym (TyApp.μ⟶-/✶-↑✶ _ k ρs₂) ⟩
      μ σ ⟶ τ /✶₂ ρs₂ ↑✶₂ k                            ∎

open TermLemmas tyLemmas public hiding (var)

module // where

  private
    open module LS = ListSubst lemmas₄ public hiding (_//_)

  -- _//_ is redefined in order to make it bind weaker than
  -- RecursiveTypes.Subterm._∗, which binds weaker than _/_.

  infixl 6 _//_

  _//_ : ∀ {m n} → List (Ty m) → Sub Ty m n → List (Ty n)
  _//_ = LS._//_


{-# OPTIONS --allow-unsolved-metas #-}
postulate
  Nat : Set

variable
  A : _
  F : _ → _


-- Andreas, 2014-09-02
-- Up to today, there was no implementation of shadowing local variables
-- (e.g., λ-bound variables) by local imports.

-- {-# OPTIONS -v scope.locals:10 #-}

module _ where

module M where

  A = Set1

test : (A : Set) → let open M in A
test A = Set

-- The A exported by M is in competition with the local A.
-- Ambiguous name should be reported.


module Verifier where

open import ModusPonens using (modusPonens)

check : ∀ {P Q : Set} → (P → Q) → P → Q
check = modusPonens


module nodcap.LocalChoice where

open import Algebra
open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺
open import Data.List as L using (List; []; _∷_; _++_)
open import Data.List.Any as LA using (Any; here; there)
open import Data.List.Any.BagAndSetEquality as B
open import Data.Product as PR using (∃; _×_; _,_; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_$_; flip)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as I using ()
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)

open import Data.Environment
open import nodcap.Base
open import nodcap.Typing

open I.Inverse using (to; from)
private module ++ {a} {A : Set a} = Monoid (L.monoid A)

-- We define local choice as follows:
_or_ : {A : Type} → ⊢ A ∷ [] → ⊢ A ∷ [] → ⊢ A ∷ []
x or y = cut (pool (in? x) (in? y)) out
  where
    in? : ∀ {A} → ⊢ A ∷ [] → ⊢ ![ suc 0 ] (𝟏 & A) ∷ []
    in? x = mk!₁ $ case halt x
    out : ∀ {A} → ⊢ ?[ suc 1 ] (⊥ ⊕ (A ^)) ∷ A ∷ []
    out = cont $ mk?₁ $ sel₁ $ wait $ mk?₁ $ sel₂ $ exch (bbl []) $ ax

-- However, Luís Caires defines local choice with contexts. For this to work we
-- need an additional trick: conversion between contexts and types.

-- We can represent a context as a sequence of pars.
⅋[_] : Environment → Type
⅋[ [] ]    = ⊥
⅋[ A ∷ Γ ] = A ⅋ ⅋[ Γ ]

-- See:
recv⋆ : {Γ Δ : Environment} →

  ⊢ Γ ++ Δ →
  ------------
  ⊢ ⅋[ Γ ] ∷ Δ

recv⋆ {[]}    x = wait x
recv⋆ {A ∷ Γ} x = recv $ exch (bbl []) $ recv⋆ $ exch (bwd [] Γ) $ x

-- In order to reverse this, we need to show that the `recv` rule is invertible.
-- Fortunately, it is:
recv⁻¹ : {Γ : Environment} {A B : Type} →

  ⊢ A ⅋ B ∷ Γ →
  -------------
  ⊢ A ∷ B ∷ Γ

recv⁻¹ {Γ} {A} {B} x
  = exch (swp₂ (A ∷ B ∷ []))
  $ cut {Γ} {A ∷ B ∷ []} x
  $ send
  ( exch (bbl []) ax )
  ( exch (bbl []) ax )

-- It should come as no surprise that the repeated application of `recv` is also
-- invertible.
recv⋆⁻¹ : {Γ Δ : Environment} →

  ⊢ ⅋[ Γ ] ∷ Δ →
  --------------
  ⊢ Γ ++ Δ

recv⋆⁻¹ {[]}    x = cut halt x
recv⋆⁻¹ {A ∷ Γ} x = exch (fwd [] Γ) $ recv⋆⁻¹ {Γ} $ exch (bbl []) $ recv⁻¹ x

-- Using these additional derivable operators, we can represent the version of
-- local choice as used by Luís Caires:
_or⋆_ : {Γ : Environment} → ⊢ Γ → ⊢ Γ → ⊢ Γ
_or⋆_ {Γ} x y
  = P.subst ⊢_ (proj₂ ++.identity Γ)
  $ recv⋆⁻¹ {Γ}
  $  ( recv⋆ $ P.subst ⊢_ (P.sym $ proj₂ ++.identity Γ) x )
  or ( recv⋆ $ P.subst ⊢_ (P.sym $ proj₂ ++.identity Γ) y )

-- -}
-- -}
-- -}
-- -}
-- -}


-- {-# OPTIONS -v scope:10 -v scope.inverse:100 #-}

open import Common.Equality
open import A.Issue1635 Set

test : ∀ x → x ≡ foo
test x = refl

-- ERROR:
-- x != .#A.Issue1635-225351734.foo of type Foo
-- when checking that the expression refl has type x ≡ foo

-- SLIGHTLY BETTER:
-- x != .A.Issue1635.Foo.foo of type Foo
-- when checking that the expression refl has type x ≡ foo

-- WANT: x != foo ...


-- Andreas, 2013-02-26
module Issue799a where

data D (A : Set1) : Set where
  d : D A

x : D Set
x = d {A = _} -- correct parameter name

y : D Set
y = d {B = _} -- wrong parameter name, should give error