------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

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

open import Prelude.Size

open import Labelled-transition-system

module Similarity.Equational-reasoning-instances
         {ℓ} {lts : LTS ℓ} {i : Size} where

open import Prelude

open import Bisimilarity lts
open import Equational-reasoning
open import Similarity lts

instance

  reflexive≤ : Reflexive [ i ]_≤_
  reflexive≤ = is-reflexive reflexive-≤

  reflexive≤′ : Reflexive [ i ]_≤′_
  reflexive≤′ = is-reflexive reflexive-≤′

  convert≤≤ : Convertible [ i ]_≤_ [ i ]_≤_
  convert≤≤ = is-convertible id

  convert≤′≤ : Convertible _≤′_ [ i ]_≤_
  convert≤′≤ = is-convertible λ p≤′q → force p≤′q

  convert≤≤′ : Convertible [ i ]_≤_ [ i ]_≤′_
  convert≤≤′ = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ≤ q → [ i ] p ≤′ q
    force (lemma p≤q) = p≤q

  convert≤′≤′ : Convertible [ i ]_≤′_ [ i ]_≤′_
  convert≤′≤′ = is-convertible id

  convert∼≤ : Convertible [ i ]_∼_ [ i ]_≤_
  convert∼≤ = is-convertible ∼⇒≤

  convert∼′≤ : Convertible _∼′_ [ i ]_≤_
  convert∼′≤ = is-convertible (convert ∘ ∼⇒≤′)

  convert∼≤′ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≤′_
  convert∼≤′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ∼ q → [ i ] p ≤′ q
    force (lemma p∼q) = ∼⇒≤ p∼q

  convert∼′≤′ : ∀ {i} → Convertible [ i ]_∼′_ [ i ]_≤′_
  convert∼′≤′ = is-convertible ∼⇒≤′

  trans≤≤ : Transitive [ i ]_≤_ [ i ]_≤_
  trans≤≤ = is-transitive transitive-≤

  trans≤′≤ : Transitive _≤′_ [ i ]_≤_
  trans≤′≤ = is-transitive λ p≤′q → transitive (force p≤′q)

  trans≤′≤′ : Transitive [ i ]_≤′_ [ i ]_≤′_
  trans≤′≤′ = is-transitive transitive-≤′

  trans≤≤′ : Transitive [ i ]_≤_ [ i ]_≤′_
  trans≤≤′ = is-transitive lemma
    where
    lemma : ∀ {p q r} → [ i ] p ≤ q → [ i ] q ≤′ r → [ i ] p ≤′ r
    force (lemma p≤q q≤′r) = transitive-≤ p≤q (force q≤′r)


module F2 where

open import Data.Empty
open import Data.Unit
open import Data.Sum hiding (map; [_,_])
open import Data.Product hiding (map; ,_)
open import Function using (flip)
open import Relation.Binary.Core
  using (IsEquivalence; Reflexive; Symmetric; Transitive)
open import Relation.Binary

open import Groupoid

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

---------------------------------------------------------------------------
-- Paths

-- these are individual paths so to speak
-- should we represent a path like swap+ as a family explicitly:
-- swap+ : (x : A) -> x ⇛ swapF x
-- I guess we can: swap+ : (x : A) -> case x of inj1 -> swap1 x else swap2 x
{--
Use pointed types instead of singletons
If A={x0,x1,x2}, 1/A has three values:
(x0<-x0, x0<-x1, x0<-x2)
(x1<-x0, x1<-x1, x1<-x2)
(x2<-x0, x2<-x1, x2<-x2)
It is a fake choice between x0, x1, and x2 (some negative information). You base
yourself at x0 for example and enforce that any other value can be mapped to x0.
So think of a value of type 1/A as an uncertainty about which value of A we
have. It could be x0, x1, or x2 but at the end it makes no difference. There is
no choice.

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

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

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

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

Explain connection to negative information.

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

--}

data _⇛_ : {A B : Set} → (x : A) → (y : B) → Set₁ where
  -- +
  unite₊⇛    : {A : Set} {x : A} → _⇛_ {⊥ ⊎ A} {A} (inj₂ x) x
  uniti₊⇛    : {A : Set} {x : A} → _⇛_ {A} {⊥ ⊎ A} x (inj₂ x)
  swap₁₊⇛    : {A B : Set} {x : A} → _⇛_ {A ⊎ B} {B ⊎ A} (inj₁ x) (inj₂ x)
  swap₂₊⇛    : {A B : Set} {y : B} → _⇛_ {A ⊎ B} {B ⊎ A} (inj₂ y) (inj₁ y)
  assocl₁₊⇛  : {A B C : Set} {x : A} →
               _⇛_ {A ⊎ (B ⊎ C)} {(A ⊎ B) ⊎ C} (inj₁ x) (inj₁ (inj₁ x))
  assocl₂₁₊⇛ : {A B C : Set} {y : B} →
               _⇛_ {A ⊎ (B ⊎ C)} {(A ⊎ B) ⊎ C} (inj₂ (inj₁ y)) (inj₁ (inj₂ y))
  assocl₂₂₊⇛ : {A B C : Set} {z : C} →
               _⇛_ {A ⊎ (B ⊎ C)} {(A ⊎ B) ⊎ C} (inj₂ (inj₂ z)) (inj₂ z)
  assocr₁₁₊⇛ : {A B C : Set} {x : A} →
               _⇛_ {(A ⊎ B) ⊎ C} {A ⊎ (B ⊎ C)} (inj₁ (inj₁ x)) (inj₁ x)
  assocr₁₂₊⇛ : {A B C : Set} {y : B} →
               _⇛_ {(A ⊎ B) ⊎ C} {A ⊎ (B ⊎ C)} (inj₁ (inj₂ y)) (inj₂ (inj₁ y))
  assocr₂₊⇛  : {A B C : Set} {z : C} →
               _⇛_ {(A ⊎ B) ⊎ C} {A ⊎ (B ⊎ C)} (inj₂ z) (inj₂ (inj₂ z))
  -- *
  unite⋆⇛    : {A : Set} {x : A} → _⇛_ {⊤ × A} {A} (tt , x) x
  uniti⋆⇛    : {A : Set} {x : A} → _⇛_ {A} {⊤ × A} x (tt , x)
  swap⋆⇛     : {A B : Set} {x : A} {y : B} → _⇛_ {A × B} {B × A} (x , y) (y , x)
  assocl⋆⇛   : {A B C : Set} {x : A} {y : B} {z : C} →
               _⇛_ {A × (B × C)} {(A × B) × C} (x , (y , z)) ((x , y) , z)
  assocr⋆⇛   : {A B C : Set} {x : A} {y : B} {z : C} →
               _⇛_ {(A × B) × C} {A × (B × C)} ((x , y) , z) (x , (y , z))
  -- distributivity
  dist₁⇛     : {A B C : Set} {x : A} {z : C} →
               _⇛_ {(A ⊎ B) × C} {(A × C) ⊎ (B × C)} (inj₁ x , z) (inj₁ (x , z))
  dist₂⇛     : {A B C : Set} {y : B} {z : C} →
               _⇛_ {(A ⊎ B) × C} {(A × C) ⊎ (B × C)} (inj₂ y , z) (inj₂ (y , z))
  factor₁⇛   : {A B C : Set} {x : A} {z : C} →
               _⇛_ {(A × C) ⊎ (B × C)} {(A ⊎ B) × C} (inj₁ (x , z)) (inj₁ x , z)
  factor₂⇛   : {A B C : Set} {y : B} {z : C} →
               _⇛_ {(A × C) ⊎ (B × C)} {(A ⊎ B) × C}
                   (inj₂ (y , z)) (inj₂ y , z)
  dist0⇛     : {A : Set} {• : ⊥} {x :  A} → _⇛_ {⊥ × A} {⊥} (• , x) •
  factor0⇛   : {A : Set} {• : ⊥} {x : A} → _⇛_ {⊥} {⊥ × A} • (• , x)
  -- congruence
  id⇛        : {A : Set} → (x : A) → x ⇛ x
  sym⇛       : {A B : Set} {x : A} {y : B} → x ⇛ y → y ⇛ x
  trans⇛     : {A B C : Set} {x : A} {y : B} {z : C} → x ⇛ y → y ⇛ z → x ⇛ z
  plus₁⇛     : {A B C D : Set} {x : A} {z : C} →
               x ⇛ z → _⇛_ {A ⊎ B} {C ⊎ D} (inj₁ x) (inj₁ z)
  plus₂⇛     : {A B C D : Set} {y : B} {w : D} →
               y ⇛ w → _⇛_ {A ⊎ B} {C ⊎ D} (inj₂ y) (inj₂ w)
  times⇛     : {A B C D : Set} {x : A} {y : B} {z : C} {w : D} →
               x ⇛ z → y ⇛ w → _⇛_ {A × B} {C × D} (x , y) (z , w)

-- permute
-- for any given type, we should be able to generate permutations mapping any
-- point to any other type

-- Introduce equational reasoning syntax to simplify proofs

_≡⟨_⟩_ : {A B C : Set} (x : A) {y : B} {z : C} → (x ⇛ y) → (y ⇛ z) → (x ⇛ z)
_ ≡⟨ p ⟩ q = trans⇛ p q

bydef : {A : Set} {x : A} → (x ⇛ x)
bydef {A} {x} = id⇛ x

_∎ : {A : Set} (x : A) → x ⇛ x
_∎ x = id⇛ x

data Singleton {A : Set} : A → Set where
  singleton : (x : A) → Singleton x

mutual

  ap : {A B : Set} {x : A} {y : B} → x ⇛ y → Singleton x → Singleton y
  ap {.(⊥ ⊎ A)} {A} {.(inj₂ x)} {x} unite₊⇛ (singleton .(inj₂ x)) =
    singleton x
  ap uniti₊⇛ (singleton x) = singleton (inj₂ x)
  ap (swap₁₊⇛ {A} {B} {x}) (singleton .(inj₁ x)) = singleton (inj₂ x)
  ap (swap₂₊⇛ {A} {B} {y}) (singleton .(inj₂ y)) = singleton (inj₁ y)
  ap (assocl₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ x)) =
    singleton (inj₁ (inj₁ x))
  ap (assocl₂₁₊⇛ {A} {B} {C} {y}) (singleton .(inj₂ (inj₁ y))) =
    singleton (inj₁ (inj₂ y))
  ap (assocl₂₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ (inj₂ z))) =
    singleton (inj₂ z)
  ap (assocr₁₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ (inj₁ x))) =
    singleton (inj₁ x)
  ap (assocr₁₂₊⇛ {A} {B} {C} {y}) (singleton .(inj₁ (inj₂ y))) =
    singleton (inj₂ (inj₁ y))
  ap (assocr₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ z)) =
    singleton (inj₂ (inj₂ z))
  ap {.(⊤ × A)} {A} {.(tt , x)} {x} unite⋆⇛ (singleton .(tt , x)) =
    singleton x
  ap uniti⋆⇛ (singleton x) = singleton (tt , x)
  ap (swap⋆⇛ {A} {B} {x} {y}) (singleton .(x , y)) = singleton (y , x)
  ap (assocl⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .(x , (y , z))) =
    singleton ((x , y) , z)
  ap (assocr⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .((x , y) , z)) =
    singleton (x , (y , z))
  ap (dist₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ x , z)) =
    singleton (inj₁ (x , z))
  ap (dist₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ y , z)) =
    singleton (inj₂ (y , z))
  ap (factor₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ (x , z))) =
    singleton (inj₁ x , z)
  ap (factor₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ (y , z))) =
    singleton (inj₂ y , z)
  ap {.(⊥ × A)} {.⊥} {.(• , x)} {•} (dist0⇛ {A} {.•} {x}) (singleton .(• , x)) =
    singleton •
  ap factor0⇛ (singleton ())
  ap (id⇛ .x) (singleton x) = singleton x
  ap (sym⇛ c) (singleton x) = apI c (singleton x)
  ap (trans⇛ c₁ c₂) (singleton x) = ap c₂ (ap c₁ (singleton x))
  ap (plus₁⇛ {A} {B} {C} {D} {x} {z} c) (singleton .(inj₁ x))
    with ap c (singleton x)
  ... | singleton .z = singleton (inj₁ z)
  ap (plus₂⇛ {A} {B} {C} {D} {y} {w} c) (singleton .(inj₂ y))
    with ap c (singleton y)
  ... | singleton .w = singleton (inj₂ w)
  ap (times⇛ {A} {B} {C} {D} {x} {y} {z} {w} c₁ c₂) (singleton .(x , y))
    with ap c₁ (singleton x) | ap c₂ (singleton y)
  ... | singleton .z | singleton .w = singleton (z , w)

  apI : {A B : Set} {x : A} {y : B} → x ⇛ y → Singleton y → Singleton x
  apI unite₊⇛ (singleton x) = singleton (inj₂ x)
  apI {A} {.(⊥ ⊎ A)} {x} uniti₊⇛ (singleton .(inj₂ x)) = singleton x
  apI (swap₁₊⇛ {A} {B} {x}) (singleton .(inj₂ x)) = singleton (inj₁ x)
  apI (swap₂₊⇛ {A} {B} {y}) (singleton .(inj₁ y)) = singleton (inj₂ y)
  apI (assocl₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ (inj₁ x))) =
    singleton (inj₁ x)
  apI (assocl₂₁₊⇛ {A} {B} {C} {y}) (singleton .(inj₁ (inj₂ y))) =
    singleton (inj₂ (inj₁ y))
  apI (assocl₂₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ z)) =
    singleton (inj₂ (inj₂ z))
  apI (assocr₁₁₊⇛ {A} {B} {C} {x}) (singleton .(inj₁ x)) =
    singleton (inj₁ (inj₁ x))
  apI (assocr₁₂₊⇛ {A} {B} {C} {y}) (singleton .(inj₂ (inj₁ y))) =
    singleton (inj₁ (inj₂ y))
  apI (assocr₂₊⇛ {A} {B} {C} {z}) (singleton .(inj₂ (inj₂ z))) =
    singleton (inj₂ z)
  apI unite⋆⇛ (singleton x) = singleton (tt , x)
  apI {A} {.(⊤ × A)} {x} uniti⋆⇛ (singleton .(tt , x)) = singleton x
  apI (swap⋆⇛ {A} {B} {x} {y}) (singleton .(y , x)) = singleton (x , y)
  apI (assocl⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .((x , y) , z)) =
    singleton (x , (y , z))
  apI (assocr⋆⇛ {A} {B} {C} {x} {y} {z}) (singleton .(x , (y , z))) =
    singleton ((x , y) , z)
  apI (dist₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ (x , z))) =
    singleton (inj₁ x , z)
  apI (dist₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ (y , z))) =
    singleton (inj₂ y , z)
  apI (factor₁⇛ {A} {B} {C} {x} {z}) (singleton .(inj₁ x , z)) =
    singleton (inj₁ (x , z))
  apI (factor₂⇛ {A} {B} {C} {y} {z}) (singleton .(inj₂ y , z)) =
    singleton (inj₂ (y , z))
  apI dist0⇛ (singleton ())
  apI {.⊥} {.(⊥ × A)} {•} (factor0⇛ {A} {.•} {x}) (singleton .(• , x)) =
    singleton •
  apI (id⇛ .x) (singleton x) = singleton x
  apI (sym⇛ c) (singleton x) = ap c (singleton x)
  apI {A} {B} {x} {y} (trans⇛ c₁ c₂) (singleton .y) =
    apI c₁ (apI c₂ (singleton y))
  apI (plus₁⇛ {A} {B} {C} {D} {x} {z} c) (singleton .(inj₁ z))
    with apI c (singleton z)
  ... | singleton .x = singleton (inj₁ x)
  apI (plus₂⇛ {A} {B} {C} {D} {y} {w} c) (singleton .(inj₂ w))
    with apI c (singleton w)
  ... | singleton .y = singleton (inj₂ y)
  apI (times⇛ {A} {B} {C} {D} {x} {y} {z} {w} c₁ c₂) (singleton .(z , w))
    with apI c₁ (singleton z) | apI c₂ (singleton w)
  ... | singleton .x | singleton .y = singleton (x , y)

-- Path induction

pathInd :
  (C : (A : Set) → (B : Set) → (x : A) → (y : B) → x ⇛ y → Set) →
  (c : (A : Set) → (x : A) → C A A x x (id⇛ x)) →
  -- add more cases, one for each constructor
  (A : Set) → (B : Set) → (x : A) → (y : B) → (p : x ⇛ y) → C A B x y p
pathInd C c .(⊥ ⊎ B) B .(inj₂ y) y unite₊⇛ = {!!}
pathInd C c A .(⊥ ⊎ A) x .(inj₂ x) uniti₊⇛ = {!!}
pathInd C c .(A ⊎ B) .(B ⊎ A) .(inj₁ x) .(inj₂ x) (swap₁₊⇛ {A} {B} {x}) = {!!}
pathInd C c .(A ⊎ B) .(B ⊎ A) .(inj₂ y) .(inj₁ y) (swap₂₊⇛ {A} {B} {y}) = {!!}
pathInd C c .(A ⊎ B ⊎ C₁) .((A ⊎ B) ⊎ C₁) .(inj₁ x) .(inj₁ (inj₁ x))
  (assocl₁₊⇛ {A} {B} {C₁} {x}) = {!!}
pathInd C c .(A ⊎ B ⊎ C₁) .((A ⊎ B) ⊎ C₁) .(inj₂ (inj₁ y)) .(inj₁ (inj₂ y))
  (assocl₂₁₊⇛ {A} {B} {C₁} {y}) = {!!}
pathInd C c .(A ⊎ B ⊎ C₁) .((A ⊎ B) ⊎ C₁) .(inj₂ (inj₂ z)) .(inj₂ z)
  (assocl₂₂₊⇛ {A} {B} {C₁} {z}) = {!!}
pathInd C c .((A ⊎ B) ⊎ C₁) .(A ⊎ B ⊎ C₁) .(inj₁ (inj₁ x)) .(inj₁ x)
  (assocr₁₁₊⇛ {A} {B} {C₁} {x}) = {!!}
pathInd C c .((A ⊎ B) ⊎ C₁) .(A ⊎ B ⊎ C₁) .(inj₁ (inj₂ y)) .(inj₂ (inj₁ y))
  (assocr₁₂₊⇛ {A} {B} {C₁} {y}) = {!!}
pathInd C c .((A ⊎ B) ⊎ C₁) .(A ⊎ B ⊎ C₁) .(inj₂ z) .(inj₂ (inj₂ z))
  (assocr₂₊⇛ {A} {B} {C₁} {z}) = {!!}
pathInd C c .(Σ ⊤ (λ x₁ → B)) B .(tt , y) y unite⋆⇛ = {!!}
pathInd C c A .(Σ ⊤ (λ x₁ → A)) x .(tt , x) uniti⋆⇛ = {!!}
pathInd C c .(Σ A (λ x₁ → B)) .(Σ B (λ x₁ → A)) .(x , y) .(y , x)
  (swap⋆⇛ {A} {B} {x} {y}) = {!!}
pathInd C c .(Σ A (λ x₁ → Σ B (λ x₂ → C₁))) .(Σ (Σ A (λ x₁ → B)) (λ x₁ → C₁))
  .(x , y , z) .((x , y) , z) (assocl⋆⇛ {A} {B} {C₁} {x} {y} {z}) = {!!}
pathInd C c .(Σ (Σ A (λ x₁ → B)) (λ x₁ → C₁)) .(Σ A (λ x₁ → Σ B (λ x₂ → C₁)))
  .((x , y) , z) .(x , y , z) (assocr⋆⇛ {A} {B} {C₁} {x} {y} {z}) = {!!}
pathInd C c .(Σ (A ⊎ B) (λ x₁ → C₁)) .(Σ A (λ x₁ → C₁) ⊎ Σ B (λ x₁ → C₁))
  .(inj₁ x , z) .(inj₁ (x , z)) (dist₁⇛ {A} {B} {C₁} {x} {z}) = {!!}
pathInd C c .(Σ (A ⊎ B) (λ x₁ → C₁)) .(Σ A (λ x₁ → C₁) ⊎ Σ B (λ x₁ → C₁))
  .(inj₂ y , z) .(inj₂ (y , z)) (dist₂⇛ {A} {B} {C₁} {y} {z}) = {!!}
pathInd C c .(Σ A (λ x₁ → C₁) ⊎ Σ B (λ x₁ → C₁)) .(Σ (A ⊎ B) (λ x₁ → C₁))
  .(inj₁ (x , z)) .(inj₁ x , z) (factor₁⇛ {A} {B} {C₁} {x} {z}) = {!!}
pathInd C c .(Σ A (λ x₁ → C₁) ⊎ Σ B (λ x₁ → C₁)) .(Σ (A ⊎ B) (λ x₁ → C₁))
  .(inj₂ (y , z)) .(inj₂ y , z) (factor₂⇛ {A} {B} {C₁} {y} {z}) = {!!}
pathInd C c .(Σ ⊥ (λ x₁ → A)) .⊥ .(y , x) y (dist0⇛ {A} {.y} {x}) = {!!}
pathInd C c .⊥ .(Σ ⊥ (λ x₁ → A)) x .(x , x₁) (factor0⇛ {A} {.x} {x₁}) = {!!}
pathInd C c A .A x .x (id⇛ .x) = c A x
pathInd C c A B x y (sym⇛ p) = {!!}
pathInd C c A B x y (trans⇛ p p₁) = {!!}
pathInd C c .(A ⊎ B) .(C₁ ⊎ D) .(inj₁ x) .(inj₁ z)
  (plus₁⇛ {A} {B} {C₁} {D} {x} {z} p) = {!!}
pathInd C c .(A ⊎ B) .(C₁ ⊎ D) .(inj₂ y) .(inj₂ w)
  (plus₂⇛ {A} {B} {C₁} {D} {y} {w} p) = {!!}
pathInd C c .(Σ A (λ x₁ → B)) .(Σ C₁ (λ x₁ → D)) .(x , y) .(z , w)
  (times⇛ {A} {B} {C₁} {D} {x} {y} {z} {w} p p₁) = {!!}

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

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

η : {A : Set} {base : A} → ⊤ → Recip base × Singleton base
η {A} {base} tt = (λ x → ? , singleton base)

{--
If A={x0,x1,x2}, 1/A has three values:
(x0<-x0, x0<-x1, x0<-x2)

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

ε : {A : Set} {x : A} → Recip x × Singleton x → ⊤
ε {A} {x} (rx , singleton .x) = tt -- makes no sense

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

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

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

data _⇛_ : {A B : Set} → (x : A) → (y : B) → Set₁ where
------------------------------------------------------------------------------
-- pi types with exactly one level of reciprocals
-- interpretation of B1 types as 1-groupoids

data B0 : Set where
  ZERO : B0
  ONE : B0
  PLUS0 : B0 → B0 → B0
  TIMES0 : B0 → B0 → B0

⟦_⟧₀ : B0 → Set
⟦ ZERO ⟧₀ = ⊥
⟦ ONE ⟧₀ = ⊤
⟦ PLUS0 b₁ b₂ ⟧₀ = ⟦ b₁ ⟧₀ ⊎ ⟦ b₂ ⟧₀
⟦ TIMES0 b₁ b₂ ⟧₀ = ⟦ b₁ ⟧₀ × ⟦ b₂ ⟧₀

data B1 : Set where
  LIFT0  : B0 → B1
  PLUS1  : B1 → B1 → B1
  TIMES1 : B1 → B1 → B1
  RECIP1 : B0 → B1

open 1Groupoid

⟦_⟧₁ : B1 → 1Groupoid
⟦ LIFT0 b0 ⟧₁ = discrete ⟦ b0 ⟧₀
⟦ PLUS1 b₁ b₂ ⟧₁ = ⟦ b₁ ⟧₁ ⊎G ⟦ b₂ ⟧₁
⟦ TIMES1 b₁ b₂ ⟧₁ =  ⟦ b₁ ⟧₁ ×G ⟦ b₂ ⟧₁
⟦ RECIP1 b0 ⟧₁ = {!!} -- allPaths (ı₀ b0)

ı₁ : B1 → Set
ı₁ b = set ⟦ b ⟧₁

test10 = ⟦ LIFT0 ONE ⟧₁
test11 = ⟦ LIFT0 (PLUS0 ONE ONE) ⟧₁
test12 = ⟦ RECIP1 (PLUS0 ONE ONE) ⟧₁

-- interpret isos as functors

data _⟷₁_ : B1 → B1 → Set where
  -- +
  swap₊   : { b₁ b₂ : B1 } → PLUS1 b₁ b₂ ⟷₁ PLUS1 b₂ b₁
  assocl₊ : { b₁ b₂ b₃ : B1 } → PLUS b₁ (PLUS b₂ b₃) ⟷₁ PLUS (PLUS b₁ b₂) b₃
  assocr₊ : { b₁ b₂ b₃ : B1 } → PLUS (PLUS b₁ b₂) b₃ ⟷₁ PLUS b₁ (PLUS b₂ b₃)
  -- *
  unite⋆  : { b : B1 } → TIMES1 (LIFT0 ONE) b ⟷₁ b
  uniti⋆  : { b : B1 } → b ⟷₁ TIMES1 (LIFT0 ONE) b
  swap⋆   : { b₁ b₂ : B } → TIMES b₁ b₂ ⟷₁ TIMES b₂ b₁
  assocl⋆ : { b₁ b₂ b₃ : B } → TIMES b₁ (TIMES b₂ b₃) ⟷₁ TIMES (TIMES b₁ b₂) b₃
  assocr⋆ : { b₁ b₂ b₃ : B } → TIMES (TIMES b₁ b₂) b₃ ⟷₁ TIMES b₁ (TIMES b₂ b₃)
  -- * distributes over +
  dist    : { b₁ b₂ b₃ : B } →
            TIMES (PLUS b₁ b₂) b₃ ⟷₁ PLUS (TIMES b₁ b₃) (TIMES b₂ b₃)
  factor  : { b₁ b₂ b₃ : B } →
            PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) ⟷₁ TIMES (PLUS b₁ b₂) b₃
  -- congruence
  id⟷₁   : { b : B } → b ⟷₁ b
  sym    : { b₁ b₂ : B } → (b₁ ⟷₁ b₂) → (b₂ ⟷₁ b₁)
  _∘_    : { b₁ b₂ b₃ : B } → (b₁ ⟷₁ b₂) → (b₂ ⟷₁ b₃) → (b₁ ⟷₁ b₃)
  _⊕_    : { b₁ b₂ b₃ b₄ : B } →
           (b₁ ⟷₁ b₃) → (b₂ ⟷₁ b₄) → (PLUS b₁ b₂ ⟷₁ PLUS b₃ b₄)
  _⊗_    : { b₁ b₂ b₃ b₄ : B } →
           (b₁ ⟷₁ b₃) → (b₂ ⟷₁ b₄) → (TIMES b₁ b₂ ⟷₁ TIMES b₃ b₄)
  η⋆ : (b : B0) → LIFT0 ONE ⟷₁ TIMES1 (LIFT0 b) (RECIP1 b)
  ε⋆ : (b : B0) → TIMES1 (LIFT0 b) (RECIP1 b) ⟷₁ LIFT0 ONE

record 1-functor (A B : 1Groupoid) : Set where
  constructor 1F
  private module A = 1Groupoid A
  private module B = 1Groupoid B

  field
    F₀ : set A → set B
    F₁ : ∀ {X Y : set A} → A [ X , Y ] → B [ F₀ X , F₀ Y ]
    -- identity : ∀ {X} → B._≈_ (F₁ (A.id {X})) B.id
    -- F-resp-≈ : ∀ {X Y} {F G : A [ X , Y ]} → A._≈_ F G → B._≈_ (F₁ F) (F₁ G)

open 1-functor public

ipath : (b : B1) → ı₁ b → ı₁ b → Set
ipath b x y = Path {ı₁ b} x y

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

intro1⋆ : {b : B1} {x y : ı₁ b} → ipath b x y → ipath (TIMES1 (LIFT0 ONE) b) (tt , x) (tt , y)
intro1⋆ (y ⇛ z) = (tt , y) ⇛ (tt , z)

objη⋆ : (b : B0) → ı₁ (LIFT0 ONE) → ı₁ (TIMES1 (LIFT0 b) (RECIP1 b))
objη⋆ b tt = point b , point b

objε⋆ : (b : B0) → ı₁ (TIMES1 (LIFT0 b) (RECIP1 b)) → ı₁ (LIFT0 ONE)
objε⋆ b (x , y) = tt

elim1∣₁ : (b : B1) → ı₁ (TIMES1 (LIFT0 ONE) b) → ı₁ b
elim1∣₁ b (tt , x) = x

intro1∣₁ : (b : B1) → ı₁ b → ı₁ (TIMES1 (LIFT0 ONE) b)
intro1∣₁ b x = (tt , x)

swapF : {b₁ b₂ : B1} →
      let G = ⟦ b₁ ⟧₁ ⊎G ⟦ b₂ ⟧₁
          G' = ⟦ b₂ ⟧₁ ⊎G ⟦ b₁ ⟧₁ in
      {X Y : set G} → G [ X , Y ] → G' [ swap⊎ X , swap⊎ Y ]
swapF {X = inj₁ _} {inj₁ _} f = f
swapF {X = inj₁ _} {inj₂ _} ()
swapF {X = inj₂ _} {inj₁ _} ()
swapF {X = inj₂ _} {inj₂ _} f = f

eta : (b : B0) → List (ipath (LIFT0 ONE)) → List (ipath (TIMES1 (LIFT0 b) (RECIP1 b)))
-- note how the input list is not used at all!
eta b _ = prod (λ a a' → _↝_ (a , tt) (a' , tt)) (elems0 b) (elems0 b)

eps : (b : B0) → ipath (TIMES1 (LIFT0 b) (RECIP1 b)) → ipath (LIFT0 ONE)
eps b0 (a ⇛ b) = tt ⇛ tt

Funite⋆ : {b₁ : B1} → ∀ {X Y : set (discrete (ı₀ ONE) ×G ⟦ b₁ ⟧₁)} →  DPath (proj₁ X) (proj₁ Y) ×  (_↝_ ⟦ b₁ ⟧₁) (proj₂ X) (proj₂ Y) →  _↝_ ⟦ b₁ ⟧₁ (proj₂ X) (proj₂ Y)
Funite⋆ {b₁} {tt , _} {tt , _} (reflD , y) = y

Funiti⋆ : {b₁ : B1} → ∀ {X Y : set (discrete (ı₀ ONE) ×G ⟦ b₁ ⟧₁)} →  _↝_ ⟦ b₁ ⟧₁ (proj₂ X) (proj₂ Y) → DPath (proj₁ X) (proj₁ Y) ×  (_↝_ ⟦ b₁ ⟧₁) (proj₂ X) (proj₂ Y)
Funiti⋆ y = reflD , y

mutual
  eval : {b₁ b₂ : B1} → (b₁ ⟷₁ b₂) → 1-functor ⟦ b₁ ⟧₁ ⟦ b₂ ⟧₁
  eval (swap₊ {b₁} {b₂}) = 1F swap⊎ (λ {X Y} → swapF {b₁} {b₂} {X} {Y})
  eval (unite⋆ {b}) = 1F (elim1∣₁ b) (Funite⋆ {b})
  eval (uniti⋆ {b}) = 1F (intro1∣₁ b) (Funiti⋆ {b})
--  eval (η⋆ b) = F₁ (objη⋆ b) (eta b )
--  eval (ε⋆ b) = F₁ (objε⋆ b) (map (eps b))

  evalB : {b₁ b₂ : B1} → (b₁ ⟷₁ b₂) → 1-functor ⟦ b₂ ⟧₁ ⟦ b₁ ⟧₁
  evalB (swap₊ {b₁} {b₂}) = 1F swap⊎ ((λ {X Y} → swapF {b₂} {b₁} {X} {Y}))
  evalB (unite⋆ {b}) = 1F (intro1∣₁ b) (Funiti⋆ {b})
  evalB (uniti⋆ {b}) = 1F (elim1∣₁ b) (Funite⋆ {b})
--  evalB (η⋆ b) = F₁ (objε⋆ b) (map (eps b))
--  evalB (ε⋆ b) = F₁ (objη⋆ b) (eta b)

eval assocl₊ = ? -- : { b₁ b₂ b₃ : B } → PLUS b₁ (PLUS b₂ b₃) ⟷₁ PLUS (PLUS b₁ b₂) b₃
eval assocr₊ = ? -- : { b₁ b₂ b₃ : B } → PLUS (PLUS b₁ b₂) b₃ ⟷₁ PLUS b₁ (PLUS b₂ b₃)
eval uniti⋆ = ? -- : { b : B } → b ⟷₁ TIMES ONE b
eval swap⋆ = ? --  : { b₁ b₂ : B } → TIMES b₁ b₂ ⟷₁ TIMES b₂ b₁
eval assocl⋆ = ? -- : { b₁ b₂ b₃ : B } → TIMES b₁ (TIMES b₂ b₃) ⟷₁ TIMES (TIMES b₁ b₂) b₃
eval assocr⋆ = ? -- : { b₁ b₂ b₃ : B } → TIMES (TIMES b₁ b₂) b₃ ⟷₁ TIMES b₁ (TIMES b₂ b₃)
eval dist = ? -- : { b₁ b₂ b₃ : B } → TIMES (PLUS b₁ b₂) b₃ ⟷₁ PLUS (TIMES b₁ b₃) (TIMES b₂ b₃)
eval factor = ? -- : { b₁ b₂ b₃ : B } → PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) ⟷₁ TIMES (PLUS b₁ b₂) b₃
eval id⟷₁ = ? --  : { b : B } → b ⟷₁ b
eval (sym c) = ? -- : { b₁ b₂ : B } → (b₁ ⟷₁ b₂) → (b₂ ⟷₁ b₁)
eval (c₁ ∘ c₂) = ? -- : { b₁ b₂ b₃ : B } → (b₁ ⟷₁ b₂) → (b₂ ⟷₁ b₃) → (b₁ ⟷₁ b₃)
eval (c₁ ⊕ c₂) = ? -- : { b₁ b₂ b₃ b₄ : B } → (b₁ ⟷₁ b₃) → (b₂ ⟷₁ b₄) → (PLUS b₁ b₂ ⟷₁ PLUS b₃ b₄)
eval (c₁ ⊗ c₂) = ? -- : { b₁ b₂ b₃ b₄ : B } → (b₁ ⟷₁ b₃) → (b₂ ⟷₁ b₄) → (TIMES b₁ b₂ ⟷₁ TIMES b₃ b₄)

-- lid⇛ : {A B : Set} {x : A} {y : B} → (trans⇛ (id⇛ x) (x ⇛ y)) ⇛ (x ⇛ y)
-- lid⇛ {A} {B} {x} {y} =
--  pathInd ?

ap : {A B : Set} → (f : A → B) → {a a' : A} → Path a a' → Path (f a) (f a')
ap f (a ⇛ a') = (f a) ⇛ (f a')

_∙⇛_ : {A : Set} {a b c : A} → Path b c → Path a b → Path a c
(b ⇛ c) ∙⇛ (a ⇛ .b) = a ⇛ c

_⇚ : {A : Set} {a b : A} → Path a b → Path b a
(x ⇛ y) ⇚ = y ⇛ x

lid⇛ : {A : Set} {x y : A} (α : Path x y) → (id⇛ y ∙⇛ α) ≣⇛ α
lid⇛ (x ⇛ y) = refl⇛

rid⇛ : {A : Set} {x y : A} (α : Path x y) → (α ∙⇛ id⇛ x) ≣⇛ α
rid⇛ (x ⇛ y) = refl⇛

assoc⇛ : {A : Set} {w x y z : A} (α : Path y z) (β : Path x y) (δ : Path w x) → ((α ∙⇛ β) ∙⇛ δ) ≣⇛ (α ∙⇛ (β ∙⇛ δ))
assoc⇛ (y ⇛ z) (x ⇛ .y) (w ⇛ .x) = refl⇛

l⇚ : {A : Set}  {x y : A} (α : Path x y) → ((α ⇚) ∙⇛ α) ≣⇛ id⇛ x
l⇚ (x ⇛ y) = refl⇛

r⇚ : {A : Set} {x y : A} (α : Path x y) → (α ∙⇛ (α ⇚)) ≣⇛ id⇛ y
r⇚ (x ⇛ y) = refl⇛

sym⇛ : {A : Set} {x y : A} {α β : Path x y} → α ≣⇛ β → β ≣⇛ α
sym⇛ refl⇛ = refl⇛

trans⇛ : {A : Set} {x y : A} {α β δ : Path x y} → α ≣⇛ β → β ≣⇛ δ → α ≣⇛ δ
trans⇛ refl⇛ refl⇛ = refl⇛

equiv≣⇛ : {A : Set} {x y : A} → IsEquivalence {_} {_} {Path x y} (_≣⇛_)
equiv≣⇛ = record { refl = refl⇛; sym = sym⇛; trans = trans⇛ }

resp≣⇛ : {A : Set} {x y z : A} {f h : Path y z} {g i : Path x y} →
  f ≣⇛ h → g ≣⇛ i → (f ∙⇛ g) ≣⇛ (h ∙⇛ i)
resp≣⇛ refl⇛ refl⇛ = refl⇛

record 0-type : Set₁ where
  constructor G₀
  field
    ∣_∣₀ : Set

open 0-type public

plus : 0-type → 0-type → 0-type
plus t₁ t₂ = G₀ (∣ t₁ ∣₀ ⊎ ∣ t₂ ∣₀)

times : 0-type → 0-type → 0-type
times t₁ t₂ = G₀ (∣ t₁ ∣₀ × ∣ t₂ ∣₀)

⟦_⟧₀ : B0 → 0-type
⟦ ONE ⟧₀ = G₀ ⊤
⟦ PLUS0 b₁ b₂ ⟧₀ = plus ⟦ b₁ ⟧₀ ⟦ b₂ ⟧₀
⟦ TIMES0 b₁ b₂ ⟧₀ = times ⟦ b₁ ⟧₀ ⟦ b₂ ⟧₀

ı₀ : B0 → Set
ı₀ b = ∣ ⟦ b ⟧₀ ∣₀

point : (b : B0) → ı₀ b
point ONE = tt
point (PLUS0 b _) = inj₁ (point b)
point (TIMES0 b₀ b₁) = point b₀ , point b₁

allPaths : Set → 1Groupoid
allPaths a =  record
    { set = a
    ; _↝_ = Path
    ; _≈_ = _≣⇛_
    ; id = λ {x} → id⇛ x
    ; _∘_ = _∙⇛_
    ; _⁻¹ = _⇚
    ; lneutr = lid⇛
    ; rneutr = rid⇛
    ; assoc = assoc⇛
    ; linv = l⇚
    ; rinv = r⇚
    ; equiv = equiv≣⇛
    ;  ∘-resp-≈ = resp≣⇛}

--}


{-# OPTIONS --prop --rewriting #-}

open import Examples.Sorting.Sequential.Comparable

module Examples.Sorting.Sequential.MergeSort.Merge (M : Comparable) where

open Comparable M
open import Examples.Sorting.Sequential.Core M

open import Calf costMonoid
open import Calf.Types.Bool
open import Calf.Types.Nat
open import Calf.Types.List
open import Calf.Types.Eq
open import Calf.Types.Bounded costMonoid

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning)
open import Data.Product using (_×_; _,_; ∃; proj₁; proj₂)
open import Function
open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_)
import Data.Nat.Properties as N

open import Examples.Sorting.Sequential.MergeSort.Split M

merge/clocked : cmp (Π nat λ _ → Π pair λ _ → F (list A))
merge/clocked zero    (l₁     , l₂    ) = ret (l₁ ++ l₂)
merge/clocked (suc k) ([]     , l₂    ) = ret l₂
merge/clocked (suc k) (x ∷ xs , []    ) = ret (x ∷ xs)
merge/clocked (suc k) (x ∷ xs , y ∷ ys) =
  bind (F (list A)) (x ≤ᵇ y) λ b →
    if b
      then (bind (F (list A)) (merge/clocked k (xs , y ∷ ys)) (ret ∘ (x ∷_)))
      else (bind (F (list A)) (merge/clocked k (x ∷ xs , ys)) (ret ∘ (y ∷_)))

merge/clocked/correct : ∀ k l₁ l₂ →
  ◯ (∃ λ l → merge/clocked k (l₁ , l₂) ≡ ret l × (length l₁ + length l₂ Nat.≤ k → Sorted l₁ → Sorted l₂ → SortedOf (l₁ ++ l₂) l))
merge/clocked/correct zero    l₁       l₂       u = l₁ ++ l₂ , refl , λ { h [] [] → refl , [] }
merge/clocked/correct (suc k) []       l₂       u = l₂ , refl , λ { h [] sorted₂ → refl , sorted₂ }
merge/clocked/correct (suc k) (x ∷ xs) []       u = x ∷ xs , refl , λ { h sorted₁ [] → ++-identityʳ (x ∷ xs) , sorted₁ }
merge/clocked/correct (suc k) (x ∷ xs) (y ∷ ys) u with h-cost x y
merge/clocked/correct (suc k) (x ∷ xs) (y ∷ ys) u | ⇓ b withCost q [ _ , h-eq ] rewrite eq/ref h-eq
  with ≤ᵇ-reflects-≤ u (Eq.trans (eq/ref h-eq) (step/ext (F bool) (ret b) q u))
merge/clocked/correct (suc k) (x ∷ xs) (y ∷ ys) u | ⇓ false withCost q [ _ , h-eq ] | ofⁿ ¬p =
  let (l , ≡ , h-sorted) = merge/clocked/correct k (x ∷ xs) ys u in
  y ∷ l , (
    let open ≡-Reasoning in
    begin
      step (F (list A)) q (bind (F (list A)) (merge/clocked k (x ∷ xs , ys)) (ret ∘ (y ∷_)))
    ≡⟨ step/ext (F (list A)) (bind (F (list A)) (merge/clocked k _) _) q u ⟩
      bind (F (list A)) (merge/clocked k (x ∷ xs , ys)) (ret ∘ (y ∷_))
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e _) ≡ ⟩
      ret (y ∷ l)
    ∎
  ) , (
    λ { (s≤s h) (h₁ ∷ sorted₁) (h₂ ∷ sorted₂) →
      let h = Eq.subst (Nat._≤ k) (N.+-suc (length xs) (length ys)) h in
      let (↭ , sorted) = h-sorted h (h₁ ∷ sorted₁) sorted₂ in
      (
        let open PermutationReasoning in
        begin
          (x ∷ xs ++ y ∷ ys)
        ↭⟨ ++-comm-↭ (x ∷ xs) (y ∷ ys) ⟩
          (y ∷ ys ++ x ∷ xs)
        ≡⟨⟩
          y ∷ (ys ++ x ∷ xs)
        <⟨ ++-comm-↭ ys (x ∷ xs) ⟩
          y ∷ (x ∷ xs ++ ys)
        <⟨ ↭ ⟩
          y ∷ l
        ∎
      ) , (
        let p = ≰⇒≥ ¬p in
        All-resp-↭ (↭) (++⁺-All (p ∷ ≤-≤* p h₁) h₂) ∷ sorted
      )
    }
  )
merge/clocked/correct (suc k) (x ∷ xs) (y ∷ ys) u | ⇓ true withCost q [ _ , h-eq ] | ofʸ p =
  let (l , ≡ , h-sorted) = merge/clocked/correct k xs (y ∷ ys) u in
  x ∷ l , (
    let open ≡-Reasoning in
    begin
      step (F (list A)) q (bind (F (list A)) (merge/clocked k (xs , y ∷ ys)) (ret ∘ (x ∷_)))
    ≡⟨ step/ext (F (list A)) (bind (F (list A)) (merge/clocked k _) _) q u ⟩
      bind (F (list A)) (merge/clocked k (xs , y ∷ ys)) (ret ∘ (x ∷_))
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e _) ≡ ⟩
      ret (x ∷ l)
    ∎
  ) , (
    λ { (s≤s h) (h₁ ∷ sorted₁) (h₂ ∷ sorted₂) →
      let (↭ , sorted) = h-sorted h sorted₁ (h₂ ∷ sorted₂)  in
      prep x ↭ , All-resp-↭ (↭) (++⁺-All h₁ (p ∷ ≤-≤* p h₂)) ∷ sorted
    }
  )

merge/clocked/cost : cmp (Π nat λ _ → Π pair λ _ → cost)
merge/clocked/cost zero    (l₁     , l₂    ) = zero
merge/clocked/cost (suc k) ([]     , l₂    ) = zero
merge/clocked/cost (suc k) (x ∷ xs , []    ) = zero
merge/clocked/cost (suc k) (x ∷ xs , y ∷ ys) =
  bind cost (x ≤ᵇ y) λ b →
    1 + (
      if b
        then (bind cost (merge/clocked k (xs , y ∷ ys)) (λ l → merge/clocked/cost k (xs , y ∷ ys) + 0))
        else (bind cost (merge/clocked k (x ∷ xs , ys)) (λ l → merge/clocked/cost k (x ∷ xs , ys) + 0))
    )

merge/clocked/cost/closed : cmp (Π nat λ _ → Π pair λ _ → cost)
merge/clocked/cost/closed k _ = k

merge/clocked/cost≤merge/clocked/cost/closed : ∀ k p → ◯ (merge/clocked/cost k p Nat.≤ merge/clocked/cost/closed k p)
merge/clocked/cost≤merge/clocked/cost/closed zero    (l₁     , l₂    ) u = N.≤-refl
merge/clocked/cost≤merge/clocked/cost/closed (suc k) ([]     , l₂    ) u = z≤n
merge/clocked/cost≤merge/clocked/cost/closed (suc k) (x ∷ xs , []    ) u = z≤n
merge/clocked/cost≤merge/clocked/cost/closed (suc k) (x ∷ xs , y ∷ ys) u with h-cost x y
... | ⇓ false withCost q [ _ , h-eq ] rewrite eq/ref h-eq =
  let (l , ≡ , _) = merge/clocked/correct k (x ∷ xs) ys u in
  begin
    step cost q (1 + bind cost (merge/clocked k (x ∷ xs , ys)) (λ l → merge/clocked/cost k (x ∷ xs , ys) + 0))
  ≡⟨ step/ext cost _ q u ⟩
    1 + bind cost (merge/clocked k (x ∷ xs , ys)) (λ l → merge/clocked/cost k (x ∷ xs , ys) + 0)
  ≡⟨⟩
    suc (bind cost (merge/clocked k (x ∷ xs , ys)) (λ l → merge/clocked/cost k (x ∷ xs , ys) + 0))
  ≡⟨ Eq.cong (λ e → suc (bind cost e λ l → merge/clocked/cost k (x ∷ xs , ys) + 0)) (≡) ⟩
    suc (merge/clocked/cost k (x ∷ xs , ys) + 0)
  ≡⟨ Eq.cong suc (N.+-identityʳ _) ⟩
    suc (merge/clocked/cost k (x ∷ xs , ys))
  ≤⟨ s≤s (merge/clocked/cost≤merge/clocked/cost/closed k (x ∷ xs , ys) u) ⟩
    suc (merge/clocked/cost/closed k (x ∷ xs , ys))
  ≡⟨⟩
    suc k
  ∎
    where open ≤-Reasoning
... | ⇓ true withCost q [ _ , h-eq ] rewrite eq/ref h-eq =
  let (l , ≡ , _) = merge/clocked/correct k xs (y ∷ ys) u in
  begin
    step cost q (1 + bind cost (merge/clocked k (xs , y ∷ ys)) (λ l → merge/clocked/cost k (xs , y ∷ ys) + 0))
  ≡⟨ step/ext cost _ q u ⟩
    1 + bind cost (merge/clocked k (xs , y ∷ ys)) (λ l → merge/clocked/cost k (xs , y ∷ ys) + 0)
  ≡⟨⟩
    suc (bind cost (merge/clocked k (xs , y ∷ ys)) (λ l → merge/clocked/cost k (xs , y ∷ ys) + 0))
  ≡⟨ Eq.cong (λ e → suc (bind cost e λ l → merge/clocked/cost k (xs , y ∷ ys) + 0)) (≡) ⟩
    suc (merge/clocked/cost k (xs , y ∷ ys) + 0)
  ≡⟨ Eq.cong suc (N.+-identityʳ _) ⟩
    suc (merge/clocked/cost k (xs , y ∷ ys))
  ≤⟨ s≤s (merge/clocked/cost≤merge/clocked/cost/closed k (xs , y ∷ ys) u) ⟩
    suc (merge/clocked/cost/closed k (xs , y ∷ ys))
  ≡⟨⟩
    suc k
  ∎
    where open ≤-Reasoning

merge/clocked≤merge/clocked/cost : ∀ k p → IsBounded (list A) (merge/clocked k p) (merge/clocked/cost k p)
merge/clocked≤merge/clocked/cost zero    (l₁     , l₂    ) = bound/ret
merge/clocked≤merge/clocked/cost (suc k) ([]     , l₂    ) = bound/ret
merge/clocked≤merge/clocked/cost (suc k) (x ∷ xs , []    ) = bound/ret
merge/clocked≤merge/clocked/cost (suc k) (x ∷ xs , y ∷ ys) =
  bound/bind 1 _ (h-cost x y) λ b →
    bound/bool {p = λ b → if_then_else_ b _ _} b
      (bound/bind (merge/clocked/cost k (x ∷ xs , ys)) _ (merge/clocked≤merge/clocked/cost k (x ∷ xs , ys)) λ l → bound/ret)
      (bound/bind (merge/clocked/cost k (xs , y ∷ ys)) _ (merge/clocked≤merge/clocked/cost k (xs , y ∷ ys)) λ l → bound/ret)

merge/clocked≤merge/clocked/cost/closed : ∀ k p → IsBounded (list A) (merge/clocked k p) (merge/clocked/cost/closed k p)
merge/clocked≤merge/clocked/cost/closed k p = bound/relax (merge/clocked/cost≤merge/clocked/cost/closed k p) (merge/clocked≤merge/clocked/cost k p)

merge : cmp (Π pair λ _ → F (list A))
merge (l₁ , l₂) = merge/clocked (length l₁ + length l₂) (l₁ , l₂)

merge/correct : ∀ l₁ l₂ →
  ◯ (∃ λ l → merge (l₁ , l₂) ≡ ret l × (Sorted l₁ → Sorted l₂ → SortedOf (l₁ ++ l₂) l))
merge/correct l₁ l₂ u =
  let (l , ≡ , h-sorted) = merge/clocked/correct (length l₁ + length l₂) l₁ l₂ u in
  l , ≡ , h-sorted N.≤-refl

merge/cost : cmp (Π pair λ _ → cost)
merge/cost (l₁ , l₂) = merge/clocked/cost (length l₁ + length l₂) (l₁ , l₂)

merge/cost/closed : cmp (Π pair λ _ → cost)
merge/cost/closed (l₁ , l₂) = merge/clocked/cost/closed (length l₁ + length l₂) (l₁ , l₂)

merge≤merge/cost : ∀ p → IsBounded (list A) (merge p) (merge/cost p)
merge≤merge/cost (l₁ , l₂) = merge/clocked≤merge/clocked/cost (length l₁ + length l₂) (l₁ , l₂)

merge≤merge/cost/closed : ∀ p → IsBounded (list A) (merge p) (merge/cost/closed p)
merge≤merge/cost/closed (l₁ , l₂) = merge/clocked≤merge/clocked/cost/closed (length l₁ + length l₂) (l₁ , l₂)


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

module Real-Backup where

open import Data.Float hiding (_-_; _≈_)
open import Level using (0ℓ)
open import Algebra.Bundles using (CommutativeRing)
open import Algebra.Module.Bundles using (Module)
open import Relation.Binary.Structures using (IsStrictTotalOrder)
open import Relation.Binary.Bundles using (StrictTotalOrder)
open import Data.Sum using (_⊎_; inj₁; inj₂)
module CR = CommutativeRing
open import Relation.Binary.PropositionalEquality using (_≡_; module ≡-Reasoning)
open import Algebra.Module.Construct.TensorUnit
import Limit
open import InnerProduct
open import Relation.Nullary using (¬_)

private postulate
  todo : ∀ {a} {A : Set a} → A

+-*-commutativeRing : CommutativeRing 0ℓ 0ℓ
CR.Carrier +-*-commutativeRing = Float
CR._≈_ +-*-commutativeRing = _≡_
CR._+_ +-*-commutativeRing = _+_
CR._*_ +-*-commutativeRing = _*_
CR.- +-*-commutativeRing = -_
CR.0# +-*-commutativeRing = 0.0
CR.1# +-*-commutativeRing = 1.0
CR.isCommutativeRing +-*-commutativeRing = todo

+-*-module : Module +-*-commutativeRing 0ℓ 0ℓ
+-*-module = ⟨module⟩

<-strictTotalOrder : StrictTotalOrder _ 0ℓ 0ℓ
<-strictTotalOrder = record { Carrier = Float; _≈_ = _≡_; _<_ = todo; isStrictTotalOrder = todo }

infixl 6 _-_
_-_ : Float → Float → Float
x - y = x + (- y)

open StrictTotalOrder <-strictTotalOrder

+-*-isInnerProduct : IsInnerProduct isStrictTotalOrder (λ x → x) +-*-module _*_
+-*-isInnerProduct = todo

+-*-isNormed : IsNormed isStrictTotalOrder (λ x → x) +-*-module _*_ sqrt
+-*-isNormed =
  record
  { isInnerProduct = +-*-isInnerProduct
  ; sqrt-law = todo
  ; sqrt-concave = todo
  ; sqrt-cong = todo
  }

module _ where

  open Limit +-*-isNormed +-*-isNormed
  open IsNormed +-*-isNormed
  open Module +-*-module
  open CommutativeRing +-*-commutativeRing using (refl; +-cong)
  open import Data.Product
  open import Algebra.Module.Morphism.Structures

  _ : ∀ c → (c + x) ⟶ c as x ⟶0
  _ = λ c ε (0<ε) → ε , λ x (0<x , x<ε) →
    begin-strict
      ∥ c + x - c ∥
    ≈⟨ ∥∥-cong (y+x-y≈x c x) ⟩
      ∥ x ∥
    <⟨ x<ε ⟩
      ε
    ∎
    where
      open import Relation.Binary.Reasoning.StrictPartialOrder strictPartialOrder

      y+x-y≈x : ∀ y x → y + x - y ≈ᴹ x
      y+x-y≈x y x =
        begin-equality
          y + x - y
        ≈⟨ +ᴹ-cong (+ᴹ-comm y x) refl ⟩
          x + y - y
        ≈⟨ +ᴹ-assoc x y (- y) ⟩
          x + (y - y)
        ≈⟨ +ᴹ-cong {x = x} refl (-ᴹ‿inverseʳ y) ⟩
          x + 0.0
        ≈⟨ +ᴹ-identityʳ x ⟩
          x
        ∎

  times : Float → Float → Float
  times = _*_

  times-homo : ∀ m → IsModuleHomomorphism +-*-module +-*-module (times m)
  times-homo = todo

  _SlopeOf_At_ : (f' : MA.X → MB.X) (f : MA.X → MB.X) (x : MA.X) → Set _
  f' SlopeOf f At x = (λ y dy → f' y * dy) Differentiates f At x

  dxⁿ≈nxⁿ⁻¹
    : ∀ x n → (1.0 < n) ⊎ (¬ x ≈ 0.0)
    → (λ y → (n * (y ** (n - 1.0)))) SlopeOf (_** n) At x
  dxⁿ≈nxⁿ⁻¹ = todo

  dlogx≈1÷x : ∀ x → ¬ x ≈ 0.0 → (λ y dy → dy ÷ y) Differentiates log At x
  dlogx≈1÷x = todo

  deˣ/dx≈eˣ : ∀ x → e^_ SlopeOf e^_ At x
  deˣ/dx≈eˣ = todo

  open import Function using (_∘_)

  -- chain'
  --   : ∀ f f' g g' x
  --   → (λ dx → dx * f' x) Differentiates f At x
  --   → (λ dx → dx * g' (f x)) Differentiates g At f x
  --   → (λ dx → g'fx * (f'x dx)) Differentiates (g ∘ f) At x
  -- chain' f g x (f'x , _) (g'fx , _) = (λ dx → g'fx (f'x dx)) , todo

  ∂exp : ∀ x → (λ y dy → dy * (e^ y)) Differentiates e^_ At x
  ∂exp x = todo

  open import Data.Nat using (zero; suc)
  instance
    exp-n-∂ : ∀ {n} {x} → e^_ ⟦ x , n ⟧
    exp-n-∂ {zero} = []
    exp-n-∂ {n = suc n} = todo ∹ exp-n-∂

  it : ∀ {a} {A : Set a} → {{A}} → A
  it {{x}} = x

  gradexp : ∀ {x} → e^_ ⟦ x , 0 ⟧
  gradexp = it

  chain
    : ∀ f g x {n}
    → ⦃ f ⟦ x , n ⟧ ⦄
    → ⦃ g ⟦ f x , n ⟧ ⦄
    → (g ∘ f) ⟦ x , n ⟧
  chain f g x {n = 0} = []
  chain f g x {_} ⦃ _∹_ {_} {f'} pf ff ⦄ ⦃ _∹_ {_} {g'} pg gg ⦄ =
    let h y dy = g' (f y) (f' y dy)
    -- confusion here between xs and dxs.
    in _∹_ {δf = h} todo (chain (f' x) (g' (f x)) x ⦃ ff ⦄ ⦃ {! gg  !} ⦄)

  exp : Float → Float
  exp = e^_

  asdf : ∀ x → (exp ∘ exp) ⟦ x , 1 ⟧
  asdf x = chain exp exp x

--   gradsin : ∀ {x} → sin DifferentiableAt x
--   gradsin {x} = (λ dx → dx * (cos x)) , todo

--   gradcos : ∀ {x} → cos DifferentiableAt x
--   gradcos {x} = (λ dx → dx * (- sin x)) , todo

--   grad : ∀ f x → f DifferentiableAt x → Float → Float
--   grad f x (f'x , _) = f'x

--   teste : Float → Float
--   teste x = grad e^_ x (grade^ {x}) 1.0

--   -- testsin : Float → Float
--   -- testsin x = grad sin x (gradsin x) 1.0

--   -- test : Float → Float
--   -- test x = grad (e^_ ∘ sin) x (chain' sin e^_ x (gradsin x) (grade^ (sin x))) 1.0

--   -- _ : ∀ x → test x ≡ 1.0 * cos x * (e^ sin x)
--   -- _ = λ x → refl

--   -- -- TODO
--   -- -- definitely need some helper functions here.
--   -- _ : ∀ y n → (λ x → n * y ** (n - 1.0) * x) Differentiates (λ x → x ** n) At y
--   -- _ = λ y n → todo , λ ε 0<ε → δ₀ ε y n , λ δ (0<δ , δ<ε) → proof y n ε δ 0<δ δ<ε
--   --   where
--   --     δ₀ : Float → Float → Float → Float
--   --     δ₀ = {!   !}

--   --     triangle : ∀ x y → ∥ x + y ∥ < ∥ x ∥ + ∥ y ∥
--   --     triangle = todo

--   --     ≈< : ∀ x {y z} → y < z → x + y < x + z
--   --     ≈< = todo

--   --     -- does this imply _≈_ is _≡_?
--   --     ∀-cong : ∀ {x y} (f : CR.X → CR.X) → x ≈ y → f x ≈ f y
--   --     ∀-cong = todo

--   --     proof
--   --       : ∀ y n ε Δ (0<Δ : 0.0 < ∥ Δ ∥) (Δ<ε : ∥ Δ ∥ < ε)
--   --       → ∥ (y + Δ) ** n - (y ** n +ᴹ n * y ** (n - 1.0) * Δ) ∥ < ε
--   --     proof y n ε Δ 0<Δ Δ<ε =
--   --       begin-strict
--   --         ∥ (y + Δ) ** n - (y ** n + n * y ** (n - 1.0) * Δ) ∥
--   --       <⟨ triangle ((y + Δ) ** n) _ ⟩
--   --         ∥ (y + Δ) ** n ∥ + ∥ - (y ** n + n * y ** (n - 1.0) * Δ) ∥
--   --       ≈⟨ +-cong { ∥ (y + Δ) ** n ∥ } refl (sqrt-cong (∥-x∥²≈∥x∥² ((y ** n + n * y ** (n - 1.0) * Δ)))) ⟩
--   --         ∥ (y + Δ) ** n ∥ + ∥ (y ** n + n * y ** (n - 1.0) * Δ) ∥
--   --       <⟨ ≈< ∥ (y + Δ) ** n ∥ (triangle (y ** n) _) ⟩
--   --         ∥ (y + Δ) ** n ∥ + (∥ y ** n ∥ + ∥ n * y ** (n - 1.0) * Δ ∥)
--   --       <⟨ {! +-cong refl (x→-x _) !} ⟩
--   --         ε
--   --       ∎

-- --   -- (f (x MA.+ᴹ dx) MB.+ᴹ (MB.-ᴹ (f x MB.+ᴹ f' dx))) ⟶ MB.0ᴹ as dx ⟶ MA.0ᴹ
-- --   _ : ∀ θ → (λ dθ → F.cos θ F.* dθ) Differentiates F.sin At θ
-- --   _ =
-- --     λ θ → times-homo (F.cos θ) ,
-- --       λ ε → ε ,
-- --         λ dθ (0<abs[dθ-0] , abs[dθ-0]<ε) → {!   !} -- abs[x-0]<ε→abs[c+x-c]<ε x ε {! F.sin (θ F.+ x) !} abs[x-0]<ε
-- --         -- if abs dθ < ε then abs ( sin (θ + dθ) - (sin θ + cos θ * dθ) ) < ε

-- --         -- sin x = (e^iπx - e^-iπx) / 2i
-- --         -- cos x = (e^iπx + e^-iπx) / 2
-- --         -- sin x+dx = ?

-- -- --   open Diff +-*-module +-*-module
-- -- --   open Line +-*-commutativeRing

-- -- --   dline : ∀ m b x → Differentiable _≤_ abs abs (line m b) x
-- -- --   dline m b x = (λ x' dx → m * dx) , {!   !} , λ dy → (dy F.÷ m) , {! asdf dy  !}
-- -- --     where
-- -- --       open import Relation.Binary.Reasoning.PartialOrder ≤-poset

-- -- --       diff≈0 : ∀ dx → (line m b (x + dx) - line m b x) - m * dx ≈ 0#
-- -- --       diff≈0 dx =
-- -- --         begin-equality
-- -- --           (line m b (x + dx) - line m b x - m * dx)
-- -- --         ≈⟨ +-cong (linear-diff m b x dx) refl ⟩
-- -- --           m * dx - m * dx
-- -- --         ≈⟨ proj₂ -‿inverse (m * dx) ⟩
-- -- --           0#
-- -- --         ∎

-- -- --   open import Data.Nat using (ℕ; zero; suc)

-- -- -- --
-- -- -- --   Convex : (A → A) → Set

-- -- -- -- minimize : (f : A → A) (c : Convex f) → A
-- -- -- -- minimize f c = {!   !}

-- -- -- -- gradient : (f : A → A) (Differentiable f)

-- -- -- -- gradientDescent : (f' : A → A) (n : ℕ) → A
-- -- -- -- gradientDescent = ?

-- --   -- open import Relation.Nullary using (¬_)

-- --   -- x<y→y≮x : ∀ {x y} → x < y → ¬ y < x
-- --   -- x<y→y≮x x y = post

-- --   -- <-trans : ∀ {i j k} → i < j → j < k → i < k
-- --   -- <-trans i<j j<k = post

-- --   -- open CommutativeRing +-*-commutativeRing
-- --   -- open Module +-*-module
-- --   -- open import Relation.Binary

-- --   -- ≤-antisym : Antisymmetric _≡_ _≤_
-- --   -- ≤-antisym (inj₂ i≡j) j≤i = i≡j
-- --   -- ≤-antisym (inj₁ i<j) (inj₂ j≡i) = sym j≡i
-- --   -- ≤-antisym {i} {j} (inj₁ i<j) (inj₁ j<i) with x<y→y≮x {i} {j} i<j j<i
-- --   -- ... | ()

-- --   -- ≤-trans : Transitive _≤_
-- --   -- ≤-trans {i} {j} {k} (inj₁ i<j) (inj₁ j<k) = inj₁ (<-trans {i} {j} {k} i<j j<k)
-- --   -- ≤-trans (inj₁ i<j) (inj₂ j≡k) = inj₁ {! tt  !}
-- --   -- ≤-trans (inj₂ y) (inj₁ x) = {!   !}
-- --   -- ≤-trans (inj₂ i≡j) (inj₂ j≡k) = inj₂ (trans i≡j j≡k)


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

module Relation.Nullary.Stable.Base where

open import Data.Empty
open import Level

Stable : Type a → Type a
Stable A = ¬ ¬ A → A


    module _ where

    module A where

      data D : Set₁ where
        !_ : Set → D

      infix 3 !_

    data C : Set₁ where
      #_ : A.D → C

    infix 2 #_

    module B where

      data D : Set₁ where
        !_ : C → D

      infix 1 !_

    open A
    open B

    ok₁ : B.D → B.D
    ok₁ (! # X) = ! # X

    ok₂ : C → C
    ok₂ (# ! X) = # ! X


-- Andreas, 2017-05-15, issue 2585, reported by Martin Stone Davis
-- Information about whether a function uses copatterns
-- needs to be added already while function is defines.
-- Otherwise, clauses might fail to check due to missing eta.

{-# OPTIONS --postfix-projections #-}

open import Agda.Builtin.Equality

record Super : Set₁ where
  eta-equality
  field
    set : Set

record Sub : Set₁ where
  eta-equality
  field
    super1 : Super
    super2 : Super
    super1=2 : super1 ≡ super2

postulate
  X : Set

works : Sub
works .Sub.super1 = record { set = X }
works .Sub.super2 .Super.set = X
works .Sub.super1=2 = refl

test : Sub
test .Sub.super1 .Super.set = X
test .Sub.super2 .Super.set = X
test .Sub.super1=2 = refl

-- Should pass


module Issue794 where

open import Common.Prelude
open import Common.MAlonzo

postulate A : Set

record R : Set where
  id : A → A
  id x = x


module Base.Free where

-- Reexport definitions from Agda's standard library that are needed by the
-- generated code.
open import Function            using (case_of_)      public
open import Data.Bool           using (if_then_else_) public
open import Size                using (Size; ↑_)      public

-- The `Free` monad over a container with shapes `S` and postions `P`.
data Free (S : Set) (P : S → Set) (A : Set) : Set where
  pure : A → Free S P A

  impure : (s : S) → (pf : P s → Free S P A) → Free S P A

infixl 1 _>>=_
_>>=_ : {S : Set} {P : S → Set} {A : Set} {B : Set} → Free S P A → (A → Free S P B) → Free S P B
pure   x    >>= k = k x
impure s pf >>= k = impure s λ p → pf p >>= k


module core where

open import Data.Nat
open import Data.Vec
open import Data.Fin
open import Data.String
open import Data.Rational
open import Data.Sum
open import Data.Unit

open import Binders.Var

{-
module ABTLearning where
   data View {univ : Set} (f : univ -> Set) (a : univ) : list univ -> Set where
     Syn : f a -> View f a []
     Var :
   record ABT {u : Set}

data Var (a b : Set) where
    Free
-}

module Term  where
    data Literal : Set where
        Nat : ℕ  -> Literal
        Rat : ℚ -> Literal
        Str : String -> Literal
    data term (a : Set) : Set where
      v : a -> term a
      app : ∀  (n : ℕ ) ->   term a -> Vec (term a) n -> term a
      abs : ∀ (n : ℕ ) -> term (Var (Fin n) (term a))-> term a
      primcall : ∀ {n : ℕ } -> String -> Vec (term a) n -> term a
      lit :  Literal -> term a
      force : term a -> term a
      delay : term a -> term a

module TypedTerm where
  data PrimType : Set where
       Nat : PrimType
       Rat : PrimType
       Str : PrimType
  data Sort : Set where -- should this be a record??
       lit : ℕ -> Sort
       -- var :
       -- univ→ :
  data Literal : PrimType ->  Set where
        NatL : ℕ  -> Literal Nat
        RatL : ℚ -> Literal Rat
        StrL : String -> Literal Str

module PHOAS where
  data Exp (a : Set) : Set where
    Lam : (a -> Exp a) -> Exp a
    App : (Exp a) -> Exp a -> Exp a


module ProposedSemantics where

open import Syntax public

-- Vindicative Kripke models.

record Model : Set₁ where
  infix 3 _⊩ᵅ_
  field
    World   : Set
    _≤_     : World → World → Set
    refl≤   : ∀ {w} → w ≤ w
    trans≤  : ∀ {w w′ w″} → w ≤ w′ → w′ ≤ w″ → w ≤ w″
    _R_     : World → World → Set
    reflR   : ∀ {w} → w R w
    transR  : ∀ {w w′ w″} → w R w′ → w′ R w″ → w R w″
    _⊩ᵅ_   : World → Atom → Set
    mono⊩ᵅ : ∀ {w w′ P} → w ≤ w′ → w ⊩ᵅ P → w′ ⊩ᵅ P

  -- Vindication, a consequence of brilliance and persistence.
  field
    ≤→R : ∀ {v′ w} → w ≤ v′ → w R v′

open Model {{…}} public

-- Forcing in a particular world of a particular model.

module _ {{_ : Model}} where
  infix 3 _⊩_
  _⊩_ : World → Type → Set
  w ⊩ α P    = w ⊩ᵅ P
  w ⊩ A ⇒ B = ∀ {w′} → w ≤ w′ → w′ ⊩ A → w′ ⊩ B
  w ⊩ □ A    = ∀ {v′} → w R v′ → v′ ⊩ A
  w ⊩ A ⩕ B  = w ⊩ A ∧ w ⊩ B
  w ⊩ ⫪     = ⊤
  w ⊩ ⫫     = ⊥
  w ⊩ A ⩖ B  = w ⊩ A ∨ w ⊩ B

  infix 3 _⊩⋆_
  _⊩⋆_ : World → Stack Type → Set
  w ⊩⋆ ∅     = ⊤
  w ⊩⋆ Ξ , A = w ⊩⋆ Ξ ∧ w ⊩ A

-- Monotonicity of forcing with respect to constructive accessibility.

module _ {{_ : Model}} where
  mono⊩ : ∀ {A w w′} → w ≤ w′ → w ⊩ A → w′ ⊩ A
  mono⊩ {α P}    ψ s       = mono⊩ᵅ ψ s
  mono⊩ {A ⇒ B} ψ f       = λ ψ′ a → f (trans≤ ψ ψ′) a
  mono⊩ {□ A}    ψ f       = λ ρ → f (transR (≤→R ψ) ρ)
  mono⊩ {A ⩕ B}  ψ (a , b) = mono⊩ {A} ψ a , mono⊩ {B} ψ b
  mono⊩ {⫪}     ψ ∙       = ∙
  mono⊩ {⫫}     ψ ()
  mono⊩ {A ⩖ B}  ψ (ι₁ a)  = ι₁ (mono⊩ {A} ψ a)
  mono⊩ {A ⩖ B}  ψ (ι₂ b)  = ι₂ (mono⊩ {B} ψ b)

  mono⊩⋆ : ∀ {Ξ w w′} → w ≤ w′ → w ⊩⋆ Ξ → w′ ⊩⋆ Ξ
  mono⊩⋆ {∅}     ψ ∙       = ∙
  mono⊩⋆ {Ξ , A} ψ (ξ , s) = mono⊩⋆ {Ξ} ψ ξ , mono⊩ {A} ψ s

-- Additional equipment.

module _ {{_ : Model}} where
  lookup : ∀ {Ξ A w} → A ∈ Ξ → w ⊩⋆ Ξ → w ⊩ A
  lookup top     (ξ , s) = s
  lookup (pop i) (ξ , s) = lookup i ξ

-- Forcing in all worlds of all models, or semantic entailment.

infix 3 _⊨_
_⊨_ : Context → Type → Set₁
Γ ⁏ Δ ⊨ A = ∀ {{_ : Model}} {w} →
             w ⊩⋆ Γ →
             (∀ {v′} → w R v′ → v′ ⊩⋆ Δ) →
             w ⊩ A

-- Soundness of the semantics with respect to the syntax.

reflect : ∀ {Γ Δ A} → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊨ A
reflect (var i)      γ δ = lookup i γ
reflect (mvar i)     γ δ = lookup i (δ reflR)
reflect (lam d)      γ δ = λ ψ a → reflect d (mono⊩⋆ ψ γ , a)
                                              (λ ρ → δ (transR (≤→R ψ) ρ))
reflect (app d e)    γ δ = (reflect d γ δ) refl≤ (reflect e γ δ)
reflect (box d)      γ δ = λ ρ → reflect d ∙
                                            (λ ρ′ → δ (transR ρ ρ′))
reflect (unbox d e)  γ δ = reflect e γ (λ ρ → δ ρ , (reflect d γ δ) ρ)
reflect (pair d e)   γ δ = reflect d γ δ , reflect e γ δ
reflect (fst d)      γ δ = π₁ (reflect d γ δ)
reflect (snd d)      γ δ = π₂ (reflect d γ δ)
reflect unit         γ δ = ∙
reflect (boom d)     γ δ = elim⊥ (reflect d γ δ)
reflect (left d)     γ δ = ι₁ (reflect d γ δ)
reflect (right d)    γ δ = ι₂ (reflect d γ δ)
reflect (case d e f) γ δ = elim∨ (reflect d γ δ) (λ a → reflect e (γ , a) δ)
                                                 (λ b → reflect f (γ , b) δ)


{- Category of reactive types -}
module CategoryTheory.Instances.Reactive where

open import CategoryTheory.Categories
open import CategoryTheory.BCCCs

open import Data.Nat using (ℕ ; zero ; suc ; _+_) public
open import Data.Unit using () renaming (⊤ to top) public
open import Data.Product
open import Data.Empty using (⊥-elim) renaming (⊥ to bot) public
open import Data.Sum renaming ([_,_] to ⟦_,_⟧)
import Function as F using (_∘_)

-- || Reactive types

-- Time-indexed types.
τ : Set₁
τ = ℕ -> Set

-- Time-indexed functions.
_⇴_ : τ -> τ -> Set
A ⇴ B = ∀(n : ℕ) -> A n -> B n
infixr 10 _⇴_

-- Category of reactive types
ℝeactive : Category lzero
ℝeactive = record
         { obj      = τ
         ; _~>_     = _⇴_
         ; id       = λ n a -> a
         ; _∘_      = λ g f -> λ n a -> g n (f n a)
         ; _≈_      = λ f g -> ∀ {n : ℕ} {a} -> f n a ≡ g n a
         ; id-left  = refl
         ; id-right = refl
         ; ∘-assoc  = refl
         ; ≈-equiv  = record { refl = refl
                             ; sym = λ x → sym x
                             ; trans = λ p q → trans p q }
         ; ≈-cong   = ≈-cong-ℝ
         }
         where
         ≈-cong-ℝ : ∀{A B C : τ} {f f′ : A ⇴ B} {g g′ : B ⇴ C}
                 -> (∀ {n a} -> f n a ≡ f′ n a)
                 -> (∀ {n b} -> g n b ≡ g′ n b)
                 -> (∀ {n a} -> g n (f n a) ≡ g′ n (f′ n a))
         ≈-cong-ℝ {f′ = f′} fe ge {n} {a′}
                rewrite fe {n} {a′}
                      | ge {n} {f′ n a′} = refl

-- Bicartesian closed structure for reactive types
ℝeactive-BCCC : BicartesianClosed ℝeactive
ℝeactive-BCCC = record
    { cart = record
        { term = record
            { ⊤ = λ n → top
            ; ! = λ n _ → top.tt
            ; !-unique = λ m → refl
            }
        ; prod = λ A B → record
            { A⊗B = λ n → A n × B n
            ; π₁ = λ n → proj₁
            ; π₂ = λ n → proj₂
            ; ⟨_,_⟩ = λ f g n a → (f n a , g n a)
            ; π₁-comm = λ {P} {p₁} {p₂} {n} {a} → refl
            ; π₂-comm = λ {P} {p₁} {p₂} {n} {a} → refl
            ; ⊗-unique = λ pr1 pr2 → unique-cart (ext λ a → ext λ n → pr1 {a} {n})
                                               (ext λ a → ext λ n → pr2 {a} {n})
            }
        }
    ; cocart = record
        { init = record
            { ⊥ = λ n → bot
            ; ¡ = λ {A} n → λ ()
            ; ¡-unique = λ {A} m {n} → λ {}
            }
        ; sum = λ A B → record
            { A⊕B = λ n → A n ⊎ B n
            ; ι₁ = λ n → inj₁
            ; ι₂ = λ n → inj₂
            ; [_⁏_] = sum
            ; ι₁-comm = λ {S} {i₁} {i₂} {n} {a} → refl
            ; ι₂-comm = λ {S} {i₁} {i₂} {n} {a} → refl
            ; ⊕-unique = λ {S} {i₁} {i₂} {m} pr1 pr2 →
                        unique-cocart {m = m} (ext λ a → ext λ n → pr1 {a} {n})
                                      (ext λ a → ext λ n → pr2 {a} {n})
            }
        }
    ; closed = record
        { exp = λ A B → record
            { A⇒B = λ n → A n -> B n
            ; eval = λ n z → proj₁ z (proj₂ z)
            ; Λ = λ  f n a b → f n (a , b)
            ; Λ-comm = refl
            ; Λ-unique = λ pr → unique-closed (ext λ n → ext λ a → pr {n} {a})
            ; Λ-cong = λ pr → ext λ _ → pr
            }
        }
    }
    where
    open Category ℝeactive
    unique-cart : ∀{A B P : τ}
              -> {p₁ : P ⇴ A} {p₂ : P ⇴ B} {m : P ⇴ (λ n -> A n × B n)}
              -> (λ _ → proj₁) ∘ m ≡ p₁ -> (λ _ → proj₂) ∘ m ≡ p₂
              -> ∀{n : ℕ}{a : P n} -> (p₁ n a , p₂ n a) ≡ m n a
    unique-cart refl refl = refl
    sum : {A B S : obj} → A ⇴ S → B ⇴ S → (λ n → A n ⊎ B n) ⇴ S
    sum f g n (inj₁ x) = f n x
    sum f g n (inj₂ y) = g n y
    unique-cocart : ∀{A B S : τ}
              -> {i₁ : A ⇴ S} {i₂ : B ⇴ S} {m : (λ n -> A n ⊎ B n) ⇴ S}
              -> m ∘ (λ _ -> inj₁) ≡ i₁ -> m ∘ (λ _ -> inj₂) ≡ i₂
              -> ∀{n : ℕ}{a : A n ⊎ B n} -> sum i₁ i₂ n a ≡ m n a
    unique-cocart refl refl {n} {inj₁ x} = refl
    unique-cocart refl refl {n} {inj₂ y} = refl
    unique-closed : ∀{A B E : τ}
              -> {e : (λ n -> E n × A n) ⇴ B} {m : E ⇴ (λ n -> A n -> B n)}
              -> (λ n fa → proj₁ fa (proj₂ fa)) ∘ ((λ n (a : E n × A n) -> ( (m n F.∘ proj₁) a , proj₂ a ))) ≡ e
              -> ∀{n}{a : E n} -> (λ b → e n (a , b)) ≡ m n a
    unique-closed refl = refl

-- | Top-level shorthands for distinguished BCCC objects and morphisms
open BicartesianClosed ℝeactive-BCCC public
open Category ℝeactive hiding (begin_ ; _∎) public

ℝeactive-cart : Cartesian ℝeactive
ℝeactive-cart = cart

-- Non-canonical distribution morphism
dist : ∀{A B C : τ} ->  A ⊗ (B ⊕ C) ⇴ (A ⊗ B) ⊕ (A ⊗ C)
dist n (a , inj₁ b) = inj₁ (a , b)
dist n (a , inj₂ c) = inj₂ (a , c)

dist2 : ∀{A B C D : τ} ->  A ⊗ (B ⊕ C ⊕ D) ⇴ (A ⊗ B) ⊕ (A ⊗ C) ⊕ (A ⊗ D)
dist2 n (a , inj₁ (inj₁ b)) = inj₁ (inj₁ (a , b))
dist2 n (a , inj₁ (inj₂ c)) = inj₁ (inj₂ (a , c))
dist2 n (a , inj₂ d) = inj₂ (a , d)

-- ℝeactive is distributive
dist-ℝ : ∀{A B C : τ} -> (A ⊗ B) ⊕ (A ⊗ C) <~> A ⊗ (B ⊕ C)
dist-ℝ = record
    { iso~> = [ id * ι₁ ⁏ id * ι₂ ]
    ; iso<~ = dist
    ; iso-id₁ = dist-iso-id₁
    ; iso-id₂ = dist-iso-id₂
    }
    where
    dist-iso-id₁ : ∀{A B C : τ} -> dist {A}{B}{C} ∘ [ id * ι₁ ⁏ id * ι₂ ] ≈ id
    dist-iso-id₁ {n = n} {inj₁ (a , b)} = refl
    dist-iso-id₁ {n = n} {inj₂ (a , c)} = refl

    dist-iso-id₂ : ∀{A B C : τ} -> [ id * ι₁ ⁏ id * ι₂ ] ∘ dist {A}{B}{C} ≈ id
    dist-iso-id₂ {n = n} {a , inj₁ b} = refl
    dist-iso-id₂ {n = n} {a , inj₂ c} = refl


{-# OPTIONS --without-K --safe #-}
module Util.Relation.Binary.PropositionalEquality where

open import Relation.Binary.PropositionalEquality public

open import Data.Product using (uncurry)

open import Util.Prelude

private
  variable
    α β γ γ′ δ : Level
    A B C A′ B′ C′ : Set α

trans-unassoc : {a b c d : A} (p : a ≡ b) {q : b ≡ c} {r : c ≡ d}
  → trans p (trans q r) ≡ trans (trans p q) r
trans-unassoc p = sym (trans-assoc p)

Σ-≡⁻ : {A : Set α} {B : A → Set β} {x y : Σ A B}
  → x ≡ y
  → Σ[ p ∈ (proj₁ x ≡ proj₁ y) ] subst B p (proj₂ x) ≡ proj₂ y
Σ-≡⁻ refl = refl , refl

Σ-≡⁺ : {A : Set α} {B : A → Set β} {x y : Σ A B}
  → Σ[ p ∈ (proj₁ x ≡ proj₁ y) ] subst B p (proj₂ x) ≡ proj₂ y
  → x ≡ y
Σ-≡⁺ (refl , refl) = refl

Σ-≡⁺∘Σ-≡⁻ : {A : Set α} {B : A → Set β} {x y : Σ A B}
  → (p : x ≡ y)
  → Σ-≡⁺ (Σ-≡⁻ p) ≡ p
Σ-≡⁺∘Σ-≡⁻ refl = refl

Σ-≡⁻∘Σ-≡⁺ : {A : Set α} {B : A → Set β} {x y : Σ A B}
  → (p : Σ[ p ∈ (proj₁ x ≡ proj₁ y) ] subst B p (proj₂ x) ≡ proj₂ y)
  → Σ-≡⁻ (Σ-≡⁺ p) ≡ p
Σ-≡⁻∘Σ-≡⁺ (refl , refl) = refl

×-≡⁺ : {x y : A × B}
  → (proj₁ x ≡ proj₁ y) × (proj₂ x ≡ proj₂ y)
  → x ≡ y
×-≡⁺ (refl , refl) = refl

×-≡⁻ : {x y : A × B}
  → x ≡ y
  → (proj₁ x ≡ proj₁ y) × (proj₂ x ≡ proj₂ y)
×-≡⁻ refl = refl , refl

×-≡⁺∘×-≡⁻ : {x y : A × B} (p : x ≡ y)
  → ×-≡⁺ (×-≡⁻ p) ≡ p
×-≡⁺∘×-≡⁻ refl = refl

×-≡⁻∘×-≡⁺ : {x y : A × B} (p : (proj₁ x ≡ proj₁ y) × (proj₂ x ≡ proj₂ y))
  → ×-≡⁻ (×-≡⁺ p) ≡ p
×-≡⁻∘×-≡⁺ (refl , refl) = refl

cast : A ≡ B → A → B
cast = subst (λ x → x)

cast-refl : {x : A} → cast refl x ≡ x
cast-refl = refl

cast-trans : (B≡C : B ≡ C) (A≡B : A ≡ B) {x : A}
  → cast B≡C (cast A≡B x) ≡ cast (trans A≡B B≡C) x
cast-trans refl refl = refl

subst-trans : ∀ {P : A → Set β} {x y z : A} {p : P x}
  → (x≡y : x ≡ y) (y≡z : y ≡ z)
  → subst P y≡z (subst P x≡y p) ≡ subst P (trans x≡y y≡z) p
subst-trans refl refl = refl

subst₂-trans : (C : A → B → Set γ)
  → {a₀ a₁ a₂ : A} (p : a₀ ≡ a₁) (p′ : a₁ ≡ a₂)
  → {b₀ b₁ b₂ : B} (q : b₀ ≡ b₁) (q′ : b₁ ≡ b₂)
  → {x : C a₀ b₀}
  → subst₂ C p′ q′ (subst₂ C p q x) ≡ subst₂ C (trans p p′) (trans q q′) x
subst₂-trans C refl refl refl refl = refl

subst₂-subst₂-sym : (C : A → B → Set γ)
  → {a a′ : A} (p : a ≡ a′)
  → {b b′ : B} (q : b ≡ b′)
  → {x : C a′ b′}
  → subst₂ C p q (subst₂ C (sym p) (sym q) x) ≡ x
subst₂-subst₂-sym C refl refl = refl

subst₂-sym-subst₂ : (C : A → B → Set γ)
  → {a a′ : A} (p : a ≡ a′)
  → {b b′ : B} (q : b ≡ b′)
  → {x : C a b}
  → subst₂ C (sym p) (sym q) (subst₂ C p q x) ≡ x
subst₂-sym-subst₂ C refl refl = refl

subst₂-cong : (C : A′ → B′ → Set γ)
  → (f : A → A′) (g : B → B′)
  → {a a′ : A} (p : a ≡ a′)
  → {b b′ : B} (q : b ≡ b′)
  → {x : C (f a) (g b)}
  → subst₂ C (cong f p) (cong g q) x ≡ subst₂ (λ a b → C (f a) (g b)) p q x
subst₂-cong C f g refl refl = refl

subst₂≡subst : ∀ {la} {A : Set la} {lb} {B : Set lb} {lc} (C : A → B → Set lc)
  → ∀ {a a′} (p : a ≡ a′) {b b′} (q : b ≡ b′) {x : C a b}
  → subst₂ C p q x ≡ subst (uncurry C) (cong₂ _,_ p q) x
subst₂≡subst C refl refl = refl

subst₂-application : (C : A → B → Set γ) {C′ : A′ → B′ → Set γ′}
  → {fa : A′ → A} {fb : B′ → B}
  → {a a′ : A′} {b b′ : B′} {c : C (fa a) (fb b)}
  → (g : ∀ a b → C (fa a) (fb b) → C′ a b)
  → (eqa : a ≡ a′)
  → (eqb : b ≡ b′)
  → subst₂ C′ eqa eqb (g a b c)
  ≡ g a′ b′ (subst₂ C (cong fa eqa) (cong fb eqb) c)
subst₂-application _ _ refl refl = refl

subst₂-application′ : {C : A → B → Set γ} (C′ : A′ → B′ → Set γ′)
  → {fa : A → A′} {fb : B → B′}
  → {a a′ : A} {b b′ : B} {c : C a b}
  → (g : ∀ a b → C a b → C′ (fa a) (fb b))
  → (eqa : a ≡ a′)
  → (eqb : b ≡ b′)
  → subst₂ C′ (cong fa eqa) (cong fb eqb) (g a b c)
  ≡ g a′ b′ (subst₂ C eqa eqb c)
subst₂-application′ _ _ refl refl = refl

cong₂-dep : {A : Set α} {B : A → Set β} {C : Set γ}
  → (f : (a : A) → B a → C)
  → {x y : A} (p : x ≡ y)
  → {u : B x} {v : B y} (q : subst B p u ≡ v)
  → f x u ≡ f y v
cong₂-dep f refl refl = refl

cong₃-dep : {A : Set α} {B : A → Set β} {C : (a : A) → B a → Set γ}
  → {D : Set δ}
  → (f : (a : A) (b : B a) → C a b → D)
  → {x y : A} (p : x ≡ y)
  → {u : B x} {v : B y} (q : subst B p u ≡ v)
  → {w : C x u} {z : C y v} (r : subst (λ i → C (proj₁ i) (proj₂ i)) (Σ-≡⁺ (p , q)) w ≡ z)
  → f x u w ≡ f y v z
cong₃-dep f refl refl refl = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Generalised notion of interleaving two lists into one in an
-- order-preserving manner
------------------------------------------------------------------------

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

module Data.List.Relation.Ternary.Interleaving where

open import Level
open import Data.List.Base as List using (List; []; _∷_; _++_)
open import Data.List.Relation.Binary.Pointwise using (Pointwise; []; _∷_)
open import Data.Product as Prod using (∃; ∃₂; _×_; uncurry; _,_; -,_; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

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

module _ {a b c l r} {A : Set a} {B : Set b} {C : Set c}
         (L : REL A C l) (R : REL B C r) where

  data Interleaving : List A → List B → List C → Set (a ⊔ b ⊔ c ⊔ l ⊔ r) where
    []   : Interleaving [] [] []
    _∷ˡ_ : ∀ {a c l r cs} → L a c → Interleaving l r cs → Interleaving (a ∷ l) r (c ∷ cs)
    _∷ʳ_ : ∀ {b c l r cs} → R b c → Interleaving l r cs → Interleaving l (b ∷ r) (c ∷ cs)

------------------------------------------------------------------------
-- Operations

module _ {a b c l r} {A : Set a} {B : Set b} {C : Set c}
         {L : REL A C l} {R : REL B C r} where

-- injections

  left : ∀ {as cs} → Pointwise L as cs → Interleaving L R as [] cs
  left []       = []
  left (l ∷ pw) = l ∷ˡ left pw

  right : ∀ {bs cs} → Pointwise R bs cs → Interleaving L R [] bs cs
  right []       = []
  right (r ∷ pw) = r ∷ʳ right pw

-- swap

  swap : ∀ {cs l r} → Interleaving L R l r cs → Interleaving R L r l cs
  swap []        = []
  swap (l ∷ˡ sp) = l ∷ʳ swap sp
  swap (r ∷ʳ sp) = r ∷ˡ swap sp

-- extract the "proper" equality split from the pointwise relations

  break : ∀ {cs l r} → Interleaving L R l r cs → ∃ $ uncurry $ λ csl csr →
          Interleaving _≡_ _≡_ csl csr cs × Pointwise L l csl × Pointwise R r csr
  break []        = -, [] , [] , []
  break (l ∷ˡ sp) = let (_ , eq , pwl , pwr) = break sp in
                    -, P.refl ∷ˡ eq , l ∷ pwl , pwr
  break (r ∷ʳ sp) = let (_ , eq , pwl , pwr) = break sp in
                    -, P.refl ∷ʳ eq , pwl , r ∷ pwr

-- map

module _ {a b c l r p q} {A : Set a} {B : Set b} {C : Set c}
         {L : REL A C l} {R : REL B C r} {P : REL A C p} {Q : REL B C q} where

  map : ∀ {cs l r} → L ⇒ P → R ⇒ Q → Interleaving L R l r cs → Interleaving P Q l r cs
  map L⇒P R⇒Q []        = []
  map L⇒P R⇒Q (l ∷ˡ sp) = L⇒P l ∷ˡ map L⇒P R⇒Q sp
  map L⇒P R⇒Q (r ∷ʳ sp) = R⇒Q r ∷ʳ map L⇒P R⇒Q sp

module _ {a b c l r p} {A : Set a} {B : Set b} {C : Set c}
         {L : REL A C l} {R : REL B C r} where

  map₁ : ∀ {P : REL A C p} {as l r} → L ⇒ P →
         Interleaving L R l r as → Interleaving P R l r as
  map₁ L⇒P = map L⇒P id

  map₂ : ∀ {P : REL B C p} {as l r} → R ⇒ P →
         Interleaving L R l r as → Interleaving L P l r as
  map₂ = map id

------------------------------------------------------------------------
-- Special case: The second and third list have the same type

module _ {a b l r} {A : Set a} {B : Set b} {L : REL A B l} {R : REL A B r} where

-- converting back and forth with pointwise

  split : ∀ {as bs} → Pointwise (λ a b → L a b ⊎ R a b) as bs →
          ∃₂ λ asr asl → Interleaving L R asl asr bs
  split []            = [] , [] , []
  split (inj₁ l ∷ pw) = Prod.map _ (Prod.map _ (l ∷ˡ_)) (split pw)
  split (inj₂ r ∷ pw) = Prod.map _ (Prod.map _ (r ∷ʳ_)) (split pw)

  unsplit : ∀ {l r as} → Interleaving L R l r as →
            ∃ λ bs → Pointwise (λ a b → L a b ⊎ R a b) bs as
  unsplit []        = -, []
  unsplit (l ∷ˡ sp) = Prod.map _ (inj₁ l ∷_) (unsplit sp)
  unsplit (r ∷ʳ sp) = Prod.map _ (inj₂ r ∷_) (unsplit sp)


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

module Transformation where

open import Data.Integer using (ℤ; +_; _-_; -_)
open import Data.List    using (List; _∷_; []; map; reverse)
open import Data.Product using (_,_)

open import Note         using (Note; tone; rest)
open import Pitch        using (Pitch; transposePitch)
open import Interval     using (PitchPair)

retrograde : List Note → List Note
retrograde = reverse

-- Create a list of intervals between all adjacent tones, ignoring rests.
intervals : List Note → List ℤ
intervals [] = []
intervals (rest _ ∷ ns) = intervals ns
intervals (tone d p ∷ ns) = intervals' p ns where
  intervals' : Pitch → List Note → List ℤ
  intervals' p []                              = []
  intervals' p (rest d ∷ ns)                   = intervals' p ns
  intervals' p (tone d q ∷ ns) = (+ q) - (+ p) ∷ intervals' q ns

inversion : List Note → List Note
inversion []                 = []
inversion    (rest d   ∷ ns) = rest d   ∷ inversion ns
inversion xs@(tone d p ∷ ns) = tone d p ∷ inversion' p is ns where
  is : List ℤ
  is = map (-_) (intervals xs)

  inversion' : Pitch → List ℤ → List Note → List Note
  inversion' p []         ns              = ns
  inversion' _ (_ ∷ _)    []              = []
  inversion' p is@(_ ∷ _) (rest d ∷ ns)   = rest d ∷ inversion' p is ns
  inversion' p (i ∷ is)   (tone d _ ∷ ns) = let q = transposePitch i p in (tone d q) ∷ inversion' q is ns


module Issue183 where

postulate A : Set

T : Set
T = A → A

data L (A : Set) : Set where

data E (x : T) : T → Set where
  e : E x x

foo : (f : A → A) → L (E f (λ x → f x))
foo = λ _ → e

-- Previously:
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/Syntax/Translation/AbstractToConcrete.hs:705
-- Should now give a proper error message.

-- E (_8 f) (_8 f) !=< L (E f f) of type Set
-- when checking that the expression e has type L (E f f)


test = forall (_Set_ : Set) → Set


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

module Cubical.Relation.Binary.Raw.Definitions where

open import Cubical.Core.Everything

open import Cubical.Foundations.Function
open import Cubical.Data.Maybe.Base using (Maybe)
open import Cubical.Data.Prod.Base using (_×_)
open import Cubical.Data.Sigma.Base using (∃-syntax)
open import Cubical.Data.Sum.Base using (_⊎_)
open import Cubical.HITs.PropositionalTruncation.Base using (∥_∥)

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

private
  variable
    a b c ℓ ℓ′ ℓ′′ : Level
    A : Type a
    B : Type b
    C : Type c

infix 8 _⟶_Respects_ _Respects_ _Respectsˡ_ _Respectsʳ_ _Respects₂_

------------------------------------------------------------------------
-- Basic definitions
------------------------------------------------------------------------

idRel : (A : Type ℓ) → RawRel A ℓ
idRel A a b = a ≡ b

invRel : ∀ {A B : Type ℓ} → RawREL A B ℓ′ → RawREL B A ℓ′
invRel R b a = R a b

compRel : ∀ {A B C : Type ℓ} → RawREL A B ℓ′ → RawREL B C ℓ′′ → RawREL A C _
compRel R S a c = Σ[ b ∈ _ ] (R a b × S b c)

graphRel : ∀ {A B : Type ℓ} → (A → B) → RawREL A B ℓ
graphRel f a b = f a ≡ b

infix 7 _⇒_ _⇔_ _=[_]⇒_

-- Implication/containment - could also be written _⊆_.
-- and corresponding notion of equivalence

_⇒_ : RawREL A B ℓ → RawREL A B ℓ′ → Type _
P ⇒ Q = ∀ {x y} → P x y → Q x y

_⇔_ : RawREL A B ℓ → RawREL A B ℓ′ → Type _
P ⇔ Q = P ⇒ Q × Q ⇒ P

-- Generalised implication - if P ≡ Q it can be read as "f preserves P".

_=[_]⇒_ : RawRel A ℓ → (A → B) → RawRel B ℓ′ → Type _
P =[ f ]⇒ Q = P ⇒ (Q on f)

-- A synonym for _=[_]⇒_.

_Preserves_⟶_ : (A → B) → RawRel A ℓ → RawRel B ℓ′ → Type _
f Preserves P ⟶ Q = P =[ f ]⇒ Q

-- An endomorphic variant of _Preserves_⟶_.

_Preserves_ : (A → A) → RawRel A ℓ → Type _
f Preserves P = f Preserves P ⟶ P

-- A binary variant of _Preserves_⟶_.

_Preserves₂_⟶_⟶_ : (A → B → C) → RawRel A ℓ → RawRel B ℓ′ → RawRel C ℓ′′ → Type _
_∙_ Preserves₂ P ⟶ Q ⟶ R = ∀ {x y u v} → P x y → Q u v → R (x ∙ u) (y ∙ v)

------------------------------------------------------------------------
-- Property predicates
------------------------------------------------------------------------

-- Reflexivity.

Reflexive : RawRel A ℓ → Type _
Reflexive _∼_ = ∀ {x} → x ∼ x

-- Equality can be converted to proof of relation.

FromEq : RawRel A ℓ → Type _
FromEq _∼_ = _≡_ ⇒ _∼_

-- Irreflexivity.

Irreflexive : RawRel A ℓ → Type _
Irreflexive _<_ = ∀ {x} → ¬ (x < x)

-- Relation implies inequality.

ToNotEq : RawRel A ℓ → Type _
ToNotEq _<_ = _<_ ⇒ (λ x y → ¬ (x ≡ y))

-- Generalised symmetry.

Sym : RawREL A B ℓ → RawREL B A ℓ′ → Type _
Sym P Q = P ⇒ flip Q

-- Symmetry.

Symmetric : RawRel A ℓ → Type _
Symmetric _∼_ = Sym _∼_ _∼_

-- Generalised transitivity.

Trans : RawREL A B ℓ → RawREL B C ℓ′ → RawREL A C ℓ′′ → Type _
Trans P Q R = ∀ {i j k} → P i j → Q j k → R i k

-- A flipped variant of generalised transitivity.

TransFlip : RawREL A B ℓ → RawREL B C ℓ′ → RawREL A C ℓ′′ → Type _
TransFlip P Q R = ∀ {i j k} → Q j k → P i j → R i k

-- Transitivity.

Transitive : RawRel A ℓ → Type _
Transitive _∼_ = Trans _∼_ _∼_ _∼_

-- Generalised antisymmetry.

Antisym : RawREL A B ℓ → RawREL B A ℓ′ → RawREL A B ℓ′′ → Type _
Antisym R S E = ∀ {i j} → R i j → S j i → E i j

-- Antisymmetry.

Antisymmetric : RawRel A ℓ → Type _
Antisymmetric _≤_ = Antisym _≤_ _≤_ _≡_

-- Asymmetry.

Asymmetric : RawRel A ℓ → Type _
Asymmetric _<_ = ∀ {x y} → x < y → ¬ (y < x)

-- Generalised connex - exactly one of the two relations holds.

Connex : RawREL A B ℓ → RawREL B A ℓ′ → Type _
Connex P Q = ∀ x y → P x y ⊎ Q y x

-- Totality.

Total : RawRel A ℓ → Type _
Total _∼_ = Connex _∼_ _∼_

-- Truncated connex - Preserves propositions.

PropConnex : RawREL A B ℓ → RawREL B A ℓ′ → Type _
PropConnex P Q = ∀ x y → ∥ P x y ⊎ Q y x ∥

-- Truncated totality.

PropTotal : RawRel A ℓ → Type _
PropTotal _∼_ = PropConnex _∼_ _∼_

-- Generalised trichotomy - exactly one of three types has a witness.

data Tri (A : Type a) (B : Type b) (C : Type c) : Type (ℓ-max a (ℓ-max b c)) where
  tri< : ( a :   A) (¬b : ¬ B) (¬c : ¬ C) → Tri A B C
  tri≡ : (¬a : ¬ A) ( b :   B) (¬c : ¬ C) → Tri A B C
  tri> : (¬a : ¬ A) (¬b : ¬ B) ( c :   C) → Tri A B C

-- Trichotomy.

Trichotomous : RawRel A ℓ → Type _
Trichotomous _<_ = ∀ x y → Tri (x < y) (x ≡ y) (x > y)
  where _>_ = flip _<_

-- Generalised maximum element.

Max : RawREL A B ℓ → B → Type _
Max _≤_ T = ∀ x → x ≤ T

-- Maximum element.

Maximum : RawRel A ℓ → A → Type _
Maximum = Max

-- Generalised minimum element.

Min : RawREL A B ℓ → A → Type _
Min R = Max (flip R)

-- Minimum element.

Minimum : RawRel A ℓ → A → Type _
Minimum = Min

-- Unary relations respecting a binary relation.

_⟶_Respects_ : (A → Type ℓ) → (B → Type ℓ′) → RawREL A B ℓ′′ → Type _
P ⟶ Q Respects _∼_ = ∀ {x y} → x ∼ y → P x → Q y

-- Unary relation respects a binary relation.

_Respects_ : (A → Type ℓ) → RawRel A ℓ′ → Type _
P Respects _∼_ = P ⟶ P Respects _∼_

-- Right respecting - relatedness is preserved on the right by some equivalence.

_Respectsʳ_ : RawREL A B ℓ → RawRel B ℓ′ → Type _
_∼_ Respectsʳ _≈_ = ∀ {x} → (x ∼_) Respects _≈_

-- Left respecting - relatedness is preserved on the left by some equivalence.

_Respectsˡ_ : RawREL A B ℓ → RawRel A ℓ′ → Type _
_∼_ Respectsˡ _≈_ = ∀ {y} → (_∼ y) Respects _≈_

-- Respecting - relatedness is preserved on both sides by some equivalence.

_Respects₂_ : RawRel A ℓ → RawRel A ℓ′ → Type _
_∼_ Respects₂ _≈_ = (_∼_ Respectsʳ _≈_) × (_∼_ Respectsˡ _≈_)

-- Substitutivity - any two related elements satisfy exactly the same
-- set of unary relations. Note that only the various derivatives
-- of propositional equality can satisfy this property.

Substitutive : RawRel A ℓ → (ℓ′ : Level) → Type _
Substitutive {A = A} _∼_ p = (P : A → Type p) → P Respects _∼_

-- Decidability - it is possible to determine whether a given pair of
-- elements are related.

Decidable : RawREL A B ℓ → Type _
Decidable _∼_ = ∀ x y → Dec (x ∼ y)

-- Weak decidability - it is sometimes possible to determine if a given
-- pair of elements are related.

WeaklyDecidable : RawREL A B ℓ → Type _
WeaklyDecidable _∼_ = ∀ x y → Maybe (x ∼ y)

-- Universal - all pairs of elements are related

Universal : RawREL A B ℓ → Type _
Universal _∼_ = ∀ x y → x ∼ y

-- Non-emptiness - at least one pair of elements are related.

NonEmpty : RawREL A B ℓ → Type _
NonEmpty _∼_ = ∃[ x ∈ _ ] ∃[ y ∈ _ ] x ∼ y


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

-- | Exclusive option. Exactly one of the options holds at the same time.
module Dodo.Nullary.XOpt where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Relation.Nullary using (¬_; Dec; yes; no)

-- # XOpt₂

data XOpt₂ {a b : Level} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  xopt₁ : ( a :   A) → (¬b : ¬ B) → XOpt₂ A B
  xopt₂ : (¬a : ¬ A) → ( b :   B) → XOpt₂ A B

xopt₂-apply : {a b c : Level} {A : Set a} {B : Set b} {C : Set c}
  → ( A → C )
  → ( B → C )
    -----------------
  → ( XOpt₂ A B → C )
xopt₂-apply f g (xopt₁ a _) = f a
xopt₂-apply f g (xopt₂ _ b) = g b

xopt₂-dec₁ : {a b : Level} {A : Set a} {B : Set b} → XOpt₂ A B → Dec A
xopt₂-dec₁ (xopt₁  a ¬b) = yes a
xopt₂-dec₁ (xopt₂ ¬a  b) = no ¬a

xopt₂-dec₂ : {a b : Level} {A : Set a} {B : Set b} → XOpt₂ A B → Dec B
xopt₂-dec₂ (xopt₁  a ¬b) = no ¬b
xopt₂-dec₂ (xopt₂ ¬a  b) = yes b

xopt₂-elim₁ : {a b : Level} {A : Set a} {B : Set b} → ¬ A → XOpt₂ A B → B
xopt₂-elim₁ ¬a (xopt₁  a ¬b) = ⊥-elim (¬a a)
xopt₂-elim₁ _  (xopt₂ ¬a  b) = b

xopt₂-elim₂ : {a b : Level} {A : Set a} {B : Set b} → ¬ B → XOpt₂ A B → A
xopt₂-elim₂ _  (xopt₁  a ¬b) = a
xopt₂-elim₂ ¬b (xopt₂ ¬a  b) = ⊥-elim (¬b b)

xopt₂-select₁ : {a b : Level} {A : Set a} {B : Set b} → A → XOpt₂ A B → ¬ B
xopt₂-select₁ _ (xopt₁ _ ¬b) = ¬b
xopt₂-select₁ a (xopt₂ ¬a _) = ⊥-elim (¬a a)

xopt₂-select₂ : {a b : Level} {A : Set a} {B : Set b} → B → XOpt₂ A B → ¬ A
xopt₂-select₂ b (xopt₁ _ ¬b) = ⊥-elim (¬b b)
xopt₂-select₂ b (xopt₂ ¬a _) = ¬a

xopt₂-sum : {a b : Level} {A : Set a} {B : Set b} → XOpt₂ A B → A ⊎ B
xopt₂-sum (xopt₁ a _) = inj₁ a
xopt₂-sum (xopt₂ _ b) = inj₂ b

-- # XOpt₃

data XOpt₃ {a b c : Level} (A : Set a) (B : Set b) (C : Set c) : Set (a ⊔ b ⊔ c) where
  xopt₁ : ( a :   A) → (¬b : ¬ B) → (¬c : ¬ C) → XOpt₃ A B C
  xopt₂ : (¬a : ¬ A) → ( b :   B) → (¬c : ¬ C) → XOpt₃ A B C
  xopt₃ : (¬a : ¬ A) → (¬b : ¬ B) → ( c :   C) → XOpt₃ A B C

xopt₃-apply : {a b c d : Level} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
  → ( A → D )
  → ( B → D )
  → ( C → D )
    -------------------
  → ( XOpt₃ A B C → D )
xopt₃-apply f g h (xopt₁ a _ _) = f a
xopt₃-apply f g h (xopt₂ _ b _) = g b
xopt₃-apply f g h (xopt₃ _ _ c) = h c

xopt₃-dec₁ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → XOpt₃ A B C → Dec A
xopt₃-dec₁ (xopt₁  a _ _) = yes  a
xopt₃-dec₁ (xopt₂ ¬a _ _) = no ¬a
xopt₃-dec₁ (xopt₃ ¬a _ _) = no ¬a

xopt₃-dec₂ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → XOpt₃ A B C → Dec B
xopt₃-dec₂ (xopt₁ _ ¬b _) = no ¬b
xopt₃-dec₂ (xopt₂ _  b _) = yes b
xopt₃-dec₂ (xopt₃ _ ¬b _) = no ¬b

xopt₃-dec₃ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → XOpt₃ A B C → Dec C
xopt₃-dec₃ (xopt₁ _ _ ¬c) = no ¬c
xopt₃-dec₃ (xopt₂ _ _ ¬c) = no ¬c
xopt₃-dec₃ (xopt₃ _ _  c) = yes c

xopt₃-elim₁ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → ¬ A → XOpt₃ A B C → XOpt₂ B C
xopt₃-elim₁ ¬a (xopt₁ a  _  _) = ⊥-elim (¬a a)
xopt₃-elim₁ _  (xopt₂ _  b ¬c) = xopt₁  b ¬c
xopt₃-elim₁ _  (xopt₃ _ ¬b  c) = xopt₂ ¬b  c

xopt₃-elim₂ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → ¬ B → XOpt₃ A B C → XOpt₂ A C
xopt₃-elim₂ ¬b (xopt₁  a  _ ¬c) = xopt₁  a ¬c
xopt₃-elim₂ ¬b (xopt₂  _  b  _) = ⊥-elim (¬b b)
xopt₃-elim₂ ¬b (xopt₃ ¬a  _  c) = xopt₂ ¬a  c

xopt₃-elim₃ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → ¬ C → XOpt₃ A B C → XOpt₂ A B
xopt₃-elim₃ _  (xopt₁  a ¬b  _) = xopt₁  a ¬b
xopt₃-elim₃ _  (xopt₂ ¬a  b  _) = xopt₂ ¬a  b
xopt₃-elim₃ ¬c (xopt₃  _  _  c) = ⊥-elim (¬c c)

xopt₃-select₁ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → A → XOpt₃ A B C → ¬ B × ¬ C
xopt₃-select₁ a (xopt₁  _ ¬b ¬c) = ¬b , ¬c
xopt₃-select₁ a (xopt₂ ¬a  _  _) = ⊥-elim (¬a a)
xopt₃-select₁ a (xopt₃ ¬a  _  _) = ⊥-elim (¬a a)

xopt₃-select₂ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → B → XOpt₃ A B C → ¬ A × ¬ C
xopt₃-select₂ b (xopt₁  _ ¬b  _) = ⊥-elim (¬b b)
xopt₃-select₂ b (xopt₂ ¬a  _ ¬c) = ¬a , ¬c
xopt₃-select₂ b (xopt₃  _ ¬b  _) = ⊥-elim (¬b b)

xopt₃-select₃ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → C → XOpt₃ A B C → ¬ A × ¬ B
xopt₃-select₃ c (xopt₁  _  _ ¬c) = ⊥-elim (¬c c)
xopt₃-select₃ c (xopt₂  _  _ ¬c) = ⊥-elim (¬c c)
xopt₃-select₃ c (xopt₃ ¬a ¬b  _) = ¬a , ¬b

xopt₃-select₁₂ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → A → B → XOpt₃ A B C → ⊥
xopt₃-select₁₂ a b x = proj₁ (xopt₃-select₁ a x) b

xopt₃-select₂₃ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → B → C → XOpt₃ A B C → ⊥
xopt₃-select₂₃ b c x = proj₂ (xopt₃-select₂ b x) c

xopt₃-select₁₃ : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → A → C → XOpt₃ A B C → ⊥
xopt₃-select₁₃ a c x = proj₂ (xopt₃-select₁ a x) c

xopt₃-sum : {a b c : Level} {A : Set a} {B : Set b} {C : Set c} → XOpt₃ A B C → A ⊎ B ⊎ C
xopt₃-sum (xopt₁ a _ _) = inj₁ a
xopt₃-sum (xopt₂ _ b _) = inj₂ (inj₁ b)
xopt₃-sum (xopt₃ _ _ c) = inj₂ (inj₂ c)


module _ where

module _ (A : Set) where

  postulate
    F : Set₁ → Set

  {-# POLARITY F ++ #-}

data D : Set where
  d : F D Set → D


------------------------------------------------------------------------
-- The Agda standard library
--
-- Definitions for types of functions that only require an equality
-- relation over the domain.
------------------------------------------------------------------------

-- The contents of this file should usually be accessed from `Function`.

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

open import Relation.Binary

module Function.Definitions.Core1
  {a ℓ₁} {A : Set a} (_≈₁_ : Rel A ℓ₁)
  where

open import Level using (_⊔_)

------------------------------------------------------------------------
-- Definitions

-- (Note the name `RightInverse` is used for the bundle)
Inverseʳ : ∀ {b} {B : Set b} → (A → B) → (B → A) → Set (a ⊔ ℓ₁)
Inverseʳ f g = ∀ x → g (f x) ≈₁ x


open import Categories
open import Monads
import Monads.CatofAdj
import Monads.CatofAdj.TermAdjObj

module Monads.CatofAdj.TermAdjUniq
  {a b}
  {C : Cat {a}{b}}
  (M : Monad C)
  (A : Monads.CatofAdj.ObjAdj M)
  (V : Monads.CatofAdj.HomAdj M A (Monads.CatofAdj.TermAdjObj.EMObj M))
  where

open import Library
open import Functors
open import Adjunctions
open Monads.CatofAdj M
open import Monads.EM M
open Monads.CatofAdj.TermAdjObj M
open import Monads.CatofAdj.TermAdjHom M A
open import Categories.Terminal
open Fun
open Adj
open ObjAdj
open Cat

omaplem : OMap (HomAdj.K EMHom ) ≅ OMap (HomAdj.K V)
omaplem = ext
  λ X → AlgEq (fcong X (cong OMap (HomAdj.Rlaw V)))
    ((ext λ Y →
        dext
        (λ {f} {f'} p →
           trans
           (trans
            (trans
             (stripsubst
               (λ Z → Hom C Z (OMap (R (adj A)) X))
               (HMap (R (adj A)) (right (adj A) f))
               (fcong Y (cong OMap (law A))))
             (cong' refl (cong
                            (λ (F : Obj (D A) → Obj C) →
                               λ (_ : Hom (D A) (OMap (L (adj A)) Y) X) →
                                 Hom C (F (OMap (L (adj A)) Y)) (F X))
                            (cong OMap (HomAdj.Rlaw V)))
                (icong' refl
                 (cong
                  (λ (F : Obj (D A) → Obj C) →
                     λ (z : Obj (D A)) →
                       Hom (D A) (OMap (L (adj A)) Y) z →
                       Hom C (F (OMap (L (adj A)) Y)) (F z))
                  (cong OMap (HomAdj.Rlaw V)))
                 (icong' refl
                  (cong
                   (λ (F : Obj (D A) → Obj C) →
                      λ (z : Obj (D A)) →
                        {Y₁ : Obj (D A)} → Hom (D A) z Y₁ → Hom C (F z) (F Y₁))
                   (cong OMap (HomAdj.Rlaw V)))
                  (cong HMap (HomAdj.Rlaw V)) (refl {x = OMap (L (adj A)) Y}))
                 (refl {x = X}))
                (refl {x = right (adj A) f})))
            (cong₃ (λ A₁ B → AlgMorph.amor  {A₁} {B})
             (fcong Y (cong OMap (HomAdj.Llaw V))) refl
             (HomAdj.rightlaw V {Y} {X} {f})))
           (cong (Alg.astr (OMap (HomAdj.K V) X) Y)
            (trans
             (stripsubst (Hom C Y) f (fcong X (cong OMap (HomAdj.Rlaw V))))
             p)))))

hmaplem : {X Y : Obj (D A)} (f : Hom (D A) X Y) →
          HMap (HomAdj.K EMHom) f ≅ HMap (HomAdj.K V) f
hmaplem {X}{Y} f = AlgMorphEq'
  (fcong X omaplem)
  (fcong Y omaplem)
  (cong'
    refl
    (cong
      (λ (F : Obj (D A) → Obj C) → λ (_ : Hom (D A) X Y) → Hom C (F X) (F Y))
      (cong OMap (HomAdj.Rlaw V)))
    (icong'
      refl
      (cong
        (λ (F : Obj (D A) → Obj C) → λ (z : Obj (D A)) →
           Hom (D A) X z → Hom C (F X) (F z))
        (cong OMap (HomAdj.Rlaw V)))
      (icong'
        refl
        (cong
          (λ (F : Obj (D A) → Obj C) → λ (z : Obj (D A)) → {Y₁ : Obj (D A)} →
             Hom (D A) z Y₁ → Hom C (F z) (F Y₁))
          (cong OMap (HomAdj.Rlaw V)))
        (cong HMap (HomAdj.Rlaw V))
        (refl {x = X}))
      (refl {x = Y}))
    (refl {x = f}))


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

open import Base
open import Homotopy.Pointed
open import Homotopy.Connected

module Homotopy.Cover.HomotopyGroupSetIsomorphism {i}
  (A⋆ : pType i) (A⋆-is-conn : is-connected⋆ ⟨0⟩ A⋆) where
  open pType A⋆ renaming (∣_∣ to A ; ⋆ to a)

  open import Algebra.Groups
  open import Homotopy.Truncation
  open import Homotopy.HomotopyGroups {i}
  open import Homotopy.PathTruncation
  open import Homotopy.Cover.Def A
  open import Homotopy.Cover.Ribbon A⋆

  private
    module G = group (fundamental-group A⋆)
  open import Algebra.GroupSets (fundamental-group A⋆)

  {-
      Isomorphism between pi1(A)-sets and coverings.
  -}

  gset⇒covering : gset → covering
  gset⇒covering gset[ _ , act , _ ] = cov[ ribbon act , ribbon-is-set ]

  covering⇒action : ∀ cov → action (covering.fiber cov a)
  covering⇒action cov = act[ tracing cov , (λ _ → refl) , compose-tracing cov ]

  covering⇒gset : covering → gset
  covering⇒gset cov = let open covering cov in
    gset[ fiber a , covering⇒action cov , fiber-is-set a ]

  -- The first direction: covering -> gset -> covering

  -- From 0-connectedness we can get a (-1)-truncated base path.
  -- The challenge is to get this path.
  abstract
    [base-path] : ∀ a₂ → [ a ≡ a₂ ]
    [base-path] = connected-has-all-τ-paths A⋆-is-conn a

  -- Part 1: Show that the generated cover (ribbon) is fiberwisely
  --         equivalent to the original fiber.
  private
    module _ (cov : covering) where

      -- Suppose that we get the path, we can compute the ribbon easily.
      fiber+path⇒ribbon : ∀ a₂ (y : covering.fiber cov a₂) (p : a ≡ a₂)
        → ribbon (covering⇒action cov) a₂
      fiber+path⇒ribbon a₂ y p = trace (tracing cov y (proj $ ! p)) (proj p)

      abstract
        -- Our construction is "constant" with respect to paths.
        fiber+path⇒ribbon-is-path-irrelevant : ∀ a₂
          (y : covering.fiber cov a₂) (p₁ p₂ : a ≡ a₂)
          → fiber+path⇒ribbon a₂ y p₁ ≡ fiber+path⇒ribbon a₂ y p₂
        fiber+path⇒ribbon-is-path-irrelevant .a y p refl =
          trace (tracing cov y (proj $ ! p)) (proj p)
            ≡⟨ paste y (proj $ ! p) (proj p) ⟩
          trace y (proj $ (! p ∘ p))
            ≡⟨ ap (λ x → trace y (proj x)) $ opposite-left-inverse p ⟩∎
          trace y refl₀
            ∎

      -- Call the magical factorization library.
      open import Homotopy.Extensions.ToPropToConstSet

      -- Now we can read the (-1)-truncated path.
      fiber+path₋₁⇒ribbon : ∀ a₂ (y : covering.fiber cov a₂)
        → [ a ≡ a₂ ] → ribbon (covering⇒action cov) a₂
      fiber+path₋₁⇒ribbon a₂ y = cst-extend
        ⦃ ribbon-is-set a₂ ⦄
        (fiber+path⇒ribbon a₂ y)
        (fiber+path⇒ribbon-is-path-irrelevant a₂ y)

  -- So the conversion from fiber to ribbon is done.
  fiber⇒ribbon : ∀ cov a₂ → covering.fiber cov a₂ → ribbon (covering⇒action cov) a₂
  fiber⇒ribbon cov a₂ y = fiber+path₋₁⇒ribbon cov a₂ y $ [base-path] a₂

  -- The other direction is easy.
  ribbon⇒fiber : ∀ cov a₂ → ribbon (covering⇒action cov) a₂ → covering.fiber cov a₂
  ribbon⇒fiber cov a₂ = let open covering cov in
    ribbon-rec-nondep a₂ (fiber a₂) ⦃ fiber-is-set a₂ ⦄ (tracing cov) (compose-tracing cov)

  private
    -- Some routine computations.
    abstract
      ribbon⇒fiber⇒ribbon : ∀ cov a₂ r → fiber⇒ribbon cov a₂ (ribbon⇒fiber cov a₂ r) ≡ r
      ribbon⇒fiber⇒ribbon cov a₂ = ribbon-rec a₂
        (λ r → fiber⇒ribbon cov a₂ (ribbon⇒fiber cov a₂ r) ≡ r)
        ⦃ λ _ → ≡-is-set $ ribbon-is-set a₂ ⦄
        (λ y p → []-extend
          -- All ugly things will go away when bp = proj bp′
          ⦃ λ bp → ribbon-is-set a₂
                    (fiber+path₋₁⇒ribbon cov a₂ (tracing cov y p) bp)
                    (trace y p) ⦄
          (lemma a₂ y p)
          ([base-path] a₂))
        (λ _ _ _ → prop-has-all-paths (ribbon-is-set a₂ _ _) _ _)
        where
          abstract
            lemma : ∀ a₂ (y : covering.fiber cov a) (p : a ≡₀ a₂) (bp : a ≡ a₂)
              → trace {act = covering⇒action cov}
                  (tracing cov (tracing cov y p) (proj $ ! bp)) (proj bp)
              ≡ trace y p
            lemma .a y p refl =
              trace (tracing cov y p) refl₀
                ≡⟨ paste y p refl₀ ⟩
              trace y (p ∘₀ refl₀)
                ≡⟨ ap (trace y) $ refl₀-right-unit p ⟩∎
              trace y p
                ∎

      fiber⇒ribbon⇒fiber : ∀ cov a₂ y → ribbon⇒fiber cov a₂ (fiber⇒ribbon cov a₂ y) ≡ y
      fiber⇒ribbon⇒fiber cov a₂ y = let open covering cov in []-extend
        -- All ugly things will go away when bp = proj bp′
        ⦃ λ bp → fiber-is-set a₂
                  (ribbon⇒fiber cov a₂
                    (fiber+path₋₁⇒ribbon cov a₂ y bp))
                  y ⦄
        (lemma a₂ y)
        ([base-path] a₂)
        where
          abstract
            lemma : ∀ a₂ (y : covering.fiber cov a₂) (bp : a ≡ a₂)
              → tracing cov (tracing cov y (proj $ ! bp)) (proj bp)
              ≡ y
            lemma .a y refl = refl

  covering⇒gset⇒covering : ∀ cov → gset⇒covering (covering⇒gset cov) ≡ cov
  covering⇒gset⇒covering cov = covering-eq $ funext λ a₂
    → eq-to-path $ ribbon⇒fiber cov a₂ , iso-is-eq
        (ribbon⇒fiber cov a₂)
        (fiber⇒ribbon cov a₂)
        (fiber⇒ribbon⇒fiber cov a₂)
        (ribbon⇒fiber⇒ribbon cov a₂)

  -- The second direction : gset -> covering -> gset

  -- Part 2.1: The fiber over the point a is the carrier.
  ribbon-a⇒Y : ∀ {Y} {act : action Y} ⦃ _ : is-set Y ⦄ → ribbon act a → Y
  ribbon-a⇒Y {Y} {act} ⦃ Y-is-set ⦄ = let open action act in
    ribbon-rec-nondep a Y ⦃ Y-is-set ⦄ _∙_ assoc

  ribbon-a≃Y : ∀ {Y} {act : action Y} ⦃ _ : is-set Y ⦄ → ribbon act a ≃ Y
  ribbon-a≃Y {Y} {act} ⦃ Y-is-set ⦄ = let open action act in
    ribbon-a⇒Y ⦃ Y-is-set ⦄ , iso-is-eq _
      (λ y → trace y refl₀)
      (λ y → right-unit y)
      (ribbon-rec a
        (λ r → trace (ribbon-a⇒Y ⦃ Y-is-set ⦄ r) refl₀ ≡ r)
        ⦃ λ _ → ≡-is-set $ ribbon-is-set a ⦄
        (λ y p →
          trace (y ∙ p) refl₀
            ≡⟨ paste y p refl₀ ⟩
          trace y (p G.∙ refl₀)
            ≡⟨ ap (trace y) $ G.right-unit p ⟩∎
          trace y p
            ∎)
        (λ _ _ _ → prop-has-all-paths (ribbon-is-set a _ _) _ _))

  private
    -- Some lemmas to simplify the proofs.
    trans-eq-∙ : ∀ {Y₁ Y₂ : Set i} (Y≃ : Y₁ ≃ Y₂) (_∙_ : Y₁ → G.carrier → Y₁) (y₂ : Y₂) (g : G.carrier)
      → transport (λ Y → Y → G.carrier → Y) (eq-to-path Y≃) _∙_ y₂ g ≡ (Y≃ ☆ (inverse Y≃ y₂ ∙ g))
    trans-eq-∙ = equiv-induction
      (λ {Y₁ Y₂ : Set i} (Y≃ : Y₁ ≃ Y₂)
        → ∀ (_∙_ : Y₁ → G.carrier → Y₁) (y₂ : Y₂) (g : G.carrier)
        → transport (λ Y → Y → G.carrier → Y) (eq-to-path Y≃) _∙_ y₂ g ≡ (Y≃ ☆ (inverse Y≃ y₂ ∙ g)))
      (λ Y _∙_ y₂ g → ap (λ x → transport (λ Y → Y → G.carrier → Y) x _∙_ y₂ g)
                         $ path-to-eq-right-inverse refl)

  gset⇒covering⇒gset : ∀ gs → covering⇒gset (gset⇒covering gs) ≡ gs
  gset⇒covering⇒gset gset[ Y , act , Y-is-set ] =
    let
      open action act
      _⊙_ = tracing cov[ ribbon act , ribbon-is-set {Y} {act} ]
      ≃Y = ribbon-a≃Y ⦃ Y-is-set ⦄
      ⇒Y = ribbon-a⇒Y ⦃ Y-is-set ⦄
    in gset-eq
        (eq-to-path ≃Y)
        (funext λ y → funext $ π₀-extend ⦃ λ _ → ≡-is-set Y-is-set ⦄ λ p →
          transport (λ Y → Y → G.carrier → Y) (eq-to-path ≃Y) _⊙_ y (proj p)
            ≡⟨ trans-eq-∙ ≃Y _⊙_ y (proj p) ⟩
          ⇒Y (transport (ribbon act) p (trace y refl₀))
            ≡⟨ ap ⇒Y $ trans-trace act p y refl₀ ⟩∎
          y ∙ proj p
            ∎)

  -- Finally...

  gset-covering-eq : gset ≃ covering
  gset-covering-eq = gset⇒covering , iso-is-eq _ covering⇒gset
                        covering⇒gset⇒covering
                        gset⇒covering⇒gset

  {-
      Universality of the covering generated by the fundamental group itself.
  -}

  -- FIXME What's the established terminology for this?
  canonical-gset : gset
  canonical-gset = record
    { carrier = G.carrier
    ; act     = record
      { _∙_        = _∘₀_
      ; right-unit = refl₀-right-unit
      ; assoc      = concat₀-assoc
      }
    ; set     = π₀-is-set (a ≡ a)
    }

  -- FIXME What's the established terminology for this?
  canonical-covering : covering
  canonical-covering = gset⇒covering canonical-gset

  private
    module Universality where
      open covering canonical-covering
      open gset canonical-gset

      center′ : Σ A fiber
      center′ = (a , trace {act = act} refl₀ refl₀)

      center : τ ⟨1⟩ (Σ A fiber)
      center = proj center′

      private
        -- An ugly lemma for this development only
        trans-fiber≡cst-proj-Σ-eq : ∀ {i} (P : Set i) (Q : P → Set i)
          (a : P) (c : Σ P Q) {b₁ b₂} (p : b₁ ≡ b₂) (q : a ≡ π₁ c)
          (r : transport Q q b₁ ≡ π₂ c)
          → transport (λ r → (a , r) ≡₀ c) p (proj $ Σ-eq q r)
          ≡ proj (Σ-eq q (ap (transport Q q) (! p) ∘ r))
        trans-fiber≡cst-proj-Σ-eq P Q a c refl q r = refl

      abstract
        path-trace-fiber : ∀ {a₂} y (p : a ≡ a₂)
          → transport fiber (! p ∘ ! y) (trace (proj y) (proj p))
          ≡ trace refl₀ refl₀
        path-trace-fiber y refl =
          transport fiber (! y) (trace (proj y) refl₀)
            ≡⟨ trans-trace act (! y) (proj y) refl₀ ⟩
          trace (proj y) (proj $ ! y)
            ≡⟨ paste refl₀ (proj y) (proj $ ! y) ⟩
          trace refl₀ (proj $ y ∘ ! y)
            ≡⟨ ap (trace refl₀ ◯ proj) $ opposite-right-inverse y ⟩∎
          trace refl₀ refl₀
            ∎

      path-trace : ∀ {a₂} y p → (a₂ , trace {act = act} y p) ≡₀ center′
      path-trace {a₂} =
        π₀-extend ⦃ λ y → Π-is-set λ p → π₀-is-set ((a₂ , trace y p) ≡ center′) ⦄
          (λ y → π₀-extend ⦃ λ p → π₀-is-set ((a₂ , trace (proj y) p) ≡ center′) ⦄
            (λ p → proj $ Σ-eq (! p ∘ ! y) (path-trace-fiber y p)))

      abstract
        path-paste′ : ∀ {a₂} y loop p
          → transport (λ r → (a₂ , r) ≡₀ center′) (paste (proj y) (proj loop) (proj p))
              (path-trace (proj $ y ∘ loop) (proj p))
          ≡ path-trace (proj y) (proj $ loop ∘ p)
        path-paste′ y loop refl =
          transport (λ r → (a , r) ≡₀ center′) (paste (proj y) (proj loop) refl₀)
            (proj $ Σ-eq (! (y ∘ loop)) (path-trace-fiber (y ∘ loop) refl))
              ≡⟨ trans-fiber≡cst-proj-Σ-eq A fiber a center′
                    (paste (proj y) (proj loop) refl₀)
                    (! (y ∘ loop)) (path-trace-fiber (y ∘ loop) refl) ⟩
          proj (Σ-eq (! (y ∘ loop)) _)
              ≡⟨ ap proj $
                  ap2 (λ p q → Σ-eq p q)
                    (! (y ∘ loop)
                      ≡⟨ opposite-concat y loop ⟩
                    ! loop ∘ ! y
                      ≡⟨ ap (λ x → ! x ∘ ! y) $ ! $ refl-right-unit loop ⟩∎
                    ! (loop ∘ refl) ∘ ! y
                      ∎)
                    (prop-has-all-paths (ribbon-is-set a _ _) _ _) ⟩∎
          proj (Σ-eq (! (loop ∘ refl) ∘ ! y) (path-trace-fiber y (loop ∘ refl)))
              ∎

      abstract
        path-paste : ∀ {a₂} y loop p
          → transport (λ r → (a₂ , r) ≡₀ center′) (paste y loop p)
              (path-trace (y ∘₀ loop) p)
          ≡ path-trace y (loop ∘₀ p)
        path-paste {a₂} =
          π₀-extend ⦃ λ y → Π-is-set λ loop → Π-is-set λ p → ≡-is-set $ π₀-is-set _ ⦄
            (λ y → π₀-extend ⦃ λ loop → Π-is-set λ p → ≡-is-set $ π₀-is-set _ ⦄
              (λ loop → π₀-extend ⦃ λ p → ≡-is-set $ π₀-is-set _ ⦄
                (λ p → path-paste′ y loop p)))

      path′ : (y : Σ A fiber) → proj {n = ⟨1⟩} y ≡ center
      path′ y = τ-path-equiv-path-τ-S {n = ⟨0⟩} ☆
        ribbon-rec {act = act} (π₁ y)
          (λ r → (π₁ y , r) ≡₀ center′)
          ⦃ λ r → π₀-is-set ((π₁ y , r) ≡ center′) ⦄
          path-trace
          path-paste
          (π₂ y)

      path : (y : τ ⟨1⟩ (Σ A fiber)) → y ≡ center
      path = τ-extend {n = ⟨1⟩} ⦃ λ _ → ≡-is-truncated ⟨1⟩ $ τ-is-truncated ⟨1⟩ _ ⦄ path′

  canonical-covering-is-universal : is-universal canonical-covering
  canonical-covering-is-universal = Universality.center , Universality.path

  -- The other direction:  If a covering is universal, then the fiber
  -- is equivalent to the fundamental group.
  module _ (cov : covering) (cov-is-universal : is-universal cov) where
    open covering cov
    open action (covering⇒action cov)

    -- We need a point!
    module GiveMeAPoint (center : fiber a) where

      -- Goal: fiber a <-> fundamental group

      fiber-a⇒fg : fiber a → a ≡₀ a
      fiber-a⇒fg y = ap₀ π₁ $ connected-has-all-τ-paths
        cov-is-universal (a , center) (a , y)

      fg⇒fiber-a : a ≡₀ a → fiber a
      fg⇒fiber-a = tracing cov center

      fg⇒fiber-a⇒fg : ∀ p → fiber-a⇒fg (fg⇒fiber-a p) ≡ p
      fg⇒fiber-a⇒fg = π₀-extend ⦃ λ _ → ≡-is-set $ π₀-is-set _ ⦄ λ p →
        ap₀ π₁ (connected-has-all-τ-paths
          cov-is-universal (a , center) (a , transport fiber p center))
            ≡⟨ ap (ap₀ π₁)
                  $ ! $ π₂ (connected-has-connected-paths cov-is-universal _ _)
                           (proj $ Σ-eq p refl) ⟩
        ap₀ π₁ (proj $ Σ-eq p refl)
            ≡⟨ ap proj $ base-path-Σ-eq p refl ⟩∎
        proj p
            ∎

      fiber-a⇒fg⇒fiber-a : ∀ y → fg⇒fiber-a (fiber-a⇒fg y) ≡ y
      fiber-a⇒fg⇒fiber-a y = π₀-extend
        ⦃ λ p → ≡-is-set {x = tracing cov center (ap₀ π₁ p)} {y = y}
                  $ fiber-is-set a ⦄
        (λ p →
          transport fiber (base-path p) center
            ≡⟨ trans-base-path p ⟩∎
          y
            ∎)
        (connected-has-all-τ-paths cov-is-universal (a , center) (a , y))

      fiber-a≃fg : fiber a ≃ (a ≡₀ a)
      fiber-a≃fg = fiber-a⇒fg , iso-is-eq _ fg⇒fiber-a
        fg⇒fiber-a⇒fg fiber-a⇒fg⇒fiber-a

    -- This is the best we can obtain, because there is no continuous
    -- choice of the center.
    [center] : [ fiber a ]
    [center] = τ-extend-nondep
      ⦃ prop-is-gpd []-is-prop ⦄
      (λ y → []-extend-nondep
        ⦃ []-is-prop ⦄
        (proj ◯ λ p → transport fiber p (π₂ y))
        (connected-has-all-τ-paths A⋆-is-conn (π₁ y) a))
      (π₁ cov-is-universal)

    -- [ isomorphism between the fiber and the fundamental group ]
    -- This is the best we can obtain, because there is no continuous
    -- choice of the center.
    [fiber-a≃fg] : [ fiber a ≃ (a ≡₀ a) ]
    [fiber-a≃fg] = []-extend-nondep ⦃ []-is-prop ⦄
      (proj ◯ GiveMeAPoint.fiber-a≃fg) [center]


------------------------------------------------------------------------
-- The delay monad defined as the greatest fixpoint of an indexed
-- container
------------------------------------------------------------------------

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

module Indexed-container.Delay-monad where

open import Equality.Propositional as E using (_≡_; refl)
open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

open import Bijection E.equality-with-J as Bijection using (_↔_)
open import Function-universe E.equality-with-J as F hiding (_∘_)

open import Delay-monad
open import Delay-monad.Bisimilarity as B

open import Indexed-container
open import Indexed-container.Combinators as C hiding (_∘_)
open import Relation

-- A container for the delay monad.

DelayC : ∀ {ℓ} → Type ℓ → Container (↑ ℓ ⊤) (↑ ℓ ⊤)
DelayC A =
  (λ _ → Maybe A) ◁ λ { (just _) _ → ⊥; nothing _ → ↑ _ ⊤ }

-- An alternative definition.

DelayC′ : ∀ {ℓ} → Type ℓ → Container (↑ ℓ ⊤) (↑ ℓ ⊤)
DelayC′ A = C.id ⊕ C.const (λ _ → A)

-- The two containers' interpretations are pointwise logically
-- equivalent, and in the presence of extensionality they are
-- pointwise isomorphic.

⟦DelayC⟧↔⟦DelayC′⟧ :
  ∀ {k a x} {A : Type a} {X : Rel x (↑ a ⊤)} {i} →
  Extensionality? k a (a ⊔ x) →
  ⟦ DelayC A ⟧ X i ↝[ k ] ⟦ DelayC′ A ⟧ X i
⟦DelayC⟧↔⟦DelayC′⟧ {k} {a} {A = A} {X} {i} ext =
  ⟦ DelayC A ⟧ X i                                              ↔⟨⟩
  (∃ λ (s : Maybe A) → Container.Position (DelayC A) s ⊆ X)     ↝⟨ Σ-cong (inverse Bijection.↑↔ ⊎-cong F.id)
                                                                     [ (λ _ → implicit-∀-cong ext $
                                                                              Π-cong (lower-extensionality? k lzero a ext) lemma λ _ →
                                                                              F.id)
                                                                     , (λ _ → F.id)
                                                                     ] ⟩
  (∃ λ (s : ↑ _ ⊤ ⊎ A) → [ (λ _ → _ ≡_) , (λ _ _ → ⊥) ] s ⊆ X)  ↔⟨⟩
  ⟦ DelayC′ A ⟧ X i                                             □
  where
  lemma : ↑ a ⊤ ↔ lift {ℓ = a} tt ≡ lift tt
  lemma = record
    { surjection = record
      { logical-equivalence = record
        { to = λ _ → refl
        }
      ; right-inverse-of = λ { refl → refl }
      }
    ; left-inverse-of = λ _ → refl
    }

-- An unfolding lemma.

νDelayC↔ : ∀ {k a i} {A : Type a} →
           Extensionality? k a a →
           ν (DelayC A) i _ ↝[ k ] A ⊎ ν′ (DelayC A) i _
νDelayC↔ {i = i} {A} ext =
  ν (DelayC A) i _                           ↔⟨⟩

  ⟦ DelayC  A ⟧ (ν′ (DelayC A) i) _          ↝⟨ ⟦DelayC⟧↔⟦DelayC′⟧ ext ⟩

  ⟦ DelayC′ A ⟧ (ν′ (DelayC A) i) _          ↔⟨ ⟦⊕⟧↔ C.id (C.const (λ _ → A)) ⟩

  ⟦ C.id ⟧ (ν′ (DelayC A) i) _ ⊎
  ⟦ C.const (λ _ → A) ⟧ (ν′ (DelayC A) i) _  ↝⟨ ⟦id⟧↔ ext ⊎-cong ⟦const⟧↔ _ ext ⟩

  ν′ (DelayC A) i _ ⊎ A                      ↔⟨ ⊎-comm ⟩□

  A ⊎ ν′ (DelayC A) i _                      □

-- There is a (size-preserving) logical equivalence between the direct
-- definition of the delay monad and an indirect definition using the
-- container DelayC and ν.

mutual

  Delay⇔νDelayC : ∀ {a i} {A : Type a} → Delay A i ⇔ ν (DelayC A) i _
  Delay⇔νDelayC {i = i} {A} =
    Delay A i              ↔⟨ Delay↔ ⟩
    A ⊎ Delay′ A i         ↝⟨ F.id ⊎-cong Delay′⇔ν′DelayC ⟩
    A ⊎ ν′ (DelayC A) i _  ↝⟨ inverse $ νDelayC↔ _ ⟩□
    ν (DelayC A) i _       □

  Delay′⇔ν′DelayC :
    ∀ {a i} {A : Type a} → Delay′ A i ⇔ ν′ (DelayC A) i _
  Delay′⇔ν′DelayC = record
    { to   = λ x → λ { .force → _⇔_.to   Delay⇔νDelayC (force x) }
    ; from = λ x → λ { .force → _⇔_.from Delay⇔νDelayC (force x) }
    }

-- The two components of Delay⇔νDelayC {i = ∞} are inverses up to
-- (strong) bisimilarity.

Delay⇔νDelayC-inverses :
  ∀ {a} {A : Type a} →
  let to   = _⇔_.to   (Delay⇔νDelayC {i = ∞})
      from = _⇔_.from (Delay⇔νDelayC {i = ∞})
  in
  (∀ x → ν-bisimilar ∞ (to (from x) , x))
    ×
  (∀ x → [ ∞ ] from (to x) ∼ x)
Delay⇔νDelayC-inverses {A = A} = to∘from , from∘to
  where
  to : ∀ {i} → Delay A i → ν (DelayC A) i _
  to = _⇔_.to Delay⇔νDelayC

  from : ∀ {i} → ν (DelayC A) i _ → Delay A i
  from = _⇔_.from Delay⇔νDelayC

  abstract

    from∘to : ∀ {i} x → [ i ] from (to x) ∼ x
    from∘to (now x)   = now x ∎
    from∘to (later x) = later λ { .force →
      from (to (force x))  ∼⟨ from∘to (force x) ⟩∼
      force x              ∎ }

    to∘from : ∀ {i} x → ν-bisimilar i (to (from x) , x)
    to∘from x@(just _ , _) =
      _⇔_.from (ν-bisimilar↔ _ (to (from x)) x)
        ( refl
        , λ ()
        )
    to∘from x@(nothing , f) =
      _⇔_.from (ν-bisimilar↔ _ (to (from x)) x)
        ( refl
        , λ p → λ { .force → to∘from (force (f p)) }
        )

-- There is an isomorphism between the direct definition of the delay
-- monad and an indirect definition using the container DelayC and ν
-- (assuming three kinds of extensionality).

Delay↔νDelayC :
  ∀ {a} {A : Type a} →
  E.Extensionality a a →
  B.Extensionality a →
  ν′-extensionality (DelayC A) →
  Delay A ∞ ↔ ν (DelayC A) ∞ _
Delay↔νDelayC ext ∼-ext ν′-ext = record
  { surjection = record
    { logical-equivalence = Delay⇔νDelayC
    ; right-inverse-of    = ν-extensionality ext ν′-ext ∘
                            proj₁ Delay⇔νDelayC-inverses
    }
  ; left-inverse-of = ∼-ext ∘ proj₂ Delay⇔νDelayC-inverses
  }