open import FRP.JS.Level using ( Level ; _⊔_ ) renaming ( zero to o ; suc to ↑ )
open import FRP.JS.Time using ( Time ; _≤_ ; _<_ )
open import FRP.JS.Bool using ( Bool ; true ; false ; not ; _≟_ )
open import FRP.JS.True using ( True ; tt )

module FRP.JS.Model where

-- This model is essentially System F-omega with a kind time
-- together with a type for the partial order on time,
-- and expressions for reflexivity and transitivity.
-- We prove parametricity, and then show that parametricity implies causality.

-- Note that this is a "deep" notion of causality, not the "shallow"
-- causality usually used in FRP. The pragmatic upshot of this is that
-- there is only one time model: nested signals are in the same time
-- model, not a simulated time model. This fits with the JS implementation,
-- which uses wall clock time for all signals.

-- Propositional equality

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

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

trans : ∀ {α} {A : Set α} {a b c : A} → (a ≡ b) → (b ≡ c) → (a ≡ c)
trans refl refl = refl

cong : ∀ {α β} {A : Set α} {B : Set β} (f : A → B) {a₁ a₂ : A} →
  (a₁ ≡ a₂) → (f a₁ ≡ f a₂)
cong f refl = refl

apply : ∀ {α β} {A : Set α} {B : Set β} {F G : A → B} → (F ≡ G) →
  ∀ {a b} → (a ≡ b) → (F a ≡ G b)
apply refl refl = refl

cast : ∀ {α} {A B : Set α} → (A ≡ B) → A → B
cast refl a = a

cast² : ∀ {α} {A B : Set α} {ℜ ℑ : A → B → Set α} → (ℜ ≡ ℑ) → ∀ {a b} → ℜ a b → ℑ a b
cast² refl aℜb = aℜb

irrel : ∀ b → (b₁ b₂ : True b) → (b₁ ≡ b₂)
irrel true  tt tt = refl
irrel false () ()

-- Postulates (including dependent extensionality)

data _≤?_ (t u : Time) : Set where
  leq : True (t ≤ u) → (t ≤? u)
  geq : True (u ≤ t) → (t ≤? u)

postulate
  ≤-refl : ∀ t → True (t ≤ t)
  ≤-trans : ∀ t u v → True (t ≤ u) → True (u ≤ v) → True (t ≤ v)
  ≤-asym : ∀ t u → True (t ≤ u) → True (u ≤ t) → (t ≡ u)
  ≤-total : ∀ t u → (t ≤? u)
  dext : ∀ {α β} {A : Set α} {B : A → Set β} {F G : ∀ a → B a} → (∀ a → F a ≡ G a) → (F ≡ G)

ext : ∀ {α β} {A : Set α} {B : Set β} {F G : A → B} →
  (∀ a → F a ≡ G a) → (F ≡ G)
ext = dext

iext : ∀ {α β} {A : Set α} {B : A → Set β} {F G : ∀ {a} → B a} →
  (∀ a → F {a} ≡ G {a}) → ((λ {a} → F {a}) ≡ (λ {a} → G {a}))
iext F≈G = cong (λ X {a} → X a) (dext F≈G)

-- Finite products

record ⊤ {α} : Set α where
  constructor tt

open ⊤ public

record Σ {α β} (A : Set α) (B : A → Set β) : Set (α ⊔ β) where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

_×_ : ∀ {α β} → Set α → Set β → Set (α ⊔ β)
A × B = Σ A (λ a → B)

_×²_ : ∀ {α β} {A C : Set α} {B D : Set β} →
  (A → C → Set α) → (B → D → Set β) → ((A × B) → (C × D) → Set (α ⊔ β))
(ℜ ×² ℑ) (a , b) (c , d) = (ℜ a c × ℑ b d)

_→²_ : ∀ {α β} {A C : Set α} {B D : Set β} →
  (A → C → Set α) → (B → D → Set β) → ((A → B) → (C → D) → Set (α ⊔ β))
(ℜ →² ℑ) f g = ∀ {a b} → ℜ a b → ℑ (f a) (g b)

-- Case on booleans

data Case (c : Bool) : Set where
  _,_ : ∀ b → True (b ≟ c) → Case c

switch : ∀ b → Case b
switch true  = (true , tt)
switch false = (false , tt)

-- Reactive sets

RSet : ∀ α → Set (↑ α)
RSet α = Time → Set α

-- Equalitional reasoning

infix  4 _IsRelatedTo_
infix  2 _∎
infixr 2 _≡⟨_⟩_
infix  1 begin_

data _IsRelatedTo_ {α} {A : Set α} (a b : A) : Set α where
  relTo : (a≡b : a ≡ b) → a IsRelatedTo b

begin_ : ∀ {α} {A : Set α} {a b : A} → a IsRelatedTo b → a ≡ b
begin relTo a≡b = a≡b

_≡⟨_⟩_ : ∀ {α} {A : Set α} a {b c : A} → a ≡ b → b IsRelatedTo c → a IsRelatedTo c
_ ≡⟨ a≡b ⟩ relTo b≡c = relTo (trans a≡b b≡c)

_∎ : ∀ {α} {A : Set α} (a : A) → a IsRelatedTo a
_∎ _ = relTo refl

-- Kinds

data Kind : Set where
  time : Kind
  set : Level → Kind
  _⇒_ : Kind → Kind → Kind

level : Kind → Level
level time    = o
level (set α) = ↑ α
level (K ⇒ L) = level K ⊔ level L

K⟦_⟧ : ∀ K → Set (level K)
K⟦ time ⟧  = Time
K⟦ set α ⟧ = Set α
K⟦ K ⇒ L ⟧ = K⟦ K ⟧ → K⟦ L ⟧

_∋_↔_ : ∀ K → K⟦ K ⟧ → K⟦ K ⟧ → Set (level K)
time    ∋ t ↔ u = (t ≡ u)
set α   ∋ A ↔ B = A → B → Set α
(K ⇒ L) ∋ F ↔ G = ∀ {A B} → (K ∋ A ↔ B) → (L ∋ F A ↔ G B)

-- ≡ can be used as a structural equivalence on relations.

struct : ∀ K {A B C D} → (A ≡ B) → (K ∋ B ↔ D) → (C ≡ D) → (K ∋ A ↔ C)
struct K refl ℜ refl = ℜ

struct-ext : ∀ K L {A B} {F G H I : K⟦ K ⇒ L ⟧}
  (F≈G : ∀ A → F A ≡ G A) (ℜ : (K ⇒ L) ∋ G ↔ I) (H≈I : ∀ B → H B ≡ I B) (ℑ : K ∋ A ↔ B) →
    struct L (F≈G A) (ℜ ℑ) (H≈I B) ≡ struct (K ⇒ L) (ext F≈G) ℜ (ext H≈I) ℑ
struct-ext K L {A} {B} F≈G ℜ H≈I ℑ
 with ext F≈G | ext H≈I | F≈G A | H≈I B
... | refl    | refl    | refl  | refl = refl

struct-apply : ∀ K L {F G H I A B C D} →
  (F≡G : F ≡ G) (ℜ : (K ⇒ L) ∋ G ↔ I) (H≡I : H ≡ I) →
  (A≡B : A ≡ B) (ℑ : K ∋ B ↔ D) (C≡D : C ≡ D) →
    struct (K ⇒ L) F≡G ℜ H≡I (struct K A≡B ℑ C≡D)
      ≡ struct L (apply F≡G A≡B) (ℜ ℑ) (apply H≡I C≡D)
struct-apply K L refl ℜ refl refl ℑ refl = refl

struct-cast : ∀ {α A B C D} (ℜ : set α ∋ B ↔ D) (A≡B : A ≡ B) (C≡D : C ≡ D) {a c} →
  struct (set α) A≡B ℜ C≡D a c → ℜ (cast A≡B a) (cast C≡D c)
struct-cast ℜ refl refl aℜc = aℜc

struct-sym : ∀ K {A B C D ℑ ℜ} → (A≡B : A ≡ B) → (C≡D : C ≡ D) →
  (ℑ ≡ struct K A≡B ℜ C≡D) →
    (ℜ ≡ struct K (sym A≡B) ℑ (sym C≡D))
struct-sym K refl refl refl = refl

struct-trans : ∀ K {A B C D E F}
  (A≡B : A ≡ B) (B≡C : B ≡ C) (ℜ : K ∋ C ↔ F) (E≡F : E ≡ F) (D≡E : D ≡ E) →
    struct K A≡B (struct K B≡C ℜ E≡F) D≡E ≡
      struct K (trans A≡B B≡C) ℜ (trans D≡E E≡F)
struct-trans K refl refl ℜ refl refl = refl

-- Type contexts

infixr 4 _∷_

data Kinds : Set where
  [] : Kinds
  _∷_ : Kind → Kinds → Kinds

levels : Kinds → Level
levels []      = o
levels (K ∷ Σ) = level K ⊔ levels Σ

Σ⟦_⟧ : ∀ Σ → Set (levels Σ)
Σ⟦ [] ⟧    = ⊤
Σ⟦ K ∷ Σ ⟧ = K⟦ K ⟧ × Σ⟦ Σ ⟧

_∋_↔*_ : ∀ Σ → Σ⟦ Σ ⟧ → Σ⟦ Σ ⟧ → Set (levels Σ)
[]      ∋ tt       ↔* tt       = ⊤
(K ∷ Σ) ∋ (A , As) ↔* (B , Bs) = (K ∋ A ↔ B) × (Σ ∋ As ↔* Bs)

-- Inclusion order on type contexts.
-- Credited by Randy Pollack to Geuvers and Nederhof, JAR 1991.
-- http://thread.gmane.org/gmane.comp.lang.agda/3259/focus=3267

data _⊑_ : Kinds → Kinds → Set where
  id : ∀ {Σ} → Σ ⊑ Σ
  keep : ∀ K {Σ Υ} → (Σ ⊑ Υ) → ((K ∷ Σ) ⊑ (K ∷ Υ))
  skip : ∀ K {Σ Υ} → (Σ ⊑ Υ) → (Σ ⊑ (K ∷ Υ))

⊑⟦_⟧ : ∀ {Σ Υ} → (Σ ⊑ Υ) → Σ⟦ Υ ⟧ → Σ⟦ Σ ⟧
⊑⟦ id ⟧         As       = As
⊑⟦ keep K Σ⊑Υ ⟧ (A , As) = (A , ⊑⟦ Σ⊑Υ ⟧ As)
⊑⟦ skip K Σ⊑Υ ⟧ (A , As) = ⊑⟦ Σ⊑Υ ⟧ As

⊑⟦_⟧² : ∀ {Σ Υ} → (Σ⊑Υ : Σ ⊑ Υ) → ∀ {As Bs} → (Υ ∋ As ↔* Bs) → (Σ ∋ ⊑⟦ Σ⊑Υ ⟧ As ↔* ⊑⟦ Σ⊑Υ ⟧ Bs)
⊑⟦ id ⟧²         ℜs       = ℜs
⊑⟦ keep K Σ⊑Υ ⟧² (ℜ , ℜs) = (ℜ , ⊑⟦ Σ⊑Υ ⟧² ℜs)
⊑⟦ skip K Σ⊑Υ ⟧² (ℜ , ℜs) = ⊑⟦ Σ⊑Υ ⟧² ℜs

-- Concatenation of type contexts

_++_ : Kinds → Kinds → Kinds
[]      ++ Υ = Υ
(K ∷ Σ) ++ Υ = K ∷ (Σ ++ Υ)

_∋_++_∋_ : ∀ Σ → Σ⟦ Σ ⟧ → ∀ Υ → Σ⟦ Υ ⟧ → Σ⟦ Σ ++ Υ ⟧
[]      ∋ tt       ++ Υ ∋ Bs = Bs
(K ∷ Σ) ∋ (A , As) ++ Υ ∋ Bs = (A , (Σ ∋ As ++ Υ ∋ Bs))

_∋_++²_∋_ : ∀ Σ {As Bs} → (Σ ∋ As ↔* Bs) → ∀ Υ {Cs Ds} → (Υ ∋ Cs ↔* Ds) →
  ((Σ ++ Υ) ∋ (Σ ∋ As ++ Υ ∋ Cs) ↔* (Σ ∋ Bs ++ Υ ∋ Ds))
[]      ∋ tt       ++² Υ ∋ ℑs = ℑs
(K ∷ Σ) ∋ (ℜ , ℜs) ++² Υ ∋ ℑs = (ℜ , (Σ ∋ ℜs ++² Υ ∋ ℑs))

-- Type variables

data TVar (K : Kind) : Kinds → Set where
  zero : ∀ {Σ} → TVar K (K ∷ Σ)
  suc : ∀ {L Σ} → TVar K Σ → TVar K (L ∷ Σ)

τ⟦_⟧ : ∀ {Σ K} (τ : TVar K Σ) → Σ⟦ Σ ⟧ → K⟦ K ⟧
τ⟦ zero ⟧  (A , As)  = A
τ⟦ suc τ ⟧ (A , As)  = τ⟦ τ ⟧ As

τ⟦_⟧² : ∀ {Σ K} (τ : TVar K Σ) {As Bs} → (Σ ∋ As ↔* Bs) → (K ∋ τ⟦ τ ⟧ As ↔ τ⟦ τ ⟧ Bs)
τ⟦ zero ⟧²  (ℜ , ℜs)  = ℜ
τ⟦ suc τ ⟧² (ℜ , ℜs)  = τ⟦ τ ⟧² ℜs

-- Type constants

data TConst : Kind → Set where
  prod fun : ∀ {α β} → TConst (set α ⇒ (set β ⇒ set (α ⊔ β)))
  leq : TConst (time ⇒ (time ⇒ set o))
  univ : ∀ K {α} → TConst ((K ⇒ set α) ⇒ set (level K ⊔ α))

C⟦_⟧ : ∀ {K} → (TConst K) → K⟦ K ⟧
C⟦ prod ⟧   = λ A B → (A × B)
C⟦ fun ⟧    = λ A B → (A → B)
C⟦ leq ⟧    = λ t u → True (t ≤ u)
C⟦ univ K ⟧ = λ F → ∀ A → F A

C⟦_⟧² : ∀ {K} (C : TConst K) → (K ∋ C⟦ C ⟧ ↔ C⟦ C ⟧)
C⟦ prod ⟧²   = λ ℜ ℑ → (ℜ ×² ℑ)
C⟦ fun ⟧²    = λ ℜ ℑ → (ℜ →² ℑ)
C⟦ leq ⟧²    = λ _ _ _ _ → ⊤
C⟦ univ K ⟧² = λ ℜ f g → ∀ {a b} ℑ → ℜ ℑ (f a) (g b)

-- Types

data Typ (Σ : Kinds) : Kind → Set where
  const : ∀ {K} → TConst K → Typ Σ K
  abs : ∀ K {L} → Typ (K ∷ Σ) L → Typ Σ (K ⇒ L)
  app : ∀ {K L} → Typ Σ (K ⇒ L) → Typ Σ K → Typ Σ L
  var : ∀ {K} → TVar K Σ → Typ Σ K

tlevel : ∀ {Σ α} → Typ Σ (set α) → Level
tlevel {Σ} {α} T = α

T⟦_⟧ : ∀ {Σ K} (T : Typ Σ K) → Σ⟦ Σ ⟧ → K⟦ K ⟧
T⟦ const C ⟧ As  = C⟦ C ⟧
T⟦ abs K T ⟧ As  = λ A → T⟦ T ⟧ (A , As)
T⟦ app T U ⟧ As  = T⟦ T ⟧ As (T⟦ U ⟧ As)
T⟦ var τ ⟧ As    = τ⟦ τ ⟧ As

T⟦_⟧² : ∀ {Σ K} (T : Typ Σ K) {As Bs} → (Σ ∋ As ↔* Bs) → (K ∋ T⟦ T ⟧ As ↔ T⟦ T ⟧ Bs)
T⟦ const C ⟧² ℜs  = C⟦ C ⟧²
T⟦ abs K T ⟧² ℜs  = λ ℜ → T⟦ T ⟧² (ℜ , ℜs)
T⟦ app T U ⟧² ℜs  = T⟦ T ⟧² ℜs (T⟦ U ⟧² ℜs)
T⟦ var τ ⟧² ℜs    = τ⟦ τ ⟧² ℜs

-- Type shorthands

app₂ :  ∀ {Σ K L M} → Typ Σ (K ⇒ (L ⇒ M)) → Typ Σ K → Typ Σ L → Typ Σ M
app₂ T U V = app (app T U) V

capp :  ∀ {Σ K L} → TConst (K ⇒ L) → Typ Σ K → Typ Σ L
capp C = app (const C)

capp₂ :  ∀ {Σ K L M} → TConst (K ⇒ (L ⇒ M)) → Typ Σ K → Typ Σ L → Typ Σ M
capp₂ C = app₂ (const C)

_⊗_ : ∀ {Σ α β} → Typ Σ (set α) → Typ Σ (set β) → Typ Σ (set (α ⊔ β))
_⊗_ = capp₂ prod

_⊸_ : ∀ {Σ α β} → Typ Σ (set α) → Typ Σ (set β) → Typ Σ (set (α ⊔ β))
_⊸_ = capp₂ fun

_≼_ : ∀ {Σ} → Typ Σ time → Typ Σ time → Typ Σ (set o)
_≼_ = capp₂ leq

Π : ∀ {Σ α} K → Typ (K ∷ Σ) (set α) → Typ Σ (set (level K ⊔ α))
Π K T = capp (univ K) (abs K T)

tvar₀ : ∀ {Σ K} → Typ (K ∷ Σ) K
tvar₀ = var zero

tvar₁ : ∀ {Σ K L} → Typ (L ∷ K ∷ Σ) K
tvar₁ = var (suc zero)

tvar₂ : ∀ {Σ K L M} → Typ (M ∷ L ∷ K ∷ Σ) K
tvar₂ = var (suc (suc zero))

tvar₃ : ∀ {Σ K L M N} → Typ (N ∷ M ∷ L ∷ K ∷ Σ) K
tvar₃ = var (suc (suc (suc zero)))

rset : Level → Kind
rset α = time ⇒ set α

rset₀ : Kind
rset₀ = rset o

prodʳ : ∀ {Σ α β} → Typ Σ (rset α ⇒ (rset β ⇒ rset (α ⊔ β)))
prodʳ {Σ} {α} {β} = abs (rset α) (abs (rset β) (abs time (app tvar₂ tvar₀ ⊗ app tvar₁ tvar₀)))

_⊗ʳ_ : ∀ {Σ α β} → Typ Σ (rset α) → Typ Σ (rset β) → Typ Σ (rset (α ⊔ β))
_⊗ʳ_ = app₂ prodʳ

funʳ : ∀ {Σ α β} → Typ Σ (rset α ⇒ (rset β ⇒ rset (α ⊔ β)))
funʳ {Σ} {α} {β} = abs (rset α) (abs (rset β) (abs time (app tvar₂ tvar₀ ⊸ app tvar₁ tvar₀)))

_⊸ʳ_ : ∀ {Σ α β} → Typ Σ (rset α) → Typ Σ (rset β) → Typ Σ (rset (α ⊔ β))
_⊸ʳ_ = app₂ funʳ

always : ∀ {Σ α} → Typ Σ (set α ⇒ rset α)
always {Σ} {α} = abs (set α) (abs time tvar₁)

interval : ∀ {Σ α} → Typ Σ (rset α ⇒ (time ⇒ (time ⇒ set α)))
interval {Σ} {α} = abs (rset α) (abs time (abs time (Π time
  ((tvar₂ ≼ tvar₀) ⊸ ((tvar₀ ≼ tvar₁) ⊸ app tvar₃ tvar₀)))))

_[_,_] : ∀ {Σ α} → Typ Σ (rset α) → Typ Σ time → Typ Σ time → Typ Σ (set α)
T [ t , u ] = app (app (app interval T) t) u

constreq : ∀ {Σ α β} → Typ Σ (rset α ⇒ (rset β ⇒ rset (α ⊔ β)))
constreq {Σ} {α} {β} = abs (rset α) (abs (rset β) (abs time (Π time
  ((tvar₁ ≼ tvar₀) ⊸ ((tvar₃ [ tvar₁ , tvar₀ ]) ⊸ app tvar₂ tvar₀)))))

_⊵_ : ∀ {Σ α β} → Typ Σ (rset α) → Typ Σ (rset β) → Typ Σ (rset (α ⊔ β))
T ⊵ U = app₂ constreq T U

-- Contexts

data Typs (Σ : Kinds) : Set where
  [] : Typs Σ
  _∷_ : ∀ {α} → (Typ Σ (set α)) → Typs Σ → Typs Σ

tlevels : ∀ {Σ} → Typs Σ → Level
tlevels []       = o
tlevels (T ∷ Γ) = tlevel T ⊔ tlevels Γ

Γ⟦_⟧ : ∀ {Σ} (Γ : Typs Σ) → Σ⟦ Σ ⟧ → Set (tlevels Γ)
Γ⟦ [] ⟧    As = ⊤
Γ⟦ T ∷ Γ ⟧ As = T⟦ T ⟧ As × Γ⟦ Γ ⟧ As

Γ⟦_⟧² : ∀ {Σ} (Γ : Typs Σ) {As Bs} (ℜs : Σ ∋ As ↔* Bs) → (Γ⟦ Γ ⟧ As → Γ⟦ Γ ⟧ Bs → Set (tlevels Γ))
Γ⟦ [] ⟧²    ℜs tt       tt       = ⊤
Γ⟦ T ∷ Γ ⟧² ℜs (a , as) (b , bs) = T⟦ T ⟧² ℜs a b × Γ⟦ Γ ⟧² ℜs as bs

-- Weakening of type variables

τweaken : ∀ {Σ Υ K} → (Σ ⊑ Υ) → TVar K Σ → TVar K Υ
τweaken id           x       = x
τweaken (keep K Σ⊑Υ) zero    = zero
τweaken (keep K Σ⊑Υ) (suc x) = suc (τweaken Σ⊑Υ x)
τweaken (skip K Σ⊑Υ) x       = suc (τweaken Σ⊑Υ x)

τweaken⟦_⟧ : ∀ {Σ Υ K} (τ : TVar K Σ) (Σ⊑Υ : Σ ⊑ Υ) (As : Σ⟦ Υ ⟧) →
  τ⟦ τ ⟧ (⊑⟦ Σ⊑Υ ⟧ As) ≡ τ⟦ τweaken Σ⊑Υ τ ⟧ As
τweaken⟦ τ ⟧     id           As       = refl
τweaken⟦ zero ⟧  (keep K Σ⊑Υ) (A , As) = refl
τweaken⟦ suc τ ⟧ (keep K Σ⊑Υ) (A , As) = τweaken⟦ τ ⟧ Σ⊑Υ As
τweaken⟦ τ ⟧     (skip K Σ⊑Υ) (A , As) = τweaken⟦ τ ⟧ Σ⊑Υ As

τweaken⟦_⟧² : ∀ {Σ Υ K} (τ : TVar K Σ) (Σ⊑Υ : Σ ⊑ Υ) {As Bs} (ℜs : Υ ∋ As ↔* Bs) →
  τ⟦ τ ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs) ≡
    struct K (τweaken⟦ τ ⟧ Σ⊑Υ As) (τ⟦ τweaken Σ⊑Υ τ ⟧² ℜs) (τweaken⟦ τ ⟧ Σ⊑Υ Bs)
τweaken⟦ τ ⟧²     id           ℜs       = refl
τweaken⟦ zero ⟧²  (keep K Σ⊑Υ) (ℜ , ℜs) = refl
τweaken⟦ suc τ ⟧² (keep K Σ⊑Υ) (ℜ , ℜs) = τweaken⟦ τ ⟧² Σ⊑Υ ℜs
τweaken⟦ τ ⟧²     (skip K Σ⊑Υ) (ℜ , ℜs) = τweaken⟦ τ ⟧² Σ⊑Υ ℜs

-- Weakening of types

weaken : ∀ {Σ Υ K} → (Σ ⊑ Υ) → Typ Σ K → Typ Υ K
weaken Σ⊑Υ (const C)  = const C
weaken Σ⊑Υ (abs K T)  = abs K (weaken (keep K Σ⊑Υ) T)
weaken Σ⊑Υ (app T U)  = app (weaken Σ⊑Υ T) (weaken Σ⊑Υ U)
weaken Σ⊑Υ (var τ)    = var (τweaken Σ⊑Υ τ)

weaken⟦_⟧ : ∀ {Σ Υ K} (T : Typ Σ K) (Σ⊑Υ : Σ ⊑ Υ) (As : Σ⟦ Υ ⟧) →
  T⟦ T ⟧ (⊑⟦ Σ⊑Υ ⟧ As) ≡ T⟦ weaken Σ⊑Υ T ⟧ As
weaken⟦ const C ⟧ Σ⊑Υ As = refl
weaken⟦ abs K T ⟧ Σ⊑Υ As = ext (λ A → weaken⟦ T ⟧ (keep K Σ⊑Υ) (A , As))
weaken⟦ app T U ⟧ Σ⊑Υ As = apply (weaken⟦ T ⟧ Σ⊑Υ As) (weaken⟦ U ⟧ Σ⊑Υ As)
weaken⟦ var τ ⟧   Σ⊑Υ As = τweaken⟦ τ ⟧ Σ⊑Υ As

weaken⟦_⟧² : ∀ {Σ Υ K} (T : Typ Σ K) (Σ⊑Υ : Σ ⊑ Υ) {As Bs} (ℜs : Υ ∋ As ↔* Bs) →
  T⟦ T ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs) ≡ struct K (weaken⟦ T ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ T ⟧² ℜs) (weaken⟦ T ⟧ Σ⊑Υ Bs)
weaken⟦ const C ⟧² Σ⊑Υ ℜs = refl
weaken⟦ abs K {L} T ⟧² Σ⊑Υ {As} {Bs} ℜs =
  iext (λ A → iext (λ B → ext (λ ℜ → begin
    T⟦ abs K T ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs) ℜ
  ≡⟨ weaken⟦ T ⟧² (keep K Σ⊑Υ) (ℜ , ℜs) ⟩
    struct L
      (weaken⟦ T ⟧ (keep K Σ⊑Υ) (A , As))
      (T⟦ weaken (keep K Σ⊑Υ) T ⟧² (ℜ , ℜs))
      (weaken⟦ T ⟧ (keep K Σ⊑Υ) (B , Bs))
  ≡⟨ struct-ext K L
       (λ A → weaken⟦ T ⟧ (keep K Σ⊑Υ) (A , As))
       (λ ℜ → T⟦ weaken (keep K Σ⊑Υ) T ⟧² (ℜ , ℜs))
       (λ B → weaken⟦ T ⟧ (keep K Σ⊑Υ) (B , Bs)) ℜ ⟩
    struct (K ⇒ L)
      (weaken⟦ abs K T ⟧ Σ⊑Υ As)
      (T⟦ weaken Σ⊑Υ (abs K T) ⟧² ℜs)
      (weaken⟦ abs K T ⟧ Σ⊑Υ Bs) ℜ
  ∎)))
weaken⟦ app {K} {L} T U ⟧² Σ⊑Υ {As} {Bs} ℜs =
  begin
    T⟦ app T U ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs)
  ≡⟨ cong (T⟦ T ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs)) (weaken⟦ U ⟧² Σ⊑Υ ℜs) ⟩
    T⟦ T ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs)
      (struct K (weaken⟦ U ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ U ⟧² ℜs) (weaken⟦ U ⟧ Σ⊑Υ Bs))
  ≡⟨ cong (λ X → X (struct K (weaken⟦ U ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ U ⟧² ℜs) (weaken⟦ U ⟧ Σ⊑Υ Bs)))
       (weaken⟦ T ⟧² Σ⊑Υ ℜs) ⟩
    (struct (K ⇒ L) (weaken⟦ T ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ T ⟧² ℜs) (weaken⟦ T ⟧ Σ⊑Υ Bs))
      (struct K (weaken⟦ U ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ U ⟧² ℜs) (weaken⟦ U ⟧ Σ⊑Υ Bs))
  ≡⟨ struct-apply K L
       (weaken⟦ T ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ T ⟧² ℜs) (weaken⟦ T ⟧ Σ⊑Υ Bs)
       (weaken⟦ U ⟧ Σ⊑Υ As) (T⟦ weaken Σ⊑Υ U ⟧² ℜs) (weaken⟦ U ⟧ Σ⊑Υ Bs) ⟩
    struct L
      (weaken⟦ app T U ⟧ Σ⊑Υ As)
      (T⟦ weaken Σ⊑Υ (app T U) ⟧² ℜs)
      (weaken⟦ app T U ⟧ Σ⊑Υ Bs)
  ∎
weaken⟦ var τ ⟧² Σ⊑Υ ℜs = τweaken⟦ τ ⟧² Σ⊑Υ ℜs

-- Weakening on type contexts

weakens : ∀ {Σ Υ} → (Σ ⊑ Υ) → Typs Σ → Typs Υ
weakens Σ⊑Υ []      = []
weakens Σ⊑Υ (T ∷ Γ) = weaken Σ⊑Υ T ∷ weakens Σ⊑Υ Γ

weakens⟦_⟧ : ∀ {Σ Υ} (Γ : Typs Σ) (Σ⊑Υ : Σ ⊑ Υ) (As : Σ⟦ Υ ⟧) →
  Γ⟦ Γ ⟧ (⊑⟦ Σ⊑Υ ⟧ As) → Γ⟦ weakens Σ⊑Υ Γ ⟧ As
weakens⟦ [] ⟧    Σ⊑Υ As tt       = tt
weakens⟦ T ∷ Γ ⟧ Σ⊑Υ As (B , Bs) = (cast (weaken⟦ T ⟧ Σ⊑Υ As) B , weakens⟦ Γ ⟧ Σ⊑Υ As Bs)

weakens⟦_⟧² : ∀ {Σ Υ} (Γ : Typs Σ) (Σ⊑Υ : Σ ⊑ Υ) {As Bs} (ℜs : Υ ∋ As ↔* Bs) {as bs} →
  Γ⟦ Γ ⟧² (⊑⟦ Σ⊑Υ ⟧² ℜs) as bs →
  Γ⟦ weakens Σ⊑Υ Γ ⟧² ℜs (weakens⟦ Γ ⟧ Σ⊑Υ As as) (weakens⟦ Γ ⟧ Σ⊑Υ Bs bs)
weakens⟦ [] ⟧²    Σ⊑Υ ℜs tt
  = tt
weakens⟦ T ∷ Γ ⟧² Σ⊑Υ ℜs (aℜb , asℜbs)
  = ( struct-cast (T⟦ weaken Σ⊑Υ T ⟧² ℜs)
        (weaken⟦ T ⟧ Σ⊑Υ _) (weaken⟦ T ⟧ Σ⊑Υ _) (cast² (weaken⟦ T ⟧² Σ⊑Υ ℜs) aℜb)
    , weakens⟦ Γ ⟧² Σ⊑Υ ℜs asℜbs)

-- Susbtitution on type variables under a context

τsubstn+ : ∀ Σ {Υ K L} → TVar K (Σ ++ (L ∷ Υ)) → Typ Υ L → Typ (Σ ++ Υ) K
τsubstn+ []      zero    U = U
τsubstn+ []      (suc τ) U = var τ
τsubstn+ (K ∷ Σ) zero    U = var zero
τsubstn+ (K ∷ Σ) (suc τ) U = weaken (skip K id) (τsubstn+ Σ τ U)

τsubstn+_⟦_⟧⟦_⟧ : ∀ Σ {Υ K L} (τ : TVar K (Σ ++ (L ∷ Υ))) (U : Typ Υ L)
  (As : Σ⟦ Σ ⟧) (Bs : Σ⟦ Υ ⟧) →
    τ⟦ τ ⟧ (Σ ∋ As ++ (L ∷ Υ) ∋ (T⟦ U ⟧ Bs , Bs)) ≡
      T⟦ τsubstn+ Σ τ U ⟧ (Σ ∋ As ++ Υ ∋ Bs)
τsubstn+ []      ⟦ zero  ⟧⟦ U ⟧ tt       Bs = refl
τsubstn+ []      ⟦ suc τ ⟧⟦ U ⟧ tt       Bs = refl
τsubstn+ (K ∷ Σ) ⟦ zero  ⟧⟦ U ⟧ (A , As) Bs = refl
τsubstn+ (K ∷ Σ) ⟦ suc τ ⟧⟦ U ⟧ (A , As) Bs = trans
  (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Bs)
  (weaken⟦ τsubstn+ Σ τ U ⟧ (skip K id) (A , (Σ ∋ As ++ _ ∋ Bs)))

τsubstn+_⟦_⟧⟦_⟧² : ∀ Σ {Υ L K} (τ : TVar K (Σ ++ (L ∷ Υ))) (U : Typ Υ L) {As Bs Cs Ds}
  (ℜs : Σ ∋ As ↔* Bs) → (ℑs : Υ ∋ Cs ↔* Ds) →
    τ⟦ τ ⟧² (Σ ∋ ℜs ++² (L ∷ Υ) ∋ (T⟦ U ⟧² ℑs , ℑs)) ≡
      struct K
        (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Cs)
        (T⟦ τsubstn+ Σ τ U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs) )
        (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ Bs Ds)
τsubstn+ []      ⟦ zero  ⟧⟦ U ⟧² tt       ℑs = refl
τsubstn+ []      ⟦ suc τ ⟧⟦ U ⟧² tt       ℑs = refl
τsubstn+ (J ∷ Σ) ⟦ zero  ⟧⟦ U ⟧² (ℜ , ℜs) ℑs = refl
τsubstn+_⟦_⟧⟦_⟧² (J ∷ Σ) {Υ} {L} {K} (suc τ) U {A , As} {B , Bs} {Cs} {Ds} (ℜ , ℜs) ℑs =
  begin
    τ⟦ τ ⟧² (Σ ∋ ℜs ++² (L ∷ Υ) ∋ (T⟦ U ⟧² ℑs , ℑs))
  ≡⟨ τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧² ℜs ℑs ⟩
    struct K
      (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Cs)
      (T⟦ τsubstn+ Σ τ U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
      (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ Bs Ds)
  ≡⟨ cong (λ X → struct K (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Cs) X (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ Bs Ds))
       (weaken⟦ τsubstn+ Σ τ U ⟧² (skip J id) (ℜ , (Σ ∋ ℜs ++² Υ ∋ ℑs))) ⟩
    struct K
      (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Cs)
      (struct K
        (weaken⟦ τsubstn+ Σ τ U ⟧ (skip J id) (A , (Σ ∋ As ++ Υ ∋ Cs)))
        (T⟦ weaken (skip J id) (τsubstn+ Σ τ U) ⟧² (ℜ , (Σ ∋ ℜs ++² Υ ∋ ℑs)))
        (weaken⟦ τsubstn+ Σ τ U ⟧ (skip J id) (B , (Σ ∋ Bs ++ Υ ∋ Ds))))
      (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ Bs Ds)
  ≡⟨ struct-trans K
       (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Cs)
       (weaken⟦ τsubstn+ Σ τ U ⟧ (skip J id) (A , (Σ ∋ As ++ Υ ∋ Cs)))
       (T⟦ weaken (skip J id) (τsubstn+ Σ τ U) ⟧² (ℜ , (Σ ∋ ℜs ++² Υ ∋ ℑs)))
       (weaken⟦ τsubstn+ Σ τ U ⟧ (skip J id) (B , (Σ ∋ Bs ++ Υ ∋ Ds)))
       (τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ Bs Ds) ⟩
    struct K
      (τsubstn+ (J ∷ Σ) ⟦ suc τ ⟧⟦ U ⟧ (A , As) Cs)
      (T⟦ τsubstn+ (J ∷ Σ) (suc τ) U ⟧² (ℜ , (Σ ∋ ℜs ++² Υ ∋ ℑs)) )
      (τsubstn+ (J ∷ Σ) ⟦ suc τ ⟧⟦ U ⟧ (B , Bs) Ds)
  ∎

-- Substitution on types under a context

substn+ : ∀ Σ {Υ K L} → Typ (Σ ++ (L ∷ Υ)) K → Typ Υ L → Typ (Σ ++ Υ) K
substn+ Σ (const C) U = const C
substn+ Σ (abs K T) U = abs K (substn+ (K ∷ Σ) T U)
substn+ Σ (app S T) U = app (substn+ Σ S U) (substn+ Σ T U)
substn+ Σ (var τ)   U = τsubstn+ Σ τ U

substn+_⟦_⟧⟦_⟧ : ∀ Σ {Υ K L} (T : Typ (Σ ++ (L ∷ Υ)) K) (U : Typ Υ L)
  (As : Σ⟦ Σ ⟧) (Bs : Σ⟦ Υ ⟧) →
    T⟦ T ⟧ (Σ ∋ As ++ (L ∷ Υ) ∋ (T⟦ U ⟧ Bs , Bs)) ≡
      T⟦ substn+ Σ T U ⟧ (Σ ∋ As ++ Υ ∋ Bs)
substn+ Σ ⟦ const C ⟧⟦ U ⟧ As Bs = refl
substn+ Σ ⟦ abs K T ⟧⟦ U ⟧ As Bs = ext (λ A → substn+ K ∷ Σ ⟦ T ⟧⟦ U ⟧ (A , As) Bs)
substn+ Σ ⟦ app S T ⟧⟦ U ⟧ As Bs = apply (substn+ Σ ⟦ S ⟧⟦ U ⟧ As Bs) (substn+ Σ ⟦ T ⟧⟦ U ⟧ As Bs)
substn+ Σ ⟦ var τ   ⟧⟦ U ⟧ As Bs = τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧ As Bs

substn+_⟦_⟧⟦_⟧² : ∀ Σ {Υ L K} (T : Typ (Σ ++ (L ∷ Υ)) K) (U : Typ Υ L) {As Bs Cs Ds}
  (ℜs : Σ ∋ As ↔* Bs) → (ℑs : Υ ∋ Cs ↔* Ds) →
    T⟦ T ⟧² (Σ ∋ ℜs ++² (L ∷ Υ) ∋ (T⟦ U ⟧² ℑs , ℑs)) ≡
      struct K
        (substn+ Σ ⟦ T ⟧⟦ U ⟧ As Cs)
        (T⟦ substn+ Σ T U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs) )
        (substn+ Σ ⟦ T ⟧⟦ U ⟧ Bs Ds)
substn+ Σ ⟦ const C ⟧⟦ U ⟧² ℜs ℑs = refl
substn+_⟦_⟧⟦_⟧² Σ {Υ} {L} (abs J {K} T) U {As} {Bs} {Cs} {Ds} ℜs ℑs =
  iext (λ A → iext (λ B → ext (λ ℜ → begin
    T⟦ abs J T ⟧² (Σ ∋ ℜs ++² (L ∷ Υ) ∋ (T⟦ U ⟧² ℑs , ℑs)) ℜ
  ≡⟨ substn+ (J ∷ Σ) ⟦ T ⟧⟦ U ⟧² (ℜ , ℜs) ℑs ⟩
    struct K
      (substn+ J ∷ Σ ⟦ T ⟧⟦ U ⟧ (A , As) Cs)
      (T⟦ substn+ (J ∷ Σ) T U ⟧² ((J ∷ Σ) ∋ (ℜ , ℜs) ++² Υ ∋ ℑs))
      (substn+ J ∷ Σ ⟦ T ⟧⟦ U ⟧ (B , Bs) Ds)
  ≡⟨ struct-ext J K
       (λ A → substn+ J ∷ Σ ⟦ T ⟧⟦ U ⟧ (A , As) Cs)
       (λ ℜ → T⟦ substn+ (J ∷ Σ) T U ⟧² ((J ∷ Σ) ∋ ℜ , ℜs ++² Υ ∋ ℑs))
       (λ B → substn+ J ∷ Σ ⟦ T ⟧⟦ U ⟧ (B , Bs) Ds) ℜ ⟩
    struct (J ⇒ K)
      (substn+ Σ ⟦ abs J T ⟧⟦ U ⟧ As Cs)
      (T⟦ substn+ Σ (abs J T) U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
      (substn+ Σ ⟦ abs J T ⟧⟦ U ⟧ Bs Ds) ℜ
  ∎)))
substn+_⟦_⟧⟦_⟧² Σ {Υ} {L} (app {J} {K} S T) U {As} {Bs} {Cs} {Ds} ℜs ℑs =
  begin
    T⟦ app S T ⟧² (Σ ∋ ℜs ++² L ∷ Υ ∋ (T⟦ U ⟧² ℑs , ℑs))
  ≡⟨ cong (T⟦ S ⟧² (Σ ∋ ℜs ++² L ∷ Υ ∋ (T⟦ U ⟧² ℑs , ℑs))) (substn+ Σ ⟦ T ⟧⟦ U ⟧² ℜs ℑs) ⟩
    T⟦ S ⟧² (Σ ∋ ℜs ++² L ∷ Υ ∋ (T⟦ U ⟧² ℑs , ℑs))
      (struct J
         (substn+ Σ ⟦ T ⟧⟦ U ⟧ As Cs)
         (T⟦ substn+ Σ T U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
         (substn+ Σ ⟦ T ⟧⟦ U ⟧ Bs Ds))
  ≡⟨ cong (λ X → X (struct J
       (substn+ Σ ⟦ T ⟧⟦ U ⟧ As Cs)
       (T⟦ substn+ Σ T U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
       (substn+ Σ ⟦ T ⟧⟦ U ⟧ Bs Ds)))
       (substn+ Σ ⟦ S ⟧⟦ U ⟧² ℜs ℑs) ⟩
    struct (J ⇒ K)
      (substn+ Σ ⟦ S ⟧⟦ U ⟧ As Cs)
      (T⟦ substn+ Σ S U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
      (substn+ Σ ⟦ S ⟧⟦ U ⟧ Bs Ds)
      (struct J
         (substn+ Σ ⟦ T ⟧⟦ U ⟧ As Cs)
         (T⟦ substn+ Σ T U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
         (substn+ Σ ⟦ T ⟧⟦ U ⟧ Bs Ds))
  ≡⟨ struct-apply J K
       (substn+ Σ ⟦ S ⟧⟦ U ⟧ As Cs)
       (T⟦ substn+ Σ S U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
       (substn+ Σ ⟦ S ⟧⟦ U ⟧ Bs Ds)
       (substn+ Σ ⟦ T ⟧⟦ U ⟧ As Cs)
       (T⟦ substn+ Σ T U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
       (substn+ Σ ⟦ T ⟧⟦ U ⟧ Bs Ds) ⟩
    struct K
      (substn+ Σ ⟦ app S T ⟧⟦ U ⟧ As Cs)
      (T⟦ substn+ Σ (app S T) U ⟧² (Σ ∋ ℜs ++² Υ ∋ ℑs))
      (substn+ Σ ⟦ app S T ⟧⟦ U ⟧ Bs Ds)
  ∎
substn+ Σ ⟦ var τ ⟧⟦ U ⟧² ℜs ℑs = τsubstn+ Σ ⟦ τ ⟧⟦ U ⟧² ℜs ℑs

-- Substitution on types

substn : ∀ {Σ K L} → Typ (L ∷ Σ) K → Typ Σ L → Typ Σ K
substn = substn+ []

substn⟦_⟧⟦_⟧ : ∀ {Σ K L} (T : Typ (L ∷ Σ) K) (U : Typ Σ L) (As : Σ⟦ Σ ⟧)→
  T⟦ T ⟧ (T⟦ U ⟧ As , As) ≡ T⟦ substn T U ⟧ As
substn⟦ T ⟧⟦ U ⟧ = substn+ [] ⟦ T ⟧⟦ U ⟧ tt

substn⟦_⟧⟦_⟧² : ∀ {Σ K L} (T : Typ (L ∷ Σ) K) (U : Typ Σ L) {As Bs} (ℜs : Σ ∋ As ↔* Bs) →
  T⟦ T ⟧² (T⟦ U ⟧² ℜs , ℜs) ≡
    struct K (substn⟦ T ⟧⟦ U ⟧ As) (T⟦ substn T U ⟧² ℜs) (substn⟦ T ⟧⟦ U ⟧ Bs)
substn⟦ T ⟧⟦ U ⟧² = substn+ [] ⟦ T ⟧⟦ U ⟧² tt

-- Eta-beta equivalence on types

data _∋_≣_ {Σ} : ∀ K → Typ Σ K → Typ Σ K → Set where
  abs : ∀ K {L T U} → (L ∋ T ≣ U) → ((K ⇒ L) ∋ abs K T ≣ abs K U)
  app : ∀ {K L F G T U} → ((K ⇒ L) ∋ F ≣ G) → (K ∋ T ≣ U) → (L ∋ app F T ≣ app G U)
  beta : ∀ {K L} T U → (L ∋ app (abs K T) U ≣ substn T U)
  eta : ∀ {K L} T → ((K ⇒ L) ∋ T ≣ abs K (app (weaken (skip K id) T) tvar₀))
  ≣-refl : ∀ {K T} → (K ∋ T ≣ T)
  ≣-sym : ∀ {K T U} → (K ∋ T ≣ U) → (K ∋ U ≣ T)
  ≣-trans : ∀ {K T U V} → (K ∋ T ≣ U) → (K ∋ U ≣ V) → (K ∋ T ≣ V)

≣⟦_⟧ : ∀ {Σ K} {T U : Typ Σ K} → (K ∋ T ≣ U) → ∀ As → T⟦ T ⟧ As ≡ T⟦ U ⟧ As
≣⟦ abs K T≣U ⟧       As = ext (λ A → ≣⟦ T≣U ⟧ (A , As))
≣⟦ app F≣G T≣U ⟧     As = apply (≣⟦ F≣G ⟧ As) (≣⟦ T≣U ⟧ As)
≣⟦ beta T U ⟧        As = substn⟦ T ⟧⟦ U ⟧ As
≣⟦ eta {K} T ⟧       As = ext (λ A → apply (weaken⟦ T ⟧ (skip K id) (A , As)) refl)
≣⟦ ≣-refl ⟧          As = refl
≣⟦ ≣-sym T≣U ⟧       As = sym (≣⟦ T≣U ⟧ As)
≣⟦ ≣-trans T≣U U≣V ⟧ As = trans (≣⟦ T≣U ⟧ As) (≣⟦ U≣V ⟧ As)

≣⟦_⟧² : ∀ {Σ K} {T U : Typ Σ K} (T≣U : K ∋ T ≣ U) {As Bs} (ℜs : Σ ∋ As ↔* Bs) →
  T⟦ T ⟧² ℜs ≡ struct K (≣⟦ T≣U ⟧ As) (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ Bs)
≣⟦ abs K {L} {T} {U} T≣U ⟧² {As} {Bs} ℜs =
  iext (λ A → iext (λ B → ext (λ ℜ → begin
    T⟦ T ⟧² (ℜ , ℜs)
  ≡⟨ ≣⟦ T≣U ⟧² (ℜ , ℜs) ⟩
    struct L (≣⟦ T≣U ⟧ (A , As)) (T⟦ U ⟧² (ℜ , ℜs)) (≣⟦ T≣U ⟧ (B , Bs))
  ≡⟨ struct-ext K L (λ A → ≣⟦ T≣U ⟧ (A , As)) (λ ℜ' → T⟦ U ⟧² (ℜ' , ℜs)) (λ B → ≣⟦ T≣U ⟧ (B , Bs)) ℜ ⟩
    struct (K ⇒ L) (≣⟦ abs K T≣U ⟧ As) (T⟦ abs K U ⟧² ℜs) (≣⟦ abs K T≣U ⟧ Bs) ℜ
  ∎)))
≣⟦ app {K} {L} {F} {G} {T} {U} F≣G T≣U ⟧² {As} {Bs} ℜs =
  begin
    T⟦ app F T ⟧² ℜs
  ≡⟨ cong (T⟦ F ⟧² ℜs) (≣⟦ T≣U ⟧² ℜs) ⟩
    T⟦ F ⟧² ℜs (struct K (≣⟦ T≣U ⟧ As) (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ Bs))
  ≡⟨ cong (λ X → X (struct K (≣⟦ T≣U ⟧ As) (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ Bs)))
       (≣⟦ F≣G ⟧² ℜs) ⟩
    struct (K ⇒ L) (≣⟦ F≣G ⟧ As) (T⟦ G ⟧² ℜs) (≣⟦ F≣G ⟧ Bs)
      (struct K (≣⟦ T≣U ⟧ As) (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ Bs))
  ≡⟨ struct-apply K L
       (≣⟦ F≣G ⟧ As) (T⟦ G ⟧² ℜs) (≣⟦ F≣G ⟧ Bs)
       (≣⟦ T≣U ⟧ As) (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ Bs) ⟩
    struct L (≣⟦ app F≣G T≣U ⟧ As) (T⟦ app G U ⟧² ℜs) (≣⟦ app F≣G T≣U ⟧ Bs)
  ∎
≣⟦ beta T U ⟧² ℜs = substn⟦ T ⟧⟦ U ⟧² ℜs
≣⟦ eta {K} {L} T ⟧² {As} {Bs} ℜs = iext (λ A → iext (λ B → ext (λ ℜ →
  begin
    T⟦ T ⟧² ℜs ℜ
  ≡⟨ cong (λ X → X ℜ) (weaken⟦ T ⟧² (skip K id) (ℜ , ℜs)) ⟩
    struct (K ⇒ L)
      (weaken⟦ T ⟧ (skip K id) (A , As))
      (T⟦ weaken (skip K id) T ⟧² (ℜ , ℜs))
      (weaken⟦ T ⟧ (skip K id) (B , Bs)) ℜ
  ≡⟨ struct-apply K L
       (weaken⟦ T ⟧ (skip K id) (A , As))
       (T⟦ weaken (skip K id) T ⟧² (ℜ , ℜs))
       (weaken⟦ T ⟧ (skip K id) (B , Bs)) refl ℜ refl ⟩
    struct L
      (apply (weaken⟦ T ⟧ (skip K id) (A , As)) refl)
      (T⟦ weaken (skip K id) T ⟧² (ℜ , ℜs) ℜ)
      (apply (weaken⟦ T ⟧ (skip K id) (B , Bs)) refl)
  ≡⟨ struct-ext K L
       (λ A → apply (weaken⟦ T ⟧ (skip K id) (A , As)) refl)
       (λ ℜ → T⟦ weaken (skip K id) T ⟧² (ℜ , ℜs) ℜ)
       (λ B → apply (weaken⟦ T ⟧ (skip K id) (B , Bs)) refl) ℜ ⟩
    struct (K ⇒ L)
      (≣⟦ eta T ⟧ As)
      (T⟦ abs K (app (weaken (skip K id) T) (var zero)) ⟧² ℜs)
      (≣⟦ eta T ⟧ Bs) ℜ
  ∎)))
≣⟦ ≣-refl ⟧² ℜs = refl
≣⟦ ≣-sym {K} {T} {U} T≣U ⟧² {As} {Bs} ℜs =
  struct-sym K (≣⟦ T≣U ⟧ As) (≣⟦ T≣U ⟧ Bs) (≣⟦ T≣U ⟧² ℜs)
≣⟦ ≣-trans {K} {T} {U} {V} T≣U U≣V ⟧² {As} {Bs} ℜs =
  begin
    T⟦ T ⟧² ℜs
  ≡⟨ ≣⟦ T≣U ⟧² ℜs ⟩
    struct K (≣⟦ T≣U ⟧ As) (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ Bs)
  ≡⟨ cong (λ X → struct K (≣⟦ T≣U ⟧ As) X (≣⟦ T≣U ⟧ Bs)) (≣⟦ U≣V ⟧² ℜs) ⟩
    struct K (≣⟦ T≣U ⟧ As) (struct K (≣⟦ U≣V ⟧ As) (T⟦ V ⟧² ℜs) (≣⟦ U≣V ⟧ Bs)) (≣⟦ T≣U ⟧ Bs)
  ≡⟨ struct-trans K (≣⟦ T≣U ⟧ As) (≣⟦ U≣V ⟧ As) (T⟦ V ⟧² ℜs) (≣⟦ U≣V ⟧ Bs) (≣⟦ T≣U ⟧ Bs) ⟩
    struct K (≣⟦ ≣-trans T≣U U≣V ⟧ As) (T⟦ V ⟧² ℜs) (≣⟦ ≣-trans T≣U U≣V ⟧ Bs)
  ∎

-- Variables

data Var {Σ : Kinds} {α} (T : Typ Σ (set α)) : Typs Σ → Set where
  zero : ∀ {Γ} → Var T (T ∷ Γ)
  suc : ∀ {β Γ} {U : Typ Σ (set β)} → Var T Γ → Var T (U ∷ Γ)

x⟦_⟧ : ∀ {Σ} {Γ : Typs Σ} {α} {T : Typ Σ (set α)} →
  Var T Γ → (As : Σ⟦ Σ ⟧) → (as : Γ⟦ Γ ⟧ As) → (T⟦ T ⟧ As)
x⟦ zero ⟧  As (a , as) = a
x⟦ suc x ⟧ As (a , as) = x⟦ x ⟧ As as

x⟦_⟧² : ∀ {Σ} {Γ : Typs Σ} {α} {T : Typ Σ (set α)} (x : Var T Γ) →
  ∀ {As Bs} (ℜs : Σ ∋ As ↔* Bs) {as bs} →
    (Γ⟦ Γ ⟧² ℜs as bs) → (T⟦ T ⟧² ℜs (x⟦ x ⟧ As as) (x⟦ x ⟧ Bs bs))
x⟦ zero ⟧²  ℜs (aℜb , asℜbs) = aℜb
x⟦ suc x ⟧² ℜs (aℜb , asℜbs) = x⟦ x ⟧² ℜs asℜbs

-- Constants

data Const {Σ : Kinds} : ∀ {α} → Typ Σ (set α) → Set where
  pair : ∀ {α β} → Const (Π (set α) (Π (set β) (tvar₁ ⊸ (tvar₀ ⊸ (tvar₁ ⊗ tvar₀)))))
  fst : ∀ {α β} → Const (Π (set α) (Π (set β) ((tvar₁ ⊗ tvar₀) ⊸ tvar₁)))
  snd : ∀ {α β} → Const (Π (set α) (Π (set β) ((tvar₁ ⊗ tvar₀) ⊸ tvar₀)))
  ≼-refl : Const (Π time (tvar₀ ≼ tvar₀))
  ≼-trans : Const (Π time (Π time (Π time ((tvar₂ ≼ tvar₁) ⊸ ((tvar₁ ≼ tvar₀) ⊸ (tvar₂ ≼ tvar₀))))))
  ≼-antisym : ∀ {α} → Const (Π (rset α) (Π time (Π time ((tvar₁ ≼ tvar₀) ⊸ ((tvar₀ ≼ tvar₁) ⊸ (app tvar₂ tvar₁ ⊸ app tvar₂ tvar₀))))))
  ≼-case : ∀ {α} → Const (Π (set α) (Π time (Π time (((tvar₁ ≼ tvar₀) ⊸ tvar₂) ⊸ (((tvar₀ ≼ tvar₁) ⊸ tvar₂) ⊸ tvar₂)))))

≤-antisym : ∀ {α} (A : RSet α) t u → True (t ≤ u) → True (u ≤ t) → A t → A u
≤-antisym A t u t≤u u≤t a with ≤-asym t u t≤u u≤t
≤-antisym A t .t _   _  a | refl = a

≤-case′ : ∀ {α} {A : Set α} {t u} → (t ≤? u) → (True (t ≤ u) → A) → (True (u ≤ t) → A) → A
≤-case′ (leq t≤u) f g = f t≤u
≤-case′ (geq u≤t) f g = g u≤t

≤-case : ∀ {α} (A : Set α) t u → (True (t ≤ u) → A) → (True (u ≤ t) → A) → A
≤-case A t u = ≤-case′ (≤-total t u)

c⟦_⟧ : ∀ {Σ} {α} {T : Typ Σ (set α)} →
  Const T → (As : Σ⟦ Σ ⟧) → (T⟦ T ⟧ As)
c⟦ pair ⟧      As = λ A B a b → (a , b)
c⟦ fst ⟧       As = λ A B → proj₁
c⟦ snd ⟧       As = λ A B → proj₂
c⟦ ≼-refl ⟧    As = ≤-refl
c⟦ ≼-trans ⟧   As = ≤-trans
c⟦ ≼-antisym ⟧ As = ≤-antisym
c⟦ ≼-case ⟧    As = ≤-case

c⟦_⟧² : ∀ {Σ} {α} {T : Typ Σ (set α)} (c : Const T) →
  ∀ {As Bs} (ℜs : Σ ∋ As ↔* Bs) →
    (T⟦ T ⟧² ℜs (c⟦ c ⟧ As) (c⟦ c ⟧ Bs))
c⟦ pair ⟧²          ℜs = λ ℜ ℑ aℜb cℑd → (aℜb , cℑd)
c⟦ fst ⟧²           ℜs = λ ℜ ℑ → proj₁
c⟦ snd ⟧²           ℜs = λ ℜ ℑ → proj₂
c⟦ ≼-refl ⟧²        ℜs = _
c⟦ ≼-trans ⟧²       ℜs = _
c⟦ ≼-antisym {α} ⟧² ℜs = lemma where
  lemma : ∀ {α} {A B : RSet α} (ℜ : rset α ∋ A ↔ B) →
    {t u : Time} → (t≡u : t ≡ u) → {v w : Time} → (v≡w : v ≡ w) →
    {t≤v : True (t ≤ v)} {u≤w : True (u ≤ w)} → ⊤ →
    {v≤t : True (v ≤ t)} {w≤u : True (w ≤ u)} → ⊤ →
    {a : A t} {b : B u} → ℜ t≡u a b →
    ℜ v≡w (≤-antisym A t v t≤v v≤t a) (≤-antisym B u w u≤w w≤u b)
  lemma ℜ {t} refl {v} refl {t≤v} {u≤w} tt {v≤t} {w≤u} tt aℜb
    with irrel (t ≤ v) t≤v u≤w | irrel (v ≤ t) v≤t w≤u
  lemma ℜ {t} refl {v} refl {t≤v} tt {v≤t} tt aℜb
    | refl | refl with ≤-asym t v t≤v v≤t
  lemma ℜ refl refl tt tt aℜb
    | refl | refl | refl = aℜb
c⟦ ≼-case {α} ⟧²    ℜs = lemma where
  lemma : ∀ {α} {A B : Set α} (ℜ : set α ∋ A ↔ B) →
    ∀ {t u : Time} → (t≡u : t ≡ u) → ∀ {v w : Time} → (v≡w : v ≡ w) →
    ∀ {f g} → (∀ {t≤v} {u≤w} → ⊤ → ℜ (f t≤v) (g u≤w)) →
    ∀ {h i} → (∀ {v≤t} {w≤u} → ⊤ → ℜ (h v≤t) (i w≤u)) →
    ℜ (≤-case A t v f h) (≤-case B u w g i)
  lemma ℜ {t} refl {v} refl {f} {g} fℜg {h} {i} hℜi = lemma′ (≤-total t v) where
    lemma′ : ∀ t≤?v → ℜ (≤-case′ t≤?v f h) (≤-case′ t≤?v g i)
    lemma′ (leq t≤v) = fℜg {t≤v} {t≤v} tt
    lemma′ (geq v≤t) = hℜi {v≤t} {v≤t} tt

-- Expressions

data Exp {Σ : Kinds} (Γ : Typs Σ) : ∀ {α} → Typ Σ (set α) → Set where
  const : ∀ {α} {T : Typ Σ (set α)} → Const T → Exp Γ T
  abs : ∀ {α β} (T : Typ Σ (set α)) {U : Typ Σ (set β)} (M : Exp (T ∷ Γ) U) → Exp Γ (T ⊸ U)
  app : ∀ {α β} {T : Typ Σ (set α)} {U : Typ Σ (set β)} (M : Exp Γ (T ⊸ U)) (N : Exp Γ T) → Exp Γ U
  var : ∀ {α} {T : Typ Σ (set α)} → Var T Γ → Exp Γ T
  tabs : ∀ K {α} {T : Typ (K ∷ Σ) (set α)} (M : Exp (weakens (skip K id) Γ) T) → Exp Γ (Π K T)
  tapp : ∀ {K α} {T : Typ (K ∷ Σ) (set α)} → Exp Γ (Π K T) → ∀ U → Exp Γ (substn T U)
  eq : ∀ {α T U} → (set α ∋ T ≣ U) → (Exp Γ T) → (Exp Γ U)

ctxt : ∀ {Σ Γ α T} → Exp {Σ} Γ {α} T → Typs Σ
ctxt {Σ} {Γ} M = Γ

M⟦_⟧ : ∀ {Σ} {Γ : Typs Σ} {α} {T : Typ Σ (set α)} →
  Exp Γ T → (As : Σ⟦ Σ ⟧) → (as : Γ⟦ Γ ⟧ As) → (T⟦ T ⟧ As)
M⟦ const c ⟧  As as = c⟦ c ⟧ As
M⟦ abs T M ⟧  As as = λ a → M⟦ M ⟧ As (a , as)
M⟦ app M N ⟧  As as = M⟦ M ⟧ As as (M⟦ N ⟧ As as)
M⟦ var x ⟧    As as = x⟦ x ⟧ As as
M⟦ tabs K M ⟧ As as = λ A →
  M⟦ M ⟧ (A , As) (weakens⟦ ctxt (tabs K M) ⟧ (skip K id) (A , As) as)
M⟦ tapp {T = T} M U ⟧ As as =
  cast (substn⟦ T ⟧⟦ U ⟧ As) (M⟦ M ⟧ As as (T⟦ U ⟧ As))
M⟦ eq T≣U M ⟧ As as = cast (≣⟦ T≣U ⟧ As) (M⟦ M ⟧ As as)

M⟦_⟧² : ∀ {Σ} {Γ : Typs Σ} {α} {T : Typ Σ (set α)} (M : Exp Γ T) →
  ∀ {As Bs} (ℜs : Σ ∋ As ↔* Bs) {as bs} →
    (Γ⟦ Γ ⟧² ℜs as bs) → (T⟦ T ⟧² ℜs (M⟦ M ⟧ As as) (M⟦ M ⟧ Bs bs))
M⟦ const c ⟧²  ℜs asℜbs = c⟦ c ⟧² ℜs
M⟦ abs T M ⟧²  ℜs asℜbs = λ aℜb → M⟦ M ⟧² ℜs (aℜb , asℜbs)
M⟦ app M N ⟧²  ℜs asℜbs = M⟦ M ⟧² ℜs asℜbs (M⟦ N ⟧² ℜs asℜbs)
M⟦ var x  ⟧²   ℜs asℜbs = x⟦ x ⟧² ℜs asℜbs
M⟦ tabs K M ⟧² ℜs asℜbs = λ ℜ →
  M⟦ M ⟧² (ℜ , ℜs) (weakens⟦ ctxt (tabs K M) ⟧² (skip K id) (ℜ , ℜs) asℜbs)
M⟦ tapp {T = T} M U ⟧² ℜs asℜbs =
  struct-cast (T⟦ substn T U ⟧² ℜs) (substn⟦ T ⟧⟦ U ⟧ _) (substn⟦ T ⟧⟦ U ⟧ _)
    (cast² (substn⟦ T ⟧⟦ U ⟧² ℜs) (M⟦ M ⟧² ℜs asℜbs (T⟦ U ⟧² ℜs)))
M⟦ eq {α} {T} {U} T≣U M ⟧² {As} {Bs} ℜs asℜbs =
  struct-cast (T⟦ U ⟧² ℜs) (≣⟦ T≣U ⟧ As) (≣⟦ T≣U ⟧ Bs) (cast² (≣⟦ T≣U ⟧² ℜs) (M⟦ M ⟧² ℜs asℜbs))

-- Types with a chosen free world variable

_∷ʳ_ : Kinds → Kind → Kinds
[]      ∷ʳ K = K ∷ []
(T ∷ Σ) ∷ʳ K = T ∷ (Σ ∷ʳ K)

TVar+ : Kind → Kinds → Set
TVar+ K Σ = TVar K (Σ ∷ʳ rset₀)

Typ+ : Kinds → Kind → Set
Typ+ Σ = Typ (Σ ∷ʳ rset₀)

wvar : ∀ Σ → TVar+ rset₀ Σ
wvar []      = zero
wvar (K ∷ Σ) = suc (wvar Σ)

world : ∀ {Σ} → Typ+ Σ rset₀
world {Σ} = var (wvar Σ)

World : Time → Set
World t = ⊤

taut : ∀ {Σ α} → Typ+ Σ (rset α ⇒ set α)
taut {Σ} {α} = abs (rset α) (Π time
  (app (world {time ∷ rset α ∷ Σ}) tvar₀ ⊸ app tvar₁ tvar₀))

-- Surface types

data STyp : Kind → Set where
  ⟨_⟩ : ∀ {α} → STyp (set α) → STyp (rset α)
  [_] : ∀ {α} → STyp (rset α) → STyp (set α)
  _⊠_ _↦_ : ∀ {α β} → STyp (set α) → STyp (set β) → STyp (set (α ⊔ β))
  _∧_ _⇒_ : ∀ {α β} → STyp (rset α) → STyp (rset β) → STyp (rset (α ⊔ β))
  □ : ∀ {α} → STyp (rset α) → STyp (rset α)

⟪_⟫ : ∀ {K} → STyp K → Typ+ [] K
⟪ ⟨ T ⟩ ⟫ = app always ⟪ T ⟫
⟪ [ T ] ⟫ = app (taut {[]}) ⟪ T ⟫
⟪ T ⊠ U ⟫ = ⟪ T ⟫ ⊗ ⟪ U ⟫
⟪ T ↦ U ⟫ = ⟪ T ⟫ ⊸ ⟪ U ⟫
⟪ T ∧ U ⟫ = ⟪ T ⟫ ⊗ʳ ⟪ U ⟫
⟪ T ⇒ U ⟫ = ⟪ T ⟫ ⊸ʳ ⟪ U ⟫
⟪ □ T ⟫   = tvar₀ ⊵ ⟪ T ⟫

T⟪_⟫ : ∀ {K} → STyp K → K⟦ K ⟧
T⟪ T ⟫ = T⟦ ⟪ T ⟫ ⟧ (World , tt)

-- Signals of T are iso to □ T

Signal : ∀ {α} → RSet α → RSet α
Signal A s = ∀ t → True (s ≤ t) → A t

sig : ∀ {α} (T : STyp (rset α)) s →
  T⟪ □ T ⟫ s → Signal T⟪ T ⟫ s
sig T s σ t s≤t = σ t s≤t _

sig⁻¹ : ∀ {α} (T : STyp (rset α)) s →
  Signal T⟪ T ⟫ s → T⟪ □ T ⟫ s
sig⁻¹ T s σ t s≤t _ = σ t s≤t

sig-iso : ∀ {α} (T : STyp (rset α)) s σ →
  (sig T s (sig⁻¹ T s σ) ≡ σ)
sig-iso T s σ = refl

sig-iso⁻¹ : ∀ {α} (T : STyp (rset α)) s σ →
  (sig⁻¹ T s (sig T s σ) ≡ σ)
sig-iso⁻¹ T s σ = refl

-- Signal functions from T to U are iso to □ T ⇒ □ U

SF : ∀ {α β} → RSet α → RSet β → RSet (α ⊔ β)
SF A B s = Signal A s → Signal B s

sf : ∀ {α β} (T : STyp (rset α)) (U : STyp (rset β)) s →
  T⟪ □ T ⇒ □ U ⟫ s → SF T⟪ T ⟫ T⟪ U ⟫ s
sf T U s f σ = sig U s (f (sig⁻¹ T s σ))

sf⁻¹ : ∀ {α β} (T : STyp (rset α)) (U : STyp (rset β)) s →
   SF T⟪ T ⟫ T⟪ U ⟫ s → T⟪ □ T ⇒ □ U ⟫ s
sf⁻¹ T U s f σ = sig⁻¹ U s (f (sig T s σ))

sf-iso : ∀ {α β} (T : STyp (rset α)) (U : STyp (rset β)) s f →
  (sf T U s (sf⁻¹ T U s f) ≡ f)
sf-iso T U s f = refl

sf-iso⁻¹ : ∀ {α β} (T : STyp (rset α)) (U : STyp (rset β)) s f →
  (sf⁻¹ T U s (sf T U s f) ≡ f)
sf-iso⁻¹ T U s f = refl

-- Causality

mutual

  _at_⊨_≈[_]_ : ∀ {α} (T : STyp (rset α)) s → T⟪ T ⟫ s → Time → T⟪ T ⟫ s → Set α
  ⟨ T ⟩   at s ⊨ a       ≈[ u ] b       = T ⊨ a ≈[ u ] b
  (T ∧ U) at s ⊨ (a , b) ≈[ u ] (c , d) = (T at s ⊨ a ≈[ u ] c) × (U at s ⊨ b ≈[ u ] d)
  (T ⇒ U) at s ⊨ f       ≈[ u ] g       = ∀ a b → (T at s ⊨ a ≈[ u ] b) → (U at s ⊨ f a ≈[ u ] g b)
  □ T     at s ⊨ σ       ≈[ u ] τ       = (∀ t s≤t → True (t ≤ u) → (T at t ⊨ σ t s≤t _ ≈[ u ] τ t s≤t _))

  _⊨_≈[_]_ : ∀ {α} → (T : STyp (set α)) → T⟪ T ⟫ → Time → T⟪ T ⟫ → Set α
  [ T ]   ⊨ σ       ≈[ u ] τ       = ∀ s → True (s ≤ u) → (T at s ⊨ σ s _ ≈[ u ] τ s _)
  (T ⊠ U) ⊨ (a , b) ≈[ u ] (c , d) = (T ⊨ a ≈[ u ] c) × (U ⊨ b ≈[ u ] d)
  (T ↦ U) ⊨ f       ≈[ u ] g       = ∀ a b → (T ⊨ a ≈[ u ] b) → (U ⊨ f a ≈[ u ] g b)

Causal : ∀ {α β} (T : STyp (set α)) (U : STyp (set β)) → T⟪ T ↦ U ⟫ → Set (α ⊔ β)
Causal T U f = ∀ u σ τ →
  (T ⊨ σ ≈[ u ] τ) → (U ⊨ f σ ≈[ u ] f τ)

-- Parametricity implies causality

ℜ[_] : Time → (rset o ∋ World ↔ World)
ℜ[ u ] {t} s≡t tt tt = True (t ≤ u)

mutual

  ℜ-impl-≈_at : ∀ {α} (T : STyp (rset α)) s u → True (s ≤ u) → ∀ a b →
    (T⟦ ⟪ T ⟫ ⟧² (ℜ[ u ] , tt) refl a b) → (T at s ⊨ a ≈[ u ] b)
  ℜ-impl-≈ ⟨ T ⟩   at s u s≤u a b aℜb
    = ℜ-impl-≈ T u a b aℜb
  ℜ-impl-≈ (T ∧ U) at s u s≤u (a , b) (c , d) (aℜc , bℜd)
    = (ℜ-impl-≈ T at s u s≤u a c aℜc , ℜ-impl-≈ U at s u s≤u b d bℜd)
  ℜ-impl-≈ (T ⇒ U) at s u s≤u f g fℜg
    = λ a b a≈b → ℜ-impl-≈ U at s u s≤u (f a) (g b) (fℜg (≈-impl-ℜ T at s u s≤u a b a≈b))
  ℜ-impl-≈_at (□ T) s u s≤u σ τ σℜτ = λ t s≤t t≤u →
    ℜ-impl-≈ T at t u t≤u (σ t s≤t _) (τ t s≤t _)
      (σℜτ refl tt (λ {r} _ _ {r≤t} _ → ≤-trans r t u r≤t t≤u))

  ≈-impl-ℜ_at : ∀ {α} (T : STyp (rset α)) s u → True (s ≤ u) → ∀ a b →
     (T at s ⊨ a ≈[ u ] b) → (T⟦ ⟪ T ⟫ ⟧² (ℜ[ u ] , tt) refl a b)
  ≈-impl-ℜ ⟨ T ⟩   at s u s≤u a b a≈b
    = ≈-impl-ℜ T u a b a≈b
  ≈-impl-ℜ (T ∧ U) at s u s≤u (a , b) (c , d) (a≈c , b≈d)
    = (≈-impl-ℜ T at s u s≤u a c a≈c , ≈-impl-ℜ U at s u s≤u b d b≈d)
  ≈-impl-ℜ (T ⇒ U) at s u s≤u f g f≈g
    = λ {a} {b} aℜb → ≈-impl-ℜ U at s u s≤u (f a) (g b) (f≈g a b (ℜ-impl-≈ T at s u s≤u a b aℜb))
  ≈-impl-ℜ (□ T)   at s u s≤u σ τ σ≈τ = lemma where
    lemma : T⟦ ⟪ □ T ⟫ ⟧² (ℜ[ u ] , tt) {s} refl σ τ
    lemma {t} refl {s≤t} {s≤t′} tt kℜk′ with irrel (s ≤ t) s≤t s≤t′
    lemma {t} refl {s≤t}        tt kℜk′ | refl
      = ≈-impl-ℜ T at t u t≤u (σ t s≤t _) (τ t s≤t _) (σ≈τ t s≤t t≤u) where
        t≤u = kℜk′ {t} refl {s≤t} {s≤t} tt {≤-refl t} {≤-refl t} tt

  ℜ-impl-≈ : ∀ {α} (T : STyp (set α)) (u : Time) (a b : T⟪ T ⟫) →
    (T⟦ ⟪ T ⟫ ⟧² (ℜ[ u ] , tt) a b) → (T ⊨ a ≈[ u ] b)
  ℜ-impl-≈ (T ⊠ U) u (a , b) (c , d) (aℜc , bℜd)
    = (ℜ-impl-≈ T u a c aℜc , ℜ-impl-≈ U u b d bℜd)
  ℜ-impl-≈ (T ↦ U) u f g fℜg
    = λ a b a≈b → ℜ-impl-≈ U u (f a) (g b) (fℜg (≈-impl-ℜ T u a b a≈b))
  ℜ-impl-≈ [ T ] u σ τ σℜτ
    = λ s s≤u → ℜ-impl-≈ T at s u s≤u (σ s _) (τ s _) (σℜτ refl s≤u)

  ≈-impl-ℜ : ∀ {α} (T : STyp (set α)) (u : Time) (a b : T⟪ T ⟫) →
    (T ⊨ a ≈[ u ] b) → (T⟦ ⟪ T ⟫ ⟧² (ℜ[ u ] , tt) a b)
  ≈-impl-ℜ (T ⊠ U) u (a , b) (c , d) (a≈c , b≈d)
    = (≈-impl-ℜ T u a c a≈c , ≈-impl-ℜ U u b d b≈d)
  ≈-impl-ℜ (T ↦ U) u f g f≈g
    = λ {a} {b} aℜb → ≈-impl-ℜ U u (f a) (g b) (f≈g a b (ℜ-impl-≈ T u a b aℜb))
  ≈-impl-ℜ [ T ] u σ τ σ≈τ = lemma where
    lemma : T⟦ ⟪ [ T ] ⟫ ⟧² (ℜ[ u ] , tt) σ τ
    lemma {s} refl s≤u = ≈-impl-ℜ T at s u s≤u (σ s _) (τ s _) (σ≈τ s s≤u)

-- Every F-omega function is causal

causality : ∀ {α β} (T : STyp (set α)) (U : STyp (set β)) (M : Exp [] ⟪ T ↦ U ⟫) →
  Causal T U (M⟦ M ⟧ (World , tt) tt)
causality T U M u
  = ℜ-impl-≈ (T ↦ U) u
      (M⟦ M ⟧ (World , tt) tt)
      (M⟦ M ⟧ (World , tt) tt)
      (M⟦ M ⟧² (ℜ[ u ] , _) tt)


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

open import lib.Basics
open import lib.types.Group
open import lib.types.Lift
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism

module lib.groups.Lift where

Lift-group-structure : ∀ {i j} {A : Type i}
  → GroupStructure A → GroupStructure (Lift {j = j} A)
Lift-group-structure GS = record
  { ident = lift ident
  ; inv = λ {(lift x) → lift (inv x)}
  ; comp = λ {(lift x) (lift y) → lift (comp x y)}
  ; unit-l = λ {(lift y) → ap lift (unit-l y)}
  ; assoc = λ {(lift x) (lift y) (lift z) → ap lift (assoc x y z)}
  ; inv-l = λ {(lift x) → ap lift (inv-l x)}
  }
  where open GroupStructure GS

Lift-group : ∀ {i j} → Group i → Group (lmax i j)
Lift-group {j = j} G = group (Lift {j = j} El) (Lift-level El-level)
                             (Lift-group-structure group-struct)
  where open Group G

lift-hom : ∀ {i j} {G : Group i} → (G →ᴳ Lift-group {j = j} G)
lift-hom = group-hom lift (λ _ _ → idp)

lower-hom : ∀ {i j} {G : Group i} → (Lift-group {j = j} G →ᴳ G)
lower-hom = group-hom lower (λ _ _ → idp)

lift-iso : ∀ {i j} {G : Group i} → (G ≃ᴳ Lift-group {j = j} G)
lift-iso = lift-hom , snd lift-equiv

lower-iso : ∀ {i j} {G : Group i} → (Lift-group {j = j} G ≃ᴳ G)
lower-iso = lower-hom , snd lower-equiv

Lift-group-is-abelian : ∀ {i j} (G : Group i) → is-abelian G → is-abelian (Lift-group {j = j} G)
Lift-group-is-abelian G comm (lift g₁) (lift g₂) = ap lift (comm g₁ g₂)

Lift-abgroup : ∀ {i j} (G : AbGroup i) → AbGroup (lmax i j)
Lift-abgroup {j = j} G = Lift-group {j = j} (AbGroup.grp G)
  , Lift-group-is-abelian (AbGroup.grp G) (AbGroup.comm G)


-- Discrete category over a type A
-- A must be an h-groupoid for the homs to be sets
{-# OPTIONS --safe #-}

module Cubical.Categories.Instances.Discrete where

open import Cubical.Categories.Category.Base
open import Cubical.Categories.Functor.Base
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Transport

private
  variable
    ℓ ℓC ℓC' : Level

open Category

-- Discrete category
DiscreteCategory : hGroupoid ℓ → Category ℓ ℓ
DiscreteCategory A .ob = A .fst
DiscreteCategory A .Hom[_,_] a a' = a ≡ a'
DiscreteCategory A .id = refl
DiscreteCategory A ._⋆_ = _∙_
DiscreteCategory A .⋆IdL f = sym (lUnit f)
DiscreteCategory A .⋆IdR f = sym (rUnit f)
DiscreteCategory A .⋆Assoc f g h = sym (assoc f g h)
DiscreteCategory A .isSetHom {x} {y} = A .snd x y

module _ {A : hGroupoid ℓ}
         {C : Category ℓC ℓC'} where
  open Functor

  -- Functions f: A → ob C give functors F: DiscreteCategory A → C
  DiscFunc : (fst A → ob C) → Functor (DiscreteCategory A) C
  DiscFunc f .F-ob = f
  DiscFunc f .F-hom {x} p = subst (λ z → C [ f x , f z ]) p (id C)
  DiscFunc f .F-id {x} = substRefl {B = λ z → C [ f x , f z ]} (id C)

  -- Preserves composition
  DiscFunc f .F-seq {x} {y} p q =
      let open Category C using () renaming (_⋆_ to _●_) in

      let Hom[fx,f—] = (λ (w : A .fst) → C [ f x , f w ]) in
      let Hom[fy,f—] = (λ (w : A .fst) → C [ f y , f w ]) in
      let id-fx = id C {f x} in
      let id-fy = id C {f y} in
      let Fp = (subst Hom[fx,f—] (p) id-fx) in

      subst Hom[fx,f—] (p ∙ q) id-fx            ≡⟨ substComposite Hom[fx,f—] _ _ _ ⟩
      subst Hom[fx,f—] (q) (Fp)                 ≡⟨ cong (subst _ q) (sym (⋆IdR C _)) ⟩
      subst Hom[fx,f—] (q) (Fp ● id-fy)         ≡⟨ substCommSlice _ _ (λ _ → Fp ●_) q _ ⟩
      Fp ● (subst Hom[fy,f—] (q) id-fy)         ∎


module Structure.Category.Functor.Category where

open import Data.Tuple
open import Function.Equals
import      Lvl
open import Logic
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Category
open import Structure.Category.Functor
open import Structure.Category.NaturalTransformation
open import Structure.Category.NaturalTransformation.Equiv
open import Structure.Category.NaturalTransformation.NaturalTransformations
open import Structure.Categorical.Properties
open import Structure.Operator
open import Syntax.Transitivity
open import Type

module _
  {ℓₗₒ ℓₗₘ ℓₗₑ ℓᵣₒ ℓᵣₘ ℓᵣₑ}
  {catₗ : CategoryObject{ℓₗₒ}{ℓₗₘ}{ℓₗₑ}}
  {catᵣ : CategoryObject{ℓᵣₒ}{ℓᵣₘ}{ℓᵣₑ}}
  where

  open Category ⦃ … ⦄
  open Wrapped

  private open module MorphismEquivₗ {x}{y} = Equiv(CategoryObject.morphism-equiv catₗ {x}{y}) using ()
  private open module MorphismEquivᵣ {x}{y} = Equiv(CategoryObject.morphism-equiv catᵣ {x}{y}) using ()
  private instance _ = CategoryObject.category-instance catₗ
  private instance _ = CategoryObject.category-instance catᵣ

  -- Natural transformations are morphisms on functors.
  functorCategory : Category{Obj = catₗ →ᶠᵘⁿᶜᵗᵒʳ catᵣ} (_→ᴺᵀ_)
  Category._∘_ functorCategory = _∘ᴺᵀ_
  Category.id  functorCategory = idᴺᵀ
  Dependent._⊜_.proof (BinaryOperator.congruence (Category.binaryOperator functorCategory) (Dependent.intro xy1) (Dependent.intro xy2)) = congruence₂(_∘_) xy1 xy2
  Dependent._⊜_.proof (Morphism.Associativity.proof (Category.associativity functorCategory)) = Morphism.associativity(_∘_)
  Dependent._⊜_.proof (Morphism.Identityₗ.proof (left (Category.identity functorCategory)) {F₁} {F₂} {ηᴺᵀ}) {x} =
    ∃.witness (idᴺᵀ ∘ᴺᵀ ηᴺᵀ)(x)                   🝖[ _≡_ ]-[]
    ∃.witness(idᴺᵀ{F = F₂})(x) ∘ ∃.witness ηᴺᵀ(x) 🝖[ _≡_ ]-[]
    id ∘ ∃.witness ηᴺᵀ(x)                         🝖[ _≡_ ]-[ Morphism.identityₗ(_∘_)(id) ]
    ∃.witness ηᴺᵀ(x)                              🝖-end
  Dependent._⊜_.proof (Morphism.Identityᵣ.proof (right (Category.identity functorCategory)) {F₁} {F₂} {ηᴺᵀ}) {x} =
    ∃.witness (ηᴺᵀ ∘ᴺᵀ idᴺᵀ)(x)                   🝖[ _≡_ ]-[]
    ∃.witness ηᴺᵀ(x) ∘ ∃.witness(idᴺᵀ{F = F₁})(x) 🝖[ _≡_ ]-[]
    ∃.witness ηᴺᵀ(x) ∘ id                         🝖[ _≡_ ]-[ Morphism.identityᵣ(_∘_)(id) ]
    ∃.witness ηᴺᵀ(x)                              🝖-end


{-# OPTIONS --universe-polymorphism #-}
module Categories.Equivalence.Strong where

-- Strong equivalence of categories.  Same as ordinary equivalence in Cat.
-- May not include everything we'd like to think of as equivalences, namely
-- the full, faithful functors that are essentially surjective on objects.

open import Level
open import Relation.Binary using (IsEquivalence; module IsEquivalence)
open import Function using () renaming (_∘_ to _∙_)

open import Categories.Category
open import Categories.Functor hiding (equiv)
open import Categories.NaturalIsomorphism as NI hiding (equiv)
open import Categories.NaturalTransformation as NT hiding (id; equiv)
open import Categories.Morphisms using (Iso; module Iso)

record WeakInverse {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} (F : Functor C D) (G : Functor D C) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    F∘G≅id : NaturalIsomorphism (F ∘ G) id
    G∘F≅id : NaturalIsomorphism (G ∘ F) id
  F∘G⇒id = NaturalIsomorphism.F⇒G F∘G≅id
  id⇒F∘G = NaturalIsomorphism.F⇐G F∘G≅id
  G∘F⇒id = NaturalIsomorphism.F⇒G G∘F≅id
  id⇒G∘F = NaturalIsomorphism.F⇐G G∘F≅id
  .F∘G-iso : _
  F∘G-iso = NaturalIsomorphism.iso F∘G≅id
  .F∘G-isoˡ : _
  F∘G-isoˡ = λ x → Iso.isoˡ {C = D} (F∘G-iso x)
  .F∘G-isoʳ : _
  F∘G-isoʳ = λ x → Iso.isoʳ {C = D} (F∘G-iso x)
  .G∘F-iso : _
  G∘F-iso = NaturalIsomorphism.iso G∘F≅id
  .G∘F-isoˡ : _
  G∘F-isoˡ = λ x → Iso.isoˡ {C = C} (G∘F-iso x)
  .G∘F-isoʳ : _
  G∘F-isoʳ = λ x → Iso.isoʳ {C = C} (G∘F-iso x)

record StrongEquivalence {o ℓ e o′ ℓ′ e′} (C : Category o ℓ e) (D : Category o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    F : Functor C D
    G : Functor D C
    weak-inverse : WeakInverse F G
  open WeakInverse weak-inverse public

module Equiv where
  refl : ∀ {o ℓ e} {C : Category o ℓ e} → StrongEquivalence C C
  refl = record
    { F = id
    ; G = id
    ; weak-inverse = record
      { F∘G≅id = IsEquivalence.refl NI.equiv
      ; G∘F≅id = IsEquivalence.refl NI.equiv
      }
    }

  sym : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} → StrongEquivalence C D → StrongEquivalence D C
  sym Inv = record
    { F = Inv.G
    ; G = Inv.F
    ; weak-inverse = record
      { F∘G≅id = Inv.G∘F≅id
      ; G∘F≅id = Inv.F∘G≅id
      }
    }
    where
    module Inv = StrongEquivalence Inv

  trans : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂ o₃ ℓ₃ e₃} {C₁ : Category o₁ ℓ₁ e₁} {C₂ : Category o₂ ℓ₂ e₂} {C₃ : Category o₃ ℓ₃ e₃} → StrongEquivalence C₁ C₂ → StrongEquivalence C₂ C₃ → StrongEquivalence C₁ C₃
  trans {C₁ = C₁} {C₂} {C₃} A B = record
    { F = B.F ∘ A.F
    ; G = A.G ∘ B.G
    ; weak-inverse = record
      { F∘G≅id = IsEquivalence.trans NI.equiv ((B.F ⓘˡ A.F∘G≅id) ⓘʳ B.G) B.F∘G≅id
      ; G∘F≅id = IsEquivalence.trans NI.equiv ((A.G ⓘˡ B.G∘F≅id) ⓘʳ A.F) A.G∘F≅id
      }
    }
    where
    module A = StrongEquivalence A
    module B = StrongEquivalence B

equiv : ∀ {o ℓ e} → IsEquivalence (StrongEquivalence {o} {ℓ} {e})
equiv = record { refl = Equiv.refl; sym = Equiv.sym; trans = Equiv.trans }


{-
This second-order signature was created from the following second-order syntax description:

syntax Empty | E

type
  𝟘 : 0-ary

term
  abort : 𝟘  ->  α

theory
  (𝟘η) e : 𝟘  c : α |> abort(e) = c
-}

module Empty.Signature where

open import SOAS.Context

-- Type declaration
data ET : Set where
  𝟘 : ET

open import SOAS.Syntax.Signature ET public
open import SOAS.Syntax.Build ET public

-- Operator symbols
data Eₒ : Set where
  abortₒ : {α : ET} → Eₒ

-- Term signature
E:Sig : Signature Eₒ
E:Sig = sig λ
  { (abortₒ {α}) → (⊢₀ 𝟘) ⟼₁ α
  }

open Signature E:Sig public


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category
open import Categories.Object.BinaryProducts
open import Categories.Object.Exponentiating

module Categories.Object.Exponentiating.Adjunction {o ℓ e}
    (C : Category o ℓ e)
    (binary : BinaryProducts C)
    (Σ : Category.Obj C)
    (exponentiating : Exponentiating C binary Σ) where

open Category C
open BinaryProducts binary
open Exponentiating exponentiating

import Categories.Object.Product
open Categories.Object.Product C

import Categories.Object.Product.Morphisms
open Categories.Object.Product.Morphisms C

open Equiv
open HomReasoning

import Categories.Object.Exponentiating.Functor
open Categories.Object.Exponentiating.Functor C binary Σ exponentiating

open import Categories.Functor
  using (Functor; Contravariant)
  renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_)

open import Categories.Adjunction hiding (_≡_; id)
open import Categories.NaturalTransformation
  using (NaturalTransformation; module NaturalTransformation)
open import Categories.Monad
  using (Monad)

Σ↑-Self-Adjunction : Adjunction (Functor.op Σ↑-Functor) Σ↑-Functor
Σ↑-Self-Adjunction = record
  { unit    = record
      { η       = λ _ → flip id
      ; commute = unit-commute
      }
  ; counit  = record
      { η       = λ _ → flip id
      ; commute = counit-commute
      }
  ; zig     = zig-zag
  ; zag     = zig-zag
  } where
    .lem₁ : ∀{A B C D}{f : (B × C) ⇒ D}{g : A ⇒ (C × B)}
      → (f ∘ swap ∘ second id) ∘ g
      ≡ f ∘ swap ∘ g
    lem₁ {A}{B}{C}{D}{f}{g} =
      begin
        (f ∘ swap ∘ second id) ∘ g
      ↓⟨ (refl ⟩∘⟨ refl ⟩∘⟨ second-id product) ⟩∘⟨ refl ⟩
        (f ∘ swap ∘ id) ∘ g
      ↓⟨ (refl ⟩∘⟨ identityʳ) ⟩∘⟨ refl ⟩
        (f ∘ swap) ∘ g
      ↓⟨ assoc ⟩
        f ∘ swap ∘ g
      ∎

    .lem₂ : ∀ {X Y}{f : X ⇒ Y}
      → eval {Σ↑ Y} ∘ first (flip id ∘ f)
      ≡ eval {X}    ∘ swap ∘ second [Σ↑ f ]
    lem₂ {X}{Y}{f} =
      begin
        eval {Σ↑ Y} ∘ first (flip id ∘ f)
      ↑⟨ refl ⟩∘⟨ first∘first ⟩
        eval {Σ↑ Y} ∘ first (flip id) ∘ first f
      ↑⟨ assoc ⟩
        (eval {Σ↑ Y} ∘ first (flip id)) ∘ first f
      ↓⟨ β ⟩∘⟨ refl ⟩
        (eval {Y} ∘ swap ∘ second id) ∘ first f
      ↓⟨ lem₁ ⟩
        eval {Y} ∘ swap ∘ first f
      ↓⟨ refl ⟩∘⟨ swap∘⁂ ⟩
        eval {Y} ∘ second f ∘ swap
      ↑⟨ assoc ⟩
        (eval {Y} ∘ second f) ∘ swap
      ↑⟨ β ⟩∘⟨ refl ⟩
        (eval {X} ∘ first (λ-abs X (eval {Y} ∘ second f))) ∘ swap
      ↓⟨ assoc ⟩
        eval {X} ∘ first (λ-abs X (eval {Y} ∘ second f)) ∘ swap
      ↑⟨ refl ⟩∘⟨ swap∘⁂ ⟩
        eval {X} ∘ swap ∘ second (λ-abs X (eval ∘ second f))
      ∎

    .unit-commute : ∀ {X Y} (f : X ⇒ Y)
      → flip id ∘ f ≡ [Σ² f ] ∘ flip id
    unit-commute {X}{Y} f =
      begin
        flip id ∘ f
      ↓⟨ λ-unique lem₂ ⟩
        flip [Σ↑ f ]
      ↑⟨ λ-cong lem₁ ⟩
        λ-abs (Σ↑ Y) ((eval {X} ∘ swap ∘ second id) ∘ second [Σ↑ f ])
      ↓⟨ λ-distrib ⟩
        [Σ↑ [Σ↑ f ] ] ∘ flip id
      ∎

    .counit-commute : ∀ {X Y} (f : X ⇒ Y)
      → [Σ² f ] ∘ flip id ≡ flip id ∘ f
    counit-commute f = sym (unit-commute f)

    .zig-zag : ∀{X}
      → id ≡ [Σ↑ flip id ] ∘ flip id
    zig-zag {X} =
      begin
        id
      ↑⟨ flip² ⟩
        flip (flip id)
      ↑⟨ λ-cong lem₁ ⟩
        λ-abs X ((eval ∘ swap ∘ second id) ∘ second (flip id))
      ↓⟨ λ-distrib ⟩
        [Σ↑ flip id ] ∘ flip id
      ∎


module Numeral.Natural.Decidable where

open import Data
open import Data.Boolean
open import Functional
open import Lang.Inspect
open import Logic.Propositional
open import Numeral.Natural
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Relator.Properties
open import Type.Properties.Decidable

module _ where
  open import Numeral.Natural.Oper.Comparisons
  open import Numeral.Natural.Oper.Proofs
  open import Relator.Equals
  open import Relator.Equals.Proofs.Equiv

  instance
    [≡?]-decider : Decider(2)(_≡_)(_≡?_)
    [≡?]-decider {𝟎}   {𝟎}   = true [≡]-intro
    [≡?]-decider {𝟎}   {𝐒 y} = false \()
    [≡?]-decider {𝐒 x} {𝟎}   = false \()
    [≡?]-decider {𝐒 x} {𝐒 y} with (x ≡? y) | [≡?]-decider {x} {y}
    ... | 𝑇 | true  xy  = true  (congruence₁(𝐒) xy)
    ... | 𝐹 | false nxy = false (nxy ∘ injective(𝐒))

  zero?-decider : Decider(1)(_≡ 𝟎)(zero?)
  zero?-decider {𝟎}   = true [≡]-intro
  zero?-decider {𝐒 x} = false \()

module _ where
  open import Numeral.Natural.Oper.Comparisons
  open import Numeral.Natural.Oper.Proofs
  open import Numeral.Natural.Oper.Divisibility
  open import Numeral.Natural.Oper.Modulo
  open import Numeral.Natural.Oper.Modulo.Proofs
  open import Numeral.Natural.Relation.Divisibility
  open import Numeral.Natural.Relation.Divisibility.Proofs
  open import Relator.Equals
  open import Relator.Equals.Proofs.Equiv

  instance
    [∣]-decider : Decider(2)(_∣_)(_∣₀?_)
    [∣]-decider {𝟎} {𝟎}   = true Div𝟎
    [∣]-decider {𝟎} {𝐒 y} = false [0]-divides-not
    [∣]-decider {𝐒 x} {y} with y mod 𝐒(x) | inspect(\x → y mod 𝐒(x)) x
    ... | 𝟎   | intro eq = true  ([↔]-to-[→] mod-divisibility eq)
    ... | 𝐒 _ | intro eq = false ([𝐒]-not-0 ∘ transitivity(_≡_) (symmetry(_≡_) eq) ∘ [↔]-to-[←] mod-divisibility)

module _ where
  open import Data.Boolean.Stmt
  open import Data.Boolean.Stmt.Proofs
  open import Data.List
  open import Data.List.Decidable as List
  open import Data.List.Equiv.Id
  open import Lang.Inspect
  open import Logic.Classical
  open import Logic.Predicate
  open import Numeral.Natural.LinearSearch
  open import Numeral.Natural.Oper.Divisibility
  open import Numeral.Natural.Prime
  open import Numeral.Natural.Prime.Proofs
  open import Numeral.Natural.Relation.Divisibility
  open import Numeral.Natural.Relation.Divisibility.Proofs
  open import Numeral.Natural.Relation.Order
  open import Numeral.Natural.Relation.Order.Classical
  open import Numeral.Natural.Relation.Order.Proofs
  open import Relator.Equals
  open import Relator.Equals.Proofs.Equiv
  open import Type.Properties.Decidable.Proofs
  open import Syntax.Implication.Dependent
  open import Syntax.Implication using (•_•_⇒₂-[_]_)

  -- A naive primality test using bruteforce.
  -- It checks if there are any divisors between 2 and p.
  -- Note: The performance and space should be terrible on this implementation because it checks whether the list of all divisors is empty.
  prime? : ℕ → Bool
  prime? 0          = 𝐹
  prime? 1          = 𝐹
  prime? n@(𝐒(𝐒 _)) = decide(2)(_≡_) ⦃ [∃]-intro _ ⦃ List.[≡]-decider ⦃ dec = [≡?]-decider ⦄ ⦄ ⦄ (findBoundedAll 2 n (_∣₀? n)) ∅

  instance
    Prime-decider : Decider(1)(Prime)(prime?)
    Prime-decider {𝟎} = false \()
    Prime-decider {𝐒 𝟎} = false \()
    Prime-decider {n@(𝐒(𝐒 x))} with prime? n | inspect prime? n
    ... | 𝑇 | intro eq = true $
      eq ⇒
      (prime? n ≡ 𝑇)                                     ⇒-[ [↔]-to-[←] IsTrue.is-𝑇 ]
      IsTrue(prime? n)                                   ⇒-[ [↔]-to-[←] (decider-true ⦃ List.[≡]-decider ⦃ dec = [≡?]-decider ⦄ ⦄) ]
      findBoundedAll 2 n (_∣₀? n) ≡ ∅                    ⇒-[ (\empty {_} → [↔]-to-[←] (findBoundedAll-emptyness{f = _∣₀? n}) empty) ]
      (∀{d} → (2 ≤ d) → (d < n) → IsFalse(d ∣₀? n))      ⇒-[ (\p {i} → [↔]-to-[←] (decider-false ⦃ [∣]-decider ⦄) ∘₂ p) ]
      (∀{d} → (2 ≤ d) → (d < n) → ¬(d ∣ n))              ⇒-[]
      (∀{d} → (2 ≤ d) → (d < 𝐒(𝐒(x))) → ¬(d ∣ 𝐒(𝐒(x))))  ⇒-[ (\p {d} div 2d dx → p{d} 2d (succ dx) div) ]
      (∀{d} → (d ∣ 𝐒(𝐒(x))) → (2 ≤ d) → ¬(d ≤ 𝐒(x)))     ⇒-[ (\p {d} div → [¬→]-disjunctive-formᵣ ⦃ decider-to-classical ⦃ [≡?]-decider ⦄ ⦄ \ nd0 → antisymmetry(_≤_)(_≡_) ([≤]-without-[𝐒] (divides-upper-limit div)) (sub₂(_≯_)(_≤_) (p{𝐒 d} div (succ ([≢]-to-[<]-of-0ᵣ nd0))))) ]
      (∀{d} → (𝐒(d) ∣ 𝐒(𝐒(x))) → ((d ≡ 0) ∨ (d ≡ 𝐒(x)))) ⇒-[ intro ]
      Prime n                                            ⇒-end
    ... | 𝐹 | intro eq = false \p →
      • (
        p ⇒
        Prime(n)                                      ⇒-[ prime-only-divisors ]
        (∀{d} → (d ∣ n) → ((d ≡ 1) ∨ (d ≡ n)))        ⇒-[ (\p {d} 2d dn div → [∨]-elim (\{[≡]-intro → [≤][0]ᵣ-negation ([≤]-without-[𝐒] 2d)}) (\{[≡]-intro → irreflexivity(_<_) dn}) (p div)) ]
        (∀{d} → (2 ≤ d) → (d < n) → ¬(d ∣ n))         ⇒-[ ((\p {i} → [↔]-to-[→] (decider-false ⦃ [∣]-decider ⦄) ∘₂ p)) ]
        (∀{d} → (2 ≤ d) → (d < n) → IsFalse(d ∣₀? n)) ⇒-[ [↔]-to-[→] findBoundedAll-emptyness ]
        findBoundedAll 2 n (_∣₀? n) ≡ ∅               ⇒-[ [↔]-to-[→] (decider-true ⦃ List.[≡]-decider ⦃ dec = [≡?]-decider ⦄ ⦄) ]
        IsTrue(prime? n)                              ⇒-end
      )
      • (
        eq ⇒
        (prime? n ≡ 𝐹)                    ⇒-[ [↔]-to-[←] IsFalse.is-𝐹 ]
        IsFalse(prime? n)                 ⇒-end
      )
      ⇒₂-[ disjointness ]
      Empty ⇒-end

  import      Data.Either as Either
  open import Data.List.Relation.Membership using (_∈_)
  open import Data.List.Relation.Membership.Proofs
  open import Data.Tuple as Tuple using (_⨯_ ; _,_)
  open import Logic.Propositional.Theorems
  open import Numeral.Natural.Oper
  open import Numeral.Natural.Oper.Proofs
  open import Numeral.Natural.Proofs
  open import Numeral.Natural.Relation.Order.Existence using ([≤]-equivalence)
  open import Structure.Function.Domain
  open import Structure.Operator
  open import Structure.Operator.Properties
  open import Syntax.Transitivity

  prime-composite-not : ∀{n} → Prime(n) → Composite(n) → ⊥
  prime-composite-not {.(𝐒(𝐒(a)) ⋅ 𝐒(𝐒(b)))} p (intro a b) =
    Either.map1
      (\())
      ((\()) ∘ cancellationₗ(_+_) {x = a} ∘ injective(𝐒) ∘ injective(𝐒))
      (prime-only-divisors p {𝐒(𝐒(a))} (divides-with-[⋅] {c = 𝐒(𝐒(b))} ([∨]-introₗ divides-reflexivity)))

  -- Using Numeral.Natural.Decidable.prime?, when it is false, there is a divisor d between 2 and n for n. This means that (d ∣ n). Equivalently ∃(k ↦ d ⋅ k ≡ n). The proof of Composite uses these d and k.
  prime-or-composite : ∀{n} → Prime(𝐒(𝐒(n))) ∨ Composite(𝐒(𝐒(n)))
  prime-or-composite{n} = [¬→]-disjunctive-formᵣ ⦃ decider-to-classical ⦃ Prime-decider ⦄ ⦄ $
    ¬ Prime(𝐒(𝐒(n)))                                                                ⇒-[ [↔]-to-[→] (decider-false ⦃ Prime-decider ⦄) ]
    IsFalse(prime? (𝐒(𝐒(n))))                                                       ⇒-[ [↔]-to-[←] (decider-false ⦃ List.[≡]-decider ⦃ dec = [≡?]-decider ⦄ ⦄) ]
    findBoundedAll 2 (𝐒(𝐒(n))) (_∣₀? 𝐒(𝐒(n))) ≢ ∅                                   ⇒-[ non-empty-inclusion-existence ]
    ∃(_∈ findBoundedAll 2 (𝐒(𝐒(n))) (_∣₀? 𝐒(𝐒(n))))                                 ⇒-[ [∃]-map-proof ([↔]-to-[→] (findBoundedAll-membership {f = _∣₀? 𝐒(𝐒(n))})) ]
    ∃(d ↦ (2 ≤ d) ∧ (d < 𝐒(𝐒(n))) ∧ IsTrue(d ∣₀? 𝐒(𝐒(n))))                          ⇒-[ [∃]-map-proof ([∧]-map id ([↔]-to-[←] (decider-true ⦃ [∣]-decider ⦄))) ]
    ∃(d ↦ (2 ≤ d) ∧ (d < 𝐒(𝐒(n))) ∧ (d ∣ 𝐒(𝐒(n))))                                  ⇒-[ (\{([∃]-intro (𝐒 𝟎) ⦃ [∧]-intro ([∧]-intro (succ()) _) _ ⦄) ; ([∃]-intro (𝐒(𝐒 d)) ⦃ [∧]-intro ([∧]-intro d2 dn) div ⦄) → [∃]-intro d ⦃ [∧]-intro dn div ⦄}) ]
    ∃(d ↦ (𝐒(𝐒(d)) < 𝐒(𝐒(n))) ∧ (𝐒(𝐒(d)) ∣ 𝐒(𝐒(n))))                                ⇒-[ (\{([∃]-intro d ⦃ [∧]-intro dn div ⦄) → [∃]-intro d ⦃ [∧]-intro dn ([∃]-intro div ⦃ divides-quotient-correctness {yx = div} ⦄) ⦄}) ]
    ∃(d ↦ (𝐒(𝐒(d)) < 𝐒(𝐒(n))) ∧ ∃{Obj = 𝐒(𝐒(d)) ∣ 𝐒(𝐒(n))}(q ↦ (𝐒(𝐒(d)) ⋅ divides-quotient q ≡ 𝐒(𝐒(n))))) ⇒-[ (\{([∃]-intro d ⦃ [∧]-intro dn ([∃]-intro q ⦃ prod ⦄) ⦄) → [∃]-intro (d , [∃]-witness ([↔]-to-[←] [≤]-equivalence (divides-quotient-composite (succ (succ min)) dn {q}))) ⦃ congruence₂ᵣ(_⋅_)(𝐒(𝐒(d))) (([∃]-proof ([↔]-to-[←] [≤]-equivalence (divides-quotient-composite (succ (succ min)) dn {q})))) 🝖 prod ⦄}) ]
    ∃{Obj = ℕ ⨯ ℕ}(\(a , b) → (𝐒(𝐒(a)) ⋅ 𝐒(𝐒(b)) ≡ 𝐒(𝐒(n))))                        ⇒-[ [↔]-to-[←] composite-existence ]
    Composite(𝐒(𝐒 n))                                                               ⇒-end

  prime-xor-composite : ∀{n} → Prime(𝐒(𝐒(n))) ⊕ Composite(𝐒(𝐒(n)))
  prime-xor-composite {n} = [⊕]-or-not-both prime-or-composite (Tuple.uncurry prime-composite-not)

  open import Data.Tuple
  -- open import Numeral.Natural.Inductions
  {-# TERMINATING #-}
  -- TODO: Use strong induction. (a < n) because (a ⋅ b = n).
  prime-factor-existence : ∀{n} → ∃(PrimeFactor(𝐒(𝐒(n))))
  prime-factor-existence {n} with prime-or-composite{n}
  ... | Either.Left  p = [∃]-intro (𝐒(𝐒(n))) ⦃ intro ⦃ p ⦄ ⦄
  ... | Either.Right c
    with [∃]-intro(a , b) ⦃ p ⦄ ← [↔]-to-[→] composite-existence c
    with [∃]-intro d ⦃ pa ⦄ ← prime-factor-existence{a}
    = [∃]-intro d ⦃ divisor-primeFactors ([↔]-to-[→] divides-[⋅]-existence ([∃]-intro (𝐒 (𝐒 b)) ⦃ p ⦄)) pa ⦄


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Postulate extensionality of functions.
--
-- Justification on Agda mailing list:
-- http://permalink.gmane.org/gmane.comp.lang.agda/2343
------------------------------------------------------------------------

module Postulate.Extensionality where

open import Relation.Binary.PropositionalEquality

postulate ext : ∀ {a b} → Extensionality a b

-- Convenience of using extensionality 3 times in a row
-- (using it twice in a row is moderately tolerable)
ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))


module Deriv where

open import Relation.Binary.Bundles using (DecSetoid)
open import Algebra.Bundles using (Semiring)
open import Level using (0ℓ)
open import Relation.Nullary using (yes; no)

module _ (S : DecSetoid 0ℓ 0ℓ) (Targ : Set) where

  open DecSetoid S renaming (Carrier to Key)

  infixl 6 _+_
  infixl 7 _*_
  data Expr : Set where
    ↑ : Targ → Expr
    ! : Key → Expr
    _+_ : Expr → Expr → Expr
    _*_ : Expr → Expr → Expr

module _ {S : DecSetoid 0ℓ 0ℓ} (R : Semiring 0ℓ 0ℓ) where

  private module S = DecSetoid S
  open S renaming (Carrier to Key)
  private module R = Semiring R
  open R using (0#; 1#) renaming (Carrier to Targ)

  eval
    : (lookup : Key → Targ)
    → (expr : Expr S Targ)
    → Targ
  eval lookup (↑ x) = x
  eval lookup (! x) = lookup x
  eval lookup (x + x₁) = eval lookup x₁ R.+ eval lookup x₁
  eval lookup (x * x₁) = eval lookup x₁ R.* eval lookup x₁

  deriv : Expr S Targ → Key → Expr S Targ
  deriv (↑ x) k = ↑ 0#
  deriv (! x) k with x ≟ k
  deriv (! x) k | yes _ = ↑ 1#
  deriv (! x) k | no _ = ↑ 0#
  deriv (e + e₁) k = deriv e k + deriv e₁ k
  deriv (e * e₁) k = (deriv e k * e₁) + (e * deriv e₁ k)

open import Data.Nat using (ℕ)
open import Data.Nat.Properties using (+-*-semiring)
open import Data.String
open import Relation.Binary.PropositionalEquality using (decSetoid)

asdf : Expr (decSetoid _≟_) ℕ
asdf = ↑ 2 + (↑ 5 * (! "hello" * ! "goodbye"))

asdf' : Expr (decSetoid _≟_) ℕ
asdf' = deriv +-*-semiring asdf "hello"

normalize : ∀ {D} → Expr D ℕ → Expr D ℕ
normalize (x + y) with normalize x | normalize y
normalize (x + y) | ↑ w | ↑ z   = ↑ (w Data.Nat.+ z)
normalize (x + y) | ↑ 0 | z   = z
normalize (x + y) | w   | ↑ 0 = w
normalize (x + y) | w   | z   = w + z
normalize (x * y) with normalize x | normalize y
normalize (x * y) | ↑ w | ↑ z   = ↑ (w Data.Nat.* z)
normalize (x * y) | ↑ 0 | z   = ↑ 0
normalize (x * y) | w   | ↑ 0 = ↑ 0
normalize (x * y) | ↑ 1 | z   = z
normalize (x * y) | w   | ↑ 1 = w
normalize (x * y) | w   | z   = w * z
normalize z = z

module _ (R : Semiring 0ℓ 0ℓ) where
  open Semiring R
  private module R = Semiring R

  asdf'' : Carrier
  asdf'' = 1# R.+ 0#


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Relation.Nullary using (yes)
open import Cubical.Relation.Binary.Raw using (Decidable)

import Cubical.Data.Unit.Base as ⊤

⊤ : {ℓ : Level} → Type ℓ
⊤ = Lift ⊤.⊤

pattern tt = lift ⊤.tt

infix 4 _≟_

_≟_ : {ℓ : Level} → Decidable {A = ⊤ {ℓ}} _≡_
_ ≟ _ = yes refl

isContr⊤ : {ℓ : Level} → isContr (⊤ {ℓ})
isContr⊤ = tt , λ {tt → refl}

isProp⊤ : {ℓ : Level} → isProp (⊤ {ℓ})
isProp⊤ _ _ i = tt


------------------------------------------------------------------------------
-- Well-founded relation on trees
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Mirror.TreeR where

open import FOTC.Base
open import FOTC.Data.List.WF-Relation.LT-Cons
open import FOTC.Program.Mirror.Type

------------------------------------------------------------------------------
-- Well-founded relation on trees.

-- A well-founded relation for rose trees is the lexicographical order
--
-- (t : ts) < (t' : ts') = t < t' or t ≡ t' and ts < ts'.
--
-- It seems we would not to use the first conjunct in the mirror
-- example.
TreeR : D → D → Set
TreeR t₁ t₂ = ∃[ d ] ∃[ ts₁ ] ∃[ ts₂ ]
                 t₁ ≡ node d ts₁
                 ∧ t₂ ≡ node d ts₂
                 ∧ LTC ts₁ ts₂


-- Non-indexed (plain) monads in form of Kleisli triple, presented in point-free style.

module Control.Comonad where

open import Function using (id) renaming (_∘′_ to _∘_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Axiom.FunctionExtensionality
open import Control.Functor

record IsComonad (W : Set → Set) : Set₁ where

  -- Methods.

  field
    extract : ∀ {A  } → W A → A
    extend  : ∀ {A B} → (W A → B) → W A → W B

  -- Laws.

  field

    extend-β : ∀ {A B} {k : W A → B} →

      extract ∘ extend k ≡ k

    extend-η : ∀ {A} →

      extend {A = A} extract ≡ id

    extend-∘ : ∀ {A B C} {k : W A → B} {l : W B → C} →

      extend (l ∘ extend k) ≡ extend l ∘ extend k

  -- Comonadic composition.

  comComp : ∀ {A B C : Set} (l : W B → C) (k : W A → B) → (W A → C)
  comComp l k = l ∘ extend k

  -- Functoriality.

  isFunctor : IsFunctor W
  isFunctor = record
    { ops  = record { map = map  }
    ; laws = record { map-id = extend-η ; map-∘ = λ {A B C f g} → sym (map-∘-sym f g) }
    }
    where
      map : ∀ {A B} → (A → B) → W A → W B
      map f = extend (f ∘ extract)

      map-∘-sym : ∀ {A B C} (f : A → B) (g : B → C) → map g ∘ map f ≡ map (g ∘ f)
      map-∘-sym f g = begin
        map g ∘ map f                                ≡⟨⟩
        extend (g ∘ extract) ∘ extend (f ∘ extract)  ≡⟨ sym extend-∘ ⟩
        extend (g ∘ extract ∘ extend (f ∘ extract))  ≡⟨ cong (λ z → extend (g ∘ z)) extend-β ⟩
        extend (g ∘ f ∘ extract)                     ≡⟨⟩
        map (g ∘ f)                                  ∎

  open IsFunctor isFunctor public

-- Monads in Kleisli Triple presentation.

record Comonad : Set₁ where
  constructor comonad
  field
    W  : Set → Set
    W! : IsComonad W

  open IsComonad W! public

-- Casting a Comonad to a Functor

FunctorOfComonad : Comonad → Functor
FunctorOfComonad WW = functor W isFunctor
  where open Comonad WW


-- Andreas, 2017-09-03, issue #2729.
-- Expect non-indexed or -primed variables when splitting.

-- {-# OPTIONS -v interaction.case:100 #-}
-- {-# OPTIONS -v tc.cover:40 #-}

data Size : Set where
  ↑ : Size → Size

data Nat : Size → Set where
  zero : ∀ i → Nat (↑ i)
  suc  : ∀ i → Nat i → Nat (↑ i)

pred : ∀ i → Nat i → Nat i
pred i x = {!x!}  -- C-c C-c

-- WRONG (agda-2.5.3):
-- pred .(↑ i₁) (zero i₁) = ?
-- pred .(↑ i₁) (suc i₁ x) = ?

-- EXPECTED (correct in agda-2.5.1.1):
-- pred .(↑ i) (zero i) = ?
-- pred .(↑ i) (suc i x) = ?


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

-- Test case by Ulf Norell, 16/09/2020

open import Agda.Primitive.Cubical    renaming (primIMin to _∧_)
open import Agda.Builtin.Cubical.Path using (_≡_)

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

record Pos : Set where
  constructor 1+_
  field unpos : Nat

open Pos

Pos→Nat : Pos → Nat
Pos→Nat (1+ n) = suc n

variable
  A : Set
  x : A

refl : x ≡ x
refl {x = x} i = x

id : Pos → Pos
id n = n

-- (i ∧ j) in the system caused a mishandling of de Bruijn indexes.
foo : (n : Pos) (i j : I) → Nat
foo n i j = primHComp
              (λ k → primPOr (i ∧ j)                (i ∧ j)
                             (λ _ → suc (n .unpos)) (λ _ → suc (n .unpos)))
              (suc (n .unpos))

-- The test triggers normalization to make sure the `primHComp` in
-- `foo` reduces properly.
                             --  v  foil syntactic equality check
test : ∀ n i j → foo n i j ≡ foo (id n) i j
test n i j = refl


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

module Equality where

open import Cubical.Core.Everything         using (_≡_; Level; Type; Σ; _,_; fst; snd; _≃_; ~_)
open import Cubical.Foundations.Prelude     using (refl; sym; cong; transport; subst; funExt; transp; I; i0; i1)
open import Cubical.Foundations.Function    using (_∘_)
open import Cubical.Foundations.Univalence  using (ua)
open import Cubical.Foundations.Isomorphism using (iso; Iso; isoToPath; section; retract)

open import Data.Bool.Base      using (Bool; true; false; _∧_)
open import Data.Nat.Base       using (ℕ; zero; suc; _+_)
open import Data.Fin            using (Fin; toℕ; fromℕ; #_; opposite) renaming (zero to fz; suc to fs)
open import Data.Product        using (_×_; proj₁; proj₂)

-- mutual recursion
data Γ : ℕ → Type
data U : {n : ℕ} → Γ n → Type

-- context (snoc list of dependent types)
data Γ where
  ε   : Γ 0
  _∙_ : {n : ℕ} → (γ : Γ n) → U γ → Γ (suc n)

tail : {n : ℕ} → Γ (suc n) → Γ n
tail (γ ∙ _) = γ

drop : {n : ℕ} → (k : ℕ) → Γ (k + n) → Γ n
drop zero    γ       = γ
drop (suc k) (γ ∙ x) = drop k γ

head : {n : ℕ} → (γ : Γ (suc n)) → U (tail γ)
head (_ ∙ A) = A

-- lookup a type in a context at position k
lookup : {n : ℕ} → (k : ℕ) → (γ : Γ (k + suc n)) → U (tail (drop k γ))
lookup k γ = head (drop k γ)

-- type universe
data U where
  nat : {n : ℕ} → {γ : Γ n} → U γ
  pi  : {n : ℕ} → {γ : Γ n} → (A : U γ) → U (γ ∙ A) → U γ

data Term : {n : ℕ} → (γ : Γ n) → U γ → Type where
--  v  : {n : ℕ} → (k : ℕ) → {γ : Γ (k + suc n)} → {A : U (tail (drop k γ))} → Term (tail (drop k γ)) A
  v  : {n : ℕ} → (k : ℕ) → {γ : Γ (k + suc n)} → {A : U (tail (drop k γ))} → Term (tail (drop k γ)) A
  tz : {n : ℕ} → {γ : Γ n} → Term γ nat -- zero
  ts : {n : ℕ} → {γ : Γ n} → Term γ nat → Term γ nat -- suc
--  tn : (P : Term nat → U) → Term (P tz) → ((n : Term nat) → Term (P n) → Term (P (ts n))) → (n : Term nat) → Term (P n) -- natrec
  tλ : {n : ℕ} → {γ : Γ n} → {A : U γ} → {B : U (γ ∙ A)} → Term (γ ∙ A) B → Term γ (pi A B)
  ta : {n : ℕ} → {γ : Γ n} → {A : U γ} → {B : U (γ ∙ A)} → Term γ (pi A B) → Term γ A → Term (γ ∙ A) B

--+1 : Term ε (pi nat nat)
--+1 = tλ {!!} --(v {n = 0} 0)

data Eq : Type where
  eq : Eq -- equal
  ne : Eq -- not equal

data Maybe (a : Type) : Type where
  nothing : Maybe a
  just    : a → Maybe a

ℕeq : ℕ → ℕ → Eq
ℕeq zero zero       = eq
ℕeq zero (suc n)    = ne
ℕeq (suc m) zero    = ne
ℕeq (suc m) (suc n) = ℕeq m n

natrec : (P : ℕ → Type) → P 0 → ((n : ℕ) → P n → P (suc n)) → (n : ℕ) → P n
natrec P z s zero    = z
natrec P z s (suc n) = s n (natrec P z s n)

_+'_ : ℕ → ℕ → ℕ
_+'_ = λ m → λ n → natrec (λ _ → ℕ) n (λ _ → suc) m

0=0 : 0 ≡ 0
0=0 = refl

suc=suc : (m n : ℕ) → m ≡ n → suc m ≡ suc n
suc=suc m n e = cong suc e

0+n=n : (n : ℕ) → 0 + n ≡ n
0+n=n = natrec (λ k → 0 + k ≡ k) 0=0 (λ n e → suc=suc n n e)

n=0+n : (n : ℕ) → n + 0 ≡ n
n=0+n = natrec (λ k → k + 0 ≡ k) 0=0 λ n e → suc=suc (n + 0) n e


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

-- An inhabited Indiscrete category is a -2-Category
module Categories.Minus2-Category.Construction.Indiscrete where

open import Level
open import Data.Unit using (tt)
open import Data.Product using (_,_)
open import Relation.Binary.PropositionalEquality using (refl)

open import Categories.Minus2-Category
open import Categories.Category.Indiscrete
open import Categories.Morphism using (_≅_)

InhIndIs-2 : ∀ {o ℓ} → (X : Set o) → (x : X) → -2-Category {o} {ℓ} {ℓ}
InhIndIs-2 X x = record
  { cat = Indiscrete X
  ; Obj-Contr = x , λ y → record
    { from = lift tt
    ; to = lift tt
    ; iso = record
      { isoˡ = refl
      ; isoʳ = refl
      }
    }
  ; Hom-Conn = refl
  }


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

module Math.FormalLanguage where

-- agda-stdlib
import Algebra.FunctionProperties as FP
import Algebra.Structures as Structures
open import Level renaming (zero to lzero; suc to lsuc)
open import Data.List as L using (List; []; _++_)
import Data.List.Properties as Lₚ
open import Data.Nat hiding (_⊔_; _^_)
open import Data.Empty
open import Data.Product using (proj₁; proj₂; _,_; _×_; ∃₂; ∃)
open import Function using (_$_)
import Function as F
open import Relation.Binary.PropositionalEquality
open import Relation.Binary
open import Relation.Unary hiding (∅; ｛_｝)
import Relation.Unary as U
import Relation.Unary.Properties as Uₚ

-- Equivalence of predicate
infix 4 _≡ᴾ_
_≡ᴾ_ : ∀ {a l} {A : Set a} → Rel (Pred A l) (a ⊔ l)
_≡ᴾ_ P Q = (P ⊆ Q) × (Q ⊆ P)

≡ᴾ-refl : ∀ {a l} {A : Set a} → Reflexive {A = Pred A l} _≡ᴾ_
≡ᴾ-refl = F.id , F.id

≡ᴾ-sym : ∀ {a l} {A : Set a} → Symmetric {A = Pred A l} _≡ᴾ_
≡ᴾ-sym = Data.Product.swap

≡ᴾ-trans : ∀ {a l} {A : Set a} → Transitive {A = Pred A l} _≡ᴾ_
≡ᴾ-trans P≡Q Q≡R = proj₁ Q≡R F.∘ proj₁ P≡Q , proj₂ P≡Q F.∘ proj₂ Q≡R

≡ᴾ-isEquivalence : ∀ {a l} {A : Set a} → IsEquivalence {A = Pred A l} _≡ᴾ_
≡ᴾ-isEquivalence = record
  { refl  = ≡ᴾ-refl
  ; sym   = ≡ᴾ-sym
  ; trans = ≡ᴾ-trans
  }

≡ᴾ-setoid : ∀ {a l} {A : Set a} → Setoid _ _
≡ᴾ-setoid {a} {l} {A} = record
  { Carrier       = Pred A l
  ; _≈_           = _≡ᴾ_
  ; isEquivalence = ≡ᴾ-isEquivalence
  }

∅ : ∀ {a l} {A : Set a} → Pred A l
∅ {l = l} = λ _ → Lift l ⊥

｛_｝ : ∀ {a l} {A : Set a} → A → Pred A (a ⊔ l)
｛_｝{l = l} x = λ y → Lift l (y ≡ x)

Lang : ∀ {s} → Set s → (l : Level) → Set _
Lang Σ l = Pred (List Σ) l

-- TODO Move Math.FormalLanguage.Construct.EmptyLang
data EmptyLang {a l} {A : Set a} : Lang A (a ⊔ l) where
  mkEmptyLang : EmptyLang []

-- TODO Move Math.FormalLanguage.Construct.Concat
-- TODO Hetero
-- Lang A l → Lang B l → Lang (A ⊎ B) l
-- map inj₁ xs ++ map inj₂ ys
-- concatenation of formal language
data _<>_ {a l} {A : Set a} (L₁ L₂ : Lang A l) : Lang A (a ⊔ l) where
  mk<> : ∀ {xs ys} → L₁ xs → L₂ ys → (L₁ <> L₂) (xs ++ ys)

-- TODO Move Math.FormalLanguage.Construct.Concat.Properties
module _ {s l} {Σ : Set s} where
  open FP {A = Lang Σ (s ⊔ l)} _≡ᴾ_

  <>-identityˡ : LeftIdentity (EmptyLang {l = l}) _<>_
  <>-identityˡ L = to , from
    where
    to : EmptyLang <> L ⊆ L
    to (mk<> mkEmptyLang x₁) = x₁
    from : L ⊆ EmptyLang <> L
    from Lx = mk<> mkEmptyLang Lx

  <>-identityʳ  : RightIdentity (EmptyLang {l = l}) _<>_
  <>-identityʳ L = to , from
    where
    to : L <> EmptyLang ⊆ L
    to (mk<> Lx mkEmptyLang) = subst L (sym $ Lₚ.++-identityʳ _) Lx
    from : L ⊆ L <> EmptyLang
    from {xs} x = subst (L <> EmptyLang) (Lₚ.++-identityʳ xs) $
      mk<> {xs = xs} {ys = []} x mkEmptyLang

{- TODO move contents of agda-combinatorics to agda-misc
  <>-dec : ∀ {L₁ L₂ : Lang Σ l} →
    U.Decidable L₁ → U.Decidable L₂ → U.Decidable (L₁ <> L₂)
  <>-dec L₁? L₂? zs with L.filter (L₁? Uₚ.×? L₂?) (splits₂ zs)
  ... | x = ?
-}


-- Classical propositional logic, de Bruijn approach, final encoding

module Bf.Cp where

open import Lib using (List; _,_; LMem; lzero; lsuc)

-- Types

infixl 2 _&&_
infixl 1 _||_
infixr 0 _=>_
data Ty : Set where
  UNIT  :             Ty
  _=>_  : Ty -> Ty -> Ty
  _&&_  : Ty -> Ty -> Ty
  _||_  : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 _<=>_
_<=>_ : Ty -> Ty -> Ty
a <=> b = (a => b) && (b => a)

NOT : Ty -> Ty
NOT a = a => FALSE

TRUE : Ty
TRUE = FALSE => FALSE

-- Context and truth judgement

Cx : Set
Cx = List Ty

isTrue : Ty -> Cx -> Set
isTrue a tc = LMem a tc

-- Terms

TmRepr : Set1
TmRepr = Cx -> Ty -> Set

module ArrMp where
  record Tm (tr : TmRepr) : Set1 where
    infixl 1 _$_
    infixr 0 lam=>_
    field
      var    : forall {tc a}   -> isTrue a tc               -> tr tc a
      lam=>_ : forall {tc a b} -> tr (tc , a) b             -> tr tc (a => b)
      _$_    : forall {tc a b} -> tr tc (a => b) -> tr tc a -> tr tc b

    v0 : forall {tc a} -> tr (tc , a) a
    v0 = var lzero

    v1 : forall {tc a b} -> tr (tc , a , b) a
    v1 = var (lsuc lzero)

    v2 : forall {tc a b c} -> tr (tc , a , b , c) a
    v2 = var (lsuc (lsuc lzero))
  open Tm {{...}} public

module Mp where
  record Tm (tr : TmRepr) : Set1 where
    field
      pair' : forall {tc a b}   -> tr tc a        -> tr tc b -> tr tc (a && b)
      fst   : forall {tc a b}   -> tr tc (a && b)            -> tr tc a
      snd   : forall {tc a b}   -> tr tc (a && b)            -> tr tc b
      left  : forall {tc a b}   -> tr tc a                   -> tr tc (a || b)
      right : forall {tc a b}   -> tr tc b                   -> tr tc (a || b)
      case' : forall {tc a b c} -> tr tc (a || b) -> tr (tc , a) c -> tr (tc , b) c -> tr tc c

      isArrMp : ArrMp.Tm tr
    open ArrMp.Tm isArrMp public

    syntax pair' x y    = [ x , y ]
    syntax case' xy x y = case xy => x => y
  open Tm {{...}} public

module Cp where
  record Tm (tr : TmRepr) : Set1 where
    infixr 0 abort=>_
    field
      abort=>_ : forall {tc a} -> tr (tc , NOT a) FALSE -> tr tc a

      isMp : Mp.Tm tr
    open Mp.Tm isMp public
  open Tm {{...}} public

  Thm : Ty -> Set1
  Thm a = forall {tr tc} {{_ : Tm tr}} -> tr tc a
open Cp public


{-

An experiment of transporting rev-++-distr from lists to lists where
the arguments to cons have been flipped inspired by section 2 of
https://arxiv.org/abs/2010.00774

Note that Agda doesn't care about the order of constructors so we
can't do exactly the same example.

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Experiments.List where

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

open import Cubical.Data.Sigma

infixr 5 _∷_
infixl 5 _∷'_
infixr 5 _++_

-- Normal lists
data List (A : Type) : Type where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

-- Lists where the arguments to cons have been flipped
data List' (A : Type) : Type where
  []  : List' A
  _∷'_ : (xs : List' A) (x : A) → List' A

variable
  A : Type

-- Some operations and properties for List

_++_ : List A → List A → List A
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ xs ++ ys

rev : List A → List A
rev [] = []
rev (x ∷ xs) = rev xs ++ (x ∷ [])

++-unit-r : (xs : List A) → xs ++ [] ≡ xs
++-unit-r [] = refl
++-unit-r (x ∷ xs) = cong (_∷_ x) (++-unit-r xs)

++-assoc : (xs ys zs : List A) → (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs
++-assoc [] ys zs = refl
++-assoc (x ∷ xs) ys zs = cong (_∷_ x) (++-assoc xs ys zs)

rev-++-distr : (xs ys : List A) → rev (xs ++ ys) ≡ rev ys ++ rev xs
rev-++-distr [] ys       = sym (++-unit-r (rev ys))
rev-++-distr (x ∷ xs) ys = cong (_++ _) (rev-++-distr xs ys) ∙ ++-assoc (rev ys) (rev xs) (x ∷ [])

-- We now want to transport this to List'. For this we first establish
-- an isomorphism of the types.

toList' : List A → List' A
toList' []       = []
toList' (x ∷ xs) = toList' xs ∷' x

fromList' : List' A → List A
fromList' []        = []
fromList' (xs ∷' x) =  x ∷ fromList' xs

toFrom : (xs : List' A) → toList' (fromList' xs) ≡ xs
toFrom []          = refl
toFrom (xs ∷' x) i = toFrom xs i ∷' x

fromTo : (xs : List A) → fromList' (toList' xs) ≡ xs
fromTo []          = refl
fromTo (x ∷ xs) i =  x ∷ fromTo xs i

ListIso : Iso (List A) (List' A)
ListIso = iso toList' fromList' toFrom fromTo

ListEquiv : List A ≃ List' A
ListEquiv = isoToEquiv ListIso

-- We then use univalence to turn this into a path
ListPath : (A : Type) → List A ≡ List' A
ListPath A = isoToPath (ListIso {A = A})

-- We can now use this path to transport the operations and properties
-- from List to List'
module transport where

  -- First make a suitable Σ-type packaging what we need for the
  -- transport (note that _++_ and rev here are part of the Σ-type).
  -- It should be possible to automatically generate this given a module/file.
  T : Type → Type
  T X = Σ[ _++_ ∈ (X → X → X) ] Σ[ rev ∈ (X → X) ] ((xs ys : X) → rev (xs ++ ys) ≡ rev ys ++ rev xs)

  -- We can now transport the instance of T for List to List'
  T-List' : T (List' A)
  T-List' {A = A} = transport (λ i → T (ListPath A i)) (_++_ , rev , rev-++-distr)

  -- Getting the operations and property for List' is then just a matter of projecting them out
  _++'_ : List' A → List' A → List' A
  _++'_ = T-List' .fst

  rev' : List' A → List' A
  rev' = T-List' .snd .fst

  rev-++-distr' : (xs ys : List' A) → rev' (xs ++' ys) ≡ rev' ys ++' rev' xs
  rev-++-distr' = T-List' .snd .snd

-- To connect this with the Cubical Agda paper consider the following
-- (painfully) manual transport. This is really what the above code
-- unfolds to.
module manualtransport where

  _++'_ : List' A → List' A → List' A
  _++'_ {A = A} = transport (λ i → ListPath A i → ListPath A i → ListPath A i) _++_

  rev' : List' A → List' A
  rev' {A = A} = transport (λ i → ListPath A i → ListPath A i) rev

  rev-++-distr' : (xs ys : List' A) → rev' (xs ++' ys) ≡ rev' ys ++' rev' xs
  rev-++-distr' {A = A} = transport (λ i → (xs ys : ListPath A i)
                                         → revP i (appP i xs ys) ≡ appP i (revP i ys) (revP i xs))
                                    rev-++-distr
    where
    appP : PathP (λ i → ListPath A i → ListPath A i → ListPath A i) _++_ _++'_
    appP i = transp (λ j → ListPath A (i ∧ j) → ListPath A (i ∧ j) → ListPath A (i ∧ j)) (~ i) _++_

    revP : PathP (λ i → ListPath A i → ListPath A i) rev rev'
    revP i = transp (λ j → ListPath A (i ∧ j) → ListPath A (i ∧ j)) (~ i) rev

-- The above operations for List' are derived by going back and
-- forth. With the SIP we can do better and transport properties for
-- user defined operations (assuming that the operations are
-- well-defined wrt to the forward direction of the equivalence).
open import Cubical.Foundations.SIP
open import Cubical.Structures.Axioms
open import Cubical.Structures.Product
open import Cubical.Structures.Pointed
open import Cubical.Structures.Function

-- For illustrative purposes we first apply the SIP manually. This
-- requires quite a bit of boilerplate code which is automated in the
-- next module.
module manualSIP (A : Type) where

  -- First define the raw structure without axioms. This is just the
  -- signature of _++_ and rev.
  RawStruct : Type → Type
  RawStruct X = (X → X → X) × (X → X)

  -- Some boilerplate code which can be automated
  e1 : StrEquiv (λ x → x → x → x) ℓ-zero
  e1 = FunctionEquivStr+ pointedEquivAction
                         (FunctionEquivStr+ pointedEquivAction PointedEquivStr)

  e2 : StrEquiv (λ x → x → x) ℓ-zero
  e2 = FunctionEquivStr+ pointedEquivAction PointedEquivStr

  RawEquivStr : StrEquiv RawStruct _
  RawEquivStr = ProductEquivStr e1 e2

  rawUnivalentStr : UnivalentStr _ RawEquivStr
  rawUnivalentStr = productUnivalentStr e1 he1 e2 he2
    where
    he2 : UnivalentStr (λ z → z → z) e2
    he2 = functionUnivalentStr+ pointedEquivAction pointedTransportStr
                                PointedEquivStr pointedUnivalentStr

    he1 : UnivalentStr (λ z → z → z → z) e1
    he1 = functionUnivalentStr+ pointedEquivAction pointedTransportStr e2 he2

  -- Now the property that we want to transport
  P : (X : Type) → RawStruct X → Type
  P X (_++_ , rev) = ((xs ys : X) → rev (xs ++ ys) ≡ rev ys ++ rev xs)

  -- Package things up for List
  List-Struct : Σ[ X ∈ Type ] (Σ[ s ∈ RawStruct X ] (P X s))
  List-Struct = List A , (_++_ , rev) , rev-++-distr

  -- We now give direct definitions of ++' and rev' for List'
  _++'_ : List' A → List' A → List' A
  [] ++' ys        = ys
  (xs ∷' x) ++' ys = (xs ++' ys) ∷' x

  rev' : List' A → List' A
  rev' [] = []
  rev' (xs ∷' x) = rev' xs ++' ([] ∷' x)

  -- We then package this up into a raw structure on List'
  List'-RawStruct : Σ[ X ∈ Type ] (RawStruct X)
  List'-RawStruct = List' A , (_++'_ , rev')

  -- Finally we prove that toList' commutes with _++_ and rev. Note
  -- that this could be a lot more complex, see for example the Matrix
  -- example (Cubical.Algebra.Matrix).
  toList'-++ : (xs ys : List A) → toList' (xs ++ ys) ≡ toList' xs ++' toList' ys
  toList'-++ [] ys = refl
  toList'-++ (x ∷ xs) ys i = toList'-++ xs ys i ∷' x

  toList'-rev : (xs : List A) → toList' (rev xs) ≡ rev' (toList' xs)
  toList'-rev [] = refl
  toList'-rev (x ∷ xs) = toList'-++ (rev xs) (x ∷ []) ∙ cong (_++' ([] ∷' x)) (toList'-rev xs)

  -- We can now get the property for ++' and rev' via the SIP
  rev-++-distr' : (xs ys : List' A) → rev' (xs ++' ys) ≡ rev' ys ++' rev' xs
  rev-++-distr' = transferAxioms rawUnivalentStr List-Struct List'-RawStruct
                        (ListEquiv , toList'-++ , toList'-rev)

  -- Note that rev-++-distr' is really talking about the direct
  -- definitions of ++' and rev', not the transported operations as in
  -- the previous attempt.

-- We now automate parts of the above construction
open import Cubical.Structures.Auto

module SIP-auto (A : Type) where

  -- First define the raw structure without axioms. This is just the
  -- signature of _++_ and rev.
  RawStruct : Type → Type
  RawStruct X = (X → X → X) × (X → X)

  -- Some automated SIP magic
  RawEquivStr : _
  RawEquivStr = AutoEquivStr RawStruct

  rawUnivalentStr : UnivalentStr _ RawEquivStr
  rawUnivalentStr = autoUnivalentStr RawStruct

  -- Now the property that we want to transport
  P : (X : Type) → RawStruct X → Type
  P X (_++_ , rev) = ((xs ys : X) → rev (xs ++ ys) ≡ rev ys ++ rev xs)

  -- Package things up for List
  List-Struct : Σ[ X ∈ Type ] (Σ[ s ∈ RawStruct X ] (P X s))
  List-Struct = List A , (_++_ , rev) , rev-++-distr

  -- We now give direct definitions of ++' and rev' for List'
  _++'_ : List' A → List' A → List' A
  [] ++' ys        = ys
  (xs ∷' x) ++' ys = (xs ++' ys) ∷' x

  rev' : List' A → List' A
  rev' [] = []
  rev' (xs ∷' x) = rev' xs ++' ([] ∷' x)

  -- We then package this up into a raw structure on List'
  List'-RawStruct : Σ[ X ∈ Type ] (RawStruct X)
  List'-RawStruct = List' A , (_++'_ , rev')

  -- Finally we prove that toList' commutes with _++_ and rev. Note
  -- that this could be a lot more complex, see for example the Matrix
  -- example (Cubical.Algebra.Matrix).
  toList'-++ : (xs ys : List A) → toList' (xs ++ ys) ≡ toList' xs ++' toList' ys
  toList'-++ [] ys = refl
  toList'-++ (x ∷ xs) ys i = toList'-++ xs ys i ∷' x

  toList'-rev : (xs : List A) → toList' (rev xs) ≡ rev' (toList' xs)
  toList'-rev [] = refl
  toList'-rev (x ∷ xs) = toList'-++ (rev xs) (x ∷ []) ∙ cong (_++' ([] ∷' x)) (toList'-rev xs)

  -- We can now get the property for ++' and rev' via the SIP
  rev-++-distr' : (xs ys : List' A) → rev' (xs ++' ys) ≡ rev' ys ++' rev' xs
  rev-++-distr' = transferAxioms rawUnivalentStr List-Struct List'-RawStruct
                        (ListEquiv , toList'-++ , toList'-rev)

  -- Note that rev-++-distr' is really talking about the direct
  -- definitions of ++' and rev', not the transported operations as in
  -- the previous attempt.


{-

This file proves the higher groupoid structure of types
for homogeneous and heterogeneous paths

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.GroupoidLaws where

open import Cubical.Foundations.Prelude

private
  variable
    ℓ : Level
    A : Type ℓ
    x y z w : A

_⁻¹ : (x ≡ y) → (y ≡ x)
x≡y ⁻¹ = sym x≡y

infix 40 _⁻¹

-- homogeneous groupoid laws

symInvo : (p : x ≡ y) → p ≡ p ⁻¹ ⁻¹
symInvo p = refl

rUnit : (p : x ≡ y) → p ≡ p ∙ refl
rUnit p j i = compPath-filler p refl j i

-- The filler of left unit: lUnit-filler p =
-- PathP (λ i → PathP (λ j → PathP (λ k → A) x (p (~ j ∨ i)))
-- (refl i) (λ j → compPath-filler refl p i j)) (λ k i → (p (~ k ∧ i ))) (lUnit p)

lUnit-filler : {x y : A} (p : x ≡ y) → I → I → I → A
lUnit-filler {x = x} p j k i =
  hfill (λ j → λ { (i = i0) → x
                  ; (i = i1) → p (~ k ∨ j )
                  ; (k = i0) → p i
               -- ; (k = i1) → compPath-filler refl p j i
                  }) (inS (p (~ k ∧ i ))) j

lUnit : (p : x ≡ y) → p ≡ refl ∙ p
lUnit p j i = lUnit-filler p i1 j i

symRefl : refl {x = x} ≡ refl ⁻¹
symRefl i = refl

compPathRefl : refl {x = x} ≡ refl ∙ refl
compPathRefl = rUnit refl

-- The filler of right cancellation: rCancel-filler p =
-- PathP (λ i → PathP (λ j → PathP (λ k → A) x (p (~ j ∧ ~ i)))
-- (λ j → compPath-filler p (p ⁻¹) i j) (refl i)) (λ j i → (p (i ∧ ~ j))) (rCancel p)

rCancel-filler : ∀ {x y : A} (p : x ≡ y) → (k j i : I) → A
rCancel-filler {x = x} p k j i =
  hfill (λ k → λ { (i = i0) → x
                  ; (i = i1) → p (~ k ∧ ~ j)
               -- ; (j = i0) → compPath-filler p (p ⁻¹) k i
                  ; (j = i1) → x
                  }) (inS (p (i ∧ ~ j))) k

rCancel : (p : x ≡ y) → p ∙ p ⁻¹ ≡ refl
rCancel {x = x} p j i = rCancel-filler p i1 j i

lCancel : (p : x ≡ y) → p ⁻¹ ∙ p ≡ refl
lCancel p = rCancel (p ⁻¹)

-- The filler of the three-out-of-four identification: 3outof4-filler α p β =
-- PathP (λ i → PathP (λ j → PathP (λ k → A) (α i i0) (α i i1))
-- (λ j → α i j) (λ j → β i j)) (λ j i → α i0 i) (3outof4 α p β)

3outof4-filler : (α : I → I → A) → (p : α i1 i0 ≡ α i1 i1) →
  (β : PathP (λ j → Path A (α j i0) (α j i1)) (λ i → α i0 i) p) → I → I → I → A
3outof4-filler α p β k j i =
  hfill (λ k → λ { (i = i0) → α k i0
                  ; (i = i1) → α k i1
                  ; (j = i0) → α k i
                  ; (j = i1) → β k i
                  }) (inS (α i0 i)) k

3outof4 : (α : I → I → A) → (p : α i1 i0 ≡ α i1 i1) →
  (β : PathP (λ j → Path A (α j i0) (α j i1)) (λ i → α i0 i) p) → (λ i → α i1 i) ≡ p
3outof4 α p β j i = 3outof4-filler α p β i1 j i

-- The filler of the pre-associative square: preassoc p q r =
-- PathP (λ i → PathP (λ j → PathP (λ k → A) x (compPath-filler q r i j))
-- (refl i) (λ j → compPath-filler (p ∙ q) r i j)) (λ j i → compPath-filler p q j i) (preassoc p q r)

preassoc-filler : {x y z w : A} (p : x ≡ y) (q : y ≡ z) (r : z ≡ w) → I → I → I → A
preassoc-filler {x = x} p q r k j i =
  hfill (λ k → λ { (i = i0) → x
                  ; (i = i1) → compPath-filler q r k j
                  ; (j = i0) → p i
               -- ; (j = i1) → compPath-filler (p ∙ q) r k i
                  }) (inS (compPath-filler p q j i)) k

preassoc : (p : x ≡ y) (q : y ≡ z) (r : z ≡ w) →
  PathP (λ j → Path A x ((q ∙ r) j)) p ((p ∙ q) ∙ r)
preassoc {x = x} p q r j i = preassoc-filler p q r i1 j i

assoc : (p : x ≡ y) (q : y ≡ z) (r : z ≡ w) →
  p ∙ q ∙ r ≡ (p ∙ q) ∙ r
assoc p q r = 3outof4 (compPath-filler p (q ∙ r)) ((p ∙ q) ∙ r) (preassoc p q r)

-- heterogeneous groupoid laws

symInvoP : {A : I → Type ℓ} → {x : A i0} → {y : A i1} → (p : PathP A x y) →
     PathP (λ j → PathP (λ i → symInvo (λ i → A i) j i) x y) p (symP (symP p))
symInvoP p = refl

rUnitP : {A : I → Type ℓ} → {x : A i0} → {y : A i1} → (p : PathP A x y) →
  PathP (λ j → PathP (λ i → rUnit (λ i → A i) j i) x y) p (compPathP p refl)
rUnitP p j i = compPathP-filler p refl i j

lUnitP : {A : I → Type ℓ} → {x : A i0} → {y : A i1} → (p : PathP A x y) →
  PathP (λ j → PathP (λ i → lUnit (λ i → A i) j i) x y) p (compPathP refl p)
lUnitP {A = A} {x = x} p k i =
  comp (λ j → lUnit-filler (λ i → A i) j k i)
       (λ j → λ { (i = i0) → x
                ; (i = i1) → p (~ k ∨ j )
                ; (k = i0) → p i
                }) (p (~ k ∧ i ))

rCancelP : {A : I → Type ℓ} → {x : A i0} → {y : A i1} → (p : PathP A x y) →
   PathP (λ j → PathP (λ i → rCancel (λ i → A i) j i) x x) (compPathP p (symP p)) refl
rCancelP {A = A} {x = x} p j i =
  comp (λ k → rCancel-filler (λ i → A i) k j i)
       (λ k → λ { (i = i0) → x
                ; (i = i1) → p (~ k ∧ ~ j)
                ; (j = i1) → x
                }) (p (i ∧ ~ j))

lCancelP : {A : I → Type ℓ} → {x : A i0} → {y : A i1} → (p : PathP A x y) →
   PathP (λ j → PathP (λ i → lCancel (λ i → A i) j i) y y) (compPathP (symP p) p) refl
lCancelP p = rCancelP (symP p)

3outof4P : {A : I → I → Type ℓ} {P : (A i0 i1) ≡ (A i1 i1)}
  {B : PathP (λ j → Path (Type ℓ) (A i0 j) (A i1 j)) (λ i → A i i0) P}
  (α : ∀ (i j : I) → A j i)
  (p : PathP (λ i → P i) (α i1 i0) (α i1 i1)) →
  (β : PathP (λ j → PathP (λ i → B j i) (α j i0) (α j i1)) (λ i → α i0 i) p) →
  PathP (λ j → PathP (λ i → 3outof4 (λ j i → A i j) P B j i) (α i1 i0) (α i1 i1)) (λ i → α i1 i) p
3outof4P {A = A} {P} {B} α p β j i =
  comp (λ k → 3outof4-filler (λ j i → A i j) P B k j i)
       (λ k → λ { (i = i0) → α k i0
                ; (i = i1) → α k i1
                ; (j = i0) → α k i
                ; (j = i1) → β k i
                }) (α i0 i)

preassocP : {A : I → Type ℓ} {x : A i0} {y : A i1} {B_i1 : Type ℓ} {B : (A i1) ≡ B_i1} {z : B i1}
  {C_i1 : Type ℓ} {C : (B i1) ≡ C_i1} {w : C i1} (p : PathP A x y) (q : PathP (λ i → B i) y z) (r : PathP (λ i → C i) z w) →
  PathP (λ j → PathP (λ i → preassoc (λ i → A i) B C j i) x ((compPathP q r) j)) p (compPathP (compPathP p q) r)
preassocP {A = A} {x = x} {B = B} {C = C} p q r j i =
  comp (λ k → preassoc-filler (λ i → A i) B C k j i)
       (λ k → λ { (i = i0) → x
                ; (i = i1) → compPathP-filler q r j k
                ; (j = i0) → p i
             -- ; (j = i1) → compPathP-filler (compPathP p q) r i k
                }) (compPathP-filler p q i j)

assocP : {A : I → Type ℓ} {x : A i0} {y : A i1} {B_i1 : Type ℓ} {B : (A i1) ≡ B_i1} {z : B i1}
  {C_i1 : Type ℓ} {C : (B i1) ≡ C_i1} {w : C i1} (p : PathP A x y) (q : PathP (λ i → B i) y z) (r : PathP (λ i → C i) z w) →
  PathP (λ j → PathP (λ i → assoc (λ i → A i) B C j i) x w) (compPathP p (compPathP q r)) (compPathP (compPathP p q) r)
assocP p q r =
  3outof4P (λ i j → compPathP-filler p (compPathP q r) j i) (compPathP (compPathP p q) r) (preassocP p q r)

-- Loic's code below

-- simultaneaous composition on both sides of a path

doubleCompPath-filler : {ℓ : Level} {A : Type ℓ} {w x y z : A} → w ≡ x → x ≡ y → y ≡ z →
                        I → I → A
doubleCompPath-filler p q r i =
  hfill (λ t → λ { (i = i0) → p (~ t)
                 ; (i = i1) → r t })
        (inS (q i))

doubleCompPath : {ℓ : Level} {A : Type ℓ} {w x y z : A} → w ≡ x → x ≡ y → y ≡ z → w ≡ z
doubleCompPath p q r i = doubleCompPath-filler p q r i i1

_∙∙_∙∙_ : {ℓ : Level} {A : Type ℓ} {w x y z : A} → w ≡ x → x ≡ y → y ≡ z → w ≡ z
p ∙∙ q ∙∙ r = doubleCompPath p q r

-- some exchange law for doubleCompPath and refl

rhombus-filler : {ℓ : Level} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : y ≡ z) → I → I → A
rhombus-filler p q i j =
  hcomp (λ t → λ { (i = i0) → p (~ t ∨ j)
                 ; (i = i1) → q (t ∧ j)
                 ; (j = i0) → p (~ t ∨ i)
                 ; (j = i1) → q (t ∧ i) })
        (p i1)

leftright : {ℓ : Level} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : y ≡ z) →
            (refl ∙∙ p ∙∙ q) ≡ (p ∙∙ q ∙∙ refl)
leftright p q i j =
  hcomp (λ t → λ { (j = i0) → p (i ∧ (~ t))
                 ; (j = i1) → q (t ∨ i) })
        (rhombus-filler p q i j)

-- equating doubleCompPath and a succession of two compPath

split-leftright : {ℓ : Level} {A : Type ℓ} {w x y z : A} (p : w ≡ x) (q : x ≡ y) (r : y ≡ z) →
                  (p ∙∙ q ∙∙ r) ≡ (refl ∙∙ (p ∙∙ q ∙∙ refl) ∙∙ r)
split-leftright p q r i j =
  hcomp (λ t → λ { (j = i0) → p (~ i ∧ ~ t)
                 ; (j = i1) → r t })
        (doubleCompPath-filler p q refl j i)

split-leftright' : {ℓ : Level} {A : Type ℓ} {w x y z : A} (p : w ≡ x) (q : x ≡ y) (r : y ≡ z) →
                  (p ∙∙ q ∙∙ r) ≡ (p ∙∙ (refl ∙∙ q ∙∙ r) ∙∙ refl)
split-leftright' p q r i j =
  hcomp (λ t → λ { (j = i0) → p (~ t)
                 ; (j = i1) → r (i ∨ t) })
        (doubleCompPath-filler refl q r j i)

doubleCompPath-elim : {ℓ : Level} {A : Type ℓ} {w x y z : A} (p : w ≡ x) (q : x ≡ y)
                      (r : y ≡ z) → (p ∙∙ q ∙∙ r) ≡ (p ∙ q) ∙ r
doubleCompPath-elim p q r = (split-leftright p q r) ∙ (λ i → (leftright p q (~ i)) ∙ r)

doubleCompPath-elim' : {ℓ : Level} {A : Type ℓ} {w x y z : A} (p : w ≡ x) (q : x ≡ y)
                       (r : y ≡ z) → (p ∙∙ q ∙∙ r) ≡ p ∙ (q ∙ r)
doubleCompPath-elim' p q r = (split-leftright' p q r) ∙ (sym (leftright p (q ∙ r)))

-- deducing associativity for compPath

-- assoc : {ℓ : Level} {A : Type ℓ} {w x y z : A} (p : w ≡ x) (q : x ≡ y) (r : y ≡ z) →
--                 (p ∙ q) ∙ r ≡ p ∙ (q ∙ r)
-- assoc p q r = (sym (doubleCompPath-elim p q r)) ∙ (doubleCompPath-elim' p q r)

hcomp-unique : ∀ {ℓ} {A : Set ℓ} {φ} → (u : I → Partial φ A) → (u0 : A [ φ ↦ u i0 ]) →
               (h2 : ∀ i → A [ (φ ∨ ~ i) ↦ (\ { (φ = i1) → u i 1=1; (i = i0) → outS u0}) ])
               → (hcomp u (outS u0) ≡ outS (h2 i1)) [ φ ↦ (\ { (φ = i1) → (\ i → u i1 1=1)}) ]
hcomp-unique {φ = φ} u u0 h2 = inS (\ i → hcomp (\ k → \ { (φ = i1) → u k 1=1
                                                            ; (i = i1) → outS (h2 k) })
                                                   (outS u0))

lid-unique : ∀ {ℓ} {A : Set ℓ} {φ} → (u : I → Partial φ A) → (u0 : A [ φ ↦ u i0 ]) →
               (h1 h2 : ∀ i → A [ (φ ∨ ~ i) ↦ (\ { (φ = i1) → u i 1=1; (i = i0) → outS u0}) ])
               → (outS (h1 i1) ≡ outS (h2 i1)) [ φ ↦ (\ { (φ = i1) → (\ i → u i1 1=1)}) ]
lid-unique {φ = φ} u u0 h1 h2 = inS (\ i → hcomp (\ k → \ { (φ = i1) → u k 1=1
                                                            ; (i = i0) → outS (h1 k)
                                                            ; (i = i1) → outS (h2 k) })
                                                   (outS u0))

transp-hcomp : ∀ {ℓ} (φ : I) {A' : Set ℓ}
                     (A : (i : I) → Set ℓ [ φ ↦ (λ _ → A') ]) (let B = \ (i : I) → outS (A i))
                 → ∀ {ψ} (u : I → Partial ψ (B i0)) → (u0 : B i0 [ ψ ↦ u i0 ]) →
                 (transp B φ (hcomp u (outS u0)) ≡ hcomp (\ i o → transp B φ (u i o)) (transp B φ (outS u0)))
                   [ ψ ↦ (\ { (ψ = i1) → (\ i → transp B φ (u i1 1=1))}) ]
transp-hcomp φ A u u0 = inS (sym (outS (hcomp-unique
               ((\ i o → transp B φ (u i o))) (inS (transp B φ (outS u0)))
                 \ i → inS (transp B φ (hfill u u0 i)))))
  where
    B = \ (i : I) → outS (A i)

hcomp-cong : ∀ {ℓ} {A : Set ℓ} {φ} → (u : I → Partial φ A) → (u0 : A [ φ ↦ u i0 ]) →
                                    (u' : I → Partial φ A) → (u0' : A [ φ ↦ u' i0 ]) →

             (ueq : ∀ i → PartialP φ (\ o → u i o ≡ u' i o)) → (outS u0 ≡ outS u0') [ φ ↦ (\ { (φ = i1) → ueq i0 1=1}) ]
             → (hcomp u (outS u0) ≡ hcomp u' (outS u0')) [ φ ↦ (\ { (φ = i1) → ueq i1 1=1 }) ]
hcomp-cong u u0 u' u0' ueq 0eq = inS (\ j → hcomp (\ i o → ueq i o j) (outS 0eq j))

squeezeSq≡
  : ∀{w x y z : A}
  → (p : w ≡ y) (q : w ≡ x) (r : y ≡ z) (s : x ≡ z)
  → (q ≡ p ∙∙ r ∙∙ sym s) ≡ (Square p q r s)
squeezeSq≡ p q r s k
  = Square
      (λ j → p (j ∧ k))
      q
      (λ j → doubleCompPath-filler p r (sym s) j (~ k))
      (λ j → s (j ∧ k))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sums (disjoint unions)
------------------------------------------------------------------------

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

module Data.Sum.Base where

open import Function using (_∘_; _-[_]-_ ; id)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Level using (_⊔_)

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

infixr 1 _⊎_

data _⊎_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

------------------------------------------------------------------------
-- Functions

[_,_] : ∀ {a b c} {A : Set a} {B : Set b} {C : A ⊎ B → Set c} →
        ((x : A) → C (inj₁ x)) → ((x : B) → C (inj₂ x)) →
        ((x : A ⊎ B) → C x)
[ f , g ] (inj₁ x) = f x
[ f , g ] (inj₂ y) = g y

[_,_]′ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
         (A → C) → (B → C) → (A ⊎ B → C)
[_,_]′ = [_,_]

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

map : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} →
      (A → C) → (B → D) → (A ⊎ B → C ⊎ D)
map f g = [ inj₁ ∘ f , inj₂ ∘ g ]

map₁ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}→
       (A → C) → (A ⊎ B → C ⊎ B)
map₁ f = map f id

map₂ : ∀ {a b d} {A : Set a} {B : Set b} {D : Set d} →
       (B → D) → (A ⊎ B → A ⊎ D)
map₂ = map id

infixr 1 _-⊎-_
_-⊎-_ : ∀ {a b c d} {A : Set a} {B : Set b} →
        (A → B → Set c) → (A → B → Set d) → (A → B → Set (c ⊔ d))
f -⊎- g = f -[ _⊎_ ]- g

module _ {p} {P : Set p} where

-- Conversion back and forth with Dec

  fromDec : Dec P → P ⊎ ¬ P
  fromDec (yes p) = inj₁ p
  fromDec (no ¬p) = inj₂ ¬p

  toDec : P ⊎ ¬ P → Dec P
  toDec (inj₁ p)  = yes p
  toDec (inj₂ ¬p) = no ¬p