module Untyped.Monads where

open import Function

open import Data.Unit
open import Data.Product as Prod
open import Data.Sum
open import Data.Sum public using () renaming (_⊎_ to Exceptional; inj₁ to exc; inj₂ to ✓)

open import Category.Monad

id-monad : ∀ {ℓ} → RawMonad {ℓ} id
id-monad = record
  { return = id
  ; _>>=_  = λ a f → f a }

record MonadReader (m : Set → Set) (e : Set) : Set₁ where
  field
    ask       : m e
    local     : ∀ {a} → (e → e) → m a → m a

  asks : ∀ ⦃ _ : RawMonad m ⦄ {a} → (e → a) → m a
  asks ⦃ m ⦄ f = let open RawMonad m in do
    e ← ask
    return $ f (e)

ReaderT : Set → (M : Set → Set) → Set → Set
ReaderT E M A = E → M A

module _ (E : Set) (M : Set → Set) ⦃ mon : RawMonad M ⦄ where
  open RawMonad mon

  reader-monad : RawMonad (ReaderT E M)
  reader-monad = record
    { return = const ∘ return
    ; _>>=_  = λ m f e → m e >>= λ x → f x e }

  reader-monad-reader : MonadReader (ReaderT E M) E
  reader-monad-reader = record
    { ask = return
    ; local = λ f c e → c (f e) }

record MonadWriter (m : Set → Set) (w : Set) : Set₁ where
  field
    write : w → m ⊤

record MonadState (m : Set → Set) (s : Set) : Set₁ where
  field
    state : ∀ {a} → (s → s × a) → m a

  put : s → m ⊤
  put s = state λ _ → (s , tt)

  get : m s
  get = state λ s → (s , s)

  gets : ∀ {a} → (s → a) → m a
  gets f = state λ s → (s , f s)

  modify : ⦃ _ : RawMonad m ⦄ → (s → s) → m ⊤
  modify ⦃ M ⦄ f = let open RawMonad M in do
    s ← get
    put (f s)

StateT : Set → (M : Set → Set) → Set → Set
StateT S M A = S → M (S × A)

module _ (S : Set) (M : Set → Set) ⦃ mon : RawMonad M ⦄ where

  state-monad : RawMonad (StateT S M)
  state-monad = record
    { return = λ a s → return (s , a)
    ; _>>=_  = λ m f s → m s >>= λ where (s' , a) → f a s' }
    where open RawMonad mon

  state-monad-state : MonadState (StateT S M) S
  state-monad-state = record
    { state = λ f s → return (f s) }
    where open RawMonad mon

  open MonadState state-monad-state

{- State focussing -}
module _ {S F M} (focus : S → F) (update : F → S → S)
  ⦃ mon : RawMonad M ⦄
  (st  : MonadState M S)
  where

  focus-monad-state : MonadState M F
  focus-monad-state = record
    { state = λ f →
      MonadState.state st λ s →
        Prod.map₁ (λ f → update f s) (f (focus s))
    }

module _ {M S} ⦃ m : RawMonad M ⦄ (stm : MonadState M S) where
  open RawMonad m
  open MonadState stm

  state-monad-reader : MonadReader M S
  state-monad-reader = record
    { ask   = get
    ; local = λ f m → do
      backup ← get
      modify f
      a ← m
      put backup
      return a
    }

  state-monad-writer : MonadWriter M S
  state-monad-writer = record
    { write = put }

ExceptT : Set → (Set → Set) → Set → Set
ExceptT E M A = M (E ⊎ A)

record MonadExcept (m : Set → Set) (e : Set) : Set₁ where
  field
    throw     : ∀ {a} → e → m a

module _ {E : Set} {M : Set → Set} ⦃ mon : RawMonad M ⦄ where
  open RawMonad mon

  except-monad : RawMonad (ExceptT E M)
  except-monad = record
    { return = λ a → return (✓ a)
    ; _>>=_ = λ where
                c f → c >>= λ where
                  (exc x) → return $ exc x
                  (✓ y)   → f y }

  except-monad-except : MonadExcept (ExceptT E M) E
  except-monad-except = record
    { throw = λ e → return (exc e) }

record MonadResumption (m : Set → Set) (c h : Set) : Set₁ where
  field
    yield : m ⊤
    fork  : c → m h

record MonadComm (m : Set → Set) (c v : Set) : Set₁ where
  field
    recv  : c → m v
    send  : c → v → m ⊤
    close : c → m ⊤

module _ c (r : c → Set) where
  mutual
    Cont = λ cmd a → (r cmd → Free a)

    data Free a : Set where
      pure   : a → Free a
      impure : (cmd : c) → Cont cmd a → Free a

free-monad : ∀ {c r} → RawMonad (Free c r)
free-monad = record
  { return = pure
  ; _>>=_  = bind }
  where
    bind : ∀ {c r a b} → Free c r a → (a → Free c r b) → Free c r b
    bind = λ where
      (pure a) f     → f a
      (impure c k) f → impure c (flip bind f ∘ k)

-- one cannot easily define instances like free-monad-comm generically
-- for some command type and interpretation, because MonadComm
-- requires that the recv return type is fixed a priori, whereas
-- free allows it to be dependent on the command payload.

module M where
  open RawMonad ⦃...⦄ public
  open MonadReader ⦃...⦄ public
  open MonadWriter ⦃...⦄ public renaming (write to schedule)
  open MonadResumption ⦃...⦄ public
  open MonadComm ⦃...⦄ public
  open MonadExcept ⦃...⦄ public
  open MonadState ⦃...⦄ public


{-# OPTIONS --without-K --allow-unsolved-metas --exact-split #-}

module 21-pushouts where

import 20-pullbacks
open 20-pullbacks public

-- Section 14.1

{- We define the type of cocones with vertex X on a span. Since we will use it
   later on, we will also characterize the identity type of the type of cocones
   with a given vertex X. -}

cocone :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) → UU l4 → UU _
cocone {A = A} {B = B} f g X =
  Σ (A → X) (λ i → Σ (B → X) (λ j → (i ∘ f) ~ (j ∘ g)))

{- We characterize the identity type of the type of cocones with vertex C. -}

coherence-htpy-cocone :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c c' : cocone f g X) →
  (K : (pr1 c) ~ (pr1 c')) (L : (pr1 (pr2 c)) ~ (pr1 (pr2 c'))) → UU (l1 ⊔ l4)
coherence-htpy-cocone f g c c' K L =
  ((pr2 (pr2 c)) ∙h (L ·r g)) ~ ((K ·r f) ∙h (pr2 (pr2 c')))

htpy-cocone :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} →
  cocone f g X → cocone f g X → UU (l1 ⊔ (l2 ⊔ (l3 ⊔ l4)))
htpy-cocone f g c c' =
  Σ ((pr1 c) ~ (pr1 c'))
    ( λ K → Σ ((pr1 (pr2 c)) ~ (pr1 (pr2 c')))
      ( coherence-htpy-cocone f g c c' K))

reflexive-htpy-cocone :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  htpy-cocone f g c c
reflexive-htpy-cocone f g (pair i (pair j H)) =
  pair refl-htpy (pair refl-htpy htpy-right-unit)

htpy-cocone-eq :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c c' : cocone f g X) →
  Id c c' → htpy-cocone f g c c'
htpy-cocone-eq f g c .c refl = reflexive-htpy-cocone f g c

is-contr-total-htpy-cocone :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  is-contr (Σ (cocone f g X) (htpy-cocone f g c))
is-contr-total-htpy-cocone f g c =
  is-contr-total-Eq-structure
    ( λ i' jH' K → Σ ((pr1 (pr2 c)) ~ (pr1 jH'))
      ( coherence-htpy-cocone f g c (pair i' jH') K))
    ( is-contr-total-htpy (pr1 c))
    ( pair (pr1 c) refl-htpy)
    ( is-contr-total-Eq-structure
      ( λ j' H' → coherence-htpy-cocone f g c
        ( pair (pr1 c) (pair j' H'))
        ( refl-htpy))
      ( is-contr-total-htpy (pr1 (pr2 c)))
      ( pair (pr1 (pr2 c)) refl-htpy)
      ( is-contr-is-equiv'
        ( Σ (((pr1 c) ∘ f) ~ ((pr1 (pr2 c)) ∘ g)) (λ H' → (pr2 (pr2 c)) ~ H'))
        ( tot (λ H' M → htpy-right-unit ∙h M))
        ( is-equiv-tot-is-fiberwise-equiv (λ H' → is-equiv-htpy-concat _ _))
        ( is-contr-total-htpy (pr2 (pr2 c)))))

is-equiv-htpy-cocone-eq :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c c' : cocone f g X) →
  is-equiv (htpy-cocone-eq f g c c')
is-equiv-htpy-cocone-eq f g c =
  fundamental-theorem-id c
    ( reflexive-htpy-cocone f g c)
    ( is-contr-total-htpy-cocone f g c)
    ( htpy-cocone-eq f g c)

eq-htpy-cocone :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c c' : cocone f g X) →
  htpy-cocone f g c c' → Id c c'
eq-htpy-cocone f g c c' = inv-is-equiv (is-equiv-htpy-cocone-eq f g c c')

{- Given a cocone c on a span S with vertex X, and a type Y, the function
   cocone-map sends a function X → Y to a new cocone with vertex Y. -}

cocone-map :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} {Y : UU l5} →
  cocone f g X → (X → Y) → cocone f g Y
cocone-map f g (pair i (pair j H)) h =
  pair (h ∘ i) (pair (h ∘ j) (h ·l H))

cocone-map-id :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  Id (cocone-map f g c id) c
cocone-map-id f g (pair i (pair j H)) =
  eq-pair refl (eq-pair refl (eq-htpy (λ s → ap-id (H s))))

cocone-map-comp :
  {l1 l2 l3 l4 l5 l6 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X)
  {Y : UU l5} (h : X → Y) {Z : UU l6} (k : Y → Z) →
  Id (cocone-map f g c (k ∘ h)) (cocone-map f g (cocone-map f g c h) k)
cocone-map-comp f g (pair i (pair j H)) h k =
  eq-pair refl (eq-pair refl (eq-htpy (λ s → ap-comp k h (H s))))

{- A cocone c on a span S is said to satisfy the universal property of the
   pushout of S if the function cocone-map is an equivalence for every type Y.
   -}

universal-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} →
  cocone f g X → UU _
universal-property-pushout l f g c =
  (Y : UU l) → is-equiv (cocone-map f g {Y = Y} c)

map-universal-property-pushout :
  {l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ( up-c : {l : Level} → universal-property-pushout l f g c)
  {Y : UU l5} → cocone f g Y → (X → Y)
map-universal-property-pushout f g c up-c {Y} = inv-is-equiv (up-c Y)

htpy-cocone-map-universal-property-pushout :
  { l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  ( f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ( up-c : {l : Level} → universal-property-pushout l f g c)
  { Y : UU l5} (d : cocone f g Y) →
  htpy-cocone f g
    ( cocone-map f g c
      ( map-universal-property-pushout f g c up-c d))
    ( d)
htpy-cocone-map-universal-property-pushout f g c up-c {Y} d =
  htpy-cocone-eq f g
    ( cocone-map f g c (map-universal-property-pushout f g c up-c d))
    ( d)
    ( issec-inv-is-equiv (up-c Y) d)

uniqueness-map-universal-property-pushout :
  { l1 l2 l3 l4 l5 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  ( f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  ( up-c : {l : Level} → universal-property-pushout l f g c) →
  { Y : UU l5} (d : cocone f g Y) →
  is-contr ( Σ (X → Y) (λ h → htpy-cocone f g (cocone-map f g c h) d))
uniqueness-map-universal-property-pushout f g c up-c {Y} d =
  is-contr-is-equiv'
    ( fib (cocone-map f g c) d)
    ( tot (λ h → htpy-cocone-eq f g (cocone-map f g c h) d))
    ( is-equiv-tot-is-fiberwise-equiv
      ( λ h → is-equiv-htpy-cocone-eq f g (cocone-map f g c h) d))
    ( is-contr-map-is-equiv (up-c Y) d)

{- We derive a 3-for-2 property of pushouts, analogous to the 3-for-2 property
   of pullbacks. -}

triangle-cocone-cocone :
  { l1 l2 l3 l4 l5 l6 : Level}
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} {Y : UU l5}
  { f : S → A} {g : S → B} (c : cocone f g X) (d : cocone f g Y)
  ( h : X → Y) (KLM : htpy-cocone f g (cocone-map f g c h) d)
  ( Z : UU l6) →
  ( cocone-map f g d) ~ ((cocone-map f g c) ∘ (λ (k : Y → Z) → k ∘ h))
triangle-cocone-cocone {Y = Y} {f = f} {g = g} c d h KLM Z k =
  inv
    ( ( cocone-map-comp f g c h k) ∙
      ( ap
        ( λ t → cocone-map f g t k)
        ( eq-htpy-cocone f g (cocone-map f g c h) d KLM)))

is-equiv-up-pushout-up-pushout :
  { l1 l2 l3 l4 l5 : Level}
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} {Y : UU l5}
  ( f : S → A) (g : S → B) (c : cocone f g X) (d : cocone f g Y) →
  ( h : X → Y) (KLM : htpy-cocone f g (cocone-map f g c h) d) →
  ( up-c : {l : Level} → universal-property-pushout l f g c) →
  ( up-d : {l : Level} → universal-property-pushout l f g d) →
  is-equiv h
is-equiv-up-pushout-up-pushout f g c d h KLM up-c up-d =
  is-equiv-is-equiv-precomp h
    ( λ l Z →
      is-equiv-right-factor
        ( cocone-map f g d)
        ( cocone-map f g c)
        ( precomp h Z)
        ( triangle-cocone-cocone c d h KLM Z)
        ( up-c Z)
        ( up-d Z))

up-pushout-up-pushout-is-equiv :
  { l1 l2 l3 l4 l5 : Level}
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} {Y : UU l5}
  ( f : S → A) (g : S → B) (c : cocone f g X) (d : cocone f g Y) →
  ( h : X → Y) (KLM : htpy-cocone f g (cocone-map f g c h) d) →
  is-equiv h →
  ( up-c : {l : Level} → universal-property-pushout l f g c) →
  {l : Level} → universal-property-pushout l f g d
up-pushout-up-pushout-is-equiv f g c d h KLM is-equiv-h up-c Z =
  is-equiv-comp
    ( cocone-map f g d)
    ( cocone-map f g c)
    ( precomp h Z)
    ( triangle-cocone-cocone c d h KLM Z)
    ( is-equiv-precomp-is-equiv h is-equiv-h Z)
    ( up-c Z)

up-pushout-is-equiv-up-pushout :
  { l1 l2 l3 l4 l5 : Level}
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} {Y : UU l5}
  ( f : S → A) (g : S → B) (c : cocone f g X) (d : cocone f g Y) →
  ( h : X → Y) (KLM : htpy-cocone f g (cocone-map f g c h) d) →
  ( up-d : {l : Level} → universal-property-pushout l f g d) →
  is-equiv h →
  {l : Level} → universal-property-pushout l f g c
up-pushout-is-equiv-up-pushout f g c d h KLM up-d is-equiv-h Z =
  is-equiv-left-factor
    ( cocone-map f g d)
    ( cocone-map f g c)
    ( precomp h Z)
    ( triangle-cocone-cocone c d h KLM Z)
    ( up-d Z)
    ( is-equiv-precomp-is-equiv h is-equiv-h Z)

uniquely-unique-pushout :
  { l1 l2 l3 l4 l5 : Level}
  { S : UU l1} {A : UU l2} {B : UU l3} {X : UU l4} {Y : UU l5}
  ( f : S → A) (g : S → B) (c : cocone f g X) (d : cocone f g Y) →
  ( up-c : {l : Level} → universal-property-pushout l f g c) →
  ( up-d : {l : Level} → universal-property-pushout l f g d) →
  is-contr
    ( Σ (X ≃ Y) (λ e → htpy-cocone f g (cocone-map f g c (map-equiv e)) d))
uniquely-unique-pushout f g c d up-c up-d =
  is-contr-total-Eq-substructure
    ( uniqueness-map-universal-property-pushout f g c up-c d)
    ( is-subtype-is-equiv)
    ( map-universal-property-pushout f g c up-c d)
    ( htpy-cocone-map-universal-property-pushout f g c up-c d)
    ( is-equiv-up-pushout-up-pushout f g c d
      ( map-universal-property-pushout f g c up-c d)
      ( htpy-cocone-map-universal-property-pushout f g c up-c d)
      ( up-c)
      ( up-d))

{- We will assume that every span has a pushout. Moreover, we will introduce
   some further terminology to facilitate working with these pushouts. -}

postulate pushout : {l1 l2 l3 : Level} {S : UU l1} {A : UU l2} {B : UU l3} (f : S → A) (g : S → B) → UU (l1 ⊔ l2 ⊔ l3)

postulate inl-pushout : {l1 l2 l3 : Level} {S : UU l1} {A : UU l2} {B : UU l3} (f : S → A) (g : S → B) → A → pushout f g

postulate inr-pushout : {l1 l2 l3 : Level} {S : UU l1} {A : UU l2} {B : UU l3} (f : S → A) (g : S → B) → B → pushout f g

postulate glue-pushout : {l1 l2 l3 : Level} {S : UU l1} {A : UU l2} {B : UU l3} (f : S → A) (g : S → B) → ((inl-pushout f g) ∘ f) ~ ((inr-pushout f g) ∘ g)

cocone-pushout :
  {l1 l2 l3 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) → cocone f g (pushout f g)
cocone-pushout f g =
  pair
    ( inl-pushout f g)
    ( pair
      ( inr-pushout f g)
      ( glue-pushout f g))

postulate up-pushout : {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} (f : S → A) (g : S → B) → universal-property-pushout l4 f g (cocone-pushout f g)

cogap :
  { l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  ( f : S → A) (g : S → B) →
  { X : UU l4} (c : cocone f g X) → pushout f g → X
cogap f g =
  map-universal-property-pushout f g
    ( cocone-pushout f g)
    ( up-pushout f g)

is-pushout :
  { l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  ( f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  UU (l1 ⊔ l2 ⊔ l3 ⊔ l4)
is-pushout f g c = is-equiv (cogap f g c)

-- Section 14.2 Suspensions

suspension-structure :
  {l1 l2 : Level} (X : UU l1) (Y : UU l2) → UU (l1 ⊔ l2)
suspension-structure X Y = Σ Y (λ N → Σ Y (λ S → (x : X) → Id N S))

suspension-cocone' :
  {l1 l2 : Level} (X : UU l1) (Y : UU l2) → UU (l1 ⊔ l2)
suspension-cocone' X Y = cocone (const X unit star) (const X unit star) Y

cocone-suspension-structure :
  {l1 l2 : Level} (X : UU l1) (Y : UU l2) →
  suspension-structure X Y → suspension-cocone' X Y
cocone-suspension-structure X Y (pair N (pair S merid)) =
  pair
    ( const unit Y N)
    ( pair
      ( const unit Y S)
      ( merid))

universal-property-suspension' :
  (l : Level) {l1 l2 : Level} (X : UU l1) (Y : UU l2)
  (susp-str : suspension-structure X Y) → UU (lsuc l ⊔ l1 ⊔ l2)
universal-property-suspension' l X Y susp-str-Y =
  universal-property-pushout l
    ( const X unit star)
    ( const X unit star)
    ( cocone-suspension-structure X Y susp-str-Y)

is-suspension :
  (l : Level) {l1 l2 : Level} (X : UU l1) (Y : UU l2) → UU (lsuc l ⊔ l1 ⊔ l2)
is-suspension l X Y =
  Σ (suspension-structure X Y) (universal-property-suspension' l X Y)

suspension :
  {l : Level} → UU l → UU l
suspension X = pushout (const X unit star) (const X unit star)

N-susp :
  {l : Level} {X : UU l} → suspension X
N-susp {X = X} = inl-pushout (const X unit star) (const X unit star) star

S-susp :
  {l : Level} {X : UU l} → suspension X
S-susp {X = X} = inr-pushout (const X unit star) (const X unit star) star

merid-susp :
  {l : Level} {X : UU l} → X → Id (N-susp {X = X}) (S-susp {X = X})
merid-susp {X = X} = glue-pushout (const X unit star) (const X unit star)

sphere : ℕ → UU lzero
sphere zero-ℕ = bool
sphere (succ-ℕ n) = suspension (sphere n)

N-sphere : (n : ℕ) → sphere n
N-sphere zero-ℕ = true
N-sphere (succ-ℕ n) = N-susp

S-sphere : (n : ℕ) → sphere n
S-sphere zero-ℕ = false
S-sphere (succ-ℕ n) = S-susp

{- We now work towards Lemma 17.2.2. -}

suspension-cocone :
  {l1 l2 : Level} (X : UU l1) (Z : UU l2) → UU _
suspension-cocone X Z = Σ Z (λ z1 → Σ Z (λ z2 → (x : X) → Id z1 z2))

ev-suspension :
  {l1 l2 l3 : Level} {X : UU l1} {Y : UU l2} →
  (susp-str-Y : suspension-structure X Y) →
  (Z : UU l3) → (Y → Z) → suspension-cocone X Z
ev-suspension (pair N (pair S merid)) Z h =
  pair (h N) (pair (h S) (h ·l merid))

universal-property-suspension :
  (l : Level) {l1 l2 : Level} (X : UU l1) (Y : UU l2) →
  suspension-structure X Y → UU (lsuc l ⊔ l1 ⊔ l2)
universal-property-suspension l X Y susp-str-Y =
  (Z : UU l) → is-equiv (ev-suspension susp-str-Y Z)

comparison-suspension-cocone :
  {l1 l2 : Level} (X : UU l1) (Z : UU l2) →
  suspension-cocone' X Z ≃ suspension-cocone X Z
comparison-suspension-cocone X Z =
  equiv-toto
    ( λ z1 → Σ Z (λ z2 → (x : X) → Id z1 z2))
    ( equiv-ev-star' Z)
    ( λ z1 →
      equiv-toto
        ( λ z2 → (x : X) → Id (z1 star) z2)
        ( equiv-ev-star' Z)
        ( λ z2 → equiv-id ((x : X) → Id (z1 star) (z2 star))))

map-comparison-suspension-cocone :
  {l1 l2 : Level} (X : UU l1) (Z : UU l2) →
  suspension-cocone' X Z → suspension-cocone X Z
map-comparison-suspension-cocone X Z =
  map-equiv (comparison-suspension-cocone X Z)

is-equiv-map-comparison-suspension-cocone :
  {l1 l2 : Level} (X : UU l1) (Z : UU l2) →
  is-equiv (map-comparison-suspension-cocone X Z)
is-equiv-map-comparison-suspension-cocone X Z =
  is-equiv-map-equiv (comparison-suspension-cocone X Z)

triangle-ev-suspension :
  {l1 l2 l3 : Level} {X : UU l1} {Y : UU l2} →
  (susp-str-Y : suspension-structure X Y) →
  (Z : UU l3) →
  ( ( map-comparison-suspension-cocone X Z) ∘
    ( cocone-map
      ( const X unit star)
      ( const X unit star)
      ( cocone-suspension-structure X Y susp-str-Y))) ~
  ( ev-suspension susp-str-Y Z)
triangle-ev-suspension (pair N (pair S merid)) Z h = refl

is-equiv-ev-suspension :
  { l1 l2 l3 : Level} {X : UU l1} {Y : UU l2} →
  ( susp-str-Y : suspension-structure X Y) →
  ( up-Y : universal-property-suspension' l3 X Y susp-str-Y) →
  ( Z : UU l3) → is-equiv (ev-suspension susp-str-Y Z)
is-equiv-ev-suspension {X = X} susp-str-Y up-Y Z =
  is-equiv-comp
    ( ev-suspension susp-str-Y Z)
    ( map-comparison-suspension-cocone X Z)
    ( cocone-map
      ( const X unit star)
      ( const X unit star)
      ( cocone-suspension-structure X _ susp-str-Y))
    ( htpy-inv (triangle-ev-suspension susp-str-Y Z))
    ( up-Y Z)
    ( is-equiv-map-comparison-suspension-cocone X Z)

{- Pointed maps and pointed homotopies. -}

pointed-fam :
  {l1 : Level} (l : Level) (X : UU-pt l1) → UU (lsuc l ⊔ l1)
pointed-fam l (pair X x) = Σ (X → UU l) (λ P → P x)

pointed-Π :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) → UU (l1 ⊔ l2)
pointed-Π (pair X x) (pair P p) = Σ ((x' : X) → P x') (λ f → Id (f x) p)

pointed-htpy :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) →
  (f g : pointed-Π X P) → UU (l1 ⊔ l2)
pointed-htpy (pair X x) (pair P p) (pair f α) g =
  pointed-Π (pair X x) (pair (λ x' → Id (f x') (pr1 g x')) (α ∙ (inv (pr2 g))))

pointed-refl-htpy :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) →
  (f : pointed-Π X P) → pointed-htpy X P f f
pointed-refl-htpy (pair X x) (pair P p) (pair f α) =
  pair refl-htpy (inv (right-inv α))

pointed-htpy-eq :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) →
  (f g : pointed-Π X P) → Id f g → pointed-htpy X P f g
pointed-htpy-eq X P f .f refl = pointed-refl-htpy X P f

is-contr-total-pointed-htpy :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) (f : pointed-Π X P) →
  is-contr (Σ (pointed-Π X P) (pointed-htpy X P f))
is-contr-total-pointed-htpy (pair X x) (pair P p) (pair f α) =
  is-contr-total-Eq-structure
    ( λ g β (H : f ~ g) → Id (H x) (α ∙ (inv β)))
    ( is-contr-total-htpy f)
    ( pair f refl-htpy)
    ( is-contr-equiv'
      ( Σ (Id (f x) p) (λ β → Id β α))
      ( equiv-tot (λ β → equiv-con-inv refl β α))
      ( is-contr-total-path' α))

is-equiv-pointed-htpy-eq :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) →
  (f g : pointed-Π X P) → is-equiv (pointed-htpy-eq X P f g)
is-equiv-pointed-htpy-eq X P f =
  fundamental-theorem-id f
    ( pointed-refl-htpy X P f)
    ( is-contr-total-pointed-htpy X P f)
    ( pointed-htpy-eq X P f)

eq-pointed-htpy :
  {l1 l2 : Level} (X : UU-pt l1) (P : pointed-fam l2 X) →
  (f g : pointed-Π X P) → (pointed-htpy X P f g) → Id f g
eq-pointed-htpy X P f g = inv-is-equiv (is-equiv-pointed-htpy-eq X P f g)

-- Section 14.3 Duality of pushouts and pullbacks

{- The universal property of the pushout of a span S can also be stated as a
   pullback-property: a cocone c = (pair i (pair j H)) with vertex X
   satisfies the universal property of the pushout of S if and only if the
   square

     Y^X -----> Y^B
      |          |
      |          |
      V          V
     Y^A -----> Y^S

   is a pullback square for every type Y. Below, we first define the cone of
   this commuting square, and then we introduce the type
   pullback-property-pushout, which states that the above square is a pullback.
   -}

htpy-precomp :
  {l1 l2 l3 : Level} {A : UU l1} {B : UU l2}
  {f g : A → B} (H : f ~ g) (C : UU l3) →
  (precomp f C) ~ (precomp g C)
htpy-precomp H C h = eq-htpy (h ·l H)

compute-htpy-precomp :
  {l1 l2 l3 : Level} {A : UU l1} {B : UU l2} (f : A → B) (C : UU l3) →
  (htpy-precomp (refl-htpy' f) C) ~ refl-htpy
compute-htpy-precomp f C h = eq-htpy-refl-htpy (h ∘ f)

cone-pullback-property-pushout :
  {l1 l2 l3 l4 l : Level} {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) (Y : UU l) →
  cone (λ (h : A → Y) → h ∘ f) (λ (h : B → Y) → h ∘ g) (X → Y)
cone-pullback-property-pushout f g {X} c Y =
  pair
    ( precomp (pr1 c) Y)
    ( pair
      ( precomp (pr1 (pr2 c)) Y)
      ( htpy-precomp (pr2 (pr2 c)) Y))

pullback-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2} {B : UU l3}
  (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  UU (l1 ⊔ (l2 ⊔ (l3 ⊔ (l4 ⊔ lsuc l))))
pullback-property-pushout l {S} {A} {B} f g {X} c =
  (Y : UU l) → is-pullback
    ( precomp f Y)
    ( precomp g Y)
    ( cone-pullback-property-pushout f g c Y)

{- In order to show that the universal property of pushouts is equivalent to
   the pullback property, we show that the maps cocone-map and the gap map fit
   in a commuting triangle, where the third map is an equivalence. The claim
   then follows from the 3-for-2 property of equivalences. -}

triangle-pullback-property-pushout-universal-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2}
  {B : UU l3} (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  {l : Level} (Y : UU l) →
  ( cocone-map f g c) ~
  ( ( tot (λ i' → tot (λ j' p → htpy-eq p))) ∘
    ( gap (λ h → h ∘ f) (λ h → h ∘ g) (cone-pullback-property-pushout f g c Y)))
triangle-pullback-property-pushout-universal-property-pushout
  {S = S} {A = A} {B = B} f g (pair i (pair j H)) Y h =
    eq-pair refl (eq-pair refl (inv (issec-eq-htpy (h ·l H))))

pullback-property-pushout-universal-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2}
  {B : UU l3} (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  universal-property-pushout l f g c → pullback-property-pushout l f g c
pullback-property-pushout-universal-property-pushout
  l f g (pair i (pair j H)) up-c Y =
  let c = (pair i (pair j H)) in
  is-equiv-right-factor
    ( cocone-map f g c)
    ( tot (λ i' → tot (λ j' p → htpy-eq p)))
    ( gap (λ h → h ∘ f) (λ h → h ∘ g) (cone-pullback-property-pushout f g c Y))
    ( triangle-pullback-property-pushout-universal-property-pushout f g c Y)
    ( is-equiv-tot-is-fiberwise-equiv
      ( λ i' → is-equiv-tot-is-fiberwise-equiv
        ( λ j' → funext (i' ∘ f) (j' ∘ g))))
    ( up-c Y)

universal-property-pushout-pullback-property-pushout :
  {l1 l2 l3 l4 : Level} (l : Level) {S : UU l1} {A : UU l2}
  {B : UU l3} (f : S → A) (g : S → B) {X : UU l4} (c : cocone f g X) →
  pullback-property-pushout l f g c → universal-property-pushout l f g c
universal-property-pushout-pullback-property-pushout
  l f g (pair i (pair j H)) pb-c Y =
  let c = (pair i (pair j H)) in
  is-equiv-comp
    ( cocone-map f g c)
    ( tot (λ i' → tot (λ j' p → htpy-eq p)))
    ( gap (λ h → h ∘ f) (λ h → h ∘ g) (cone-pullback-property-pushout f g c Y))
    ( triangle-pullback-property-pushout-universal-property-pushout f g c Y)
    ( pb-c Y)
    ( is-equiv-tot-is-fiberwise-equiv
      ( λ i' → is-equiv-tot-is-fiberwise-equiv
        ( λ j' → funext (i' ∘ f) (j' ∘ g))))

cocone-compose-horizontal :
  { l1 l2 l3 l4 l5 l6 : Level}
  { A : UU l1} {B : UU l2} {C : UU l3} {X : UU l4} {Y : UU l5} {Z : UU l6}
  ( f : A → X) (i : A → B) (k : B → C) →
  ( c : cocone f i Y) (d : cocone (pr1 (pr2 c)) k Z) →
  cocone f (k ∘ i) Z
cocone-compose-horizontal f i k (pair j (pair g H)) (pair l (pair h K)) =
  pair
    ( l ∘ j)
    ( pair
      ( h)
      ( (l ·l H) ∙h (K ·r i)))

{-
is-pushout-rectangle-is-pushout-right-square :
  ( l : Level) { l1 l2 l3 l4 l5 l6 : Level}
  { A : UU l1} {B : UU l2} {C : UU l3} {X : UU l4} {Y : UU l5} {Z : UU l6}
  ( f : A → X) (i : A → B) (k : B → C) →
  ( c : cocone f i Y) (d : cocone (pr1 (pr2 c)) k Z) →
  universal-property-pushout l f i c →
  universal-property-pushout l (pr1 (pr2 c)) k d →
  universal-property-pushout l f (k ∘ i) (cocone-compose-horizontal f i k c d)
is-pushout-rectangle-is-pushout-right-square l f i k c d up-Y up-Z =
  universal-property-pushout-pullback-property-pushout l f (k ∘ i)
    ( cocone-compose-horizontal f i k c d)
    ( λ T → is-pullback-htpy {!!} {!!} {!!} {!!} {!!} {!!} {!!})
-}

-- Examples of pushouts

{- The cofiber of a map. -}

cofiber :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} → (A → B) → UU (l1 ⊔ l2)
cofiber {A = A} f = pushout f (const A unit star)

cocone-cofiber :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) →
  cocone f (const A unit star) (cofiber f)
cocone-cofiber {A = A} f = cocone-pushout f (const A unit star)

inl-cofiber :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) → B → cofiber f
inl-cofiber {A = A} f = pr1 (cocone-cofiber f)

inr-cofiber :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) → unit → cofiber f
inr-cofiber f = pr1 (pr2 (cocone-cofiber f))

pt-cofiber :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) → cofiber f
pt-cofiber {A = A} f = inr-cofiber f star

cofiber-ptd :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) → UU-pt (l1 ⊔ l2)
cofiber-ptd f = pair (cofiber f) (pt-cofiber f)

up-cofiber :
  { l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) →
  ( {l : Level} →
    universal-property-pushout l f (const A unit star) (cocone-cofiber f))
up-cofiber {A = A} f = up-pushout f (const A unit star)

_*_ :
  {l1 l2 : Level} (A : UU l1) (B : UU l2) → UU (l1 ⊔ l2)
A * B = pushout (pr1 {A = A} {B = λ x → B}) pr2

cocone-join :
  {l1 l2 : Level} (A : UU l1) (B : UU l2) →
  cocone (pr1 {A = A} {B = λ x → B}) pr2 (A * B)
cocone-join A B = cocone-pushout pr1 pr2

up-join :
  {l1 l2 : Level} (A : UU l1) (B : UU l2) →
  ( {l : Level} → universal-property-pushout l
    ( pr1 {A = A} {B = λ x → B}) pr2 (cocone-join A B))
up-join A B = up-pushout pr1 pr2

inl-join :
  {l1 l2 : Level} (A : UU l1) (B : UU l2) → A → A * B
inl-join A B = pr1 (cocone-join A B)

inr-join :
  {l1 l2 : Level} (A : UU l1) (B : UU l2) → B → A * B
inr-join A B = pr1 (pr2 (cocone-join A B))

glue-join :
  {l1 l2 : Level} (A : UU l1) (B : UU l2) (t : A × B) →
  Id (inl-join A B (pr1 t)) (inr-join A B (pr2 t))
glue-join A B = pr2 (pr2 (cocone-join A B))

_∨_ :
  {l1 l2 : Level} (A : UU-pt l1) (B : UU-pt l2) → UU-pt (l1 ⊔ l2)
A ∨ B =
  pair
    ( pushout
      ( const unit (pr1 A) (pr2 A))
      ( const unit (pr1 B) (pr2 B)))
    ( inl-pushout
      ( const unit (pr1 A) (pr2 A))
      ( const unit (pr1 B) (pr2 B))
      ( pr2 A))

indexed-wedge :
  {l1 l2 : Level} (I : UU l1) (A : I → UU-pt l2) → UU-pt (l1 ⊔ l2)
indexed-wedge I A =
  pair
    ( cofiber (λ i → pair i (pr2 (A i))))
    ( pt-cofiber (λ i → pair i (pr2 (A i))))

wedge-inclusion :
  {l1 l2 : Level} (A : UU-pt l1) (B : UU-pt l2) →
  pr1 (A ∨ B) → (pr1 A) × (pr1 B)
wedge-inclusion {l1} {l2} (pair A a) (pair B b) =
  inv-is-equiv
    ( up-pushout
      ( const unit A a)
      ( const unit B b)
      ( A × B))
    ( pair
      ( λ x → pair x b)
      ( pair
        ( λ y → pair a y)
        ( refl-htpy)))

-- Exercises

-- Exercise 13.1

-- Exercise 13.2

is-equiv-universal-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g C) →
  is-equiv f →
  ({l : Level} → universal-property-pushout l f g c) → is-equiv (pr1 (pr2 c))
is-equiv-universal-property-pushout
  {A = A} {B} f g (pair i (pair j H)) is-equiv-f up-c =
  is-equiv-is-equiv-precomp j
    ( λ l T →
      is-equiv-is-pullback'
        ( λ (h : A → T) → h ∘ f)
        ( λ (h : B → T) → h ∘ g)
        ( cone-pullback-property-pushout f g (pair i (pair j H)) T)
        ( is-equiv-precomp-is-equiv f is-equiv-f T)
        ( pullback-property-pushout-universal-property-pushout
          l f g (pair i (pair j H)) up-c T))

equiv-universal-property-pushout :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (e : S ≃ A) (g : S → B) (c : cocone (map-equiv e) g C) →
  ({l : Level} → universal-property-pushout l (map-equiv e) g c) →
  B ≃ C
equiv-universal-property-pushout e g c up-c =
  pair
    ( pr1 (pr2 c))
    ( is-equiv-universal-property-pushout
      ( map-equiv e)
      ( g)
      ( c)
      ( is-equiv-map-equiv e)
      ( up-c))

is-equiv-universal-property-pushout' :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g C) →
  is-equiv g →
  ({l : Level} → universal-property-pushout l f g c) →
  is-equiv (pr1 c)
is-equiv-universal-property-pushout' f g (pair i (pair j H)) is-equiv-g up-c =
  is-equiv-is-equiv-precomp i
    ( λ l T →
      is-equiv-is-pullback
        ( precomp f T)
        ( precomp g T)
        ( cone-pullback-property-pushout f g (pair i (pair j H)) T)
        ( is-equiv-precomp-is-equiv g is-equiv-g T)
        ( pullback-property-pushout-universal-property-pushout
          l f g (pair i (pair j H)) up-c T))

equiv-universal-property-pushout' :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (f : S → A) (e : S ≃ B) (c : cocone f (map-equiv e) C) →
  ({l : Level} → universal-property-pushout l f (map-equiv e) c) →
  A ≃ C
equiv-universal-property-pushout' f e c up-c =
  pair
    ( pr1 c)
    ( is-equiv-universal-property-pushout'
      ( f)
      ( map-equiv e)
      ( c)
      ( is-equiv-map-equiv e)
      ( up-c))

universal-property-pushout-is-equiv :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g C) →
  is-equiv f → is-equiv (pr1 (pr2 c)) →
  ({l : Level} → universal-property-pushout l f g c)
universal-property-pushout-is-equiv f g (pair i (pair j H)) is-equiv-f is-equiv-j {l} =
  let c = (pair i (pair j H)) in
  universal-property-pushout-pullback-property-pushout l f g c
    ( λ T → is-pullback-is-equiv'
      ( λ h → h ∘ f)
      ( λ h → h ∘ g)
      ( cone-pullback-property-pushout f g c T)
      ( is-equiv-precomp-is-equiv f is-equiv-f T)
      ( is-equiv-precomp-is-equiv j is-equiv-j T))

universal-property-pushout-is-equiv' :
  {l1 l2 l3 l4 : Level} {S : UU l1} {A : UU l2} {B : UU l3} {C : UU l4}
  (f : S → A) (g : S → B) (c : cocone f g C) →
  is-equiv g → is-equiv (pr1 c) →
  ({l : Level} → universal-property-pushout l f g c)
universal-property-pushout-is-equiv'
  f g (pair i (pair j H)) is-equiv-g is-equiv-i {l} =
  let c = (pair i (pair j H)) in
  universal-property-pushout-pullback-property-pushout l f g c
    ( λ T → is-pullback-is-equiv
      ( precomp f T)
      ( precomp g T)
      ( cone-pullback-property-pushout f g c T)
      ( is-equiv-precomp-is-equiv g is-equiv-g T)
      ( is-equiv-precomp-is-equiv i is-equiv-i T))

is-contr-suspension-is-contr :
  {l : Level} {X : UU l} → is-contr X → is-contr (suspension X)
is-contr-suspension-is-contr {l} {X} is-contr-X =
  is-contr-is-equiv'
    ( unit)
    ( pr1 (pr2 (cocone-pushout (const X unit star) (const X unit star))))
    ( is-equiv-universal-property-pushout
      ( const X unit star)
      ( const X unit star)
      ( cocone-pushout
        ( const X unit star)
        ( const X unit star))
      ( is-equiv-is-contr (const X unit star) is-contr-X is-contr-unit)
      ( up-pushout (const X unit star) (const X unit star)))
    ( is-contr-unit)

is-contr-cofiber-is-equiv :
  {l1 l2 : Level} {A : UU l1} {B : UU l2} (f : A → B) →
  is-equiv f → is-contr (cofiber f)
is-contr-cofiber-is-equiv {A = A} {B} f is-equiv-f =
  is-contr-is-equiv'
    ( unit)
    ( pr1 (pr2 (cocone-cofiber f)))
    ( is-equiv-universal-property-pushout
      ( f)
      ( const A unit star)
      ( cocone-cofiber f)
      ( is-equiv-f)
      ( up-cofiber f))
    ( is-contr-unit)

is-equiv-cofiber-point :
  {l : Level} {B : UU l} (b : B) →
  is-equiv (pr1 (cocone-pushout (const unit B b) (const unit unit star)))
is-equiv-cofiber-point {l} {B} b =
  is-equiv-universal-property-pushout'
    ( const unit B b)
    ( const unit unit star)
    ( cocone-pushout (const unit B b) (const unit unit star))
    ( is-equiv-is-contr (const unit unit star) is-contr-unit is-contr-unit)
    ( up-pushout (const unit B b) (const unit unit star))

is-equiv-inr-join-empty :
  {l : Level} (X : UU l) → is-equiv (inr-join empty X)
is-equiv-inr-join-empty X =
  is-equiv-universal-property-pushout
    ( pr1 {A = empty} {B = λ t → X})
    ( pr2)
    ( cocone-join empty X)
    ( is-equiv-pr1-prod-empty X)
    ( up-join empty X)

left-unit-law-join :
  {l : Level} (X : UU l) → X ≃ (empty * X)
left-unit-law-join X =
  pair (inr-join empty X) (is-equiv-inr-join-empty X)

is-equiv-inl-join-empty :
  {l : Level} (X : UU l) → is-equiv (inl-join X empty)
is-equiv-inl-join-empty X =
  is-equiv-universal-property-pushout'
    ( pr1)
    ( pr2)
    ( cocone-join X empty)
    ( is-equiv-pr2-prod-empty X)
    ( up-join X empty)

right-unit-law-join :
  {l : Level} (X : UU l) → X ≃ (X * empty)
right-unit-law-join X =
  pair (inl-join X empty) (is-equiv-inl-join-empty X)

inv-map-left-unit-law-prod :
  {l : Level} (X : UU l) → X → (unit × X)
inv-map-left-unit-law-prod X = pair star

issec-inv-map-left-unit-law-prod :
  {l : Level} (X : UU l) → (pr2 ∘ (inv-map-left-unit-law-prod X)) ~ id
issec-inv-map-left-unit-law-prod X x = refl

isretr-inv-map-left-unit-law-prod :
  {l : Level} (X : UU l) → ((inv-map-left-unit-law-prod X) ∘ pr2) ~ id
isretr-inv-map-left-unit-law-prod X (pair star x) = refl

is-equiv-left-unit-law-prod :
  {l : Level} (X : UU l) → is-equiv (pr2 {A = unit} {B = λ t → X})
is-equiv-left-unit-law-prod X =
  is-equiv-has-inverse
    ( inv-map-left-unit-law-prod X)
    ( issec-inv-map-left-unit-law-prod X)
    ( isretr-inv-map-left-unit-law-prod X)

left-unit-law-prod :
  {l : Level} (X : UU l) → (unit × X) ≃ X
left-unit-law-prod X =
  pair pr2 (is-equiv-left-unit-law-prod X)

is-equiv-inl-join-unit :
  {l : Level} (X : UU l) → is-equiv (inl-join unit X)
is-equiv-inl-join-unit X =
  is-equiv-universal-property-pushout'
    ( pr1)
    ( pr2)
    ( cocone-join unit X)
    ( is-equiv-left-unit-law-prod X)
    ( up-join unit X)

left-zero-law-join :
  {l : Level} (X : UU l) → is-contr (unit * X)
left-zero-law-join X =
  is-contr-equiv'
    ( unit)
    ( pair (inl-join unit X) (is-equiv-inl-join-unit X))
    ( is-contr-unit)

inv-map-right-unit-law-prod :
  {l : Level} (X : UU l) → X → X × unit
inv-map-right-unit-law-prod X x = pair x star

issec-inv-map-right-unit-law-prod :
  {l : Level} (X : UU l) → (pr1 ∘ (inv-map-right-unit-law-prod X)) ~ id
issec-inv-map-right-unit-law-prod X x = refl

isretr-inv-map-right-unit-law-prod :
  {l : Level} (X : UU l) → ((inv-map-right-unit-law-prod X) ∘ pr1) ~ id
isretr-inv-map-right-unit-law-prod X (pair x star) = refl

is-equiv-right-unit-law-prod :
  {l : Level} (X : UU l) → is-equiv (pr1 {A = X} {B = λ t → unit})
is-equiv-right-unit-law-prod X =
  is-equiv-has-inverse
    ( inv-map-right-unit-law-prod X)
    ( issec-inv-map-right-unit-law-prod X)
    ( isretr-inv-map-right-unit-law-prod X)

right-unit-law-prod :
  {l : Level} (X : UU l) → (X × unit) ≃ X
right-unit-law-prod X =
  pair pr1 (is-equiv-right-unit-law-prod X)

is-equiv-inr-join-unit :
  {l : Level} (X : UU l) → is-equiv (inr-join X unit)
is-equiv-inr-join-unit X =
  is-equiv-universal-property-pushout
    ( pr1)
    ( pr2)
    ( cocone-join X unit)
    ( is-equiv-right-unit-law-prod X)
    ( up-join X unit)

right-zero-law-join :
  {l : Level} (X : UU l) → is-contr (X * unit)
right-zero-law-join X =
  is-contr-equiv'
    ( unit)
    ( pair (inr-join X unit) (is-equiv-inr-join-unit X))
    ( is-contr-unit)

unit-pt : UU-pt lzero
unit-pt = pair unit star

is-contr-pt :
  {l : Level} → UU-pt l → UU l
is-contr-pt A = is-contr (pr1 A)

-- Exercise 16.2

-- ev-disjunction :
--   {l1 l2 l3 : Level} (P : UU-Prop l1) (Q : UU-Prop l2) (R : UU-Prop l3) →
--   ((type-Prop P) * (type-Prop Q) → (type-Prop R)) →
--   (type-Prop P → type-Prop R) × (type-Prop Q → type-Prop R)
-- ev-disjunction P Q R f =
--   pair
--     ( f ∘ (inl-join (type-Prop P) (type-Prop Q)))
--     ( f ∘ (inr-join (type-Prop P) (type-Prop Q)))

-- comparison-ev-disjunction :
--   {l1 l2 l3 : Level} (P : UU-Prop l1) (Q : UU-Prop l2) (R : UU-Prop l3) →
--   cocone-join (type-Prop P) (type-Prop Q) (type-Prop R)

-- universal-property-disjunction-join-prop :
--   {l1 l2 l3 : Level} (P : UU-Prop l1) (Q : UU-Prop l2) (R : UU-Prop l3) →
--   is-equiv (ev-disjunction P Q R)


module _ where

record LinearOrderStr (D : Set) : Set₁ where
  no-eta-equality
  field
    _<_ : D -> D -> Set

open LinearOrderStr {{...}}

postulate
  D : Set

module _ {{O : LinearOrderStr D}} where
  abstract
    broken : {b c : D} -> (b < c) -> b < c
    broken {b} {c} b<c = b<c
      where
      b<c2 : b < c
      b<c2 = b<c


------------------------------------------------------------------------
-- The Agda standard library
--
-- A pointwise lifting of a relation to incorporate a new infimum.
------------------------------------------------------------------------

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

-- This module is designed to be used with
-- Relation.Nullary.Construct.Add.Infimum

open import Relation.Binary

module Relation.Binary.Construct.Add.Infimum.Equality
  {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) where

open import Relation.Binary.Construct.Add.Point.Equality _≈_ public
  renaming
  (_≈∙_                 to _≈₋_
  ; ∙≈∙                 to ⊥₋≈⊥₋
  ; ≈∙-refl             to ≈₋-refl
  ; ≈∙-sym              to ≈₋-sym
  ; ≈∙-trans            to ≈₋-trans
  ; ≈∙-dec              to ≈₋-dec
  ; ≈∙-irrelevant       to ≈₋-irrelevant
  ; ≈∙-substitutive     to ≈₋-substitutive
  ; ≈∙-isEquivalence    to ≈₋-isEquivalence
  ; ≈∙-isDecEquivalence to ≈₋-isDecEquivalence
  )


{-# OPTIONS --allow-unsolved-metas #-}

open import Agda.Builtin.Unit
open import Agda.Builtin.Equality

data Unit : Set where unit : Unit

A : Unit → Set
A unit = ⊤

postulate
  a b : (u : Unit) → A u

mutual
  _X : Unit
  _X = {!unit!}

  test : a _X ≡ b _X
  test = refl


{-# OPTIONS --cubical --no-import-sorts --safe --experimental-lossy-unification #-}

module Cubical.ZCohomology.EilenbergSteenrodZ where

open import Cubical.Homotopy.EilenbergSteenrod

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Groups.Wedge
open import Cubical.ZCohomology.Groups.Sn

open import Cubical.Relation.Nullary

open import Cubical.Data.Nat
open import Cubical.Data.Bool
open import Cubical.Data.Int
open import Cubical.Data.Empty renaming (rec to ⊥-rec)
open import Cubical.Data.Unit
open import Cubical.Data.Sigma

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws renaming (assoc to assoc∙)
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

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

open import Cubical.Algebra.Group
open import Cubical.Algebra.AbGroup

open coHomTheory
open Iso
open IsGroup
open GroupStr
open GroupIso
open GroupHom

private
  suspΩFun' : ∀ {ℓ} {A : Type ℓ} (n : ℕ) (f : A → Path _ (0ₖ _) (0ₖ _))
           → Susp A → coHomK (suc n)
  suspΩFun' n f north = 0ₖ _
  suspΩFun' n f south = 0ₖ _
  suspΩFun' n f (merid a i) = f a i

  suspΩFun : ∀ {ℓ} {A : Type ℓ} (n : ℕ) (f : A → coHomK n) → Susp A → coHomK (suc n)
  suspΩFun n f = suspΩFun' n λ a → Kn→ΩKn+1 n (f a)

  ≡suspΩFun : ∀ {ℓ} (n : ℕ) (A : Pointed ℓ) (f : Susp (typ A) → coHomK (suc n)) (p : f north ≡ 0ₖ _)
            → f ≡ suspΩFun' n λ a → sym p ∙∙ (cong f (merid a)) ∙∙ (cong f (sym (merid (pt A))) ∙ p)
  ≡suspΩFun n s f p i north = p i
  ≡suspΩFun n s f p i south = (cong f (sym (merid (pt s))) ∙ p) i
  ≡suspΩFun n s f p i (merid a j) =
    doubleCompPath-filler (sym p) (cong f (merid a)) (cong f (sym (merid (pt s))) ∙ p) i j

-- induction principle for Hⁿ(Susp A)
SuspCohomElim : ∀ {ℓ ℓ'} {A : Pointed ℓ} (n : ℕ) {B : coHom (suc n) (Susp (typ A)) → Type ℓ'}
             → ((x : coHom (suc n) (Susp (typ A))) → isProp (B x))
             → ((f : typ A → Path _ (0ₖ _) (0ₖ _)) → f (pt A) ≡ refl → B ∣ suspΩFun' n f ∣₂)
             → (x : _) → B x
SuspCohomElim {A = A} n {B = B} isprop f =
  coHomPointedElim _ north isprop λ g gid
    → subst (B ∘ ∣_∣₂) (sym (≡suspΩFun n A g gid))
                       (f _ ((λ i → (sym gid ∙∙ (λ j → g (merid (pt A) (~ i ∧ j))) ∙∙ ((λ j → g (merid (pt A) (~ i ∧ ~ j))) ∙ gid)))
                                  ∙∙ (λ i → (λ j → gid (i ∨ ~ j)) ∙∙ refl ∙∙ lUnit (λ j → gid (i ∨ j)) (~ i))
                                  ∙∙ sym (rUnit refl)))

-- (Reduced) cohomology functor
coHomFunctor : {ℓ : Level}  (n : Int) → Pointed ℓ → AbGroup {ℓ}
coHomFunctor (pos n) = coHomRedGroup n
coHomFunctor (negsuc n) _ = trivialAbGroup

-- Alternative definition with reduced groups replaced by unrecued one for n ≥ 1
coHomFunctor' : {ℓ : Level} (n : Int) → Pointed ℓ → AbGroup {ℓ}
coHomFunctor' (pos zero) = coHomFunctor 0
coHomFunctor' (pos (suc n)) A = coHomGroup (suc n) (typ A)
coHomFunctor' (negsuc n) = coHomFunctor (negsuc n)

coHomFunctor≡coHomFunctor' : ∀ {ℓ} → coHomFunctor {ℓ} ≡ coHomFunctor'
coHomFunctor≡coHomFunctor' = funExt λ {(pos zero) → refl
                                     ; (pos (suc n)) → funExt λ A → sym (coHomGroup≡coHomRedGroup n A)
                                     ; (negsuc n) → refl}

-- Ĥ⁰(Susp A) is contractible
H0-susp : ∀ {ℓ} {A : Pointed ℓ} → isContr (coHomRed 0 (Susp (typ A) , north))
fst H0-susp = 0ₕ∙ _
snd (H0-susp {A = A}) =
  sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ {(f , p)
          → cong ∣_∣₂ (Σ≡Prop (λ _ → isSetInt _ _)
                        (funExt λ {north → sym p
                                 ; south → sym p ∙ cong f (merid (pt A))
                                 ; (merid a i) j → isSet→isSet' (isSetInt)
                                                                  (sym p)
                                                                  (sym p ∙ cong f (merid (pt A)))
                                                                  refl (cong f (merid a)) i j}))}
-- We need that Hⁿ⁺¹(Susp A) ≃ Hⁿ(A)

private
  suspFunCharacFun : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ)
                     → ((Susp (typ A)) → coHomK (suc n))
                     → (typ A → (coHomK n))
  suspFunCharacFun {A = A} n f x = ΩKn+1→Kn n (sym (rCancelₖ (suc n) (f north))
                                                     ∙∙ cong (λ x → f x -[ (suc n) ]ₖ f north) ((merid x) ∙ sym (merid (pt A)))
                                                     ∙∙ rCancelₖ (suc n) (f north))

  linvLem : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) (f : typ A → Path (coHomK (suc n)) (0ₖ _) (0ₖ _))
                        (fId : f (pt A) ≡ refl)
                     → (x : _) → suspΩFun n (suspFunCharacFun {A = A} n (suspΩFun' n f)) x
                                 ≡ suspΩFun' n f x
  linvLem n f fId north = refl
  linvLem n f fId south = refl
  linvLem {A = A} n f fId (merid x i) j = helper n x f fId j i
    where
    helper : (n : ℕ) (a : typ A) (f : typ A → Path (coHomK (suc n)) (0ₖ _) (0ₖ _))
                       (fId : f (pt A) ≡ refl)
                     → Kn→ΩKn+1 n (suspFunCharacFun {A = A} n (suspΩFun' n f) a) ≡ f a
    helper zero a f fId =
        Iso.rightInv (Iso-Kn-ΩKn+1 0) (sym (rCancelₖ _ (0ₖ 1))
                                    ∙∙ cong (λ x → suspΩFun' 0 f x +ₖ 0ₖ 1) (merid a ∙ (sym (merid (pt A))))
                                    ∙∙ rCancelₖ _ (0ₖ 1))
     ∙∙ (λ i → sym (transportRefl (λ _ → 0ₖ 1) i)
             ∙∙ cong (λ x → rUnitₖ 1 (suspΩFun' 0 f x) i) (merid a ∙ (sym (merid (pt A))))
             ∙∙ transportRefl (λ _ → 0ₖ 1) i)
     ∙∙ (λ i → rUnit (congFunct (suspΩFun' 0 f) (merid a) (sym (merid (pt A))) i) (~ i))
     ∙∙ cong (λ p → f a ∙ sym p) fId
     ∙∙ sym (rUnit (f a))
    helper (suc n) a f fId =
         Iso.rightInv (Iso-Kn-ΩKn+1 (suc n))
                           (sym (rCancelₖ _ (0ₖ (suc (suc n))))
                        ∙∙ cong (λ x → suspΩFun' (suc n) f x +ₖ 0ₖ (suc (suc n))) (merid a ∙ (sym (merid (pt A))))
                        ∙∙ rCancelₖ _ (0ₖ (suc (suc n))))
      ∙∙ ((λ i → sym (transportRefl (λ _ → 0ₖ (suc (suc n))) i)
                   ∙∙ cong (λ x → rUnitₖ (suc (suc n)) (suspΩFun' (suc n) f x) i) (merid a ∙ (sym (merid (pt A))))
                   ∙∙ transportRefl (λ _ → 0ₖ (suc (suc n))) i))
      ∙∙ (λ i → rUnit (congFunct (suspΩFun' (suc n) f) (merid a) (sym (merid (pt A))) i) (~ i))
      ∙∙ cong (λ p → f a ∙ sym p) fId
      ∙∙ sym (rUnit (f a))

suspFunCharac : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → Iso (coHom (suc (suc n)) (Susp (typ A))) (coHom (suc n) (typ A))
fun (suspFunCharac {A = A} n) =
  sMap λ f → suspFunCharacFun {A = A} (suc n) f
inv (suspFunCharac {A = A} n) = sMap (suspΩFun (suc n))
rightInv (suspFunCharac {A = A} n) =
  sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
    (λ f → trRec (isProp→isOfHLevelSuc n (setTruncIsSet _ _))
                  (λ fId → cong ∣_∣₂ (funExt λ x → (cong (ΩKn+1→Kn (suc n))
                                                            ((λ i → (sym (transportRefl (λ _ → 0ₖ _) i)
                                                                ∙∙ cong (λ x → suspΩFun (suc n) f x +ₖ 0ₖ _)
                                                                        (merid x ∙ sym (merid (pt A)))
                                                                ∙∙ transportRefl (λ _ → 0ₖ _) i))
                                                         ∙∙ (sym (rUnit (cong (λ x → suspΩFun (suc n) f x +ₖ 0ₖ _)
                                                                                ((merid x) ∙ sym (merid (pt A))))))
                                                         ∙∙ (λ i → congFunct (λ x → rUnitₖ _ (suspΩFun (suc n) f x) i)
                                                                              (merid x) (sym (merid (pt A))) i)))
                                                 ∙∙ ΩKn+1→Kn-hom (suc n) (Kn→ΩKn+1 (suc n) (f x))
                                                                  (sym (Kn→ΩKn+1 (suc n) (f (pt A))))
                                                 ∙∙ cong₂ _+ₖ_ (Iso.leftInv (Iso-Kn-ΩKn+1 (suc n)) (f x))
                                                               (cong (λ x → ΩKn+1→Kn (suc n) (sym (Kn→ΩKn+1 (suc n) x))) fId)
                                                 ∙∙ cong (λ y → f x +ₖ ΩKn+1→Kn (suc n) (sym y)) (Kn→ΩKn+10ₖ (suc n))
                                                 ∙∙ cong (f x +ₖ_) (ΩKn+1→Kn-refl (suc n))
                                                  ∙ rUnitₖ _ (f x)))
                  (fst (isConnectedPathKn n (f (pt A)) (0ₖ _))))
leftInv (suspFunCharac {A = A} n) =
  SuspCohomElim {A = A} _ (λ _ → setTruncIsSet _ _)
    λ f fId → cong ∣_∣₂ (funExt (linvLem (suc n) f fId))

-- We also need that H¹(Susp A) ≃ Ĥ⁰(A)
suspFunCharac0 : ∀ {ℓ} {A : Pointed ℓ} → Iso (∥ ((Susp (typ A)) → coHomK 1) ∥₂) ∥ A →∙ (Int , 0) ∥₂
fun (suspFunCharac0 {A = A}) =
    sMap λ f → suspFunCharacFun {A = A} 0 f
  ,  (cong (ΩKn+1→Kn 0) ((λ i → sym (rCancelₖ _ (f north))
                                   ∙∙ cong (λ x → f x -ₖ f north) (rCancel (merid (pt A)) i)
                                   ∙∙ rCancelₖ _ (f north))
                      ∙∙ (doubleCompPath-elim (sym (rCancelₖ _ (f north))) refl (rCancelₖ _ (f north)))
                      ∙∙ (cong (_∙ (rCancelₖ _ (f north))) (sym (rUnit (sym (rCancelₖ _ (f north))))))
                       ∙ (lCancel (rCancelₖ _ (f north)))))
inv suspFunCharac0 = sMap λ f → suspΩFun 0 (fst f)
rightInv (suspFunCharac0 {A = A}) =
  sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
    λ {(f , p)
      → cong ∣_∣₂ (Σ≡Prop (λ _ → isSetInt _ _)
                   (funExt (λ x → (λ j → transp (λ i → helix (wedgeMapS¹ (intLoop (p j) (~ i)) base)) j
                                             ((transport (λ i → helix (trRec isGroupoidS¹ (λ x → x)
                                                                              (rUnitₖ 1 ∣ intLoop (f x) i ∣ j)))
                                                         (pos 0))))
                                 ∙ windingIntLoop (f x))))}
leftInv (suspFunCharac0 {A = A}) =
  SuspCohomElim {A = A} _ (λ _ → setTruncIsSet _ _)
    λ f fId → cong ∣_∣₂ (funExt (linvLem 0 f fId))

-- We now prove that the alternative definition of cohomology is a cohomology theory.
private
  -- First, we need to that coHomFunctor' is contravariant
  theMorph : ∀ {ℓ} (n : Int) {A B : Pointed ℓ} (f : A →∙ B)
          → AbGroupHom (coHomFunctor' n B) (coHomFunctor' n A)
  fun (theMorph (pos zero) f) = sMap λ g → (λ x → fst g (fst f x)) , cong (fst g) (snd f) ∙ snd g
  isHom (theMorph (pos zero) f) =
    sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
           λ f g → cong ∣_∣₂ (Σ≡Prop (λ _ → isSetInt _ _) refl)
  theMorph (pos (suc n)) f = coHomMorph _ (fst f)
  fun (theMorph (negsuc n) f) = idfun _
  isHom (theMorph (negsuc n) f) _ _ = refl

  open coHomTheory
  isCohomTheoryZ' : ∀ {ℓ} → coHomTheory {ℓ} coHomFunctor'
  Hmap isCohomTheoryZ' = theMorph

  -------------------------- Suspension --------------------------
  -- existence of suspension isomorphism
  fst (Suspension isCohomTheoryZ') (pos zero) {A = A} =
      invGroupEquiv
      (GrIsoToGrEquiv
        (Iso+Hom→GrIso (invIso suspFunCharac0)
                        (sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                λ f g → cong ∣_∣₂ (funExt λ { north → refl
                                                           ; south → refl
                                                           ; (merid a i) j → helper a (fst f) (fst g) j i}))))
    where
    helper : (a : typ A) (f g : typ A → coHomK 0)
          → Kn→ΩKn+1 0 (f a +[ 0 ]ₖ g a)
           ≡ cong₂ _+ₖ_ (Kn→ΩKn+1 0 (f a)) (Kn→ΩKn+1 0 (g a))
    helper a f g = Kn→ΩKn+1-hom 0 (f a) (g a)
                ∙ ∙≡+₁ (Kn→ΩKn+1 _ (f a)) (Kn→ΩKn+1 _ (g a))
  fst (Suspension isCohomTheoryZ') (pos (suc n)) {A = A} =
      invGroupEquiv
      (GrIsoToGrEquiv
        (Iso+Hom→GrIso (invIso (suspFunCharac {A = A} n))
                        (sElim2 (λ _ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                λ f g → cong ∣_∣₂ (funExt λ { north → refl
                                                           ; south → refl
                                                           ; (merid a i) j → helper a f g j i}))))
    where
    helper : (a : typ A) (f g : typ A → coHomK (suc n))
          → Kn→ΩKn+1 (suc n) (f a +ₖ g a)
           ≡ cong₂ _+ₖ_ (Kn→ΩKn+1 (suc n) (f a)) (Kn→ΩKn+1 (suc n) (g a))
    helper a f g = Kn→ΩKn+1-hom (suc n) (f a) (g a)
                ∙ ∙≡+₂ n (Kn→ΩKn+1 _ (f a)) (Kn→ΩKn+1 _ (g a))
  fst (Suspension isCohomTheoryZ') (negsuc zero) {A = A} =
      GrIsoToGrEquiv (Iso+Hom→GrIso (isContr→Iso (H0-susp {A = _ , pt A}) isContrUnit*)
                      λ _ _ → refl)
  fst (Suspension isCohomTheoryZ') (negsuc (suc n)) = idGroupEquiv _

  -- naturality of the suspension isomorphism
  snd (Suspension (isCohomTheoryZ' {ℓ})) (f , p) (pos zero) =
    funExt (sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
           λ {(f , _) → cong ∣_∣₂ (funExt λ {north → refl
                                          ; south → refl
                                          ; (merid a i) → refl})})
  snd (Suspension (isCohomTheoryZ' {ℓ})) (f , p) (pos (suc n)) =
    funExt (sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
           λ f → cong ∣_∣₂ (funExt λ {north → refl
                                    ; south → refl
                                    ; (merid a i) → refl}))
  snd (Suspension (isCohomTheoryZ' {ℓ})) (f , p) (negsuc zero) = refl
  snd (Suspension (isCohomTheoryZ' {ℓ})) (f , p) (negsuc (suc n)) = refl

  -------------------------- Exactness ---------------------------
  Exactness isCohomTheoryZ' {A = A} {B = B} f n = isoToPath (exactnessIso n f)
    where
    exactnessIso : (n : Int) (f : A →∙ B)
                → Iso (Ker (theMorph n f)) (Im (theMorph n (cfcod (fst f) , refl)))
    fun (exactnessIso (pos zero) (f , p)) =
      uncurry (sElim (λ _ → isSetΠ λ _ → isSetΣ setTruncIsSet λ _ → isProp→isSet propTruncIsProp)
                     λ {(g , q) inker → ∣ g , q ∣₂
                                       , pRec propTruncIsProp
                                              (λ gId → ∣ ∣ (λ { (inl tt) → 0
                                                              ; (inr b) → g b
                                                              ; (push a i) → funExt⁻ (cong fst gId) a (~ i)}) , q ∣₂
                                                       , cong ∣_∣₂ (Σ≡Prop (λ _ → isSetInt _ _) refl) ∣)
                                              (Iso.fun PathIdTrunc₀Iso inker)})
    inv (exactnessIso (pos zero) (f , p)) =
      uncurry (sElim (λ _ → isSetΠ λ _ → isSetΣ setTruncIsSet λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                λ {(g , q) inim'
                  → ∣ g , q ∣₂
                   , pRec (setTruncIsSet _ _)
                          (uncurry
                            (sElim (λ _ → isSetΠ (λ _ → isOfHLevelPath 2 setTruncIsSet _ _))
                                   (λ pushmap pushId'
                                     → pRec (setTruncIsSet _ _)
                                             (λ pushId
                                               → cong ∣_∣₂ (Σ≡Prop (λ _ → isSetInt _ _)
                                                             (funExt λ x → sym (funExt⁻ (cong fst pushId) (f x))
                                                                         ∙∙ cong (fst pushmap) (sym (push x) ∙ push (pt A))
                                                                         ∙∙ (cong (fst pushmap ∘ inr) p
                                                                           ∙ snd pushmap))))
                                             (Iso.fun PathIdTrunc₀Iso pushId'))))
                          inim'})
    rightInv (exactnessIso (pos zero) (f , p)) =
      uncurry (sElim (λ _ → isSetΠ λ _ → isOfHLevelPath 2
                                              (isSetΣ setTruncIsSet
                                                      (λ _ → isProp→isSet propTruncIsProp)) _ _)
                     λ {(p , q) _ → Σ≡Prop (λ _ → propTruncIsProp) refl})
    leftInv (exactnessIso (pos zero) (f , p)) =
      uncurry (sElim (λ _ → isSetΠ λ _ → isOfHLevelPath 2
                                              (isSetΣ setTruncIsSet
                                                      (λ _ → isProp→isSet (setTruncIsSet _ _))) _ _)
                     λ {(p , q) _ → Σ≡Prop (λ _ → setTruncIsSet _ _) refl})
    fun (exactnessIso (pos (suc n)) f) ker = (fst ker) , inIm-helper (fst ker) (snd ker)
      where
      inIm-helper : (x : coHom (suc n) (typ B))
                  → isInKer _ _ (theMorph (pos (suc n)) {A = A} {B = B} f) x
                  → isInIm _ _ (theMorph (pos (suc n)) {A = B} {B = _ , inr (pt B)} (cfcod (fst f) , refl)) x
      inIm-helper =
        coHomPointedElim _ (pt B) (λ _ → isPropΠ λ _ → propTruncIsProp)
          λ g gId inker → pRec propTruncIsProp
                               (λ gIdTot → ∣ ∣ (λ { (inl tt) → 0ₖ _
                                                  ; (inr b) → g b
                                                  ; (push a i) → funExt⁻ gIdTot a (~ i)}) ∣₂
                                             , cong ∣_∣₂ (funExt λ b → refl) ∣)
                               (Iso.fun PathIdTrunc₀Iso inker)
    inv (exactnessIso (pos (suc n)) f) im = fst im , inKer-helper (fst im) (snd im)
      where
      inKer-helper : (x : coHom (suc n) (typ B))
                  → isInIm _ _ (theMorph (pos (suc n)) {A = B} {B = _ , inr (pt B)} (cfcod (fst f) , refl)) x
                  → isInKer _ _ (theMorph (pos (suc n)) {A = A} {B = B} f) x
      inKer-helper =
        coHomPointedElim _ (pt B) (λ _ → isPropΠ λ _ → setTruncIsSet _ _)
          λ g gId → pRec (setTruncIsSet _ _)
                          (uncurry λ cg p
                            → subst (isInKer (coHomGr (suc n) (typ B)) (coHomGr (suc n) (typ A))
                                                                        (coHomMorph (suc n) (fst f)))
                                     p
                                     (helper cg))
         where
         helper : (cg : _) → coHomFun (suc n) (fst f) (coHomFun (suc n) (cfcod (fst f)) cg) ≡ 0ₕ _
         helper = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                        λ cg → trRec (isProp→isOfHLevelSuc n (setTruncIsSet _ _))
                                      (λ p → (cong ∣_∣₂ (funExt λ x → cong cg (sym (push x))
                                                                    ∙ p)))
                                      (isConnectedPathKn _ (cg (inl tt)) (0ₖ (suc n)) .fst)
    rightInv (exactnessIso (pos (suc n)) f) _ = Σ≡Prop (λ _ → propTruncIsProp) refl
    leftInv (exactnessIso (pos (suc n)) f) _ = Σ≡Prop (λ _ → setTruncIsSet _ _) refl
    exactnessIso (negsuc n) (f , p) =
      isContr→Iso ((tt* , refl)
                   , λ {(tt* , p) → Σ≡Prop (λ _ → isOfHLevelPath 1 isPropUnit* _ _)
                                            refl})
                   ((tt* , ∣ tt* , refl ∣)
                   , λ {(tt* , p) → Σ≡Prop (λ _ → propTruncIsProp)
                                            refl})

  -------------------------- Dimension ---------------------------
  Dimension isCohomTheoryZ' (pos zero) p = ⊥-rec (p refl)
  fst (Dimension isCohomTheoryZ' (pos (suc n)) _) = 0ₕ _
  snd (Dimension isCohomTheoryZ' (pos (suc n)) _) =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          (λ f → trRec (isProp→isOfHLevelSuc n (setTruncIsSet _ _))
                        (λ f-true → trRec (isProp→isOfHLevelSuc n (setTruncIsSet _ _))
                                          (λ f-false → cong ∣_∣₂ (funExt (λ {(lift true) → f-true
                                                                          ; (lift false) → f-false})))
                                          (isConnectedPathKn n (0ₖ _) (f (lift false)) .fst))
                        (isConnectedPathKn n (0ₖ _) (f (lift true)) .fst))
  Dimension isCohomTheoryZ' (negsuc n) _ = isContrUnit*

  ------------------------ Binary wedges -------------------------
  BinaryWedge isCohomTheoryZ' (pos zero) = GrIsoToGrEquiv (H⁰Red-⋁ _ _)
  BinaryWedge isCohomTheoryZ' (pos (suc n)) = GrIsoToGrEquiv (Hⁿ-⋁ _ _ n)
  BinaryWedge isCohomTheoryZ' (negsuc n) =
    GrIsoToGrEquiv
      (compGroupIso (IsoContrGroupTrivialGroup isContrUnit*)
                    (invGroupIso (IsoContrGroupTrivialGroup (isOfHLevel× 0 isContrUnit* isContrUnit*))))

-- Substituting back for our original theory, we are done
isCohomTheoryZ : ∀ {ℓ} → coHomTheory {ℓ} coHomFunctor
isCohomTheoryZ = subst coHomTheory (sym coHomFunctor≡coHomFunctor')
                       isCohomTheoryZ'


{-

Part 4: Higher inductive types

- Quotients via HITs
- Propositional truncation for logic?
- CS example using quotients (maybe finite multisets or queues)
- Synthetic homotopy theory (probably Torus = S^1 * S^1, pi_1(S^1) =
  Z, pi_1(Torus) = Z * Z)

-}

{-# OPTIONS --cubical #-}
module Part4 where

open import Cubical.Foundations.Prelude hiding (refl ; cong ; subst ; sym)
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Int
open import Cubical.Data.Prod

open import Part3

-----------------------------------------------------------------------------
-- Higher inductive types

-- The following definition of finite multisets is due to Vikraman
-- Choudhury and Marcelo Fiore.

infixr 5 _∷_

data FMSet (A : Type ℓ) : Type ℓ where
  [] : FMSet A
  _∷_ : (x : A) → (xs : FMSet A) → FMSet A
  comm : (x y : A) (xs : FMSet A) → x ∷ y ∷ xs ≡ y ∷ x ∷ xs
--  trunc : (xs ys : FMSet A) (p q : xs ≡ ys) → p ≡ q

-- We need to add the trunc constructor for FMSets to be sets, omitted
-- here for simplicity.

_++_ : ∀ {A : Type ℓ} (xs ys : FMSet A) → FMSet A
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ xs ++ ys
comm x y xs i ++ ys = comm x y (xs ++ ys) i
-- trunc xs zs p q i j ++ ys =
--   trunc (xs ++ ys) (zs ++ ys) (cong (_++ ys) p) (cong (_++ ys) q) i j

unitr-++ : {A : Type ℓ} (xs : FMSet A) → xs ++ [] ≡ xs
unitr-++ [] = refl
unitr-++ (x ∷ xs) = cong (x ∷_) (unitr-++ xs)
unitr-++ (comm x y xs i) j = comm x y (unitr-++ xs j) i
-- unitr-++ (trunc xs ys x y i j) = {!!}

-- This is a special case of set quotients! Very useful for
-- programming and set level mathematics

data _/_ (A : Type ℓ) (R : A → A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
  [_] : A → A / R
  eq/ : (a b : A) → R a b → [ a ] ≡ [ b ]
  trunc : (a b : A / R) (p q : a ≡ b) → p ≡ q

-- Proving that they are effective ((a b : A) → [ a ] ≡ [ b ] → R a b)
-- requires univalence for propositions.

-------------------------------------------------------------------------
-- Topological examples of things that are not sets

-- We can define the circle as the following simple data declaration:
data S¹ : Type₀ where
  base : S¹
  loop : base ≡ base

-- We can write functions on S¹ using pattern-matching equations:
double : S¹ → S¹
double base = base
double (loop i) = (loop ∙ loop) i

helix : S¹ → Type₀
helix base     = Int
helix (loop i) = sucPathInt i

ΩS¹ : Type₀
ΩS¹ = base ≡ base

winding : ΩS¹ → Int
winding p = subst helix p (pos 0)

_ : winding (λ i → double ((loop ∙ loop) i)) ≡ pos 4
_ = refl

-- We can define the Torus as:
data Torus : Type₀ where
  point : Torus
  line1 : point ≡ point
  line2 : point ≡ point
  square : PathP (λ i → line1 i ≡ line1 i) line2 line2

-- And prove that it is equivalent to two circle:
t2c : Torus → S¹ × S¹
t2c point        = (base , base)
t2c (line1 i)    = (loop i , base)
t2c (line2 j)    = (base , loop j)
t2c (square i j) = (loop i , loop j)

c2t : S¹ × S¹ → Torus
c2t (base   , base)   = point
c2t (loop i , base)   = line1 i
c2t (base   , loop j) = line2 j
c2t (loop i , loop j) = square i j

c2t-t2c : (t : Torus) → c2t (t2c t) ≡ t
c2t-t2c point        = refl
c2t-t2c (line1 _)    = refl
c2t-t2c (line2 _)    = refl
c2t-t2c (square _ _) = refl

t2c-c2t : (p : S¹ × S¹) → t2c (c2t p) ≡ p
t2c-c2t (base   , base)   = refl
t2c-c2t (base   , loop _) = refl
t2c-c2t (loop _ , base)   = refl
t2c-c2t (loop _ , loop _) = refl

-- Using univalence we get the following equality:
Torus≡S¹×S¹ : Torus ≡ S¹ × S¹
Torus≡S¹×S¹ = isoToPath' (iso t2c c2t t2c-c2t c2t-t2c)

windingTorus : point ≡ point → Int × Int
windingTorus l = ( winding (λ i → proj₁ (t2c (l i)))
                 , winding (λ i → proj₂ (t2c (l i))))

_ : windingTorus (line1 ∙ sym line2) ≡ (pos 1 , negsuc 0)
_ = refl

-- We have many more topological examples, including Klein bottle, RP^n,
-- higher spheres, suspensions, join, wedges, smash product:
open import Cubical.HITs.KleinBottle
open import Cubical.HITs.RPn
open import Cubical.HITs.S2
open import Cubical.HITs.S3
open import Cubical.HITs.Susp
open import Cubical.HITs.Join
-- open import Cubical.HITs.Wedge
open import Cubical.HITs.SmashProduct

-- There's also a proof of the "3x3 lemma" for pushouts in less than
-- 200LOC. In HoTT-Agda this took about 3000LOC. For details see:
-- https://github.com/HoTT/HoTT-Agda/tree/master/theorems/homotopy/3x3
open import Cubical.HITs.Pushout

-- We also defined the Hopf fibration and proved that its total space
-- is S³ in about 300LOC:
open import Cubical.HITs.Hopf

-- There is also some integer cohomology:
open import Cubical.ZCohomology.Everything
-- To compute cohomology groups of various spaces we need a bunch of
-- interesting theorems: Freudenthal suspension theorem,
-- Mayer-Vietoris sequence...
open import Cubical.Homotopy.Freudenthal
-- open import Cubical.ZCohomology.MayerVietorisUnreduced


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

postulate
  A : Set
  P : A → Set
  Q : {x : A} → P x → P x → Set

variable
  B    : Set
  @0 q : B

postulate
  F : ∀ p → Q p q → Set

Test : {@0 x : A} ({q} p : P x) (q′ : Q p q) → Set
Test = F


------------------------------------------------------------------------------
-- Conversion rules for the recursive operator rec
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.Rec.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Rec

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

private
  -- We follow the same methodology used in
  -- LTC-PCF.Program.Division.EquationsI (see it for the
  -- documentation).

  ----------------------------------------------------------------------------
  -- The steps

  -- Initially, the conversion rule fix-eq is applied.
  rec-s₁ : D → D → D → D
  rec-s₁ n a f = rech (fix rech) · n · a · f

  -- First argument application.
  rec-s₂ : D → D
  rec-s₂ n = lam (λ a → lam (λ f →
               if (iszero₁ n)
                 then a
                 else f · pred₁ n · (fix rech · pred₁ n · a · f)))

  -- Second argument application.
  rec-s₃ : D → D → D
  rec-s₃ n a = lam (λ f →
                 if (iszero₁ n)
                   then a
                   else f · pred₁ n · (fix rech · pred₁ n · a · f))

  -- Third argument application.
  rec-s₄ : D → D → D → D
  rec-s₄ n a f = if (iszero₁ n)
                   then a
                   else f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction iszero₁ n ≡ b.
  rec-s₅ : D → D → D → D → D
  rec-s₅ n a f b = if b
                     then a
                     else f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction of iszero₁ n ≡ true
  --
  -- It should be
  -- rec-s₆ : D → D → D → D
  -- rec-s₆ n a f = a
  --
  -- but we do not give a name to this step.

  -- Reduction iszero₁ n ≡ false.
  rec-s₆ : D → D → D → D
  rec-s₆ n a f = f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction pred₁ (succ n) ≡ n.
  rec-s₇ : D → D → D → D
  rec-s₇ n a f = f · n · (fix rech · n · a · f)

  ----------------------------------------------------------------------------
  -- The execution steps

  -- We follow the same methodology used in
  -- LTC-PCF.Program.Division.EquationsI (see it for the
  -- documentation).

  -- Application of the conversion rule fix-eq.
  proof₀₋₁ : ∀ n a f → fix rech · n · a · f ≡ rec-s₁ n a f
  proof₀₋₁ n a f = subst (λ x → x · n · a · f ≡ rech (fix rech) · n · a · f )
                         (sym (fix-eq rech))
                         refl

  -- Application of the first argument.
  proof₁₋₂ : ∀ n a f → rec-s₁ n a f ≡ rec-s₂ n · a · f
  proof₁₋₂ n a f = subst (λ x → x · a · f ≡ rec-s₂ n · a · f)
                         (sym (beta rec-s₂ n))
                         refl

  -- Application of the second argument.
  proof₂₋₃ : ∀ n a f → rec-s₂ n · a · f ≡ rec-s₃ n a · f
  proof₂₋₃ n a f = subst (λ x → x · f ≡ rec-s₃ n a · f)
                         (sym (beta (rec-s₃ n) a))
                         refl

  -- Application of the third argument.
  proof₃₋₄ : ∀ n a f → rec-s₃ n a · f ≡ rec-s₄ n a f
  proof₃₋₄ n a f = beta (rec-s₄ n a) f

  -- Cases iszero₁ n ≡ b using that proof.
  -- 25 April 2014. Failed with Andreas' --without-K.
  proof₄₋₅ : ∀ n a f b → iszero₁ n ≡ b → rec-s₄ n a f ≡ rec-s₅ n a f b
  proof₄₋₅ n a f .(iszero₁ n) refl = refl

  -- Reduction of if true ... using the conversion rule if-true.
  proof₅₊ : ∀ n a f → rec-s₅ n a f true ≡ a
  proof₅₊ n a f = if-true a

   -- Reduction of if false ... using the conversion rule if-false.
  proof₅₋₆ : ∀ n a f → rec-s₅ n a f false ≡ rec-s₆ n a f
  proof₅₋₆ n a f = if-false (rec-s₆ n a f)

  -- Reduction pred₁ (succ n) ≡ n using the conversion rule pred₁-S.
  proof₆₋₇ : ∀ n a f → rec-s₆ (succ₁ n) a f ≡ rec-s₇ n a f
  proof₆₋₇ n a f = subst (λ x → rec-s₇ x a f ≡ rec-s₇ n a f)
                         (sym (pred-S n))
                         refl

------------------------------------------------------------------------------
-- The conversion rules for rec.

rec-0 : ∀ a {f} → rec zero a f ≡ a
rec-0 a {f} =
  fix rech · zero · a · f  ≡⟨ proof₀₋₁ zero a f ⟩
  rec-s₁ zero a f          ≡⟨ proof₁₋₂ zero a f ⟩
  rec-s₂ zero · a · f      ≡⟨ proof₂₋₃ zero a f ⟩
  rec-s₃ zero a · f        ≡⟨ proof₃₋₄ zero a f ⟩
  rec-s₄ zero a f          ≡⟨ proof₄₋₅ zero a f true iszero-0 ⟩
  rec-s₅ zero a f true     ≡⟨ proof₅₊ zero a f ⟩
  a                        ∎

rec-S : ∀ n a f → rec (succ₁ n) a f ≡ f · n · (rec n a f)
rec-S n a f =
  fix rech · (succ₁ n) · a · f  ≡⟨ proof₀₋₁ (succ₁ n) a f ⟩
  rec-s₁ (succ₁ n) a f          ≡⟨ proof₁₋₂ (succ₁ n) a f ⟩
  rec-s₂ (succ₁ n) · a · f      ≡⟨ proof₂₋₃ (succ₁ n) a f ⟩
  rec-s₃ (succ₁ n) a · f        ≡⟨ proof₃₋₄ (succ₁ n) a f ⟩
  rec-s₄ (succ₁ n) a f          ≡⟨ proof₄₋₅ (succ₁ n) a f false (iszero-S n) ⟩
  rec-s₅ (succ₁ n) a f false    ≡⟨ proof₅₋₆ (succ₁ n) a f ⟩
  rec-s₆ (succ₁ n) a f          ≡⟨ proof₆₋₇ n a f ⟩
  rec-s₇ n a f                  ∎


------------------------------------------------------------------------
-- Parser indices
------------------------------------------------------------------------

module StructurallyRecursiveDescentParsing.Index where

open import Data.Bool
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Function

------------------------------------------------------------------------
-- Indices to the parser type

-- Does the parser accept empty strings?

Empty : Set
Empty = Bool

-- The proper left corners of the parser, represented as a tree. See
-- StructurallyRecursiveDescentParsing.Grammar.

infix 5 _∪_

data Corners : Set where
  ε   : Corners
  _∪_ : (c₁ c₂ : Corners) → Corners

-- The index type.

infix 4 _◇_

record Index : Set where
  constructor _◇_
  field
    empty   : Empty
    corners : Corners

open Index public

-- Type signature for non-terminals. The second argument is the result
-- type.

NonTerminalType : Set2
NonTerminalType = Index → Set → Set1

------------------------------------------------------------------------
-- Operations on indices

infixr 50 _·_
infixr 40 _∥_

0I : Index
0I = false ◇ ε

1I : Index
1I = true ◇ ε

_∥_ : Index → Index → Index
i₁ ∥ i₂ = empty i₁ ∨ empty i₂ ◇ corners i₁ ∪ corners i₂

_·_ : Index → Index → Index
i₁ · i₂ = (empty i₁ ∧ empty i₂)
          ◇
          (if empty i₁ then corners i₁ ∪ corners i₂
                       else corners i₁)

------------------------------------------------------------------------
-- Testing indices for equality

infix 15 _Index-≟_ _Corners-≟_

private

  drop-∪₁ : ∀ {c₁ c₂ c₃ c₄} → c₁ ∪ c₂ ≡ c₃ ∪ c₄ → c₁ ≡ c₃
  drop-∪₁ refl = refl

  drop-∪₂ : ∀ {c₁ c₂ c₃ c₄} → c₁ ∪ c₂ ≡ c₃ ∪ c₄ → c₂ ≡ c₄
  drop-∪₂ refl = refl

_Corners-≟_ : Decidable {A = Corners} _≡_
ε         Corners-≟ ε           = yes refl
(c₁ ∪ c₂) Corners-≟ ( c₃ ∪  c₄) with c₁ Corners-≟ c₃ | c₂ Corners-≟ c₄
(c₁ ∪ c₂) Corners-≟ (.c₁ ∪ .c₂) | yes refl | yes refl = yes refl
(c₁ ∪ c₂) Corners-≟ ( c₃ ∪  c₄) | no  ¬c₁≡c₂ | _          = no (¬c₁≡c₂ ∘ drop-∪₁)
(c₁ ∪ c₂) Corners-≟ ( c₃ ∪  c₄) | _          | no  ¬c₁≡c₂ = no (¬c₁≡c₂ ∘ drop-∪₂)
ε         Corners-≟ (_ ∪ _)     = no λ()
(_ ∪ _)   Corners-≟ ε           = no λ()

_Index-≟_ : Decidable {A = Index} _≡_
i₁ Index-≟ i₂ with empty i₁ ≟ empty i₂
                 | corners i₁ Corners-≟ corners i₂
... | yes e₁≡e₂ | yes c₁≡c₂ = yes (cong₂ _◇_ e₁≡e₂ c₁≡c₂)
... | no ¬e₁≡e₂ | _         = no (¬e₁≡e₂ ∘ cong empty)
... | _         | no ¬c₁≡c₂ = no (¬c₁≡c₂ ∘ cong corners)


module char where

open import bool
open import nat
open import eq
open import product
open import product-thms

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

postulate
  char : Set

{-# BUILTIN CHAR char #-}

----------------------------------------------------------------------
-- primitive operations
----------------------------------------------------------------------

private
 primitive
  primCharToNat    : char → ℕ
  primCharEquality : char → char → 𝔹

toNat : char → ℕ
toNat = primCharToNat

infix 4 _=char_

_=char_ : char → char → 𝔹
_=char_ = primCharEquality

postulate
  ≡char-to-= : (c1 c2 : char) → c1 ≡ c2 → _=char_ c1 c2 ≡ tt
  =char-to-≡ : (c1 c2 : char) → _=char_ c1 c2 ≡ tt → c1 ≡ c2

=char-sym : (c1 c2 : char) → (c1 =char c2) ≡ (c2 =char c1)
=char-sym c1 c2 with keep (c1 =char c2)
=char-sym c1 c2 | tt , p rewrite =char-to-≡ c1 c2 p = refl
=char-sym c1 c2 | ff , p with keep (c2 =char c1)
=char-sym c1 c2 | ff , p | tt , p' rewrite =char-to-≡ c2 c1 p' = refl
=char-sym c1 c2 | ff , p | ff , p' rewrite p | p' = refl

postulate
  _<char_ : char → char → 𝔹

{-# COMPILED _<char_ (<)   #-}

----------------------------------------------------------------------
-- defined operations
----------------------------------------------------------------------

-- is a decimal digit
is-digit : char → 𝔹
is-digit '0' = tt
is-digit '1' = tt
is-digit '2' = tt
is-digit '3' = tt
is-digit '4' = tt
is-digit '5' = tt
is-digit '6' = tt
is-digit '7' = tt
is-digit '8' = tt
is-digit '9' = tt
is-digit _ = ff


{-

  - UARel given by a universe and equivalences
  - SubstRel and DUARel for the element family over the universe

-}
{-# OPTIONS --no-exact-split --safe #-}
module Cubical.Displayed.Universe where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Displayed.Base
open import Cubical.Displayed.Subst

private
  variable
    ℓA ℓ≅A ℓB ℓ≅B ℓP : Level

𝒮-Univ : ∀ ℓ → UARel (Type ℓ) ℓ
𝒮-Univ ℓ .UARel._≅_ = _≃_
𝒮-Univ ℓ .UARel.ua _ _ = isoToEquiv (invIso univalenceIso)

𝒮ˢ-El : ∀ ℓ → SubstRel (𝒮-Univ ℓ) (λ X → X)
𝒮ˢ-El ℓ .SubstRel.act e = e
𝒮ˢ-El ℓ .SubstRel.uaˢ e a = uaβ e a

𝒮ᴰ-El : ∀ ℓ → DUARel (𝒮-Univ ℓ) (λ X → X) ℓ
𝒮ᴰ-El ℓ .DUARel._≅ᴰ⟨_⟩_  a e a' = e .fst a ≡ a'
𝒮ᴰ-El ℓ .DUARel.uaᴰ a e a' = invEquiv (ua-ungluePath-Equiv e)


module examplesPaperJFP.CounterCell where

open import Data.Product
open import Data.Nat.Base
open import Data.Nat.Show
open import Data.String.Base using (String; _++_)

open import Size

-- open import NativeIO

-- open import SizedIO.Base
-- open import SizedIO.Object
-- open import SizedIO.IOObject
-- open import SizedIO.ConsoleObject
-- open import SizedIO.Console hiding (main)

open import examplesPaperJFP.NativeIOSafe

open import examplesPaperJFP.ConsoleInterface
open import examplesPaperJFP.Console hiding (main)
open import examplesPaperJFP.Object using (Interface; Method; Result; CellMethod; get; put; CellResult; cellJ)
open import examplesPaperJFP.Sized hiding (program; main)

data CounterMethod A : Set where
  super  :  (m : CellMethod A) → CounterMethod A
  stats  :  CounterMethod A

pattern getᶜ    = super get
pattern putᶜ x  = super (put x)

statsCellI : (A : Set) → Interface
Method  (statsCellI A)            =  CounterMethod A
Result  (statsCellI A) (super m)  =  Result (cellJ A) m
Result  (statsCellI A) stats      =  Unit

CounterC : (i : Size) → Set
CounterC = IOObject ConsoleInterface (statsCellI String)

counterCell : ∀{i} (c : CellC i) (ngets nputs : ℕ) → CounterC i

method (counterCell c ngets nputs) getᶜ =
  method c get                                >>= λ { (s , c′) →
  return (s , counterCell c′ (1 + ngets) nputs)  }

method (counterCell c ngets nputs) (putᶜ x) =
  method c (put x)                            >>= λ { (_ , c′) →
  return (unit , counterCell c′ ngets (1 + nputs))  }

method (counterCell c ngets nputs) stats =
  exec (putStrLn ("Counted "
    ++ show ngets ++ " calls to get and "
    ++ show nputs ++ " calls to put."))       λ _ →
  return (unit , counterCell c ngets nputs)

program : String → IO ConsoleInterface ∞ Unit
program arg =
  let c₀ = counterCell (simpleCell "Start") 0 0 in
  method c₀ getᶜ               >>= λ{ (s   , c₁) →
  exec (putStrLn s)              λ _ →
  method c₁ (putᶜ arg)         >>= λ{ (_        , c₂) →
  method c₂ getᶜ               >>= λ{ (s′  , c₃) →
  exec (putStrLn s′)             λ _ →
  method c₃ (putᶜ "Over!")     >>= λ{ (_ , c₄) →
  method c₄ stats              >>= λ{ (_ , c₅) →
  return unit                  }}}}}

main : NativeIO Unit
main = translateIO translateIOConsoleLocal (program "Hello")


-- Andreas, bug found 2011-12-31

{-# OPTIONS --irrelevant-projections #-}

module Issue543a where

open import Common.Equality

data   ⊥ : Set where
record ⊤ : Set where
  constructor tt

data Bool : Set where
  true false : Bool

record Squash (A : Set) : Set where
  constructor squash
  field
    .unsquash : A
open Squash

-- ok:
sqT≡sqF : squash true ≡ squash false
sqT≡sqF = refl

record Inhabited : Set1 where
  constructor inhabited
  field
    Type : Set
    elem : Type
open Inhabited

.bad1 : Inhabited
bad1 = inhabited (true ≡ unsquash (squash true)) refl

.bad2 : Inhabited
bad2 = inhabited (unsquash (squash false) ≡ false) refl

infixl 2 _∘_
_∘_ = trans

-- this should not be provable!!
.irrT≡F : true ≡ false
irrT≡F = elem bad1 ∘ cong unsquash sqT≡sqF ∘ elem bad2

-- the rest is easy

T : Bool → Set
T true  = ⊤
T false = ⊥

T≠F : true ≡ false → ⊥
T≠F p = subst T p tt

.irr⊥ : ⊥
irr⊥ = T≠F irrT≡F

rel⊥ : .⊥ → ⊥
rel⊥ ()

absurd : ⊥
absurd = rel⊥ irr⊥


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Sigma.Base where

open import Cubical.Core.Primitives public

-- Σ-types are defined in Core/Primitives as they are needed for Glue types.

_×_ : ∀ {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') → Type (ℓ-max ℓ ℓ')
A × B = Σ A (λ _ → B)

infixr 5 _×_


-- Andreas, 2022-03-11, issue #5823
-- Make sure we do not weaken the singleton detection too much by checking for loops.

open import Agda.Builtin.Nat

record ⊤ : Set where

record Wrap (A : Set) : Set where
  field unwrap : A

record _×_ (A B : Set) : Set where
  field
    fst : A
    snd : B

-- A singleton record type with nestings of Wrap.

Singleton = (Wrap ⊤ × Wrap (Wrap ⊤)) × Wrap (Wrap (Wrap ⊤ × ⊤) × Wrap ⊤)

-- Agda should solve this meta:

unique : Singleton
unique = _

-- This is fine, even though we pass through 'Wrap' several times.
-- Passing already visited non-recursive records is fine!

mutual
  record S (n : Nat) : Set where
    inductive; eta-equality
    field inn : T n

  T : Nat → Set
  T zero = ⊤
  T (suc n) = T n × S n

-- S n is a eta singleton type for each n because it is terminating.

inh5 : S 5
inh5 = _


{-# OPTIONS --guardedness #-}

module ky where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; _≢_; refl; cong; cong₂; sym)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _≡⟨_⟩_; _∎)
open import Data.Rational using (ℚ; _+_; _*_; _-_)
open import Data.Bool
open import Data.Bool.Properties
open import Data.Rational
open import Data.Nat as ℕ using (ℕ; zero; suc)
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Agda.Builtin.Size
open import Data.Product
open import Data.Unit
open import Data.Maybe

data QRE : Set → Set → Set₁ where
  ⊥ : ∀{D C} → QRE D C
  ε : ∀{D C} → C → QRE D C
  α : ∀{D C}
    → (D → Bool)  --φ
    → (D → C)     --op
    → QRE D C
  split : ∀{D C B A}
    → QRE D A     --f
    → QRE D B     --g
    → (A → B → C) --op
    → QRE D C
  iter : ∀{D B A}
    → QRE D B     --init
    → QRE D A     --body
    → (B → A → B) --op
    → QRE D B
  or : ∀{D C}
    → QRE D C
    → QRE D C
    → QRE D C

Event : Set
Event = ℕ

data Val : Set → Set where
  VBool : Bool → Val Bool
  VNat  : ℕ → Val ℕ

data Exp : Set → Set where
  EVal : ∀{t : Set} → Val t → Exp t

data Com : Set → Set where
  CFlip : ∀{t} → Com t → Com t → Com t
  CUpd  : Exp Event → Com ⊤
  CIte  : ∀{t} → Exp Bool → Com t → Com t → Com t
  CSeq  : ∀{t} → Com ⊤ → Com t → Com t

is-true : Bool → Bool
is-true = λ{x → x}

data CoList (i : Size) (A : Set) : Set where
  nil  : CoList i A
  cons : A → ∀{j : Size< i} → CoList j A → CoList i A

_++_ : ∀{A} → CoList ∞ A → CoList ∞ A → CoList ∞ A
nil         ++ s₂ = s₂
(cons a s₁) ++ s₂ = cons a (s₁ ++ s₂)

interp : Com ⊤ → QRE Bool (CoList ∞ Event)
interp (CFlip c₁ c₂) =
  or (split (α is-true λ{_ → nil}) (interp c₁) (_++_))
     (split (α not     λ{_ → nil}) (interp c₂) (_++_))


module Issue978 where

module A where

  infixr 4 _,_

  record _×_ (A B : Set) : Set where
    constructor _,_
    field
      fst : A
      snd : B

module B where

  infixl 2 _,_

  data Ty : Set where

  data Cxt : Set where
    ε   : Cxt
    _,_ : (Γ : Cxt) (a : Ty) → Cxt

open A
open B

test : (Γ : Cxt) → Set₁
test ε = Set
test (ε , a) = ?
test (Γ , a , a₁) = ?


{-

Groupoid quotients:

-}

{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.GroupoidQuotients.Properties where

open import Cubical.HITs.GroupoidQuotients.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels

open import Cubical.Functions.Surjection

open import Cubical.Data.Sigma

open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary.Base

open import Cubical.HITs.PropositionalTruncation as PropTrunc using (∥_∥₁; ∣_∣₁; squash₁)
open import Cubical.HITs.SetTruncation as SetTrunc using (∥_∥₂; ∣_∣₂; squash₂)

-- Type quotients

private
  variable
    ℓA ℓR ℓ : Level
    A : Type ℓA
    R : A → A → Type ℓR

elimSet : (Rt : BinaryRelation.isTrans R)
     → {B : A // Rt → Type ℓ}
     → ((x : A // Rt) → isSet (B x))
     → (f : (a : A) → B [ a ])
     → ({a b : A} (r : R a b) → PathP (λ i → B (eq// r i)) (f a) (f b))
     → (x : A // Rt)
     → B x
elimSet Rt Bset f feq [ a ] = f a
elimSet Rt Bset f feq (eq// r i) = feq r i
elimSet Rt Bset f feq (comp// {a} {b} {c} r s i j) =
  isSet→SquareP (λ i j → Bset (comp// r s i j))
    (λ j → feq r j) (λ j → feq (Rt a b c r s) j)
    (λ i → f a) (λ i → feq s i) i j
elimSet Rt Bset f feq (squash// x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 (λ x → isSet→isGroupoid (Bset x))
    _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (squash// x y p q r s) i j k
  where
    g = elimSet Rt Bset f feq

elimProp : (Rt : BinaryRelation.isTrans R)
         → {B : A // Rt → Type ℓ}
         → ((x : A // Rt) → isProp (B x))
         → ((a : A) → B [ a ])
         → (x : A // Rt)
         → B x
elimProp Rt Brop f x =
  elimSet Rt (λ x → isProp→isSet (Brop x)) f (λ r → isProp→PathP (λ i → Brop (eq// r i)) (f _) (f _)) x

elimProp2 : (Rt : BinaryRelation.isTrans R)
          → {C : A // Rt → A // Rt → Type ℓ}
         → ((x y : A // Rt) → isProp (C x y))
         → ((a b : A) → C [ a ] [ b ])
         → (x y : A // Rt)
         → C x y
elimProp2 Rt Cprop f = elimProp Rt (λ x → isPropΠ (λ y → Cprop x y))
                                   (λ x → elimProp Rt (λ y → Cprop [ x ] y) (f x))

isSurjective[] : (Rt : BinaryRelation.isTrans R)
               → isSurjection (λ a → [ a ])
isSurjective[] Rt = elimProp Rt (λ x → squash₁) (λ a → ∣ a , refl ∣₁)

elim : (Rt : BinaryRelation.isTrans R)
     → {B : A // Rt → Type ℓ}
     → ((x : A // Rt) → isGroupoid (B x))
     → (f : (a : A) → B [ a ])
     → (feq : {a b : A} (r : R a b) → PathP (λ i → B (eq// r i)) (f a) (f b))
     → ({a b c : A} (r : R a b) (s : R b c)
           → SquareP (λ i j → B (comp// r s i j))
           (feq r) (feq (Rt a b c r s)) (λ j → f a) (feq s))
     → (x : A // Rt)
     → B x
elim Rt Bgpd f feq fcomp [ a ] = f a
elim Rt Bgpd f feq fcomp (eq// r i) = feq r i
elim Rt Bgpd f feq fcomp (comp// r s i j) = fcomp r s i j
elim Rt Bgpd f feq fcomp (squash// x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 Bgpd
    _ _ _ _ (λ j k → g (r j k)) (λ j k → g (s j k)) (squash// x y p q r s) i j k
  where
    g = elim Rt Bgpd f feq fcomp

rec : (Rt : BinaryRelation.isTrans R)
    → {B : Type ℓ}
    → isGroupoid B
    → (f : A → B)
    → (feq : {a b : A} (r : R a b) → f a ≡ f b)
    → ({a b c : A} (r : R a b) (s : R b c)
          → Square (feq r) (feq (Rt a b c r s)) refl (feq s))
    → (x : A // Rt)
    → B
rec Rt Bgpd = elim Rt (λ _ → Bgpd)


-- Andreas, 2014-10-18 AIM XX

module EvalInTopLevel where

data Bool : Set where true false : Bool

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

-- Evaluate @not false@ in top level.


postulate
  F : @0 Set → Set

G : @0 Set → Set
G A = F (λ { → A })


{-# OPTIONS --allow-unsolved-metas #-}
open import Level
open import Ordinals
module ODC {n : Level } (O : Ordinals {n} ) where

open import zf
open import Data.Nat renaming ( zero to Zero ; suc to Suc ;  ℕ to Nat ; _⊔_ to _n⊔_ )
open import  Relation.Binary.PropositionalEquality
open import Data.Nat.Properties
open import Data.Empty
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Core

import OrdUtil
open import logic
open import nat
import OD
import ODUtil

open inOrdinal O
open OD O
open OD.OD
open OD._==_
open ODAxiom odAxiom
open ODUtil O

open Ordinals.Ordinals  O
open Ordinals.IsOrdinals isOrdinal
open Ordinals.IsNext isNext
open OrdUtil O

open HOD

open _∧_

postulate
  -- mimimul and x∋minimal is an Axiom of choice
  minimal : (x : HOD  ) → ¬ (x =h= od∅ )→ HOD
  -- this should be ¬ (x =h= od∅ )→ ∃ ox → x ∋ Ord ox  ( minimum of x )
  x∋minimal : (x : HOD  ) → ( ne : ¬ (x =h= od∅ ) ) → odef x ( & ( minimal x ne ) )
  -- minimality (may proved by ε-induction with LEM)
  minimal-1 : (x : HOD  ) → ( ne : ¬ (x =h= od∅ ) ) → (y : HOD ) → ¬ ( odef (minimal x ne) (& y)) ∧ (odef x (&  y) )

--
-- Axiom of choice in intutionistic logic implies the exclude middle
--     https://plato.stanford.edu/entries/axiom-choice/#AxiChoLog
--

pred-od :  ( p : Set n )  → HOD
pred-od  p  = record { od = record { def = λ x → (x ≡ o∅) ∧ p } ;
   odmax = osuc o∅; <odmax = λ x → subst (λ k →  k o< osuc o∅) (sym (proj1 x)) <-osuc }

ppp :  { p : Set n } { a : HOD  } → pred-od p ∋ a → p
ppp  {p} {a} d = proj2 d

p∨¬p : ( p : Set n ) → p ∨ ( ¬ p )         -- assuming axiom of choice
p∨¬p  p with is-o∅ ( & (pred-od p ))
p∨¬p  p | yes eq = case2 (¬p eq) where
   ps = pred-od p
   eqo∅ : ps =h=  od∅  → & ps ≡  o∅
   eqo∅ eq = subst (λ k → & ps ≡ k) ord-od∅ ( cong (λ k → & k ) (==→o≡ eq))
   lemma : ps =h= od∅ → p → ⊥
   lemma eq p0 = ¬x<0  {& ps} (eq→ eq record { proj1 = eqo∅ eq ; proj2 = p0 } )
   ¬p : (& ps ≡ o∅) → p → ⊥
   ¬p eq = lemma ( subst₂ (λ j k → j =h=  k ) *iso o∅≡od∅ ( o≡→== eq ))
p∨¬p  p | no ¬p = case1 (ppp  {p} {minimal ps (λ eq →  ¬p (eqo∅ eq))} lemma) where
   ps = pred-od p
   eqo∅ : ps =h=  od∅  → & ps ≡  o∅
   eqo∅ eq = subst (λ k → & ps ≡ k) ord-od∅ ( cong (λ k → & k ) (==→o≡ eq))
   lemma : ps ∋ minimal ps (λ eq →  ¬p (eqo∅ eq))
   lemma = x∋minimal ps (λ eq →  ¬p (eqo∅ eq))

decp : ( p : Set n ) → Dec p   -- assuming axiom of choice
decp  p with p∨¬p p
decp  p | case1 x = yes x
decp  p | case2 x = no x

∋-p : (A x : HOD ) → Dec ( A ∋ x )
∋-p A x with p∨¬p ( A ∋ x ) -- LEM
∋-p A x | case1 t  = yes t
∋-p A x | case2 t  = no (λ x → t x)

double-neg-eilm : {A : Set n} → ¬ ¬ A → A      -- we don't have this in intutionistic logic
double-neg-eilm  {A} notnot with decp  A                         -- assuming axiom of choice
... | yes p = p
... | no ¬p = ⊥-elim ( notnot ¬p )

open _⊆_

power→⊆ :  ( A t : HOD) → Power A ∋ t → t ⊆ A
power→⊆ A t  PA∋t = record { incl = λ {x} t∋x → double-neg-eilm (t1 t∋x) } where
   t1 : {x : HOD }  → t ∋ x → ¬ ¬ (A ∋ x)
   t1 = power→ A t PA∋t

OrdP : ( x : Ordinal  ) ( y : HOD  ) → Dec ( Ord x ∋ y )
OrdP  x y with trio< x (& y)
OrdP  x y | tri< a ¬b ¬c = no ¬c
OrdP  x y | tri≈ ¬a refl ¬c = no ( o<¬≡ refl )
OrdP  x y | tri> ¬a ¬b c = yes c

open import zfc

HOD→ZFC : ZFC
HOD→ZFC   = record {
    ZFSet = HOD
    ; _∋_ = _∋_
    ; _≈_ = _=h=_
    ; ∅  = od∅
    ; Select = Select
    ; isZFC = isZFC
 } where
    -- infixr  200 _∈_
    -- infixr  230 _∩_ _∪_
    isZFC : IsZFC (HOD )  _∋_  _=h=_ od∅ Select
    isZFC = record {
       choice-func = choice-func ;
       choice = choice
     } where
         -- Axiom of choice ( is equivalent to the existence of minimal in our case )
         -- ∀ X [ ∅ ∉ X → (∃ f : X → ⋃ X ) → ∀ A ∈ X ( f ( A ) ∈ A ) ]
         choice-func : (X : HOD  ) → {x : HOD } → ¬ ( x =h= od∅ ) → ( X ∋ x ) → HOD
         choice-func X {x} not X∋x = minimal x not
         choice : (X : HOD  ) → {A : HOD } → ( X∋A : X ∋ A ) → (not : ¬ ( A =h= od∅ )) → A ∋ choice-func X not X∋A
         choice X {A} X∋A not = x∋minimal A not


module BasicIPC.Metatheory.Hilbert-TarskiGluedClosedImplicit where

open import BasicIPC.Syntax.Hilbert public
open import BasicIPC.Semantics.TarskiGluedClosedImplicit public

open ImplicitSyntax (∅ ⊢_) public

-- Completeness with respect to a particular model, for closed terms only.

module _ {{_ : Model}} where
  reify : ∀ {A} → ⊩ A → ∅ ⊢ A
  reify {α P}   s = syn s
  reify {A ▻ B} s = syn s
  reify {A ∧ B} s = pair (reify (π₁ s)) (reify (π₂ s))
  reify {⊤}    s = unit

-- Additional useful equipment.

module _ {{_ : Model}} where
  ⟪K⟫ : ∀ {A B} → ⊩ A → ⊩ B ▻ A
  ⟪K⟫ a = app ck (reify a) ⅋ K a

  ⟪S⟫′ : ∀ {A B C} → ⊩ A ▻ B ▻ C → ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ s₁ = app cs (reify s₁) ⅋ λ s₂ →
              app (app cs (reify s₁)) (reify s₂) ⅋ ⟪S⟫ s₁ s₂

  _⟪,⟫′_ : ∀ {A B} → ⊩ A → ⊩ B ▻ A ∧ B
  _⟪,⟫′_ a = app cpair (reify a) ⅋ _,_ a

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)   γ = lookup i γ
eval (app t u) γ = eval t γ ⟪$⟫ eval u γ
eval ci        γ = ci ⅋ I
eval ck        γ = ck ⅋ ⟪K⟫
eval cs        γ = cs ⅋ ⟪S⟫′
eval cpair     γ = cpair ⅋ _⟪,⟫′_
eval cfst      γ = cfst ⅋ π₁
eval csnd      γ = csnd ⅋ π₂
eval unit      γ = ∙

-- Correctness of evaluation with respect to conversion.

eval✓ : ∀ {{_ : Model}} {A Γ} {t t′ : Γ ⊢ A} → t ⋙ t′ → eval t ≡ eval t′
eval✓ refl⋙                   = refl
eval✓ (trans⋙ p q)            = trans (eval✓ p) (eval✓ q)
eval✓ (sym⋙ p)                = sym (eval✓ p)
eval✓ (congapp⋙ p q)          = cong² _⟦$⟧_ (eval✓ p) (eval✓ q)
eval✓ (congi⋙ p)              = cong I (eval✓ p)
eval✓ (congk⋙ p q)            = cong² K (eval✓ p) (eval✓ q)
eval✓ (congs⋙ p q r)          = cong³ ⟦S⟧ (eval✓ p) (eval✓ q) (eval✓ r)
eval✓ (congpair⋙ {A} {B} p q) = cong² (_⟦,⟧_ {A} {B}) (eval✓ p) (eval✓ q)
eval✓ (congfst⋙ {A} {B} p)    = cong (⟦π₁⟧ {A} {B}) (eval✓ p)
eval✓ (congsnd⋙ {A} {B} p)    = cong (⟦π₂⟧ {A} {B}) (eval✓ p)
eval✓ beta▻ₖ⋙                 = refl
eval✓ beta▻ₛ⋙                 = refl
eval✓ beta∧₁⋙                 = refl
eval✓ beta∧₂⋙                 = refl
eval✓ eta∧⋙                   = refl
eval✓ eta⊤⋙                  = refl

-- The canonical model.

private
  instance
    canon : Model
    canon = record
      { ⊩ᵅ_ = λ P → ∅ ⊢ α P
      }

-- Completeness with respect to all models, or quotation, for closed terms only.

quot₀ : ∀ {A} → ∅ ⊨ A → ∅ ⊢ A
quot₀ t = reify (t ∙)

-- Normalisation by evaluation, for closed terms only.

norm₀ : ∀ {A} → ∅ ⊢ A → ∅ ⊢ A
norm₀ = quot₀ ∘ eval

-- TODO: Correctness of normalisation with respect to conversion.


-- An implementation of terminating parsers due to Conor McBride and
-- James McKinna, as presented in the talk Seeing and Doing at the
-- Workshop on Termination and Type Theory, Hindås, Sweden, 2002.

{-# OPTIONS --type-in-type #-}

module SeeingAndDoing where

open import Data.Unit
open import Data.Bool
open import Data.List
open import Data.Maybe as Maybe
open import Data.String renaming (_==_ to _=S=_)
open import Category.Monad
open RawMonadPlus Maybe.monadPlus
open import Data.Function using (_∘_; const)
open import Relation.Binary.PropositionalEquality

data Token : Set where
  V     : (s : String) → Token
  IF    : Token
  THEN  : Token
  ELSE  : Token
  TRUE  : Token
  FALSE : Token

_==_ : Token → Token → Bool
V s₁  == V s₂  = s₁ =S= s₂
IF    == IF    = true
THEN  == THEN  = true
ELSE  == ELSE  = true
TRUE  == TRUE  = true
FALSE == FALSE = true
_     == _     = false

data Pos : Set where
  L : Pos
  R : Pos

Memo : (Pos → Set) → Pos → Set
Memo P L = ⊤
Memo P R = P L

PosOrder : ∀ j P → (∀ i → Memo P i → P i) → P j
PosOrder L P p = p L _
PosOrder R P p = p R (p L _)

module Combinators (Rec : Set) where

  infixl 25 _∙_ _!_
  infixl 15 _+_

  data _⟨_⟩_ : Pos → Set → Pos → Set where
    rec  : R ⟨ Rec ⟩ R
    η    : ∀ {i X} (x : Maybe X) → i ⟨ X ⟩ i
    tok  : ∀ {i} (u : Token) → i ⟨ ⊤ ⟩ R
    vart : ∀ {i} → i ⟨ String ⟩ R
    _+_  : ∀ {i j X} (x y : i ⟨ X ⟩ j) → i ⟨ X ⟩ j
    _∙_  : ∀ {j i k S T}
           (f : i ⟨ (S → T) ⟩ j) (s : j ⟨ S ⟩ k) → i ⟨ T ⟩ k

  for : ∀ {i X} → X → i ⟨ X ⟩ i
  for = η ∘ just

  fail : ∀ {i X} → i ⟨ X ⟩ i
  fail = η nothing

  _!_ : ∀ {i j k S T} → i ⟨ S ⟩ j → j ⟨ T ⟩ k → i ⟨ S ⟩ k
  s ! t = for const ∙ s ∙ t

Grammar : Set → Set
Grammar Rec = L ⟨ Rec ⟩ R
  where open Combinators Rec

module Parser {Rec : Set} (grammar : Grammar Rec) where

  open Combinators Rec

  ⇓ : ∀ {i j X} → i ⟨ X ⟩ j → Maybe X
  ⇓ (η x)   = x
  ⇓ (x + y) = ⇓ x ∣ ⇓ y
  ⇓ (f ∙ s) = ⇓ f ⊛ ⇓ s
  ⇓ _       = nothing

  eat : ∀ {i X} → i ⟨ X ⟩ R → Token → R ⟨ X ⟩ R
  eat {i} x t = PosOrder i P eat′ x t
    where
    P = λ i → ∀ {X} → i ⟨ X ⟩ R → Token → R ⟨ X ⟩ R

    eat′ : ∀ i → Memo P i → P i
    eat′ _ _    (tok u)       t     with u == t
    eat′ _ _    (tok u)       t     | true  = for _
    eat′ _ _    (tok u)       t     | false = fail
    eat′ _ _    vart          (V x) = for x
    eat′ _ eat  (x + y)       t     = eat′ _ eat x t
                                    + eat′ _ eat y t
    eat′ L _    (_∙_ {L} f s) t     = η (⇓ f) ∙ eat′ L _ s t
    eat′ L _    (_∙_ {R} f s) t     = eat′ L _ f t ∙ s
    eat′ R eatL (_∙_ {R} f s) t     = η (⇓ f) ∙ eat′ R eatL s t
                                    + eat′ R eatL f t ∙ s
    eat′ R eatL rec           t     = eatL grammar t
    eat′ _ _    _             _     = fail

  parse : List Token → Maybe Rec
  parse is = ⇓ (foldr (λ t x → eat x t) rec (reverse is))

data CE : Set where
  var : (s : String) → CE
  val : (b : Bool) → CE
  if  : (i t e : CE) → CE

grammar : Grammar CE
grammar = for var ∙ vart
        + for (val true)  ! tok TRUE
        + for (val false) ! tok FALSE
        + for (λ i → if i (val true) (val true)) ! tok IF ∙ rec
        + for if ! tok IF ∙ rec ! tok THEN ∙ rec
                                ! tok ELSE ∙ rec
  where open Combinators CE

test₁ : let open Parser grammar in
        parse (IF ∷ V "x" ∷ THEN ∷ TRUE ∷ ELSE ∷ FALSE ∷ []) ≡
        just (if (var "x") (val true) (val false))
test₁ = refl

-- Takes ages to type check:

-- test₂ : let open Parser grammar in
--         parse (IF ∷ V "x" ∷
--                     THEN ∷ IF ∷ V "y" ∷ THEN ∷ V "z" ∷ ELSE ∷ V "x" ∷
--                     ELSE ∷ FALSE ∷ []) ≡
--         just (if (var "x") (if (var "y") (var "z") (var "x"))
--                            (val false))
-- test₂ = refl