NomPa: Update use of NP library

NomPa: Update use of NP library

{-# OPTIONS --universe-polymorphism #-}
import Level as L
open import Data.Bool.NP
open import Data.Nat.Logical
open import Data.Two hiding (_==_)
open import Data.Two.Logical
open import Data.Unit
open import Data.Empty
open import Data.Sum.NP
open import Data.Sum.Logical
open import Data.Maybe.NP
open import Data.List
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Nullary.Decidable
open import Relation.Binary.NP as Bin
open import Relation.Binary.Logical
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as ⇔ using (_⇔_; equivalence; module Equivalence)
import Relation.Binary.PropositionalEquality.NP as ≡
import Data.Nat.NP as ℕ
open ℕ renaming (_==_ to _==ℕ_)
import Data.Nat.Properties as ℕ
open import NomPa.Record using (module NomPa)
open import NomPa.Implem
import NaPa
open NaPa using (∈-uniq)
open import NomPa.Worlds
import NomPa.Derived

module NomPa.Implem.LogicalRelation.Internals where

open ≡ using (_≡_; _≢_; ⟦≡⟧)
open ≡.≡-Reasoning
open NomPa.Implem.Internals
open NomPa NomPa.Implem.nomPa using (worldSym; Nameø-elim; sucᴺ; sucᴺ↑)

-- move to record
predᴺ : ∀ {α} → Name (α +1) → Name α
predᴺ = subtractᴺ 1

≢→✓-not-==ℕ : ∀ {x y} → x ≢ y → ✓ (not (x ==ℕ y))
≢→✓-not-==ℕ ¬p = ✓-¬-not (¬p ∘ ℕ.==.sound _ _)

#⇒∉ : ∀ {α b} → b # α → b ∉ α
#⇒∉ (_ #ø)      = id
#⇒∉ (suc#∷ b#α) = #⇒∉ b#α
#⇒∉ (0# _)      = id

#⇒≢ : ∀ {α b} → b # α → (x : Name α) → binderᴺ x ≢ b
#⇒≢ b# (b , b∈) ≡.refl = #⇒∉ b# b∈

binderᴺ-injective : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y → x ≡ y
binderᴺ-injective {α} {_ , p₁} {a , p₂} eq rewrite eq = ≡.cong (_,_ a) (∈-uniq α p₁ p₂)

pf-irr′ : ∀ {α β} (ℛ : Name α → Name β → Set) {x x′ : Name α} {y y′ : Name β}
         → binderᴺ x ≡ binderᴺ x′ → binderᴺ y ≡ binderᴺ y′ → ℛ x y → ℛ x′ y′
pf-irr′ {α} {β} ℛ {x , x∈} {x′ , x′∈} {y , y∈} {y′ , y′∈} eq₁ eq₂ xᵣy
  rewrite eq₁ | eq₂ | ∈-uniq α x∈ x′∈ | ∈-uniq β y∈ y′∈ = xᵣy

pf-irr : ∀ {α β} (ℛ : Name α → Name β → Set) {x y x∈ x∈′ y∈ y∈′}
         → ℛ (x , x∈) (y , y∈) → ℛ (x , x∈′) (y , y∈′)
pf-irr ℛ = pf-irr′ ℛ ≡.refl ≡.refl

Preserve-≈ : ∀ {a b ℓ ℓa ℓb} {A : Set a} {B : Set b} → Rel A ℓa → Rel (B) ℓb → REL A (B) ℓ → Set _
Preserve-≈ _≈a_ _≈b_ _∼_ = ∀ {x₁ x₂ y₁ y₂} → x₁ ∼ x₂ → y₁ ∼ y₂ → (x₁ ≈a y₁) ⇔ (x₂ ≈b y₂)

==ℕ⇔≡ : ∀ {x y} → ✓ (x ==ℕ y) ⇔ x ≡ y
==ℕ⇔≡ {x} {y} = equivalence (ℕ.==.sound _ _) ℕ.==.reflexive

≡-on-name⇔≡ : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y ⇔ x ≡ y
≡-on-name⇔≡ {α} {x} {y} = equivalence binderᴺ-injective (≡.cong binderᴺ)

T⇔T→≡ : ∀ {b₁ b₂} → ✓ b₁ ⇔ ✓ b₂ → b₁ ≡ b₂
T⇔T→≡ {1₂} {1₂} b₁⇔b₂ = ≡.refl
T⇔T→≡ {1₂} {0₂} b₁⇔b₂ = ⊥-elim (Equivalence.to b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {1₂} b₁⇔b₂ = ⊥-elim (Equivalence.from b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {0₂} b₁⇔b₂ = ≡.refl

==ᴺ⇔≡ : ∀ {α} {x y : Name α} → ✓ (x ==ᴺ y) ⇔ x ≡ y
==ᴺ⇔≡ = ≡-on-name⇔≡ ⟨∘⟩ ==ℕ⇔≡ where open ⇔ renaming (_∘_ to _⟨∘⟩_)

-- Preserving the equalities also mean that the relation is functional and injective
Preserve-≡ : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A (B) ℓ → Set _
Preserve-≡ _∼_ = Preserve-≈ _≡_ _≡_ _∼_

exportᴺ?-nothing : ∀ {b α} (x : Name (b ◅ α)) → ✓ (binderᴺ x ==ℕ b) → exportᴺ? {b} x ≡ nothing
exportᴺ?-nothing {b} {α} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ≡.refl
... | 0₂ | _ = ⊥-elim p

exportᴺ?-just : ∀ {α b} (x : Name (b ◅ α)) {x∈} → ✓ (not (binderᴺ x ==ℕ b)) → exportᴺ? {b} x ≡ just (binderᴺ x , x∈)
exportᴺ?-just {α} {b} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ⊥-elim p
... | 0₂ | _ = ≡.cong just (binderᴺ-injective ≡.refl)

record ⟦World⟧ (α₁ α₂ : World) : Set₁ where
  constructor _,_
  field
    _∼_ : Name α₁ → Name α₂ → Set
    ∼-pres-≡ : Preserve-≡ _∼_

  ∼-inj : ∀ {x y z} → x ∼ z → y ∼ z → x ≡ y
  ∼-inj p q = Equivalence.from (∼-pres-≡ p q) ⟨$⟩ ≡.refl
  ∼-fun : ∀ {x y z} → x ∼ y → x ∼ z → y ≡ z
  ∼-fun p q = Equivalence.to (∼-pres-≡ p q) ⟨$⟩ ≡.refl

  ∼-∈-uniq : ∀ {x₁ x₂} {x₁∈′ x₂∈′} →
        x₁ ∼ x₂ ≡ (binderᴺ x₁ , x₁∈′) ∼ (binderᴺ x₂ , x₂∈′)
  ∼-∈-uniq {_ , x₁∈} {_ , x₂∈} {x₁∈′} {x₂∈′} = ≡.ap₂ (λ x₁∈ x₂∈ → (_ , x₁∈) ∼ (_ , x₂∈)) (∈-uniq α₁ x₁∈ x₁∈′) (∈-uniq α₂ x₂∈ x₂∈′)

⟦sym⟧ : ∀ {α₁ α₂} → ⟦World⟧ α₁ α₂ → ⟦World⟧ α₂ α₁
⟦sym⟧ (ℛ , ℛ-pres-≡) = ℛ-sym , ℛ-sym-pres-≡
  where ℛ-sym = flip ℛ
        ℛ-sym-pres-≡ : Preserve-≡ ℛ-sym
        ℛ-sym-pres-≡ p q = ⇔.sym (ℛ-pres-≡ p q)

record ⟦Binder⟧ (b₁ b₂ : Binder) : Set where

module ⟦◅⟧ (b₁ b₂ : Binder) {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ
  data _ℛ_ (x : Name (b₁ ◅ α₁)) (y : Name (b₂ ◅ α₂)) : Set where
    here  : (x≡b₁ : binderᴺ x ≡ b₁) (y≡b₂ : binderᴺ y ≡ b₂) → x ℛ y
    there : ∀ (x≢b₁ : binderᴺ x ≢ b₁) (y≢b₂ : binderᴺ y ≢ b₂) {x∈ y∈} (x∼y : (binderᴺ x , x∈) ∼ (binderᴺ y , y∈)) → x ℛ y

  ℛ-inj : ∀ {x y z} → x ℛ z → y ℛ z → x ≡ y
  ℛ-inj (here x≡b₁ _)    (here y≡b₁ _)     = binderᴺ-injective (≡.trans x≡b₁ (≡.sym y≡b₁))
  ℛ-inj (here _ z≡b₂)    (there _ z≢b₂ _)  = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj (there _ z≢b₂ _) (here _ z≡b₂)     = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj {x} {y} {z} (there x≢b₁ z≢b₂ {x∈} {z∈} x∼z) (there y≢b₁ _ {y∈} {z∈′} y∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-inj x∼z (≡.tr (λ z∈ → (binderᴺ y , y∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₂ z∈′ z∈) y∼z )))

  ℛ-fun : ∀ {x y z} → x ℛ y → x ℛ z → y ≡ z
  ℛ-fun (here _ y≡b₂)  (here _ z≡b₂)    = binderᴺ-injective (≡.trans y≡b₂ (≡.sym z≡b₂))
  ℛ-fun (here p _)     (there ¬p _ _)    = ⊥-elim (¬p p)
  ℛ-fun (there ¬p _ _) (here p _)        = ⊥-elim (¬p p)
  ℛ-fun {x} {y} {z} (there x≢b₁ y≢b₂ {x∈} {y∈} x∼y) (there p q {x∈′} {z∈} x∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-fun x∼y (≡.tr (λ x∈ → (binderᴺ x , x∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₁ x∈′ x∈) x∼z )))

  ℛ-pres-≡ : Preserve-≡ _ℛ_
  ℛ-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     equivalence (λ x₁=y₁ → ℛ-fun {y₁} (≡.tr (λ x₁ → x₁ ℛ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ-inj x₁∼x₂ (≡.tr (λ y₂ → y₁ ℛ y₂) (≡.sym x₂=y₂) y₁∼y₂))

  ⟦world⟧ : ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
  ⟦world⟧ = _ℛ_ , ℛ-pres-≡

here′ : ∀ {α₁ α₂ b₁ b₂ pf₁ pf₂} {αᵣ : ⟦World⟧ α₁ α₂} → ⟦◅⟧._ℛ_ b₁ b₂ αᵣ (b₁ , pf₁) (b₂ , pf₂)
here′ = ⟦◅⟧.here ≡.refl ≡.refl

_⟦◅⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦World⟧) _◅_ _◅_
_⟦◅⟧_ {b₁} {b₂} _ αᵣ = ⟦◅⟧.⟦world⟧ b₁ b₂ αᵣ

⟦Name⟧ : ⟦Pred⟧ L.zero ⟦World⟧ Name Name
⟦Name⟧ (ℛ , _) x₁ x₂ = ℛ x₁ x₂

⟦zeroᴮ⟧ : ⟦Binder⟧ zeroᴮ zeroᴮ
⟦zeroᴮ⟧ = _

⟦sucᴮ⟧ : (⟦Binder⟧ ⟦→⟧ ⟦Binder⟧) sucᴮ sucᴮ
⟦sucᴮ⟧ = _

⟦ø⟧ : ⟦World⟧ ø ø
⟦ø⟧ = (λ _ _ → ⊥) , (λ())

_⟦==ᴺ⟧_ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
_⟦==ᴺ⟧_ αᵣ xᵣ yᵣ =
   ⟦𝟚⟧-Props.reflexive (T⇔T→≡ (sym ==ᴺ⇔≡ ⟨∘⟩ ∼-pres-≡ xᵣ yᵣ ⟨∘⟩ ==ᴺ⇔≡)) where
  open ⟦World⟧ αᵣ
  open ⇔ using (sym) renaming (_∘_ to _⟨∘⟩_)

⟦nameᴮ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ)) nameᴮ nameᴮ
⟦nameᴮ⟧ _ _ = here′

⟦binderᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Binder⟧) binderᴺ binderᴺ
⟦binderᴺ⟧ _ _ = _

⟦nothing⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂}
            → x ≡ nothing → y ≡ nothing → ⟦Maybe⟧ Aᵣ x y
⟦nothing⟧′ ≡.refl ≡.refl = ⟦nothing⟧

⟦just⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂} {x′ y′}
            → x ≡ just x′ → y ≡ just y′ → Aᵣ x′ y′ → ⟦Maybe⟧ Aᵣ x y
⟦just⟧′ ≡.refl ≡.refl = ⟦just⟧

⟦exportᴺ?⟧ : (∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦→⟧ ⟦Maybe⟧ (⟦Name⟧ αᵣ)) (λ {b} → exportᴺ? {b}) (λ {b} → exportᴺ? {b})
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.here e₁ e₂)
  = ⟦nothing⟧′ (exportᴺ?-nothing x₁ (ℕ.==.reflexive e₁)) (exportᴺ?-nothing x₂ (ℕ.==.reflexive e₂))
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.there x₁≢b₁ x₂≢b₂ x₁∼x₂)
  = ⟦just⟧′ (exportᴺ?-just x₁ (≢→✓-not-==ℕ x₁≢b₁))
           (exportᴺ?-just x₂ (≢→✓-not-==ℕ x₂≢b₂)) x₁∼x₂

_⟦⊆⟧b_ : ⟦Rel⟧ ⟦World⟧ L.zero _⊆_ _⊆_
_⟦⊆⟧b_ αᵣ βᵣ x y = (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) (coerceᴺ x) (coerceᴺ y)

data _⟦⊆⟧_ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {β₁ β₂} (βᵣ : ⟦World⟧ β₁ β₂) (x : α₁ ⊆ β₁) (y : α₂ ⊆ β₂) : Set where
  mk : _⟦⊆⟧b_ αᵣ βᵣ x y → _⟦⊆⟧_ αᵣ βᵣ x y

un⟦⊆⟧ : ∀ {α₁ α₂} {αᵣ : ⟦World⟧ α₁ α₂} {β₁ β₂} {βᵣ : ⟦World⟧ β₁ β₂} {x y} → (αᵣ ⟦⊆⟧ βᵣ) x y → (αᵣ ⟦⊆⟧b βᵣ) x y
un⟦⊆⟧ (mk x) {a} {b} c = x {a} {b} c

⟦⊆-refl⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ αᵣ) ⊆-refl ⊆-refl
⟦⊆-refl⟧ _ = mk (λ xᵣ → xᵣ)

⟦⊆-trans⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ γᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                  αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (βᵣ ⟦⊆⟧ γᵣ ⟦→⟧ (αᵣ ⟦⊆⟧ γᵣ))) ⊆-trans ⊆-trans
⟦⊆-trans⟧ _ _ _ {mk f₁} {mk f₂} f {mk g₁} {mk g₂} g
  = mk (λ {x₁} {x₂} xᵣ → un⟦⊆⟧ g {coerceᴺ (mk f₁) x₁} {coerceᴺ (mk f₂) x₂} (un⟦⊆⟧ f {x₁} {x₂} xᵣ))

⟦coerceᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ)) coerceᴺ coerceᴺ
⟦coerceᴺ⟧ _ _ α⊆βᵣ {x₁} {x₂} xᵣ = un⟦⊆⟧ α⊆βᵣ {x₁} {x₂} xᵣ

⟦¬Nameø⟧ : (⟦¬⟧(⟦Name⟧ ⟦ø⟧)) ¬Nameø ¬Nameø
⟦¬Nameø⟧ ()

⟦⊆-ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦ø⟧ ⟦⊆⟧ αᵣ) ⊆-ø ⊆-ø
⟦⊆-ø⟧ αᵣ = mk λ { {_ , ()} }

_⟦#⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦Set₀⟧) _#_ _#_
_⟦#⟧_ _ _ _ _ = ⊤

_⟦#ø⟧ : (⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ ⟦ø⟧) _#ø _#ø
_⟦#ø⟧ _ = _

⟦suc#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ αᵣ ⟦→⟧ (⟦sucᴮ⟧ bᵣ) ⟦#⟧ (bᵣ ⟦◅⟧ αᵣ)) suc# suc#
⟦suc#⟧ _ _ _ = _

⟦⊆-#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                  (bᵣ ⟦#⟧ αᵣ) ⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ)) ⊆-# ⊆-#
⟦⊆-#⟧ _ {b₁} {b₂} _ {b₁#α₁} {b₂#α₂} _ = mk (λ {x₁} {x₂} → ⟦◅⟧.there (#⇒≢ b₁#α₁ x₁) (#⇒≢ b₂#α₂ x₂))

⟦⊆-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦⊆⟧ (bᵣ ⟦◅⟧ βᵣ)) ⊆-◅ ⊆-◅
⟦⊆-◅⟧ {α₁} {α₂} αᵣ {β₁} {β₂} βᵣ {b₁} {b₂} _ {α⊆β₁} {α⊆β₂} (mk f) = mk g where
  open ⟦◅⟧ b₁ b₂
  g : ∀ {x₁ x₂} → _ℛ_ αᵣ x₁ x₂ → _ℛ_ βᵣ (coerceᴺ (⊆-◅ b₁ α⊆β₁) x₁) (coerceᴺ (⊆-◅ b₂ α⊆β₂) x₂)
  g (here x≡b₁ y≡b₂)       = here x≡b₁ y≡b₂
  g (there x≢b₁ y≢b₂ x∼y) = there x≢b₁ y≢b₂ (f x∼y)

congℕ : ∀ {α β : World} {x y : Name α} (f : ℕ → ℕ) {fx∈ fy∈} → x ≡ y → _≡_ {A = Name β} (f (binderᴺ x) , fx∈) (f (binderᴺ y) , fy∈)
congℕ f = binderᴺ-injective ∘ ≡.cong (f ∘ binderᴺ)

module ⟦+1⟧ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ renaming (_∼_ to ℛ; ∼-inj to ℛ-inj; ∼-fun to ℛ-fun)
  ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set
  ℛ+1 x y = ⟦Name⟧ αᵣ (predᴺ x) (predᴺ y)
{-
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x x∈ y y∈} → ⟦Name⟧ αᵣ x y → ℛ+1 (suc x , ) (sucN y)
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x y} → ⟦Name⟧ αᵣ x y → ℛ+1 (sucN x) (sucN y)
-}

  ℛ+1-inj : ∀ {x y z} → ℛ+1 x z →  ℛ+1 y z → x ≡ y
  -- ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} (suc a) (suc b) = {!!}
  ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-inj a b)
  ℛ+1-inj {zero , ()} _ _
  ℛ+1-inj {_} {zero , ()} _ _
  ℛ+1-inj {_} {_} {zero , ()} _ _
  ℛ+1-fun : ∀ {x y z} → ℛ+1 x y →  ℛ+1 x z → y ≡ z
  ℛ+1-fun {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-fun a b)
  ℛ+1-fun {zero , ()} _ _
  ℛ+1-fun {_} {zero , ()} _ _
  ℛ+1-fun {_} {_} {zero , ()} _ _

  ℛ+1-pres-≡ : Preserve-≡ ℛ+1
  -- ℛ+1-pres-≡ x y = equivalence {!ℛ+1-inj!} {!!}
  ℛ+1-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     -- factor this move
     equivalence (λ x₁=y₁ → ℛ+1-fun {y₁} (≡.tr (λ x₁ → ℛ+1 x₁ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ+1-inj {x₁} {y₁} {x₂} x₁∼x₂ (≡.tr (λ y₂ → ℛ+1 y₁ y₂) (≡.sym x₂=y₂) y₁∼y₂))

_⟦+1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _+1 _+1
_⟦+1⟧ αᵣ = ℛ+1 , ℛ+1-pres-≡ where open ⟦+1⟧ αᵣ

open WorldOps worldSym

_⟦↑1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _↑1 _↑1
_⟦↑1⟧ αᵣ = ⟦zeroᴮ⟧ ⟦◅⟧ (αᵣ ⟦+1⟧)

_⟦↑⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _↑_ _↑_
_⟦↑⟧_ αᵣ zero    = αᵣ
_⟦↑⟧_ αᵣ (suc k) = (αᵣ ⟦↑⟧ k) ⟦↑1⟧

_⟦+ᵂ⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _+ᵂ_ _+ᵂ_
_⟦+ᵂ⟧_ αᵣ zero    = αᵣ
_⟦+ᵂ⟧_ αᵣ (suc k) = (αᵣ ⟦+ᵂ⟧ k) ⟦+1⟧

⟦predᴺ⟧-sucᴺ↑ : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂)
                 {x₁ x₂} (xᵣ : ⟦Name⟧ (αᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ αᵣ x₁ x₂
⟦predᴺ⟧-sucᴺ↑ _  (⟦◅⟧.here () _)
⟦predᴺ⟧-sucᴺ↑ αᵣ (⟦◅⟧.there _ _ x∼y) = pf-irr (⟦Name⟧ αᵣ) x∼y

⟦ø+1⊆ø⟧ : (⟦ø⟧ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧) ø+1⊆ø ø+1⊆ø
⟦ø+1⊆ø⟧ = mk (λ {x} _ → Nameø-elim (predᴺ x))

⟦⊆-cong-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧)) ⊆-cong-+1 ⊆-cong-+1
⟦⊆-cong-+1⟧ _ βᵣ α⊆βᵣ = mk (pf-irr (⟦Name⟧ βᵣ) ∘ un⟦⊆⟧ α⊆βᵣ)

⟦⊆-cong-↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-cong-↑1 ⊆-cong-↑1
⟦⊆-cong-↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk helper where
  open ⟦◅⟧ 0 0
  helper : (⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-cong-↑1 α⊆β₁)) (coerceᴺ (⊆-cong-↑1 α⊆β₂))
  helper (here x≡b₁ y≡b₂) = here x≡b₁ y≡b₂
  helper {x₁ , _} {x₂ , _} (there x≢b₁ y≢b₂ {p₁} {p₂} x∼y)
     = there x≢b₁ y≢b₂ {coe (⊆-cong-+1 α⊆β₁) x₁ p₁}
                        {coe (⊆-cong-+1 α⊆β₂) x₂ p₂}
                        (pf-irr (⟦Name⟧ βᵣ) (un⟦⊆⟧ α⊆βᵣ x∼y))

⟦⊆-+1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-+1-inj ⊆-+1-inj
⟦⊆-+1-inj⟧ _ _ α+⊆β+ᵣ = mk (λ {x₁} {x₂} → un⟦⊆⟧ α+⊆β+ᵣ {addᴺ 1 x₁} {addᴺ 1 x₂})

≢0 : ∀ {α} (x : Name (α +1)) → binderᴺ x ≢ 0
≢0 (0 , ()) ≡.refl
≢0 (suc _ , _) ()

⟦⊆-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (αᵣ ⟦↑1⟧)) ⊆-+1↑1 ⊆-+1↑1
⟦⊆-+1↑1⟧ αᵣ = mk (λ {x₁} {x₂} → there (≢0 x₁) (≢0 x₂)) where open ⟦◅⟧ 0 0

⟦⊆-↑1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-↑1-inj ⊆-↑1-inj
⟦⊆-↑1-inj⟧ _ βᵣ α↑⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → ⟦predᴺ⟧-sucᴺ↑ βᵣ (un⟦⊆⟧ α↑⊆β↑ᵣ {sucᴺ↑ x₁} {sucᴺ↑ x₂} (there (λ()) (λ()) xᵣ))) where
  open ⟦◅⟧ 0 0

⟦⊆-unctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-unctx-+1↑1 ⊆-unctx-+1↑1
⟦⊆-unctx-+1↑1⟧ _ βᵣ α+⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → helper (un⟦⊆⟧ α+⊆β↑ᵣ {sucᴺ x₁} {sucᴺ x₂} xᵣ)) where
  open ⟦◅⟧ 0 0
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (βᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ βᵣ x₁ x₂
  helper (here () _)
  helper (there _ _ x∼y) = pf-irr (⟦Name⟧ βᵣ) x∼y

⟦sucᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧)) sucᴺ sucᴺ
⟦sucᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦predᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ αᵣ) predᴺ predᴺ
⟦predᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦sucᴺ↑⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) sucᴺ↑ sucᴺ↑
⟦sucᴺ↑⟧ αᵣ xᵣ = ⟦coerceᴺ⟧ _ _ (⟦⊆-+1↑1⟧ αᵣ) (⟦sucᴺ⟧ αᵣ xᵣ)

⟦addᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) addᴺ addᴺ
⟦addᴺ⟧ _  zero xᵣ = xᵣ
⟦addᴺ⟧ αᵣ (suc kᵣ) xᵣ = pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (⟦addᴺ⟧ αᵣ kᵣ xᵣ)

⟦subtractᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) ⟦→⟧ ⟦Name⟧ αᵣ) subtractᴺ subtractᴺ
⟦subtractᴺ⟧ _ zero x = x
⟦subtractᴺ⟧ αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} xᵣ
   = pf-irr′ (⟦Name⟧ αᵣ) (ℕ.∸-+-assoc (binderᴺ x₁) 1 k₁) (ℕ.∸-+-assoc (binderᴺ x₂) 1 k₂) (⟦subtractᴺ⟧ αᵣ kᵣ xᵣ)

¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {pf₁ : 0 ∈ α₁ ↑1} {n} {pf₂ : suc n ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (0 , pf₁) (suc n , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.there p _ _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.here _ ())

¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {n} {pf₁ : suc n ∈ α₁ ↑1} {pf₂ : 0 ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (suc n , pf₁) (0 , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.there _ p _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.here () _)

-- cmpᴺ-bool : ∀ {α} ℓ → Name (α ↑ ℓ) → 𝟚
-- cmpᴺ-bool ℓ x = suc (binderᴺ x) <= ℓ

⟦cmpᴺ-bool⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦𝟚⟧) NaPa.cmpᴺ-bool NaPa.cmpᴺ-bool
⟦cmpᴺ-bool⟧ _ zero _ = ⟦0₂⟧
⟦cmpᴺ-bool⟧ _ (suc _) {zero , _} {zero , _} _ = ⟦1₂⟧
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦cmpᴺ-bool⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦easy-cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
             ) NaPa.easy-cmpᴺ NaPa.easy-cmpᴺ
⟦easy-cmpᴺ⟧ _ zero xᵣ = ⟦inr⟧ xᵣ
⟦easy-cmpᴺ⟧ _ (suc _) {zero , _} {zero , _} xᵣ = ⟦inl⟧ here′
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦map⟧ _ _ _ _ (⟦sucᴺ↑⟧ (⟦ø⟧ ⟦↑⟧ kᵣ)) (pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) (⟦easy-cmpᴺ⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ))
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
         ) cmpᴺ cmpᴺ
⟦cmpᴺ⟧ {α₁} {α₂} αᵣ {k₁} {k₂} kᵣ {x₁} {x₂} xᵣ =
   ≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (cmpᴺ {α₁} k₁ x₁) x)
           (NaPa.easy-cmpᴺ≗cmpᴺ {α₂} k₂ x₂)
           (≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) x
                    (NaPa.easy-cmpᴺ {α₂} k₂ x₂))
                    (NaPa.easy-cmpᴺ≗cmpᴺ {α₁} k₁ x₁) (⟦easy-cmpᴺ⟧ αᵣ kᵣ {x₁} {x₂} xᵣ))

⟦⊆-dist-+1-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) ⟦⊆⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))))
                 ⊆-dist-+1-◅ ⊆-dist-+1-◅
⟦⊆-dist-+1-◅⟧ αᵣ {b₁} {b₂} bᵣ = mk (λ {η₁} {η₂} η₃ → helper {η₁} {η₂} η₃) where
  -- open ⟦◅⟧ b₁ b₂

  hper :   ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (sucᴺ x₁) (sucᴺ x₂)
  hper (⟦◅⟧.here x≡b₁ y≡b₂) = ⟦◅⟧.here (≡.cong suc x≡b₁) (≡.cong suc y≡b₂)
  hper (⟦◅⟧.there x≢b₁ y≢b₂ x∼y) = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong pred) (y≢b₂ ∘ ≡.cong pred) x∼y

  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (coerceᴺ (⊆-dist-+1-◅ b₁) x₁)
                     (coerceᴺ (⊆-dist-+1-◅ b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ = hper xᵣ
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

⟦⊆-dist-◅-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) ⟦⊆⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)))
                 ⊆-dist-◅-+1 ⊆-dist-◅-+1
⟦⊆-dist-◅-+1⟧ αᵣ {b₁} {b₂} bᵣ = mk helper where
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) x₁ x₂)
           → ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)
                     (coerceᴺ (⊆-dist-◅-+1 b₁) x₁)
                     (coerceᴺ (⊆-dist-◅-+1 b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ with xᵣ
  ... | ⟦◅⟧.here x≡b₁ y≡b₂ = ⟦◅⟧.here (≡.cong (λ x → x ∸ 1) x≡b₁) (≡.cong (λ x → x ∸ 1) y≡b₂)
  ... | ⟦◅⟧.there x≢b₁ y≢b₂ x∼y = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong suc) (y≢b₂ ∘ ≡.cong suc) x∼y
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

{-
Binder≡ℕ : Binder ≡ ℕ
Binder≡ℕ = ≡.refl

postulate
  ⟦Binder⟧≢⟦ℕ⟧ : ⟦Binder⟧ ≢ ⟦ℕ⟧

⟦≡⟧-lem : ∀ {a₁ a₂ aᵣ A₁ A₂} {Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂} {x₁ x₂} {xᵣ : Aᵣ x₁ x₂} {y₁ y₂} {yᵣ : Aᵣ y₁ y₂} {pf₁ pf₂} → ⟦≡⟧ Aᵣ xᵣ yᵣ pf₁ pf₂ → ∀ (P : ∀ {z₁ z₂} → Aᵣ z₁ z₂ → Set) → P xᵣ → P yᵣ
⟦≡⟧-lem = {!!}

¬⟦Binder≡ℕ⟧ : ¬((⟦≡⟧ ⟦Set₀⟧ ⟦Binder⟧ ⟦ℕ⟧) Binder≡ℕ Binder≡ℕ)
¬⟦Binder≡ℕ⟧ = λ pf → ⟦≡⟧-lem pf (λ x → ⊥) {!!}
-}

⟦binderᴺ∘nameᴮ⟧ : (⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                   ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                    ⟦≡⟧ ⟦Binder⟧ (⟦binderᴺ⟧ (bᵣ ⟦◅⟧ αᵣ) (⟦nameᴮ⟧ αᵣ bᵣ)) bᵣ) binderᴺ∘nameᴮ binderᴺ∘nameᴮ
⟦binderᴺ∘nameᴮ⟧ αᵣ bᵣ = ≡.⟦refl⟧

⟨_,_⟩⟦◅⟧_ : (b₁ b₂ : Binder) → ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) → ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
⟨ b₁ , b₂ ⟩⟦◅⟧ αᵣ = _⟦◅⟧_ {b₁} {b₂} _ αᵣ

module Perm (m n : ℕ) (m≢n : m ≢ n) where
  mnᵂ : World
  mnᵂ = m ◅ n ◅ ø
  nmᵂ : World
  nmᵂ = n ◅ m ◅ ø
  perm-m-n : ⟦World⟧ mnᵂ nmᵂ
  perm-m-n = ⟨ m , n ⟩⟦◅⟧ (⟨ n , m ⟩⟦◅⟧ ⟦ø⟧)
  m-n : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (m , m∈) (n , n∈)
  m-n = here′
  n-m : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (n , n∈) (m , m∈)
  n-m = ⟦◅⟧.there (m≢n ∘ ≡.sym) m≢n {b∈b◅ n ø} {b∈b◅ m ø} here′

¬⟦𝟚⟧-1₂-0₂ : ¬(⟦𝟚⟧ 1₂ 0₂)
¬⟦𝟚⟧-1₂-0₂ ()

binder-irrelevance : ∀ (f : Binder → 𝟚)
                     → (⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f
                     → ∀ {b₁ b₂} → f b₁ ≡ f b₂
binder-irrelevance _ fᵣ = ⟦𝟚⟧-Props.to-propositional (fᵣ _)

contrab : ∀ (f : Binder → 𝟚) {b₁ b₂}
          → f b₁ ≢ f b₂
          → ¬((⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f)
contrab f = contraposition (λ fᵣ → binder-irrelevance f (λ xᵣ → fᵣ xᵣ))

module Single α₁ α₂ x₁ x₂ where
  data ℛ : Name α₁ → Name α₂ → Set where
    refl : ℛ x₁ x₂
  ℛ-pres-≡ : ∀ {x₁ x₂ y₁ y₂} → ℛ x₁ x₂ → ℛ y₁ y₂ → (x₁ ≡ y₁) ⇔ (x₂ ≡ y₂)
  ℛ-pres-≡ refl refl = equivalence (const ≡.refl) (const ≡.refl)
  αᵣ : ⟦World⟧ α₁ α₂
  αᵣ = ℛ , ℛ-pres-≡

poly-name-uniq : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α} (x : Name α) → f x ≡ f {ø ↑1} (0 , _)
poly-name-uniq f fᵣ {α} x =
  ⟦𝟚⟧-Props.to-propositional (fᵣ {α} {ø ↑1} αᵣ {x} {0 , _} refl)
  where open Single α (ø ↑1) x (0 , _)

poly-name-irrelevance : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α₁ α₂} (x₁ : Name α₁) (x₂ : Name α₂)
                        → f x₁ ≡ f x₂
poly-name-irrelevance f fᵣ x₁ x₂ =
  ≡.trans (poly-name-uniq f fᵣ x₁) (≡.sym (poly-name-uniq f fᵣ x₂))

module Broken where
  _<=ᴺ_ : ∀ {α} → Name α → Name α → 𝟚
  (m , _) <=ᴺ (n , _) = ℕ._<=_ m n

  ¬⟦<=ᴺ⟧ : ¬((∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _<=ᴺ_ _<=ᴺ_)
  ¬⟦<=ᴺ⟧ ⟦<=⟧ = ¬⟦𝟚⟧-1₂-0₂ (⟦<=⟧ perm-0-1 {0 , _} {1 , _} 0-1 {1 , _} {0 , _} 1-0)
     where open Perm 0 1 (λ()) renaming (perm-m-n to perm-0-1; m-n to 0-1; n-m to 1-0)

  ⊆-broken : ∀ α b → α ⊆ (b ◅ α)
  ⊆-broken α b = mk (λ b′ b′∈α → ≡.tr id (≡.sym (◅-sem α b′ b)) (If′ ℕ._==_ b′ b then _ else b′∈α))

  ¬⟦⊆-broken⟧ : ¬((⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ))
                  ⊆-broken ⊆-broken)
  ¬⟦⊆-broken⟧ ⟦⊆-broken⟧ = bot
     where 0↔0 : ⟦Name⟧ (⟨ 0 , 1 ⟩⟦◅⟧ ⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) (0 , _) (0 , _)
           0↔0 = un⟦⊆⟧ (⟦⊆-broken⟧ (⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) _) {0 , _} {0 , _} here′

           bot : ⊥
           bot with 0↔0
           bot | ⟦◅⟧.here _ ()
           bot | ⟦◅⟧.there 0≢0 _ _ = 0≢0 ≡.refl

{-# OPTIONS --universe-polymorphism #-}
import Level as L
open import Data.Nat.Logical
open import Data.Two hiding (_==_)
open import Data.Two.Logical
open import Data.Unit
open import Data.Empty
open import Data.Sum.NP
open import Data.Sum.Logical
open import Data.Maybe.NP
open import Data.List
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Nullary.Decidable
open import Relation.Binary.NP as Bin
open import Relation.Binary.Logical
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as ⇔ using (_⇔_; equivalence; module Equivalence)
import Relation.Binary.PropositionalEquality.NP as ≡
import Data.Nat.NP as ℕ
open ℕ renaming (_==_ to _==ℕ_)
import Data.Nat.Properties as ℕ
open import NomPa.Record using (module NomPa)
open import NomPa.Implem
import NaPa
open NaPa using (∈-uniq)
open import NomPa.Worlds
import NomPa.Derived

module NomPa.Implem.LogicalRelation.Internals where

open ≡ using (_≡_; _≢_; ⟦≡⟧)
open ≡.≡-Reasoning
open NomPa.Implem.Internals
open NomPa NomPa.Implem.nomPa using (worldSym; Nameø-elim; sucᴺ; sucᴺ↑)

-- move to record
predᴺ : ∀ {α} → Name (α +1) → Name α
predᴺ = subtractᴺ 1

≢→✓-not-==ℕ : ∀ {x y} → x ≢ y → ✓ (not (x ==ℕ y))
≢→✓-not-==ℕ ¬p = ✓-¬-not (¬p ∘ ℕ.==.sound _ _)

#⇒∉ : ∀ {α b} → b # α → b ∉ α
#⇒∉ (_ #ø)      = id
#⇒∉ (suc#∷ b#α) = #⇒∉ b#α
#⇒∉ (0# _)      = id

#⇒≢ : ∀ {α b} → b # α → (x : Name α) → binderᴺ x ≢ b
#⇒≢ b# (b , b∈) ≡.refl = #⇒∉ b# b∈

binderᴺ-injective : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y → x ≡ y
binderᴺ-injective {α} {_ , p₁} {a , p₂} eq rewrite eq = ≡.cong (_,_ a) (∈-uniq α p₁ p₂)

pf-irr′ : ∀ {α β} (ℛ : Name α → Name β → Set) {x x′ : Name α} {y y′ : Name β}
         → binderᴺ x ≡ binderᴺ x′ → binderᴺ y ≡ binderᴺ y′ → ℛ x y → ℛ x′ y′
pf-irr′ {α} {β} ℛ {x , x∈} {x′ , x′∈} {y , y∈} {y′ , y′∈} eq₁ eq₂ xᵣy
  rewrite eq₁ | eq₂ | ∈-uniq α x∈ x′∈ | ∈-uniq β y∈ y′∈ = xᵣy

pf-irr : ∀ {α β} (ℛ : Name α → Name β → Set) {x y x∈ x∈′ y∈ y∈′}
         → ℛ (x , x∈) (y , y∈) → ℛ (x , x∈′) (y , y∈′)
pf-irr ℛ = pf-irr′ ℛ ≡.refl ≡.refl

Preserve-≈ : ∀ {a b ℓ ℓa ℓb} {A : Set a} {B : Set b} → Rel A ℓa → Rel (B) ℓb → REL A (B) ℓ → Set _
Preserve-≈ _≈a_ _≈b_ _∼_ = ∀ {x₁ x₂ y₁ y₂} → x₁ ∼ x₂ → y₁ ∼ y₂ → (x₁ ≈a y₁) ⇔ (x₂ ≈b y₂)

==ℕ⇔≡ : ∀ {x y} → ✓ (x ==ℕ y) ⇔ x ≡ y
==ℕ⇔≡ {x} {y} = equivalence (ℕ.==.sound _ _) ℕ.==.reflexive

≡-on-name⇔≡ : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y ⇔ x ≡ y
≡-on-name⇔≡ {α} {x} {y} = equivalence binderᴺ-injective (≡.cong binderᴺ)

T⇔T→≡ : ∀ {b₁ b₂} → ✓ b₁ ⇔ ✓ b₂ → b₁ ≡ b₂
T⇔T→≡ {1₂} {1₂} b₁⇔b₂ = ≡.refl
T⇔T→≡ {1₂} {0₂} b₁⇔b₂ = ⊥-elim (Equivalence.to b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {1₂} b₁⇔b₂ = ⊥-elim (Equivalence.from b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {0₂} b₁⇔b₂ = ≡.refl

==ᴺ⇔≡ : ∀ {α} {x y : Name α} → ✓ (x ==ᴺ y) ⇔ x ≡ y
==ᴺ⇔≡ = ≡-on-name⇔≡ ⟨∘⟩ ==ℕ⇔≡ where open ⇔ renaming (_∘_ to _⟨∘⟩_)

-- Preserving the equalities also mean that the relation is functional and injective
Preserve-≡ : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A (B) ℓ → Set _
Preserve-≡ _∼_ = Preserve-≈ _≡_ _≡_ _∼_

exportᴺ?-nothing : ∀ {b α} (x : Name (b ◅ α)) → ✓ (binderᴺ x ==ℕ b) → exportᴺ? {b} x ≡ nothing
exportᴺ?-nothing {b} {α} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ≡.refl
... | 0₂ | _ = ⊥-elim p

exportᴺ?-just : ∀ {α b} (x : Name (b ◅ α)) {x∈} → ✓ (not (binderᴺ x ==ℕ b)) → exportᴺ? {b} x ≡ just (binderᴺ x , x∈)
exportᴺ?-just {α} {b} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ⊥-elim p
... | 0₂ | _ = ≡.cong just (binderᴺ-injective ≡.refl)

record ⟦World⟧ (α₁ α₂ : World) : Set₁ where
  constructor _,_
  field
    _∼_ : Name α₁ → Name α₂ → Set
    ∼-pres-≡ : Preserve-≡ _∼_

  ∼-inj : ∀ {x y z} → x ∼ z → y ∼ z → x ≡ y
  ∼-inj p q = Equivalence.from (∼-pres-≡ p q) ⟨$⟩ ≡.refl
  ∼-fun : ∀ {x y z} → x ∼ y → x ∼ z → y ≡ z
  ∼-fun p q = Equivalence.to (∼-pres-≡ p q) ⟨$⟩ ≡.refl

  ∼-∈-uniq : ∀ {x₁ x₂} {x₁∈′ x₂∈′} →
        x₁ ∼ x₂ ≡ (binderᴺ x₁ , x₁∈′) ∼ (binderᴺ x₂ , x₂∈′)
  ∼-∈-uniq {_ , x₁∈} {_ , x₂∈} {x₁∈′} {x₂∈′} = ≡.ap₂ (λ x₁∈ x₂∈ → (_ , x₁∈) ∼ (_ , x₂∈)) (∈-uniq α₁ x₁∈ x₁∈′) (∈-uniq α₂ x₂∈ x₂∈′)

⟦sym⟧ : ∀ {α₁ α₂} → ⟦World⟧ α₁ α₂ → ⟦World⟧ α₂ α₁
⟦sym⟧ (ℛ , ℛ-pres-≡) = ℛ-sym , ℛ-sym-pres-≡
  where ℛ-sym = flip ℛ
        ℛ-sym-pres-≡ : Preserve-≡ ℛ-sym
        ℛ-sym-pres-≡ p q = ⇔.sym (ℛ-pres-≡ p q)

record ⟦Binder⟧ (b₁ b₂ : Binder) : Set where

module ⟦◅⟧ (b₁ b₂ : Binder) {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ
  data _ℛ_ (x : Name (b₁ ◅ α₁)) (y : Name (b₂ ◅ α₂)) : Set where
    here  : (x≡b₁ : binderᴺ x ≡ b₁) (y≡b₂ : binderᴺ y ≡ b₂) → x ℛ y
    there : ∀ (x≢b₁ : binderᴺ x ≢ b₁) (y≢b₂ : binderᴺ y ≢ b₂) {x∈ y∈} (x∼y : (binderᴺ x , x∈) ∼ (binderᴺ y , y∈)) → x ℛ y

  ℛ-inj : ∀ {x y z} → x ℛ z → y ℛ z → x ≡ y
  ℛ-inj (here x≡b₁ _)    (here y≡b₁ _)     = binderᴺ-injective (≡.trans x≡b₁ (≡.sym y≡b₁))
  ℛ-inj (here _ z≡b₂)    (there _ z≢b₂ _)  = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj (there _ z≢b₂ _) (here _ z≡b₂)     = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj {x} {y} {z} (there x≢b₁ z≢b₂ {x∈} {z∈} x∼z) (there y≢b₁ _ {y∈} {z∈′} y∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-inj x∼z (≡.tr (λ z∈ → (binderᴺ y , y∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₂ z∈′ z∈) y∼z )))

  ℛ-fun : ∀ {x y z} → x ℛ y → x ℛ z → y ≡ z
  ℛ-fun (here _ y≡b₂)  (here _ z≡b₂)    = binderᴺ-injective (≡.trans y≡b₂ (≡.sym z≡b₂))
  ℛ-fun (here p _)     (there ¬p _ _)    = ⊥-elim (¬p p)
  ℛ-fun (there ¬p _ _) (here p _)        = ⊥-elim (¬p p)
  ℛ-fun {x} {y} {z} (there x≢b₁ y≢b₂ {x∈} {y∈} x∼y) (there p q {x∈′} {z∈} x∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-fun x∼y (≡.tr (λ x∈ → (binderᴺ x , x∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₁ x∈′ x∈) x∼z )))

  ℛ-pres-≡ : Preserve-≡ _ℛ_
  ℛ-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     equivalence (λ x₁=y₁ → ℛ-fun {y₁} (≡.tr (λ x₁ → x₁ ℛ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ-inj x₁∼x₂ (≡.tr (λ y₂ → y₁ ℛ y₂) (≡.sym x₂=y₂) y₁∼y₂))

  ⟦world⟧ : ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
  ⟦world⟧ = _ℛ_ , ℛ-pres-≡

here′ : ∀ {α₁ α₂ b₁ b₂ pf₁ pf₂} {αᵣ : ⟦World⟧ α₁ α₂} → ⟦◅⟧._ℛ_ b₁ b₂ αᵣ (b₁ , pf₁) (b₂ , pf₂)
here′ = ⟦◅⟧.here ≡.refl ≡.refl

_⟦◅⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦World⟧) _◅_ _◅_
_⟦◅⟧_ {b₁} {b₂} _ αᵣ = ⟦◅⟧.⟦world⟧ b₁ b₂ αᵣ

⟦Name⟧ : ⟦Pred⟧ L.zero ⟦World⟧ Name Name
⟦Name⟧ (ℛ , _) x₁ x₂ = ℛ x₁ x₂

⟦zeroᴮ⟧ : ⟦Binder⟧ zeroᴮ zeroᴮ
⟦zeroᴮ⟧ = _

⟦sucᴮ⟧ : (⟦Binder⟧ ⟦→⟧ ⟦Binder⟧) sucᴮ sucᴮ
⟦sucᴮ⟧ = _

⟦ø⟧ : ⟦World⟧ ø ø
⟦ø⟧ = (λ _ _ → ⊥) , (λ())

_⟦==ᴺ⟧_ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
_⟦==ᴺ⟧_ αᵣ xᵣ yᵣ =
   ⟦𝟚⟧-Props.reflexive (T⇔T→≡ (sym ==ᴺ⇔≡ ⟨∘⟩ ∼-pres-≡ xᵣ yᵣ ⟨∘⟩ ==ᴺ⇔≡)) where
  open ⟦World⟧ αᵣ
  open ⇔ using (sym) renaming (_∘_ to _⟨∘⟩_)

⟦nameᴮ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ)) nameᴮ nameᴮ
⟦nameᴮ⟧ _ _ = here′

⟦binderᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Binder⟧) binderᴺ binderᴺ
⟦binderᴺ⟧ _ _ = _

⟦nothing⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂}
            → x ≡ nothing → y ≡ nothing → ⟦Maybe⟧ Aᵣ x y
⟦nothing⟧′ ≡.refl ≡.refl = ⟦nothing⟧

⟦just⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂} {x′ y′}
            → x ≡ just x′ → y ≡ just y′ → Aᵣ x′ y′ → ⟦Maybe⟧ Aᵣ x y
⟦just⟧′ ≡.refl ≡.refl = ⟦just⟧

⟦exportᴺ?⟧ : (∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦→⟧ ⟦Maybe⟧ (⟦Name⟧ αᵣ)) (λ {b} → exportᴺ? {b}) (λ {b} → exportᴺ? {b})
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.here e₁ e₂)
  = ⟦nothing⟧′ (exportᴺ?-nothing x₁ (ℕ.==.reflexive e₁)) (exportᴺ?-nothing x₂ (ℕ.==.reflexive e₂))
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.there x₁≢b₁ x₂≢b₂ x₁∼x₂)
  = ⟦just⟧′ (exportᴺ?-just x₁ (≢→✓-not-==ℕ x₁≢b₁))
           (exportᴺ?-just x₂ (≢→✓-not-==ℕ x₂≢b₂)) x₁∼x₂

_⟦⊆⟧b_ : ⟦Rel⟧ ⟦World⟧ L.zero _⊆_ _⊆_
_⟦⊆⟧b_ αᵣ βᵣ x y = (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) (coerceᴺ x) (coerceᴺ y)

data _⟦⊆⟧_ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {β₁ β₂} (βᵣ : ⟦World⟧ β₁ β₂) (x : α₁ ⊆ β₁) (y : α₂ ⊆ β₂) : Set where
  mk : _⟦⊆⟧b_ αᵣ βᵣ x y → _⟦⊆⟧_ αᵣ βᵣ x y

un⟦⊆⟧ : ∀ {α₁ α₂} {αᵣ : ⟦World⟧ α₁ α₂} {β₁ β₂} {βᵣ : ⟦World⟧ β₁ β₂} {x y} → (αᵣ ⟦⊆⟧ βᵣ) x y → (αᵣ ⟦⊆⟧b βᵣ) x y
un⟦⊆⟧ (mk x) {a} {b} c = x {a} {b} c

⟦⊆-refl⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ αᵣ) ⊆-refl ⊆-refl
⟦⊆-refl⟧ _ = mk (λ xᵣ → xᵣ)

⟦⊆-trans⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ γᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                  αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (βᵣ ⟦⊆⟧ γᵣ ⟦→⟧ (αᵣ ⟦⊆⟧ γᵣ))) ⊆-trans ⊆-trans
⟦⊆-trans⟧ _ _ _ {mk f₁} {mk f₂} f {mk g₁} {mk g₂} g
  = mk (λ {x₁} {x₂} xᵣ → un⟦⊆⟧ g {coerceᴺ (mk f₁) x₁} {coerceᴺ (mk f₂) x₂} (un⟦⊆⟧ f {x₁} {x₂} xᵣ))

⟦coerceᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ)) coerceᴺ coerceᴺ
⟦coerceᴺ⟧ _ _ α⊆βᵣ {x₁} {x₂} xᵣ = un⟦⊆⟧ α⊆βᵣ {x₁} {x₂} xᵣ

⟦¬Nameø⟧ : (⟦¬⟧(⟦Name⟧ ⟦ø⟧)) ¬Nameø ¬Nameø
⟦¬Nameø⟧ ()

⟦⊆-ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦ø⟧ ⟦⊆⟧ αᵣ) ⊆-ø ⊆-ø
⟦⊆-ø⟧ αᵣ = mk λ { {_ , ()} }

_⟦#⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦Set₀⟧) _#_ _#_
_⟦#⟧_ _ _ _ _ = ⊤

_⟦#ø⟧ : (⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ ⟦ø⟧) _#ø _#ø
_⟦#ø⟧ _ = _

⟦suc#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ αᵣ ⟦→⟧ (⟦sucᴮ⟧ bᵣ) ⟦#⟧ (bᵣ ⟦◅⟧ αᵣ)) suc# suc#
⟦suc#⟧ _ _ _ = _

⟦⊆-#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                  (bᵣ ⟦#⟧ αᵣ) ⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ)) ⊆-# ⊆-#
⟦⊆-#⟧ _ {b₁} {b₂} _ {b₁#α₁} {b₂#α₂} _ = mk (λ {x₁} {x₂} → ⟦◅⟧.there (#⇒≢ b₁#α₁ x₁) (#⇒≢ b₂#α₂ x₂))

⟦⊆-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦⊆⟧ (bᵣ ⟦◅⟧ βᵣ)) ⊆-◅ ⊆-◅
⟦⊆-◅⟧ {α₁} {α₂} αᵣ {β₁} {β₂} βᵣ {b₁} {b₂} _ {α⊆β₁} {α⊆β₂} (mk f) = mk g where
  open ⟦◅⟧ b₁ b₂
  g : ∀ {x₁ x₂} → _ℛ_ αᵣ x₁ x₂ → _ℛ_ βᵣ (coerceᴺ (⊆-◅ b₁ α⊆β₁) x₁) (coerceᴺ (⊆-◅ b₂ α⊆β₂) x₂)
  g (here x≡b₁ y≡b₂)       = here x≡b₁ y≡b₂
  g (there x≢b₁ y≢b₂ x∼y) = there x≢b₁ y≢b₂ (f x∼y)

congℕ : ∀ {α β : World} {x y : Name α} (f : ℕ → ℕ) {fx∈ fy∈} → x ≡ y → _≡_ {A = Name β} (f (binderᴺ x) , fx∈) (f (binderᴺ y) , fy∈)
congℕ f = binderᴺ-injective ∘ ≡.cong (f ∘ binderᴺ)

module ⟦+1⟧ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ renaming (_∼_ to ℛ; ∼-inj to ℛ-inj; ∼-fun to ℛ-fun)
  ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set
  ℛ+1 x y = ⟦Name⟧ αᵣ (predᴺ x) (predᴺ y)
{-
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x x∈ y y∈} → ⟦Name⟧ αᵣ x y → ℛ+1 (suc x , ) (sucN y)
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x y} → ⟦Name⟧ αᵣ x y → ℛ+1 (sucN x) (sucN y)
-}

  ℛ+1-inj : ∀ {x y z} → ℛ+1 x z →  ℛ+1 y z → x ≡ y
  -- ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} (suc a) (suc b) = {!!}
  ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-inj a b)
  ℛ+1-inj {zero , ()} _ _
  ℛ+1-inj {_} {zero , ()} _ _
  ℛ+1-inj {_} {_} {zero , ()} _ _
  ℛ+1-fun : ∀ {x y z} → ℛ+1 x y →  ℛ+1 x z → y ≡ z
  ℛ+1-fun {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-fun a b)
  ℛ+1-fun {zero , ()} _ _
  ℛ+1-fun {_} {zero , ()} _ _
  ℛ+1-fun {_} {_} {zero , ()} _ _

  ℛ+1-pres-≡ : Preserve-≡ ℛ+1
  -- ℛ+1-pres-≡ x y = equivalence {!ℛ+1-inj!} {!!}
  ℛ+1-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     -- factor this move
     equivalence (λ x₁=y₁ → ℛ+1-fun {y₁} (≡.tr (λ x₁ → ℛ+1 x₁ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ+1-inj {x₁} {y₁} {x₂} x₁∼x₂ (≡.tr (λ y₂ → ℛ+1 y₁ y₂) (≡.sym x₂=y₂) y₁∼y₂))

_⟦+1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _+1 _+1
_⟦+1⟧ αᵣ = ℛ+1 , ℛ+1-pres-≡ where open ⟦+1⟧ αᵣ

open WorldOps worldSym

_⟦↑1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _↑1 _↑1
_⟦↑1⟧ αᵣ = ⟦zeroᴮ⟧ ⟦◅⟧ (αᵣ ⟦+1⟧)

_⟦↑⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _↑_ _↑_
_⟦↑⟧_ αᵣ zero    = αᵣ
_⟦↑⟧_ αᵣ (suc k) = (αᵣ ⟦↑⟧ k) ⟦↑1⟧

_⟦+ᵂ⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _+ᵂ_ _+ᵂ_
_⟦+ᵂ⟧_ αᵣ zero    = αᵣ
_⟦+ᵂ⟧_ αᵣ (suc k) = (αᵣ ⟦+ᵂ⟧ k) ⟦+1⟧

⟦predᴺ⟧-sucᴺ↑ : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂)
                 {x₁ x₂} (xᵣ : ⟦Name⟧ (αᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ αᵣ x₁ x₂
⟦predᴺ⟧-sucᴺ↑ _  (⟦◅⟧.here () _)
⟦predᴺ⟧-sucᴺ↑ αᵣ (⟦◅⟧.there _ _ x∼y) = pf-irr (⟦Name⟧ αᵣ) x∼y

⟦ø+1⊆ø⟧ : (⟦ø⟧ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧) ø+1⊆ø ø+1⊆ø
⟦ø+1⊆ø⟧ = mk (λ {x} _ → Nameø-elim (predᴺ x))

⟦⊆-cong-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧)) ⊆-cong-+1 ⊆-cong-+1
⟦⊆-cong-+1⟧ _ βᵣ α⊆βᵣ = mk (pf-irr (⟦Name⟧ βᵣ) ∘ un⟦⊆⟧ α⊆βᵣ)

⟦⊆-cong-↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-cong-↑1 ⊆-cong-↑1
⟦⊆-cong-↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk helper where
  open ⟦◅⟧ 0 0
  helper : (⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-cong-↑1 α⊆β₁)) (coerceᴺ (⊆-cong-↑1 α⊆β₂))
  helper (here x≡b₁ y≡b₂) = here x≡b₁ y≡b₂
  helper {x₁ , _} {x₂ , _} (there x≢b₁ y≢b₂ {p₁} {p₂} x∼y)
     = there x≢b₁ y≢b₂ {coe (⊆-cong-+1 α⊆β₁) x₁ p₁}
                        {coe (⊆-cong-+1 α⊆β₂) x₂ p₂}
                        (pf-irr (⟦Name⟧ βᵣ) (un⟦⊆⟧ α⊆βᵣ x∼y))

⟦⊆-+1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-+1-inj ⊆-+1-inj
⟦⊆-+1-inj⟧ _ _ α+⊆β+ᵣ = mk (λ {x₁} {x₂} → un⟦⊆⟧ α+⊆β+ᵣ {addᴺ 1 x₁} {addᴺ 1 x₂})

≢0 : ∀ {α} (x : Name (α +1)) → binderᴺ x ≢ 0
≢0 (0 , ()) ≡.refl
≢0 (suc _ , _) ()

⟦⊆-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (αᵣ ⟦↑1⟧)) ⊆-+1↑1 ⊆-+1↑1
⟦⊆-+1↑1⟧ αᵣ = mk (λ {x₁} {x₂} → there (≢0 x₁) (≢0 x₂)) where open ⟦◅⟧ 0 0

⟦⊆-↑1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-↑1-inj ⊆-↑1-inj
⟦⊆-↑1-inj⟧ _ βᵣ α↑⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → ⟦predᴺ⟧-sucᴺ↑ βᵣ (un⟦⊆⟧ α↑⊆β↑ᵣ {sucᴺ↑ x₁} {sucᴺ↑ x₂} (there (λ()) (λ()) xᵣ))) where
  open ⟦◅⟧ 0 0

⟦⊆-unctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-unctx-+1↑1 ⊆-unctx-+1↑1
⟦⊆-unctx-+1↑1⟧ _ βᵣ α+⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → helper (un⟦⊆⟧ α+⊆β↑ᵣ {sucᴺ x₁} {sucᴺ x₂} xᵣ)) where
  open ⟦◅⟧ 0 0
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (βᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ βᵣ x₁ x₂
  helper (here () _)
  helper (there _ _ x∼y) = pf-irr (⟦Name⟧ βᵣ) x∼y

⟦sucᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧)) sucᴺ sucᴺ
⟦sucᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦predᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ αᵣ) predᴺ predᴺ
⟦predᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦sucᴺ↑⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) sucᴺ↑ sucᴺ↑
⟦sucᴺ↑⟧ αᵣ xᵣ = ⟦coerceᴺ⟧ _ _ (⟦⊆-+1↑1⟧ αᵣ) (⟦sucᴺ⟧ αᵣ xᵣ)

⟦addᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) addᴺ addᴺ
⟦addᴺ⟧ _  zero xᵣ = xᵣ
⟦addᴺ⟧ αᵣ (suc kᵣ) xᵣ = pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (⟦addᴺ⟧ αᵣ kᵣ xᵣ)

⟦subtractᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) ⟦→⟧ ⟦Name⟧ αᵣ) subtractᴺ subtractᴺ
⟦subtractᴺ⟧ _ zero x = x
⟦subtractᴺ⟧ αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} xᵣ
   = pf-irr′ (⟦Name⟧ αᵣ) (ℕ.∸-+-assoc (binderᴺ x₁) 1 k₁) (ℕ.∸-+-assoc (binderᴺ x₂) 1 k₂) (⟦subtractᴺ⟧ αᵣ kᵣ xᵣ)

¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {pf₁ : 0 ∈ α₁ ↑1} {n} {pf₂ : suc n ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (0 , pf₁) (suc n , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.there p _ _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.here _ ())

¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {n} {pf₁ : suc n ∈ α₁ ↑1} {pf₂ : 0 ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (suc n , pf₁) (0 , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.there _ p _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.here () _)

-- cmpᴺ-bool : ∀ {α} ℓ → Name (α ↑ ℓ) → 𝟚
-- cmpᴺ-bool ℓ x = suc (binderᴺ x) <= ℓ

⟦cmpᴺ-bool⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦𝟚⟧) NaPa.cmpᴺ-bool NaPa.cmpᴺ-bool
⟦cmpᴺ-bool⟧ _ zero _ = ⟦0₂⟧
⟦cmpᴺ-bool⟧ _ (suc _) {zero , _} {zero , _} _ = ⟦1₂⟧
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦cmpᴺ-bool⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦easy-cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
             ) NaPa.easy-cmpᴺ NaPa.easy-cmpᴺ
⟦easy-cmpᴺ⟧ _ zero xᵣ = ⟦inr⟧ xᵣ
⟦easy-cmpᴺ⟧ _ (suc _) {zero , _} {zero , _} xᵣ = ⟦inl⟧ here′
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦map⟧ _ _ _ _ (⟦sucᴺ↑⟧ (⟦ø⟧ ⟦↑⟧ kᵣ)) (pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) (⟦easy-cmpᴺ⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ))
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
         ) cmpᴺ cmpᴺ
⟦cmpᴺ⟧ {α₁} {α₂} αᵣ {k₁} {k₂} kᵣ {x₁} {x₂} xᵣ =
   ≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (cmpᴺ {α₁} k₁ x₁) x)
           (NaPa.easy-cmpᴺ≗cmpᴺ {α₂} k₂ x₂)
           (≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) x
                    (NaPa.easy-cmpᴺ {α₂} k₂ x₂))
                    (NaPa.easy-cmpᴺ≗cmpᴺ {α₁} k₁ x₁) (⟦easy-cmpᴺ⟧ αᵣ kᵣ {x₁} {x₂} xᵣ))

⟦⊆-dist-+1-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) ⟦⊆⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))))
                 ⊆-dist-+1-◅ ⊆-dist-+1-◅
⟦⊆-dist-+1-◅⟧ αᵣ {b₁} {b₂} bᵣ = mk (λ {η₁} {η₂} η₃ → helper {η₁} {η₂} η₃) where
  -- open ⟦◅⟧ b₁ b₂

  hper :   ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (sucᴺ x₁) (sucᴺ x₂)
  hper (⟦◅⟧.here x≡b₁ y≡b₂) = ⟦◅⟧.here (≡.cong suc x≡b₁) (≡.cong suc y≡b₂)
  hper (⟦◅⟧.there x≢b₁ y≢b₂ x∼y) = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong pred) (y≢b₂ ∘ ≡.cong pred) x∼y

  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (coerceᴺ (⊆-dist-+1-◅ b₁) x₁)
                     (coerceᴺ (⊆-dist-+1-◅ b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ = hper xᵣ
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

⟦⊆-dist-◅-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) ⟦⊆⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)))
                 ⊆-dist-◅-+1 ⊆-dist-◅-+1
⟦⊆-dist-◅-+1⟧ αᵣ {b₁} {b₂} bᵣ = mk helper where
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) x₁ x₂)
           → ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)
                     (coerceᴺ (⊆-dist-◅-+1 b₁) x₁)
                     (coerceᴺ (⊆-dist-◅-+1 b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ with xᵣ
  ... | ⟦◅⟧.here x≡b₁ y≡b₂ = ⟦◅⟧.here (≡.cong (λ x → x ∸ 1) x≡b₁) (≡.cong (λ x → x ∸ 1) y≡b₂)
  ... | ⟦◅⟧.there x≢b₁ y≢b₂ x∼y = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong suc) (y≢b₂ ∘ ≡.cong suc) x∼y
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

{-
Binder≡ℕ : Binder ≡ ℕ
Binder≡ℕ = ≡.refl

postulate
  ⟦Binder⟧≢⟦ℕ⟧ : ⟦Binder⟧ ≢ ⟦ℕ⟧

⟦≡⟧-lem : ∀ {a₁ a₂ aᵣ A₁ A₂} {Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂} {x₁ x₂} {xᵣ : Aᵣ x₁ x₂} {y₁ y₂} {yᵣ : Aᵣ y₁ y₂} {pf₁ pf₂} → ⟦≡⟧ Aᵣ xᵣ yᵣ pf₁ pf₂ → ∀ (P : ∀ {z₁ z₂} → Aᵣ z₁ z₂ → Set) → P xᵣ → P yᵣ
⟦≡⟧-lem = {!!}

¬⟦Binder≡ℕ⟧ : ¬((⟦≡⟧ ⟦Set₀⟧ ⟦Binder⟧ ⟦ℕ⟧) Binder≡ℕ Binder≡ℕ)
¬⟦Binder≡ℕ⟧ = λ pf → ⟦≡⟧-lem pf (λ x → ⊥) {!!}
-}

⟦binderᴺ∘nameᴮ⟧ : (⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                   ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                    ⟦≡⟧ ⟦Binder⟧ (⟦binderᴺ⟧ (bᵣ ⟦◅⟧ αᵣ) (⟦nameᴮ⟧ αᵣ bᵣ)) bᵣ) binderᴺ∘nameᴮ binderᴺ∘nameᴮ
⟦binderᴺ∘nameᴮ⟧ αᵣ bᵣ = ≡.⟦refl⟧

⟨_,_⟩⟦◅⟧_ : (b₁ b₂ : Binder) → ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) → ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
⟨ b₁ , b₂ ⟩⟦◅⟧ αᵣ = _⟦◅⟧_ {b₁} {b₂} _ αᵣ

module Perm (m n : ℕ) (m≢n : m ≢ n) where
  mnᵂ : World
  mnᵂ = m ◅ n ◅ ø
  nmᵂ : World
  nmᵂ = n ◅ m ◅ ø
  perm-m-n : ⟦World⟧ mnᵂ nmᵂ
  perm-m-n = ⟨ m , n ⟩⟦◅⟧ (⟨ n , m ⟩⟦◅⟧ ⟦ø⟧)
  m-n : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (m , m∈) (n , n∈)
  m-n = here′
  n-m : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (n , n∈) (m , m∈)
  n-m = ⟦◅⟧.there (m≢n ∘ ≡.sym) m≢n {b∈b◅ n ø} {b∈b◅ m ø} here′

¬⟦𝟚⟧-1₂-0₂ : ¬(⟦𝟚⟧ 1₂ 0₂)
¬⟦𝟚⟧-1₂-0₂ ()

binder-irrelevance : ∀ (f : Binder → 𝟚)
                     → (⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f
                     → ∀ {b₁ b₂} → f b₁ ≡ f b₂
binder-irrelevance _ fᵣ = ⟦𝟚⟧-Props.to-propositional (fᵣ _)

contrab : ∀ (f : Binder → 𝟚) {b₁ b₂}
          → f b₁ ≢ f b₂
          → ¬((⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f)
contrab f = contraposition (λ fᵣ → binder-irrelevance f (λ xᵣ → fᵣ xᵣ))

module Single α₁ α₂ x₁ x₂ where
  data ℛ : Name α₁ → Name α₂ → Set where
    refl : ℛ x₁ x₂
  ℛ-pres-≡ : ∀ {x₁ x₂ y₁ y₂} → ℛ x₁ x₂ → ℛ y₁ y₂ → (x₁ ≡ y₁) ⇔ (x₂ ≡ y₂)
  ℛ-pres-≡ refl refl = equivalence (const ≡.refl) (const ≡.refl)
  αᵣ : ⟦World⟧ α₁ α₂
  αᵣ = ℛ , ℛ-pres-≡

poly-name-uniq : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α} (x : Name α) → f x ≡ f {ø ↑1} (0 , _)
poly-name-uniq f fᵣ {α} x =
  ⟦𝟚⟧-Props.to-propositional (fᵣ {α} {ø ↑1} αᵣ {x} {0 , _} refl)
  where open Single α (ø ↑1) x (0 , _)

poly-name-irrelevance : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α₁ α₂} (x₁ : Name α₁) (x₂ : Name α₂)
                        → f x₁ ≡ f x₂
poly-name-irrelevance f fᵣ x₁ x₂ =
  ≡.trans (poly-name-uniq f fᵣ x₁) (≡.sym (poly-name-uniq f fᵣ x₂))

module Broken where
  _<=ᴺ_ : ∀ {α} → Name α → Name α → 𝟚
  (m , _) <=ᴺ (n , _) = ℕ._<=_ m n

  ¬⟦<=ᴺ⟧ : ¬((∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _<=ᴺ_ _<=ᴺ_)
  ¬⟦<=ᴺ⟧ ⟦<=⟧ = ¬⟦𝟚⟧-1₂-0₂ (⟦<=⟧ perm-0-1 {0 , _} {1 , _} 0-1 {1 , _} {0 , _} 1-0)
     where open Perm 0 1 (λ()) renaming (perm-m-n to perm-0-1; m-n to 0-1; n-m to 1-0)

  ⊆-broken : ∀ α b → α ⊆ (b ◅ α)
  ⊆-broken α b = mk (λ b′ b′∈α → ≡.tr id (≡.sym (◅-sem α b′ b)) (If′ ℕ._==_ b′ b then _ else b′∈α))

  ¬⟦⊆-broken⟧ : ¬((⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ))
                  ⊆-broken ⊆-broken)
  ¬⟦⊆-broken⟧ ⟦⊆-broken⟧ = bot
     where 0↔0 : ⟦Name⟧ (⟨ 0 , 1 ⟩⟦◅⟧ ⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) (0 , _) (0 , _)
           0↔0 = un⟦⊆⟧ (⟦⊆-broken⟧ (⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) _) {0 , _} {0 , _} here′

           bot : ⊥
           bot with 0↔0
           bot | ⟦◅⟧.here _ ()
           bot | ⟦◅⟧.there 0≢0 _ _ = 0≢0 ≡.refl


Function: +lift-op₂

Function: +lift-op₂

{-# OPTIONS --without-K #-}
module Function.NP where

open import Level
  using (_⊔_; Lift; lift; lower)
open import Type
  hiding (★)
open import Algebra
  using (module Monoid; Monoid)
open import Algebra.Structures
  using (IsSemigroup)
open import Data.Nat.Base
  using (ℕ; zero; suc)
open import Data.Bool.Base
  renaming (Bool to 𝟚)
open import Data.Product
  using (_×_; Σ; _,_)
open import Data.Vec.N-ary
  using (N-ary; N-ary-level)
open import Category.Monad
  using () renaming (module RawMonad to Monad; RawMonad to Monad)
open import Category.Monad.Identity
  using (IdentityMonad)
open import Category.Applicative
  renaming (module RawApplicative to Applicative;
            RawApplicative to Applicative)
open import Relation.Binary
  using (IsEquivalence; module IsEquivalence; _Preserves₂_⟶_⟶_;
         module Setoid)
open import Relation.Binary.PropositionalEquality.NP
  using (_≡_; _≗_; refl; ap; ap₂; module ≡-Reasoning; _→-setoid_; _∙_)
  renaming (isEquivalence to ≡-isEquivalence)

open import Function public

id-app : ∀ {f} → Applicative {f} id
id-app = Monad.rawIApplicative IdentityMonad

-→- : ∀ {a b} (A : ★ a) (B : ★ b) → ★ (a ⊔ b)
-→- A B = A → B

_→⟨_⟩_ : ∀ {a b} (A : ★ a) (n : ℕ) (B : ★ b) → ★ (N-ary-level a b n)
A →⟨ n ⟩ B = N-ary n A B

_→⟨_⟩₀_ : ∀ (A : ★₀) (n : ℕ) (B : ★₀) → ★₀
A →⟨ zero  ⟩₀ B = B
A →⟨ suc n ⟩₀ B = A → A →⟨ n ⟩₀ B

_→⟨_⟩₁_ : ∀ (A : ★₀) (n : ℕ) (B : ★₁) → ★₁
A →⟨ zero  ⟩₁ B = B
A →⟨ suc n ⟩₁ B = A → A →⟨ n ⟩₁ B

_↔_ : ∀ {a b} (A : ★ a) (B : ★ b) → ★ (a ⊔ b)
A ↔ B = (A → B) × (B → A)

Endo : ∀ {a} → ★ a → ★ a
Endo A = A → A

Cmp : ∀ {a} → ★ a → ★ a
Cmp A = A → A → 𝟚

Op₁ : ∀ {a} → ★ a → ★ a
Op₁ A = A → A

Op₂ : ∀ {a} → ★ a → ★ a
Op₂ A = A → A → A

lift-op₂ : ∀ {a}{A : ★_ a}(op : Op₂ A){ℓ} → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A
lift-op₂ op x y = lift (op (lower x) (lower y))

-- More properties about nest/fold are in Data.Nat.NP
nest : ∀ {a} {A : ★ a} → ℕ → Endo (Endo A)
-- TMP nest n f x = fold x f n
nest zero    f x = x
nest (suc n) f x = f (nest n f x)

_$⟨_⟩_ : ∀ {a} {A : ★ a} → Endo A → ℕ → Endo A
_$⟨_⟩_ f n = nest n f

-- If you run a version of Agda without the support of instance
-- arguments, simply comment this definition, very little code rely on it.
it : ∀ {a} {A : ★ a} ⦃ x : A ⦄ → A
it ⦃ x ⦄ = x

_⟨_⟩°_ : ∀ {i a b c} {Ix : ★ i} {A : ★ a} {B : A → ★ b} {C : (x : A) → B x → ★ c}
         → (f  : Ix → A)
         → (op : (x : A) (y : B x) → C x y)
         → (g  : (i : Ix) → B (f i))
         → (i : Ix) → C (f i) (g i)
(f ⟨ _∙_ ⟩° g) x = f x ∙ g x

module Combinators where
    S : ∀ {A B C : ★₀} →
          (A → B → C) →
          (A → B) →
          (A → C)
    S = _ˢ_

    K : ∀ {A B : ★₀} → A → B → A
    K = const

    -- B ≗ _∘_
    B : ∀ {A B C : ★₀} → (B → C) → (A → B) → A → C
    B = S (K S) K

    -- C ≗ flip
    C : ∀ {A B C : ★₀} → (A → B → C) → B → A → C
    C = S (S (K (S (K S) K)) S) (K K)

module EndoMonoid-≈ {a ℓ} {A : ★ a}
                    {_≈_ : Endo A → Endo A → ★ ℓ}
                    (isEquivalence : IsEquivalence _≈_)
                    (∘-cong : _∘′_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
                   where
  private
    module ≈ = IsEquivalence isEquivalence
    isSemigroup : IsSemigroup _≈_ _∘′_
    isSemigroup = record { isEquivalence = isEquivalence; assoc = λ _ _ _ → ≈.refl; ∙-cong = ∘-cong }

  monoid : Monoid a ℓ
  monoid = record { Carrier = Endo A; _≈_ = _≈_; _∙_ = _∘′_; ε = id
                  ; isMonoid = record { isSemigroup = isSemigroup
                                      ; identity = (λ _ → ≈.refl) , (λ _ → ≈.refl) } }

  open Monoid monoid public

module EndoMonoid-≡ {a} (A : ★ a) = EndoMonoid-≈ {A = A} ≡-isEquivalence (ap₂ _∘′_)

module EndoMonoid-≗ {a} (A : ★ a) = EndoMonoid-≈ (Setoid.isEquivalence (A →-setoid A))
                                                   (λ {f} {g} {h} {i} p q x → p (h x) ∙ ap g (q x))

Π : ∀ {a b} (A : ★ a) → (B : A → ★ b) → ★ _
Π A B = (x : A) → B x

Πⁱ : ∀ {a b} (A : ★ a) → (B : A → ★ b) → ★ _
Πⁱ A B = {x : A} → B x

module FromΠ (Π : ∀ {a b}(A : ★ a)(B : A → ★ b) → ★(a ⊔ b)) where

  module _ {a b}{A : ★ a}(B : A → ★ b) where
    ∀₁ : ★(a ⊔ b)
    ∀₁ = Π A B

  module _ {a b c}{A : ★ a}{B : A → ★ b}(C : (x : A)(y : B x) → ★ c) where
    ∀₂ : ★(a ⊔ b ⊔ c)
    ∀₂ = Π A λ x → Π (B x) (C _)

  module _ {a b c d}{A : ★ a}{B : A → ★ b}{C : {x : A}(y : B x) → ★ c}
           (D : (x : A)(y : B x)(z : C y) → ★ d) where
    ∀₃ : ★(a ⊔ b ⊔ c ⊔ d)
    ∀₃ = Π A λ x → Π (B x) λ y → Π (C y) (D _ _)

  module _ {a b c d e}{A : ★ a}{B : A → ★ b}{C : {x : A}(y : B x) → ★ c}
           {D : {x : A}{y : B x}(z : C y) → ★ d}
           (E : (x : A)(y : B x)(z : C y)(t : D z) → ★ e)
           where
    ∀₄ : ★(a ⊔ b ⊔ c ⊔ d ⊔ e)
    ∀₄ = Π A λ x → Π (B x) λ y → Π (C y) λ z → Π (D z) (E _ _ _)

module FromΣ (Σ : ∀ {a b}(A : ★ a)(B : A → ★ b) → ★(a ⊔ b)) =
  FromΠ Σ renaming (∀₁ to ∃₁; ∀₂ to ∃₂; ∀₃ to ∃₃; ∀₄ to ∃₄)

module FromΠΣ (Π Σ : ∀ {a b}(A : ★ a)(B : A → ★ b) → ★(a ⊔ b))
              (_,_ : ∀ {a b}{A : ★ a}{B : A → ★ b}(x : A)(y : B x) → Σ A B) where
  module _ {a b c}(A : ★ a)(B : A → ★ b)(C : Σ A B → ★ c) where
    ΠΠ ΠΣ ΣΠ : ★ _
    ΠΠ = Π A λ x → Π (B x) λ y → C (x , y)
    ΠΣ = Π A λ x → Σ (B x) λ y → C (x , y)
    ΣΠ = Σ A λ x → Π (B x) λ y → C (x , y)
    ΣΣ = Σ A λ x → Σ (B x) λ y → C (x , y)

  module _ {a b c d}(A : ★ a)(B : A → ★ b)(C : Σ A B → ★ c)
           (D : Σ (Σ A B) C → ★ d) where
    ΠΠΠ ΠΣΠ ΠΣΣ ΣΠΣ ΣΠΠ : ★ _
    ΠΠΠ = Π A λ x → Π (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)
    ΠΣΠ = Π A λ x → Σ (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)
    ΠΣΣ = Π A λ x → Σ (B x) λ y → Σ (C (x , y)) λ z → D ((x , y) , z)
    ΣΠΣ = Σ A λ x → Π (B x) λ y → Σ (C (x , y)) λ z → D ((x , y) , z)
    ΣΠΠ = Σ A λ x → Π (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)

module Implicits where
  open FromΠ  Πⁱ       public
  open FromΠΣ Πⁱ Σ _,_ public

module Explicits where
  open FromΠ  Π       public
  open FromΣ  Σ       public
  open FromΠΣ Π Σ _,_ public
-- -}

{-# OPTIONS --without-K #-}
module Function.NP where

open import Level
  using (_⊔_)
open import Type
  hiding (★)
open import Algebra
  using (module Monoid; Monoid)
open import Algebra.Structures
  using (IsSemigroup)
open import Data.Nat.Base
  using (ℕ; zero; suc)
open import Data.Bool.Base
  renaming (Bool to 𝟚)
open import Data.Product
  using (_×_; Σ; _,_)
open import Data.Vec.N-ary
  using (N-ary; N-ary-level)
open import Category.Monad
  using () renaming (module RawMonad to Monad; RawMonad to Monad)
open import Category.Monad.Identity
  using (IdentityMonad)
open import Category.Applicative
  renaming (module RawApplicative to Applicative;
            RawApplicative to Applicative)
open import Relation.Binary
  using (IsEquivalence; module IsEquivalence; _Preserves₂_⟶_⟶_;
         module Setoid)
open import Relation.Binary.PropositionalEquality.NP
  using (_≡_; _≗_; refl; ap; ap₂; module ≡-Reasoning; _→-setoid_; _∙_)
  renaming (isEquivalence to ≡-isEquivalence)

open import Function public

id-app : ∀ {f} → Applicative {f} id
id-app = Monad.rawIApplicative IdentityMonad

-→- : ∀ {a b} (A : ★ a) (B : ★ b) → ★ (a ⊔ b)
-→- A B = A → B

_→⟨_⟩_ : ∀ {a b} (A : ★ a) (n : ℕ) (B : ★ b) → ★ (N-ary-level a b n)
A →⟨ n ⟩ B = N-ary n A B

_→⟨_⟩₀_ : ∀ (A : ★₀) (n : ℕ) (B : ★₀) → ★₀
A →⟨ zero  ⟩₀ B = B
A →⟨ suc n ⟩₀ B = A → A →⟨ n ⟩₀ B

_→⟨_⟩₁_ : ∀ (A : ★₀) (n : ℕ) (B : ★₁) → ★₁
A →⟨ zero  ⟩₁ B = B
A →⟨ suc n ⟩₁ B = A → A →⟨ n ⟩₁ B

_↔_ : ∀ {a b} (A : ★ a) (B : ★ b) → ★ (a ⊔ b)
A ↔ B = (A → B) × (B → A)

Endo : ∀ {a} → ★ a → ★ a
Endo A = A → A

Cmp : ∀ {a} → ★ a → ★ a
Cmp A = A → A → 𝟚

Op₁ : ∀ {a} → ★ a → ★ a
Op₁ A = A → A

Op₂ : ∀ {a} → ★ a → ★ a
Op₂ A = A → A → A

-- More properties about nest/fold are in Data.Nat.NP
nest : ∀ {a} {A : ★ a} → ℕ → Endo (Endo A)
-- TMP nest n f x = fold x f n
nest zero    f x = x
nest (suc n) f x = f (nest n f x)

_$⟨_⟩_ : ∀ {a} {A : ★ a} → Endo A → ℕ → Endo A
_$⟨_⟩_ f n = nest n f

-- If you run a version of Agda without the support of instance
-- arguments, simply comment this definition, very little code rely on it.
it : ∀ {a} {A : ★ a} ⦃ x : A ⦄ → A
it ⦃ x ⦄ = x

_⟨_⟩°_ : ∀ {i a b c} {Ix : ★ i} {A : ★ a} {B : A → ★ b} {C : (x : A) → B x → ★ c}
         → (f  : Ix → A)
         → (op : (x : A) (y : B x) → C x y)
         → (g  : (i : Ix) → B (f i))
         → (i : Ix) → C (f i) (g i)
(f ⟨ _∙_ ⟩° g) x = f x ∙ g x

module Combinators where
    S : ∀ {A B C : ★₀} →
          (A → B → C) →
          (A → B) →
          (A → C)
    S = _ˢ_

    K : ∀ {A B : ★₀} → A → B → A
    K = const

    -- B ≗ _∘_
    B : ∀ {A B C : ★₀} → (B → C) → (A → B) → A → C
    B = S (K S) K

    -- C ≗ flip
    C : ∀ {A B C : ★₀} → (A → B → C) → B → A → C
    C = S (S (K (S (K S) K)) S) (K K)

module EndoMonoid-≈ {a ℓ} {A : ★ a}
                    {_≈_ : Endo A → Endo A → ★ ℓ}
                    (isEquivalence : IsEquivalence _≈_)
                    (∘-cong : _∘′_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
                   where
  private
    module ≈ = IsEquivalence isEquivalence
    isSemigroup : IsSemigroup _≈_ _∘′_
    isSemigroup = record { isEquivalence = isEquivalence; assoc = λ _ _ _ → ≈.refl; ∙-cong = ∘-cong }

  monoid : Monoid a ℓ
  monoid = record { Carrier = Endo A; _≈_ = _≈_; _∙_ = _∘′_; ε = id
                  ; isMonoid = record { isSemigroup = isSemigroup
                                      ; identity = (λ _ → ≈.refl) , (λ _ → ≈.refl) } }

  open Monoid monoid public

module EndoMonoid-≡ {a} (A : ★ a) = EndoMonoid-≈ {A = A} ≡-isEquivalence (ap₂ _∘′_)

module EndoMonoid-≗ {a} (A : ★ a) = EndoMonoid-≈ (Setoid.isEquivalence (A →-setoid A))
                                                   (λ {f} {g} {h} {i} p q x → p (h x) ∙ ap g (q x))

Π : ∀ {a b} (A : ★ a) → (B : A → ★ b) → ★ _
Π A B = (x : A) → B x

Πⁱ : ∀ {a b} (A : ★ a) → (B : A → ★ b) → ★ _
Πⁱ A B = {x : A} → B x

module FromΠ (Π : ∀ {a b}(A : ★ a)(B : A → ★ b) → ★(a ⊔ b)) where

  module _ {a b}{A : ★ a}(B : A → ★ b) where
    ∀₁ : ★(a ⊔ b)
    ∀₁ = Π A B

  module _ {a b c}{A : ★ a}{B : A → ★ b}(C : (x : A)(y : B x) → ★ c) where
    ∀₂ : ★(a ⊔ b ⊔ c)
    ∀₂ = Π A λ x → Π (B x) (C _)

  module _ {a b c d}{A : ★ a}{B : A → ★ b}{C : {x : A}(y : B x) → ★ c}
           (D : (x : A)(y : B x)(z : C y) → ★ d) where
    ∀₃ : ★(a ⊔ b ⊔ c ⊔ d)
    ∀₃ = Π A λ x → Π (B x) λ y → Π (C y) (D _ _)

  module _ {a b c d e}{A : ★ a}{B : A → ★ b}{C : {x : A}(y : B x) → ★ c}
           {D : {x : A}{y : B x}(z : C y) → ★ d}
           (E : (x : A)(y : B x)(z : C y)(t : D z) → ★ e)
           where
    ∀₄ : ★(a ⊔ b ⊔ c ⊔ d ⊔ e)
    ∀₄ = Π A λ x → Π (B x) λ y → Π (C y) λ z → Π (D z) (E _ _ _)

module FromΣ (Σ : ∀ {a b}(A : ★ a)(B : A → ★ b) → ★(a ⊔ b)) =
  FromΠ Σ renaming (∀₁ to ∃₁; ∀₂ to ∃₂; ∀₃ to ∃₃; ∀₄ to ∃₄)

module FromΠΣ (Π Σ : ∀ {a b}(A : ★ a)(B : A → ★ b) → ★(a ⊔ b))
              (_,_ : ∀ {a b}{A : ★ a}{B : A → ★ b}(x : A)(y : B x) → Σ A B) where
  module _ {a b c}(A : ★ a)(B : A → ★ b)(C : Σ A B → ★ c) where
    ΠΠ ΠΣ ΣΠ : ★ _
    ΠΠ = Π A λ x → Π (B x) λ y → C (x , y)
    ΠΣ = Π A λ x → Σ (B x) λ y → C (x , y)
    ΣΠ = Σ A λ x → Π (B x) λ y → C (x , y)
    ΣΣ = Σ A λ x → Σ (B x) λ y → C (x , y)

  module _ {a b c d}(A : ★ a)(B : A → ★ b)(C : Σ A B → ★ c)
           (D : Σ (Σ A B) C → ★ d) where
    ΠΠΠ ΠΣΠ ΠΣΣ ΣΠΣ ΣΠΠ : ★ _
    ΠΠΠ = Π A λ x → Π (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)
    ΠΣΠ = Π A λ x → Σ (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)
    ΠΣΣ = Π A λ x → Σ (B x) λ y → Σ (C (x , y)) λ z → D ((x , y) , z)
    ΣΠΣ = Σ A λ x → Π (B x) λ y → Σ (C (x , y)) λ z → D ((x , y) , z)
    ΣΠΠ = Σ A λ x → Π (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)

module Implicits where
  open FromΠ  Πⁱ       public
  open FromΠΣ Πⁱ Σ _,_ public

module Explicits where
  open FromΠ  Π       public
  open FromΣ  Σ       public
  open FromΠΣ Π Σ _,_ public
-- -}


Implement booleans.

Implement booleans.

This was harder than I expected. I had to adapt some of the
older proofs. Apparently I used the fact that Type had only
one constructor somehow.

Missing features:

 - deriveTerm (if ...)
 - congruence of equivalence relation (ok, ok, it isn't easy).

Old-commit-hash: 8b6ea9150951d6c6e3c0cf05d2a788f4a59c9deb

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import meaning

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type
  bool : Type

infixr 5 _⇒_

-- Denotational Semantics

data Bool : Set where
  true false : Bool

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type
⟦ bool ⟧Type = Bool

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- Value Equivalence

data _≡_ : ∀ {τ} → (v₁ v₂ : ⟦ τ ⟧) → Set where
  ext : ∀ {τ₁ τ₂} {f₁ f₂ : ⟦ τ₁ ⇒ τ₂ ⟧} →
    (∀ v → f₁ v ≡ f₂ v) →
    f₁ ≡ f₂
  bool : ∀ {b : Bool} →
    b ≡ b

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl {τ₁ ⇒ τ₂} = ext (λ v → ≡-refl)
≡-refl {bool} = bool

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym {τ₁ ⇒ τ₂} (ext ≡) = ext (λ v → ≡-sym (≡ v))
≡-sym {bool} bool = bool

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans {τ₁ ⇒ τ₂} {f} (ext ≡₁) (ext ≡₂) =
  ext (λ v → ≡-trans (≡₁ v) (≡₂ v))
≡-trans {bool} bool bool = bool

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong {τ₁ ⇒ τ₂} f ≡ = ext (λ v → ≡-cong (λ x → f x v) ≡)
≡-cong {bool} f ≡ = {!!}

≡-cong₂ : ∀ {τ₃ τ₁ τ₂ v₁ v₂ v₃ v₄} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧ → ⟦ τ₃ ⟧) →
  v₁ ≡ v₂ → v₃ ≡ v₄ → f v₁ v₃ ≡ f v₂ v₄
≡-cong₂ {τ₁ ⇒ τ₂} f ≡₁ ≡₂ = ext (λ v → ≡-cong₂ (λ x y → f x y v) ≡₁ ≡₂)
≡-cong₂ {bool} f ≡₁ ≡₂ = {!!}

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = ≡-cong₂ (λ x y → x y)

≡-isEquivalence : ∀ {τ} → IsEquivalence (_≡_ {τ})
≡-isEquivalence = record
  { refl  = ≡-refl
  ; sym   = ≡-sym
  ; trans = ≡-trans
  }

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

module ≡-Reasoning where
  module _ {τ : Type} where
    open EqR (≡-setoid τ) public
      hiding (_≡⟨_⟩_) renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂
Δ-Type (bool) = bool -- true means negate, false means nil change

derive : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
apply : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧ → ⟦ τ ⟧
diff : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

diff {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → diff (f₁ (apply dv v)) (f₂ v)
diff {bool} true true = false
diff {bool} true false = true
diff {bool} false true = true
diff {bool} false false = false

derive {τ₁ ⇒ τ₂} f = λ v dv → diff (f (apply dv v)) (f v)
derive {bool} b = false

apply {τ₁ ⇒ τ₂} df f = λ v → apply (df v (derive v)) (f v)
apply {bool} true true = false
apply {bool} true false = true
apply {bool} false true = true
apply {bool} false false = false

compose : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧
compose {τ₁ ⇒ τ₂} df₁ df₂ = λ v dv → compose (df₁ v dv) (df₂ v dv)
compose {bool} true true = false
compose {bool} true false = true
compose {bool} false true = true
compose {bool} false false = false

-- CONGRUENCE rules for change operations

≡-diff : ∀ {τ : Type} {v₁ v₂ v₃ v₄ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → diff v₁ v₃ ≡ diff v₂ v₄
≡-diff = ≡-cong₂ diff

≡-apply : ∀ {τ : Type} {dv₁ dv₂ : ⟦ Δ-Type τ ⟧} {v₁ v₂ : ⟦ τ ⟧} →
  dv₁ ≡ dv₂ → v₁ ≡ v₂ → apply dv₁ v₁ ≡ apply dv₂ v₂
≡-apply = ≡-cong₂ apply

-- PROPERTIES of changes

diff-derive : ∀ {τ} (v : ⟦ τ ⟧) →
  diff v v ≡ derive v
diff-derive {τ₁ ⇒ τ₂} v = ≡-refl
diff-derive {bool} true = bool
diff-derive {bool} false = bool

diff-apply : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
  diff (apply dv v) v ≡ dv
diff-apply {τ₁ ⇒ τ₂} df f = ext (λ v → ext (λ dv →
  {!!}))
diff-apply {bool} true true = bool
diff-apply {bool} true false = bool
diff-apply {bool} false true = bool
diff-apply {bool} false false = bool

apply-diff : ∀ {τ} (v₁ v₂ : ⟦ τ ⟧) →
  apply (diff v₂ v₁) v₁ ≡ v₂

apply-derive : ∀ {τ} (v : ⟦ τ ⟧) →
  apply (derive v) v ≡ v

apply-diff {τ₁ ⇒ τ₂} f₁ f₂ = ext (λ v →
  begin
    apply (diff f₂ f₁) f₁ v
  ≡⟨ ≡-refl ⟩
    apply (diff (f₂ (apply (derive v) v)) (f₁ v)) (f₁ v)
  ≡⟨ ≡-apply (≡-diff (≡-cong f₂ (apply-derive v)) ≡-refl) ≡-refl ⟩
    apply (diff (f₂ v) (f₁ v)) (f₁ v)
  ≡⟨ apply-diff (f₁ v) (f₂ v) ⟩
    f₂ v
  ∎) where open ≡-Reasoning
apply-diff {bool} true true = bool
apply-diff {bool} true false = bool
apply-diff {bool} false true = bool
apply-diff {bool} false false = bool

apply-derive {τ₁ ⇒ τ₂} f = ext (λ v →
  begin
    apply (derive f) f v
  ≡⟨ ≡-refl ⟩
    apply (diff (f (apply (derive v) v)) (f v)) (f v)
  ≡⟨ ≡-cong (λ x → apply (diff (f x) (f v)) (f v)) (apply-derive v) ⟩
    apply (diff (f v) (f v)) (f v)
  ≡⟨ apply-diff (f v) (f v)⟩
    f v
  ∎) where open ≡-Reasoning
apply-derive {bool} true = bool
apply-derive {bool} false = bool

apply-compose : ∀ {τ} (v : ⟦ τ ⟧) (dv₁ dv₂ : ⟦ Δ-Type τ ⟧) →
  apply (compose dv₁ dv₂) v ≡ apply dv₁ (apply dv₂ v)
apply-compose {τ₁ ⇒ τ₂} f df₁ df₂ = ext (λ v →
  apply-compose (f v) (df₁ v (derive v)) (df₂ v (derive v)))
apply-compose {bool} true true true = bool
apply-compose {bool} true true false = bool
apply-compose {bool} true false true = bool
apply-compose {bool} true false false = bool
apply-compose {bool} false true true = bool
apply-compose {bool} false true false = bool
apply-compose {bool} false false true = bool
apply-compose {bool} false false false = bool

compose-assoc : ∀ {τ} (dv₁ dv₂ dv₃ : ⟦ Δ-Type τ ⟧) →
  compose dv₁ (compose dv₂ dv₃) ≡ compose (compose dv₁ dv₂) dv₃
compose-assoc {τ₁ ⇒ τ₂} df₁ df₂ df₃ = ext (λ v → ext (λ dv →
  compose-assoc (df₁ v dv) (df₂ v dv) (df₃ v dv)))
compose-assoc {bool} true true true = bool
compose-assoc {bool} true true false = bool
compose-assoc {bool} true false true = bool
compose-assoc {bool} true false false = bool
compose-assoc {bool} false true true = bool
compose-assoc {bool} false true false = bool
compose-assoc {bool} false false true = bool
compose-assoc {bool} false false false = bool

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

update : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
update {∅} ∅ = ∅
update {τ • Γ} (dv • v • ρ) = apply dv v • update ρ

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore {∅} ∅ = ∅
ignore {τ • Γ} (dv • v • ρ) = v • ignore ρ

Δ-Context′ : (Γ : Context) → Prefix Γ → Context
Δ-Context′ Γ ∅ = Δ-Context Γ
Δ-Context′ (.τ • Γ) (τ • Γ′) = τ • Δ-Context′ Γ Γ′

update′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
update′ ∅ ρ = update ρ
update′ (τ • Γ′) (v • ρ) = v • update′ Γ′ ρ

ignore′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
ignore′ ∅ ρ = ignore ρ
ignore′ (τ • Γ′) (v • ρ) = v • ignore′ Γ′ ρ

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

  true false : ∀ {Γ} → Term Γ bool
  if : ∀ {Γ τ} → (t₁ : Term Γ bool) (t₂ t₃ : Term Γ τ) → Term Γ τ

  -- `Δ t` describes how t changes if its free variables or arguments change
  Δ : ∀ {Γ τ} → (t : Term Γ τ) → Term (Δ-Context Γ) (Δ-Type τ)

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ if t₁ t₂ t₃ ⟧Term ρ with ⟦ t₁ ⟧Term ρ
... | true = ⟦ t₂ ⟧Term ρ
... | false = ⟦ t₃ ⟧Term ρ
⟦ Δ t ⟧Term ρ = diff (⟦ t ⟧Term (update ρ)) (⟦ t ⟧Term (ignore ρ))

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext ≈) = ext (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext ≈₁) (ext ≈₂) = ext (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext ≈₁) (ext ≈₂) = ext (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext ≈) = ext (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext ≈) = ext (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open EqR (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = {!!}

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | bool = lift-term-ignore′ Γ′ t₂
... | false | false | bool = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if t₁ t₂ t₃) = {!!}
derive-term (Δ t) = Δ (derive-term t)

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext (λ ρ → ≡-refl)
derive-term-correct false = ext (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)

-- NATURAL SEMANTICS

-- (without support for Δ for now)

-- Syntax

data Env : Context → Set
data Val : Type → Set

data Val where
  ⟨abs_,_⟩ : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) (ρ : Env Γ) → Val (τ₁ ⇒ τ₂)

data Env where
  ∅ : Env ∅
  _•_ : ∀ {Γ τ} → Val τ → Env Γ → Env (τ • Γ)

-- Lookup

infixr 8 _⊢_↓_ _⊢_↦_

data _⊢_↦_ : ∀ {Γ τ} → Env Γ → Var Γ τ → Val τ → Set where
  this : ∀ {Γ τ} {ρ : Env Γ} {v : Val τ} →
    v • ρ ⊢ this ↦ v
  that : ∀ {Γ τ₁ τ₂ x} {ρ : Env Γ} {v₁ : Val τ₁} {v₂ : Val τ₂} →
    ρ ⊢ x ↦ v₂ →
    v₁ • ρ ⊢ that x ↦ v₂

-- Reduction

data _⊢_↓_ : ∀ {Γ τ} → Env Γ → Term Γ τ → Val τ → Set where
  abs : ∀ {Γ τ₁ τ₂ ρ} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ ⟨abs t , ρ ⟩
  app : ∀ {Γ Γ′ τ₁ τ₂ ρ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ ⟨abs t′ , ρ′ ⟩ →
    ρ ⊢ t₂ ↓ v₂ →
    v₂ • ρ′ ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {Γ τ x} {ρ : Env Γ} {v : Val τ}→
    ρ ⊢ x ↦ v →
    ρ ⊢ var x ↓ v

-- SOUNDNESS of natural semantics

⟦_⟧Env : ∀ {Γ} → Env Γ → ⟦ Γ ⟧
⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ ⟨abs t , ρ ⟩ ⟧Val = λ v → ⟦ t ⟧ (v • ⟦ ρ ⟧Env)

meaningOfEnv : ∀ {Γ} → Meaning (Env Γ)
meaningOfEnv = meaning ⟦_⟧Env

meaningOfVal : ∀ {τ} → Meaning (Val τ)
meaningOfVal = meaning ⟦_⟧Val

↦-sound : ∀ {Γ τ ρ v} {x : Var Γ τ} →
  ρ ⊢ x ↦ v →
  ⟦ x ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↦-sound this = ≡-refl
↦-sound (that ↦) = ↦-sound ↦

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↓-sound abs = ≡-refl
↓-sound (app ↓₁ ↓₂ ↓′) =
  ≡-trans
    (≡-cong₂ (λ x y → x y) (↓-sound ↓₁) (↓-sound ↓₂))
    (↓-sound ↓′)
↓-sound (var ↦) = ↦-sound ↦

-- WEAKENING

-- Weaken a term to a super context

{-
weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)
weaken {Γ₁} {Γ₂} (Δ t) = ?
-}

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import meaning

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- Value Equivalence

data _≡_ : ∀ {τ} → (v₁ v₂ : ⟦ τ ⟧) → Set where
  ext : ∀ {τ₁ τ₂} {f₁ f₂ : ⟦ τ₁ ⇒ τ₂ ⟧} →
    (∀ v → f₁ v ≡ f₂ v) →
    f₁ ≡ f₂

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl {τ₁ ⇒ τ₂} = ext (λ v → ≡-refl)

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym {τ₁ ⇒ τ₂} (ext ≡) = ext (λ v → ≡-sym (≡ v))

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans {τ₁ ⇒ τ₂} {f} (ext ≡₁) (ext ≡₂) =
  ext (λ v → ≡-trans (≡₁ v) (≡₂ v))

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong {τ₁ ⇒ τ₂} f ≡ = ext (λ v → ≡-cong (λ x → f x v) ≡)

≡-cong₂ : ∀ {τ₃ τ₁ τ₂ v₁ v₂ v₃ v₄} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧ → ⟦ τ₃ ⟧) →
  v₁ ≡ v₂ → v₃ ≡ v₄ → f v₁ v₃ ≡ f v₂ v₄
≡-cong₂ {τ₁ ⇒ τ₂} f ≡₁ ≡₂ = ext (λ v → ≡-cong₂ (λ x y → f x y v) ≡₁ ≡₂)

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = ≡-cong₂ (λ x y → x y)

≡-isEquivalence : ∀ {τ} → IsEquivalence (_≡_ {τ})
≡-isEquivalence = record
  { refl  = ≡-refl
  ; sym   = ≡-sym
  ; trans = ≡-trans
  }

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

module ≡-Reasoning where
  module _ {τ : Type} where
    open EqR (≡-setoid τ) public
      hiding (_≡⟨_⟩_) renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂

derive : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
apply : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧ → ⟦ τ ⟧
diff : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

diff {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → diff (f₁ (apply dv v)) (f₂ v)

derive {τ₁ ⇒ τ₂} f = λ v dv → diff (f (apply dv v)) (f v)

apply {τ₁ ⇒ τ₂} df f = λ v → apply (df v (derive v)) (f v)

compose : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧
compose {τ₁ ⇒ τ₂} df₁ df₂ = λ v dv → compose (df₁ v dv) (df₂ v dv)

-- PROPERTIES of changes

diff-derive : ∀ {τ} (v : ⟦ τ ⟧) →
  diff v v ≡ derive v
diff-derive {τ₁ ⇒ τ₂} v = ≡-refl

diff-apply : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
  diff (apply dv v) v ≡ dv
diff-apply {τ₁ ⇒ τ₂} df f = ext (λ v → ext (λ dv →
  {!!}))

apply-diff : ∀ {τ} (v₁ v₂ : ⟦ τ ⟧) →
  apply (diff v₂ v₁) v₁ ≡ v₂
apply-diff {τ₁ ⇒ τ₂} f₁ f₂ = ext (λ v → apply-diff (f₁ v) (f₂ v))

apply-derive : ∀ {τ} (v : ⟦ τ ⟧) →
  apply (derive v) v ≡ v
apply-derive {τ₁ ⇒ τ₂} f = ext (λ v →
  begin
    apply (derive f) f v
  ≡⟨ ≡-refl ⟩
    apply (diff (f (apply (derive v) v)) (f v)) (f v)
  ≡⟨ ≡-cong (λ x → apply (diff (f x) (f v)) (f v)) (apply-derive v) ⟩
    apply (diff (f v) (f v)) (f v)
  ≡⟨ apply-diff (f v) (f v)⟩
    f v
  ∎) where open ≡-Reasoning

apply-compose : ∀ {τ} (v : ⟦ τ ⟧) (dv₁ dv₂ : ⟦ Δ-Type τ ⟧) →
  apply (compose dv₁ dv₂) v ≡ apply dv₁ (apply dv₂ v)
apply-compose {τ₁ ⇒ τ₂} f df₁ df₂ = ext (λ v →
  apply-compose (f v) (df₂ v (derive v)) (df₂ v (derive v)))

compose-assoc : ∀ {τ} (dv₁ dv₂ dv₃ : ⟦ Δ-Type τ ⟧) →
  compose dv₁ (compose dv₂ dv₃) ≡ compose (compose dv₁ dv₂) dv₃
compose-assoc {τ₁ ⇒ τ₂} df₁ df₂ df₃ = ext (λ v → ext (λ dv →
  compose-assoc (df₁ v dv) (df₂ v dv) (df₃ v dv)))

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

update : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
update {∅} ∅ = ∅
update {τ • Γ} (dv • v • ρ) = apply dv v • update ρ

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore {∅} ∅ = ∅
ignore {τ • Γ} (dv • v • ρ) = v • ignore ρ

Δ-Context′ : (Γ : Context) → Prefix Γ → Context
Δ-Context′ Γ ∅ = Δ-Context Γ
Δ-Context′ (.τ • Γ) (τ • Γ′) = τ • Δ-Context′ Γ Γ′

update′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
update′ ∅ ρ = update ρ
update′ (τ • Γ′) (v • ρ) = v • update′ Γ′ ρ

ignore′ : ∀ {Γ} → (Γ′ : Prefix Γ) → ⟦ Δ-Context′ Γ Γ′ ⟧ → ⟦ Γ ⟧
ignore′ ∅ ρ = ignore ρ
ignore′ (τ • Γ′) (v • ρ) = v • ignore′ Γ′ ρ

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

  -- `Δ t` describes how t changes if its free variables or arguments change
  Δ : ∀ {Γ τ} → (t : Term Γ τ) → Term (Δ-Context Γ) (Δ-Type τ)

fv : ∀ {Γ τ} → Term Γ τ → Context
fv {Γ} _ = Γ

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ Δ t ⟧Term ρ = diff (⟦ t ⟧Term (update ρ)) (⟦ t ⟧Term (ignore ρ))

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext ≈) = ext (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext ≈₁) (ext ≈₂) = ext (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext ≈₁) (ext ≈₂) = ext (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext ≈) = ext (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ {τ₁ ⇒ τ₂} (ext ≈) = ext (λ ρ → ext (λ v → ext (λ dv →
  ≡-cong₂ (λ x y → diff (x v) (y v)) (≈ (update ρ)) (≈ (ignore ρ)))))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open EqR (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ (Δ t) = {!!}

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ (Δ t) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨ ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term (Δ t) = Δ (derive-term t)

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)

-- NATURAL SEMANTICS

-- (without support for Δ for now)

-- Syntax

data Env : Context → Set
data Val : Type → Set

data Val where
  ⟨abs_,_⟩ : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) (ρ : Env Γ) → Val (τ₁ ⇒ τ₂)

data Env where
  ∅ : Env ∅
  _•_ : ∀ {Γ τ} → Val τ → Env Γ → Env (τ • Γ)

-- Lookup

infixr 8 _⊢_↓_ _⊢_↦_

data _⊢_↦_ : ∀ {Γ τ} → Env Γ → Var Γ τ → Val τ → Set where
  this : ∀ {Γ τ} {ρ : Env Γ} {v : Val τ} →
    v • ρ ⊢ this ↦ v
  that : ∀ {Γ τ₁ τ₂ x} {ρ : Env Γ} {v₁ : Val τ₁} {v₂ : Val τ₂} →
    ρ ⊢ x ↦ v₂ →
    v₁ • ρ ⊢ that x ↦ v₂

-- Reduction

data _⊢_↓_ : ∀ {Γ τ} → Env Γ → Term Γ τ → Val τ → Set where
  abs : ∀ {Γ τ₁ τ₂ ρ} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ ⟨abs t , ρ ⟩
  app : ∀ {Γ Γ′ τ₁ τ₂ ρ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ ⟨abs t′ , ρ′ ⟩ →
    ρ ⊢ t₂ ↓ v₂ →
    v₂ • ρ′ ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {Γ τ x} {ρ : Env Γ} {v : Val τ}→
    ρ ⊢ x ↦ v →
    ρ ⊢ var x ↓ v

-- SOUNDNESS of natural semantics

⟦_⟧Env : ∀ {Γ} → Env Γ → ⟦ Γ ⟧
⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ ⟨abs t , ρ ⟩ ⟧Val = λ v → ⟦ t ⟧ (v • ⟦ ρ ⟧Env)

meaningOfEnv : ∀ {Γ} → Meaning (Env Γ)
meaningOfEnv = meaning ⟦_⟧Env

meaningOfVal : ∀ {τ} → Meaning (Val τ)
meaningOfVal = meaning ⟦_⟧Val

↦-sound : ∀ {Γ τ ρ v} {x : Var Γ τ} →
  ρ ⊢ x ↦ v →
  ⟦ x ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↦-sound this = ≡-refl
↦-sound (that ↦) = ↦-sound ↦

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↓-sound abs = ≡-refl
↓-sound (app ↓₁ ↓₂ ↓′) =
  ≡-trans
    (≡-cong₂ (λ x y → x y) (↓-sound ↓₁) (↓-sound ↓₂))
    (↓-sound ↓′)
↓-sound (var ↦) = ↦-sound ↦

-- WEAKENING

-- Weaken a term to a super context

{-
weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)
weaken {Γ₁} {Γ₂} (Δ t) = ?
-}


auxiliary functions to define levels compactly; example level

{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin renaming (_+_ to _F+_)
  open import Data.List
  open import Data.Vec renaming (map to vmap; lookup to vlookup)

  module Matrix where
    data Matrix (A : Set) : ℕ → ℕ → Set where
      Mat : {w h : ℕ} → Vec (Vec A w) h → Matrix A w h

    lookup : ∀ {w h} {A : Set} → Fin h → Fin w → Matrix A w h → A
    lookup row column (Mat rows) = vlookup column (vlookup row rows)
  open Matrix

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa Color : Set where
    _KT : Color → KoopaTroopa Color

  data Material : Set where
    gas    : Material
    -- liquid : Material
    solid  : Material

  record Position : Set where
    constructor pos
    field
      x   : ℕ
      y   : ℕ
      mat : Material

  data _follows_ : Position → Position → Set where
    stay  : ∀ {p} → p follows p
    next  : ∀ {x y mat} → pos (suc x) y mat follows pos x y mat
    back  : ∀ {x y mat} → pos x y mat follows pos (suc x) y mat
    -- jump  : ∀ {x y mat} → pos x (suc y) mat follows pos x y mat
    fall  : ∀ {x y mat} → pos x y mat follows pos x (suc y) mat

  infixr 5 _↠⟨_⟩_
  data Path (Koopa : KoopaTroopa Color) : Position → Position → Set where
    []  : ∀ {p} → Path Koopa p p
    _↠⟨_⟩_ : {q r : Position} → (p : Position) → q follows p
                → (qs : Path Koopa q r) → Path Koopa p r

  ex_path : Path (Red KT) (pos 0 0 solid) (pos 0 0 solid)
  ex_path = pos 0 0 solid ↠⟨ next ⟩
            pos 1 0 solid ↠⟨ back ⟩
            pos 0 0 solid ↠⟨ stay ⟩ []

  matToPosVec : {n : ℕ} → Vec Material n → ℕ → ℕ → Vec Position n
  matToPosVec []           _ _ = []
  matToPosVec (mat ∷ mats) x y = pos x y mat ∷ matToPosVec mats (x + 1) y

  matToPosVecs : {w h : ℕ} → Vec (Vec Material w) h → Vec (Vec Position w) h
  matToPosVecs []                   = []
  matToPosVecs (_∷_ {y} mats matss) = matToPosVec mats 0 y ∷ matToPosVecs matss

  matToMat : {w h : ℕ} → Vec (Vec Material w) h → Matrix Position w h
  matToMat matss = Mat (matToPosVecs matss)

  □ : Material
  □ = gas
  ■ : Material
  ■ = solid
  example_level : Matrix Position 10 7
  example_level = Mat (matToPosVecs (
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ []) ∷
    (■ ∷ ■ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ []) ∷ []))

{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin
  open import Data.List
  open import Data.Vec renaming (map to vmap; lookup to vlookup)

  module Matrix where
    data Matrix (A : Set) : ℕ → ℕ → Set where
      Mat : {w h : ℕ} → Vec (Vec A w) h → Matrix A w h

    lookup : ∀ {w h} {A : Set} → Fin h → Fin w → Matrix A w h → A
    lookup row column (Mat rows) = vlookup column (vlookup row rows)

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa Color : Set where
    _KT : Color → KoopaTroopa Color

  data Material : Set where
    gas    : Material
    -- liquid : Material
    solid  : Material

  record Position : Set where
    constructor pos
    field
      x   : ℕ
      y   : ℕ
      mat : Material

  data _follows_ : Position → Position → Set where
    stay  : ∀ {p} → p follows p
    next  : ∀ {x y mat} → pos (suc x) y mat follows pos x y mat
    back  : ∀ {x y mat} → pos x y mat follows pos (suc x) y mat
    -- jump  : ∀ {x y mat} → pos x (suc y) mat follows pos x y mat
    fall  : ∀ {x y mat} → pos x y mat follows pos x (suc y) mat

  infixr 5 _↠⟨_⟩_
  data Path (Koopa : KoopaTroopa Color) : Position → Position → Set where
    []  : ∀ {p} → Path Koopa p p
    _↠⟨_⟩_ : {q r : Position} → (p : Position) → q follows p
                → (qs : Path Koopa q r) → Path Koopa p r

  example_level : Matrix Position
  example_level = []

  ex_path : Path (Red KT) (pos 0 0 solid) (pos 0 0 solid)
  ex_path = pos 0 0 solid ↠⟨ next ⟩
            pos 1 0 solid ↠⟨ back ⟩
            pos 0 0 solid ↠⟨ stay ⟩ []


Added draft about the use of the existential elimination.

Ignore-this: 3eaa2ea7fe0572858239df18e1843c2c

darcs-hash:20120219124310-3bd4e-aad6b1f41dbc1f59201ed878ba50fec74bbc21ae.gz