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

module 19-fundamental-cover where

import 18-circle
open 18-circle public

{- Section 12.1 Families over the circle -}

Aut :
  { l1 : Level} → UU l1 → UU l1
Aut Y = Y ≃ Y

Fam-circle :
  ( l1 : Level) → UU (lsuc l1)
Fam-circle l1 = Σ (UU l1) Aut

Eq-Fam-circle :
  { l1 : Level} → Fam-circle l1 → Fam-circle l1 → UU l1
Eq-Fam-circle P Q =
  Σ ( (pr1 P) ≃ (pr1 Q))
    ( λ h →
      ( (map-equiv h) ∘ (map-equiv (pr2 P))) ~ ((map-equiv (pr2 Q)) ∘ (map-equiv h)))

reflexive-Eq-Fam-circle :
  { l1 : Level} (P : Fam-circle l1) → Eq-Fam-circle P P
reflexive-Eq-Fam-circle (pair X e) =
  pair (equiv-id X) refl-htpy

Eq-Fam-circle-eq :
  { l1 : Level} (P Q : Fam-circle l1) → Id P Q → Eq-Fam-circle P Q
Eq-Fam-circle-eq P .P refl = reflexive-Eq-Fam-circle P

abstract
  is-contr-total-Eq-Fam-circle :
    { l1 : Level} (P : Fam-circle l1) →
    is-contr (Σ (Fam-circle l1) (Eq-Fam-circle P))
  is-contr-total-Eq-Fam-circle (pair X e) =
    is-contr-total-Eq-structure
      ( λ Y f h →
        ((map-equiv h) ∘ (map-equiv e)) ~ ((map-equiv f) ∘ (map-equiv h)))
      ( is-contr-total-equiv X)
      ( pair X (equiv-id X))
    ( is-contr-total-htpy-equiv e)

abstract
  is-equiv-Eq-Fam-circle-eq :
    { l1 : Level} (P Q : Fam-circle l1) → is-equiv (Eq-Fam-circle-eq P Q)
  is-equiv-Eq-Fam-circle-eq P =
    fundamental-theorem-id P
      ( reflexive-Eq-Fam-circle P)
      ( is-contr-total-Eq-Fam-circle P)
      ( Eq-Fam-circle-eq P)

eq-Eq-Fam-circle :
  { l1 : Level} (P Q : Fam-circle l1) → Eq-Fam-circle P Q → Id P Q
eq-Eq-Fam-circle P Q = inv-is-equiv (is-equiv-Eq-Fam-circle-eq P Q)

ev-fam-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
  ( X → UU l2) → Fam-circle l2
ev-fam-circle l P =
  pair
    ( P (base-free-loop l))
    ( equiv-tr P (loop-free-loop l))

comparison-fam-circle :
  ( l1 : Level) → free-loops (UU l1) → Fam-circle l1
comparison-fam-circle l1 = tot (λ Y → equiv-eq)

abstract
  is-equiv-comparison-fam-circle :
    ( l1 : Level) → is-equiv (comparison-fam-circle l1)
  is-equiv-comparison-fam-circle l1 =
    is-equiv-tot-is-fiberwise-equiv (λ Y → univalence Y Y)

triangle-comparison-fam-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
  (ev-fam-circle l) ~ ((comparison-fam-circle l2) ∘ (ev-free-loop l (UU l2)))
triangle-comparison-fam-circle l P =
  eq-Eq-Fam-circle
    ( ev-fam-circle l P)
    ( comparison-fam-circle _ (ev-free-loop l (UU _) P))
    ( pair (equiv-id _) (htpy-inv (tr-equiv-eq-ap (pr2 l))))

abstract
  is-equiv-ev-fam-circle-universal-property-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X)
    ( up-circle : universal-property-circle (lsuc l2) l) →
    is-equiv (ev-fam-circle {l2 = l2} l)
  is-equiv-ev-fam-circle-universal-property-circle {l2 = l2} l up-circle =
    is-equiv-comp
      ( ev-fam-circle l)
      ( comparison-fam-circle l2)
      ( ev-free-loop l (UU l2))
      ( triangle-comparison-fam-circle l)
      ( up-circle (UU l2))
      ( is-equiv-comparison-fam-circle l2)

unique-family-property-circle :
  { l1 : Level} (l2 : Level) {X : UU l1} (l : free-loops X) →
  UU (l1 ⊔ (lsuc l2))
unique-family-property-circle l2 {X} l =
  ( Q : Fam-circle l2) →
    is-contr (Σ (X → UU l2) (λ P → Eq-Fam-circle Q (ev-fam-circle l P)))

abstract
  unique-family-property-universal-property-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    universal-property-circle (lsuc l2) l → unique-family-property-circle l2 l
  unique-family-property-universal-property-circle l up-circle Q =
    is-contr-is-equiv'
      ( fib (ev-fam-circle l) Q)
      ( tot (λ P → (Eq-Fam-circle-eq Q (ev-fam-circle l P)) ∘ inv))
      ( is-equiv-tot-is-fiberwise-equiv
        ( λ P →
          is-equiv-comp' _ _
            ( is-equiv-inv _ _)
            ( is-equiv-Eq-Fam-circle-eq Q (ev-fam-circle l P))))
      ( is-contr-map-is-equiv
        ( is-equiv-ev-fam-circle-universal-property-circle l up-circle)
        ( Q))

Section-Fam-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : Fam-circle l2) → UU _
Section-Fam-circle l P =
  Σ (pr1 P) (λ p → Id (map-equiv (pr2 P) p) p)

fam-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
  ( dependent-universal-property-circle (lsuc l2) l) →
  Fam-circle l2 → X → UU l2
fam-circle {l1} {l2} l dup-circle =
  inv-is-equiv
    ( is-equiv-ev-fam-circle-universal-property-circle l
      ( universal-property-dependent-universal-property-circle l dup-circle))

section-fam-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle l2 l) →
  ( Q : X → UU l2) (P : Fam-circle l2) →
  ( e : Eq-Fam-circle P (ev-fam-circle l Q)) →
  Section-Fam-circle l P → (x : X) → Q x
section-fam-circle l dup-circle Q P (pair e H) (pair p α) =
  inv-is-equiv
    ( dup-circle Q)
    ( pair (map-equiv e p) ((inv (H p)) ∙ (ap (map-equiv e) α)))

{- Section 12.2 The fundamental cover of the circle -}

{- We show that if a type with a free loop satisfies the induction principle
   of the circle with respect to any universe level, then it satisfies the
   induction principle with respect to the zeroth universe level. -}

naturality-tr-fiberwise-transformation :
  { l1 l2 l3 : Level} {X : UU l1} {P : X → UU l2} {Q : X → UU l3}
  ( f : (x : X) → P x → Q x) {x y : X} (α : Id x y) (p : P x) →
  Id (tr Q α (f x p)) (f y (tr P α p))
naturality-tr-fiberwise-transformation f refl p = refl

functor-dependent-free-loops :
  { l1 l2 l3 : Level} {X : UU l1} (l : free-loops X)
  { P : X → UU l2} {Q : X → UU l3} (f : (x : X) → P x → Q x) →
  dependent-free-loops l P → dependent-free-loops l Q
functor-dependent-free-loops l {P} {Q} f =
  toto
    ( λ q₀ → Id (tr Q (loop-free-loop l) q₀) q₀)
    ( f (base-free-loop l))
    ( λ p₀ α →
      ( naturality-tr-fiberwise-transformation f (loop-free-loop l) p₀) ∙
      ( ap (f (base-free-loop l)) α))

coherence-square-functor-dependent-free-loops :
  { l1 l2 l3 : Level} {X : UU l1} {P : X → UU l2} {Q : X → UU l3}
  ( f : (x : X) → P x → Q x) {x y : X} (α : Id x y)
  ( h : (x : X) → P x) →
  Id ( ( naturality-tr-fiberwise-transformation f α (h x)) ∙
       ( ap (f y) (apd h α)))
     ( apd (postcomp-Π f h) α)
coherence-square-functor-dependent-free-loops f refl h = refl

square-functor-dependent-free-loops :
  { l1 l2 l3 : Level} {X : UU l1} (l : free-loops X)
  { P : X → UU l2} {Q : X → UU l3} (f : (x : X) → P x → Q x) →
  ( (functor-dependent-free-loops l f) ∘ (ev-free-loop' l P)) ~
  ( (ev-free-loop' l Q) ∘ (postcomp-Π f))
square-functor-dependent-free-loops (pair x l) {P} {Q} f h =
  eq-Eq-dependent-free-loops (pair x l) Q
    ( functor-dependent-free-loops (pair x l) f
      ( ev-free-loop' (pair x l) P h))
    ( ev-free-loop' (pair x l) Q (postcomp-Π f h))
    ( pair refl
      ( right-unit ∙ (coherence-square-functor-dependent-free-loops f l h)))

abstract
  is-equiv-functor-dependent-free-loops-is-fiberwise-equiv :
    { l1 l2 l3 : Level} {X : UU l1} (l : free-loops X)
    { P : X → UU l2} {Q : X → UU l3} {f : (x : X) → P x → Q x}
    ( is-equiv-f : (x : X) → is-equiv (f x)) →
    is-equiv (functor-dependent-free-loops l f)
  is-equiv-functor-dependent-free-loops-is-fiberwise-equiv
    (pair x l) {P} {Q} {f} is-equiv-f =
    is-equiv-toto-is-fiberwise-equiv-is-equiv-base-map
      ( λ q₀ → Id (tr Q l q₀) q₀)
      ( _)
      ( _)
      ( is-equiv-f x)
      ( λ p₀ →
        is-equiv-comp'
          ( concat
            ( naturality-tr-fiberwise-transformation f l p₀)
            ( f x p₀))
          ( ap (f x))
          ( is-emb-is-equiv (f x) (is-equiv-f x) (tr P l p₀) p₀)
          ( is-equiv-concat
            ( naturality-tr-fiberwise-transformation f l p₀)
            ( f x p₀)))

abstract
  lower-dependent-universal-property-circle :
    { l1 l2 : Level} (l3 : Level) {X : UU l1} (l : free-loops X) →
    dependent-universal-property-circle (l2 ⊔ l3) l →
    dependent-universal-property-circle l3 l
  lower-dependent-universal-property-circle {l1} {l2} l3 l dup-circle P =
    is-equiv-left-is-equiv-right-square
      ( ev-free-loop' l P)
      ( ev-free-loop' l (λ x → raise l2 (P x)))
      ( postcomp-Π (λ x → map-raise l2 (P x)))
      ( functor-dependent-free-loops l (λ x → map-raise l2 (P x)))
      ( square-functor-dependent-free-loops l (λ x → map-raise l2 (P x)))
      ( is-equiv-postcomp-Π _ (λ x → is-equiv-map-raise l2 (P x)))
      ( is-equiv-functor-dependent-free-loops-is-fiberwise-equiv l
        ( λ x → is-equiv-map-raise l2 (P x)))
      ( dup-circle (λ x → raise l2 (P x)))

abstract
  lower-lzero-dependent-universal-property-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    dependent-universal-property-circle l2 l →
    dependent-universal-property-circle lzero l
  lower-lzero-dependent-universal-property-circle =
    lower-dependent-universal-property-circle lzero

{- The definition of the fundamental cover -}

{- The fundamental cover -}

abstract
  Fundamental-cover-circle :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l →
    Σ ( X → UU lzero)
      ( λ P → Eq-Fam-circle (pair ℤ equiv-succ-ℤ) (ev-fam-circle l P))
  Fundamental-cover-circle {l1} l dup-circle =
    center
      ( unique-family-property-universal-property-circle l
        ( universal-property-dependent-universal-property-circle l
          ( lower-dependent-universal-property-circle
            {l2 = l1} (lsuc lzero) l dup-circle))
        ( pair ℤ equiv-succ-ℤ))

  fundamental-cover-circle :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l →
    X → UU lzero
  fundamental-cover-circle l dup-circle =
    pr1 (Fundamental-cover-circle l dup-circle)

  comp-fiber-fundamental-cover-circle :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
    ℤ ≃ fundamental-cover-circle l dup-circle (base-free-loop l)
  comp-fiber-fundamental-cover-circle l dup-circle =
    pr1 ( pr2 ( Fundamental-cover-circle l dup-circle))

  comp-tr-fundamental-cover-circle :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
    ( ( map-equiv (comp-fiber-fundamental-cover-circle l dup-circle)) ∘
      ( succ-ℤ)) ~
    ( ( tr (fundamental-cover-circle l dup-circle) (loop-free-loop l)) ∘
      ( map-equiv (comp-fiber-fundamental-cover-circle l dup-circle)))
  comp-tr-fundamental-cover-circle l dup-circle =
    pr2 ( pr2 ( Fundamental-cover-circle l dup-circle))

{- We show that the fundamental cover of the circle is a family of sets. -}

abstract
  is-set-fundamental-cover-circle :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
    ( x : X) → is-set (fundamental-cover-circle l dup-circle x)
  is-set-fundamental-cover-circle l dup-circle =
    is-connected-circle' l
      ( lower-dependent-universal-property-circle lzero l dup-circle)
      ( λ x → is-set (fundamental-cover-circle l dup-circle x))
      ( λ x → is-prop-is-set (fundamental-cover-circle l dup-circle x))
      ( is-trunc-is-equiv' zero-𝕋 ℤ
        ( map-equiv (comp-fiber-fundamental-cover-circle l dup-circle))
        ( is-equiv-map-equiv (comp-fiber-fundamental-cover-circle l dup-circle))
        ( is-set-ℤ))

{- Contractibility of a general total space -}

contraction-total-space :
  { l1 l2 : Level} {A : UU l1} {B : A → UU l2} (center : Σ A B) →
  ( x : A) → UU (l1 ⊔ l2)
contraction-total-space {B = B} center x =
  ( y : B x) → Id center (pair x y)

path-total-path-fiber :
  { l1 l2 : Level} {A : UU l1} (B : A → UU l2) (x : A) →
  { y y' : B x} (q : Id y' y) → Id {A = Σ A B} (pair x y) (pair x y')
path-total-path-fiber B x q = eq-pair refl (inv q)

tr-path-total-path-fiber :
  { l1 l2 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) (x : A) →
  { y y' : B x} (q : Id y' y) (α : Id c (pair x y')) →
  Id ( tr (λ z → Id c (pair x z)) q α)
     ( α ∙ (inv (path-total-path-fiber B x q)))
tr-path-total-path-fiber c x refl α = inv right-unit

segment-Σ :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} →
  { x x' : A} (p : Id x x')
  { F : UU l3} {F' : UU l4} (f : F ≃ F') ( e : F ≃ B x) (e' : F' ≃ B x')
  ( H : ((map-equiv e') ∘ (map-equiv f)) ~ ((tr B p) ∘ (map-equiv e))) (y : F) →
  Id (pair x (map-equiv e y)) (pair x' (map-equiv e' (map-equiv f y)))
segment-Σ refl f e e' H y = path-total-path-fiber _ _ (H y)

contraction-total-space' :
  { l1 l2 l3 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
  ( x : A) → {F : UU l3} (e : F ≃ B x) → UU (l1 ⊔ (l2 ⊔ l3))
contraction-total-space' c x {F} e =
  ( y : F) → Id c (pair x (map-equiv e y))

equiv-tr-contraction-total-space' :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
  { x x' : A} (p : Id x x') →
  { F : UU l3} {F' : UU l4} (f : F ≃ F') (e : F ≃ B x) (e' : F' ≃ B x') →
  ( H : ((map-equiv e') ∘ (map-equiv f)) ~ ((tr B p) ∘ (map-equiv e))) →
  ( contraction-total-space' c x' e') ≃ (contraction-total-space' c x e)
equiv-tr-contraction-total-space' c p f e e' H =
  ( equiv-postcomp-Π
    ( λ y → equiv-concat' c (inv (segment-Σ p f e e' H y)))) ∘e
  ( precomp-Π-equiv f _)

equiv-contraction-total-space :
  { l1 l2 l3 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
  ( x : A) → {F : UU l3} (e : F ≃ B x) →
  ( contraction-total-space c x) ≃ (contraction-total-space' c x e)
equiv-contraction-total-space c x e =
  precomp-Π-equiv e (λ y → Id c (pair x y))

tr-path-total-tr-coherence :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) (x : A) →
  { F : UU l3} {F' : UU l4} (f : F ≃ F') ( e : F ≃ B x) (e' : F' ≃ B x)
  ( H : ((map-equiv e') ∘ (map-equiv f)) ~ (map-equiv e)) →
  (y : F) (α : Id c (pair x (map-equiv e' (map-equiv f y)))) →
  Id ( tr (λ z → Id c (pair x z)) (H y) α)
     ( α ∙ (inv (segment-Σ refl f e e' H y)))
tr-path-total-tr-coherence c x f e e' H y α =
  tr-path-total-path-fiber c x (H y) α

square-tr-contraction-total-space :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
  { x x' : A} (p : Id x x')
  { F : UU l3} {F' : UU l4} (f : F ≃ F') (e : F ≃ B x) (e' : F' ≃ B x')
  ( H : ((map-equiv e') ∘ (map-equiv f)) ~ ((tr B p) ∘ (map-equiv e)))
  (h : contraction-total-space c x) →
  ( map-equiv
    ( ( equiv-tr-contraction-total-space' c p f e e' H) ∘e
      ( ( equiv-contraction-total-space c x' e') ∘e
        ( equiv-tr (contraction-total-space c) p)))
    ( h)) ~
  ( map-equiv (equiv-contraction-total-space c x e) h)
square-tr-contraction-total-space c refl f e e' H h y =
  ( inv (tr-path-total-tr-coherence c _ f e e' H y
    ( h (map-equiv e' (map-equiv f y))))) ∙
  ( apd h (H y))

path-over-contraction-total-space' :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
  {x x' : A} (p : Id x x') →
  {F : UU l3} {F' : UU l4} (f : F ≃ F') ( e : F ≃ B x) (e' : F' ≃ B x')
  (H : ((map-equiv e') ∘ (map-equiv f)) ~ ((tr B p) ∘ (map-equiv e))) →
  (h : (y : F) → Id c (pair x (map-equiv e y))) →
  (h' : (y' : F') → Id c (pair x' (map-equiv e' y'))) →
  UU _
path-over-contraction-total-space' c {x} {x'} p {F} {F'} f e e' H h h' =
  ( postcomp-Π
    ( λ y → concat' c (segment-Σ p f e e' H y)) h) ~
  ( precomp-Π
    ( map-equiv f)
    ( λ y' → Id c (pair x' (map-equiv e' y')))
    ( h'))

map-path-over-contraction-total-space' :
    { l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
    { x x' : A} (p : Id x x') →
    { F : UU l3} {F' : UU l4} (f : F ≃ F') ( e : F ≃ B x) (e' : F' ≃ B x')
    ( H : ((map-equiv e') ∘ (map-equiv f)) ~ ((tr B p) ∘ (map-equiv e))) →
    ( h : contraction-total-space' c x e) →
    ( h' : contraction-total-space' c x' e') →
    ( path-over-contraction-total-space' c p f e e' H h h') →
    ( path-over (contraction-total-space c) p
      ( inv-map-equiv (equiv-contraction-total-space c x e) h)
      ( inv-map-equiv (equiv-contraction-total-space c x' e') h'))
map-path-over-contraction-total-space' c {x} {.x} refl f e e' H h h' α =
  inv-map-equiv
    ( equiv-ap
      ( ( equiv-tr-contraction-total-space' c refl f e e' H) ∘e
        ( equiv-contraction-total-space c x e'))
      ( inv-map-equiv (equiv-contraction-total-space c x e) h)
      ( inv-map-equiv (equiv-contraction-total-space c x e') h'))
    ( ( ( eq-htpy
          ( square-tr-contraction-total-space c refl f e e' H
            ( inv-map-equiv (equiv-contraction-total-space c x e) h))) ∙
        ( issec-inv-is-equiv
          ( is-equiv-map-equiv (equiv-contraction-total-space c x e))
          ( h))) ∙
      ( ( eq-htpy
          ( htpy-con-inv h
            ( segment-Σ refl f e e' H)
            ( precomp-Π
              ( map-equiv f)
              ( λ y' → Id c (pair x (map-equiv e' y')))
              ( h'))
            ( α))) ∙
        ( inv
          ( ap
            ( map-equiv (equiv-tr-contraction-total-space' c refl f e e' H))
            ( issec-inv-is-equiv
              ( is-equiv-map-equiv
                ( precomp-Π-equiv e' (λ y' → Id c (pair x y'))))
              ( h'))))))

equiv-path-over-contraction-total-space' :
  { l1 l2 l3 l4 : Level} {A : UU l1} {B : A → UU l2} (c : Σ A B) →
  { x x' : A} (p : Id x x') →
  { F : UU l3} {F' : UU l4} (f : F ≃ F') ( e : F ≃ B x) (e' : F' ≃ B x')
  ( H : ((map-equiv e') ∘ (map-equiv f)) ~ ((tr B p) ∘ (map-equiv e))) →
  ( h : contraction-total-space' c x e) →
  ( h' : contraction-total-space' c x' e') →
  ( path-over (contraction-total-space c) p
    ( inv-map-equiv (equiv-contraction-total-space c x e) h)
    ( inv-map-equiv (equiv-contraction-total-space c x' e') h')) ≃
  ( path-over-contraction-total-space' c p f e e' H h h')
equiv-path-over-contraction-total-space' c {x} {.x} refl f e e' H h h' =
  ( inv-equiv
    ( equiv-htpy-con-inv h
      ( segment-Σ refl f e e' H)
      ( precomp-Π
        ( map-equiv f)
        ( λ y' → Id c (pair x (map-equiv e' y')))
        ( h')))) ∘e
  ( ( equiv-funext) ∘e
    ( ( equiv-concat' h
        ( ap
          ( map-equiv (equiv-tr-contraction-total-space' c refl f e e' H))
          ( issec-inv-is-equiv
            ( is-equiv-map-equiv
              ( precomp-Π-equiv e' (λ y' → Id c (pair x y'))))
            ( h')))) ∘e
      ( ( equiv-concat
          ( inv
            ( ( eq-htpy
                ( square-tr-contraction-total-space c refl f e e' H
                  ( inv-map-equiv (equiv-contraction-total-space c x e) h))) ∙
              ( issec-inv-is-equiv
                ( is-equiv-map-equiv (equiv-contraction-total-space c x e))
                ( h))))
          ( map-equiv
            ( ( equiv-tr-contraction-total-space' c refl f e e' H) ∘e
              ( ( equiv-contraction-total-space c x e') ∘e
                ( inv-equiv (equiv-contraction-total-space c x e'))))
            ( h'))) ∘e
        ( equiv-ap
          ( ( equiv-tr-contraction-total-space' c refl f e e' H) ∘e
            ( equiv-contraction-total-space c x e'))
          ( inv-map-equiv (equiv-contraction-total-space c x e) h)
          ( inv-map-equiv (equiv-contraction-total-space c x e') h')))))

{- We use the above construction to provide sufficient conditions for the total
   space of the fundamental cover to be contractible. -}

center-total-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  Σ X (fundamental-cover-circle l dup-circle)
center-total-fundamental-cover-circle l dup-circle =
  pair
    ( base-free-loop l)
    ( map-equiv
      ( comp-fiber-fundamental-cover-circle l dup-circle) zero-ℤ)

path-over-loop-contraction-total-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  ( h : contraction-total-space'
        ( center-total-fundamental-cover-circle l dup-circle)
        ( base-free-loop l)
        ( comp-fiber-fundamental-cover-circle l dup-circle)) →
  ( p : path-over-contraction-total-space'
        ( center-total-fundamental-cover-circle l dup-circle)
        ( loop-free-loop l)
        ( equiv-succ-ℤ)
        ( comp-fiber-fundamental-cover-circle l dup-circle)
        ( comp-fiber-fundamental-cover-circle l dup-circle)
        ( comp-tr-fundamental-cover-circle l dup-circle)
        ( h)
        ( h)) →
  path-over
    ( contraction-total-space
      ( center-total-fundamental-cover-circle l dup-circle))
    ( pr2 l)
    ( inv-map-equiv
      ( equiv-contraction-total-space
        ( center-total-fundamental-cover-circle l dup-circle)
        ( base-free-loop l)
        ( comp-fiber-fundamental-cover-circle l dup-circle))
      ( h))
    ( inv-map-equiv
      ( equiv-contraction-total-space
        ( center-total-fundamental-cover-circle l dup-circle)
        ( base-free-loop l)
        ( comp-fiber-fundamental-cover-circle l dup-circle))
      ( h))
path-over-loop-contraction-total-fundamental-cover-circle l dup-circle h p =
  map-path-over-contraction-total-space'
    ( center-total-fundamental-cover-circle l dup-circle)
    ( loop-free-loop l)
    ( equiv-succ-ℤ)
    ( comp-fiber-fundamental-cover-circle l dup-circle)
    ( comp-fiber-fundamental-cover-circle l dup-circle)
    ( comp-tr-fundamental-cover-circle l dup-circle)
    ( h)
    ( h)
    ( p)

contraction-total-fundamental-cover-circle-data :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  ( h : contraction-total-space'
        ( center-total-fundamental-cover-circle l dup-circle)
        ( base-free-loop l)
        ( comp-fiber-fundamental-cover-circle l dup-circle)) →
  ( p : path-over-contraction-total-space'
        ( center-total-fundamental-cover-circle l dup-circle)
        ( loop-free-loop l)
        ( equiv-succ-ℤ)
        ( comp-fiber-fundamental-cover-circle l dup-circle)
        ( comp-fiber-fundamental-cover-circle l dup-circle)
        ( comp-tr-fundamental-cover-circle l dup-circle)
        ( h)
        ( h)) →
  ( t : Σ X (fundamental-cover-circle l dup-circle)) →
  Id (center-total-fundamental-cover-circle l dup-circle) t
contraction-total-fundamental-cover-circle-data
  {l1} l dup-circle h p (pair x y) =
  inv-is-equiv
    ( lower-dependent-universal-property-circle
      { l2 = lsuc lzero} l1 l dup-circle
      ( contraction-total-space
        ( center-total-fundamental-cover-circle l dup-circle)))
    ( pair
      ( inv-map-equiv
        ( equiv-contraction-total-space
          ( center-total-fundamental-cover-circle l dup-circle)
          ( base-free-loop l)
          ( comp-fiber-fundamental-cover-circle l dup-circle))
        ( h))
      ( path-over-loop-contraction-total-fundamental-cover-circle
        l dup-circle h p))
    x y

is-contr-total-fundamental-cover-circle-data :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  ( h : contraction-total-space'
        ( center-total-fundamental-cover-circle l dup-circle)
        ( base-free-loop l)
        ( comp-fiber-fundamental-cover-circle l dup-circle)) →
  ( p : path-over-contraction-total-space'
        ( center-total-fundamental-cover-circle l dup-circle)
        ( loop-free-loop l)
        ( equiv-succ-ℤ)
        ( comp-fiber-fundamental-cover-circle l dup-circle)
        ( comp-fiber-fundamental-cover-circle l dup-circle)
        ( comp-tr-fundamental-cover-circle l dup-circle)
        ( h)
        ( h)) →
  is-contr (Σ X (fundamental-cover-circle l dup-circle))
is-contr-total-fundamental-cover-circle-data l dup-circle h p =
  pair
    ( center-total-fundamental-cover-circle l dup-circle)
    ( contraction-total-fundamental-cover-circle-data l dup-circle h p)

{- Section 12.4 The dependent universal property of ℤ -}

abstract
  elim-ℤ :
    { l1 : Level} (P : ℤ → UU l1)
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
    ( k : ℤ) → P k
  elim-ℤ P p0 pS (inl zero-ℕ) =
    inv-is-equiv (is-equiv-map-equiv (pS neg-one-ℤ)) p0
  elim-ℤ P p0 pS (inl (succ-ℕ x)) =
    inv-is-equiv
      ( is-equiv-map-equiv (pS (inl (succ-ℕ x))))
      ( elim-ℤ P p0 pS (inl x))
  elim-ℤ P p0 pS (inr (inl star)) = p0
  elim-ℤ P p0 pS (inr (inr zero-ℕ)) = map-equiv (pS zero-ℤ) p0
  elim-ℤ P p0 pS (inr (inr (succ-ℕ x))) =
    map-equiv
      ( pS (inr (inr x)))
      ( elim-ℤ P p0 pS (inr (inr x)))

  comp-zero-elim-ℤ :
    { l1 : Level} (P : ℤ → UU l1)
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
    Id (elim-ℤ P p0 pS zero-ℤ) p0
  comp-zero-elim-ℤ P p0 pS = refl

  comp-succ-elim-ℤ :
    { l1 : Level} (P : ℤ → UU l1)
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) (k : ℤ) →
    Id ( elim-ℤ P p0 pS (succ-ℤ k)) (map-equiv (pS k)
      ( elim-ℤ P p0 pS k))
  comp-succ-elim-ℤ P p0 pS (inl zero-ℕ) =
    inv
      ( issec-inv-is-equiv
        ( is-equiv-map-equiv (pS (inl zero-ℕ)))
        ( elim-ℤ P p0 pS (succ-ℤ (inl zero-ℕ))))
  comp-succ-elim-ℤ P p0 pS (inl (succ-ℕ x)) =
    inv
      ( issec-inv-is-equiv
        ( is-equiv-map-equiv (pS (inl (succ-ℕ x))))
        ( elim-ℤ P p0 pS (succ-ℤ (inl (succ-ℕ x)))))
  comp-succ-elim-ℤ P p0 pS (inr (inl star)) = refl
  comp-succ-elim-ℤ P p0 pS (inr (inr x)) = refl

ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) → UU l1
ELIM-ℤ P p0 pS =
  Σ ( (k : ℤ) → P k) (λ f →
    ( ( Id (f zero-ℤ) p0) ×
      ( (k : ℤ) → Id (f (succ-ℤ k)) ((map-equiv (pS k)) (f k)))))

Elim-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) → ELIM-ℤ P p0 pS
Elim-ℤ P p0 pS =
  pair
    ( elim-ℤ P p0 pS)
    ( pair
      ( comp-zero-elim-ℤ P p0 pS)
      ( comp-succ-elim-ℤ P p0 pS))

equiv-comparison-map-Eq-ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s t : ELIM-ℤ P p0 pS) (k : ℤ) →
  Id ((pr1 s) k) ((pr1 t) k) ≃ Id ((pr1 s) (succ-ℤ k)) ((pr1 t) (succ-ℤ k))
equiv-comparison-map-Eq-ELIM-ℤ P p0 pS s t k =
  ( ( equiv-concat (pr2 (pr2 s) k) (pr1 t (succ-ℤ k))) ∘e
    ( equiv-concat' (map-equiv (pS k) (pr1 s k)) (inv (pr2 (pr2 t) k)))) ∘e
  ( equiv-ap (pS k) (pr1 s k) (pr1 t k))

zero-Eq-ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s t : ELIM-ℤ P p0 pS) (H : (pr1 s) ~ (pr1 t)) → UU l1
zero-Eq-ELIM-ℤ P p0 pS s t H =
  Id (H zero-ℤ) ((pr1 (pr2 s)) ∙ (inv (pr1 (pr2 t))))

succ-Eq-ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s t : ELIM-ℤ P p0 pS) (H : (pr1 s) ~ (pr1 t)) → UU l1
succ-Eq-ELIM-ℤ P p0 pS s t H =
  ( k : ℤ) → Id
    ( H (succ-ℤ k))
    ( map-equiv (equiv-comparison-map-Eq-ELIM-ℤ P p0 pS s t k) (H k))

Eq-ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s t : ELIM-ℤ P p0 pS) → UU l1
Eq-ELIM-ℤ P p0 pS s t =
  ELIM-ℤ
    ( λ k → Id (pr1 s k) (pr1 t k))
    ( (pr1 (pr2 s)) ∙ (inv (pr1 (pr2 t))))
    ( equiv-comparison-map-Eq-ELIM-ℤ P p0 pS s t)

reflexive-Eq-ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1)
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s : ELIM-ℤ P p0 pS) → Eq-ELIM-ℤ P p0 pS s s
reflexive-Eq-ELIM-ℤ P p0 pS (pair f (pair p H)) =
  pair
    ( refl-htpy)
    ( pair
      ( inv (right-inv p))
      ( λ k → inv (right-inv (H k))))

Eq-ELIM-ℤ-eq :
  { l1 : Level} (P : ℤ → UU l1) →
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s t : ELIM-ℤ P p0 pS) → Id s t → Eq-ELIM-ℤ P p0 pS s t
Eq-ELIM-ℤ-eq P p0 pS s .s refl = reflexive-Eq-ELIM-ℤ P p0 pS s

abstract
  is-contr-total-htpy' :
    {l1 l2 : Level} {A : UU l1} {B : A → UU l2} (f : (x : A) → B x) →
    is-contr (Σ ((x : A) → B x) (λ g → g ~ f))
  is-contr-total-htpy' {A = A} {B} f =
    is-contr-is-equiv'
      ( Σ ((x : A) → B x) (λ g → f ~ g))
      ( tot (λ g → htpy-inv))
      ( is-equiv-tot-is-fiberwise-equiv (λ g → is-equiv-htpy-inv f g))
      ( is-contr-total-htpy f)

abstract
  is-contr-total-Eq-ELIM-ℤ :
    { l1 : Level} (P : ℤ → UU l1) →
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
    ( s : ELIM-ℤ P p0 pS) → is-contr (Σ (ELIM-ℤ P p0 pS) (Eq-ELIM-ℤ P p0 pS s))
  is-contr-total-Eq-ELIM-ℤ P p0 pS s =
    is-contr-total-Eq-structure
      ( λ f t H →
        ( zero-Eq-ELIM-ℤ P p0 pS s (pair f t) H) ×
        ( succ-Eq-ELIM-ℤ P p0 pS s (pair f t) H))
      ( is-contr-total-htpy (pr1 s))
      ( pair (pr1 s) refl-htpy)
      ( is-contr-total-Eq-structure
        ( λ p K
          ( q : zero-Eq-ELIM-ℤ P p0 pS s
            ( pair (pr1 s) (pair p K))
            ( refl-htpy)) →
          succ-Eq-ELIM-ℤ P p0 pS s
            ( pair (pr1 s) (pair p K))
            ( refl-htpy))
        ( is-contr-is-equiv'
          ( Σ (Id (pr1 s zero-ℤ) p0) (λ α → Id α (pr1 (pr2 s))))
             ( tot (λ α → con-inv refl α (pr1 (pr2 s))))
          ( is-equiv-tot-is-fiberwise-equiv
            ( λ α → is-equiv-con-inv refl α (pr1 (pr2 s))))
          ( is-contr-total-path' (pr1 (pr2 s))))
        ( pair (pr1 (pr2 s)) (inv (right-inv (pr1 (pr2 s)))))
        ( is-contr-is-equiv'
          ( Σ ( ( k : ℤ) → Id (pr1 s (succ-ℤ k)) (pr1 (pS k) (pr1 s k)))
              ( λ β → β ~ (pr2 (pr2 s))))
          ( tot (λ β → htpy-con-inv refl-htpy β (pr2 (pr2 s))))
          ( is-equiv-tot-is-fiberwise-equiv
            ( λ β → is-equiv-htpy-con-inv refl-htpy β (pr2 (pr2 s))))
          ( is-contr-total-htpy' (pr2 (pr2 s)))))

abstract
  is-equiv-Eq-ELIM-ℤ-eq :
    { l1 : Level} (P : ℤ → UU l1) →
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
    ( s t : ELIM-ℤ P p0 pS) → is-equiv (Eq-ELIM-ℤ-eq P p0 pS s t)
  is-equiv-Eq-ELIM-ℤ-eq P p0 pS s =
    fundamental-theorem-id s
      ( reflexive-Eq-ELIM-ℤ P p0 pS s)
      ( is-contr-total-Eq-ELIM-ℤ P p0 pS s)
      ( Eq-ELIM-ℤ-eq P p0 pS s)

eq-Eq-ELIM-ℤ :
  { l1 : Level} (P : ℤ → UU l1) →
  ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
  ( s t : ELIM-ℤ P p0 pS) → Eq-ELIM-ℤ P p0 pS s t → Id s t
eq-Eq-ELIM-ℤ P p0 pS s t = inv-is-equiv (is-equiv-Eq-ELIM-ℤ-eq P p0 pS s t)

abstract
  is-prop-ELIM-ℤ :
    { l1 : Level} (P : ℤ → UU l1) →
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
    is-prop (ELIM-ℤ P p0 pS)
  is-prop-ELIM-ℤ P p0 pS =
    is-prop-is-prop'
      ( λ s t → eq-Eq-ELIM-ℤ P p0 pS s t
        ( Elim-ℤ
          ( λ k → Id (pr1 s k) (pr1 t k))
          ( (pr1 (pr2 s)) ∙ (inv (pr1 (pr2 t))))
          ( equiv-comparison-map-Eq-ELIM-ℤ P p0 pS s t)))

-- We finally arrive at the dependent universal property of ℤ

abstract
  is-contr-ELIM-ℤ :
    { l1 : Level} (P : ℤ → UU l1) →
    ( p0 : P zero-ℤ) (pS : (k : ℤ) → (P k) ≃ (P (succ-ℤ k))) →
    is-contr (ELIM-ℤ P p0 pS)
  is-contr-ELIM-ℤ P p0 pS =
    is-contr-is-prop-inh (is-prop-ELIM-ℤ P p0 pS) (Elim-ℤ P p0 pS)

-- The universal property of ℤ is now just a special case

ELIM-ℤ' :
  { l1 : Level} {X : UU l1} (x : X) (e : X ≃ X) → UU l1
ELIM-ℤ' {X = X} x e = ELIM-ℤ (λ k → X) x (λ k → e)

abstract
  universal-property-ℤ :
    { l1 : Level} {X : UU l1} (x : X) (e : X ≃ X) → is-contr (ELIM-ℤ' x e)
  universal-property-ℤ {X = X} x e = is-contr-ELIM-ℤ (λ k → X) x (λ k → e)

{- Section 12.5 The identity type of the circle -}

path-total-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l)
  (k : ℤ) →
  Id {A = Σ X (fundamental-cover-circle l dup-circle)}
     ( pair
       ( base-free-loop l)
       ( map-equiv (comp-fiber-fundamental-cover-circle l dup-circle) k))
     ( pair
       ( base-free-loop l)
       ( map-equiv
         ( comp-fiber-fundamental-cover-circle l dup-circle)
         ( succ-ℤ k)))
path-total-fundamental-cover-circle l dup-circle k =
  segment-Σ
    ( loop-free-loop l)
    ( equiv-succ-ℤ)
    ( comp-fiber-fundamental-cover-circle l dup-circle)
    ( comp-fiber-fundamental-cover-circle l dup-circle)
    ( comp-tr-fundamental-cover-circle l dup-circle)
    k

CONTRACTION-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  UU l1
CONTRACTION-fundamental-cover-circle l dup-circle =
  ELIM-ℤ
    ( λ k →
      Id ( center-total-fundamental-cover-circle l dup-circle)
         ( pair
           ( base-free-loop l)
           ( map-equiv (comp-fiber-fundamental-cover-circle l dup-circle) k)))
    ( refl)
    ( λ k → equiv-concat'
      ( center-total-fundamental-cover-circle l dup-circle)
      ( path-total-fundamental-cover-circle l dup-circle k))

Contraction-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  CONTRACTION-fundamental-cover-circle l dup-circle
Contraction-fundamental-cover-circle l dup-circle =
  Elim-ℤ
    ( λ k →
      Id ( center-total-fundamental-cover-circle l dup-circle)
         ( pair
           ( base-free-loop l)
           ( map-equiv (comp-fiber-fundamental-cover-circle l dup-circle) k)))
    ( refl)
    ( λ k → equiv-concat'
      ( center-total-fundamental-cover-circle l dup-circle)
      ( path-total-fundamental-cover-circle l dup-circle k))

abstract
  is-contr-total-fundamental-cover-circle :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
    is-contr (Σ X (fundamental-cover-circle l dup-circle))
  is-contr-total-fundamental-cover-circle l dup-circle =
    is-contr-total-fundamental-cover-circle-data l dup-circle
      ( pr1 (Contraction-fundamental-cover-circle l dup-circle))
      ( htpy-inv
        ( pr2 (pr2 (Contraction-fundamental-cover-circle l dup-circle))))

pt-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  fundamental-cover-circle l dup-circle (base-free-loop l)
pt-fundamental-cover-circle l dup-circle =
  map-equiv (comp-fiber-fundamental-cover-circle l dup-circle) zero-ℤ

fundamental-cover-circle-eq :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  ( x : X) → Id (base-free-loop l) x → fundamental-cover-circle l dup-circle x
fundamental-cover-circle-eq l dup-circle .(base-free-loop l) refl =
  pt-fundamental-cover-circle l dup-circle

abstract
  is-equiv-fundamental-cover-circle-eq :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
    ( x : X) → is-equiv (fundamental-cover-circle-eq l dup-circle x)
  is-equiv-fundamental-cover-circle-eq l dup-circle =
    fundamental-theorem-id
      ( base-free-loop l)
      ( pt-fundamental-cover-circle l dup-circle)
      ( is-contr-total-fundamental-cover-circle l dup-circle)
      ( fundamental-cover-circle-eq l dup-circle)

equiv-fundamental-cover-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  ( x : X) →
  ( Id (base-free-loop l) x) ≃ (fundamental-cover-circle l dup-circle x)
equiv-fundamental-cover-circle l dup-circle x =
  pair
    ( fundamental-cover-circle-eq l dup-circle x)
    ( is-equiv-fundamental-cover-circle-eq l dup-circle x)

comp-loop-space-circle :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  ( dup-circle : dependent-universal-property-circle (l1 ⊔ (lsuc lzero)) l) →
  ( Id (base-free-loop l) (base-free-loop l)) ≃ ℤ
comp-loop-space-circle l dup-circle =
  ( inv-equiv (comp-fiber-fundamental-cover-circle l dup-circle)) ∘e
  ( equiv-fundamental-cover-circle l dup-circle (base-free-loop l))


f : {A B : Set} → (@0 A → B) → A → B
f g x = g x


------------------------------------------------------------------------
-- Truncated queues: any two queues representing the same sequence are
-- equal, and things are set up so that at compile-time (but not at
-- run-time) some queue operations compute in roughly the same way as
-- the corresponding list operations
------------------------------------------------------------------------

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

import Equality.Path as P

module Queue.Truncated
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

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

open import Bijection equality-with-J as Bijection using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Erased.Cubical eq hiding (map)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import List equality-with-J as L hiding (map)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as Trunc
import Queue equality-with-J as Q
open import Sum equality-with-J
open import Surjection equality-with-J using (_↠_)

private
  variable
    a b     : Level
    A B     : Type a
    p q x   : A
    f       : A → B
    xs      : List A
    s s₁ s₂ : Very-stableᴱ-≡ A

------------------------------------------------------------------------
-- Queues

-- The queue type family is parametrised.

module _
  -- The underlying queue type family.
  (Q : ∀ {ℓ} → Type ℓ → Type ℓ)

  -- Note that the predicate is required to be trivial. Perhaps the
  -- code could be made more general, but I have not found a use for
  -- such generality.
  ⦃ is-queue : ∀ {ℓ} → Q.Is-queue (λ A → Q A) (λ _ → ↑ _ ⊤) ℓ ⦄
  where

  abstract

    -- Queues indexed by corresponding lists, and truncated so that
    -- any two queues that stand for the same list are seen as equal.
    --
    -- The type is abstract to ensure that a change to a different
    -- underlying queue type family does not break code that uses this
    -- module.
    --
    -- Ulf Norell suggested to me that I could use parametrisation
    -- instead of abstract. (Because if the underlying queue type
    -- family is a parameter, then the underlying queues do not
    -- compute.) I decided to use both. (Because I want to have the
    -- flexibility that comes with parametrisation, but I do not want
    -- to force users to work in a parametrised setting.)

    Queue_⟪_⟫ : {A : Type a} → @0 List A → Type a
    Queue_⟪_⟫ {A = A} xs =
      ∥ (∃ λ (q : Q A) → Erased (Q.to-List _ q ≡ xs)) ∥

  -- Queues.

  Queue : Type a → Type a
  Queue A = ∃ λ (xs : Erased (List A)) → Queue_⟪_⟫ (erased xs)

-- The remainder of the code uses an implicit underlying queue type
-- family parameter, and an extra instance argument.

module _
  {Q : ∀ {ℓ} → Type ℓ → Type ℓ}
  ⦃ is-queue : ∀ {ℓ} → Q.Is-queue (λ A → Q A) (λ _ → ↑ _ ⊤) ℓ ⦄
  ⦃ is-queue-with-map :
      ∀ {ℓ₁ ℓ₂} → Q.Is-queue-with-map (λ A → Q A) ℓ₁ ℓ₂ ⦄
  where

  abstract

    -- Queue Q ⟪ xs ⟫ is a proposition.

    Queue-⟪⟫-propositional :
      {@0 xs : List A} →
      Is-proposition (Queue Q ⟪ xs ⟫)
    Queue-⟪⟫-propositional = truncation-is-proposition

  -- Returns the (erased) index.

  @0 ⌊_⌋ : Queue Q A → List A
  ⌊_⌋ = erased ∘ proj₁

  -- There is a bijection between equality of two values of type
  -- Queue Q A and erased equality of the corresponding list indices.

  ≡-for-indices↔≡ :
    {xs ys : Queue Q A} →
    Erased (⌊ xs ⌋ ≡ ⌊ ys ⌋) ↔ xs ≡ ys
  ≡-for-indices↔≡ {xs = xs} {ys = ys} =
    Erased (⌊ xs ⌋ ≡ ⌊ ys ⌋)  ↝⟨ Erased-≡↔[]≡[] ⟩
    proj₁ xs ≡ proj₁ ys       ↝⟨ ignore-propositional-component Queue-⟪⟫-propositional ⟩□
    xs ≡ ys                   □

  -- If a queue equality holds under the (non-dependent) assumption
  -- that equality is very stable for the carrier type, then it also
  -- holds without this assumption.
  --
  -- For an example of a lemma which has this kind of assumption, see
  -- Queue.from-List≡foldl-enqueue-empty.

  strengthen-queue-equality :
    {q₁ q₂ : Queue Q A} → (Very-stable-≡ A → q₁ ≡ q₂) → q₁ ≡ q₂
  strengthen-queue-equality {q₁ = q₁} {q₂ = q₂} eq =
    _↔_.to ≡-for-indices↔≡
      [ ⌊ q₁ ⌋  ≡⟨ cong ⌊_⌋ (eq (Very-stable→Very-stable-≡ 0 (erased Erased-Very-stable))) ⟩∎
        ⌊ q₂ ⌋  ∎
      ]

------------------------------------------------------------------------
-- Conversion functions

  mutual

    abstract

      -- The right-to-left direction of Queue-⟪⟫↔Σ-List (defined
      -- below). Note that there is no assumption of stability.

      Σ-List→Queue-⟪⟫ :
        {@0 ys : List A} →
        (∃ λ xs → Erased (xs ≡ ys)) → Queue Q ⟪ ys ⟫
      Σ-List→Queue-⟪⟫ = _  -- Agda can infer the definition.

    -- If ys : List A and equality is very stable (with erased proofs)
    -- for A, then Queue Q ⟪ ys ⟫ is isomorphic to the type of lists
    -- equal (with erased equality proofs) to ys.
    --
    -- Note that equality is very stable for A if A has decidable
    -- equality.

    Queue-⟪⟫↔Σ-List :
      {@0 ys : List A} →
      Very-stableᴱ-≡ A →
      Queue Q ⟪ ys ⟫ ↔ ∃ λ xs → Erased (xs ≡ ys)
    Queue-⟪⟫↔Σ-List {ys = ys} s = Bijection.with-other-inverse
      Queue-⟪⟫↔Σ-List′
      Σ-List→Queue-⟪⟫
      (λ _ → from-Queue-⟪⟫↔Σ-List′)
      where
      abstract

        Queue-⟪⟫↔Σ-List′ : Queue Q ⟪ ys ⟫ ↔ ∃ λ xs → Erased (xs ≡ ys)
        Queue-⟪⟫↔Σ-List′ = ↠→↔Erased-singleton
          (Q.Queue↠List _)
          (Very-stableᴱ-≡-List 0 s)

        from-Queue-⟪⟫↔Σ-List′ :
          _≡_ {A = Queue Q ⟪ ys ⟫}
              (_↔_.from Queue-⟪⟫↔Σ-List′ p)
              (Σ-List→Queue-⟪⟫ p)
        from-Queue-⟪⟫↔Σ-List′ = refl _

  -- If equality is very stable (with erased proofs) for A, then
  -- Queue Q A is isomorphic to List A.

  Queue↔List : Very-stableᴱ-≡ A → Queue Q A ↔ List A
  Queue↔List {A = A} s =
    Queue Q A                                                        ↔⟨⟩
    (∃ λ (xs : Erased (List A)) → Queue Q ⟪ erased xs ⟫)             ↝⟨ (∃-cong λ _ → Queue-⟪⟫↔Σ-List s) ⟩
    (∃ λ (xs : Erased (List A)) → ∃ λ ys → Erased (ys ≡ erased xs))  ↝⟨ Σ-Erased-Erased-singleton↔ ⟩□
    List A                                                           □

  mutual

    -- The right-to-left direction of Queue↔List. (Note that equality
    -- is not required to be very stable with erased proofs for the
    -- carrier type.)

    from-List : List A → Queue Q A
    from-List = _  -- Agda can infer the definition.

    _ : _↔_.from (Queue↔List s) ≡ from-List
    _ = refl _

  -- The forward direction of Queue↔List s.

  to-List : Very-stableᴱ-≡ A → Queue Q A → List A
  to-List s = _↔_.to (Queue↔List s)

  abstract

    -- The function to-List returns the index.

    @0 ≡⌊⌋ : to-List s q ≡ ⌊ q ⌋
    ≡⌊⌋ {s = s} {q = q} =
      to-Σ-Erased-∥-Σ-Erased-≡-∥↔≡
        (Q.Queue↠List _) (Very-stableᴱ-≡-List 0 s) q

  -- Queue Q A is isomorphic to List A in an erased context. The
  -- forward direction of this isomorphism returns the index directly.

  @0 Queue↔Listⁱ : Queue Q A ↔ List A
  Queue↔Listⁱ {A = A} =
    Queue Q A                                             ↔⟨⟩
    (∃ λ (xs : Erased (List A)) → Queue Q ⟪ erased xs ⟫)  ↝⟨ drop-⊤-right (λ _ → _⇔_.to contractible⇔↔⊤ $
                                                             propositional⇒inhabited⇒contractible Queue-⟪⟫-propositional $
                                                             _↔_.from (Queue-⟪⟫↔Σ-List (Very-stable→Very-stableᴱ 1 $
                                                                                Very-stable→Very-stable-≡ 0 $
                                                                                erased Erased-Very-stable))
                                                                      (_ , [ refl _ ])) ⟩
    Erased (List A)                                       ↝⟨ Very-stable→Stable 0 $ erased Erased-Very-stable ⟩□
    List A                                                □

  private

    @0 to-Queue↔Listⁱ-, : _↔_.to Queue↔Listⁱ q ≡ ⌊ q ⌋
    to-Queue↔Listⁱ-, = refl _

  -- The forward directions of Queue↔List and Queue↔Listⁱ match.

  @0 to-Queue↔List : _↔_.to (Queue↔List s) q ≡ _↔_.to Queue↔Listⁱ q
  to-Queue↔List = ≡⌊⌋

  -- Variants of Queue↔List and Queue↔Listⁱ.

  Maybe[×Queue]↔List :
    Very-stableᴱ-≡ A →
    Maybe (A × Queue Q A) ↔ List A
  Maybe[×Queue]↔List {A = A} s =
    Maybe (A × Queue Q A)  ↝⟨ F.id ⊎-cong F.id ×-cong Queue↔List s ⟩
    Maybe (A × List A)     ↝⟨ inverse List↔Maybe[×List] ⟩□
    List A                 □

  @0 Maybe[×Queue]↔Listⁱ :
    Maybe (A × Queue Q A) ↔ List A
  Maybe[×Queue]↔Listⁱ {A = A} =
    Maybe (A × Queue Q A)  ↝⟨ F.id ⊎-cong F.id ×-cong Queue↔Listⁱ ⟩
    Maybe (A × List A)     ↝⟨ inverse List↔Maybe[×List] ⟩□
    List A                 □

  @0 to-Maybe[×Queue]↔List :
    ∀ xs →
    _↔_.to (Maybe[×Queue]↔List s) xs ≡
    _↔_.to Maybe[×Queue]↔Listⁱ xs
  to-Maybe[×Queue]↔List {s = s} xs =
    _↔_.from List↔Maybe[×List]
      (⊎-map id (Σ-map id (_↔_.to (Queue↔List s))) xs)  ≡⟨ cong (λ f → _↔_.from List↔Maybe[×List] (⊎-map id (Σ-map id f) xs)) (⟨ext⟩ λ _ →
                                                           to-Queue↔List) ⟩∎
    _↔_.from List↔Maybe[×List]
      (⊎-map id (Σ-map id (_↔_.to Queue↔Listⁱ)) xs)     ∎

  -- A lemma that can be used to prove "to-List lemmas".

  ⌊⌋≡→to-List≡ :
    Erased (⌊ q ⌋ ≡ xs) →
    to-List s q ≡ xs
  ⌊⌋≡→to-List≡ {q = q} {xs = xs} {s = s} eq =
    to-List s q               ≡⟨ cong (to-List _) (_↔_.to ≡-for-indices↔≡ eq) ⟩
    to-List s (from-List xs)  ≡⟨ _↔_.right-inverse-of (Queue↔List _) _ ⟩∎
    xs                        ∎

------------------------------------------------------------------------
-- Some queue operations, implemented for Queue ⟪_⟫

  module Indexed where

    abstract

      private

        -- A helper function that can be used to define unary
        -- functions on queues.

        unary :
          {A : Type a} {B : Type b}
          {@0 xs : List A} {@0 f : List A → List B}
          (g : Q A → Q B) →
          @0 (∀ {q} → Q.to-List _ (g q) ≡ f (Q.to-List _ q)) →
          Queue Q ⟪ xs ⟫ → Queue Q ⟪ f xs ⟫
        unary {xs = xs} {f = f} g hyp = Trunc.rec
          truncation-is-proposition
          (uncurry λ q p →
             ∣ g q
             , [ Q.to-List _ (g q)  ≡⟨ hyp ⟩
                 f (Q.to-List _ q)  ≡⟨ cong f (erased p) ⟩∎
                 f xs               ∎
               ]
             ∣)

      -- Enqueues an element.

      enqueue :
        {@0 xs : List A}
        (x : A) → Queue Q ⟪ xs ⟫ → Queue Q ⟪ xs ++ x ∷ [] ⟫
      enqueue x = unary (Q.enqueue x) Q.to-List-enqueue

      -- A map function.

      map :
        {@0 xs : List A} →
        (f : A → B) → Queue Q ⟪ xs ⟫ → Queue Q ⟪ L.map f xs ⟫
      map f = unary (Q.map f) Q.to-List-map

    -- The result of trying to dequeue an element from an indexed
    -- queue.
    --
    -- TODO: Perhaps it makes sense to make Q an explicit argument of
    -- this definition.

    Result-⟪_⟫ : {A : Type a} → @0 List A → Type a
    Result-⟪_⟫ {A = A} xs =
      ∃ λ (q : Maybe (A × Queue Q A)) →
        Erased (_↔_.to Maybe[×Queue]↔Listⁱ q ≡ xs)

    -- If equality is very stable (with erased proofs) for A, then
    -- Result-⟪ xs ⟫ is a proposition for lists xs of type List A.

    Result-⟪⟫-propositional :
      {@0 xs : List A} →
      Very-stableᴱ-≡ A →
      Is-proposition Result-⟪ xs ⟫
    Result-⟪⟫-propositional {A = A} {xs = xs} s =
                                            $⟨ erased-singleton-with-erased-center-propositional (Very-stableᴱ-≡-List 0 s) ⟩
      Is-proposition (Erased-singleton xs)  ↝⟨ H-level-cong _ 1 (inverse lemma) ⦂ (_ → _) ⟩□
      Is-proposition Result-⟪ xs ⟫          □
      where
      lemma : _ ↔ _
      lemma =
        Result-⟪ xs ⟫                                       ↔⟨⟩

        (∃ λ (ys : Maybe (A × Queue Q A)) →
           Erased (_↔_.to Maybe[×Queue]↔Listⁱ ys ≡ xs))     ↝⟨ ∃-cong (λ ys → Erased-cong (≡⇒↝ _ $ cong (_≡ xs) $ sym $
                                                               to-Maybe[×Queue]↔List ys)) ⟩
        (∃ λ (ys : Maybe (A × Queue Q A)) →
           Erased (_↔_.to (Maybe[×Queue]↔List s) ys ≡ xs))  ↝⟨ Σ-cong (Maybe[×Queue]↔List s) (λ _ → F.id) ⟩

        (∃ λ (ys : List A) → Erased (ys ≡ xs))              ↔⟨⟩

        Erased-singleton xs                                 □

    abstract

      -- Dequeuing.

      dequeue :
        {@0 xs : List A} →
        Very-stableᴱ-≡ A →
        Queue Q ⟪ xs ⟫ →
        Result-⟪ xs ⟫
      dequeue {xs = xs} s = Trunc.rec
        (Result-⟪⟫-propositional s)
        (λ (q , [ eq ]) →

             ⊎-map id (Σ-map id λ q → _ , ∣ q , [ refl _ ] ∣)
               (Q.dequeue _ q)

           , [ _↔_.to Maybe[×Queue]↔Listⁱ
                 (⊎-map id (Σ-map id (λ q → _ , ∣ q , [ refl _ ] ∣))
                    (Q.dequeue _ q))                                     ≡⟨⟩

               _↔_.from List↔Maybe[×List]
                 (⊎-map id (Σ-map id (_↔_.to Queue↔Listⁱ))
                    (⊎-map id (Σ-map id (λ q → _ , ∣ q , [ refl _ ] ∣))
                       (Q.dequeue _ q)))                                 ≡⟨ cong (_↔_.from List↔Maybe[×List]) $ sym $ ⊎-map-∘ (Q.dequeue _ q) ⟩

               _↔_.from List↔Maybe[×List]
                 (⊎-map id (Σ-map id (Q.to-List _)) (Q.dequeue _ q))     ≡⟨ cong (_↔_.from List↔Maybe[×List]) $ Q.to-List-dequeue {q = q} ⟩

               _↔_.from List↔Maybe[×List]
                 (_↔_.to List↔Maybe[×List] (Q.to-List _ q))              ≡⟨ _↔_.left-inverse-of List↔Maybe[×List] _ ⟩

               Q.to-List _ q                                             ≡⟨ eq ⟩∎

               xs                                                        ∎
             ])

      -- The inverse of the dequeue operation. This operation does not
      -- depend on stability.

      dequeue⁻¹ :
        {@0 xs : List A} →
        Result-⟪ xs ⟫ → Queue Q ⟪ xs ⟫
      dequeue⁻¹ {xs = xs} (nothing , eq) =
        ∣ Q.empty
        , [ Q.to-List _ (Q.empty ⦂ Q _)  ≡⟨ Q.to-List-empty ⟩
            []                           ≡⟨ erased eq ⟩∎
            xs                           ∎
          ]
        ∣
      dequeue⁻¹ {xs = xs} (just (x , ys , q) , eq) =
        ∥∥-map (Σ-map (Q.cons x)
                      (λ {q′} → Erased-cong λ eq′ →
                                  Q.to-List _ (Q.cons x q′)  ≡⟨ Q.to-List-cons ⟩
                                  x ∷ Q.to-List _ q′         ≡⟨ cong (x ∷_) eq′ ⟩
                                  x ∷ erased ys              ≡⟨ erased eq ⟩∎
                                  xs                         ∎))
               q

    -- The dequeue and dequeue⁻¹ operations are inverses.

    Queue-⟪⟫↔Result-⟪⟫ :
      {@0 xs : List A} →
      Very-stableᴱ-≡ A →
      Queue Q ⟪ xs ⟫ ↔ Result-⟪ xs ⟫
    Queue-⟪⟫↔Result-⟪⟫ s = record
      { surjection = record
        { logical-equivalence = record
          { to   = dequeue s
          ; from = dequeue⁻¹
          }
        ; right-inverse-of = λ _ → Result-⟪⟫-propositional s _ _
        }
      ; left-inverse-of = λ _ → Queue-⟪⟫-propositional _ _
      }

------------------------------------------------------------------------
-- Some queue operations, implemented for Queue

  -- Note that none of these operations are abstract.

  module Non-indexed where

    -- Enqueues an element.

    enqueue : A → Queue Q A → Queue Q A
    enqueue x = Σ-map _ (Indexed.enqueue x)

    to-List-enqueue : to-List s (enqueue x q) ≡ to-List s q ++ x ∷ []
    to-List-enqueue {s = s} {x = x} {q = q} = ⌊⌋≡→to-List≡
      [ ⌊ q ⌋ ++ x ∷ []        ≡⟨ cong (_++ _) $ sym ≡⌊⌋ ⟩∎
        to-List s q ++ x ∷ []  ∎
      ]

    -- A map function.

    map : (A → B) → Queue Q A → Queue Q B
    map f = Σ-map _ (Indexed.map f)

    to-List-map : to-List s₁ (map f q) ≡ L.map f (to-List s₂ q)
    to-List-map {f = f} {q = q} {s₂ = s₂} = ⌊⌋≡→to-List≡
      [ L.map f ⌊ q ⌋           ≡⟨ cong (L.map f) $ sym ≡⌊⌋ ⟩∎
        L.map f (to-List s₂ q)  ∎
      ]

    private

      -- A variant of the result of the dequeue operation.

      Result : Type a → Type a
      Result A =
        ∃ λ (xs : Erased (List A)) → Indexed.Result-⟪ erased xs ⟫

      -- Conversion lemmas for Result.

      Result↠Maybe[×Queue] : Result A ↠ Maybe (A × Queue Q A)
      Result↠Maybe[×Queue] = record
        { logical-equivalence = record
          { to   = proj₁ ∘ proj₂
          ; from = λ q → _ , q , [ refl _ ]
          }
        ; right-inverse-of = refl
        }

      Result↔Maybe[×Queue] :
        Very-stableᴱ-≡ A →
        Result A ↔ Maybe (A × Queue Q A)
      Result↔Maybe[×Queue] s = record
        { surjection      = Result↠Maybe[×Queue]
        ; left-inverse-of = λ r →               $⟨ from∘to r ⟩
            Erased (⌊ from (to r) ⌋ʳ ≡ ⌊ r ⌋ʳ)  ↝⟨ Erased-≡↔[]≡[] ⟩
            proj₁ (from (to r)) ≡ proj₁ r       ↝⟨ ignore-propositional-component (Indexed.Result-⟪⟫-propositional s) ⟩□
            from (to r) ≡ r                     □
        }
        where
        open _↠_ Result↠Maybe[×Queue]

        @0 ⌊_⌋ʳ : Result A → List A
        ⌊_⌋ʳ = erased ∘ proj₁

        from∘to : ∀ r → Erased (⌊ from (to r) ⌋ʳ ≡ ⌊ r ⌋ʳ)
        from∘to (_ , _ , eq) = eq

    -- Queue Q A is isomorphic to Maybe (A × Queue Q A), assuming that
    -- equality is very stable (with erased proofs) for A.

    Queue↔Maybe[×Queue] :
      Very-stableᴱ-≡ A →
      Queue Q A ↔ Maybe (A × Queue Q A)
    Queue↔Maybe[×Queue] {A = A} s =
      Queue Q A              ↝⟨ ∃-cong (λ _ → Indexed.Queue-⟪⟫↔Result-⟪⟫ s) ⟩
      Result A               ↝⟨ Result↔Maybe[×Queue] s ⟩□
      Maybe (A × Queue Q A)  □

    mutual

      -- The inverse of the dequeue operation. This operation does not
      -- depend on stability.

      dequeue⁻¹ : Maybe (A × Queue Q A) → Queue Q A
      dequeue⁻¹ q = _  -- Agda can infer the definition.

      _ : _↔_.from (Queue↔Maybe[×Queue] s) ≡ dequeue⁻¹
      _ = refl _

    to-List-dequeue⁻¹ :
      to-List s (dequeue⁻¹ x) ≡
      _↔_.from List↔Maybe[×List] (⊎-map id (Σ-map id (to-List s)) x)
    to-List-dequeue⁻¹ {x = nothing} = ⌊⌋≡→to-List≡ [ refl _ ]

    to-List-dequeue⁻¹ {s = s} {x = just (x , q)} = ⌊⌋≡→to-List≡
      [ x ∷ ⌊ q ⌋        ≡⟨ cong (_ ∷_) $ sym ≡⌊⌋ ⟩∎
        x ∷ to-List s q  ∎
      ]

    -- Dequeues an element, if possible.

    dequeue : Very-stableᴱ-≡ A → Queue Q A → Maybe (A × Queue Q A)
    dequeue s = _↔_.to (Queue↔Maybe[×Queue] s)

    to-List-dequeue :
      ⊎-map id (Σ-map id (to-List s)) (dequeue s q) ≡
      _↔_.to List↔Maybe[×List] (to-List s q)
    to-List-dequeue {s = s} {q = q} =
      ⊎-map id (Σ-map id (to-List s)) (dequeue s q)                   ≡⟨ _↔_.to (from≡↔≡to (from-isomorphism List↔Maybe[×List])) $
                                                                         sym to-List-dequeue⁻¹ ⟩
      _↔_.to List↔Maybe[×List] (to-List s (dequeue⁻¹ (dequeue s q)))  ≡⟨ cong (_↔_.to List↔Maybe[×List] ∘ to-List s) $
                                                                         _↔_.left-inverse-of (Queue↔Maybe[×Queue] _) _ ⟩∎
      _↔_.to List↔Maybe[×List] (to-List s q)                          ∎


postulate
  A : Set

data B : Set where
  x : A → B

f : A → A
f = {!!} -- C-c C-c yields 'f x = ?', which fails to type check


-- Andreas, 2019-11-06, issue #4173, reported and testcase by nad.
-- Allow pattern matching on erased arguments in erased context.

-- {-# OPTIONS -v tc.cover.split:60 #-}

open import Agda.Builtin.Bool

@0 F : @0 Bool → Set₁
F true  = Set
F false = Set

-- Should succeed.

@0 G : @0 Bool → Set₁
G x = {! x !}  -- splitting on x should also succeed


------------------------------------------------------------------------
-- The lenses fst and snd
------------------------------------------------------------------------

-- This module uses univalence without tracking such uses in the types
-- of functions, and it is not parametrised by a notion of equality,
-- it uses path equality.

{-# OPTIONS --guardedness #-}

module README.Fst-snd where

open import Equality.Path
open import Equality.Path.Univalence
open import Prelude

open import Equivalence.Erased.Cubical equality-with-paths as EEq
  using (_≃ᴱ_)

import Lens.Non-dependent.Higher.Coinductive.Small.Erased
  equality-with-paths as S
import Lens.Non-dependent.Higher.Erased equality-with-paths as E

private
  variable
    a   : Level
    A B : Type a

-- A static variant of one consequence of S.Lens≃ᴱLensᴱ. Applications
-- of static functions are normalised by (at least) the GHC backend.

Lens→Lens : E.Lens A B → S.Lens univ A B
Lens→Lens = _≃ᴱ_.from (S.Lens≃ᴱLensᴱ ⊠ univ)

{-# STATIC Lens→Lens #-}

-- A lens for the first projection.

fst : S.Lens univ (A × B) A
fst = Lens→Lens E.fst

-- A lens for the second projection.
--
-- With the implementation that this lens had at the time of writing
-- (dependencies may later have changed) it turned out that when the
-- lens was compiled using the non-strict GHC backend of a certain
-- development version of Agda and GHC 9.0.1, then GHC's flag
-- -ddump-simpl suggested that you ended up with code that could lead
-- to a space leak: the code for the setter was something like
--
--   \p y -> Pair (case p of { Pair x _ -> x }) y
--
-- (where names have been changed, and code related to coercions and
-- casts has been removed).
--
-- Note that, unlike the lens snd^C discussed in "Compiling Programs
-- with Erased Univalence", this one (as well as the one below) takes
-- two universe level arguments.

snd-with-space-leak : S.Lens univ (A × B) B
snd-with-space-leak = Lens→Lens E.snd

-- A lens for the second projection.
--
-- This variant did not seem to have the problem exhibited by
-- snd-with-space-leak: the code for the setter was something like
--
--   \p y -> case p of { Pair x _ -> Pair x y }.

snd : S.Lens univ (A × B) B
snd =
  S.with-other-setter
    (Lens→Lens E.snd)
    (λ { (x , _) y → (x , y) })
    ((λ (x , _) y → (x , y))       ≡⟨⟩
     E.Lens.set E.snd              ≡⟨ sym $ proj₂ $ proj₂ (S.Lens≃ᴱLensᴱ-preserves-getters-and-setters ⊠ univ univ) E.snd ⟩∎
     S.Lens.set (Lens→Lens E.snd)  ∎)


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

open import lib.Basics

module lib.types.Empty where

⊥ = Empty

⊥-elim : ∀ {i} {A : ⊥ → Type i} → ((x : ⊥) → A x)
⊥-elim = Empty-elim

Empty-rec : ∀ {i} {A : Type i} → (Empty → A)
Empty-rec = Empty-elim

⊥-rec : ∀ {i} {A : Type i} → (⊥ → A)
⊥-rec = Empty-rec

Empty-is-prop : is-prop Empty
Empty-is-prop = Empty-elim

⊥-is-prop : is-prop ⊥
⊥-is-prop = Empty-is-prop


postulate
  A : Set
  I : ..(_ : A) → Set
  R : A → Set
  f : ∀ ..(x : A) (r : R x) → I x
 -- can now be used here ^