Fixed whitespace issue

Fixed whitespace issue

------------------------------------------------------------------------------
-- Properties related with lists using instances of the induction principle
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.List.Induction.Instances.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Totality properties

lengthList-N-ind-instance :
  N (length []) →
  (∀ x {xs} → N (length xs) → N (length (x ∷ xs))) →
  ∀ {xs} → List xs → N (length xs)
lengthList-N-ind-instance = List-ind (λ as → N (length as))

postulate lengthList-N : ∀ {xs} → List xs → N (length xs)
{-# ATP prove lengthList-N lengthList-N-ind-instance #-}

++-List-ind-instance :
  ∀ {ys} →
  List ([] ++ ys) →
  (∀ x {xs} → List (xs ++ ys) → List ((x ∷ xs) ++ ys)) →
  ∀ {xs} → List xs → List (xs ++ ys)
++-List-ind-instance {ys} = List-ind (λ as → List (as ++ ys))

postulate ++-List : ∀ {xs ys} → List xs → List ys → List (xs ++ ys)
{-# ATP prove ++-List ++-List-ind-instance #-}

map-List-ind-instance :
  ∀ {f} →
  List (map f []) →
  (∀ x {xs} → List (map f xs) → List (map f (x ∷ xs))) →
  ∀ {xs} → List xs → List (map f xs)
map-List-ind-instance {f} = List-ind (λ as → List (map f as))

postulate map-List : ∀ f {xs} → List xs → List (map f xs)
{-# ATP prove map-List map-List-ind-instance #-}

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

++-assoc-ind-instance :
  ∀ {ys zs} →
  ([] ++ ys) ++ zs ≡ [] ++ ys ++ zs →
  (∀ x {xs} →
    (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs →
    ((x ∷ xs) ++ ys) ++ zs ≡ (x ∷ xs) ++ ys ++ zs) →
  ∀ {xs} → List xs → (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs
++-assoc-ind-instance {ys} {zs} =
  List-ind (λ as → (as ++ ys) ++ zs ≡ as ++ ys ++ zs )

postulate
  ++-assoc : ∀ {xs} → List xs → ∀ ys zs → (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs
{-# ATP prove ++-assoc ++-assoc-ind-instance #-}

map-++-ind-instance :
  ∀ {f} {ys} →
  map f ([] ++ ys) ≡ map f [] ++ map f ys →
  (∀ x {xs} → map f (xs ++ ys) ≡ map f xs ++ map f ys →
    map f ((x ∷ xs) ++ ys) ≡ map f (x ∷ xs) ++ map f ys) →
  ∀ {xs} → List xs → map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-ind-instance {f} {ys} =
  List-ind (λ as → map f (as ++ ys) ≡ map f as ++ map f ys)

postulate
  map-++ : ∀ f {xs} → List xs → ∀ ys →
           map f (xs ++ ys) ≡ map f xs ++ map f ys
{-# ATP prove map-++ map-++-ind-instance #-}


hiding _↔_

hiding _↔_

-- NOTE with-K
open import Type hiding (★)
open import Level.NP
open import Function.NP hiding (_↔_)
open import Data.Nat.NP hiding (⟨_↔+1⟩; ⟨0↔1+_⟩)
open import Data.Nat.Properties
open import Data.Vec.NP
open import Data.Bits
open import Data.Product hiding (map)
open import Data.Fin using (Fin; zero; suc; inject₁)
open import Relation.Binary.PropositionalEquality

module Data.Vec.Permutation where

-- ⟨0↔1+ i ⟩: Exchange elements at position 0 and 1+i.
⟨0↔1+_⟩ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A (1 + n) → Vec A (1 + n)
⟨0↔1+ zero  ⟩ = 0↔1
⟨0↔1+ suc i ⟩ = 0↔1 ∘ (map-tail ⟨0↔1+ i ⟩) ∘ 0↔1
  {- 0   1   2 3 ... i 1+i ... n
     1   0   2 3 ... i 1+i ... n
     1   1+i 2 3 ... i 0   ... n

     1+i 1   2 3 ... i 0   ... n
   -}

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = ⟨0↔1+ i ⟩

⟨0↔zero⟩ : ∀ {n a} {A : ★ a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = refl

private
    _² : ∀ {a} {A : ★ a} → Endo (Endo A)
    f ² = f ∘ f

module ⟨↔⟩ {a} (A : ★ a) where

    ⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Vec A n → Vec A n
    ⟨ zero  ↔ j     ⟩ = ⟨0↔ j ⟩
    ⟨ i     ↔ zero  ⟩ = ⟨0↔ i ⟩
    ⟨ suc i ↔ suc j ⟩ = map-tail ⟨ i ↔ j ⟩
-- ⟨ # 0 ↔ # 1 ⟩

    comm : ∀ {n} (i j : Fin n) → ⟨ i ↔ j ⟩ ≗ ⟨ j ↔ i ⟩
    comm zero    zero    _ = refl
    comm zero    (suc _) _ = refl
    comm (suc _) zero    _ = refl
    comm (suc i) (suc j) (x ∷ xs) rewrite comm i j xs = refl

    0↔1²-cancel : ∀ {n} → 0↔1 ² ≗ id {A = Vec A n}
    0↔1²-cancel [] = refl
    0↔1²-cancel (_ ∷ []) = refl
    0↔1²-cancel (x ∷ x₁ ∷ xs) = refl

    ⟨0↔1+_⟩²-cancel : ∀ {n} (i : Fin n) → ⟨0↔1+ i ⟩ ² ≗ id {A = Vec A (1 + n)}
    ⟨0↔1+ zero  ⟩²-cancel xs = 0↔1²-cancel xs
    ⟨0↔1+ suc i ⟩²-cancel xs
      rewrite 0↔1²-cancel (map-tail ⟨0↔1+ i ⟩ (0↔1 xs))
            | map-tail∘map-tail ⟨0↔1+ i ⟩ ⟨0↔1+ i ⟩ (0↔1 xs)
            | map-tail-≗ _ _ ⟨0↔1+ i ⟩²-cancel (0↔1 xs)
            | map-tail-id (0↔1 xs)
            | 0↔1²-cancel xs = refl

    ⟨0↔_⟩²-cancel : ∀ {n} (i : Fin n) → ⟨0↔ i ⟩ ² ≗ id {A = Vec A n}
    ⟨0↔ zero  ⟩²-cancel _  = refl
    ⟨0↔ suc i ⟩²-cancel xs = ⟨0↔1+ i ⟩²-cancel xs

    ⟨_↔_⟩²-cancel : ∀ {n} (i j : Fin n) → ⟨ i ↔ j ⟩ ² ≗ id
    ⟨ zero  ↔ j     ⟩²-cancel xs = ⟨0↔ j   ⟩²-cancel xs
    ⟨ suc i ↔ zero  ⟩²-cancel xs = ⟨0↔1+ i ⟩²-cancel xs
    ⟨ suc i ↔ suc j ⟩²-cancel xs
      rewrite map-tail∘map-tail ⟨ i ↔ j ⟩ ⟨ i ↔ j ⟩ xs
            | map-tail-≗ _ _ ⟨ i ↔ j ⟩²-cancel xs
            | map-tail-id xs = refl

    lem01maptail2 : ∀ {m n a} {A : ★ a} (f : Vec A m → Vec A n) →
                      0↔1 ∘ map-tail (map-tail f) ∘ 0↔1 ≗ map-tail (map-tail f)
    lem01maptail2 _ (_ ∷ _ ∷ _) = refl

    ↔-refl : ∀ {n} (i : Fin n) → ⟨ i ↔ i ⟩ ≗ id
    ↔-refl zero    _  = refl
    ↔-refl (suc i) xs rewrite map-tail-≗ _ _ (↔-refl i) xs = map-tail-id xs

⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
⟨_↔_⟩ i j = ⟨↔⟩.⟨_↔_⟩ _ i j

module PermutationSyntax where
    infixr 1 _`⁏_
    data Perm : ℕ → ★₀ where
      `id : ∀ {n} → Perm n
      `0↔1 : ∀ {n} → Perm (2 + n)
      _`⁏_ : ∀ {n} → Perm n → Perm n → Perm n
      `tl : ∀ {n} → Perm n → Perm (1 + n)

    _⁻¹ : ∀ {n} → Endo (Perm n)
    `id ⁻¹ = `id
    (f₀ `⁏ f₁) ⁻¹ = f₁ ⁻¹ `⁏ f₀ ⁻¹
    `0↔1 ⁻¹ = `0↔1
    (`tl f) ⁻¹ = `tl (f ⁻¹)

    `⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Perm (1 + n)
    `⟨0↔1+ zero  ⟩ = `0↔1
    `⟨0↔1+ suc i ⟩ = `0↔1 `⁏ `tl `⟨0↔1+ i ⟩ `⁏ `0↔1

    `⟨0↔_⟩ : ∀ {n} (i : Fin n) → Perm n
    `⟨0↔ zero  ⟩ = `id
    `⟨0↔ suc i ⟩ = `⟨0↔1+ i ⟩

    `⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Perm n
    `⟨ zero  ↔ j     ⟩ = `⟨0↔ j ⟩
    `⟨ i     ↔ zero  ⟩ = `⟨0↔ i ⟩
    `⟨ suc i ↔ suc j ⟩ = `tl `⟨ i ↔ j ⟩

module PermutationSemantics {a} {A : ★ a} where
    open PermutationSyntax

    eval : ∀ {n} → Perm n → Endo (Vec A n)
    eval `id      = id
    eval (f `⁏ g)  = eval g ∘ eval f
    eval `0↔1     = 0↔1
    eval (`tl f)  = λ xs → head xs ∷ eval f (tail xs)

    infixr 9 _·_
    _·_ : ∀ {n} → Perm n → Endo (Vec A n)
    _·_ = eval

    `⟨0↔1+_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A (suc n)) → `⟨0↔1+ i ⟩ · xs ≡ ⟨0↔1+ i ⟩ xs
    `⟨0↔1+ zero  ⟩-spec xs = refl
    `⟨0↔1+ suc i ⟩-spec (x ∷ y ∷ xs) rewrite `⟨0↔1+ i ⟩-spec (x ∷ xs) = refl

    `⟨0↔_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A n) → `⟨0↔ i ⟩ · xs ≡ ⟨0↔ i ⟩ xs
    `⟨0↔ zero  ⟩-spec xs = refl
    `⟨0↔ suc i ⟩-spec xs = `⟨0↔1+ i ⟩-spec xs

    _≗′_ : ∀ {n} → Perm n → Perm n → ★ _
    f ≗′ g = ∀ xs → f · xs ≡ g · xs

    open ⟨↔⟩ A hiding (⟨_↔_⟩)

    _⁻¹-inverse : ∀ {n} (f : Perm n) → (f `⁏ f ⁻¹) ≗′ `id
    (`id ⁻¹-inverse) xs = refl
    ((f `⁏ g) ⁻¹-inverse) xs
      rewrite (g ⁻¹-inverse) (f · xs)
            | (f ⁻¹-inverse) xs = refl
    (`0↔1 ⁻¹-inverse) xs = 0↔1²-cancel xs
    ((`tl f) ⁻¹-inverse) (x ∷ xs)
      rewrite (f ⁻¹-inverse) xs = refl

    _⁻¹-involutive : ∀ {n} (f : Perm n) → (f ⁻¹) ⁻¹ ≗′ f
    (`id ⁻¹-involutive) _ = refl
    ((f `⁏ g) ⁻¹-involutive) x
      rewrite (f ⁻¹-involutive) x
            | (g ⁻¹-involutive) (f · x) = refl
    (`0↔1 ⁻¹-involutive) _ = refl
    ((`tl f) ⁻¹-involutive) (x ∷ xs)
      rewrite (f ⁻¹-involutive) xs
            = refl

    _⁻¹-inverse′ : ∀ {n} (f : Perm n) → (f ⁻¹ `⁏ f) ≗′ `id
    (f ⁻¹-inverse′) xs with ((f ⁻¹) ⁻¹-inverse) xs
    ... | p rewrite (f ⁻¹-involutive) (f ⁻¹ · xs) = p

    `⟨_↔_⟩-spec : ∀ {n} (i j : Fin n) (xs : Vec A n) → `⟨ i ↔ j ⟩ · xs ≡ ⟨ i ↔ j ⟩ xs
    `⟨_↔_⟩-spec zero    j       xs = `⟨0↔   j ⟩-spec xs
    `⟨_↔_⟩-spec (suc i) zero    xs = `⟨0↔1+ i ⟩-spec xs
    `⟨_↔_⟩-spec (suc i) (suc j) (x ∷ xs)
       rewrite `⟨ i ↔ j ⟩-spec xs = refl

module PermutationProperties {a : Level} where
    open PermutationSyntax
    open PermutationSemantics

    ⊛-dist-· : ∀ {n} {A : ★ a} (fs : Vec (Endo A) n) (f : Perm n) xs → (f · fs ⊛ f · xs) ≡ f · (fs ⊛ xs)
    ⊛-dist-· _       `id        _  = refl
    ⊛-dist-· fs      `0↔1       xs = ⊛-dist-0↔1 fs xs
    ⊛-dist-· (_ ∷ fs) (`tl f)   (_ ∷ xs) rewrite ⊛-dist-· fs f xs = refl
    ⊛-dist-· fs       (f `⁏ g)   xs rewrite ⊛-dist-· (f · fs) g (f · xs)
                                         | ⊛-dist-· fs f xs = refl

    ·-replicate : ∀ {n} {A : ★ a} (x : A) (f : Perm n) → f · replicate x ≡ replicate x
    ·-replicate x `id = refl
    ·-replicate x `0↔1 = refl
    ·-replicate x (`tl f) rewrite ·-replicate x f = refl
    ·-replicate x (f `⁏ g) rewrite ·-replicate x f | ·-replicate x g = refl

    private
        lem : ∀ {n} {A : ★ a} (fs : Vec (Endo A) n) f xs
              → fs ⊛ f · xs ≡ f · (f ⁻¹ · fs ⊛ xs)
        lem fs f xs rewrite sym (⊛-dist-· (f ⁻¹ · fs) f xs) | (f ⁻¹-inverse′) fs = refl

    ·-map : ∀ {n} {A : ★ a} (f : Endo A) g (xs : Vec A n) → map f (g · xs) ≡ g · map f xs
    ·-map f g xs rewrite sym (⊛-dist-· (replicate f) g xs) | ·-replicate f g = refl

    ⊕-dist-0↔1 : ∀ {n} (pad : Bits n) xs → 0↔1 pad ⊕ 0↔1 xs ≡ 0↔1 (pad ⊕ xs)
    ⊕-dist-0↔1 _           []          = refl
    ⊕-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = refl
    ⊕-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = refl

    -- TODO make use of ⊛-dist-·
    ⊕-dist-· : ∀ {n} (pad : Bits n) π xs → π · pad ⊕ π · xs ≡ π · (pad ⊕ xs)
    ⊕-dist-· fs      `id        xs = refl
    ⊕-dist-· fs      `0↔1       xs = ⊕-dist-0↔1 fs xs
    ⊕-dist-· (f ∷ fs) (`tl π)   (x ∷ xs) rewrite ⊕-dist-· fs π xs = refl
    ⊕-dist-· fs       (π₀ `⁏ π₁) xs rewrite ⊕-dist-· (π₀ · fs) π₁ (π₀ · xs)
                                         | ⊕-dist-· fs π₀ xs = refl

private
  module Unused where
    module Foo where
    {-
       WRONG
        ⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
        ⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

        ⟨0↔⟩-spec : ∀ {n a} {A : ★ a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
        ⟨0↔⟩-spec _ _ = ≡.refl
        -}

    ⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    ⟨0↔_⟩′ {zero}  i xs = xs
    ⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

    -- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
    ⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    ⟨ zero  ↔+1⟩ = 0↔1
    ⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

    ⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : ★ a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩ {A = A}
    ⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = refl
    ⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = refl

    -- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
    --           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
    rot-up-to : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    rot-up-to zero    = id
    rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

    -- Inverse of rot-up-to
    rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    rot⁻¹-up-to zero    = id
    rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

    rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : ★ a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
    rot⁻¹-up-to∘rot-up-to zero            _ = refl
    rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = refl
    rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = refl

-- NOTE with-K
open import Type hiding (★)
open import Level.NP
open import Function.NP
open import Data.Nat.NP hiding (⟨_↔+1⟩; ⟨0↔1+_⟩)
open import Data.Nat.Properties
open import Data.Vec.NP
open import Data.Bits
open import Data.Product hiding (map)
open import Data.Fin using (Fin; zero; suc; inject₁)
open import Relation.Binary.PropositionalEquality

module Data.Vec.Permutation where

-- ⟨0↔1+ i ⟩: Exchange elements at position 0 and 1+i.
⟨0↔1+_⟩ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A (1 + n) → Vec A (1 + n)
⟨0↔1+ zero  ⟩ = 0↔1
⟨0↔1+ suc i ⟩ = 0↔1 ∘ (map-tail ⟨0↔1+ i ⟩) ∘ 0↔1
  {- 0   1   2 3 ... i 1+i ... n
     1   0   2 3 ... i 1+i ... n
     1   1+i 2 3 ... i 0   ... n

     1+i 1   2 3 ... i 0   ... n
   -}

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = ⟨0↔1+ i ⟩

⟨0↔zero⟩ : ∀ {n a} {A : ★ a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = refl

private
    _² : ∀ {a} {A : ★ a} → Endo (Endo A)
    f ² = f ∘ f

module ⟨↔⟩ {a} (A : ★ a) where

    ⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Vec A n → Vec A n
    ⟨ zero  ↔ j     ⟩ = ⟨0↔ j ⟩
    ⟨ i     ↔ zero  ⟩ = ⟨0↔ i ⟩
    ⟨ suc i ↔ suc j ⟩ = map-tail ⟨ i ↔ j ⟩
-- ⟨ # 0 ↔ # 1 ⟩

    comm : ∀ {n} (i j : Fin n) → ⟨ i ↔ j ⟩ ≗ ⟨ j ↔ i ⟩
    comm zero    zero    _ = refl
    comm zero    (suc _) _ = refl
    comm (suc _) zero    _ = refl
    comm (suc i) (suc j) (x ∷ xs) rewrite comm i j xs = refl

    0↔1²-cancel : ∀ {n} → 0↔1 ² ≗ id {A = Vec A n}
    0↔1²-cancel [] = refl
    0↔1²-cancel (_ ∷ []) = refl
    0↔1²-cancel (x ∷ x₁ ∷ xs) = refl

    ⟨0↔1+_⟩²-cancel : ∀ {n} (i : Fin n) → ⟨0↔1+ i ⟩ ² ≗ id {A = Vec A (1 + n)}
    ⟨0↔1+ zero  ⟩²-cancel xs = 0↔1²-cancel xs
    ⟨0↔1+ suc i ⟩²-cancel xs
      rewrite 0↔1²-cancel (map-tail ⟨0↔1+ i ⟩ (0↔1 xs))
            | map-tail∘map-tail ⟨0↔1+ i ⟩ ⟨0↔1+ i ⟩ (0↔1 xs)
            | map-tail-≗ _ _ ⟨0↔1+ i ⟩²-cancel (0↔1 xs)
            | map-tail-id (0↔1 xs)
            | 0↔1²-cancel xs = refl

    ⟨0↔_⟩²-cancel : ∀ {n} (i : Fin n) → ⟨0↔ i ⟩ ² ≗ id {A = Vec A n}
    ⟨0↔ zero  ⟩²-cancel _  = refl
    ⟨0↔ suc i ⟩²-cancel xs = ⟨0↔1+ i ⟩²-cancel xs

    ⟨_↔_⟩²-cancel : ∀ {n} (i j : Fin n) → ⟨ i ↔ j ⟩ ² ≗ id
    ⟨ zero  ↔ j     ⟩²-cancel xs = ⟨0↔ j   ⟩²-cancel xs
    ⟨ suc i ↔ zero  ⟩²-cancel xs = ⟨0↔1+ i ⟩²-cancel xs
    ⟨ suc i ↔ suc j ⟩²-cancel xs
      rewrite map-tail∘map-tail ⟨ i ↔ j ⟩ ⟨ i ↔ j ⟩ xs
            | map-tail-≗ _ _ ⟨ i ↔ j ⟩²-cancel xs
            | map-tail-id xs = refl

    lem01maptail2 : ∀ {m n a} {A : ★ a} (f : Vec A m → Vec A n) →
                      0↔1 ∘ map-tail (map-tail f) ∘ 0↔1 ≗ map-tail (map-tail f)
    lem01maptail2 _ (_ ∷ _ ∷ _) = refl

    ↔-refl : ∀ {n} (i : Fin n) → ⟨ i ↔ i ⟩ ≗ id
    ↔-refl zero    _  = refl
    ↔-refl (suc i) xs rewrite map-tail-≗ _ _ (↔-refl i) xs = map-tail-id xs

⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
⟨_↔_⟩ i j = ⟨↔⟩.⟨_↔_⟩ _ i j

module PermutationSyntax where
    infixr 1 _`⁏_
    data Perm : ℕ → ★₀ where
      `id : ∀ {n} → Perm n
      `0↔1 : ∀ {n} → Perm (2 + n)
      _`⁏_ : ∀ {n} → Perm n → Perm n → Perm n
      `tl : ∀ {n} → Perm n → Perm (1 + n)

    _⁻¹ : ∀ {n} → Endo (Perm n)
    `id ⁻¹ = `id
    (f₀ `⁏ f₁) ⁻¹ = f₁ ⁻¹ `⁏ f₀ ⁻¹
    `0↔1 ⁻¹ = `0↔1
    (`tl f) ⁻¹ = `tl (f ⁻¹)

    `⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Perm (1 + n)
    `⟨0↔1+ zero  ⟩ = `0↔1
    `⟨0↔1+ suc i ⟩ = `0↔1 `⁏ `tl `⟨0↔1+ i ⟩ `⁏ `0↔1

    `⟨0↔_⟩ : ∀ {n} (i : Fin n) → Perm n
    `⟨0↔ zero  ⟩ = `id
    `⟨0↔ suc i ⟩ = `⟨0↔1+ i ⟩

    `⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Perm n
    `⟨ zero  ↔ j     ⟩ = `⟨0↔ j ⟩
    `⟨ i     ↔ zero  ⟩ = `⟨0↔ i ⟩
    `⟨ suc i ↔ suc j ⟩ = `tl `⟨ i ↔ j ⟩

module PermutationSemantics {a} {A : ★ a} where
    open PermutationSyntax

    eval : ∀ {n} → Perm n → Endo (Vec A n)
    eval `id      = id
    eval (f `⁏ g)  = eval g ∘ eval f
    eval `0↔1     = 0↔1
    eval (`tl f)  = λ xs → head xs ∷ eval f (tail xs)

    infixr 9 _·_
    _·_ : ∀ {n} → Perm n → Endo (Vec A n)
    _·_ = eval

    `⟨0↔1+_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A (suc n)) → `⟨0↔1+ i ⟩ · xs ≡ ⟨0↔1+ i ⟩ xs
    `⟨0↔1+ zero  ⟩-spec xs = refl
    `⟨0↔1+ suc i ⟩-spec (x ∷ y ∷ xs) rewrite `⟨0↔1+ i ⟩-spec (x ∷ xs) = refl

    `⟨0↔_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A n) → `⟨0↔ i ⟩ · xs ≡ ⟨0↔ i ⟩ xs
    `⟨0↔ zero  ⟩-spec xs = refl
    `⟨0↔ suc i ⟩-spec xs = `⟨0↔1+ i ⟩-spec xs

    _≗′_ : ∀ {n} → Perm n → Perm n → ★ _
    f ≗′ g = ∀ xs → f · xs ≡ g · xs

    open ⟨↔⟩ A hiding (⟨_↔_⟩)

    _⁻¹-inverse : ∀ {n} (f : Perm n) → (f `⁏ f ⁻¹) ≗′ `id
    (`id ⁻¹-inverse) xs = refl
    ((f `⁏ g) ⁻¹-inverse) xs
      rewrite (g ⁻¹-inverse) (f · xs)
            | (f ⁻¹-inverse) xs = refl
    (`0↔1 ⁻¹-inverse) xs = 0↔1²-cancel xs
    ((`tl f) ⁻¹-inverse) (x ∷ xs)
      rewrite (f ⁻¹-inverse) xs = refl

    _⁻¹-involutive : ∀ {n} (f : Perm n) → (f ⁻¹) ⁻¹ ≗′ f
    (`id ⁻¹-involutive) _ = refl
    ((f `⁏ g) ⁻¹-involutive) x
      rewrite (f ⁻¹-involutive) x
            | (g ⁻¹-involutive) (f · x) = refl
    (`0↔1 ⁻¹-involutive) _ = refl
    ((`tl f) ⁻¹-involutive) (x ∷ xs)
      rewrite (f ⁻¹-involutive) xs
            = refl

    _⁻¹-inverse′ : ∀ {n} (f : Perm n) → (f ⁻¹ `⁏ f) ≗′ `id
    (f ⁻¹-inverse′) xs with ((f ⁻¹) ⁻¹-inverse) xs
    ... | p rewrite (f ⁻¹-involutive) (f ⁻¹ · xs) = p

    `⟨_↔_⟩-spec : ∀ {n} (i j : Fin n) (xs : Vec A n) → `⟨ i ↔ j ⟩ · xs ≡ ⟨ i ↔ j ⟩ xs
    `⟨_↔_⟩-spec zero    j       xs = `⟨0↔   j ⟩-spec xs
    `⟨_↔_⟩-spec (suc i) zero    xs = `⟨0↔1+ i ⟩-spec xs
    `⟨_↔_⟩-spec (suc i) (suc j) (x ∷ xs)
       rewrite `⟨ i ↔ j ⟩-spec xs = refl

module PermutationProperties {a : Level} where
    open PermutationSyntax
    open PermutationSemantics

    ⊛-dist-· : ∀ {n} {A : ★ a} (fs : Vec (Endo A) n) (f : Perm n) xs → (f · fs ⊛ f · xs) ≡ f · (fs ⊛ xs)
    ⊛-dist-· _       `id        _  = refl
    ⊛-dist-· fs      `0↔1       xs = ⊛-dist-0↔1 fs xs
    ⊛-dist-· (_ ∷ fs) (`tl f)   (_ ∷ xs) rewrite ⊛-dist-· fs f xs = refl
    ⊛-dist-· fs       (f `⁏ g)   xs rewrite ⊛-dist-· (f · fs) g (f · xs)
                                         | ⊛-dist-· fs f xs = refl

    ·-replicate : ∀ {n} {A : ★ a} (x : A) (f : Perm n) → f · replicate x ≡ replicate x
    ·-replicate x `id = refl
    ·-replicate x `0↔1 = refl
    ·-replicate x (`tl f) rewrite ·-replicate x f = refl
    ·-replicate x (f `⁏ g) rewrite ·-replicate x f | ·-replicate x g = refl

    private
        lem : ∀ {n} {A : ★ a} (fs : Vec (Endo A) n) f xs
              → fs ⊛ f · xs ≡ f · (f ⁻¹ · fs ⊛ xs)
        lem fs f xs rewrite sym (⊛-dist-· (f ⁻¹ · fs) f xs) | (f ⁻¹-inverse′) fs = refl

    ·-map : ∀ {n} {A : ★ a} (f : Endo A) g (xs : Vec A n) → map f (g · xs) ≡ g · map f xs
    ·-map f g xs rewrite sym (⊛-dist-· (replicate f) g xs) | ·-replicate f g = refl

    ⊕-dist-0↔1 : ∀ {n} (pad : Bits n) xs → 0↔1 pad ⊕ 0↔1 xs ≡ 0↔1 (pad ⊕ xs)
    ⊕-dist-0↔1 _           []          = refl
    ⊕-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = refl
    ⊕-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = refl

    -- TODO make use of ⊛-dist-·
    ⊕-dist-· : ∀ {n} (pad : Bits n) π xs → π · pad ⊕ π · xs ≡ π · (pad ⊕ xs)
    ⊕-dist-· fs      `id        xs = refl
    ⊕-dist-· fs      `0↔1       xs = ⊕-dist-0↔1 fs xs
    ⊕-dist-· (f ∷ fs) (`tl π)   (x ∷ xs) rewrite ⊕-dist-· fs π xs = refl
    ⊕-dist-· fs       (π₀ `⁏ π₁) xs rewrite ⊕-dist-· (π₀ · fs) π₁ (π₀ · xs)
                                         | ⊕-dist-· fs π₀ xs = refl

private
  module Unused where
    module Foo where
    {-
       WRONG
        ⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
        ⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

        ⟨0↔⟩-spec : ∀ {n a} {A : ★ a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
        ⟨0↔⟩-spec _ _ = ≡.refl
        -}

    ⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    ⟨0↔_⟩′ {zero}  i xs = xs
    ⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

    -- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
    ⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    ⟨ zero  ↔+1⟩ = 0↔1
    ⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

    ⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : ★ a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩ {A = A}
    ⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = refl
    ⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = refl

    -- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
    --           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
    rot-up-to : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    rot-up-to zero    = id
    rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

    -- Inverse of rot-up-to
    rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : ★ a} → Vec A n → Vec A n
    rot⁻¹-up-to zero    = id
    rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

    rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : ★ a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
    rot⁻¹-up-to∘rot-up-to zero            _ = refl
    rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = refl
    rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = refl


NaPa: Remove broken import

NaPa: Remove broken import

{-# OPTIONS --universe-polymorphism #-}
module NaPa.LogicalRelation where

import Level as L
open import Irrelevance
open import Data.Nat.NP hiding (_⊔_) renaming (_+_ to _+ℕ_; _≤_ to _≤ℕ_; _≤?_ to _≤?ℕ_; _<_ to _<ℕ_
                                              ;module == to ==ℕ; _==_ to _==ℕ_)
open import Data.Nat.Logical renaming (_≟_ to _≟ℕ_; _⟦+⟧_ to _⟦+ℕ⟧_)
open import Data.Nat.Properties as Nat
open import Data.Empty
open import Data.Unit
open import Data.Maybe.NP
open import Data.Bool.NP hiding (_==_)
open import Data.Two.Logical
open import Data.Sum.NP
open import Data.Product.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)
open ≡.≡-Reasoning
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.NP
open import Relation.Binary.Logical
open import Function
open import Function.Equality as ⟶≡ using (_⟶_; _⟨$⟩_)
open import Function.Injection.NP using (Injection; Injective; module
    Injection; _∈_)
open import NaPa hiding (_∈_)

private
  module Inj = Injection
  module ℕs = Setoid ⟦ℕ⟧-setoid
  module ==ℕs = Setoid ==ℕ.setoid
  module ℕe = Equality ⟦ℕ⟧-equality

_⟨$⟩ᵢ_ : ∀ {f₁ f₂ t₁ t₂}
           {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
         → Injection From To → Setoid.Carrier From → Setoid.Carrier To
_⟨$⟩ᵢ_ = ⟶≡._⟨$⟩_ ∘ Inj.to -- inj x = Inj.to inj ⟨$⟩ x

==ℕ-dec : ∀ x y → ⟦𝟚⟧ ⌊ x ≟ℕ y ⌋ (x ==ℕ y)
==ℕ-dec x y with x ≟ℕ y
... | yes p = ⟦1₂⟧′ (==ℕs.reflexive (ℕe.to-propositional p))
... | no ¬p = ⟦0₂⟧′ (T'¬'not (¬p ∘ ℕs.reflexive ∘ ==ℕ.sound _ _))

⟦dec⟧ : ∀ {P Q : Set} (decP : Dec P) (decQ : Dec Q) → (P → Q) → (Q → P) → ⟦𝟚⟧ ⌊ decP ⌋ ⌊ decQ ⌋
⟦dec⟧ (yes _) (yes _) _ _ = ⟦1₂⟧
⟦dec⟧ (no  _) (no  _) _ _ = ⟦0₂⟧
⟦dec⟧ (yes p) (no ¬q) f _ = ⊥-elim (¬q (f p))
⟦dec⟧ (no ¬p) (yes q) _ g = ⊥-elim (¬p (g q))

⟦World⟧ : (α₁ α₂ : World) → Set
⟦World⟧ = Injection on Nm

-- dup with NotSoFresh.LogicalRelation
⟦WorldPred⟧ : (P₁ P₂ : Pred L.zero World) → Set₁
⟦WorldPred⟧ = ⟦Pred⟧ _ ⟦World⟧

⟦WorldRel⟧ : (R₁ R₂ : Rel World L.zero) → Set₁
⟦WorldRel⟧ = ⟦Rel⟧ ⟦World⟧ L.zero

_⟦↑1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _↑1 _↑1
_⟦↑1⟧ {α₁} {α₂} αᵣ = record { to = to; injective = to-inj } where
  to : Nm (α₁ ↑1) ⟶ Nm (α₂ ↑1)
  to = Name→-to-Nm⟶ (protect↑1 (_⟨$⟩ᵢ_ αᵣ))
  to-inj : Injective to
  to-inj {zero  , _} {zero  , _} zero    = zero
  to-inj {suc _ , _} {suc _ , _} (suc e) = suc (Inj.injective αᵣ e)
  to-inj {suc _ , _} {zero  , _} ()
  to-inj {zero  , _} {suc _ , _} ()

_⟦+1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _+1 _+1
_⟦+1⟧ {α₁} {α₂} αᵣ = record { to = to; injective = inj } where
  to : Nm (α₁ +1) ⟶ Nm (α₂ +1)
  to = Name→-to-Nm⟶ (λ x → sucᴺ (αᵣ ⟨$⟩ᵢ (predᴺ x)))
  inj : Injective to
  inj {zero  , _} {zero  , _} _       = zero
  inj {suc _ , _} {suc _ , _} (suc e) = suc (Inj.injective αᵣ e)
  inj {suc _ , _} {zero  , ()} _
  inj {zero  , ()} {suc _ , _} _

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

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

⟦Name⟧ : ⟦Pred⟧ L.zero ⟦World⟧ Name Name
⟦Name⟧ αᵣ x₁ x₂ = ( x₁ , x₂ ) ∈ αᵣ

⟦Name⟧≡ : ⟦WorldPred⟧ Name Name
⟦Name⟧≡ αᵣ x₁ x₂ = αᵣ ⟨$⟩ᵢ x₁ ≡ x₂

⟦ø⟧ : ⟦World⟧ ø ø
⟦ø⟧ = record { to = Name→-to-Nm⟶ Nameø-elim
             ; injective = λ{x} → Nameø-elim x }

_⟦==ᴺ⟧_ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
_⟦==ᴺ⟧_ αᵣ {_} {x₂} xᵣ {_} {y₂} yᵣ = helper (≡ᴺ⇒≡ {_} {_} {x₂} xᵣ) (≡ᴺ⇒≡ {_} {_} {y₂} yᵣ) where
  helper : (⟦Name⟧≡ αᵣ ⟦→⟧ ⟦Name⟧≡ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
  helper {x} ≡.refl {y} ≡.refl =
       x ==ᴺ y       ≈⟨ sym (==ℕ-dec _ _) ⟩
       ⌊ x ≟ᴺ y ⌋   ≈⟨ ⟦dec⟧ (x ≟ᴺ y) (x′ ≟ᴺ y′) (⟶≡.cong (Inj.to αᵣ)) (Inj.injective αᵣ) ⟩
       ⌊ x′ ≟ᴺ y′ ⌋ ≈⟨ ==ℕ-dec _ _ ⟩
       x′ ==ᴺ y′ ∎
    where
      x′ = αᵣ ⟨$⟩ᵢ x
      y′ = αᵣ ⟨$⟩ᵢ y
      open ⟦𝟚⟧-Props using (sym)
      open ⟦𝟚⟧-Reasoning

⟦zeroᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) zeroᴺ zeroᴺ
⟦zeroᴺ⟧ _ = zero

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

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

⟦predᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ αᵣ) predᴺ predᴺ
⟦predᴺ⟧ _ = ⟦ℕ⟧-cong (λ x → x ∸ 1)

⟦addᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) addᴺ addᴺ
⟦addᴺ⟧ _ zero x = x
⟦addᴺ⟧ {α₁} {α₂} αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} x
   = ℕ.suc (name ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟨$⟩ᵢ (k₁ +ℕ name x₁ , _{-p-})))
   ≈⟨ ≡ᴺ-⟦ℕ⟧-cong (λ x → suc (name ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟨$⟩ᵢ x))) ℕe.refl ⟩
     suc (name ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟨$⟩ᵢ (k₁ +ℕ name x₁ , _{-q-})))
   ≈⟨ suc (⟦addᴺ⟧ αᵣ kᵣ {x₁} {x₂} x) ⟩
     suc (k₂ +ℕ name x₂)
   ∎ where open ⟦ℕ⟧-Reasoning

⟦subtractᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) ⟦→⟧ ⟦Name⟧ αᵣ) subtractᴺ subtractᴺ
⟦subtractᴺ⟧ _ zero x = x
⟦subtractᴺ⟧ {α₁} {α₂} αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} xᵣ
   = name (αᵣ ⟨$⟩ᵢ (name x₁ ∸ suc k₁ , _{-p-}))
   ≈⟨ ≡-⟦ℕ⟧-cong (λ x → name (αᵣ ⟨$⟩ᵢ x)) (name-injective (≡.sym (∸-+-assoc (name x₁) 1 k₁))) ⟩
      name (αᵣ ⟨$⟩ᵢ (name x₁ ∸ 1 ∸ k₁ , _{-r-}))
   ≈⟨ ⟦subtractᴺ⟧ αᵣ kᵣ {predᴺ x₁} {predᴺ x₂} (⟦predᴺ⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) {x₁} {x₂} xᵣ)  ⟩
      (name x₂ ∸ 1) ∸ k₂
   ≈⟨ ℕe.reflexive (∸-+-assoc (name x₂) 1 k₂) ⟩
      name x₂ ∸ suc k₂
   ∎ where open ⟦ℕ⟧-Reasoning

⟦cmpᴺ-bool⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦𝟚⟧) cmpᴺ-bool cmpᴺ-bool
⟦cmpᴺ-bool⟧ αᵣ kᵣ {x₁} {x₂} xᵣ = helper kᵣ {x₁} {x₂} (≡ᴺ⇒≡ xᵣ) where
  helper : (⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧≡ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦𝟚⟧) cmpᴺ-bool cmpᴺ-bool
  helper zero                   ≡.refl  = ⟦0₂⟧
  helper (suc kᵣ) {zero  , _ }  ≡.refl  = ⟦1₂⟧
  helper (suc kᵣ) {suc x , pf₁} ≡.refl  = helper kᵣ {x , pf₁} ≡.refl

⟦easy-cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑ kᵣ ⟧) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
             ) easy-cmpᴺ easy-cmpᴺ
⟦easy-cmpᴺ⟧ αᵣ kᵣ {x₁} {x₂} xᵣ = helper kᵣ {x₁} {x₂} (≡ᴺ⇒≡ xᵣ) where
  helper : (⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧≡ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑ kᵣ ⟧) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) easy-cmpᴺ easy-cmpᴺ
  helper zero                             ≡.refl = inj₂ (≡ᴺ-⟦ℕ⟧-cong (λ x → name (αᵣ ⟨$⟩ᵢ x)) ℕe.refl)
  helper (suc kᵣ)           {zero  , _ }  ≡.refl = inj₁ zero
  helper (suc {k₁} {k₂} kᵣ) {suc x , pf₁} ≡.refl
    = ⟦map⟧ _ _ _ _ suc suc (helper kᵣ {x , pf₁} ≡.refl)

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

⟦protect↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧
           (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) ⟦→⟧ (⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧))) protect↑1 protect↑1
⟦protect↑1⟧ {α₁} {α₂} αᵣ {β₁} {β₂} βᵣ {f₁} {f₂} fᵣ {x₁} {x₂} xᵣ = helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ) where
   helper : (⟦Name⟧≡ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (protect↑1 f₁) (protect↑1 f₂)
   helper {zero ,  _}  ≡.refl = zero
   helper {suc x , pf} ≡.refl = suc (fᵣ ℕe.refl)

_⟦⊆⟧b_ : ⟦WorldRel⟧ _⊆_ _⊆_
_⟦⊆⟧b_ αᵣ βᵣ α⊆β₁ α⊆β₂
  = (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) (coerceᴺ α⊆β₁) (coerceᴺ α⊆β₂)

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

-- this is the start of an experimentation to see if the issue with ⟦dropName⟧ is due
-- to implicit lambdas.
_⟦⊆⟧e_ : ⟦WorldRel⟧ _⊆_ _⊆_
_⟦⊆⟧e_ αᵣ βᵣ α⊆β₁ α⊆β₂
  = (⟦Name⟧ αᵣ ⟦→⟧e ⟦Name⟧ βᵣ) (coerceᴺ α⊆β₁) (coerceᴺ α⊆β₂)

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

⟦⊆-trans⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ γᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                  αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (βᵣ ⟦⊆⟧ γᵣ ⟦→⟧ (αᵣ ⟦⊆⟧ γᵣ))) ⊆-trans ⊆-trans
⟦⊆-trans⟧ _ _ _ {_} {f₂} f g = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → un⟦⊆⟧ g {_} {coerceᴺ 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ø⟧ {_ , ()}

⟦⊆-cong-↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-cong-↑1 ⊆-cong-↑1
⟦⊆-cong-↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-cong-↑1 α⊆β₁)) (coerceᴺ (⊆-cong-↑1 α⊆β₂))
  helper {zero  , _} ≡.refl = zero
  helper {suc x , p} ≡.refl = suc (un⟦⊆⟧ α⊆βᵣ {x , p} {αᵣ ⟨$⟩ᵢ (x , p)} ℕe.refl)

⟦⊆-cong-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧)) ⊆-cong-+1 ⊆-cong-+1
⟦⊆-cong-+1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦+1⟧)) (coerceᴺ (⊆-cong-+1 α⊆β₁)) (coerceᴺ (⊆-cong-+1 α⊆β₂))
  helper {zero  , ()} _
  helper {suc x , p} ≡.refl = suc (un⟦⊆⟧ α⊆βᵣ {x , p} {αᵣ ⟨$⟩ᵢ (x , p)} ℕe.refl)

⟦⊆-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (αᵣ ⟦↑1⟧)) ⊆-+1↑1 ⊆-+1↑1
⟦⊆-+1↑1⟧ αᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) (coerceᴺ ⊆-+1↑1) (coerceᴺ ⊆-+1↑1)
  helper {zero  , ()} _
  helper {suc x , p} ≡.refl = suc ℕe.refl

⟦⊆-ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦ø⟧ ⟦⊆⟧ αᵣ) ⊆-ø ⊆-ø
⟦⊆-ø⟧ αᵣ = mk⟦⊆⟧ (λ {η₁} {η₂} η → helper {η₁} {η₂} η) where
   helper : (⟦ø⟧ ⟦⊆⟧b αᵣ) ⊆-ø ⊆-ø
   helper {_ , ()}

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

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

⟦⊆-unctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-unctx-+1↑1 ⊆-unctx-+1↑1
⟦⊆-unctx-+1↑1⟧ _ _ α+⊆β↑ᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → ⟦ℕ⟧-cong (λ x → x ∸ 1) (un⟦⊆⟧ α+⊆β↑ᵣ {sucᴺ x₁} {sucᴺ x₂} (suc xᵣ)))

⟦α⊆ø→α+1⊆ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ ⟦ø⟧ ⟦→⟧ αᵣ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧) α⊆ø→α+1⊆ø α⊆ø→α+1⊆ø
⟦α⊆ø→α+1⊆ø⟧ _ {α⊆ø} _ = mk⟦⊆⟧ (λ {x} _ → Name-elim α⊆ø (predᴺ x))

⟦α+1⊆ø→α⊆ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧ ⟦→⟧ αᵣ ⟦⊆⟧ ⟦ø⟧) α+1⊆ø→α⊆ø α+1⊆ø→α⊆ø
⟦α+1⊆ø→α⊆ø⟧ _ {α+1⊆ø} _ = mk⟦⊆⟧ (λ {x} _ → Name-elim α+1⊆ø (sucᴺ x))

-- not primitive

⟦predᴺ?⟧-core : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) x
                    → ⟦Maybe⟧ (⟦Name⟧ αᵣ) (predᴺ? x) (predᴺ? (protect↑1 (_⟨$⟩ᵢ_ αᵣ) x))
⟦predᴺ?⟧-core _  (zero  , _) = ⟦nothing⟧
⟦predᴺ?⟧-core αᵣ (suc _ , _) = ⟦just⟧ (⟶≡.cong (Inj.to αᵣ) ℕe.refl)

⟦predᴺ?⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Maybe⟧ (⟦Name⟧ αᵣ)) predᴺ? predᴺ?
⟦predᴺ?⟧ {_} {α₂} αᵣ {x₁} {x₂} xᵣ = helper {x₂} (≡ᴺ⇒≡ xᵣ)
    -- BUG: the 'with' notation failed here
  where helper : ∀ {x₂} (eq : protect↑1 (_⟨$⟩ᵢ_ αᵣ) x₁ ≡ x₂) → ⟦Maybe⟧ (⟦Name⟧ αᵣ) (predᴺ? x₁) (predᴺ? x₂)
        helper ≡.refl = ⟦predᴺ?⟧-core αᵣ x₁

⟦⊆-ctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-ctx-+1↑1 ⊆-ctx-+1↑1
⟦⊆-ctx-+1↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-ctx-+1↑1 α⊆β₁)) (coerceᴺ (⊆-ctx-+1↑1 α⊆β₂))
  helper {zero  , ()} _
  helper {suc x , p} ≡.refl = suc (un⟦⊆⟧ α⊆βᵣ {x , p} {αᵣ ⟨$⟩ᵢ (x , p)} ℕe.refl)

⟦¬Name⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ ⟦ø⟧ ⟦→⟧ (⟦¬⟧(⟦Name⟧ αᵣ))) ¬Name ¬Name
⟦¬Name⟧ _ {α⊆ø₁} _ {x₁} _ = Name-elim α⊆ø₁ x₁

⟦⊆-cong-+⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟦⊆⟧ (βᵣ ⟦+ᵂ⟧ kᵣ)))) ⊆-cong-+ ⊆-cong-+
⟦⊆-cong-+⟧ _ _ α⊆βᵣ zero    = α⊆βᵣ
⟦⊆-cong-+⟧ _ _ α⊆βᵣ (suc kᵣ) = ⟦⊆-cong-+1⟧ _ _ (⟦⊆-cong-+⟧ _ _ α⊆βᵣ kᵣ)

⟦⊆-+-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟦⊆⟧ (βᵣ ⟦+ᵂ⟧ kᵣ)) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-+-inj ⊆-+-inj
⟦⊆-+-inj⟧ _ _ zero    α⊆βᵣ = α⊆βᵣ
⟦⊆-+-inj⟧ _ _ (suc kᵣ) α⊆βᵣ = ⟦⊆-+-inj⟧ _ _ kᵣ (⟦⊆-+1-inj⟧ _ _ α⊆βᵣ)

⟦⊆-assoc-+′⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟨ k₁ᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟨ k₂ᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                 (αᵣ ⟦+ᵂ⟧ (k₂ᵣ ⟦+ℕ⟧ k₁ᵣ)) ⟦⊆⟧ ((βᵣ ⟦+ᵂ⟧ k₁ᵣ) ⟦+ᵂ⟧ k₂ᵣ)))) ⊆-assoc-+′ ⊆-assoc-+′
⟦⊆-assoc-+′⟧ _ _ base k₁ zero      = ⟦⊆-cong-+⟧ _ _ base k₁
⟦⊆-assoc-+′⟧ _ _ base k₁ (suc k₂)  = ⟦⊆-cong-+1⟧ _ _ (⟦⊆-assoc-+′⟧ _ _ base k₁ k₂)

{-# OPTIONS --universe-polymorphism #-}
module NaPa.LogicalRelation where

import Level as L
open import Abstractor
open import Irrelevance
open import Data.Nat.NP hiding (_⊔_) renaming (_+_ to _+ℕ_; _≤_ to _≤ℕ_; _≤?_ to _≤?ℕ_; _<_ to _<ℕ_
                                              ;module == to ==ℕ; _==_ to _==ℕ_)
open import Data.Nat.Logical renaming (_≟_ to _≟ℕ_; _⟦+⟧_ to _⟦+ℕ⟧_)
open import Data.Nat.Properties as Nat
open import Data.Empty
open import Data.Unit
open import Data.Maybe.NP
open import Data.Bool.NP hiding (_==_)
open import Data.Two.Logical
open import Data.Sum.NP
open import Data.Product.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)
open ≡.≡-Reasoning
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.NP
open import Relation.Binary.Logical
open import Function
open import Function.Equality as ⟶≡ using (_⟶_; _⟨$⟩_)
open import Function.Injection.NP using (Injection; Injective; module
    Injection; _∈_)
open import NaPa hiding (_∈_)

private
  module Inj = Injection
  module ℕs = Setoid ⟦ℕ⟧-setoid
  module ==ℕs = Setoid ==ℕ.setoid
  module ℕe = Equality ⟦ℕ⟧-equality

_⟨$⟩ᵢ_ : ∀ {f₁ f₂ t₁ t₂}
           {From : Setoid f₁ f₂} {To : Setoid t₁ t₂}
         → Injection From To → Setoid.Carrier From → Setoid.Carrier To
_⟨$⟩ᵢ_ = ⟶≡._⟨$⟩_ ∘ Inj.to -- inj x = Inj.to inj ⟨$⟩ x

==ℕ-dec : ∀ x y → ⟦𝟚⟧ ⌊ x ≟ℕ y ⌋ (x ==ℕ y)
==ℕ-dec x y with x ≟ℕ y
... | yes p = ⟦1₂⟧′ (==ℕs.reflexive (ℕe.to-propositional p))
... | no ¬p = ⟦0₂⟧′ (T'¬'not (¬p ∘ ℕs.reflexive ∘ ==ℕ.sound _ _))

⟦dec⟧ : ∀ {P Q : Set} (decP : Dec P) (decQ : Dec Q) → (P → Q) → (Q → P) → ⟦𝟚⟧ ⌊ decP ⌋ ⌊ decQ ⌋
⟦dec⟧ (yes _) (yes _) _ _ = ⟦1₂⟧
⟦dec⟧ (no  _) (no  _) _ _ = ⟦0₂⟧
⟦dec⟧ (yes p) (no ¬q) f _ = ⊥-elim (¬q (f p))
⟦dec⟧ (no ¬p) (yes q) _ g = ⊥-elim (¬p (g q))

⟦World⟧ : (α₁ α₂ : World) → Set
⟦World⟧ = Injection on Nm

-- dup with NotSoFresh.LogicalRelation
⟦WorldPred⟧ : (P₁ P₂ : Pred L.zero World) → Set₁
⟦WorldPred⟧ = ⟦Pred⟧ _ ⟦World⟧

⟦WorldRel⟧ : (R₁ R₂ : Rel World L.zero) → Set₁
⟦WorldRel⟧ = ⟦Rel⟧ ⟦World⟧ L.zero

_⟦↑1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _↑1 _↑1
_⟦↑1⟧ {α₁} {α₂} αᵣ = record { to = to; injective = to-inj } where
  to : Nm (α₁ ↑1) ⟶ Nm (α₂ ↑1)
  to = Name→-to-Nm⟶ (protect↑1 (_⟨$⟩ᵢ_ αᵣ))
  to-inj : Injective to
  to-inj {zero  , _} {zero  , _} zero    = zero
  to-inj {suc _ , _} {suc _ , _} (suc e) = suc (Inj.injective αᵣ e)
  to-inj {suc _ , _} {zero  , _} ()
  to-inj {zero  , _} {suc _ , _} ()

_⟦+1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _+1 _+1
_⟦+1⟧ {α₁} {α₂} αᵣ = record { to = to; injective = inj } where
  to : Nm (α₁ +1) ⟶ Nm (α₂ +1)
  to = Name→-to-Nm⟶ (λ x → sucᴺ (αᵣ ⟨$⟩ᵢ (predᴺ x)))
  inj : Injective to
  inj {zero  , _} {zero  , _} _       = zero
  inj {suc _ , _} {suc _ , _} (suc e) = suc (Inj.injective αᵣ e)
  inj {suc _ , _} {zero  , ()} _
  inj {zero  , ()} {suc _ , _} _

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

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

⟦Name⟧ : ⟦Pred⟧ L.zero ⟦World⟧ Name Name
⟦Name⟧ αᵣ x₁ x₂ = ( x₁ , x₂ ) ∈ αᵣ

⟦Name⟧≡ : ⟦WorldPred⟧ Name Name
⟦Name⟧≡ αᵣ x₁ x₂ = αᵣ ⟨$⟩ᵢ x₁ ≡ x₂

⟦ø⟧ : ⟦World⟧ ø ø
⟦ø⟧ = record { to = Name→-to-Nm⟶ Nameø-elim
             ; injective = λ{x} → Nameø-elim x }

_⟦==ᴺ⟧_ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
_⟦==ᴺ⟧_ αᵣ {_} {x₂} xᵣ {_} {y₂} yᵣ = helper (≡ᴺ⇒≡ {_} {_} {x₂} xᵣ) (≡ᴺ⇒≡ {_} {_} {y₂} yᵣ) where
  helper : (⟦Name⟧≡ αᵣ ⟦→⟧ ⟦Name⟧≡ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
  helper {x} ≡.refl {y} ≡.refl =
       x ==ᴺ y       ≈⟨ sym (==ℕ-dec _ _) ⟩
       ⌊ x ≟ᴺ y ⌋   ≈⟨ ⟦dec⟧ (x ≟ᴺ y) (x′ ≟ᴺ y′) (⟶≡.cong (Inj.to αᵣ)) (Inj.injective αᵣ) ⟩
       ⌊ x′ ≟ᴺ y′ ⌋ ≈⟨ ==ℕ-dec _ _ ⟩
       x′ ==ᴺ y′ ∎
    where
      x′ = αᵣ ⟨$⟩ᵢ x
      y′ = αᵣ ⟨$⟩ᵢ y
      open ⟦𝟚⟧-Props using (sym)
      open ⟦𝟚⟧-Reasoning

⟦zeroᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) zeroᴺ zeroᴺ
⟦zeroᴺ⟧ _ = zero

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

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

⟦predᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ αᵣ) predᴺ predᴺ
⟦predᴺ⟧ _ = ⟦ℕ⟧-cong (λ x → x ∸ 1)

⟦addᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) addᴺ addᴺ
⟦addᴺ⟧ _ zero x = x
⟦addᴺ⟧ {α₁} {α₂} αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} x
   = ℕ.suc (name ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟨$⟩ᵢ (k₁ +ℕ name x₁ , _{-p-})))
   ≈⟨ ≡ᴺ-⟦ℕ⟧-cong (λ x → suc (name ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟨$⟩ᵢ x))) ℕe.refl ⟩
     suc (name ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟨$⟩ᵢ (k₁ +ℕ name x₁ , _{-q-})))
   ≈⟨ suc (⟦addᴺ⟧ αᵣ kᵣ {x₁} {x₂} x) ⟩
     suc (k₂ +ℕ name x₂)
   ∎ where open ⟦ℕ⟧-Reasoning

⟦subtractᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) ⟦→⟧ ⟦Name⟧ αᵣ) subtractᴺ subtractᴺ
⟦subtractᴺ⟧ _ zero x = x
⟦subtractᴺ⟧ {α₁} {α₂} αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} xᵣ
   = name (αᵣ ⟨$⟩ᵢ (name x₁ ∸ suc k₁ , _{-p-}))
   ≈⟨ ≡-⟦ℕ⟧-cong (λ x → name (αᵣ ⟨$⟩ᵢ x)) (name-injective (≡.sym (∸-+-assoc (name x₁) 1 k₁))) ⟩
      name (αᵣ ⟨$⟩ᵢ (name x₁ ∸ 1 ∸ k₁ , _{-r-}))
   ≈⟨ ⟦subtractᴺ⟧ αᵣ kᵣ {predᴺ x₁} {predᴺ x₂} (⟦predᴺ⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) {x₁} {x₂} xᵣ)  ⟩
      (name x₂ ∸ 1) ∸ k₂
   ≈⟨ ℕe.reflexive (∸-+-assoc (name x₂) 1 k₂) ⟩
      name x₂ ∸ suc k₂
   ∎ where open ⟦ℕ⟧-Reasoning

⟦cmpᴺ-bool⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦𝟚⟧) cmpᴺ-bool cmpᴺ-bool
⟦cmpᴺ-bool⟧ αᵣ kᵣ {x₁} {x₂} xᵣ = helper kᵣ {x₁} {x₂} (≡ᴺ⇒≡ xᵣ) where
  helper : (⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧≡ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦𝟚⟧) cmpᴺ-bool cmpᴺ-bool
  helper zero                   ≡.refl  = ⟦0₂⟧
  helper (suc kᵣ) {zero  , _ }  ≡.refl  = ⟦1₂⟧
  helper (suc kᵣ) {suc x , pf₁} ≡.refl  = helper kᵣ {x , pf₁} ≡.refl

⟦easy-cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑ kᵣ ⟧) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
             ) easy-cmpᴺ easy-cmpᴺ
⟦easy-cmpᴺ⟧ αᵣ kᵣ {x₁} {x₂} xᵣ = helper kᵣ {x₁} {x₂} (≡ᴺ⇒≡ xᵣ) where
  helper : (⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧≡ (αᵣ ⟦↑ kᵣ ⟧) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑ kᵣ ⟧) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) easy-cmpᴺ easy-cmpᴺ
  helper zero                             ≡.refl = inj₂ (≡ᴺ-⟦ℕ⟧-cong (λ x → name (αᵣ ⟨$⟩ᵢ x)) ℕe.refl)
  helper (suc kᵣ)           {zero  , _ }  ≡.refl = inj₁ zero
  helper (suc {k₁} {k₂} kᵣ) {suc x , pf₁} ≡.refl
    = ⟦map⟧ _ _ _ _ suc suc (helper kᵣ {x , pf₁} ≡.refl)

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

⟦protect↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧
           (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) ⟦→⟧ (⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧))) protect↑1 protect↑1
⟦protect↑1⟧ {α₁} {α₂} αᵣ {β₁} {β₂} βᵣ {f₁} {f₂} fᵣ {x₁} {x₂} xᵣ = helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ) where
   helper : (⟦Name⟧≡ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (protect↑1 f₁) (protect↑1 f₂)
   helper {zero ,  _}  ≡.refl = zero
   helper {suc x , pf} ≡.refl = suc (fᵣ ℕe.refl)

_⟦⊆⟧b_ : ⟦WorldRel⟧ _⊆_ _⊆_
_⟦⊆⟧b_ αᵣ βᵣ α⊆β₁ α⊆β₂
  = (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) (coerceᴺ α⊆β₁) (coerceᴺ α⊆β₂)

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

-- this is the start of an experimentation to see if the issue with ⟦dropName⟧ is due
-- to implicit lambdas.
_⟦⊆⟧e_ : ⟦WorldRel⟧ _⊆_ _⊆_
_⟦⊆⟧e_ αᵣ βᵣ α⊆β₁ α⊆β₂
  = (⟦Name⟧ αᵣ ⟦→⟧e ⟦Name⟧ βᵣ) (coerceᴺ α⊆β₁) (coerceᴺ α⊆β₂)

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

⟦⊆-trans⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ γᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                  αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (βᵣ ⟦⊆⟧ γᵣ ⟦→⟧ (αᵣ ⟦⊆⟧ γᵣ))) ⊆-trans ⊆-trans
⟦⊆-trans⟧ _ _ _ {_} {f₂} f g = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → un⟦⊆⟧ g {_} {coerceᴺ 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ø⟧ {_ , ()}

⟦⊆-cong-↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-cong-↑1 ⊆-cong-↑1
⟦⊆-cong-↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-cong-↑1 α⊆β₁)) (coerceᴺ (⊆-cong-↑1 α⊆β₂))
  helper {zero  , _} ≡.refl = zero
  helper {suc x , p} ≡.refl = suc (un⟦⊆⟧ α⊆βᵣ {x , p} {αᵣ ⟨$⟩ᵢ (x , p)} ℕe.refl)

⟦⊆-cong-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧)) ⊆-cong-+1 ⊆-cong-+1
⟦⊆-cong-+1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦+1⟧)) (coerceᴺ (⊆-cong-+1 α⊆β₁)) (coerceᴺ (⊆-cong-+1 α⊆β₂))
  helper {zero  , ()} _
  helper {suc x , p} ≡.refl = suc (un⟦⊆⟧ α⊆βᵣ {x , p} {αᵣ ⟨$⟩ᵢ (x , p)} ℕe.refl)

⟦⊆-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (αᵣ ⟦↑1⟧)) ⊆-+1↑1 ⊆-+1↑1
⟦⊆-+1↑1⟧ αᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) (coerceᴺ ⊆-+1↑1) (coerceᴺ ⊆-+1↑1)
  helper {zero  , ()} _
  helper {suc x , p} ≡.refl = suc ℕe.refl

⟦⊆-ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦ø⟧ ⟦⊆⟧ αᵣ) ⊆-ø ⊆-ø
⟦⊆-ø⟧ αᵣ = mk⟦⊆⟧ (λ {η₁} {η₂} η → helper {η₁} {η₂} η) where
   helper : (⟦ø⟧ ⟦⊆⟧b αᵣ) ⊆-ø ⊆-ø
   helper {_ , ()}

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

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

⟦⊆-unctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-unctx-+1↑1 ⊆-unctx-+1↑1
⟦⊆-unctx-+1↑1⟧ _ _ α+⊆β↑ᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → ⟦ℕ⟧-cong (λ x → x ∸ 1) (un⟦⊆⟧ α+⊆β↑ᵣ {sucᴺ x₁} {sucᴺ x₂} (suc xᵣ)))

⟦α⊆ø→α+1⊆ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ ⟦ø⟧ ⟦→⟧ αᵣ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧) α⊆ø→α+1⊆ø α⊆ø→α+1⊆ø
⟦α⊆ø→α+1⊆ø⟧ _ {α⊆ø} _ = mk⟦⊆⟧ (λ {x} _ → Name-elim α⊆ø (predᴺ x))

⟦α+1⊆ø→α⊆ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧ ⟦→⟧ αᵣ ⟦⊆⟧ ⟦ø⟧) α+1⊆ø→α⊆ø α+1⊆ø→α⊆ø
⟦α+1⊆ø→α⊆ø⟧ _ {α+1⊆ø} _ = mk⟦⊆⟧ (λ {x} _ → Name-elim α+1⊆ø (sucᴺ x))

-- not primitive

⟦predᴺ?⟧-core : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) x
                    → ⟦Maybe⟧ (⟦Name⟧ αᵣ) (predᴺ? x) (predᴺ? (protect↑1 (_⟨$⟩ᵢ_ αᵣ) x))
⟦predᴺ?⟧-core _  (zero  , _) = ⟦nothing⟧
⟦predᴺ?⟧-core αᵣ (suc _ , _) = ⟦just⟧ (⟶≡.cong (Inj.to αᵣ) ℕe.refl)

⟦predᴺ?⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Maybe⟧ (⟦Name⟧ αᵣ)) predᴺ? predᴺ?
⟦predᴺ?⟧ {_} {α₂} αᵣ {x₁} {x₂} xᵣ = helper {x₂} (≡ᴺ⇒≡ xᵣ)
    -- BUG: the 'with' notation failed here
  where helper : ∀ {x₂} (eq : protect↑1 (_⟨$⟩ᵢ_ αᵣ) x₁ ≡ x₂) → ⟦Maybe⟧ (⟦Name⟧ αᵣ) (predᴺ? x₁) (predᴺ? x₂)
        helper ≡.refl = ⟦predᴺ?⟧-core αᵣ x₁

⟦⊆-ctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-ctx-+1↑1 ⊆-ctx-+1↑1
⟦⊆-ctx-+1↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk⟦⊆⟧ (λ {x₁} {x₂} xᵣ → helper {x₁} {x₂} (≡ᴺ⇒≡ xᵣ)) where
  helper : (⟦Name⟧≡ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-ctx-+1↑1 α⊆β₁)) (coerceᴺ (⊆-ctx-+1↑1 α⊆β₂))
  helper {zero  , ()} _
  helper {suc x , p} ≡.refl = suc (un⟦⊆⟧ α⊆βᵣ {x , p} {αᵣ ⟨$⟩ᵢ (x , p)} ℕe.refl)

⟦¬Name⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ ⟦ø⟧ ⟦→⟧ (⟦¬⟧(⟦Name⟧ αᵣ))) ¬Name ¬Name
⟦¬Name⟧ _ {α⊆ø₁} _ {x₁} _ = Name-elim α⊆ø₁ x₁

⟦⊆-cong-+⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟦⊆⟧ (βᵣ ⟦+ᵂ⟧ kᵣ)))) ⊆-cong-+ ⊆-cong-+
⟦⊆-cong-+⟧ _ _ α⊆βᵣ zero    = α⊆βᵣ
⟦⊆-cong-+⟧ _ _ α⊆βᵣ (suc kᵣ) = ⟦⊆-cong-+1⟧ _ _ (⟦⊆-cong-+⟧ _ _ α⊆βᵣ kᵣ)

⟦⊆-+-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ((αᵣ ⟦+ᵂ⟧ kᵣ) ⟦⊆⟧ (βᵣ ⟦+ᵂ⟧ kᵣ)) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-+-inj ⊆-+-inj
⟦⊆-+-inj⟧ _ _ zero    α⊆βᵣ = α⊆βᵣ
⟦⊆-+-inj⟧ _ _ (suc kᵣ) α⊆βᵣ = ⟦⊆-+-inj⟧ _ _ kᵣ (⟦⊆-+1-inj⟧ _ _ α⊆βᵣ)

⟦⊆-assoc-+′⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟨ k₁ᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟨ k₂ᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                 (αᵣ ⟦+ᵂ⟧ (k₂ᵣ ⟦+ℕ⟧ k₁ᵣ)) ⟦⊆⟧ ((βᵣ ⟦+ᵂ⟧ k₁ᵣ) ⟦+ᵂ⟧ k₂ᵣ)))) ⊆-assoc-+′ ⊆-assoc-+′
⟦⊆-assoc-+′⟧ _ _ base k₁ zero      = ⟦⊆-cong-+⟧ _ _ base k₁
⟦⊆-assoc-+′⟧ _ _ base k₁ (suc k₂)  = ⟦⊆-cong-+1⟧ _ _ (⟦⊆-assoc-+′⟧ _ _ base k₁ k₂)


Agda: ≙-symm ↦ ≙-sym, for consistency with sym for ≡

Old-commit-hash: 590f75f6eea150a3f02693ff2ac470479b6a7cfe


Added automatic proofs.

Added automatic proofs.

------------------------------------------------------------------------------
-- The Booleans properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Data.Bool.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Bool
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Basic properties

postulate t&&x≡x : ∀ b → true && b ≡ b
{-# ATP prove t&&x≡x #-}

postulate f&&x≡f : ∀ b → false && b ≡ false
{-# ATP prove f&&x≡f #-}

&&-Bool : ∀ {a b} → Bool a → Bool b → Bool (a && b)
&&-Bool {b = b} btrue Bb = prf
  where postulate prf : Bool (true && b)
        {-# ATP prove prf #-}
&&-Bool {b = b} bfalse Bb = prf
  where postulate prf : Bool (false && b)
        {-# ATP prove prf #-}

not-Bool : ∀ {b} → Bool b → Bool (not b)
not-Bool btrue = prf
  where postulate prf : Bool (not true)
        {-# ATP prove prf #-}
not-Bool bfalse = prf
  where postulate prf : Bool (not false)
        {-# ATP prove prf #-}

&&-list₂-t : ∀ {a b} → Bool a → Bool b → a && b ≡ true → a ≡ true ∧ b ≡ true
&&-list₂-t btrue btrue   h = refl , refl
&&-list₂-t btrue bfalse  h = ⊥-elim (t≢f (trans (sym h) (t&&x≡x false)))
&&-list₂-t bfalse btrue  h = ⊥-elim (t≢f (trans (sym h) (f&&x≡f true)))
&&-list₂-t bfalse bfalse h = ⊥-elim (t≢f (trans (sym h) (f&&x≡f false)))

&&-list₂-t₁ : ∀ {a b} → Bool a → Bool b → a && b ≡ true → a ≡ true
&&-list₂-t₁ Ba Bb h = ∧-proj₁ (&&-list₂-t Ba Bb h)

&&-list₂-t₂ : ∀ {a b} → Bool a → Bool b → a && b ≡ true → b ≡ true
&&-list₂-t₂ Ba Bb h = ∧-proj₂ (&&-list₂-t Ba Bb h)

&&-list₄-some-f : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
                  a ≡ false ∨ b ≡ false ∨ c ≡ false ∨ d ≡ false →
                  a && b && c && d ≡ false
&&-list₄-some-f btrue Bb Bc Bd (inj₁ h) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue Bc Bd (inj₂ (inj₁ h)) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue Bd (inj₂ (inj₂ (inj₁ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue btrue (inj₂ (inj₂ (inj₂ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue bfalse (inj₂ (inj₂ (inj₂ h))) =
  trans (t&&x≡x (true && true && false))
        (trans (t&&x≡x (true && false)) (t&&x≡x false))
&&-list₄-some-f btrue btrue bfalse btrue (inj₂ (inj₂ (inj₁ h))) =
  trans (t&&x≡x (true && false && true))
        (trans (t&&x≡x (false && true)) (f&&x≡f true))
&&-list₄-some-f btrue btrue bfalse btrue (inj₂ (inj₂ (inj₂ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue bfalse bfalse (inj₂ (inj₂ h)) =
  trans (t&&x≡x (true && false && false))
        (trans (t&&x≡x (false && false)) (f&&x≡f false))
&&-list₄-some-f {c = c} {d} btrue bfalse Bc Bd (inj₂ h) =
  trans (t&&x≡x (false && c && d)) (f&&x≡f (c && d))
&&-list₄-some-f {b = b} {c} {d} bfalse Bb Bc Bd _ = f&&x≡f (b && c && d)

&&-list₄-t : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
             a && b && c && d ≡ true →
             a ≡ true ∧ b ≡ true ∧ c ≡ true ∧ d ≡ true
&&-list₄-t btrue btrue btrue btrue h = refl , refl , refl , refl
&&-list₄-t btrue btrue btrue bfalse h =
  ⊥-elim (t≢f
           (trans (sym h)
                  (&&-list₄-some-f btrue btrue btrue bfalse (inj₂ (inj₂ (inj₂ refl))))))
&&-list₄-t btrue btrue bfalse Bd h =
  ⊥-elim (t≢f
           (trans (sym h)
                  (&&-list₄-some-f btrue btrue bfalse Bd (inj₂ (inj₂ (inj₁ refl))))))
&&-list₄-t btrue bfalse Bc Bd h =
  ⊥-elim (t≢f
           (trans (sym h) (&&-list₄-some-f btrue bfalse Bc Bd (inj₂ (inj₁ refl)))))
&&-list₄-t bfalse Bb Bc Bd h =
  ⊥-elim (t≢f (trans (sym h) (&&-list₄-some-f bfalse Bb Bc Bd (inj₁ refl))))

&&-list₄-t₁ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → a ≡ true
&&-list₄-t₁ {a} Ba Bb Bc Bd h = prf
  where postulate prf : a ≡ true
        {-# ATP prove prf &&-list₄-t #-}

&&-list₄-t₂ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → b ≡ true
&&-list₄-t₂ {b = b} Ba Bb Bc Bd h = prf
  where postulate prf : b ≡ true
        {-# ATP prove prf &&-list₄-t #-}

&&-list₄-t₃ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → c ≡ true
&&-list₄-t₃ {c = c} Ba Bb Bc Bd h = prf
  where postulate prf : c ≡ true
        {-# ATP prove prf &&-list₄-t #-}

&&-list₄-t₄ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → d ≡ true
&&-list₄-t₄ {d = d} Ba Bb Bc Bd h = prf
  where postulate prf : d ≡ true
        {-# ATP prove prf &&-list₄-t #-}

x≢not-x : ∀ {b} → Bool b → b ≢ not b
x≢not-x btrue = prf
  where postulate prf : true ≡ not true → ⊥
        {-# ATP prove prf #-}
x≢not-x bfalse = prf
  where postulate prf : false ≡ not false → ⊥
        {-# ATP prove prf #-}

not-x≢x : ∀ {b} → Bool b → not b ≢ b
not-x≢x Bb h = x≢not-x Bb (sym h)

not-involutive : ∀ {b} → Bool b → not (not b) ≡ b
not-involutive btrue = prf
  where postulate prf : not (not true) ≡ true
        {-# ATP prove prf #-}
not-involutive bfalse = prf
  where postulate prf : not (not false) ≡ false
        {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Properties with inequalities

lt-Bool : ∀ {m n} → N m → N n → Bool (lt m n)
lt-Bool nzero nzero = prf
  where postulate prf : Bool (lt zero zero)
        {-# ATP prove prf #-}
lt-Bool nzero (nsucc {n} Nn) = prf
  where postulate prf : Bool (lt zero (succ₁ n))
        {-# ATP prove prf #-}
lt-Bool (nsucc {m} Nm) nzero = prf
  where postulate prf : Bool (lt (succ₁ m)  zero)
        {-# ATP prove prf #-}
lt-Bool (nsucc {m} Nm) (nsucc {n} Nn) = prf (lt-Bool Nm Nn)
  where postulate prf : Bool (lt m n) → Bool (lt (succ₁ m) (succ₁ n))
        {-# ATP prove prf #-}

le-Bool : ∀ {m n} → N m → N n → Bool (le m n)
le-Bool {n = n} nzero Nn = prf
  where postulate prf : Bool (le zero n)
        {-# ATP prove prf #-}
le-Bool (nsucc {m} Nm) nzero = prf
  where postulate prf : Bool (le (succ₁ m) zero)
        {-# ATP prove prf Sx≰0 #-}
le-Bool (nsucc {m} Nm) (nsucc {n} Nn) = prf (le-Bool Nm Nn)
  where postulate prf : Bool (le m n) → Bool (le (succ₁ m) (succ₁ n))
        {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- The Booleans properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Data.Bool.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Bool
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Basic properties

postulate t&&x≡x : ∀ b → true && b ≡ b
{-# ATP prove t&&x≡x #-}

postulate f&&x≡f : ∀ b → false && b ≡ false
{-# ATP prove f&&x≡f #-}

&&-Bool : ∀ {a b} → Bool a → Bool b → Bool (a && b)
&&-Bool {b = b} btrue Bb = prf
  where postulate prf : Bool (true && b)
        {-# ATP prove prf #-}
&&-Bool {b = b} bfalse Bb = prf
  where postulate prf : Bool (false && b)
        {-# ATP prove prf #-}

not-Bool : ∀ {b} → Bool b → Bool (not b)
not-Bool btrue = prf
  where postulate prf : Bool (not true)
        {-# ATP prove prf #-}
not-Bool bfalse = prf
  where postulate prf : Bool (not false)
        {-# ATP prove prf #-}

&&-list₂-t : ∀ {a b} → Bool a → Bool b → a && b ≡ true → a ≡ true ∧ b ≡ true
&&-list₂-t btrue btrue   h = refl , refl
&&-list₂-t btrue bfalse  h = ⊥-elim (t≢f (trans (sym h) (t&&x≡x false)))
&&-list₂-t bfalse btrue  h = ⊥-elim (t≢f (trans (sym h) (f&&x≡f true)))
&&-list₂-t bfalse bfalse h = ⊥-elim (t≢f (trans (sym h) (f&&x≡f false)))

&&-list₂-t₁ : ∀ {a b} → Bool a → Bool b → a && b ≡ true → a ≡ true
&&-list₂-t₁ Ba Bb h = ∧-proj₁ (&&-list₂-t Ba Bb h)

&&-list₂-t₂ : ∀ {a b} → Bool a → Bool b → a && b ≡ true → b ≡ true
&&-list₂-t₂ Ba Bb h = ∧-proj₂ (&&-list₂-t Ba Bb h)

&&-list₄-some-f : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
                  a ≡ false ∨ b ≡ false ∨ c ≡ false ∨ d ≡ false →
                  a && b && c && d ≡ false
&&-list₄-some-f btrue Bb Bc Bd (inj₁ h) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue Bc Bd (inj₂ (inj₁ h)) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue Bd (inj₂ (inj₂ (inj₁ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue btrue (inj₂ (inj₂ (inj₂ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue bfalse (inj₂ (inj₂ (inj₂ h))) =
  trans (t&&x≡x (true && true && false))
        (trans (t&&x≡x (true && false)) (t&&x≡x false))
&&-list₄-some-f btrue btrue bfalse btrue (inj₂ (inj₂ (inj₁ h))) =
  trans (t&&x≡x (true && false && true))
        (trans (t&&x≡x (false && true)) (f&&x≡f true))
&&-list₄-some-f btrue btrue bfalse btrue (inj₂ (inj₂ (inj₂ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue bfalse bfalse (inj₂ (inj₂ h)) =
  trans (t&&x≡x (true && false && false))
        (trans (t&&x≡x (false && false)) (f&&x≡f false))
&&-list₄-some-f {c = c} {d} btrue bfalse Bc Bd (inj₂ h) =
  trans (t&&x≡x (false && c && d)) (f&&x≡f (c && d))
&&-list₄-some-f {b = b} {c} {d} bfalse Bb Bc Bd _ = f&&x≡f (b && c && d)

&&-list₄-t : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
             a && b && c && d ≡ true →
             a ≡ true ∧ b ≡ true ∧ c ≡ true ∧ d ≡ true
&&-list₄-t btrue btrue btrue btrue h = refl , refl , refl , refl
&&-list₄-t btrue btrue btrue bfalse h =
  ⊥-elim (t≢f
           (trans (sym h)
                  (&&-list₄-some-f btrue btrue btrue bfalse (inj₂ (inj₂ (inj₂ refl))))))
&&-list₄-t btrue btrue bfalse Bd h =
  ⊥-elim (t≢f
           (trans (sym h)
                  (&&-list₄-some-f btrue btrue bfalse Bd (inj₂ (inj₂ (inj₁ refl))))))
&&-list₄-t btrue bfalse Bc Bd h =
  ⊥-elim (t≢f
           (trans (sym h) (&&-list₄-some-f btrue bfalse Bc Bd (inj₂ (inj₁ refl)))))
&&-list₄-t bfalse Bb Bc Bd h =
  ⊥-elim (t≢f (trans (sym h) (&&-list₄-some-f bfalse Bb Bc Bd (inj₁ refl))))

&&-list₄-t₁ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → a ≡ true
&&-list₄-t₁ Ba Bb Bc Bd h = ∧-proj₁ (&&-list₄-t Ba Bb Bc Bd h)

&&-list₄-t₂ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → b ≡ true
&&-list₄-t₂ Ba Bb Bc Bd h = ∧-proj₁ (∧-proj₂ (&&-list₄-t Ba Bb Bc Bd h))

&&-list₄-t₃ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → c ≡ true
&&-list₄-t₃ Ba Bb Bc Bd h =
  ∧-proj₁ (∧-proj₂ (∧-proj₂ (&&-list₄-t Ba Bb Bc Bd h)))

&&-list₄-t₄ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → d ≡ true
&&-list₄-t₄ Ba Bb Bc Bd h =
  ∧-proj₂ (∧-proj₂ (∧-proj₂ (&&-list₄-t Ba Bb Bc Bd h)))

x≢not-x : ∀ {b} → Bool b → b ≢ not b
x≢not-x btrue = prf
  where postulate prf : true ≡ not true → ⊥
        {-# ATP prove prf #-}
x≢not-x bfalse = prf
  where postulate prf : false ≡ not false → ⊥
        {-# ATP prove prf #-}

not-x≢x : ∀ {b} → Bool b → not b ≢ b
not-x≢x Bb h = x≢not-x Bb (sym h)

not-involutive : ∀ {b} → Bool b → not (not b) ≡ b
not-involutive btrue = prf
  where postulate prf : not (not true) ≡ true
        {-# ATP prove prf #-}
not-involutive bfalse = prf
  where postulate prf : not (not false) ≡ false
        {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Properties with inequalities

lt-Bool : ∀ {m n} → N m → N n → Bool (lt m n)
lt-Bool nzero nzero = prf
  where postulate prf : Bool (lt zero zero)
        {-# ATP prove prf #-}
lt-Bool nzero (nsucc {n} Nn) = prf
  where postulate prf : Bool (lt zero (succ₁ n))
        {-# ATP prove prf #-}
lt-Bool (nsucc {m} Nm) nzero = prf
  where postulate prf : Bool (lt (succ₁ m)  zero)
        {-# ATP prove prf #-}
lt-Bool (nsucc {m} Nm) (nsucc {n} Nn) = prf (lt-Bool Nm Nn)
  where postulate prf : Bool (lt m n) → Bool (lt (succ₁ m) (succ₁ n))
        {-# ATP prove prf #-}

le-Bool : ∀ {m n} → N m → N n → Bool (le m n)
le-Bool {n = n} nzero Nn = prf
  where postulate prf : Bool (le zero n)
        {-# ATP prove prf #-}
le-Bool (nsucc {m} Nm) nzero = prf
  where postulate prf : Bool (le (succ₁ m) zero)
        {-# ATP prove prf Sx≰0 #-}
le-Bool (nsucc {m} Nm) (nsucc {n} Nn) = prf (le-Bool Nm Nn)
  where postulate prf : Bool (le m n) → Bool (le (succ₁ m) (succ₁ n))
        {-# ATP prove prf #-}


Decouple syntax of semantics of proof-embedded changes
... by embedding the proof in the interpretation as opposed to
embedding them in the Δ-terms. Invalid programs are well-formed
terms now, but they may only denote the empty function.

Old-commit-hash: 4d82a603c0824b2e4c070a22ddb7ca78562be994

{-
The goal of this file is to make the domain of Δ types smaller
so as to be nearer to full abstraction and hopefully close
enough for the purpose of having explicit nil changes.
-}

module TaggedDeltaTypes where

open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

---------------------------------------------------------
-- Postulates: Extensionality and bag properties (#55) --
---------------------------------------------------------

postulate extensionality : Extensionality Level.zero Level.zero
-- Instead of:
-- open import Data.NatBag renaming
---  (map to mapBag ; empty to emptyBag ; update to updateBag)
-- open import Data.NatBag.Properties
postulate Bag : Set
postulate emptyBag : Bag
postulate mapBag : (ℕ → ℕ) → Bag → Bag
postulate _++_ : Bag → Bag → Bag
postulate _\\_ : Bag → Bag → Bag
infixr 5 _++_
infixl 9 _\\_
postulate b\\b=∅ : ∀ {b : Bag} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {b : Bag} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {b : Bag} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

----------------------------
-- Useful data structures --
----------------------------

record Quadruple
  (A : Set) (B : A → Set) (C : (a : A) → B a → Set)
  (D : (a : A) → (b : B a) → (c : C a b) → Set): Set where
  constructor cons
  field
    car   : A
    cadr  : B car
    caddr : C car cadr
    cdddr : D car cadr caddr

open Quadruple public

couple : Set → Set → Set
couple A B = Quadruple A (λ _ → B) (λ _ _ → ⊤) (λ _ _ _ → ⊤)

triple : Set → Set → Set → Set
triple A B C = Quadruple A (λ _ → B) (λ _ _ → C) (λ _ _ _ → ⊤)

------------------------
-- Syntax of programs --
------------------------

data Type : Set where
  nats : Type
  bags : Type
  _⇒_ : (σ τ : Type) → Type

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

data Var : Context → Type → Set where
  this : ∀ {τ Γ} → Var (τ • Γ) τ
  that : ∀ {σ τ Γ} → (x : Var Γ σ) → Var (τ • Γ) σ

data Term : Context -> Type -> Set where

  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  bag : ∀ {Γ} → (b : Bag) → Term Γ bags

  var : ∀ {τ Γ} → (x : Var Γ τ) → Term Γ τ
  abs : ∀ {σ τ Γ} → (t : Term (σ • Γ) τ) → Term Γ (σ ⇒ τ)
  app : ∀ {σ τ Γ} → (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) → Term Γ τ

  add : ∀ {Γ} → (s : Term Γ nats) → (t : Term Γ nats) → Term Γ nats
  map : ∀ {Γ} → (f : Term Γ (nats ⇒ nats)) → (b : Term Γ bags) →
    Term Γ bags

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ {∅} = ∅≼∅
Γ≼Γ {τ • Γ} = keep τ • Γ≼Γ {Γ}

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x
weaken subctx (bag b) = bag b
weaken subctx (add t₁ t₂) = add (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (map f b) = map (weaken subctx f) (weaken subctx b)

---------------------------
-- Semantics of programs --
---------------------------

record Meaning (Syntax : Set) {ℓ : Level.Level} : Set (Level.suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ nats ⟧Type = ℕ
⟦ bags ⟧Type = Bag
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

⟦_⟧Var : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ this ⟧Var (v • ρ) = v
⟦ that x ⟧Var (v • ρ) = ⟦ x ⟧Var ρ

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

identity-weakening : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
identity-weakening {∅} {∅} = refl
identity-weakening {τ • Γ} {v • ρ} =
  cong₂ _•_ {x = v} refl (identity-weakening {Γ} {ρ})

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n
⟦ bag b ⟧Term ρ = b
⟦ add m n ⟧Term ρ = ⟦ m ⟧Term ρ + ⟦ n ⟧Term ρ
⟦ map f b ⟧Term ρ = mapBag (⟦ f ⟧Term ρ) (⟦ b ⟧Term ρ)

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

_⟨$⟩_ : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
_⟨$⟩_ = cong₂ (λ x y → x y)

-- infix 0 $ in Haskell
infixl 0 _⟨$⟩_

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = weaken-sound t₁ ρ ⟨$⟩ weaken-sound t₂ ρ
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (bag b) ρ = refl
weaken-sound (add m n) ρ = cong₂ _+_ (weaken-sound m ρ) (weaken-sound n ρ)
weaken-sound (map f b) ρ =
  cong₂ mapBag (weaken-sound f ρ) (weaken-sound b ρ)

-----------------------
-- Syntax of changes --
-----------------------

-- Validity proofs are not literally embedded in terms.
-- They are introduced and checked at interpretation time.
-- Invalid programs are well-formed terms,
-- they just denote the empty function.
--
-- Thus do we avoid the horrible mutual recursions between
-- the syntax and semantics of changes and between the
-- program transformation and its correctness, which drives
-- the type checker to thrashing.

data ΔTerm : Context → Type → Set where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → ΔTerm Γ nats
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → ΔTerm Γ bags
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → ΔTerm Γ τ
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (dt : ΔTerm (τ₁ • Γ) τ₂) →
         ΔTerm Γ (τ₁ ⇒ τ₂)
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {σ τ Γ}
    (ds : ΔTerm Γ (σ ⇒ τ))
    ( t :  Term Γ σ)
    (dt : ΔTerm Γ σ) →
    ΔTerm Γ τ
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ}
    (ds : ΔTerm Γ nats)
    (dt : ΔTerm Γ nats) →
    ΔTerm Γ nats
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ}
    ( s :   Term Γ (nats ⇒ nats))
    (ds : ΔTerm Γ (nats ⇒ nats))
    ( t :   Term Γ bags)
    (dt : ΔTerm Γ bags) →
    ΔTerm Γ bags
  Δmap₁ : ∀ {Γ}
    ( s :   Term Γ (nats ⇒ nats))
    (dt : ΔTerm Γ bags) →
    ΔTerm Γ bags

---------------------------------
-- Semantic domains of changes --
---------------------------------

ΔVal : Type → Set
ΔEnv : Context → Set
valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set

-- ΔVal : Type → Set
ΔVal nats = ℕ × ℕ
ΔVal bags = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

-- ΔEnv : Context → Set
ΔEnv ∅ = EmptySet
ΔEnv (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ _ → ΔVal τ)
  (λ v dv → valid v dv)
  (λ _ _ _ → ΔEnv Γ)

_⊕_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊝_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {σ ⇒ τ} f df =
  ∀ (v : ⟦ σ ⟧) (dv : ΔVal σ) (R[v,dv] : valid v dv)
  → valid (f v) (df v dv R[v,dv])
  × (f ⊕ df) (v ⊕ dv) ≡ f v ⊕ df v dv R[v,dv]

R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)

-- _⊕_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]

-- _⊝_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v

v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
v⊕[u⊝v]=u {nats} {u} {v} = refl
v⊕[u⊝v]=u {bags} {u} {v} = b++[d\\b]=d {v} {u}
v⊕[u⊝v]=u {σ ⇒ τ} {u} {v} = extensionality (λ w →
  begin
    (v ⊕ (u ⊝ v)) w
  ≡⟨ refl ⟩ -- for clarity
    v w ⊕ (u (w ⊕ (w ⊝ w)) ⊝ v w)
  ≡⟨ cong (λ hole → v w ⊕ (u hole ⊝ v w)) v⊕[u⊝v]=u ⟩
    v w ⊕ (u w ⊝ v w)
  ≡⟨ v⊕[u⊝v]=u ⟩
    u w
  ∎) where open ≡-Reasoning

-- R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {σ ⇒ τ} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v]
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {u = u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {u = u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
ignore {∅} ρ = ∅
ignore {τ • Γ} (cons v dv R[v,dv] ρ) = v • ignore ρ

update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
update {∅} ρ = ∅
update {τ • Γ} (cons v dv R[v,dv] ρ) = (v ⊕ dv) • update ρ

--------------------------
-- Semantics of changes --
--------------------------

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → ΔEnv Γ → ΔVal τ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] ρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] ρ) = ⟦ x ⟧ΔVar ρ

_is-valid-wrt_ : ∀ {τ Γ} → ΔTerm Γ τ → ΔEnv Γ → Set

⟦_⟧Δ : ∀ {τ Γ} →
  (t : ΔTerm Γ τ) → (ρ : ΔEnv Γ) → t is-valid-wrt ρ →
  ΔVal τ

-- _is-valid-wrt_ : ∀ {τ Γ} → ΔTerm Γ τ → ΔEnv Γ → Set
Δnat old new is-valid-wrt ρ = ⊤
Δbag db is-valid-wrt ρ = ⊤
Δvar x is-valid-wrt ρ = ⊤

_is-valid-wrt_ {σ ⇒ τ} (Δabs dt) ρ =
  (v : ⟦ σ ⟧) (dv : ΔVal σ) (R[v,dv] : valid v dv) →
  _is-valid-wrt_ dt (cons v dv R[v,dv] ρ)

Δapp ds t dt is-valid-wrt ρ = Quadruple
  (ds is-valid-wrt ρ)
  (λ _ → dt is-valid-wrt ρ)
  (λ _ v-dt → valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt))
  (λ _ _ _ → ⊤)

Δadd ds dt is-valid-wrt ρ = couple
  (ds is-valid-wrt ρ)
  (dt is-valid-wrt ρ)

Δmap₀ s ds t dt is-valid-wrt ρ = couple
  (ds is-valid-wrt ρ)
  (dt is-valid-wrt ρ)
_is-valid-wrt_ (Δmap₁ s db) ρ = db is-valid-wrt ρ

⟦ Δnat old new ⟧Δ ρ tt = old , new
⟦ Δbag db ⟧Δ ρ tt = db
⟦ Δvar x ⟧Δ ρ tt = ⟦ x ⟧ΔVar ρ

⟦ Δabs dt ⟧Δ ρ make-valid = λ v dv R[v,dv] →
  ⟦ dt ⟧Δ (cons v dv R[v,dv] ρ) (make-valid v dv R[v,dv])

⟦ Δapp ds t dt ⟧Δ ρ (cons v-ds v-dt R[ds,dt] _) =
  ⟦ ds ⟧Δ ρ v-ds (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt) R[ds,dt]

⟦ Δadd ds dt ⟧Δ ρ (cons v-ds v-dt _ _) =
  let
    (old-s , new-s) = ⟦ ds ⟧Δ ρ v-ds
    (old-t , new-t) = ⟦ dt ⟧Δ ρ v-dt
  in
    (old-s + old-t , new-s + new-t)

⟦ Δmap₀ s ds t dt ⟧Δ ρ (cons v-ds v-dt _ _) =
  let
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ v-ds
    dv = ⟦ dt ⟧Δ ρ v-dt
  in
    mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v

⟦ Δmap₁ s dt ⟧Δ ρ v-dt = mapBag (⟦ s ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt)

-- Minor issue about concrete syntax
--
-- Because ⟦_⟧Δ have dependently typed arguments,
-- we can't make it an instance of the Meaning
-- type class and can't use ⟦_⟧ on ΔTerms.
--
-- Error message:
-- Cannot instantiate the metavariable _872 to solution ((ρ : ΔEnv .Γ)
-- → t is-valid-wrt ρ → ΔVal .τ) since it contains the variable t
-- which is not in scope of the metavariable or irrelevant in the
-- metavariable but relevant in the solution
-- when checking that the expression ⟦_⟧Δ has type
-- ΔTerm .Γ .τ → _Semantics_872
--
--     meaning-ΔTerm : ∀ {τ Γ} → Meaning (ΔTerm Γ τ)
--     meaning-ΔTerm = meaning ⟦_⟧Δ

----------------------------
-- Program transformation --
----------------------------

derive : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ

derive (nat n) = Δnat n n
derive (bag b) = Δbag emptyBag
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t)
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

-----------------
-- Correctness --
-----------------

unrestricted : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  derive t is-valid-wrt ρ

validity : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  valid (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧Δ ρ (unrestricted {t = t}))

correctness : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ}
  → ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted {t = t})
  ≡ ⟦ t ⟧ (update ρ)

unrestricted {t = nat n} = tt
unrestricted {t = bag b} = tt
unrestricted {t = var x} {ρ} = tt
unrestricted {t = abs t} {ρ} = (λ _ _ _ → unrestricted {t = t})
unrestricted {t = app s t} {ρ} = cons
  (unrestricted {t = s})
  (unrestricted {t = t})
  (validity {t = t}) tt
unrestricted {t = add s t} {ρ} = cons
  (unrestricted {t = s})
  (unrestricted {t = t}) tt tt
unrestricted {t = map s t} {ρ} = cons
  (unrestricted {t = s})
  (unrestricted {t = t}) tt tt

validity-var : ∀ {τ Γ} → (x : Var Γ τ) →
  ∀ {ρ : ΔEnv Γ} → valid (⟦ x ⟧ (ignore ρ)) (⟦ x ⟧ΔVar ρ)

validity-var this {cons v dv R[v,dv] ρ} = R[v,dv]
validity-var (that x) {cons v dv R[v,dv] ρ} = validity-var x

validity {t = nat n} = refl
validity {t = bag b} = tt
validity {t = var x} = validity-var x
validity {t = map f b} = tt
validity {t = add s t} = cong₂ _+_ (validity {t = s}) (validity {t = t})

validity {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted {t = t})
  in
    proj₁ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))

validity {t = abs t} {ρ} = λ v dv R[v,dv] →
  let
    v′ = v ⊕ dv
    dv′ = v′ ⊝ v′
    ρ₁ = cons v dv R[v,dv] ρ
    ρ₂ = cons v′ dv′ R[v,u⊝v] ρ
  in
    validity {t = t} {ρ₁}
    ,
    (begin
      ⟦ t ⟧ (ignore ρ₂) ⊕ ⟦ derive t ⟧Δ ρ₂ (unrestricted {t = t})
    ≡⟨ correctness {t = t} {ρ₂} ⟩
      ⟦ t ⟧ (update ρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update ρ)) v⊕[u⊝v]=u ⟩
      ⟦ t ⟧ (update ρ₁)
    ≡⟨ sym (correctness {t = t} {ρ₁}) ⟩
      ⟦ t ⟧ (ignore ρ₁) ⊕ ⟦ derive t ⟧Δ ρ₁ (unrestricted {t = t})
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {ρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (update ρ)

correctVar {x = this  } {cons v dv R[v,dv] ρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] ρ} = correctVar {x = y} {ρ}

correctness {t = nat n} = refl
correctness {t = bag b} = b++∅=b
correctness {t = var x} = correctVar {x = x}

correctness {t = add s t} =
  cong₂ _+_ (correctness {t = s}) (correctness {t = t})

correctness {t = map s t} {ρ} =
  trans (b++[d\\b]=d {mapBag f b} {mapBag (f ⊕ df) (b ⊕ db)})
        (cong₂ mapBag (correctness {t = s}) (correctness {t = t}))
  where
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted {t = s})
    db = ⟦ derive t ⟧Δ ρ (unrestricted {t = t})

correctness {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted {t = t})
  in trans
     (sym (proj₂ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))))
     (correctness {t = s} ⟨$⟩ correctness {t = t})

correctness {τ₁ ⇒ τ₂} {Γ} {abs t} {ρ} = extensionality (λ v →
  let
    ρ′ : ΔEnv (τ₁ • Γ)
    ρ′ = cons v (v ⊝ v) R[v,u⊝v] ρ
  in
    begin
      ⟦ t ⟧ (ignore ρ′) ⊕ ⟦ derive t ⟧Δ ρ′ (unrestricted {t = t})
    ≡⟨ correctness {t = t} {ρ′} ⟩
      ⟦ t ⟧ (update ρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update ρ)) v⊕[u⊝v]=u ⟩
      ⟦ t ⟧ (v • update ρ)
    ∎
  ) where open ≡-Reasoning

{-
The goal of this file is to make the domain of Δ types smaller
so as to be nearer to full abstraction and hopefully close
enough for the purpose of having explicit nil changes.
-}

module TaggedDeltaTypes where

open import Data.NatBag renaming
  (map to mapBag ; empty to emptyBag ; update to updateBag)
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- open import Data.NatBag.Properties
postulate b\\b=∅ : ∀ {{b : Bag}} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {{b : Bag}} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {{b : Bag}} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

------------------------
-- Syntax of programs --
------------------------

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

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

data Var : Context → Type → Set where
  this : ∀ {τ Γ} → Var (τ • Γ) τ
  that : ∀ {τ τ′ Γ} → (x : Var Γ τ) → Var (τ′ • Γ) τ

data Term : Context -> Type -> Set where

  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  bag : ∀ {Γ} → (b : Bag) → Term Γ bags

  var : ∀ {τ Γ} → (x : Var Γ τ) → Term Γ τ
  abs : ∀ {τ₁ τ₂ Γ} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ} → (s : Term Γ (τ₁ ⇒ τ₂)) (t : Term Γ τ₁)
                   → Term Γ τ₂

  add : ∀ {Γ} → (s : Term Γ nats) → (t : Term Γ nats) → Term Γ nats
  map : ∀ {Γ} → (f : Term Γ (nats ⇒ nats)) → (b : Term Γ bags) → Term Γ bags

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ {∅} = ∅≼∅
Γ≼Γ {τ • Γ} = keep τ • Γ≼Γ {Γ}

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x
weaken subctx (bag b) = bag b
weaken subctx (add t₁ t₂) = add (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (map f b) = map (weaken subctx f) (weaken subctx b)

---------------------------
-- Semantics of programs --
---------------------------

record Meaning (Syntax : Set) {ℓ : Level.Level} : Set (Level.suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ nats ⟧Type = ℕ
⟦ bags ⟧Type = Bag
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

⟦_⟧Var : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ this ⟧Var (v • ρ) = v
⟦ that x ⟧Var (v • ρ) = ⟦ x ⟧Var ρ

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

identity-weakening : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
identity-weakening {∅} {∅} = refl
identity-weakening {τ • Γ} {v • ρ} =
  cong₂ _•_ {x = v} refl (identity-weakening {Γ} {ρ})

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n
⟦ bag b ⟧Term ρ = b
⟦ add m n ⟧Term ρ = ⟦ m ⟧Term ρ + ⟦ n ⟧Term ρ
⟦ map f b ⟧Term ρ = mapBag (⟦ f ⟧Term ρ) (⟦ b ⟧Term ρ)

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

_⟨$⟩_ : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
_⟨$⟩_ = cong₂ (λ x y → x y)

-- infix 0 $ in Haskell
infixl 0 _⟨$⟩_

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = weaken-sound t₁ ρ ⟨$⟩ weaken-sound t₂ ρ
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (bag b) ρ = refl
weaken-sound (add m n) ρ = cong₂ _+_ (weaken-sound m ρ) (weaken-sound n ρ)
weaken-sound (map f b) ρ =
  cong₂ mapBag (weaken-sound f ρ) (weaken-sound b ρ)

----------------------------------------------------------
-- Syntax and semantics of changes (they are entangled) --
----------------------------------------------------------

data Δ-Type : Set where
  Δ : (τ : Type) → Δ-Type

data Δ-Context : Set where
  Δ : (Γ : Context) → Δ-Context

Env : Context → Set
Env Γ = ⟦ Γ ⟧Context

data Δ-Term : Δ-Context → Δ-Type → Set

-- Syntax of Δ-Types
-- ...   is mutually recursive with semantics of Δ-Terms
-- (because it embeds validity proofs),
-- which is mutually recursive with validity and Δ-environments,
-- which is mutually recursive with ⊕,
-- which is mutually recursive with ⊝ and R[v,v⊝v],
-- which is mutually recursive with v⊕[u⊝v]=v, et cetera.
⟦_⟧Δτ : Δ-Type → Set
Δ-Env : Context → Set
⟦_⟧Δ : ∀ {τ : Type} {Γ : Context}
    → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
_⊕_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → ⟦ τ ⟧
_⊝_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ
valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → Set
R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧
update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧

infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

data Δ-Term where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → Δ-Term (Δ Γ) (Δ nats)
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → Δ-Term (Δ Γ) (Δ bags)
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → Δ-Term (Δ Γ) (Δ τ)
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (t : Δ-Term (Δ (τ₁ • Γ)) (Δ τ₂)) →
         Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂))
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {τ₁ τ₂ Γ} → (ds : Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂)))
                    → ( t :   Term    Γ      τ₁)
                    → (dt : Δ-Term (Δ Γ) (Δ  τ₁))
                    → (R[t,dt] : {ρ : Δ-Env Γ} → -- 'Tis but a proof.
                          valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ)) →
         Δ-Term (Δ Γ) (Δ τ₂)
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ} → (ds : Δ-Term (Δ Γ) (Δ nats))
               → (dt : Δ-Term (Δ Γ) (Δ nats)) →
         Δ-Term (Δ Γ) (Δ nats)
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (df : Δ-Term (Δ Γ) (Δ (nats ⇒ nats)))
                → ( b :   Term    Γ     bags)
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)
  Δmap₁ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)

-- ⟦_⟧Δτ : Δ-Type → Set
⟦ Δ nats ⟧Δτ = ℕ × ℕ
⟦ Δ bags ⟧Δτ = Bag
⟦ Δ (τ₁ ⇒ τ₂) ⟧Δτ =
  (v : ⟦ τ₁ ⟧) → (dv : ⟦ Δ τ₁ ⟧Δτ) → valid v dv → ⟦ Δ τ₂ ⟧Δτ

meaning-Δτ : Meaning Δ-Type
meaning-Δτ = meaning ⟦_⟧Δτ

_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]

_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v

-- valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {τ₁ ⇒ τ₂} f df =
  ∀ (v : ⟦ τ₁ ⟧) (dv : ⟦ Δ τ₁ ⟧Δτ) (R[v,dv] : valid v dv)
  → valid (f v) (df v dv R[v,dv])
  × (f ⊕ df) (v ⊕ dv) ≡ f v ⊕ df v dv R[v,dv]

eq1 : ∀ {τ₁ τ₂ : Type} {f : ⟦ τ₁ ⇒ τ₂ ⟧} {df} {x : ⟦ τ₁ ⟧} {dx} →
      valid f df → (R[x,dx] : valid x dx) →
      (f ⊕ df) (x ⊕ dx) ≡ f x ⊕ df x dx R[x,dx]

eq1 R[f,df] R[x,dx] = proj₂ (R[f,df] _ _ R[x,dx])

v⊕[u⊝v]=u {nats}   {u} {v} = refl
v⊕[u⊝v]=u {bags}   {u} {v} = b++[d\\b]=d {v} {u}
v⊕[u⊝v]=u {τ₁ ⇒ τ₂} {u} {v} = extensionality (λ w →
  begin
    (v ⊕ (u ⊝ v)) w
  ≡⟨ refl ⟩ -- for clarity
    v w ⊕ (u (w ⊕ (w ⊝ w)) ⊝ v w)
  ≡⟨ cong (λ hole → v w ⊕ (u hole ⊝ v w)) v⊕[u⊝v]=u ⟩
    v w ⊕ (u w ⊝ v w)
  ≡⟨ v⊕[u⊝v]=u ⟩
    u w
  ∎) where open ≡-Reasoning

R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {τ₁ ⇒ τ₂} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v] -- NOT a self recursion: implicit arguments are different.
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {u = u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {u = u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

record Quadruple
  (A : Set) (B : A → Set) (C : (a : A) → B a → Set)
  (D : (a : A) → (b : B a) → (c : C a b) → Set): Set where
  constructor cons
  field
    car   : A
    cadr  : B car
    caddr : C car cadr
    cdddr : D car cadr caddr

open Quadruple public

-- The type of environments ensures their consistency.
-- Δ-Env : Context → Set
Δ-Env ∅ = EmptySet
Δ-Env (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ v → ⟦ Δ τ ⟧Δτ)
  (λ v dv → valid v dv)
  (λ v dv R[v,dv] → Δ-Env Γ)

-- ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
ignore {∅} ρ = ∅
ignore {τ • Γ} (cons v dv R[v,dv] ρ) = v • ignore ρ

-- update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
update {∅} ρ = ∅
update {τ • Γ} (cons v dv R[v,dv] ρ) = (v ⊕ dv) • update ρ

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] ρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] ρ) = ⟦ x ⟧ΔVar ρ

-- ⟦_⟧ΔVar is not put into the Meaning type class
-- because its argument is identical to that of ⟦_⟧Var.

-- ⟦_⟧Δ : ∀ {τ Γ} → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ Δnat old new ⟧Δ ρ = (old , new)
⟦ Δbag db ⟧Δ ρ = db
⟦ Δvar x ⟧Δ ρ = ⟦ x ⟧ΔVar ρ
⟦ Δabs t ⟧Δ ρ = λ v dv R[v,dv] → ⟦ t ⟧Δ (cons v dv R[v,dv] ρ)
⟦ Δapp ds t dt R[dt,t] ⟧Δ ρ =
  ⟦ ds ⟧Δ ρ (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ) R[dt,t]
⟦ Δadd ds dt ⟧Δ ρ =
  let
    (old-s , new-s) = ⟦ ds ⟧Δ ρ
    (old-t , new-t) = ⟦ dt ⟧Δ ρ
  in
    (old-s + old-t , new-s + new-t)
⟦ Δmap₀ f df b db ⟧Δ ρ =
  let
    v  = ⟦ b ⟧ (ignore ρ)
    h  = ⟦ f ⟧ (ignore ρ)
    dv = ⟦ db ⟧Δ ρ
    dh = ⟦ df ⟧Δ ρ
  in
    mapBag (h ⊕ dh) (v ⊕ dv) \\ mapBag h v
⟦ Δmap₁ f db ⟧Δ ρ = mapBag (⟦ f ⟧ (ignore ρ)) (⟦ db ⟧Δ ρ)

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

--------------------------------------------------------
-- Program transformation and correctness (entangled) --
--------------------------------------------------------

derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)

validity : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  valid (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

correctness : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧ ρ ≡ ⟦ t ⟧ (update ρ)

-- derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)
derive (nat n) = Δnat n n
derive (bag b) = Δbag emptyBag
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t) validity
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

validity-var : ∀ {τ Γ} → (x : Var Γ τ) →
  ∀ {ρ : Δ-Env Γ} → valid (⟦ x ⟧ (ignore ρ)) (⟦ x ⟧ΔVar ρ)

validity-var this {cons v dv R[v,dv] ρ} = R[v,dv]
validity-var (that x) {cons v dv R[v,dv] ρ} = validity-var x

validity {t = nat n} = refl
validity {t = bag b} = tt
validity {t = var x} = validity-var x
validity {t = map f b} = tt
validity {t = add s t} = cong₂ _+_ (validity {t = s}) (validity {t = t})

validity {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧ ρ
  in
    proj₁ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))

validity {t = abs t} {ρ} = λ v dv R[v,dv] →
  let
    v′ = v ⊕ dv
    dv′ = v′ ⊝ v′
    ρ₁ = cons v dv R[v,dv] ρ
    ρ₂ = cons v′ dv′ R[v,u⊝v] ρ
  in
    validity {t = t} {ρ₁}
    ,
    (begin
      ⟦ t ⟧ (ignore ρ₂) ⊕ ⟦ derive t ⟧ ρ₂
    ≡⟨ correctness {t = t} {ρ₂} ⟩
      ⟦ t ⟧ (update ρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update ρ)) v⊕[u⊝v]=u ⟩
      ⟦ t ⟧ (update ρ₁)
    ≡⟨ sym (correctness {t = t} {ρ₁}) ⟩
      ⟦ t ⟧ (ignore ρ₁) ⊕ ⟦ derive t ⟧ ρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {ρ : Δ-Env Γ} →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (update ρ)

correctVar {x = this  } {cons v dv R[v,dv] ρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] ρ} = correctVar {x = y} {ρ}

correctness {t = nat n} = refl
correctness {t = bag b} = b++∅=b
correctness {t = var x} = correctVar {x = x}

correctness {t = add s t} =
  cong₂ _+_ (correctness {t = s}) (correctness {t = t})

correctness {t = map s t} {ρ} =
  trans (b++[d\\b]=d {mapBag f b} {mapBag (f ⊕ df) (b ⊕ db)})
        (cong₂ mapBag (correctness {t = s}) (correctness {t = t}))
  where
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧ ρ
    db = ⟦ derive t ⟧ ρ

correctness {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧ ρ
  in trans
     (sym (proj₂ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))))
     (correctness {t = s} ⟨$⟩ correctness {t = t})

correctness {τ₁ ⇒ τ₂} {Γ} {abs t} {ρ} = extensionality (λ v →
  let
    ρ′ : Δ-Env (τ₁ • Γ)
    ρ′ = cons v (v ⊝ v) R[v,u⊝v] ρ
  in
    begin
      ⟦ t ⟧ (ignore ρ′) ⊕ ⟦ derive t ⟧ ρ′
    ≡⟨ correctness {t = t} {ρ′} ⟩
      ⟦ t ⟧ (update ρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update ρ)) v⊕[u⊝v]=u ⟩
      ⟦ t ⟧ (v • update ρ)
    ∎
  ) where open ≡-Reasoning