Proved that parametricity implies causality for signals.

open import FRP.JS.Level using ( Level ; _⊔_ ) renaming ( zero to o ; suc to ↑ )
open import FRP.JS.Time using ( Time ; _≟_ ; _≤_ ; _<_ )
open import FRP.JS.True using ( True )
open import FRP.JS.Nat using ( ℕ ; zero ; suc )

module FRP.JS.Model where

-- Preliminaries

infixr 4 _+_

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)

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

postulate
  ≤-refl : ∀ t → True (t ≤ t)
  ≤-trans : ∀ t u v → True (t ≤ u) → True (u ≤ v) → True (t ≤ v)

-- Relations on Set

_∋_↔_ : ∀ α → Set α → Set α → Set (↑ α)
α ∋ A ↔ B = A → B → Set α

-- RSets and relations on RSet

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

RSet₀ = RSet o
RSet₁ = RSet (↑ o)

_∋_⇔_ : ∀ α → RSet α → RSet α → Set (↑ α)
α ∋ A ⇔ B = ∀ t → (α ∋ A t ↔ B t)

--- Level sequences

data Levels : Set where
  ε : Levels
  _,_ : ∀ (αs : Levels) (α : Level) → Levels

max : Levels → Level
max ε = o
max (αs , α) = max αs ⊔ α

-- Sequences of Sets

Sets : ∀ αs → Set (↑ (max αs))
Sets ε        = ⊤
Sets (αs , α) = Sets αs × Set α

⟨_∋_⟩ : ∀ αs → Sets αs → Set (max αs)
⟨ ε ∋ tt ⟩ = ⊤
⟨ (αs , α) ∋ (As , A) ⟩ = ⟨ αs ∋ As ⟩ × A

_∋_↔*_ : ∀ αs → Sets αs → Sets αs → Set (↑ (max αs))
ε        ∋ tt       ↔* tt       = ⊤
(αs , α) ∋ (As , A) ↔* (Bs , B) = (αs ∋ As ↔* Bs) × (α ∋ A ↔ B)

⟨_∋_⟩² : ∀ αs {As Bs} → (αs ∋ As ↔* Bs) → (max αs ∋ ⟨ αs ∋ As ⟩ ↔ ⟨ αs ∋ Bs ⟩)
⟨ ε        ∋ tt       ⟩² tt       tt       = ⊤
⟨ (αs , α) ∋ (ℜs , ℜ) ⟩² (as , a) (bs , b) = (⟨ αs ∋ ℜs ⟩² as bs) × (ℜ a b)

-- Sequences of RSets

RSets : ∀ αs → Set (↑ (max αs))
RSets ε        = ⊤
RSets (αs , α) = RSets αs × RSet α

_∋_⇔*_ : ∀ αs → RSets αs → RSets αs → Set (↑ (max αs))
ε        ∋ tt       ⇔* tt       = ⊤
(αs , α) ∋ (As , A) ⇔* (Bs , B) = (αs ∋ As ⇔* Bs) × (α ∋ A ⇔ B)

-- Concatenation of sequences

_+_ : Levels → Levels → Levels
αs + ε        = αs
αs + (βs , β) = (αs + βs) , β

_∋_++_∋_ : ∀ αs → RSets αs → ∀ βs → RSets βs → RSets (αs + βs)
αs ∋ As ++ ε        ∋ tt       = As
αs ∋ As ++ (βs , β) ∋ (Bs , B) = ((αs ∋ As ++ βs ∋ Bs) , B)

_∋_++²_∋_ : ∀ αs {As Bs} → (αs ∋ As ⇔* Bs) → ∀ βs {Cs Ds} → (βs ∋ Cs ⇔* Ds) →
  ((αs + βs) ∋ (αs ∋ As ++ βs ∋ Cs) ⇔* (αs ∋ Bs ++ βs ∋ Ds))
αs ∋ ℜs ++² ε        ∋ tt       = ℜs
αs ∋ ℜs ++² (βs , β) ∋ (ℑs , ℑ) = ((αs ∋ ℜs ++² βs ∋ ℑs) , ℑ)

-- Intervals

_[_,_] : ∀ {α} → RSet α → Time → Time → Set α
A [ s , u ] = ∀ t → True (s ≤ t) → True (t ≤ u) → A t

_[_,_]² : ∀ {α A B} → (α ∋ A ⇔ B) → ∀ s u → (α ∋ A [ s , u ] ↔ B [ s , u ])
(ℜ [ s , u ]²) σ τ = ∀ t s≤t t≤u → ℜ t (σ t s≤t t≤u) (τ t s≤t t≤u)

-- Type variables

data TVar : Levels → Set₁ where
  zero : ∀ {αs α} → TVar (αs , α)
  suc : ∀ {αs α} → (τ : TVar αs) → TVar (αs , α)

τlevel : ∀ {αs} → TVar αs → Level
τlevel (zero {α = α}) = α
τlevel (suc τ) = τlevel τ

τ⟦_⟧ : ∀ {αs} (τ : TVar αs) → RSets αs → RSet (τlevel τ)
τ⟦ zero ⟧  (As , A) = A
τ⟦ suc τ ⟧ (As , A) = τ⟦ τ ⟧ As

τ⟦_⟧² : ∀ {αs As Bs} (τ : TVar αs) (ℜs : αs ∋ As ⇔* Bs) → (τlevel τ ∋ τ⟦ τ ⟧ As ⇔ τ⟦ τ ⟧ Bs)
τ⟦ zero ⟧²  (ℜs , ℜ) t a b = ℜ t a b
τ⟦ suc τ ⟧² (ℜs , ℜ) t a b = τ⟦ τ ⟧² ℜs t a b

-- Types

data Typ (αs : Levels) : Set₁ where
  ⟨_⟩ : (A : Set) → Typ αs
  _∧_ _⇒_ _⊵_ : (T : Typ αs) → (U : Typ αs) → Typ αs
  tvar : (τ : TVar αs) → Typ αs
  univ : ∀ α → (T : Typ (αs , α)) → Typ αs

tlevel : ∀ {αs} → Typ αs → Level
tlevel ⟨ A ⟩      = o
tlevel (T ∧ U)    = tlevel T ⊔ tlevel U
tlevel (T ⇒ U)    = tlevel T ⊔ tlevel U
tlevel (T ⊵ U)    = tlevel T ⊔ tlevel U
tlevel (tvar τ)   = τlevel τ
tlevel (univ α T) = ↑ α ⊔ tlevel T

T⟦_⟧ : ∀ {αs} (T : Typ αs) → RSets αs → RSet (tlevel T)
T⟦ ⟨ A ⟩ ⟧    As t = A
T⟦ T ∧ U ⟧    As t = T⟦ T ⟧ As t × T⟦ U ⟧ As t
T⟦ T ⇒ U ⟧    As t = T⟦ T ⟧ As t → T⟦ U ⟧ As t
T⟦ T ⊵ U ⟧    As t = ∀ u → True (t ≤ u) → T⟦ T ⟧ As [ t , u ] → T⟦ U ⟧ As u
T⟦ tvar τ ⟧   As t = τ⟦ τ ⟧ As t
T⟦ univ α T ⟧ As t = ∀ (A : RSet α) → T⟦ T ⟧ (As , A) t

T⟦_⟧² : ∀ {αs As Bs} (T : Typ αs) (ℜs : αs ∋ As ⇔* Bs) → (tlevel T ∋ T⟦ T ⟧ As ⇔ T⟦ T ⟧ Bs)
T⟦ ⟨ A ⟩ ⟧²    ℜs t a       b       = a ≡ b
T⟦ T ∧ U ⟧²    ℜs t (a , b) (c , d) = T⟦ T ⟧² ℜs t a c × T⟦ U ⟧² ℜs t b d
T⟦ T ⇒ U ⟧²    ℜs t f       g       = ∀ {a b} → T⟦ T ⟧² ℜs t a b → T⟦ U ⟧² ℜs t (f a) (g b)
T⟦ T ⊵ U ⟧²    ℜs t f       g       = ∀ u t≤u {σ τ} → (T⟦ T ⟧² ℜs [ t , u ]²) σ τ → T⟦ U ⟧² ℜs u (f u t≤u σ) (g u t≤u τ)
T⟦ tvar τ ⟧²   ℜs t v       w       = τ⟦ τ ⟧² ℜs t v w
T⟦ univ α T ⟧² ℜs t f       g       = ∀ {A B} (ℜ : α ∋ A ⇔ B) → T⟦ T ⟧² (ℜs , ℜ) t (f A) (g B)

-- Contexts

data Ctxt (αs : Levels) : Set₁ where
  ε : Ctxt αs
  _,_at_ : (Γ : Ctxt αs) (T : Typ αs) (t : Time) → Ctxt αs

clevels : ∀ {αs} → Ctxt αs → Levels
clevels ε            = ε
clevels (Γ , T at t) = (clevels Γ , tlevel T)

Γ⟦_⟧ : ∀ {αs} (Γ : Ctxt αs) → RSets αs → Sets (clevels Γ)
Γ⟦ ε ⟧          As = tt
Γ⟦ Γ , T at t ⟧ As = (Γ⟦ Γ ⟧ As , T⟦ T ⟧ As t)

Γ⟦_⟧² : ∀ {αs As Bs} (Γ : Ctxt αs) (ℜs : αs ∋ As ⇔* Bs) → (clevels Γ ∋ Γ⟦ Γ ⟧ As ↔* Γ⟦ Γ ⟧ Bs)
Γ⟦ ε ⟧²          ℜs = tt
Γ⟦ Γ , T at t ⟧² ℜs = (Γ⟦ Γ ⟧² ℜs , T⟦ T ⟧² ℜs t)

-- Weakening of type variables

τweaken : ∀ {αs} α βs → TVar (αs + βs) → TVar ((αs , α) + βs)
τweaken α ε        τ       = suc τ
τweaken α (βs , β) zero    = zero
τweaken α (βs , β) (suc τ) = suc (τweaken α βs τ)

⟦τweaken⟧ : ∀ {αs} α βs (τ : TVar (αs + βs)) As A Bs t →
  τ⟦ τ ⟧ (αs ∋ As ++ βs ∋ Bs) t → τ⟦ τweaken α βs τ ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t
⟦τweaken⟧ α ε        τ       As A Bs       t a = a
⟦τweaken⟧ α (βs , β) zero    As A Bs       t a = a
⟦τweaken⟧ α (βs , β) (suc τ) As A (Bs , B) t a = ⟦τweaken⟧ α βs τ As A Bs t a

⟦τweaken⁻¹⟧ : ∀ {αs} α βs (τ : TVar (αs + βs)) As A Bs t →
  τ⟦ τweaken α βs τ ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t → τ⟦ τ ⟧ (αs ∋ As ++ βs ∋ Bs) t
⟦τweaken⁻¹⟧ α ε        τ       As A Bs       t a = a
⟦τweaken⁻¹⟧ α (βs , β) zero    As A Bs       t a = a
⟦τweaken⁻¹⟧ α (βs , β) (suc τ) As A (Bs , B) t a = ⟦τweaken⁻¹⟧ α βs τ As A Bs t a

⟦τweaken⟧² : ∀ {αs} α βs (τ : TVar (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
  τ⟦ τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
  τ⟦ τweaken α βs τ ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t (⟦τweaken⟧ α βs τ As A Cs t a) (⟦τweaken⟧ α βs τ Bs B Ds t b)
⟦τweaken⟧² α ε        τ       ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⟧² α (βs , β) zero    ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⟧² α (βs , β) (suc τ) ℜs ℜ (ℑs , ℑ) t aℜb = ⟦τweaken⟧² α βs τ ℜs ℜ ℑs t aℜb

⟦τweaken⁻¹⟧² : ∀ {αs} α βs (τ : TVar (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
  τ⟦ τweaken α βs τ ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t a b →
  τ⟦ τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦τweaken⁻¹⟧ α βs τ As A Cs t a) (⟦τweaken⁻¹⟧ α βs τ Bs B Ds t b)
⟦τweaken⁻¹⟧² α ε        τ       ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⁻¹⟧² α (βs , β) zero    ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⁻¹⟧² α (βs , β) (suc τ) ℜs ℜ (ℑs , ℑ) t aℜb = ⟦τweaken⁻¹⟧² α βs τ ℜs ℜ ℑs t aℜb

-- Weakening of types

tweaken : ∀ {αs} α βs → Typ (αs + βs) → Typ ((αs , α) + βs)
tweaken α βs ⟨ A ⟩      = ⟨ A ⟩
tweaken α βs (T ∧ U)    = tweaken α βs T ∧ tweaken α βs U
tweaken α βs (T ⇒ U)    = tweaken α βs T ⇒ tweaken α βs U
tweaken α βs (T ⊵ U)    = tweaken α βs T ⊵ tweaken α βs U
tweaken α βs (tvar τ)   = tvar (τweaken α βs τ)
tweaken α βs (univ β T) = univ β (tweaken α (βs , β) T)

mutual

  ⟦tweaken⟧ : ∀ {αs} α βs (T : Typ (αs + βs)) As A Bs t →
    T⟦ T ⟧ (αs ∋ As ++ βs ∋ Bs) t →
    T⟦ tweaken α βs T ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t
  ⟦tweaken⟧ α βs ⟨ B ⟩      As A Bs t a       = a
  ⟦tweaken⟧ α βs (T ∧ U)    As A Bs t (a , b) = (⟦tweaken⟧ α βs T As A Bs t a , ⟦tweaken⟧ α βs U As A Bs t b)
  ⟦tweaken⟧ α βs (T ⇒ U)    As A Bs t f       = λ a → ⟦tweaken⟧ α βs U As A Bs t (f (⟦tweaken⁻¹⟧ α βs T As A Bs t a))
  ⟦tweaken⟧ α βs (T ⊵ U)    As A Bs t f       = λ v t≤v σ → ⟦tweaken⟧ α βs U As A Bs v (f v t≤v (λ u t≤u u≤v → ⟦tweaken⁻¹⟧ α βs T As A Bs u (σ u t≤u u≤v)))
  ⟦tweaken⟧ α βs (tvar τ)   As A Bs t a       = ⟦τweaken⟧ α βs τ As A Bs t a
  ⟦tweaken⟧ α βs (univ β T) As A Bs t f       = λ B → ⟦tweaken⟧ α (βs , β) T As A (Bs , B) t (f B)

  ⟦tweaken⁻¹⟧ : ∀ {αs} α βs (T : Typ (αs + βs)) As A Bs t →
    T⟦ tweaken α βs T ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t →
    T⟦ T ⟧ (αs ∋ As ++ βs ∋ Bs) t
  ⟦tweaken⁻¹⟧ α βs ⟨ B ⟩      As A Bs t a       = a
  ⟦tweaken⁻¹⟧ α βs (T ∧ U)    As A Bs t (a , b) = (⟦tweaken⁻¹⟧ α βs T As A Bs t a , ⟦tweaken⁻¹⟧ α βs U As A Bs t b)
  ⟦tweaken⁻¹⟧ α βs (T ⇒ U)    As A Bs t f       = λ a → ⟦tweaken⁻¹⟧ α βs U As A Bs t (f (⟦tweaken⟧ α βs T As A Bs t a))
  ⟦tweaken⁻¹⟧ α βs (T ⊵ U)    As A Bs t f       = λ v t≤v σ → ⟦tweaken⁻¹⟧ α βs U As A Bs v (f v t≤v (λ u t≤u u≤v → ⟦tweaken⟧ α βs T As A Bs u (σ u t≤u u≤v)))
  ⟦tweaken⁻¹⟧ α βs (tvar τ)   As A Bs t a       = ⟦τweaken⁻¹⟧ α βs τ As A Bs t a
  ⟦tweaken⁻¹⟧ α βs (univ β T) As A Bs t f       = λ B → ⟦tweaken⁻¹⟧ α (βs , β) T As A (Bs , B) t (f B)

mutual

  ⟦tweaken⟧² : ∀ {αs} α βs (T : Typ (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
    T⟦ T ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
    T⟦ tweaken α βs T ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t (⟦tweaken⟧ α βs T As A Cs t a) (⟦tweaken⟧ α βs T Bs B Ds t b)
  ⟦tweaken⟧² α βs ⟨ B ⟩      ℜs ℜ ℑs t aℜb         = aℜb
  ⟦tweaken⟧² α βs (T ∧ U)    ℜs ℜ ℑs t (aℜb , cℜd) = (⟦tweaken⟧² α βs T ℜs ℜ ℑs t aℜb , ⟦tweaken⟧² α βs U ℜs ℜ ℑs t cℜd)
  ⟦tweaken⟧² α βs (T ⇒ U)    ℜs ℜ ℑs t fℜg         = λ aℜb → ⟦tweaken⟧² α βs U ℜs ℜ ℑs t (fℜg (⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs t aℜb))
  ⟦tweaken⟧² α βs (T ⊵ U)    ℜs ℜ ℑs t fℜg         = λ v t≤v σℜτ → ⟦tweaken⟧² α βs U ℜs ℜ ℑs v (fℜg v t≤v (λ u t≤u u≤v → ⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs u (σℜτ u t≤u u≤v)))
  ⟦tweaken⟧² α βs (tvar τ)   ℜs ℜ ℑs t aℜb         = ⟦τweaken⟧² α βs τ ℜs ℜ ℑs t aℜb
  ⟦tweaken⟧² α βs (univ β T) ℜs ℜ ℑs t fℜg         = λ ℑ → ⟦tweaken⟧² α (βs , β) T ℜs ℜ (ℑs , ℑ) t (fℜg ℑ)

  ⟦tweaken⁻¹⟧² : ∀ {αs} α βs (T : Typ (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
    T⟦ tweaken α βs T ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t a b →
    T⟦ T ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦tweaken⁻¹⟧ α βs T As A Cs t a) (⟦tweaken⁻¹⟧ α βs T Bs B Ds t b)
  ⟦tweaken⁻¹⟧² α βs ⟨ B ⟩      ℜs ℜ ℑs t aℜb         = aℜb
  ⟦tweaken⁻¹⟧² α βs (T ∧ U)    ℜs ℜ ℑs t (aℜb , cℜd) = (⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs t aℜb , ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs t cℜd)
  ⟦tweaken⁻¹⟧² α βs (T ⇒ U)    ℜs ℜ ℑs t fℜg         = λ aℜb → ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs t (fℜg (⟦tweaken⟧² α βs T ℜs ℜ ℑs t aℜb))
  ⟦tweaken⁻¹⟧² α βs (T ⊵ U)    ℜs ℜ ℑs t fℜg         = λ v t≤v σℜτ → ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs v (fℜg v t≤v (λ u t≤u u≤v → ⟦tweaken⟧² α βs T ℜs ℜ ℑs u (σℜτ u t≤u u≤v)))
  ⟦tweaken⁻¹⟧² α βs (tvar τ)   ℜs ℜ ℑs t aℜb         = ⟦τweaken⁻¹⟧² α βs τ ℜs ℜ ℑs t aℜb
  ⟦tweaken⁻¹⟧² α βs (univ β T) ℜs ℜ ℑs t fℜg         = λ ℑ → ⟦tweaken⁻¹⟧² α (βs , β) T ℜs ℜ (ℑs , ℑ) t (fℜg ℑ)

-- Weakening of contexts

cweaken : ∀ {αs} α → Ctxt αs → Ctxt (αs , α)
cweaken α ε            = ε
cweaken α (Γ , T at t) = (cweaken α Γ , tweaken α ε T at t)

⟦cweaken⟧ : ∀ {αs} α (Γ : Ctxt αs) As A → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → ⟨ clevels (cweaken α Γ) ∋ Γ⟦ cweaken α Γ ⟧ (As , A) ⟩
⟦cweaken⟧ α ε            As A tt       = tt
⟦cweaken⟧ α (Γ , T at t) As A (as , a) = (⟦cweaken⟧ α Γ As A as , ⟦tweaken⟧ α ε T As A tt t a)

⟦cweaken⟧² : ∀ {αs} α (Γ : Ctxt αs) {As Bs A B} ℜs ℜ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs →
  ⟨ clevels (cweaken α Γ) ∋ Γ⟦ cweaken α Γ ⟧² (ℜs , ℜ) ⟩² (⟦cweaken⟧ α Γ As A as) (⟦cweaken⟧ α Γ Bs B bs)
⟦cweaken⟧² α ε            ℜs ℜ tt            = tt
⟦cweaken⟧² α (Γ , T at t) ℜs ℜ (asℜbs , aℜb) = (⟦cweaken⟧² α Γ ℜs ℜ asℜbs , ⟦tweaken⟧² α ε T ℜs ℜ tt t aℜb)

-- Substitution into type variables

τsubst : ∀ {αs} (T : Typ αs) βs → TVar ((αs , tlevel T) + βs) → Typ (αs + βs)
τsubst T ε        zero    = T
τsubst T ε        (suc τ) = tvar τ
τsubst T (βs , β) zero    = tvar zero
τsubst T (βs , β) (suc τ) = tweaken β ε (τsubst T βs τ)

⟦τsubst⟧ : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) As Bs t →
  τ⟦ τ ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t →
  T⟦ τsubst T βs τ ⟧ (αs ∋ As ++ βs ∋ Bs) t
⟦τsubst⟧      T ε        zero    As Bs       t a = a
⟦τsubst⟧      T ε        (suc τ) As Bs       t a = a
⟦τsubst⟧      T (βs , β) zero    As Bs       t a = a
⟦τsubst⟧ {αs} T (βs , β) (suc τ) As (Bs , B) t a =
  ⟦tweaken⟧ β ε (τsubst T βs τ) (αs ∋ As ++ βs ∋ Bs) B tt t
    (⟦τsubst⟧ T βs τ As Bs t a)

⟦τsubst⁻¹⟧ : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) As Bs t →
  T⟦ τsubst T βs τ ⟧ (αs ∋ As ++ βs ∋ Bs) t →
  τ⟦ τ ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t
⟦τsubst⁻¹⟧      T ε        zero    As Bs       t a = a
⟦τsubst⁻¹⟧      T ε        (suc τ) As Bs       t a = a
⟦τsubst⁻¹⟧      T (βs , β) zero    As Bs       t a = a
⟦τsubst⁻¹⟧ {αs} T (βs , β) (suc τ) As (Bs , B) t a =
  ⟦τsubst⁻¹⟧ T βs τ As Bs t
    (⟦tweaken⁻¹⟧ β ε (τsubst T βs τ) (αs ∋ As ++ βs ∋ Bs) B tt t a)

⟦τsubst⟧² : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
  τ⟦ τ ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t a b →
  T⟦ τsubst T βs τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦τsubst⟧ T βs τ As Bs t a) (⟦τsubst⟧ T βs τ Cs Ds t b)
⟦τsubst⟧²      T ε        zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧²      T ε        (suc τ) ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧²      T (βs , β) zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧² {αs} T (βs , β) (suc τ) ℜs (ℑs , ℑ) t aℜb =
  ⟦tweaken⟧² β ε (τsubst T βs τ) (αs ∋ ℜs ++² βs ∋ ℑs) ℑ tt t
    (⟦τsubst⟧² T βs τ ℜs ℑs t aℜb)

⟦τsubst⁻¹⟧² : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
  T⟦ τsubst T βs τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
  τ⟦ τ ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t (⟦τsubst⁻¹⟧ T βs τ As Bs t a) (⟦τsubst⁻¹⟧ T βs τ Cs Ds t b)
⟦τsubst⁻¹⟧²      T ε        zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧²      T ε        (suc τ) ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧²      T (βs , β) zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧² {αs} T (βs , β) (suc τ) ℜs (ℑs , ℑ) t aℜb =
  ⟦τsubst⁻¹⟧² T βs τ ℜs ℑs t
    (⟦tweaken⁻¹⟧² β ε (τsubst T βs τ) (αs ∋ ℜs ++² βs ∋ ℑs) ℑ tt t aℜb)

-- Substitution into types

tsubst : ∀ {αs} (T : Typ αs) βs → Typ ((αs , tlevel T) + βs) → Typ (αs + βs)
tsubst T βs ⟨ A ⟩      = ⟨ A ⟩
tsubst T βs (U ∧ V)    = tsubst T βs U ∧ tsubst T βs V
tsubst T βs (U ⇒ V)    = tsubst T βs U ⇒ tsubst T βs V
tsubst T βs (U ⊵ V)    = tsubst T βs U ⊵ tsubst T βs V
tsubst T βs (tvar τ)   = τsubst T βs τ
tsubst T βs (univ β U) = univ β (tsubst T (βs , β) U)

mutual

  ⟦tsubst⟧ : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) As Bs t →
    T⟦ U ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t →
    T⟦ tsubst T βs U ⟧ (αs ∋ As ++ βs ∋ Bs) t
  ⟦tsubst⟧ T βs ⟨ A ⟩      As Bs t a       = a
  ⟦tsubst⟧ T βs (U ∧ V)    As Bs t (a , b) = (⟦tsubst⟧ T βs U As Bs t a , ⟦tsubst⟧ T βs V As Bs t b)
  ⟦tsubst⟧ T βs (U ⇒ V)    As Bs t f       = λ a → ⟦tsubst⟧ T βs V As Bs t (f (⟦tsubst⁻¹⟧ T βs U As Bs t a))
  ⟦tsubst⟧ T βs (U ⊵ V)    As Bs t f       = λ v t≤v σ → ⟦tsubst⟧ T βs V As Bs v (f v t≤v (λ u t≤u u≤v → ⟦tsubst⁻¹⟧ T βs U As Bs u (σ u t≤u u≤v)))
  ⟦tsubst⟧ T βs (tvar τ)   As Bs t a       = ⟦τsubst⟧ T βs τ As Bs t a
  ⟦tsubst⟧ T βs (univ β U) As Bs t f       = λ B → ⟦tsubst⟧ T (βs , β) U As (Bs , B) t (f B)

  ⟦tsubst⁻¹⟧ : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) As Bs t →
    T⟦ tsubst T βs U ⟧ (αs ∋ As ++ βs ∋ Bs) t →
    T⟦ U ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t
  ⟦tsubst⁻¹⟧ T βs ⟨ A ⟩      As Bs t a       = a
  ⟦tsubst⁻¹⟧ T βs (U ∧ V)    As Bs t (a , b) = (⟦tsubst⁻¹⟧ T βs U As Bs t a , ⟦tsubst⁻¹⟧ T βs V As Bs t b)
  ⟦tsubst⁻¹⟧ T βs (U ⇒ V)    As Bs t f       = λ a → ⟦tsubst⁻¹⟧ T βs V As Bs t (f (⟦tsubst⟧ T βs U As Bs t a))
  ⟦tsubst⁻¹⟧ T βs (U ⊵ V)    As Bs t f       = λ v t≤v σ → ⟦tsubst⁻¹⟧ T βs V As Bs v (f v t≤v (λ u t≤u u≤v → ⟦tsubst⟧ T βs U As Bs u (σ u t≤u u≤v)))
  ⟦tsubst⁻¹⟧ T βs (tvar τ)   As Bs t a       = ⟦τsubst⁻¹⟧ T βs τ As Bs t a
  ⟦tsubst⁻¹⟧ T βs (univ β U) As Bs t f       = λ B → ⟦tsubst⁻¹⟧ T (βs , β) U As (Bs , B) t (f B)

mutual

  ⟦tsubst⟧² : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
    T⟦ U ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t a b →
    T⟦ tsubst T βs U ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦tsubst⟧ T βs U As Bs t a) (⟦tsubst⟧ T βs U Cs Ds t b)
  ⟦tsubst⟧² T βs ⟨ A ⟩      ℜs ℑs t aℜb         = aℜb
  ⟦tsubst⟧² T βs (U ∧ V)    ℜs ℑs t (aℜb , cℜd) = (⟦tsubst⟧² T βs U ℜs ℑs t aℜb , ⟦tsubst⟧² T βs V ℜs ℑs t cℜd)
  ⟦tsubst⟧² T βs (U ⇒ V)    ℜs ℑs t fℜg         = λ aℜb → ⟦tsubst⟧² T βs V ℜs ℑs t (fℜg (⟦tsubst⁻¹⟧² T βs U ℜs ℑs t aℜb))
  ⟦tsubst⟧² T βs (U ⊵ V)    ℜs ℑs t fℜg         = λ v t≤v σℜτ → ⟦tsubst⟧² T βs V ℜs ℑs v (fℜg v t≤v (λ u t≤u u≤v → ⟦tsubst⁻¹⟧² T βs U ℜs ℑs u (σℜτ u t≤u u≤v)))
  ⟦tsubst⟧² T βs (tvar τ)   ℜs ℑs t aℜb         = ⟦τsubst⟧² T βs τ ℜs ℑs t aℜb
  ⟦tsubst⟧² T βs (univ β U) ℜs ℑs t fℜg         = λ ℑ → ⟦tsubst⟧² T (βs , β) U ℜs (ℑs , ℑ) t (fℜg ℑ)

  ⟦tsubst⁻¹⟧² : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
    T⟦ tsubst T βs U ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
    T⟦ U ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t (⟦tsubst⁻¹⟧ T βs U As Bs t a) (⟦tsubst⁻¹⟧ T βs U Cs Ds t b)
  ⟦tsubst⁻¹⟧² T βs ⟨ A ⟩      ℜs ℑs t aℜb         = aℜb
  ⟦tsubst⁻¹⟧² T βs (U ∧ V)    ℜs ℑs t (aℜb , cℜd) = (⟦tsubst⁻¹⟧² T βs U ℜs ℑs t aℜb , ⟦tsubst⁻¹⟧² T βs V ℜs ℑs t cℜd)
  ⟦tsubst⁻¹⟧² T βs (U ⇒ V)    ℜs ℑs t fℜg         = λ aℜb → ⟦tsubst⁻¹⟧² T βs V ℜs ℑs t (fℜg (⟦tsubst⟧² T βs U ℜs ℑs t aℜb))
  ⟦tsubst⁻¹⟧² T βs (U ⊵ V)    ℜs ℑs t fℜg         = λ v t≤v σℜτ → ⟦tsubst⁻¹⟧² T βs V ℜs ℑs v (fℜg v t≤v (λ u t≤u u≤v → ⟦tsubst⟧² T βs U ℜs ℑs u (σℜτ u t≤u u≤v)))
  ⟦tsubst⁻¹⟧² T βs (tvar τ)   ℜs ℑs t aℜb         = ⟦τsubst⁻¹⟧² T βs τ ℜs ℑs t aℜb
  ⟦tsubst⁻¹⟧² T βs (univ β U) ℜs ℑs t fℜg         = λ ℑ → ⟦tsubst⁻¹⟧² T (βs , β) U ℜs (ℑs , ℑ) t (fℜg ℑ)

-- Variables

data Var {αs} (T : Typ αs) (t : Time) : (Γ : Ctxt αs) → Set₁ where
  zero : ∀ {Γ : Ctxt αs} → Var T t (Γ , T at t)
  suc : ∀ {Γ : Ctxt αs} {U : Typ αs} {u} → Var T t Γ → Var T t (Γ , U at u)

v⟦_⟧ : ∀ {αs} {Γ : Ctxt αs} {T : Typ αs} {t} → Var T t Γ → ∀ As → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → T⟦ T ⟧ As t
v⟦ zero ⟧  As (as , a) = a
v⟦ suc v ⟧ As (as , a) = v⟦ v ⟧ As as

v⟦_⟧² : ∀ {αs As Bs} {Γ : Ctxt αs} {T : Typ αs} {t} (τ : Var T t Γ) (ℜs : αs ∋ As ⇔* Bs) →
  ∀ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs → T⟦ T ⟧² ℜs t (v⟦ τ ⟧ As as) (v⟦ τ ⟧ Bs bs)
v⟦ zero ⟧²  ℜs (asℜbs , aℜb) = aℜb
v⟦ suc v ⟧² ℜs (asℜbs , aℜb) = v⟦ v ⟧² ℜs asℜbs

-- Expressions

data Exp : ∀ {αs} → Ctxt αs → Typ αs → RSet₁ where
  const : ∀ {αs Γ A t} → (a : A) → Exp {αs} Γ ⟨ A ⟩ t
  pair : ∀ {αs Γ T U t} → (e : Exp Γ T t) → (f : Exp Γ U t) → Exp {αs} Γ (T ∧ U) t
  fst : ∀ {αs Γ T U t} → (e : Exp Γ (T ∧ U) t) → Exp {αs} Γ T t
  snd : ∀ {αs Γ T U t} → (e : Exp Γ (T ∧ U) t) → Exp {αs} Γ U t
  abs : ∀ {αs Γ T U t} → (e : Exp (Γ , T at t) U t) → Exp {αs} Γ (T ⇒ U) t
  app : ∀ {αs Γ T U t} → (f : Exp Γ (T ⇒ U) t) → (e : Exp Γ T t) → Exp {αs} Γ U t
  var : ∀ {αs Γ T t} → (v : Var T t Γ) → Exp {αs} Γ T t
  tabs : ∀ {αs Γ} α {T t} → (e : Exp (cweaken α Γ) T t) → Exp {αs} Γ (univ α T) t
  tapp : ∀ {αs Γ t} (T : Typ αs) {U} → (e : Exp Γ (univ (tlevel T) U) t) → Exp {αs} Γ (tsubst T ε U) t

e⟦_⟧ : ∀ {αs} {Γ : Ctxt αs} {T : Typ αs} {t} → Exp Γ T t → ∀ As → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → T⟦ T ⟧ As t
e⟦ const a ⟧                  As as = a
e⟦ pair e f ⟧                 As as = (e⟦ e ⟧ As as , e⟦ f ⟧ As as)
e⟦ fst e ⟧                    As as = proj₁ (e⟦ e ⟧ As as)
e⟦ snd e ⟧                    As as = proj₂ (e⟦ e ⟧ As as)
e⟦ abs e ⟧                    As as = λ a → e⟦ e ⟧ As (as , a)
e⟦ app f e ⟧                  As as = e⟦ f ⟧ As as (e⟦ e ⟧ As as)
e⟦ var v ⟧                    As as = v⟦ v ⟧ As as
e⟦ tabs {Γ = Γ} α e ⟧         As as = λ A → e⟦ e ⟧ (As , A) (⟦cweaken⟧ α Γ As A as)
e⟦ tapp {t = t} T {U = U} e ⟧ As as = ⟦tsubst⟧ T ε U As tt t (e⟦ e ⟧ As as (T⟦ T ⟧ As))

e⟦_⟧² : ∀ {αs As Bs} {Γ : Ctxt αs} {T : Typ αs} {t} (e : Exp Γ T t) (ℜs : αs ∋ As ⇔* Bs) →
  ∀ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs → T⟦ T ⟧² ℜs t (e⟦ e ⟧ As as) (e⟦ e ⟧ Bs bs)
e⟦ const a ⟧²                  ℜs asℜbs = refl
e⟦ pair e f ⟧²                 ℜs asℜbs = (e⟦ e ⟧² ℜs asℜbs , e⟦ f ⟧² ℜs asℜbs)
e⟦ fst e ⟧²                    ℜs asℜbs = proj₁ (e⟦ e ⟧² ℜs asℜbs)
e⟦ snd e ⟧²                    ℜs asℜbs = proj₂ (e⟦ e ⟧² ℜs asℜbs)
e⟦ abs e ⟧²                    ℜs asℜbs = λ aℜb → e⟦ e ⟧² ℜs (asℜbs , aℜb)
e⟦ app f e ⟧²                  ℜs asℜbs = e⟦ f ⟧² ℜs asℜbs (e⟦ e ⟧² ℜs asℜbs)
e⟦ var v ⟧²                    ℜs asℜbs = v⟦ v ⟧² ℜs asℜbs
e⟦ tabs {Γ = Γ} α e ⟧²         ℜs asℜbs = λ ℜ → e⟦ e ⟧² (ℜs , ℜ) (⟦cweaken⟧² α Γ ℜs ℜ asℜbs)
e⟦ tapp {t = t} T {U = U} e ⟧² ℜs asℜbs = ⟦tsubst⟧² T ε U ℜs tt t (e⟦ e ⟧² ℜs asℜbs (T⟦ T ⟧² ℜs))

-- Surface level types

data STyp : Set₁ where
  ⟨_⟩ : (A : Set) → STyp
  _∧_ _⇒_ : (T : STyp) → (U : STyp) → STyp
  □ : (T : STyp) → STyp

-- Translation of surface level types into types

⟪_⟫ : STyp → Typ (ε , o)
⟪ ⟨ A ⟩ ⟫ = ⟨ A ⟩
⟪ T ∧ U ⟫ = ⟪ T ⟫ ∧ ⟪ U ⟫
⟪ T ⇒ U ⟫ = ⟪ T ⟫ ⇒ ⟪ U ⟫
⟪ □ T ⟫   = tvar zero ⊵ ⟪ T ⟫

T⟪_⟫ : STyp → RSet₀
T⟪ ⟨ A ⟩ ⟫ t = A
T⟪ T ∧ U ⟫ t = T⟪ T ⟫ t × T⟪ U ⟫ t
T⟪ T ⇒ U ⟫ t = T⟪ T ⟫ t → T⟪ U ⟫ t
T⟪ □ T ⟫   t = ∀ u → True (t ≤ u) → T⟪ T ⟫ u

World : RSet₀
World t = ⊤

mutual

  trans : ∀ T {t} → T⟪ T ⟫ t → T⟦ ⟪ T ⟫ ⟧ (tt , World) t
  trans ⟨ A ⟩   a       = a
  trans (T ∧ U) (a , b) = (trans T a , trans U b)
  trans (T ⇒ U) f       = λ a → trans U (f (trans⁻¹ T a))
  trans (□ T)   σ       = λ u t≤u τ → trans T (σ u t≤u)

  trans⁻¹ : ∀ T {t} → T⟦ ⟪ T ⟫ ⟧ (tt , World) t → T⟪ T ⟫ t
  trans⁻¹ ⟨ A ⟩   a       = a
  trans⁻¹ (T ∧ U) (a , b) = (trans⁻¹ T a , trans⁻¹ U b)
  trans⁻¹ (T ⇒ U) f       = λ a → trans⁻¹ U (f (trans T a))
  trans⁻¹ (□ T)   σ       = λ u t≤u → trans⁻¹ T (σ u t≤u _)

-- Causality

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

Causal : ∀ T U t → T⟪ T ⇒ U ⟫ t → Set
Causal T U t f = ∀ u t≤u {a b} → (T at t ∋ a ≈[ u ∵ t≤u ] b) → (U at t ∋ f a ≈[ u ∵ t≤u ] f b)

-- Parametricity implies causality

ℜ[_] : Time → (o ∋ World ⇔ World)
ℜ[ u ] t tt tt = True (t ≤ u)

mutual

  ℜ-impl-≈ : ∀ T t u t≤u {a b} →
    T⟦ ⟪ T ⟫ ⟧² (tt , ℜ[ u ]) t a b →
    (T at t ∋ trans⁻¹ T a ≈[ u ∵ t≤u ] trans⁻¹ T b)
  ℜ-impl-≈ ⟨ A ⟩   t u t≤u aℜb         = aℜb
  ℜ-impl-≈ (T ∧ U) t u t≤u (aℜc , bℜd) = (ℜ-impl-≈ T t u t≤u aℜc , ℜ-impl-≈ U t u t≤u bℜd)
  ℜ-impl-≈ (T ⇒ U) t u t≤u fℜg         = λ a≈b → ℜ-impl-≈ U t u t≤u (fℜg (≈-impl-ℜ T t u t≤u a≈b))
  ℜ-impl-≈ (□ T)   s v s≤v σℜτ         = λ u s≤u u≤v → ℜ-impl-≈ T u v u≤v (σℜτ u s≤u (λ t s≤t t≤u → ≤-trans t u v t≤u u≤v))

  ≈-impl-ℜ : ∀ T t u t≤u {a b} →
    (T at t ∋ a ≈[ u ∵ t≤u ] b) →
    T⟦ ⟪ T ⟫ ⟧² (tt , ℜ[ u ]) t (trans T a) (trans T b)
  ≈-impl-ℜ ⟨ A ⟩   t u t≤u a≈b         = a≈b
  ≈-impl-ℜ (T ∧ U) t u t≤u (a≈c , b≈d) = (≈-impl-ℜ T t u t≤u a≈c , ≈-impl-ℜ U t u t≤u b≈d)
  ≈-impl-ℜ (T ⇒ U) t u t≤u f≈g         = λ aℜb → ≈-impl-ℜ U t u t≤u (f≈g (ℜ-impl-≈ T t u t≤u aℜb))
  ≈-impl-ℜ (□ T)   s v s≤v σ≈τ         = λ u s≤u ρ → ≈-impl-ℜ T u v (ρ u s≤u (≤-refl u)) (σ≈τ u s≤u (ρ u s≤u (≤-refl u)))

-- Every expression is causal

e⟪_at_∋_⟫ : ∀ T t → Exp ε ⟪ T ⟫ t → T⟪ T ⟫ t
e⟪ T at t ∋ e ⟫ = trans⁻¹ T (e⟦ e ⟧ (tt , World) tt)

causality : ∀ T U t f → Causal T U t e⟪ (T ⇒ U) at t ∋ f ⟫
causality T U t f u t≤u = ℜ-impl-≈ (T ⇒ U) t u t≤u (e⟦ f ⟧² (tt , ℜ[ u ]) tt)

open import FRP.JS.Level using ( Level ; _⊔_ ) renaming ( zero to o ; suc to ↑ )
open import FRP.JS.Time using ( Time ; _≟_ ; _≤_ ; _<_ )
open import FRP.JS.True using ( True )
open import FRP.JS.Nat using ( ℕ ; zero ; suc )

module FRP.JS.Model where

-- Preliminaries

infixr 4 _+_

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)

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

-- Relations on Set

_∋_↔_ : ∀ α → Set α → Set α → Set (↑ α)
α ∋ A ↔ B = A → B → Set α

-- RSets and relations on RSet

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

RSet₀ = RSet o
RSet₁ = RSet (↑ o)

_∋_⇔_ : ∀ α → RSet α → RSet α → Set (↑ α)
α ∋ A ⇔ B = ∀ t → (α ∋ A t ↔ B t)

--- Level sequences

data Levels : Set where
  ε : Levels
  _,_ : ∀ (αs : Levels) (α : Level) → Levels

max : Levels → Level
max ε = o
max (αs , α) = max αs ⊔ α

-- Sequences of Sets

Sets : ∀ αs → Set (↑ (max αs))
Sets ε        = ⊤
Sets (αs , α) = Sets αs × Set α

⟨_∋_⟩ : ∀ αs → Sets αs → Set (max αs)
⟨ ε ∋ tt ⟩ = ⊤
⟨ (αs , α) ∋ (As , A) ⟩ = ⟨ αs ∋ As ⟩ × A

_∋_↔*_ : ∀ αs → Sets αs → Sets αs → Set (↑ (max αs))
ε        ∋ tt       ↔* tt       = ⊤
(αs , α) ∋ (As , A) ↔* (Bs , B) = (αs ∋ As ↔* Bs) × (α ∋ A ↔ B)

⟨_∋_⟩² : ∀ αs {As Bs} → (αs ∋ As ↔* Bs) → (max αs ∋ ⟨ αs ∋ As ⟩ ↔ ⟨ αs ∋ Bs ⟩)
⟨ ε        ∋ tt       ⟩² tt       tt       = ⊤
⟨ (αs , α) ∋ (ℜs , ℜ) ⟩² (as , a) (bs , b) = (⟨ αs ∋ ℜs ⟩² as bs) × (ℜ a b)

-- Sequences of RSets

RSets : ∀ αs → Set (↑ (max αs))
RSets ε        = ⊤
RSets (αs , α) = RSets αs × RSet α

_∋_⇔*_ : ∀ αs → RSets αs → RSets αs → Set (↑ (max αs))
ε        ∋ tt       ⇔* tt       = ⊤
(αs , α) ∋ (As , A) ⇔* (Bs , B) = (αs ∋ As ⇔* Bs) × (α ∋ A ⇔ B)

-- Concatenation of sequences

_+_ : Levels → Levels → Levels
αs + ε        = αs
αs + (βs , β) = (αs + βs) , β

_∋_++_∋_ : ∀ αs → RSets αs → ∀ βs → RSets βs → RSets (αs + βs)
αs ∋ As ++ ε        ∋ tt       = As
αs ∋ As ++ (βs , β) ∋ (Bs , B) = ((αs ∋ As ++ βs ∋ Bs) , B)

_∋_++²_∋_ : ∀ αs {As Bs} → (αs ∋ As ⇔* Bs) → ∀ βs {Cs Ds} → (βs ∋ Cs ⇔* Ds) →
  ((αs + βs) ∋ (αs ∋ As ++ βs ∋ Cs) ⇔* (αs ∋ Bs ++ βs ∋ Ds))
αs ∋ ℜs ++² ε        ∋ tt       = ℜs
αs ∋ ℜs ++² (βs , β) ∋ (ℑs , ℑ) = ((αs ∋ ℜs ++² βs ∋ ℑs) , ℑ)

-- Type variables

data TVar : Levels → Set₁ where
  zero : ∀ {αs α} → TVar (αs , α)
  suc : ∀ {αs α} → (τ : TVar αs) → TVar (αs , α)

τlevel : ∀ {αs} → TVar αs → Level
τlevel (zero {α = α}) = α
τlevel (suc τ) = τlevel τ

τ⟦_⟧ : ∀ {αs} (τ : TVar αs) → RSets αs → RSet (τlevel τ)
τ⟦ zero ⟧  (As , A) = A
τ⟦ suc τ ⟧ (As , A) = τ⟦ τ ⟧ As

τ⟦_⟧² : ∀ {αs As Bs} (τ : TVar αs) (ℜs : αs ∋ As ⇔* Bs) → (τlevel τ ∋ τ⟦ τ ⟧ As ⇔ τ⟦ τ ⟧ Bs)
τ⟦ zero ⟧²  (ℜs , ℜ) t a b = ℜ t a b
τ⟦ suc τ ⟧² (ℜs , ℜ) t a b = τ⟦ τ ⟧² ℜs t a b

-- Types

data Typ (αs : Levels) : Set₁ where
  ⟨_⟩ : (A : Set) → Typ αs
  _∧_ _⇒_ : (T : Typ αs) → (U : Typ αs) → Typ αs
  var : (τ : TVar αs) → Typ αs
  univ : ∀ α → (T : Typ (αs , α)) → Typ αs

tlevel : ∀ {αs} → Typ αs → Level
tlevel ⟨ A ⟩ = o
tlevel (T ∧ U) = tlevel T ⊔ tlevel U
tlevel (T ⇒ U) = tlevel T ⊔ tlevel U
tlevel (var τ) = τlevel τ
tlevel (univ α T) = ↑ α ⊔ tlevel T

T⟦_⟧ : ∀ {αs} (T : Typ αs) → RSets αs → RSet (tlevel T)
T⟦ ⟨ A ⟩ ⟧    As t = A
T⟦ T ∧ U ⟧    As t = T⟦ T ⟧ As t × T⟦ U ⟧ As t
T⟦ T ⇒ U ⟧    As t = T⟦ T ⟧ As t → T⟦ U ⟧ As t
T⟦ var τ ⟧    As t = τ⟦ τ ⟧ As t
T⟦ univ α T ⟧ As t = ∀ (A : RSet α) → T⟦ T ⟧ (As , A) t

T⟦_⟧² : ∀ {αs As Bs} (T : Typ αs) (ℜs : αs ∋ As ⇔* Bs) → (tlevel T ∋ T⟦ T ⟧ As ⇔ T⟦ T ⟧ Bs)
T⟦ ⟨ A ⟩ ⟧²    ℜs t a       b       = a ≡ b
T⟦ T ∧ U ⟧²    ℜs t (a , b) (c , d) = T⟦ T ⟧² ℜs t a c × T⟦ U ⟧² ℜs t b d
T⟦ T ⇒ U ⟧²    ℜs t f       g       = ∀ {a b} → T⟦ T ⟧² ℜs t a b → T⟦ U ⟧² ℜs t (f a) (g b)
T⟦ var τ ⟧²    ℜs t v       w       = τ⟦ τ ⟧² ℜs t v w
T⟦ univ α T ⟧² ℜs t f       g       = ∀ {A B} (ℜ : α ∋ A ⇔ B) → T⟦ T ⟧² (ℜs , ℜ) t (f A) (g B)

-- Contexts

data Ctxt (αs : Levels) : Set₁ where
  ε : Ctxt αs
  _,_at_ : (Γ : Ctxt αs) (T : Typ αs) (t : Time) → Ctxt αs

clevels : ∀ {αs} → Ctxt αs → Levels
clevels ε            = ε
clevels (Γ , T at t) = (clevels Γ , tlevel T)

Γ⟦_⟧ : ∀ {αs} (Γ : Ctxt αs) → RSets αs → Sets (clevels Γ)
Γ⟦ ε ⟧          As = tt
Γ⟦ Γ , T at t ⟧ As = (Γ⟦ Γ ⟧ As , T⟦ T ⟧ As t)

Γ⟦_⟧² : ∀ {αs As Bs} (Γ : Ctxt αs) (ℜs : αs ∋ As ⇔* Bs) → (clevels Γ ∋ Γ⟦ Γ ⟧ As ↔* Γ⟦ Γ ⟧ Bs)
Γ⟦ ε ⟧²          ℜs = tt
Γ⟦ Γ , T at t ⟧² ℜs = (Γ⟦ Γ ⟧² ℜs , T⟦ T ⟧² ℜs t)

-- Weakening of type variables

τweaken : ∀ {αs} α βs → TVar (αs + βs) → TVar ((αs , α) + βs)
τweaken α ε        τ       = suc τ
τweaken α (βs , β) zero    = zero
τweaken α (βs , β) (suc τ) = suc (τweaken α βs τ)

⟦τweaken⟧ : ∀ {αs} α βs (τ : TVar (αs + βs)) As A Bs t →
  τ⟦ τ ⟧ (αs ∋ As ++ βs ∋ Bs) t → τ⟦ τweaken α βs τ ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t
⟦τweaken⟧ α ε        τ       As A Bs       t a = a
⟦τweaken⟧ α (βs , β) zero    As A Bs       t a = a
⟦τweaken⟧ α (βs , β) (suc τ) As A (Bs , B) t a = ⟦τweaken⟧ α βs τ As A Bs t a

⟦τweaken⁻¹⟧ : ∀ {αs} α βs (τ : TVar (αs + βs)) As A Bs t →
  τ⟦ τweaken α βs τ ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t → τ⟦ τ ⟧ (αs ∋ As ++ βs ∋ Bs) t
⟦τweaken⁻¹⟧ α ε        τ       As A Bs       t a = a
⟦τweaken⁻¹⟧ α (βs , β) zero    As A Bs       t a = a
⟦τweaken⁻¹⟧ α (βs , β) (suc τ) As A (Bs , B) t a = ⟦τweaken⁻¹⟧ α βs τ As A Bs t a

⟦τweaken⟧² : ∀ {αs} α βs (τ : TVar (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
  τ⟦ τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
  τ⟦ τweaken α βs τ ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t (⟦τweaken⟧ α βs τ As A Cs t a) (⟦τweaken⟧ α βs τ Bs B Ds t b)
⟦τweaken⟧² α ε        τ       ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⟧² α (βs , β) zero    ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⟧² α (βs , β) (suc τ) ℜs ℜ (ℑs , ℑ) t aℜb = ⟦τweaken⟧² α βs τ ℜs ℜ ℑs t aℜb

⟦τweaken⁻¹⟧² : ∀ {αs} α βs (τ : TVar (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
  τ⟦ τweaken α βs τ ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t a b →
  τ⟦ τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦τweaken⁻¹⟧ α βs τ As A Cs t a) (⟦τweaken⁻¹⟧ α βs τ Bs B Ds t b)
⟦τweaken⁻¹⟧² α ε        τ       ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⁻¹⟧² α (βs , β) zero    ℜs ℜ ℑs       t aℜb = aℜb
⟦τweaken⁻¹⟧² α (βs , β) (suc τ) ℜs ℜ (ℑs , ℑ) t aℜb = ⟦τweaken⁻¹⟧² α βs τ ℜs ℜ ℑs t aℜb

-- Weakening of types

tweaken : ∀ {αs} α βs → Typ (αs + βs) → Typ ((αs , α) + βs)
tweaken α βs ⟨ A ⟩      = ⟨ A ⟩
tweaken α βs (T ∧ U)    = tweaken α βs T ∧ tweaken α βs U
tweaken α βs (T ⇒ U)    = tweaken α βs T ⇒ tweaken α βs U
tweaken α βs (var τ)    = var (τweaken α βs τ)
tweaken α βs (univ β T) = univ β (tweaken α (βs , β) T)

mutual

  ⟦tweaken⟧ : ∀ {αs} α βs (T : Typ (αs + βs)) As A Bs t →
    T⟦ T ⟧ (αs ∋ As ++ βs ∋ Bs) t → T⟦ tweaken α βs T ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t
  ⟦tweaken⟧ α βs ⟨ B ⟩      As A Bs t a       = a
  ⟦tweaken⟧ α βs (T ∧ U)    As A Bs t (a , b) = (⟦tweaken⟧ α βs T As A Bs t a , ⟦tweaken⟧ α βs U As A Bs t b)
  ⟦tweaken⟧ α βs (T ⇒ U)    As A Bs t f       = λ a → ⟦tweaken⟧ α βs U As A Bs t (f (⟦tweaken⁻¹⟧ α βs T As A Bs t a))
  ⟦tweaken⟧ α βs (var τ)    As A Bs t a       = ⟦τweaken⟧ α βs τ As A Bs t a
  ⟦tweaken⟧ α βs (univ β T) As A Bs t f       = λ B → ⟦tweaken⟧ α (βs , β) T As A (Bs , B) t (f B)

  ⟦tweaken⁻¹⟧ : ∀ {αs} α βs (T : Typ (αs + βs)) As A Bs t →
    T⟦ tweaken α βs T ⟧ ((αs , α) ∋ (As , A) ++ βs ∋ Bs) t → T⟦ T ⟧ (αs ∋ As ++ βs ∋ Bs) t
  ⟦tweaken⁻¹⟧ α βs ⟨ B ⟩      As A Bs t a       = a
  ⟦tweaken⁻¹⟧ α βs (T ∧ U)    As A Bs t (a , b) = (⟦tweaken⁻¹⟧ α βs T As A Bs t a , ⟦tweaken⁻¹⟧ α βs U As A Bs t b)
  ⟦tweaken⁻¹⟧ α βs (T ⇒ U)    As A Bs t f       = λ a → ⟦tweaken⁻¹⟧ α βs U As A Bs t (f (⟦tweaken⟧ α βs T As A Bs t a))
  ⟦tweaken⁻¹⟧ α βs (var τ)    As A Bs t a       = ⟦τweaken⁻¹⟧ α βs τ As A Bs t a
  ⟦tweaken⁻¹⟧ α βs (univ β T) As A Bs t f       = λ B → ⟦tweaken⁻¹⟧ α (βs , β) T As A (Bs , B) t (f B)

mutual

  ⟦tweaken⟧² : ∀ {αs} α βs (T : Typ (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
    T⟦ T ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
    T⟦ tweaken α βs T ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t (⟦tweaken⟧ α βs T As A Cs t a) (⟦tweaken⟧ α βs T Bs B Ds t b)
  ⟦tweaken⟧² α βs ⟨ B ⟩      ℜs ℜ ℑs t aℜb         = aℜb
  ⟦tweaken⟧² α βs (T ∧ U)    ℜs ℜ ℑs t (aℜb , cℜd) = (⟦tweaken⟧² α βs T ℜs ℜ ℑs t aℜb , ⟦tweaken⟧² α βs U ℜs ℜ ℑs t cℜd)
  ⟦tweaken⟧² α βs (T ⇒ U)    ℜs ℜ ℑs t fℜg         = λ aℜb → ⟦tweaken⟧² α βs U ℜs ℜ ℑs t (fℜg (⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs t aℜb))
  ⟦tweaken⟧² α βs (var τ)    ℜs ℜ ℑs t aℜb         = ⟦τweaken⟧² α βs τ ℜs ℜ ℑs t aℜb
  ⟦tweaken⟧² α βs (univ β T) ℜs ℜ ℑs t fℜg         = λ ℑ → ⟦tweaken⟧² α (βs , β) T ℜs ℜ (ℑs , ℑ) t (fℜg ℑ)

  ⟦tweaken⁻¹⟧² : ∀ {αs} α βs (T : Typ (αs + βs)) {As Bs A B Cs Ds} ℜs ℜ ℑs t {a b} →
    T⟦ tweaken α βs T ⟧² ((αs , α) ∋ (ℜs , ℜ) ++² βs ∋ ℑs) t a b →
    T⟦ T ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦tweaken⁻¹⟧ α βs T As A Cs t a) (⟦tweaken⁻¹⟧ α βs T Bs B Ds t b)
  ⟦tweaken⁻¹⟧² α βs ⟨ B ⟩      ℜs ℜ ℑs t aℜb         = aℜb
  ⟦tweaken⁻¹⟧² α βs (T ∧ U)    ℜs ℜ ℑs t (aℜb , cℜd) = (⟦tweaken⁻¹⟧² α βs T ℜs ℜ ℑs t aℜb , ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs t cℜd)
  ⟦tweaken⁻¹⟧² α βs (T ⇒ U)    ℜs ℜ ℑs t fℜg         = λ aℜb → ⟦tweaken⁻¹⟧² α βs U ℜs ℜ ℑs t (fℜg (⟦tweaken⟧² α βs T ℜs ℜ ℑs t aℜb))
  ⟦tweaken⁻¹⟧² α βs (var τ)    ℜs ℜ ℑs t aℜb         = ⟦τweaken⁻¹⟧² α βs τ ℜs ℜ ℑs t aℜb
  ⟦tweaken⁻¹⟧² α βs (univ β T) ℜs ℜ ℑs t fℜg         = λ ℑ → ⟦tweaken⁻¹⟧² α (βs , β) T ℜs ℜ (ℑs , ℑ) t (fℜg ℑ)

-- Weakening of contexts

cweaken : ∀ {αs} α → Ctxt αs → Ctxt (αs , α)
cweaken α ε            = ε
cweaken α (Γ , T at t) = (cweaken α Γ , tweaken α ε T at t)

⟦cweaken⟧ : ∀ {αs} α (Γ : Ctxt αs) As A → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → ⟨ clevels (cweaken α Γ) ∋ Γ⟦ cweaken α Γ ⟧ (As , A) ⟩
⟦cweaken⟧ α ε            As A tt       = tt
⟦cweaken⟧ α (Γ , T at t) As A (as , a) = (⟦cweaken⟧ α Γ As A as , ⟦tweaken⟧ α ε T As A tt t a)

⟦cweaken⟧² : ∀ {αs} α (Γ : Ctxt αs) {As Bs A B} ℜs ℜ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs →
  ⟨ clevels (cweaken α Γ) ∋ Γ⟦ cweaken α Γ ⟧² (ℜs , ℜ) ⟩² (⟦cweaken⟧ α Γ As A as) (⟦cweaken⟧ α Γ Bs B bs)
⟦cweaken⟧² α ε            ℜs ℜ tt            = tt
⟦cweaken⟧² α (Γ , T at t) ℜs ℜ (asℜbs , aℜb) = (⟦cweaken⟧² α Γ ℜs ℜ asℜbs , ⟦tweaken⟧² α ε T ℜs ℜ tt t aℜb)

-- Substitution into type variables

τsubst : ∀ {αs} (T : Typ αs) βs → TVar ((αs , tlevel T) + βs) → Typ (αs + βs)
τsubst T ε        zero    = T
τsubst T ε        (suc τ) = var τ
τsubst T (βs , β) zero    = var zero
τsubst T (βs , β) (suc τ) = tweaken β ε (τsubst T βs τ)

⟦τsubst⟧ : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) As Bs t →
  τ⟦ τ ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t →
  T⟦ τsubst T βs τ ⟧ (αs ∋ As ++ βs ∋ Bs) t
⟦τsubst⟧      T ε        zero    As Bs       t a = a
⟦τsubst⟧      T ε        (suc τ) As Bs       t a = a
⟦τsubst⟧      T (βs , β) zero    As Bs       t a = a
⟦τsubst⟧ {αs} T (βs , β) (suc τ) As (Bs , B) t a =
  ⟦tweaken⟧ β ε (τsubst T βs τ) (αs ∋ As ++ βs ∋ Bs) B tt t
    (⟦τsubst⟧ T βs τ As Bs t a)

⟦τsubst⁻¹⟧ : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) As Bs t →
  T⟦ τsubst T βs τ ⟧ (αs ∋ As ++ βs ∋ Bs) t →
  τ⟦ τ ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t
⟦τsubst⁻¹⟧      T ε        zero    As Bs       t a = a
⟦τsubst⁻¹⟧      T ε        (suc τ) As Bs       t a = a
⟦τsubst⁻¹⟧      T (βs , β) zero    As Bs       t a = a
⟦τsubst⁻¹⟧ {αs} T (βs , β) (suc τ) As (Bs , B) t a =
  ⟦τsubst⁻¹⟧ T βs τ As Bs t
    (⟦tweaken⁻¹⟧ β ε (τsubst T βs τ) (αs ∋ As ++ βs ∋ Bs) B tt t a)

⟦τsubst⟧² : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
  τ⟦ τ ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t a b →
  T⟦ τsubst T βs τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦τsubst⟧ T βs τ As Bs t a) (⟦τsubst⟧ T βs τ Cs Ds t b)
⟦τsubst⟧²      T ε        zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧²      T ε        (suc τ) ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧²      T (βs , β) zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⟧² {αs} T (βs , β) (suc τ) ℜs (ℑs , ℑ) t aℜb =
  ⟦tweaken⟧² β ε (τsubst T βs τ) (αs ∋ ℜs ++² βs ∋ ℑs) ℑ tt t
    (⟦τsubst⟧² T βs τ ℜs ℑs t aℜb)

⟦τsubst⁻¹⟧² : ∀ {αs} (T : Typ αs) βs (τ : TVar ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
  T⟦ τsubst T βs τ ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
  τ⟦ τ ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t (⟦τsubst⁻¹⟧ T βs τ As Bs t a) (⟦τsubst⁻¹⟧ T βs τ Cs Ds t b)
⟦τsubst⁻¹⟧²      T ε        zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧²      T ε        (suc τ) ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧²      T (βs , β) zero    ℜs ℑs       t aℜb = aℜb
⟦τsubst⁻¹⟧² {αs} T (βs , β) (suc τ) ℜs (ℑs , ℑ) t aℜb =
  ⟦τsubst⁻¹⟧² T βs τ ℜs ℑs t
    (⟦tweaken⁻¹⟧² β ε (τsubst T βs τ) (αs ∋ ℜs ++² βs ∋ ℑs) ℑ tt t aℜb)

-- Substitution into types

tsubst : ∀ {αs} (T : Typ αs) βs → Typ ((αs , tlevel T) + βs) → Typ (αs + βs)
tsubst T βs ⟨ A ⟩ = ⟨ A ⟩
tsubst T βs (U ∧ V) = tsubst T βs U ∧ tsubst T βs V
tsubst T βs (U ⇒ V) = tsubst T βs U ⇒ tsubst T βs V
tsubst T βs (var τ) = τsubst T βs τ
tsubst T βs (univ β U) = univ β (tsubst T (βs , β) U)

mutual

  ⟦tsubst⟧ : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) As Bs t →
    T⟦ U ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t →
    T⟦ tsubst T βs U ⟧ (αs ∋ As ++ βs ∋ Bs) t
  ⟦tsubst⟧ T βs ⟨ A ⟩      As Bs t a       = a
  ⟦tsubst⟧ T βs (U ∧ V)    As Bs t (a , b) = (⟦tsubst⟧ T βs U As Bs t a , ⟦tsubst⟧ T βs V As Bs t b)
  ⟦tsubst⟧ T βs (U ⇒ V)    As Bs t f       = λ a → ⟦tsubst⟧ T βs V As Bs t (f (⟦tsubst⁻¹⟧ T βs U As Bs t a))
  ⟦tsubst⟧ T βs (var τ)    As Bs t a       = ⟦τsubst⟧ T βs τ As Bs t a
  ⟦tsubst⟧ T βs (univ β U) As Bs t f       = λ B → ⟦tsubst⟧ T (βs , β) U As (Bs , B) t (f B)

  ⟦tsubst⁻¹⟧ : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) As Bs t →
    T⟦ tsubst T βs U ⟧ (αs ∋ As ++ βs ∋ Bs) t →
    T⟦ U ⟧ ((αs , tlevel T) ∋ (As , T⟦ T ⟧ As) ++ βs ∋ Bs) t
  ⟦tsubst⁻¹⟧ T βs ⟨ A ⟩      As Bs t a       = a
  ⟦tsubst⁻¹⟧ T βs (U ∧ V)    As Bs t (a , b) = (⟦tsubst⁻¹⟧ T βs U As Bs t a , ⟦tsubst⁻¹⟧ T βs V As Bs t b)
  ⟦tsubst⁻¹⟧ T βs (U ⇒ V)    As Bs t f       = λ a → ⟦tsubst⁻¹⟧ T βs V As Bs t (f (⟦tsubst⟧ T βs U As Bs t a))
  ⟦tsubst⁻¹⟧ T βs (var τ)    As Bs t a       = ⟦τsubst⁻¹⟧ T βs τ As Bs t a
  ⟦tsubst⁻¹⟧ T βs (univ β U) As Bs t f       = λ B → ⟦tsubst⁻¹⟧ T (βs , β) U As (Bs , B) t (f B)

mutual

  ⟦tsubst⟧² : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
    T⟦ U ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t a b →
    T⟦ tsubst T βs U ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t (⟦tsubst⟧ T βs U As Bs t a) (⟦tsubst⟧ T βs U Cs Ds t b)
  ⟦tsubst⟧² T βs ⟨ A ⟩      ℜs ℑs t aℜb         = aℜb
  ⟦tsubst⟧² T βs (U ∧ V)    ℜs ℑs t (aℜb , cℜd) = (⟦tsubst⟧² T βs U ℜs ℑs t aℜb , ⟦tsubst⟧² T βs V ℜs ℑs t cℜd)
  ⟦tsubst⟧² T βs (U ⇒ V)    ℜs ℑs t fℜg         = λ aℜb → ⟦tsubst⟧² T βs V ℜs ℑs t (fℜg (⟦tsubst⁻¹⟧² T βs U ℜs ℑs t aℜb))
  ⟦tsubst⟧² T βs (var τ)    ℜs ℑs t aℜb         = ⟦τsubst⟧² T βs τ ℜs ℑs t aℜb
  ⟦tsubst⟧² T βs (univ β U) ℜs ℑs t fℜg         = λ ℑ → ⟦tsubst⟧² T (βs , β) U ℜs (ℑs , ℑ) t (fℜg ℑ)

  ⟦tsubst⁻¹⟧² : ∀ {αs} (T : Typ αs) βs (U : Typ ((αs , tlevel T) + βs)) {As Bs Cs Ds} ℜs ℑs t {a b} →
    T⟦ tsubst T βs U ⟧² (αs ∋ ℜs ++² βs ∋ ℑs) t a b →
    T⟦ U ⟧² ((αs , tlevel T) ∋ (ℜs , T⟦ T ⟧² ℜs) ++² βs ∋ ℑs) t (⟦tsubst⁻¹⟧ T βs U As Bs t a) (⟦tsubst⁻¹⟧ T βs U Cs Ds t b)
  ⟦tsubst⁻¹⟧² T βs ⟨ A ⟩      ℜs ℑs t aℜb         = aℜb
  ⟦tsubst⁻¹⟧² T βs (U ∧ V)    ℜs ℑs t (aℜb , cℜd) = (⟦tsubst⁻¹⟧² T βs U ℜs ℑs t aℜb , ⟦tsubst⁻¹⟧² T βs V ℜs ℑs t cℜd)
  ⟦tsubst⁻¹⟧² T βs (U ⇒ V)    ℜs ℑs t fℜg         = λ aℜb → ⟦tsubst⁻¹⟧² T βs V ℜs ℑs t (fℜg (⟦tsubst⟧² T βs U ℜs ℑs t aℜb))
  ⟦tsubst⁻¹⟧² T βs (var τ)    ℜs ℑs t aℜb         = ⟦τsubst⁻¹⟧² T βs τ ℜs ℑs t aℜb
  ⟦tsubst⁻¹⟧² T βs (univ β U) ℜs ℑs t fℜg         = λ ℑ → ⟦tsubst⁻¹⟧² T (βs , β) U ℜs (ℑs , ℑ) t (fℜg ℑ)

-- Variables

data Var {αs} (T : Typ αs) (t : Time) : (Γ : Ctxt αs) → Set₁ where
  zero : ∀ {Γ : Ctxt αs} → Var T t (Γ , T at t)
  suc : ∀ {Γ : Ctxt αs} {U : Typ αs} {u} → Var T t Γ → Var T t (Γ , U at u)

v⟦_⟧ : ∀ {αs} {Γ : Ctxt αs} {T : Typ αs} {t} → Var T t Γ → ∀ As → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → T⟦ T ⟧ As t
v⟦ zero ⟧  As (as , a) = a
v⟦ suc v ⟧ As (as , a) = v⟦ v ⟧ As as

v⟦_⟧² : ∀ {αs As Bs} {Γ : Ctxt αs} {T : Typ αs} {t} (τ : Var T t Γ) (ℜs : αs ∋ As ⇔* Bs) →
  ∀ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs → T⟦ T ⟧² ℜs t (v⟦ τ ⟧ As as) (v⟦ τ ⟧ Bs bs)
v⟦ zero ⟧²  ℜs (asℜbs , aℜb) = aℜb
v⟦ suc v ⟧² ℜs (asℜbs , aℜb) = v⟦ v ⟧² ℜs asℜbs

-- Expressions

data Exp : ∀ {αs} → Ctxt αs → Typ αs → RSet₁ where
  const : ∀ {αs Γ A t} → (a : A) → Exp {αs} Γ ⟨ A ⟩ t
  pair : ∀ {αs Γ T U t} → (e : Exp Γ T t) → (f : Exp Γ U t) → Exp {αs} Γ (T ∧ U) t
  fst : ∀ {αs Γ T U t} → (e : Exp Γ (T ∧ U) t) → Exp {αs} Γ T t
  snd : ∀ {αs Γ T U t} → (e : Exp Γ (T ∧ U) t) → Exp {αs} Γ U t
  abs : ∀ {αs Γ T U t} → (e : Exp (Γ , T at t) U t) → Exp {αs} Γ (T ⇒ U) t
  app : ∀ {αs Γ T U t} → (f : Exp Γ (T ⇒ U) t) → (e : Exp Γ T t) → Exp {αs} Γ U t
  var : ∀ {αs Γ T t} → (v : Var T t Γ) → Exp {αs} Γ T t
  tabs : ∀ {αs Γ} α {T t} → (e : Exp (cweaken α Γ) T t) → Exp {αs} Γ (univ α T) t
  tapp : ∀ {αs Γ t} (T : Typ αs) {U} → (e : Exp Γ (univ (tlevel T) U) t) → Exp {αs} Γ (tsubst T ε U) t

e⟦_⟧ : ∀ {αs} {Γ : Ctxt αs} {T : Typ αs} {t} → Exp Γ T t → ∀ As → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧ As ⟩ → T⟦ T ⟧ As t
e⟦ const a ⟧                  As as = a
e⟦ pair e f ⟧                 As as = (e⟦ e ⟧ As as , e⟦ f ⟧ As as)
e⟦ fst e ⟧                    As as = proj₁ (e⟦ e ⟧ As as)
e⟦ snd e ⟧                    As as = proj₂ (e⟦ e ⟧ As as)
e⟦ abs e ⟧                    As as = λ a → e⟦ e ⟧ As (as , a)
e⟦ app f e ⟧                  As as = e⟦ f ⟧ As as (e⟦ e ⟧ As as)
e⟦ var v ⟧                    As as = v⟦ v ⟧ As as
e⟦ tabs {Γ = Γ} α e ⟧         As as = λ A → e⟦ e ⟧ (As , A) (⟦cweaken⟧ α Γ As A as)
e⟦ tapp {t = t} T {U = U} e ⟧ As as = ⟦tsubst⟧ T ε U As tt t (e⟦ e ⟧ As as (T⟦ T ⟧ As))

e⟦_⟧² : ∀ {αs As Bs} {Γ : Ctxt αs} {T : Typ αs} {t} (e : Exp Γ T t) (ℜs : αs ∋ As ⇔* Bs) →
  ∀ {as bs} → ⟨ clevels Γ ∋ Γ⟦ Γ ⟧² ℜs ⟩² as bs → T⟦ T ⟧² ℜs t (e⟦ e ⟧ As as) (e⟦ e ⟧ Bs bs)
e⟦ const a ⟧²                  ℜs asℜbs = refl
e⟦ pair e f ⟧²                 ℜs asℜbs = (e⟦ e ⟧² ℜs asℜbs , e⟦ f ⟧² ℜs asℜbs)
e⟦ fst e ⟧²                    ℜs asℜbs = proj₁ (e⟦ e ⟧² ℜs asℜbs)
e⟦ snd e ⟧²                    ℜs asℜbs = proj₂ (e⟦ e ⟧² ℜs asℜbs)
e⟦ abs e ⟧²                    ℜs asℜbs = λ aℜb → e⟦ e ⟧² ℜs (asℜbs , aℜb)
e⟦ app f e ⟧²                  ℜs asℜbs = e⟦ f ⟧² ℜs asℜbs (e⟦ e ⟧² ℜs asℜbs)
e⟦ var v ⟧²                    ℜs asℜbs = v⟦ v ⟧² ℜs asℜbs
e⟦ tabs {Γ = Γ} α e ⟧²         ℜs asℜbs = λ ℜ → e⟦ e ⟧² (ℜs , ℜ) (⟦cweaken⟧² α Γ ℜs ℜ asℜbs)
e⟦ tapp {t = t} T {U = U} e ⟧² ℜs asℜbs = ⟦tsubst⟧² T ε U ℜs tt t (e⟦ e ⟧² ℜs asℜbs (T⟦ T ⟧² ℜs))

-- Surface level types

data STyp : Set₁ where
  ⟨_⟩ : (A : Set) → STyp
  _∧_ _⇒_ : (T : STyp) → (U : STyp) → STyp

-- Translation of surface level types into types

⟪_⟫ : STyp → Typ (ε , o)
⟪ ⟨ A ⟩ ⟫ = ⟨ A ⟩
⟪ T ∧ U ⟫ = ⟪ T ⟫ ∧ ⟪ U ⟫
⟪ T ⇒ U ⟫ = ⟪ T ⟫ ⇒ ⟪ U ⟫

T⟪_⟫ : STyp → RSet₀
T⟪ ⟨ A ⟩ ⟫ t = A
T⟪ T ∧ U ⟫ t = T⟪ T ⟫ t × T⟪ U ⟫ t
T⟪ T ⇒ U ⟫ t = T⟪ T ⟫ t → T⟪ U ⟫ t

World : RSet₀
World t = ⊤

mutual

  trans : ∀ T {s} → T⟪ T ⟫ s → T⟦ ⟪ T ⟫ ⟧ (tt , World) s
  trans ⟨ A ⟩   a       = a
  trans (T ∧ U) (a , b) = (trans T a , trans U b)
  trans (T ⇒ U) f       = λ a → trans U (f (trans⁻¹ T a))

  trans⁻¹ : ∀ T {s} → T⟦ ⟪ T ⟫ ⟧ (tt , World) s → T⟪ T ⟫ s
  trans⁻¹ ⟨ A ⟩   a       = a
  trans⁻¹ (T ∧ U) (a , b) = (trans⁻¹ T a , trans⁻¹ U b)
  trans⁻¹ (T ⇒ U) f       = λ a → trans⁻¹ U (f (trans T a))

-- Causality

_at_∋_≈[_∵_]_ : ∀ T s → T⟪ T ⟫ s → ∀ u → True (s ≤ u) → T⟪ T ⟫ s → Set
⟨ A ⟩   at s ∋ a       ≈[ u ∵ s≤u ] b       = a ≡ b
(T ∧ U) at s ∋ (a , b) ≈[ u ∵ s≤u ] (c , d) = (T at s ∋ a ≈[ u ∵ s≤u ] c) × (U at s ∋ b ≈[ u ∵ s≤u ] d)
(T ⇒ U) at s ∋ f       ≈[ u ∵ s≤u ] g       = ∀ {a b} → (T at s ∋ a ≈[ u ∵ s≤u ] b) → (U at s ∋ f a ≈[ u ∵ s≤u ] g b)

Causal : ∀ T U s → T⟪ T ⇒ U ⟫ s → Set
Causal T U s f = ∀ u s≤u {a b} → (T at s ∋ a ≈[ u ∵ s≤u ] b) → (U at s ∋ f a ≈[ u ∵ s≤u ] f b)

-- Parametricity implies causality

ℜ[_] : Time → (o ∋ World ⇔ World)
ℜ[ u ] t tt tt = True (t ≤ u)

mutual

  ℜ-impl-≈ : ∀ T s u s≤u {a b} →
    T⟦ ⟪ T ⟫ ⟧² (tt , ℜ[ u ]) s a b →
    (T at s ∋ trans⁻¹ T a ≈[ u ∵ s≤u ] trans⁻¹ T b)
  ℜ-impl-≈ ⟨ A ⟩   s u s≤u aℜb         = aℜb
  ℜ-impl-≈ (T ∧ U) s u s≤u (aℜc , bℜd) = (ℜ-impl-≈ T s u s≤u aℜc , ℜ-impl-≈ U s u s≤u bℜd)
  ℜ-impl-≈ (T ⇒ U) s u s≤u fℜg         = λ a≈b → ℜ-impl-≈ U s u s≤u (fℜg (≈-impl-ℜ T s u s≤u a≈b))

  ≈-impl-ℜ : ∀ T s u s≤u {a b} →
    (T at s ∋ a ≈[ u ∵ s≤u ] b) →
    T⟦ ⟪ T ⟫ ⟧² (tt , ℜ[ u ]) s (trans T a) (trans T b)
  ≈-impl-ℜ ⟨ A ⟩   s u s≤u a≈b         = a≈b
  ≈-impl-ℜ (T ∧ U) s u s≤u (a≈c , b≈d) = (≈-impl-ℜ T s u s≤u a≈c , ≈-impl-ℜ U s u s≤u b≈d)
  ≈-impl-ℜ (T ⇒ U) s u s≤u f≈g         = λ aℜb → ≈-impl-ℜ U s u s≤u (f≈g (ℜ-impl-≈ T s u s≤u aℜb))

-- Every expression is causal

e⟪_at_∋_⟫ : ∀ T t → Exp ε ⟪ T ⟫ t → T⟪ T ⟫ t
e⟪ T at t ∋ e ⟫ = trans⁻¹ T (e⟦ e ⟧ (tt , World) tt)

causality : ∀ T U s f → Causal T U s e⟪ (T ⇒ U) at s ∋ f ⟫
causality T U s f u s≤u = ℜ-impl-≈ (T ⇒ U) s u s≤u (e⟦ f ⟧² (tt , ℜ[ u ]) tt)


Rename TermConstructor to CurriedTermConstructor.

This rename prepares for introducing UncurriedTermConstructor which
will allow to clarify the role of lift-η-const-rec.

Old-commit-hash: b9de3c413f5a2a2015d3114bfb8483ab3078cc06

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Context.Context {Type.Type B} → Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

-- Declarations of Term and Terms to enable mutual recursion
data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

-- (Term Γ τ) represents a term of type τ
-- with free variables bound in Γ.
data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- (Terms Γ Σ) represents a list of terms with types from Σ
-- with free variables bound in Γ.
data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

weaken Γ₁≼Γ₂ (const c ts) = const c (weakenAll Γ₁≼Γ₂ ts)
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

weakenAll Γ₁≼Γ₂ ∅ = ∅
weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ ts

-- Specialized weakening
weaken₁ : ∀ {Γ σ τ} →
  Term Γ τ → Term (σ • Γ) τ
weaken₁ t = weaken (drop _ • ≼-refl) t

weaken₂ : ∀ {Γ α β τ} →
  Term Γ τ → Term (α • β • Γ) τ
weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

weaken₃ : ∀ {Γ α β γ τ} →
  Term Γ τ → Term (α • β • γ • Γ) τ
weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

-- Shorthands for nested applications
app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
app₂ f x = app (app f x)

app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
app₃ f x = app₂ (app f x)

app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
app₄ f x = app₃ (app f x)

app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
app₅ f x = app₄ (app f x)

app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
app₆ f x = app₅ (app f x)

CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

-- helper for lift-η-const, don't try to understand at home
lift-η-const-rec : ∀ {Σ Γ τ} → (Terms Γ Σ → Term Γ τ) → CurriedTermConstructor Γ Σ τ
lift-η-const-rec {∅} k = k ∅
lift-η-const-rec {τ • Σ} k = λ t → lift-η-const-rec (λ ts → k (t • ts))

lift-η-const : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
lift-η-const constant = lift-η-const-rec (const constant)

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Context.Context {Type.Type B} → Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

-- Declarations of Term and Terms to enable mutual recursion
data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

-- (Term Γ τ) represents a term of type τ
-- with free variables bound in Γ.
data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- (Terms Γ Σ) represents a list of terms with types from Σ
-- with free variables bound in Γ.
data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

weaken Γ₁≼Γ₂ (const c ts) = const c (weakenAll Γ₁≼Γ₂ ts)
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

weakenAll Γ₁≼Γ₂ ∅ = ∅
weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ ts

-- Specialized weakening
weaken₁ : ∀ {Γ σ τ} →
  Term Γ τ → Term (σ • Γ) τ
weaken₁ t = weaken (drop _ • ≼-refl) t

weaken₂ : ∀ {Γ α β τ} →
  Term Γ τ → Term (α • β • Γ) τ
weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

weaken₃ : ∀ {Γ α β γ τ} →
  Term Γ τ → Term (α • β • γ • Γ) τ
weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

-- Shorthands for nested applications
app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
app₂ f x = app (app f x)

app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
app₃ f x = app₂ (app f x)

app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
app₄ f x = app₃ (app f x)

app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
app₅ f x = app₄ (app f x)

app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
app₆ f x = app₅ (app f x)

TermConstructor : (Γ Σ : Context) (τ : Type) → Set
TermConstructor Γ ∅ τ′ = Term Γ τ′
TermConstructor Γ (τ • Σ) τ′ = Term Γ τ → TermConstructor Γ Σ τ′

-- helper for lift-η-const, don't try to understand at home
lift-η-const-rec : ∀ {Σ Γ τ} → (Terms Γ Σ → Term Γ τ) → TermConstructor Γ Σ τ
lift-η-const-rec {∅} k = k ∅
lift-η-const-rec {τ • Σ} k = λ t → lift-η-const-rec (λ ts → k (t • ts))

lift-η-const : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → TermConstructor Γ Σ τ
lift-η-const constant = lift-η-const-rec (const constant)


bijection-syntax: fix

bijection-syntax: fix

-- NOTE with-K
module bijection-syntax.Bijection-Fin where

  open import Type

  open import bijection-syntax.Bijection
  open import Function.NP hiding (Cmp)
  open import Relation.Binary.PropositionalEquality.NP

  open import Data.Empty
  open import Data.Nat.NP hiding (suc-injective)
  open import Data.Two
  open import Data.Fin.NP
    using ( Fin ; zero ; suc ; ℕ▹Fin ; inject₁; suc-injective; _≤F_; z≤i; s≤s
          ; module From-mono-inj )
  open import Data.Nat.BoundedMonoInj-is-Id hiding (module From-mono-inj)
  open import Data.Vec hiding ([_])
  open import Data.Sum
  import Algebra.FunctionProperties.Eq
  open Algebra.FunctionProperties.Eq.Implicits

  data `Syn : ℕ → Type where
    `id   : ∀ {n} → `Syn n
    `swap : ∀ {n} → `Syn (2 + n)
    `tail : ∀ {n} → `Syn n → `Syn (1 + n)
    _`∘_  : ∀ {n} → `Syn n → `Syn n → `Syn n

  `Rep = Fin

  `Ix = ℕ

  `Tree : Type → `Ix → Type
  `Tree X = Vec X

  `fromFun : ∀ {i X} → (`Rep i → X) → `Tree X i
  `fromFun = tabulate

  `toFun : ∀ {i X} → `Tree X i → (`Rep i → X)
  `toFun T zero    = head T
  `toFun T (suc i) = `toFun (tail T) i

  `toFun∘fromFun : ∀ {i X}(f : `Rep i → X) → f ≗ `toFun (`fromFun f)
  `toFun∘fromFun f zero = refl
  `toFun∘fromFun f (suc i) = `toFun∘fromFun (f ∘ suc) i

  fin-swap : ∀ {n} → Endo (Fin (2 + n))
  fin-swap zero = suc zero
  fin-swap (suc zero) = zero
  fin-swap (suc (suc i)) = suc (suc i)

  fin-tail : ∀ {n} → Endo (Fin n) → Endo (Fin (1 + n))
  fin-tail f zero = zero
  fin-tail f (suc i) = suc (f i)

  `evalArg : ∀ {i} → `Syn i → Endo (`Rep i)
  `evalArg `id       = id
  `evalArg `swap     = fin-swap
  `evalArg (`tail f) = fin-tail (`evalArg f)
  `evalArg (S `∘ S₁) = `evalArg S ∘ `evalArg S₁

  vec-swap : ∀ {n}{X : Type} → Endo (Vec X (2 + n))
  vec-swap xs = head (tail xs) ∷ head xs ∷ tail (tail xs)

  vec-tail : ∀ {n}{X : Type} → Endo (Vec X n) → Endo (Vec X (1 + n))
  vec-tail f xs = head xs ∷ f (tail xs)

  `evalTree : ∀ {i X} → `Syn i → Endo (`Tree X i)
  `evalTree `id       = id
  `evalTree `swap     = vec-swap
  `evalTree (`tail f) = vec-tail (`evalTree f)
  `evalTree (S `∘ S₁) = `evalTree S ∘ `evalTree S₁

  `eval-proof : ∀ {i X} S (T : `Tree X i) → `toFun T ≗ `toFun (`evalTree S T) ∘ `evalArg S
  `eval-proof `id       T i = refl
  `eval-proof `swap T zero = refl
  `eval-proof `swap T (suc zero) = refl
  `eval-proof `swap T (suc (suc i)) = refl
  `eval-proof (`tail S) T zero = refl
  `eval-proof (`tail S) T (suc i) = `eval-proof S (tail T) i
  `eval-proof (S `∘ S₁) T i rewrite
    `eval-proof S₁ T i |
    `eval-proof S (`evalTree S₁ T) (`evalArg S₁ i) = refl

  `inv : ∀ {i} → Endo (`Syn i)
  `inv `id       = `id
  `inv `swap     = `swap
  `inv (`tail S) = `tail (`inv S)
  `inv (S `∘ S₁) = `inv S₁ `∘ `inv S

  `inv-proof : ∀ {i} → (S : `Syn i) → `evalArg S ∘ `evalArg (`inv S) ≗ id
  `inv-proof `id x       = refl
  `inv-proof `swap zero          = refl
  `inv-proof `swap (suc zero)    = refl
  `inv-proof `swap (suc (suc x)) = refl
  `inv-proof (`tail S) zero = refl
  `inv-proof (`tail S) (suc x) rewrite `inv-proof S x = refl
  `inv-proof (S `∘ S₁) x rewrite
    `inv-proof S₁ (`evalArg (`inv S) x) |
    `inv-proof S x = refl

  `RC : ∀ {i} → Cmp (`Rep i)
  `RC zero zero = eq
  `RC zero (suc j) = lt
  `RC (suc i) zero = gt
  `RC (suc i) (suc j) = `RC i j

  insert : ∀ {n X} → Cmp X → X → Vec X n → Vec X (1 + n)
  insert X-cmp x [] = x ∷ []
  insert X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert X-cmp x (x₁ ∷ xs) | lt = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | eq = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | gt = x₁ ∷ insert X-cmp x xs

  `sort : ∀ {i X} → Cmp X → Endo (`Tree X i)
  `sort X-cmp [] = []
  `sort X-cmp (x ∷ xs) = insert X-cmp x (`sort X-cmp xs)

  insert-syn : ∀ {n X} → Cmp X → X → Vec X n → `Syn (1 + n)
  insert-syn X-cmp x [] = `id
  insert-syn X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert-syn X-cmp x (x₁ ∷ xs) | lt = `id
  insert-syn X-cmp x (x₁ ∷ xs) | eq = `id
  insert-syn X-cmp x (x₁ ∷ xs) | gt = `tail (insert-syn X-cmp x xs) `∘ `swap

  `sort-syn : ∀ {i X} → Cmp X → `Tree X i → `Syn i
  `sort-syn X-cmp []       = `id
  `sort-syn X-cmp (x ∷ xs) = insert-syn X-cmp x (`sort X-cmp xs) `∘ `tail (`sort-syn X-cmp xs)

  insert-proof : ∀ {n X}(X-cmp : Cmp X) x (T : Vec X n) → insert X-cmp x T ≡ `evalTree (insert-syn X-cmp x T) (x ∷ T)
  insert-proof X-cmp x [] = refl
  insert-proof X-cmp x (x₁ ∷ T) with X-cmp x x₁
  insert-proof X-cmp x (x₁ ∷ T) | lt = refl
  insert-proof X-cmp x (x₁ ∷ T) | eq = refl
  insert-proof X-cmp x (x₁ ∷ T) | gt rewrite insert-proof X-cmp x T = refl

  `sort-proof : ∀ {i X}(X-cmp : Cmp X)(T : `Tree X i) → `sort X-cmp T ≡ `evalTree (`sort-syn X-cmp T) T
  `sort-proof X-cmp [] = refl
  `sort-proof X-cmp (x ∷ T) rewrite
    ! `sort-proof X-cmp T = insert-proof X-cmp x (`sort X-cmp T)

  module Alt-Syn where

    data ``Syn : ℕ → Type where
      `id : ∀ {n} → ``Syn n
      _`∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
      `swap : ∀ {n} m → ``Syn (m + 2 + n)

    swap-fin : ∀ {n} m → Endo (Fin (m + 2 + n))
    swap-fin zero zero = suc zero
    swap-fin zero (suc zero) = zero
    swap-fin zero (suc (suc i)) = suc (suc i)
    swap-fin (suc m) zero = zero
    swap-fin (suc m) (suc i) = suc (swap-fin m i)

    ``evalArg : ∀ {n} → ``Syn n → Endo (`Rep n)
    ``evalArg `id       = id
    ``evalArg (S `∘ S₁) = ``evalArg S ∘ ``evalArg S₁
    ``evalArg (`swap m) = swap-fin m

    _``∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
    `id ``∘ y = y
    (x `∘ x₁) ``∘ `id = x `∘ x₁
    (x `∘ x₁) ``∘ (y `∘ y₁) = x `∘ (x₁ `∘ (y `∘ y₁))
    (x `∘ x₁) ``∘ `swap m = x `∘ (x₁ ``∘ `swap m)
    `swap m ``∘ y = `swap m `∘ y

    ``tail : ∀ {n} → ``Syn n → ``Syn (suc n)
    ``tail `id = `id
    ``tail (S `∘ S₁) = ``tail S ``∘ ``tail S₁
    ``tail (`swap m) = `swap (suc m)

    translate : ∀ {n} → `Syn n → ``Syn n
    translate `id = `id
    translate `swap = `swap 0
    translate (`tail S) = ``tail (translate S)
    translate (S `∘ S₁) = translate S ``∘ translate S₁

    ``∘-p : ∀ {n}(A B : ``Syn n) → ``evalArg (A ``∘ B) ≗ ``evalArg (A `∘ B)
    ``∘-p `id B x = refl
    ``∘-p (A `∘ A₁) `id x = refl
    ``∘-p (A `∘ A₁) (B `∘ B₁) x = refl
    ``∘-p (A `∘ A₁) (`swap m) x rewrite ``∘-p A₁ (`swap m) x = refl
    ``∘-p (`swap m) B x = refl

    ``tail-p : ∀ {n} (S : ``Syn n) → fin-tail (``evalArg S) ≗ ``evalArg (``tail S)
    ``tail-p `id zero = refl
    ``tail-p `id (suc x) = refl
    ``tail-p (S `∘ S₁) zero rewrite ``∘-p (``tail S) (``tail S₁) zero
                                  | ! ``tail-p S₁ zero = ``tail-p S zero
    ``tail-p (S `∘ S₁) (suc x) rewrite ``∘-p (``tail S) (``tail S₁) (suc x)
                                     | ! ``tail-p S₁ (suc x) = ``tail-p S (suc (``evalArg S₁ x))
    ``tail-p (`swap m) zero = refl
    ``tail-p (`swap m) (suc x) = refl

    `eval`` : ∀ {n} (S : `Syn n) → `evalArg S ≗ ``evalArg (translate S)
    `eval`` `id       x = refl
    `eval`` `swap zero = refl
    `eval`` `swap (suc zero) = refl
    `eval`` `swap (suc (suc x)) = refl
    `eval`` (`tail S) zero = ``tail-p (translate S) zero
    `eval`` (`tail S) (suc x) rewrite `eval`` S x = ``tail-p (translate S) (suc x)
    `eval`` (S `∘ S₁) x rewrite ``∘-p (translate S) (translate S₁) x | ! `eval`` S₁ x | `eval`` S (`evalArg S₁ x) = refl

  data Fin-View : ∀ {n} → Fin n → Type where
    max : ∀ {n} → Fin-View (ℕ▹Fin n)
    inject : ∀ {n} → (i : Fin n) → Fin-View (inject₁ i)

  data Sorted {X}(XC : Cmp X) : ∀ {l} → Vec X l  → Type where
    []  : Sorted XC []
    sing : ∀ x → Sorted XC (x ∷ [])
    dbl-lt  : ∀ {l} x y {xs : Vec X l} → lt ≡ XC x y → Sorted XC (y ∷ xs) → Sorted XC (x ∷ y ∷ xs)
    dbl-eq  : ∀ {l} x {xs : Vec X l} → Sorted XC (x ∷ xs) → Sorted XC (x ∷ x ∷ xs)

  opposite : Ord → Ord
  opposite lt = gt
  opposite eq = eq
  opposite gt = lt

  flip-RC : ∀ {n}(x y : Fin n) → opposite (`RC x y) ≡ `RC y x
  flip-RC zero zero = refl
  flip-RC zero (suc y) = refl
  flip-RC (suc x) zero = refl
  flip-RC (suc x) (suc y) = flip-RC x y

  eq=>≡ : ∀ {i} (x y : Fin i) → eq ≡ `RC x y → x ≡ y
  eq=>≡ zero zero p = refl
  eq=>≡ zero (suc y) ()
  eq=>≡ (suc x) zero ()
  eq=>≡ (suc x) (suc y) p rewrite eq=>≡ x y p = refl

  insert-Sorted : ∀ {n l}{V : Vec (Fin n) l}(x : Fin n) → Sorted {Fin n} `RC V → Sorted {Fin n} `RC (insert `RC x V)
  insert-Sorted x [] = sing x
  insert-Sorted x (sing x₁) with `RC x x₁ | dbl-lt {XC = `RC} x x₁ {[]} | eq=>≡ x x₁ | flip-RC x x₁
  insert-Sorted x (sing x₁) | lt | b | _ | _ = b refl (sing x₁)
  insert-Sorted x (sing x₁) | eq | _ | p | _ rewrite p refl = dbl-eq x₁ (sing x₁)
  insert-Sorted x (sing x₁) | gt | b | _ | l = dbl-lt x₁ x l (sing x)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) with `RC x y | dbl-lt {XC = `RC} x y {y' ∷ xs} | eq=>≡ x y | flip-RC x y
  insert-Sorted x (dbl-lt y y' prf xs₁) | lt | b | p | l₁ = b refl (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' prf xs₁) | eq | b | p | l₁ rewrite p refl = dbl-eq y (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) | gt | b | p | l₁ with `RC x y' | insert-Sorted x xs₁
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | lt | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | eq | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | gt | xs' = dbl-lt y y' prf xs'
  insert-Sorted x (dbl-eq y {xs} xs₁) with `RC x y | inspect (`RC x) y | dbl-lt {XC = `RC} x y {y ∷ xs} | eq=>≡ x y | flip-RC x y | insert-Sorted x xs₁
  insert-Sorted x (dbl-eq y xs₁) | lt | _ | b | p | l | _ = b refl (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | eq | _ | b | p | l | _ rewrite p refl = dbl-eq y (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | gt | [ prf ] | b | p | l | ss  rewrite prf = dbl-eq y ss

  sort-Sorted : ∀ {n l}(V : Vec (Fin n) l) → Sorted `RC (`sort `RC V)
  sort-Sorted [] = []
  sort-Sorted (x ∷ V) = insert-Sorted x (sort-Sorted V)

  RC-refl : ∀ {i}(x : Fin i) → `RC x x ≡ eq
  RC-refl zero = refl
  RC-refl (suc x) = RC-refl x

  STail : ∀ {X l}{XC : Cmp X}{xs : Vec X (suc l)} → Sorted XC xs → Sorted XC (tail xs)
  STail (sing x) = []
  STail (dbl-lt x y x₁ T) = T
  STail (dbl-eq x T) = T

  module sproof {X}(XC : Cmp X)(XC-refl : ∀ x → XC x x ≡ eq)
     (eq≡ : ∀ x y → XC x y ≡ eq → x ≡ y)
     (lt-trans : ∀ x y z → XC x y ≡ lt → XC y z ≡ lt → XC x z ≡ lt)
     (XC-flip : ∀ x y → opposite (XC x y) ≡ XC y x)
     where

    open import Data.Sum

    _≤X_ : X → X → Type
    x ≤X y = XC x y ≡ lt ⊎ XC x y ≡ eq

    ≤X-trans : ∀ {x y z} → x ≤X y → y ≤X z → x ≤X z
    ≤X-trans (inj₁ x₁) (inj₁ x₂) = inj₁ (lt-trans _ _ _ x₁ x₂)
    ≤X-trans {_}{y}{z}(inj₁ x₁) (inj₂ y₁) rewrite eq≡ y z y₁ = inj₁ x₁
    ≤X-trans {x}{y} (inj₂ y₁) y≤z rewrite eq≡ x y y₁ = y≤z

    h≤t : ∀ {n}{T : `Tree X (2 + n)} → Sorted XC T → head T ≤X head (tail T)
    h≤t (dbl-lt x y x₁ ST) = inj₁ (! x₁)
    h≤t (dbl-eq x ST) rewrite XC-refl x = inj₂ refl

    head-p : ∀ {n}{T : `Tree X (suc n)} i → Sorted XC T → head T ≤X `toFun T i
    head-p {T = T} zero ST rewrite XC-refl (head T) = inj₂ refl
    head-p {zero} (suc ()) ST
    head-p {suc n} (suc i) ST = ≤X-trans (h≤t ST) (head-p i (STail ST))

    toFun-p : ∀ {n}{T : `Tree X n}{i j : Fin n} → i ≤F j → Sorted XC T → `toFun T i ≤X `toFun T j
    toFun-p {j = j} z≤i ST = head-p j ST
    toFun-p (s≤s i≤Fj) ST = toFun-p i≤Fj (STail ST)

    sort-proof : ∀ {i}{T : `Tree X i} → Sorted XC T → Is-Mono `RC XC (`toFun T)
    sort-proof {T = T} T₁ zero zero rewrite XC-refl (head T) = _
    sort-proof T₁ zero (suc y) with toFun-p (z≤i {i = suc y}) T₁
    sort-proof T zero (suc y) | inj₁ x rewrite x = _
    sort-proof T zero (suc y) | inj₂ y₁ rewrite y₁ = _
    sort-proof {T = T} T₁ (suc x) zero with toFun-p (z≤i {i = suc x}) T₁ | XC-flip (head T) (`toFun (tail T) x)
    sort-proof T (suc x) zero | inj₁ x₁ | l rewrite x₁ | ! l = _
    sort-proof T (suc x) zero | inj₂ y | l rewrite y | ! l = _
    sort-proof T₁ (suc x) (suc y) = sort-proof (STail T₁) x y

  lt-trans-RC : ∀ {i} (x y z : Fin i) → `RC x y ≡ lt → `RC y z ≡ lt → `RC x z ≡ lt
  lt-trans-RC zero zero zero x<y y<z = y<z
  lt-trans-RC zero zero (suc z) x<y y<z = refl
  lt-trans-RC zero (suc y) zero x<y ()
  lt-trans-RC zero (suc y) (suc z) x<y y<z = refl
  lt-trans-RC (suc x) zero zero x<y y<z = x<y
  lt-trans-RC (suc x) zero (suc z) () y<z
  lt-trans-RC (suc x) (suc y) zero x<y y<z = y<z
  lt-trans-RC (suc x) (suc y) (suc z) x<y y<z = lt-trans-RC x y z x<y y<z

  `sort-mono : ∀ {i}(T : `Tree (`Rep i) i) → Is-Mono `RC `RC (`toFun (`sort `RC T))
  `sort-mono T x y = sproof.sort-proof `RC RC-refl (λ x₁ y₁ x₂ → eq=>≡ x₁ y₁ (! x₂)) lt-trans-RC flip-RC (sort-Sorted T) x y

  move-to-RC : ∀ {n}{x y : Fin n} → x ≤F y → `RC x y ≡ lt ⊎ `RC x y ≡ eq
  move-to-RC {y = zero} z≤i = inj₂ refl
  move-to-RC {y = suc y} z≤i = inj₁ refl
  move-to-RC (s≤s x≤Fy) = move-to-RC x≤Fy

  move-from-RC : ∀ {n}(x y : Fin n) → lt ≡ `RC x y ⊎ eq ≡ `RC x y → x ≤F y
  move-from-RC zero zero prf = z≤i
  move-from-RC zero (suc y) prf = z≤i
  move-from-RC (suc x) zero (inj₁ ())
  move-from-RC (suc x) zero (inj₂ ())
  move-from-RC (suc x) (suc y) prf = s≤s (move-from-RC x y prf)

  mono-RC : ∀ {n}(f : Endo (Fin n))(f-mono : Is-Mono `RC `RC f)
              {x y} → x ≤F y → f x ≤F f y
  mono-RC {n} f f-mono {x} {y} x≤Fy with `RC x y | `RC (f x) (f y) | move-to-RC x≤Fy | f-mono x y | move-from-RC (f x) (f y)
  mono-RC f f-mono x≤Fy | .lt | lt | inj₁ refl | r4 | r5 = r5 (inj₁ refl)
  mono-RC f f-mono x≤Fy | .lt | eq | inj₁ refl | r4 | r5 = r5 (inj₂ refl)
  mono-RC f f-mono x≤Fy | .lt | gt | inj₁ refl | () | r5
  mono-RC f f-mono x≤Fy | .eq | lt | inj₂ refl | () | r5
  mono-RC f f-mono x≤Fy | .eq | eq | inj₂ refl | r4 | r5 = r5 (inj₂ refl)
  mono-RC f f-mono x≤Fy | .eq | gt | inj₂ refl | () | r5

  fin-view : ∀ {n} → (i : Fin (suc n)) → Fin-View i
  fin-view {zero} zero = max
  fin-view {zero} (suc ())
  fin-view {suc n} zero = inject _
  fin-view {suc n} (suc i) with fin-view i
  fin-view {suc n} (suc .(ℕ▹Fin n)) | max = max
  fin-view {suc n} (suc .(inject₁ i)) | inject i = inject _

  absurd : {X : Type} → .⊥ → X
  absurd ()

  drop₁ : ∀ {n} → (i : Fin (suc n)) → .(i ≢ ℕ▹Fin n) → Fin n
  drop₁ i neq with fin-view i
  drop₁ {n} .(ℕ▹Fin n) neq | max = absurd (neq refl)
  drop₁ .(inject₁ i) neq | inject i = i

  drop₁→inject₁ : ∀ {n}(i : Fin (suc n))(j : Fin n).(p : i ≢ ℕ▹Fin n) → drop₁ i p ≡ j → i ≡ inject₁ j
  drop₁→inject₁ i j p q with fin-view i
  drop₁→inject₁ {n} .(ℕ▹Fin n) j p q | max = absurd (p refl)
  drop₁→inject₁ .(inject₁ i) j p q | inject i = ap inject₁ q

  `mono-inj→id : ∀{i}(f : Endo (`Rep i)) → Injective f → Is-Mono `RC `RC f → f ≗ id
  `mono-inj→id f inj mono = From-mono-inj.f≗id f inj (mono-RC f mono)

  interface : Interface
  interface = record
    { Ix            = `Ix
    ; Rep           = `Rep
    ; Syn           = `Syn
    ; Tree          = `Tree
    ; fromFun       = `fromFun
    ; toFun         = `toFun
    ; toFun∘fromFun = `toFun∘fromFun
    ; evalArg       = `evalArg
    ; evalTree      = `evalTree
    ; eval-proof    = `eval-proof
    ; inv           = `inv
    ; inv-proof     = `inv-proof
    ; RC            = `RC
    ; sort          = `sort
    ; sort-syn      = `sort-syn
    ; sort-proof    = `sort-proof
    ; sort-mono     = `sort-mono
    ; mono-inj→id   = `mono-inj→id
    }

  count : ∀ {n} → (Fin n → ℕ) → ℕ
  count {n} f = sum (tabulate f)

  count-ext : ∀ {n} → (f g : Fin n → ℕ) → f ≗ g → count f ≡ count g
  count-ext {zero} f g f≗g = refl
  count-ext {suc n} f g f≗g rewrite f≗g zero | count-ext (f ∘ suc) (g ∘ suc) (f≗g ∘ suc) = refl

  #⟨_⟩ : ∀ {n} → (Fin n → 𝟚) → ℕ
  #⟨ f ⟩ = count (𝟚▹ℕ ∘ f)

  #-ext : ∀ {n} → (f g : Fin n → 𝟚) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
  #-ext f g f≗g = count-ext (𝟚▹ℕ ∘ f) (𝟚▹ℕ ∘ g) (ap 𝟚▹ℕ ∘ f≗g)

  com-assoc : ∀ x y z → x + (y + z) ≡ y + (x + z)
  com-assoc x y z rewrite
    ! ℕ°.+-assoc x y z |
    ℕ°.+-comm x y      |
    ℕ°.+-assoc y x z   = refl

  syn-pres : ∀ {n}(f : Fin n → ℕ)(S : `Syn n)
           → count f ≡ count (f ∘ `evalArg S)
  syn-pres f `id = refl
  syn-pres f `swap = com-assoc (f zero) (f (suc zero)) (count (λ i → f (suc (suc i))))
  syn-pres f (`tail S) rewrite syn-pres (f ∘ suc) S = refl
  syn-pres f (S `∘ S₁) rewrite syn-pres f S = syn-pres (f ∘ `evalArg S) S₁

  count-perm : ∀ {n}(f : Fin n → ℕ)(p : Endo (Fin n)) → Injective p
         → count f ≡ count (f ∘ p)
  count-perm f p p-inj = trans (syn-pres f (sort-bij p)) (count-ext _ _ f∘eval≗f∘p)
   where
     open abs interface
     f∘eval≗f∘p : f ∘ `evalArg (sort-bij p) ≗ f ∘ p
     f∘eval≗f∘p x rewrite thm p p-inj x = refl

  #-perm : ∀ {n}(f : Fin n → 𝟚)(p : Endo (Fin n)) → Injective p
         → #⟨ f ⟩ ≡ #⟨ f ∘ p ⟩
  #-perm f p p-inj = count-perm (𝟚▹ℕ ∘ f) p p-inj

  test : `Syn 8
  test = abs.sort-bij interface (λ x → `evalArg (`tail `swap) x)
-- -}

-- NOTE with-K
module bijection-syntax.Bijection-Fin where

  open import Type

  open import bijection-syntax.Bijection
  open import Function.NP hiding (Cmp)
  open import Relation.Binary.PropositionalEquality.NP

  open import Data.Empty
  open import Data.Nat.NP hiding (suc-injective)
  open import Data.Two
  open import Data.Fin.NP
    using ( Fin ; zero ; suc ; ℕ▹Fin ; inject₁; suc-injective; _≤F_; z≤i; s≤s
          ; module From-mono-inj )
  open import Data.Vec hiding ([_])
  open import Data.Sum

  data `Syn : ℕ → Type where
    `id   : ∀ {n} → `Syn n
    `swap : ∀ {n} → `Syn (2 + n)
    `tail : ∀ {n} → `Syn n → `Syn (1 + n)
    _`∘_  : ∀ {n} → `Syn n → `Syn n → `Syn n

  `Rep = Fin

  `Ix = ℕ

  `Tree : Type → `Ix → Type
  `Tree X = Vec X

  `fromFun : ∀ {i X} → (`Rep i → X) → `Tree X i
  `fromFun = tabulate

  `toFun : ∀ {i X} → `Tree X i → (`Rep i → X)
  `toFun T zero    = head T
  `toFun T (suc i) = `toFun (tail T) i

  `toFun∘fromFun : ∀ {i X}(f : `Rep i → X) → f ≗ `toFun (`fromFun f)
  `toFun∘fromFun f zero = refl
  `toFun∘fromFun f (suc i) = `toFun∘fromFun (f ∘ suc) i

  fin-swap : ∀ {n} → Endo (Fin (2 + n))
  fin-swap zero = suc zero
  fin-swap (suc zero) = zero
  fin-swap (suc (suc i)) = suc (suc i)

  fin-tail : ∀ {n} → Endo (Fin n) → Endo (Fin (1 + n))
  fin-tail f zero = zero
  fin-tail f (suc i) = suc (f i)

  `evalArg : ∀ {i} → `Syn i → Endo (`Rep i)
  `evalArg `id       = id
  `evalArg `swap     = fin-swap
  `evalArg (`tail f) = fin-tail (`evalArg f)
  `evalArg (S `∘ S₁) = `evalArg S ∘ `evalArg S₁

  vec-swap : ∀ {n}{X : Type} → Endo (Vec X (2 + n))
  vec-swap xs = head (tail xs) ∷ head xs ∷ tail (tail xs)

  vec-tail : ∀ {n}{X : Type} → Endo (Vec X n) → Endo (Vec X (1 + n))
  vec-tail f xs = head xs ∷ f (tail xs)

  `evalTree : ∀ {i X} → `Syn i → Endo (`Tree X i)
  `evalTree `id       = id
  `evalTree `swap     = vec-swap
  `evalTree (`tail f) = vec-tail (`evalTree f)
  `evalTree (S `∘ S₁) = `evalTree S ∘ `evalTree S₁

  `eval-proof : ∀ {i X} S (T : `Tree X i) → `toFun T ≗ `toFun (`evalTree S T) ∘ `evalArg S
  `eval-proof `id       T i = refl
  `eval-proof `swap T zero = refl
  `eval-proof `swap T (suc zero) = refl
  `eval-proof `swap T (suc (suc i)) = refl
  `eval-proof (`tail S) T zero = refl
  `eval-proof (`tail S) T (suc i) = `eval-proof S (tail T) i
  `eval-proof (S `∘ S₁) T i rewrite
    `eval-proof S₁ T i |
    `eval-proof S (`evalTree S₁ T) (`evalArg S₁ i) = refl

  `inv : ∀ {i} → Endo (`Syn i)
  `inv `id       = `id
  `inv `swap     = `swap
  `inv (`tail S) = `tail (`inv S)
  `inv (S `∘ S₁) = `inv S₁ `∘ `inv S

  `inv-proof : ∀ {i} → (S : `Syn i) → `evalArg S ∘ `evalArg (`inv S) ≗ id
  `inv-proof `id x       = refl
  `inv-proof `swap zero          = refl
  `inv-proof `swap (suc zero)    = refl
  `inv-proof `swap (suc (suc x)) = refl
  `inv-proof (`tail S) zero = refl
  `inv-proof (`tail S) (suc x) rewrite `inv-proof S x = refl
  `inv-proof (S `∘ S₁) x rewrite
    `inv-proof S₁ (`evalArg (`inv S) x) |
    `inv-proof S x = refl

  `RC : ∀ {i} → Cmp (`Rep i)
  `RC zero zero = eq
  `RC zero (suc j) = lt
  `RC (suc i) zero = gt
  `RC (suc i) (suc j) = `RC i j

  insert : ∀ {n X} → Cmp X → X → Vec X n → Vec X (1 + n)
  insert X-cmp x [] = x ∷ []
  insert X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert X-cmp x (x₁ ∷ xs) | lt = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | eq = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | gt = x₁ ∷ insert X-cmp x xs

  `sort : ∀ {i X} → Cmp X → Endo (`Tree X i)
  `sort X-cmp [] = []
  `sort X-cmp (x ∷ xs) = insert X-cmp x (`sort X-cmp xs)

  insert-syn : ∀ {n X} → Cmp X → X → Vec X n → `Syn (1 + n)
  insert-syn X-cmp x [] = `id
  insert-syn X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert-syn X-cmp x (x₁ ∷ xs) | lt = `id
  insert-syn X-cmp x (x₁ ∷ xs) | eq = `id
  insert-syn X-cmp x (x₁ ∷ xs) | gt = `tail (insert-syn X-cmp x xs) `∘ `swap

  `sort-syn : ∀ {i X} → Cmp X → `Tree X i → `Syn i
  `sort-syn X-cmp []       = `id
  `sort-syn X-cmp (x ∷ xs) = insert-syn X-cmp x (`sort X-cmp xs) `∘ `tail (`sort-syn X-cmp xs)

  insert-proof : ∀ {n X}(X-cmp : Cmp X) x (T : Vec X n) → insert X-cmp x T ≡ `evalTree (insert-syn X-cmp x T) (x ∷ T)
  insert-proof X-cmp x [] = refl
  insert-proof X-cmp x (x₁ ∷ T) with X-cmp x x₁
  insert-proof X-cmp x (x₁ ∷ T) | lt = refl
  insert-proof X-cmp x (x₁ ∷ T) | eq = refl
  insert-proof X-cmp x (x₁ ∷ T) | gt rewrite insert-proof X-cmp x T = refl

  `sort-proof : ∀ {i X}(X-cmp : Cmp X)(T : `Tree X i) → `sort X-cmp T ≡ `evalTree (`sort-syn X-cmp T) T
  `sort-proof X-cmp [] = refl
  `sort-proof X-cmp (x ∷ T) rewrite
    ! `sort-proof X-cmp T = insert-proof X-cmp x (`sort X-cmp T)

  module Alt-Syn where

    data ``Syn : ℕ → Type where
      `id : ∀ {n} → ``Syn n
      _`∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
      `swap : ∀ {n} m → ``Syn (m + 2 + n)

    swap-fin : ∀ {n} m → Endo (Fin (m + 2 + n))
    swap-fin zero zero = suc zero
    swap-fin zero (suc zero) = zero
    swap-fin zero (suc (suc i)) = suc (suc i)
    swap-fin (suc m) zero = zero
    swap-fin (suc m) (suc i) = suc (swap-fin m i)

    ``evalArg : ∀ {n} → ``Syn n → Endo (`Rep n)
    ``evalArg `id       = id
    ``evalArg (S `∘ S₁) = ``evalArg S ∘ ``evalArg S₁
    ``evalArg (`swap m) = swap-fin m

    _``∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
    `id ``∘ y = y
    (x `∘ x₁) ``∘ `id = x `∘ x₁
    (x `∘ x₁) ``∘ (y `∘ y₁) = x `∘ (x₁ `∘ (y `∘ y₁))
    (x `∘ x₁) ``∘ `swap m = x `∘ (x₁ ``∘ `swap m)
    `swap m ``∘ y = `swap m `∘ y

    ``tail : ∀ {n} → ``Syn n → ``Syn (suc n)
    ``tail `id = `id
    ``tail (S `∘ S₁) = ``tail S ``∘ ``tail S₁
    ``tail (`swap m) = `swap (suc m)

    translate : ∀ {n} → `Syn n → ``Syn n
    translate `id = `id
    translate `swap = `swap 0
    translate (`tail S) = ``tail (translate S)
    translate (S `∘ S₁) = translate S ``∘ translate S₁

    ``∘-p : ∀ {n}(A B : ``Syn n) → ``evalArg (A ``∘ B) ≗ ``evalArg (A `∘ B)
    ``∘-p `id B x = refl
    ``∘-p (A `∘ A₁) `id x = refl
    ``∘-p (A `∘ A₁) (B `∘ B₁) x = refl
    ``∘-p (A `∘ A₁) (`swap m) x rewrite ``∘-p A₁ (`swap m) x = refl
    ``∘-p (`swap m) B x = refl

    ``tail-p : ∀ {n} (S : ``Syn n) → fin-tail (``evalArg S) ≗ ``evalArg (``tail S)
    ``tail-p `id zero = refl
    ``tail-p `id (suc x) = refl
    ``tail-p (S `∘ S₁) zero rewrite ``∘-p (``tail S) (``tail S₁) zero
                                  | ! ``tail-p S₁ zero = ``tail-p S zero
    ``tail-p (S `∘ S₁) (suc x) rewrite ``∘-p (``tail S) (``tail S₁) (suc x)
                                     | ! ``tail-p S₁ (suc x) = ``tail-p S (suc (``evalArg S₁ x))
    ``tail-p (`swap m) zero = refl
    ``tail-p (`swap m) (suc x) = refl

    `eval`` : ∀ {n} (S : `Syn n) → `evalArg S ≗ ``evalArg (translate S)
    `eval`` `id       x = refl
    `eval`` `swap zero = refl
    `eval`` `swap (suc zero) = refl
    `eval`` `swap (suc (suc x)) = refl
    `eval`` (`tail S) zero = ``tail-p (translate S) zero
    `eval`` (`tail S) (suc x) rewrite `eval`` S x = ``tail-p (translate S) (suc x)
    `eval`` (S `∘ S₁) x rewrite ``∘-p (translate S) (translate S₁) x | ! `eval`` S₁ x | `eval`` S (`evalArg S₁ x) = refl

  data Fin-View : ∀ {n} → Fin n → Type where
    max : ∀ {n} → Fin-View (ℕ▹Fin n)
    inject : ∀ {n} → (i : Fin n) → Fin-View (inject₁ i)

  data Sorted {X}(XC : Cmp X) : ∀ {l} → Vec X l  → Type where
    []  : Sorted XC []
    sing : ∀ x → Sorted XC (x ∷ [])
    dbl-lt  : ∀ {l} x y {xs : Vec X l} → lt ≡ XC x y → Sorted XC (y ∷ xs) → Sorted XC (x ∷ y ∷ xs)
    dbl-eq  : ∀ {l} x {xs : Vec X l} → Sorted XC (x ∷ xs) → Sorted XC (x ∷ x ∷ xs)

  opposite : Ord → Ord
  opposite lt = gt
  opposite eq = eq
  opposite gt = lt

  flip-RC : ∀ {n}(x y : Fin n) → opposite (`RC x y) ≡ `RC y x
  flip-RC zero zero = refl
  flip-RC zero (suc y) = refl
  flip-RC (suc x) zero = refl
  flip-RC (suc x) (suc y) = flip-RC x y

  eq=>≡ : ∀ {i} (x y : Fin i) → eq ≡ `RC x y → x ≡ y
  eq=>≡ zero zero p = refl
  eq=>≡ zero (suc y) ()
  eq=>≡ (suc x) zero ()
  eq=>≡ (suc x) (suc y) p rewrite eq=>≡ x y p = refl

  insert-Sorted : ∀ {n l}{V : Vec (Fin n) l}(x : Fin n) → Sorted {Fin n} `RC V → Sorted {Fin n} `RC (insert `RC x V)
  insert-Sorted x [] = sing x
  insert-Sorted x (sing x₁) with `RC x x₁ | dbl-lt {XC = `RC} x x₁ {[]} | eq=>≡ x x₁ | flip-RC x x₁
  insert-Sorted x (sing x₁) | lt | b | _ | _ = b refl (sing x₁)
  insert-Sorted x (sing x₁) | eq | _ | p | _ rewrite p refl = dbl-eq x₁ (sing x₁)
  insert-Sorted x (sing x₁) | gt | b | _ | l = dbl-lt x₁ x l (sing x)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) with `RC x y | dbl-lt {XC = `RC} x y {y' ∷ xs} | eq=>≡ x y | flip-RC x y
  insert-Sorted x (dbl-lt y y' prf xs₁) | lt | b | p | l₁ = b refl (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' prf xs₁) | eq | b | p | l₁ rewrite p refl = dbl-eq y (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) | gt | b | p | l₁ with `RC x y' | insert-Sorted x xs₁
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | lt | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | eq | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | gt | xs' = dbl-lt y y' prf xs'
  insert-Sorted x (dbl-eq y {xs} xs₁) with `RC x y | inspect (`RC x) y | dbl-lt {XC = `RC} x y {y ∷ xs} | eq=>≡ x y | flip-RC x y | insert-Sorted x xs₁
  insert-Sorted x (dbl-eq y xs₁) | lt | _ | b | p | l | _ = b refl (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | eq | _ | b | p | l | _ rewrite p refl = dbl-eq y (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | gt | [ prf ] | b | p | l | ss  rewrite prf = dbl-eq y ss

  sort-Sorted : ∀ {n l}(V : Vec (Fin n) l) → Sorted `RC (`sort `RC V)
  sort-Sorted [] = []
  sort-Sorted (x ∷ V) = insert-Sorted x (sort-Sorted V)

  RC-refl : ∀ {i}(x : Fin i) → `RC x x ≡ eq
  RC-refl zero = refl
  RC-refl (suc x) = RC-refl x

  STail : ∀ {X l}{XC : Cmp X}{xs : Vec X (suc l)} → Sorted XC xs → Sorted XC (tail xs)
  STail (sing x) = []
  STail (dbl-lt x y x₁ T) = T
  STail (dbl-eq x T) = T

  module sproof {X}(XC : Cmp X)(XC-refl : ∀ x → XC x x ≡ eq)
     (eq≡ : ∀ x y → XC x y ≡ eq → x ≡ y)
     (lt-trans : ∀ x y z → XC x y ≡ lt → XC y z ≡ lt → XC x z ≡ lt)
     (XC-flip : ∀ x y → opposite (XC x y) ≡ XC y x)
     where

    open import Data.Sum

    _≤X_ : X → X → Type
    x ≤X y = XC x y ≡ lt ⊎ XC x y ≡ eq

    ≤X-trans : ∀ {x y z} → x ≤X y → y ≤X z → x ≤X z
    ≤X-trans (inj₁ x₁) (inj₁ x₂) = inj₁ (lt-trans _ _ _ x₁ x₂)
    ≤X-trans {_}{y}{z}(inj₁ x₁) (inj₂ y₁) rewrite eq≡ y z y₁ = inj₁ x₁
    ≤X-trans {x}{y} (inj₂ y₁) y≤z rewrite eq≡ x y y₁ = y≤z

    h≤t : ∀ {n}{T : `Tree X (2 + n)} → Sorted XC T → head T ≤X head (tail T)
    h≤t (dbl-lt x y x₁ ST) = inj₁ (! x₁)
    h≤t (dbl-eq x ST) rewrite XC-refl x = inj₂ refl

    head-p : ∀ {n}{T : `Tree X (suc n)} i → Sorted XC T → head T ≤X `toFun T i
    head-p {T = T} zero ST rewrite XC-refl (head T) = inj₂ refl
    head-p {zero} (suc ()) ST
    head-p {suc n} (suc i) ST = ≤X-trans (h≤t ST) (head-p i (STail ST))

    toFun-p : ∀ {n}{T : `Tree X n}{i j : Fin n} → i ≤F j → Sorted XC T → `toFun T i ≤X `toFun T j
    toFun-p {j = j} z≤i ST = head-p j ST
    toFun-p (s≤s i≤Fj) ST = toFun-p i≤Fj (STail ST)

    sort-proof : ∀ {i}{T : `Tree X i} → Sorted XC T → Is-Mono `RC XC (`toFun T)
    sort-proof {T = T} T₁ zero zero rewrite XC-refl (head T) = _
    sort-proof T₁ zero (suc y) with toFun-p (z≤i {i = suc y}) T₁
    sort-proof T zero (suc y) | inj₁ x rewrite x = _
    sort-proof T zero (suc y) | inj₂ y₁ rewrite y₁ = _
    sort-proof {T = T} T₁ (suc x) zero with toFun-p (z≤i {i = suc x}) T₁ | XC-flip (head T) (`toFun (tail T) x)
    sort-proof T (suc x) zero | inj₁ x₁ | l rewrite x₁ | ! l = _
    sort-proof T (suc x) zero | inj₂ y | l rewrite y | ! l = _
    sort-proof T₁ (suc x) (suc y) = sort-proof (STail T₁) x y

  lt-trans-RC : ∀ {i} (x y z : Fin i) → `RC x y ≡ lt → `RC y z ≡ lt → `RC x z ≡ lt
  lt-trans-RC zero zero zero x<y y<z = y<z
  lt-trans-RC zero zero (suc z) x<y y<z = refl
  lt-trans-RC zero (suc y) zero x<y ()
  lt-trans-RC zero (suc y) (suc z) x<y y<z = refl
  lt-trans-RC (suc x) zero zero x<y y<z = x<y
  lt-trans-RC (suc x) zero (suc z) () y<z
  lt-trans-RC (suc x) (suc y) zero x<y y<z = y<z
  lt-trans-RC (suc x) (suc y) (suc z) x<y y<z = lt-trans-RC x y z x<y y<z

  `sort-mono : ∀ {i}(T : `Tree (`Rep i) i) → Is-Mono `RC `RC (`toFun (`sort `RC T))
  `sort-mono T x y = sproof.sort-proof `RC RC-refl (λ x₁ y₁ x₂ → eq=>≡ x₁ y₁ (! x₂)) lt-trans-RC flip-RC (sort-Sorted T) x y

  move-to-RC : ∀ {n}{x y : Fin n} → x ≤F y → `RC x y ≡ lt ⊎ `RC x y ≡ eq
  move-to-RC {y = zero} z≤i = inj₂ refl
  move-to-RC {y = suc y} z≤i = inj₁ refl
  move-to-RC (s≤s x≤Fy) = move-to-RC x≤Fy

  move-from-RC : ∀ {n}(x y : Fin n) → lt ≡ `RC x y ⊎ eq ≡ `RC x y → x ≤F y
  move-from-RC zero zero prf = z≤i
  move-from-RC zero (suc y) prf = z≤i
  move-from-RC (suc x) zero (inj₁ ())
  move-from-RC (suc x) zero (inj₂ ())
  move-from-RC (suc x) (suc y) prf = s≤s (move-from-RC x y prf)

  module toNatRC n (f : Endo (Fin (suc n)))(f-inj : Is-Inj f)(f-mono : Is-Mono `RC `RC f) where
    proper-mono : ∀ {x y} → x ≤F y → f x ≤F f y
    proper-mono {x} {y} x≤Fy with `RC x y | `RC (f x) (f y) | move-to-RC x≤Fy | f-mono x y | move-from-RC (f x) (f y)
    proper-mono x≤Fy | .lt | lt | inj₁ refl | r4 | r5 = r5 (inj₁ refl)
    proper-mono x≤Fy | .lt | eq | inj₁ refl | r4 | r5 = r5 (inj₂ refl)
    proper-mono x≤Fy | .lt | gt | inj₁ refl | () | r5
    proper-mono x≤Fy | .eq | lt | inj₂ refl | () | r5
    proper-mono x≤Fy | .eq | eq | inj₂ refl | r4 | r5 = r5 (inj₂ refl)
    proper-mono x≤Fy | .eq | gt | inj₂ refl | () | r5
    open From-mono-inj f f-inj proper-mono public

  fin-view : ∀ {n} → (i : Fin (suc n)) → Fin-View i
  fin-view {zero} zero = max
  fin-view {zero} (suc ())
  fin-view {suc n} zero = inject _
  fin-view {suc n} (suc i) with fin-view i
  fin-view {suc n} (suc .(ℕ▹Fin n)) | max = max
  fin-view {suc n} (suc .(inject₁ i)) | inject i = inject _

  absurd : {X : Type} → .⊥ → X
  absurd ()

  drop₁ : ∀ {n} → (i : Fin (suc n)) → .(i ≢ ℕ▹Fin n) → Fin n
  drop₁ i neq with fin-view i
  drop₁ {n} .(ℕ▹Fin n) neq | max = absurd (neq refl)
  drop₁ .(inject₁ i) neq | inject i = i

  drop₁→inject₁ : ∀ {n}(i : Fin (suc n))(j : Fin n).(p : i ≢ ℕ▹Fin n) → drop₁ i p ≡ j → i ≡ inject₁ j
  drop₁→inject₁ i j p q with fin-view i
  drop₁→inject₁ {n} .(ℕ▹Fin n) j p q | max = absurd (p refl)
  drop₁→inject₁ .(inject₁ i) j p q | inject i = ap inject₁ q

  `mono-inj→id : ∀{i}(f : Endo (`Rep i)) → Is-Inj f → Is-Mono `RC `RC f → f ≗ id
  `mono-inj→id {zero}  = λ f x x₁ ()
  `mono-inj→id {suc i} = toNatRC.f≗id i

  interface : Interface
  interface = record
    { Ix            = `Ix
    ; Rep           = `Rep
    ; Syn           = `Syn
    ; Tree          = `Tree
    ; fromFun       = `fromFun
    ; toFun         = `toFun
    ; toFun∘fromFun = `toFun∘fromFun
    ; evalArg       = `evalArg
    ; evalTree      = `evalTree
    ; eval-proof    = `eval-proof
    ; inv           = `inv
    ; inv-proof     = `inv-proof
    ; RC            = `RC
    ; sort          = `sort
    ; sort-syn      = `sort-syn
    ; sort-proof    = `sort-proof
    ; sort-mono     = `sort-mono
    ; mono-inj→id   = `mono-inj→id
    }

  count : ∀ {n} → (Fin n → ℕ) → ℕ
  count {n} f = sum (tabulate f)

  count-ext : ∀ {n} → (f g : Fin n → ℕ) → f ≗ g → count f ≡ count g
  count-ext {zero} f g f≗g = refl
  count-ext {suc n} f g f≗g rewrite f≗g zero | count-ext (f ∘ suc) (g ∘ suc) (f≗g ∘ suc) = refl

  #⟨_⟩ : ∀ {n} → (Fin n → 𝟚) → ℕ
  #⟨ f ⟩ = count (𝟚▹ℕ ∘ f)

  #-ext : ∀ {n} → (f g : Fin n → 𝟚) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
  #-ext f g f≗g = count-ext (𝟚▹ℕ ∘ f) (𝟚▹ℕ ∘ g) (ap 𝟚▹ℕ ∘ f≗g)

  com-assoc : ∀ x y z → x + (y + z) ≡ y + (x + z)
  com-assoc x y z rewrite
    ! ℕ°.+-assoc x y z |
    ℕ°.+-comm x y      |
    ℕ°.+-assoc y x z   = refl

  syn-pres : ∀ {n}(f : Fin n → ℕ)(S : `Syn n)
           → count f ≡ count (f ∘ `evalArg S)
  syn-pres f `id = refl
  syn-pres f `swap = com-assoc (f zero) (f (suc zero)) (count (λ i → f (suc (suc i))))
  syn-pres f (`tail S) rewrite syn-pres (f ∘ suc) S = refl
  syn-pres f (S `∘ S₁) rewrite syn-pres f S = syn-pres (f ∘ `evalArg S) S₁

  count-perm : ∀ {n}(f : Fin n → ℕ)(p : Endo (Fin n)) → Is-Inj p
         → count f ≡ count (f ∘ p)
  count-perm f p p-inj = trans (syn-pres f (sort-bij p)) (count-ext _ _ f∘eval≗f∘p)
   where
     open abs interface
     f∘eval≗f∘p : f ∘ `evalArg (sort-bij p) ≗ f ∘ p
     f∘eval≗f∘p x rewrite thm p p-inj x = refl

  #-perm : ∀ {n}(f : Fin n → 𝟚)(p : Endo (Fin n)) → Is-Inj p
         → #⟨ f ⟩ ≡ #⟨ f ∘ p ⟩
  #-perm f p p-inj = count-perm (𝟚▹ℕ ∘ f) p p-inj

  test : `Syn 8
  test = abs.sort-bij interface (λ x → `evalArg (`tail `swap) x)
-- -}


Remove dead code of Data.NatBag.Properties
Checkpoint: Recast property proofs using set theoretic methods (#55)

Old-commit-hash: 04b32e5d92152cdab089a25c0d8f9f4c39279fb0

module Data.NatBag.Properties where

import Data.Nat as ℕ
open import Relation.Binary.PropositionalEquality
open import Data.NatBag
open import Data.Integer
open import Data.Sum hiding (map)
open import Data.Product hiding (map)

-- This import is too slow.
-- It causes Agda 2.3.2 to use so much memory that cai's
-- computer with 4GB RAM begins to thresh.
--
-- open import Data.Integer.Properties using (n⊖n≡0)
n⊖n≡0 : ∀ n → n ⊖ n ≡ + 0
n⊖n≡0 ℕ.zero    = refl
n⊖n≡0 (ℕ.suc n) = n⊖n≡0 n

----------------
-- Statements --
----------------

b\\b=∅ : ∀ {b : Bag} → b \\ b ≡ empty

∅++b=b : ∀ {b : Bag} → empty ++ b ≡ b

b\\∅=b : ∀ {b : Bag} → b \\ empty ≡ b

∅\\b=-b : ∀ {b : Bag} → empty \\ b ≡ map₂ -_ b

b++[d\\b]=d : ∀ {b d : Bag} → b ++ (d \\ b) ≡ d

------------
-- Proofs --
------------

i-i=0 : ∀ {i : ℤ} → (i - i) ≡ (+ 0)
i-i=0 {+ ℕ.zero} = refl
i-i=0 {+ ℕ.suc n} = n⊖n≡0 n
i-i=0 { -[1+ n ]} = n⊖n≡0 n

-- Debug tool
-- Lets you try out inhabitance of any type anywhere
absurd! : ∀ {B C : Set} → 0 ≡ 1 → B → {x : B} → C
absurd! ()

-- Specialized absurdity needed to type check.
-- λ () hasn't enough information sometimes.
absurd : Nonzero (+ 0) → ∀ {A : Set} → A
absurd ()

-- Here to please the termination checker.
neb\\neb=∅ : ∀ {neb : NonemptyBag} → zipNonempty _-_ neb neb ≡ empty
neb\\neb=∅ {singleton i i≠0} with nonzero? (i - i)
... | inj₁ _ = refl
... | inj₂ 0≠0 rewrite i-i=0 {i} = absurd 0≠0
neb\\neb=∅ {i ∷ neb} with nonzero? (i - i)
... | inj₁ _ rewrite neb\\neb=∅ {neb} = refl
... | inj₂ 0≠0 rewrite neb\\neb=∅ {neb} | i-i=0 {i} = absurd 0≠0

b\\b=∅ {inj₁ ∅} = refl
b\\b=∅ {inj₂ neb} = neb\\neb=∅ {neb}

∅++b=b {b} = {!!}

b\\∅=b {b} = {!!}

∅\\b=-b {b} = {!!}

negate : ∀ {i} → Nonzero i → Nonzero (- i)
negate (negative n) = positive n
negate (positive n) = negative n

negate′ : ∀ {i} → (i≠0 : Nonzero i) → Nonzero (+ 0 - i)
negate′ { -[1+ n ]} (negative .n) = positive n
negate′ {+ .(ℕ.suc n)} (positive n) = negative n

0-i=-i : ∀ {i} → + 0 - i ≡ - i
0-i=-i { -[1+ n ]} = refl -- cases are split, for arguments to
0-i=-i {+ ℕ.zero}  = refl -- refl are different.
0-i=-i {+ ℕ.suc n} = refl

rewrite-singleton :
  ∀ (i : ℤ) (0-i≠0 : Nonzero (+ 0 - i)) ( -i≠0 : Nonzero (- i)) →
    singleton (+ 0 - i) 0-i≠0 ≡ singleton (- i) -i≠0
rewrite-singleton (+ ℕ.zero) () ()
rewrite-singleton (+ ℕ.suc n) (negative .n) (negative .n) = refl
rewrite-singleton ( -[1+ n ]) (positive .n) (positive .n) = refl

negateSingleton : ∀ {i i≠0} →
  mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡
  inj₂ (singleton (- i) (negate i≠0))

-- Fun fact:
-- Pattern-match on implicit parameters in the first two
-- cases results in rejection by Agda.
negateSingleton {i} {i≠0} with nonzero? i | nonzero? (+ 0 - i)
negateSingleton | inj₂ (negative n) | inj₁ ()
negateSingleton | inj₂ (positive n) | inj₁ ()
negateSingleton {_} {i≠0} | inj₁ i=0 | _ rewrite i=0 = absurd i≠0
negateSingleton {i} {i≠0} | inj₂ _ | inj₂ 0-i≠0 =
  begin -- Reasoning done in 1 step. Included for clarity only.
    inj₂ (singleton (+ 0 + - i) 0-i≠0)
  ≡⟨ cong inj₂ (rewrite-singleton i 0-i≠0 (negate i≠0)) ⟩
    inj₂ (singleton (- i) (negate i≠0))
  ∎  where open ≡-Reasoning

absurd[i-i≠0] : ∀ {i} → Nonzero (i - i) → ∀ {A : Set} → A
absurd[i-i≠0] {+ ℕ.zero} = absurd
absurd[i-i≠0] {+ ℕ.suc n} = absurd[i-i≠0] { -[1+ n ]}
absurd[i-i≠0] { -[1+ ℕ.zero ]} = absurd
absurd[i-i≠0] { -[1+ ℕ.suc n ]} = absurd[i-i≠0] { -[1+ n ]}

annihilate : ∀ {i i≠0} →
  inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0)) ≡ inj₁ ∅
annihilate {i} with nonzero? (i - i)
... | inj₁ i-i=0 = λ {i≠0} → refl
... | inj₂ i-i≠0 = absurd[i-i≠0] {i} i-i≠0

b++[∅\\b]=∅ : ∀ {b} → b ++ (empty \\ b) ≡ empty
b++[∅\\b]=∅ {inj₁ ∅} = refl
b++[∅\\b]=∅ {inj₂ (singleton i i≠0)} =
  begin
    inj₂ (singleton i i≠0) ++
      mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡⟨ cong₂ _++_ {x = inj₂ (singleton i i≠0)} refl
                (negateSingleton {i} {i≠0}) ⟩
    inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0))
  ≡⟨ annihilate {i} {i≠0} ⟩
    inj₁ ∅
  ∎ where open ≡-Reasoning
b++[∅\\b]=∅ {inj₂ (i ∷ y)} = {!!}

b++[d\\b]=d {inj₁ ∅} {d} rewrite b\\∅=b {d} | ∅++b=b {d} = refl
b++[d\\b]=d {b} {inj₁ ∅} = b++[∅\\b]=∅ {b}
b++[d\\b]=d {inj₂ b} {inj₂ d} = {!!}

module Data.NatBag.Properties where

import Data.Nat as ℕ
open import Relation.Binary.PropositionalEquality
open import Data.NatBag
open import Data.Integer
open import Data.Sum hiding (map)
open import Data.Product hiding (map)

-- This import is too slow.
-- It causes Agda 2.3.2 to use so much memory that cai's
-- computer with 4GB RAM begins to thresh.
--
-- open import Data.Integer.Properties using (n⊖n≡0)
n⊖n≡0 : ∀ n → n ⊖ n ≡ + 0
n⊖n≡0 ℕ.zero    = refl
n⊖n≡0 (ℕ.suc n) = n⊖n≡0 n

----------------
-- Statements --
----------------

b\\b=∅ : ∀ {b : Bag} → b \\ b ≡ empty

∅++b=b : ∀ {b : Bag} → empty ++ b ≡ b

b\\∅=b : ∀ {b : Bag} → b \\ empty ≡ b

∅\\b=-b : ∀ {b : Bag} → empty \\ b ≡ map₂ -_ b

-- ++d=\\-d : ∀ {b d : Bag} → b ++ d ≡ b \\ map₂ -_ d

b++[d\\b]=d : ∀ {b d : Bag} → b ++ (d \\ b) ≡ d

------------
-- Proofs --
------------

i-i=0 : ∀ {i : ℤ} → (i - i) ≡ (+ 0)
i-i=0 {+ ℕ.zero} = refl
i-i=0 {+ ℕ.suc n} = n⊖n≡0 n
i-i=0 { -[1+ n ]} = n⊖n≡0 n

-- Debug tool
-- Lets you try out inhabitance of any type anywhere
absurd! : ∀ {B C : Set} → 0 ≡ 1 → B → {x : B} → C
absurd! ()

-- Specialized absurdity needed to type check.
-- λ () hasn't enough information sometimes.
absurd : Nonzero (+ 0) → ∀ {A : Set} → A
absurd ()

-- Here to please the termination checker.
neb\\neb=∅ : ∀ {neb : NonemptyBag} → zipNonempty _-_ neb neb ≡ empty
neb\\neb=∅ {singleton i i≠0} with nonzero? (i - i)
... | inj₁ _ = refl
... | inj₂ 0≠0 rewrite i-i=0 {i} = absurd 0≠0
neb\\neb=∅ {i ∷ neb} with nonzero? (i - i)
... | inj₁ _ rewrite neb\\neb=∅ {neb} = refl
... | inj₂ 0≠0 rewrite neb\\neb=∅ {neb} | i-i=0 {i} = absurd 0≠0

{-
++d=\\-d {inj₁ ∅} {inj₁ ∅} = refl
++d=\\-d {inj₁ ∅} {inj₂ (i ∷ y)} = {!!}
++d=\\-d {inj₂ y} {d} = {!!}
++d=\\-d {inj₁ ∅} {inj₂ (singleton i i≠0)}
  rewrite ∅++b=b {inj₂ (singleton i i≠0)}
  with nonzero? i | nonzero? (+ 0 - i)
... | inj₂ _ | inj₂ 0-i≠0 =
  begin
    {!!}
  ≡⟨ {!!} ⟩
    {!inj₂ (singleton (- i) ?)!}
  ∎ where open ≡-Reasoning
... | inj₁ i=0 | _ rewrite i=0 = absurd i≠0
++d=\\-d {inj₁ ∅} {inj₂ (singleton (+ 0) i≠0)} | _ | _ = absurd i≠0
++d=\\-d {inj₁ ∅} {inj₂ (singleton (+ (ℕ.suc n)) i≠0)}
  | inj₂ (positive .n) | inj₁ ()
++d=\\-d {inj₁ ∅} {inj₂ (singleton -[1+ n ] i≠0)}
  | inj₂ (negative .n) | inj₁ ()
-}

b\\b=∅ {inj₁ ∅} = refl
b\\b=∅ {inj₂ neb} = neb\\neb=∅ {neb}

∅++b=b {b} = {!!}

b\\∅=b {b} = {!!}

∅\\b=-b {b} = {!!}

negate : ∀ {i} → Nonzero i → Nonzero (- i)
negate (negative n) = positive n
negate (positive n) = negative n

negate′ : ∀ {i} → (i≠0 : Nonzero i) → Nonzero (+ 0 - i)
negate′ { -[1+ n ]} (negative .n) = positive n
negate′ {+ .(ℕ.suc n)} (positive n) = negative n

0-i=-i : ∀ {i} → + 0 - i ≡ - i
0-i=-i { -[1+ n ]} = refl -- cases are split, for arguments to
0-i=-i {+ ℕ.zero}  = refl -- refl are different.
0-i=-i {+ ℕ.suc n} = refl

rewrite-singleton :
  ∀ (i : ℤ) (0-i≠0 : Nonzero (+ 0 - i)) ( -i≠0 : Nonzero (- i)) →
    singleton (+ 0 - i) 0-i≠0 ≡ singleton (- i) -i≠0
rewrite-singleton (+ ℕ.zero) () ()
rewrite-singleton (+ ℕ.suc n) (negative .n) (negative .n) = refl
rewrite-singleton ( -[1+ n ]) (positive .n) (positive .n) = refl

negateSingleton : ∀ {i i≠0} →
  mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡
  inj₂ (singleton (- i) (negate i≠0))

-- Fun fact:
-- Pattern-match on implicit parameters in the first two
-- cases results in rejection by Agda.
negateSingleton {i} {i≠0} with nonzero? i | nonzero? (+ 0 - i)
negateSingleton | inj₂ (negative n) | inj₁ ()
negateSingleton | inj₂ (positive n) | inj₁ ()
negateSingleton {_} {i≠0} | inj₁ i=0 | _ rewrite i=0 = absurd i≠0
negateSingleton {i} {i≠0} | inj₂ _ | inj₂ 0-i≠0 =
  begin -- Reasoning done in 1 step. Included for clarity only.
    inj₂ (singleton (+ 0 + - i) 0-i≠0)
  ≡⟨ cong inj₂ (rewrite-singleton i 0-i≠0 (negate i≠0)) ⟩
    inj₂ (singleton (- i) (negate i≠0))
  ∎  where open ≡-Reasoning

absurd[i-i≠0] : ∀ {i} → Nonzero (i - i) → ∀ {A : Set} → A
absurd[i-i≠0] {+ ℕ.zero} = absurd
absurd[i-i≠0] {+ ℕ.suc n} = absurd[i-i≠0] { -[1+ n ]}
absurd[i-i≠0] { -[1+ ℕ.zero ]} = absurd
absurd[i-i≠0] { -[1+ ℕ.suc n ]} = absurd[i-i≠0] { -[1+ n ]}

annihilate : ∀ {i i≠0} →
  inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0)) ≡ inj₁ ∅
annihilate {i} with nonzero? (i - i)
... | inj₁ i-i=0 = λ {i≠0} → refl
... | inj₂ i-i≠0 = absurd[i-i≠0] {i} i-i≠0

{-
left-is-not-right : ∀ {A B : Set} {a : A} {b : B} →
                    inj₁ a ≡ inj₂ b → ∀ {X : Set} → X
left-is-not-right = λ {A} {B} {a} {b} → λ ()

never-both : ∀ {A B : Set} {sum : A ⊎ B} {a b} →
               sum ≡ inj₁ a → sum ≡ inj₂ b → ∀ {X : Set} → X
never-both s=a s=b = left-is-not-right (trans (sym s=a) s=b)

empty-bag? : ∀ (b : Bag) → (b ≡ inj₁ ∅) ⊎ Σ NonemptyBag (λ neb → b ≡ inj₂ neb)
empty-bag? (inj₁ ∅) = inj₁ refl
empty-bag? (inj₂ neb) = inj₂ (neb , refl)
-}

b++[∅\\b]=∅ : ∀ {b} → b ++ (empty \\ b) ≡ empty
b++[∅\\b]=∅ {inj₁ ∅} = refl
b++[∅\\b]=∅ {inj₂ (singleton i i≠0)} =
  begin
    inj₂ (singleton i i≠0) ++
      mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡⟨ cong₂ _++_ {x = inj₂ (singleton i i≠0)} refl
                (negateSingleton {i} {i≠0}) ⟩
    inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0))
  ≡⟨ annihilate {i} {i≠0} ⟩
    inj₁ ∅
  ∎ where open ≡-Reasoning
b++[∅\\b]=∅ {inj₂ (i ∷ y)} = {!!}

b++[d\\b]=d {inj₁ ∅} {d} rewrite b\\∅=b {d} | ∅++b=b {d} = refl
b++[d\\b]=d {b} {inj₁ ∅} = b++[∅\\b]=∅ {b}
b++[d\\b]=d {inj₂ b} {inj₂ d} = {!!}