Vec: sum, rot, properties

Vec: sum, rot, properties

module Data.Vec.NP where

import Level as L
open import Category.Applicative
open import Data.Vec public hiding (_⊛_; zipWith; zip; map; applicative)
open import Data.Nat.NP using (ℕ; suc; zero; _+_; module ℕ°)
open import Data.Fin renaming (_+_ to _+ᶠ_)
import Data.Fin.Props as F
open import Data.Bool
open import Data.Product hiding (map; zip; swap)
open import Function.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Function.Bijection.SyntaxKit

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    applicative : ∀ {a n} → RawApplicative (λ (A : Set a) → Vec A n)
    applicative = record
      { pure = replicate
      ; _⊛_  = _⊛_
      }

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

    tabulate-∘ : ∀ {n a b} {A : Set a} {B : Set b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = refl
    tabulate-∘ {suc n} f g =
      ≡.cong (_∷_ (f (g zero))) (tabulate-∘ f (g ∘ suc))

    -- map is functorial.

    map-id : ∀ {a n} {A : Set a} → map id ≗ id {A = Vec A n}
    map-id []       = refl
    map-id (x ∷ xs) = ≡.cong (_∷_ x) (map-id xs)

    map-∘ : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c}
            (f : B → C) (g : A → B) →
            _≗_ {A = Vec A n} (map (f ∘ g)) (map f ∘ map g)
    map-∘ f g []       = refl
    map-∘ f g (x ∷ xs) = ≡.cong (_∷_ (f (g x))) (map-∘ f g xs)

open waiting-for-a-fix-in-the-stdlib public

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-app : ∀ {a} {A : Set a} {m n} →
              Vec A n → Vec A m → Vec A (rev-+ n m)
    rev-app []       = id
    rev-app (x ∷ xs) = rev-app xs ∘ _∷_ x

    rev-aux : ∀ {a} {A : Set a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Set a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                  | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                  | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

shallow-η : ∀ {n a} {A : Set a} (xs : Vec A (1 + n)) → xs ≡ head xs ∷ tail xs
shallow-η (x ∷ xs) = ≡.refl

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

swap : ∀ m {n} {a} {A : Set a} → Vec A (m + n) → Vec A (n + m)
swap m xs = drop m xs ++ take m xs

swap-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
swap-++ m xs ys rewrite drop-++ m xs ys | take-++ m xs ys = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

⊛-dist-0↔1 : ∀ {n a} {A : Set a} (fs : Vec (Endo A) n) xs → 0↔1 fs ⊛ 0↔1 xs ≡ 0↔1 (fs ⊛ xs)
⊛-dist-0↔1 _           []          = refl
⊛-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = refl
⊛-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = refl

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

map-tail∘map-tail : ∀ {m n o a} {A : Set a}
                      (f : Vec A o → Vec A m)
                      (g : Vec A n → Vec A o)
                    → map-tail f ∘ map-tail g ≗ map-tail (f ∘ g)
map-tail∘map-tail f g (x ∷ xs) = refl

map-tail-≗ : ∀ {m n a} {A : Set a} (f g : Vec A m → Vec A n) → f ≗ g → map-tail f ≗ map-tail g
map-tail-≗ f g f≗g (x ∷ xs) rewrite f≗g xs = refl

-- ⟨0↔1+ i ⟩: Exchange elements at position 0 and 1+i.
⟨0↔1+_⟩ : ∀ {n} (i : Fin n) {a} {A : Set 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 : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = ⟨0↔1+ i ⟩

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

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

module ⟨↔⟩ {a} (A : Set 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 : Set 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

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

    lem : ∀ {n} (i j : Fin n) → ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩ ≗ ⟨ i ↔ j ⟩
    lem zero j xs = refl
    lem (suc i) zero xs = {!⟨0↔1+ i ⟩²-cancel xs!}
    lem (suc i) (suc j) xs = (⟨0↔1+ i ⟩ ∘ ⟨0↔1+ j ⟩ ∘ ⟨0↔1+ i ⟩) xs
                 ≡⟨ lem1+ i j xs ⟩
                   ⟨ suc i ↔ suc j ⟩ xs
                 ∎ where open ≡-Reasoning
    test = {!!}
    -}
{-
    lem : ∀ {n} (i j k : Fin n) → ⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ j ⟩ ≗ ⟨ j ↔ k ⟩
    lem i j k xs = (⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ j ⟩) xs
                   (⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ id ∘ ⟨ i ↔ j ⟩) xs
                   (⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ j ⟩) xs
                 ≡⟨ {!!} ⟩
                   ⟨ j ↔ k ⟩ xs
                 ∎ where open ≡-Reasoning
-}
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨_↔_⟩ i j = ⟨↔⟩.⟨_↔_⟩ _ i j

module PermutationSyntax where
    infixr 1 _`⁏_
    data Perm : ℕ → Set 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 : Set 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 → Set _
    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 : L.Level} where
    open PermutationSyntax
    open PermutationSemantics

    ⊛-dist-∙ : ∀ {n} {A : Set 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 : Set 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 : Set 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 : Set 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

module BijectionSyntax {a b} (A : Set a) (Bijᴬ : Set b) where
    infixr 1 _`⁏_
    data Bij : ℕ → Set (a L.⊔ b) where
      `id : ∀ {n} → Bij n
      `0↔1 : ∀ {n} → Bij (2 + n)
      _`⁏_ : ∀ {n} → Bij n → Bij n → Bij n
      _`∷_ : ∀ {n} → Bijᴬ → (A → Bij n) → Bij (1 + n)

module BijectionLib where
    open BijectionSyntax
    mapBij : ∀ {a bᴬ} {A : Set a} {Bijᴬ : Set bᴬ}
               {b bᴮ} {B : Set b} {Bijᴮ : Set bᴮ}
               (fᴮᴬ : B → A)
               (f   : Bijᴬ → Bijᴮ)
               {n} → Bij A Bijᴬ n → Bij B Bijᴮ n
    mapBij fᴮᴬ f `id = `id
    mapBij fᴮᴬ f `0↔1 = `0↔1
    mapBij fᴮᴬ f (`g `⁏ `h) = mapBij fᴮᴬ f `g `⁏ mapBij fᴮᴬ f `h
    mapBij fᴮᴬ f (`fᴬ `∷ `g) = f `fᴬ `∷ λ x → mapBij fᴮᴬ f (`g (fᴮᴬ x))

module BijectionSemantics {a b} {A : Set a} (bijKitᴬ : BijKit b A) where
    open BijKit bijKitᴬ renaming (Bij to Bijᴬ; eval to evalᴬ; _⁻¹ to _⁻¹ᴬ;
                                  idBij to idᴬ; _≗Bij_ to _≗ᴬ_;
                                  _⁻¹-inverse to _⁻¹-inverseᴬ;
                                  _⁻¹-involutive to _⁻¹-involutiveᴬ;
                                  id-spec to idᴬ-spec)
    open BijectionSyntax A Bijᴬ

    _⁻¹ : ∀ {n} → Endo (Bij n)
    `id ⁻¹ = `id
    (f₀ `⁏ f₁) ⁻¹ = f₁ ⁻¹ `⁏ f₀ ⁻¹
    `0↔1 ⁻¹ = `0↔1
    (fᴬ `∷ f) ⁻¹ = fᴬ⁻¹ `∷ λ x → (f (evalᴬ fᴬ⁻¹ x))⁻¹ where fᴬ⁻¹ = fᴬ ⁻¹ᴬ

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

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

    _≗′_ : ∀ {n} → Bij n → Bij n → Set _
    f ≗′ g = ∀ xs → f ∙ xs ≡ g ∙ xs

    _⁻¹-inverse : ∀ {n} (f : Bij 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
    ((fᴬ `∷ f) ⁻¹-inverse) (x ∷ xs)
      rewrite (fᴬ ⁻¹-inverseᴬ) x | (f x ⁻¹-inverse) xs = refl

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

    Vec-bijKit : ∀ n → BijKit _ (Vec A n)
    Vec-bijKit n = mk (Bij n) eval _⁻¹ `id _`⁏_ (λ _ → refl) (λ _ _ _ → refl)
                (λ f x → _⁻¹-inverse f x) (λ f x → _⁻¹-involutive f x)

    module VecBijKit n = BijKit (Vec-bijKit n)

    `tl : ∀ {n} → Bij n → Bij (1 + n)
    `tl f = idᴬ `∷ const f

    private
      module P where
        open PermutationSyntax public
        open PermutationSemantics {A = A} public
    open P using (Perm; `id; `0↔1; _`⁏_)
    fromPerm : ∀ {n} → Perm n → Bij n
    fromPerm `id = `id
    fromPerm `0↔1 = `0↔1
    fromPerm (π₀ `⁏ π₁) = fromPerm π₀ `⁏ fromPerm π₁
    fromPerm (P.`tl π) = `tl (fromPerm π)

    fromPerm-spec : ∀ {n} π (xs : Vec A n) → π P.∙ xs ≡ fromPerm π ∙ xs
    fromPerm-spec `id xs = refl
    fromPerm-spec `0↔1 xs = refl
    fromPerm-spec (π `⁏ π₁) xs rewrite fromPerm-spec π xs | fromPerm-spec π₁ (fromPerm π ∙ xs) = refl
    fromPerm-spec (P.`tl π) (x ∷ xs) rewrite idᴬ-spec x | fromPerm-spec π xs = refl

    private
      module Unused where
        `⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Bij (1 + n)
        `⟨0↔1+ i ⟩ = fromPerm P.`⟨0↔1+ i ⟩

        `⟨0↔1+_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A (suc n)) → `⟨0↔1+ i ⟩ ∙ xs ≡ ⟨0↔1+ i ⟩ xs
        `⟨0↔1+ i ⟩-spec xs rewrite sym (P.`⟨0↔1+ i ⟩-spec xs) | fromPerm-spec P.`⟨0↔1+ i ⟩ xs = refl

        `⟨0↔_⟩ : ∀ {n} (i : Fin n) → Bij n
        `⟨0↔ i ⟩ = fromPerm P.`⟨0↔ i ⟩

        `⟨0↔_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A n) → `⟨0↔ i ⟩ ∙ xs ≡ ⟨0↔ i ⟩ xs
        `⟨0↔ i ⟩-spec xs rewrite sym (P.`⟨0↔ i ⟩-spec xs) | fromPerm-spec P.`⟨0↔ i ⟩ xs = refl

    `⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Bij n
    `⟨ i ↔ j ⟩ = fromPerm P.`⟨ i ↔ j ⟩

    `⟨_↔_⟩-spec : ∀ {n} (i j : Fin n) (xs : Vec A n) → `⟨ i ↔ j ⟩ ∙ xs ≡ ⟨ i ↔ j ⟩ xs
    `⟨ i ↔ j ⟩-spec xs rewrite sym (P.`⟨ i ↔ j ⟩-spec xs) | fromPerm-spec P.`⟨ i ↔ j ⟩ xs = refl

sum-∷ʳ : ∀ {n} x (xs : Vec ℕ n) → sum (xs ∷ʳ x) ≡ sum xs + x
sum-∷ʳ x [] = ℕ°.+-comm x 0
sum-∷ʳ x (x₁ ∷ xs) rewrite sum-∷ʳ x xs | ℕ°.+-assoc x₁ (sum xs) x = refl

rot₁ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
rot₁ []       = []
rot₁ (x ∷ xs) = xs ∷ʳ x

rot : ∀ {n a} {A : Set a} → ℕ → Vec A n → Vec A n
rot zero    xs = xs
rot (suc n) xs = rot n (rot₁ xs)

sum-rot₁ : ∀ {n} (xs : Vec ℕ n) → sum xs ≡ sum (rot₁ xs)
sum-rot₁ [] = refl
sum-rot₁ (x ∷ xs) rewrite sum-∷ʳ x xs = ℕ°.+-comm x _

map-∷ʳ : ∀ {n a} {A : Set a} (f : A → ℕ) x (xs : Vec A n) → map f (xs ∷ʳ x) ≡ map f xs ∷ʳ f x
map-∷ʳ f x [] = refl
map-∷ʳ f x (x₁ ∷ xs) rewrite map-∷ʳ f x xs = refl

sum-map-rot₁ : ∀ {n a} {A : Set a} (f : A → ℕ) (xs : Vec A n) → sum (map f (rot₁ xs)) ≡ sum (map f xs)
sum-map-rot₁ f [] = refl
sum-map-rot₁ f (x ∷ xs) rewrite ℕ°.+-comm (f x) (sum (map f xs))
                              | ≡.sym (sum-∷ʳ (f x) (map f xs))
                              | ≡.sym (map-∷ʳ f x xs)
                              = refl

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

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

    ⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set 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 : Set 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 : Set 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 : Set 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 : Set 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 : Set 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

module Data.Vec.NP where

import Level as L
open import Category.Applicative
open import Data.Vec public hiding (_⊛_; zipWith; zip; map; applicative)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
import Data.Fin.Props as F
open import Data.Bool
open import Data.Product hiding (map; zip; swap)
open import Function.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Function.Bijection.SyntaxKit

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    applicative : ∀ {a n} → RawApplicative (λ (A : Set a) → Vec A n)
    applicative = record
      { pure = replicate
      ; _⊛_  = _⊛_
      }

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

    tabulate-∘ : ∀ {n a b} {A : Set a} {B : Set b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = refl
    tabulate-∘ {suc n} f g =
      ≡.cong (_∷_ (f (g zero))) (tabulate-∘ f (g ∘ suc))

open waiting-for-a-fix-in-the-stdlib public

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-app : ∀ {a} {A : Set a} {m n} →
              Vec A n → Vec A m → Vec A (rev-+ n m)
    rev-app []       = id
    rev-app (x ∷ xs) = rev-app xs ∘ _∷_ x

    rev-aux : ∀ {a} {A : Set a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Set a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                  | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                  | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

shallow-η : ∀ {n a} {A : Set a} (xs : Vec A (1 + n)) → xs ≡ head xs ∷ tail xs
shallow-η (x ∷ xs) = ≡.refl

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

swap : ∀ m {n} {a} {A : Set a} → Vec A (m + n) → Vec A (n + m)
swap m xs = drop m xs ++ take m xs

swap-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
swap-++ m xs ys rewrite drop-++ m xs ys | take-++ m xs ys = refl

rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
rewire f v = tabulate (flip lookup v ∘ f)

RewireTbl : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
rewireTbl tbl v = map (flip lookup v) tbl

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

⊛-dist-0↔1 : ∀ {n a} {A : Set a} (fs : Vec (Endo A) n) xs → 0↔1 fs ⊛ 0↔1 xs ≡ 0↔1 (fs ⊛ xs)
⊛-dist-0↔1 _           []          = refl
⊛-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = refl
⊛-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = refl

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

map-tail∘map-tail : ∀ {m n o a} {A : Set a}
                      (f : Vec A o → Vec A m)
                      (g : Vec A n → Vec A o)
                    → map-tail f ∘ map-tail g ≗ map-tail (f ∘ g)
map-tail∘map-tail f g (x ∷ xs) = refl

map-tail-≗ : ∀ {m n a} {A : Set a} (f g : Vec A m → Vec A n) → f ≗ g → map-tail f ≗ map-tail g
map-tail-≗ f g f≗g (x ∷ xs) rewrite f≗g xs = refl

-- ⟨0↔1+ i ⟩: Exchange elements at position 0 and 1+i.
⟨0↔1+_⟩ : ∀ {n} (i : Fin n) {a} {A : Set 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 : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = ⟨0↔1+ i ⟩

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

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

module ⟨↔⟩ {a} (A : Set 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 : Set 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

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

    lem : ∀ {n} (i j : Fin n) → ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩ ≗ ⟨ i ↔ j ⟩
    lem zero j xs = refl
    lem (suc i) zero xs = {!⟨0↔1+ i ⟩²-cancel xs!}
    lem (suc i) (suc j) xs = (⟨0↔1+ i ⟩ ∘ ⟨0↔1+ j ⟩ ∘ ⟨0↔1+ i ⟩) xs
                 ≡⟨ lem1+ i j xs ⟩
                   ⟨ suc i ↔ suc j ⟩ xs
                 ∎ where open ≡-Reasoning
    test = {!!}
    -}
{-
    lem : ∀ {n} (i j k : Fin n) → ⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ j ⟩ ≗ ⟨ j ↔ k ⟩
    lem i j k xs = (⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ j ⟩) xs
                   (⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ id ∘ ⟨ i ↔ j ⟩) xs
                   (⟨ i ↔ j ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ k ⟩ ∘ ⟨ i ↔ j ⟩) xs
                 ≡⟨ {!!} ⟩
                   ⟨ j ↔ k ⟩ xs
                 ∎ where open ≡-Reasoning
-}
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨_↔_⟩ i j = ⟨↔⟩.⟨_↔_⟩ _ i j

module PermutationSyntax where
    infixr 1 _`⁏_
    data Perm : ℕ → Set 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 : Set 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 → Set _
    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 : L.Level} where
    open PermutationSyntax
    open PermutationSemantics

    ⊛-dist-∙ : ∀ {n} {A : Set 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 : Set 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 : Set 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 : Set 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

module BijectionSyntax {a b} (A : Set a) (Bijᴬ : Set b) where
    infixr 1 _`⁏_
    data Bij : ℕ → Set (a L.⊔ b) where
      `id : ∀ {n} → Bij n
      `0↔1 : ∀ {n} → Bij (2 + n)
      _`⁏_ : ∀ {n} → Bij n → Bij n → Bij n
      _`∷_ : ∀ {n} → Bijᴬ → (A → Bij n) → Bij (1 + n)

module BijectionLib where
    open BijectionSyntax
    mapBij : ∀ {a bᴬ} {A : Set a} {Bijᴬ : Set bᴬ}
               {b bᴮ} {B : Set b} {Bijᴮ : Set bᴮ}
               (fᴮᴬ : B → A)
               (f   : Bijᴬ → Bijᴮ)
               {n} → Bij A Bijᴬ n → Bij B Bijᴮ n
    mapBij fᴮᴬ f `id = `id
    mapBij fᴮᴬ f `0↔1 = `0↔1
    mapBij fᴮᴬ f (`g `⁏ `h) = mapBij fᴮᴬ f `g `⁏ mapBij fᴮᴬ f `h
    mapBij fᴮᴬ f (`fᴬ `∷ `g) = f `fᴬ `∷ λ x → mapBij fᴮᴬ f (`g (fᴮᴬ x))

module BijectionSemantics {a b} {A : Set a} (bijKitᴬ : BijKit b A) where
    open BijKit bijKitᴬ renaming (Bij to Bijᴬ; eval to evalᴬ; _⁻¹ to _⁻¹ᴬ;
                                  idBij to idᴬ; _≗Bij_ to _≗ᴬ_;
                                  _⁻¹-inverse to _⁻¹-inverseᴬ;
                                  _⁻¹-involutive to _⁻¹-involutiveᴬ;
                                  id-spec to idᴬ-spec)
    open BijectionSyntax A Bijᴬ

    _⁻¹ : ∀ {n} → Endo (Bij n)
    `id ⁻¹ = `id
    (f₀ `⁏ f₁) ⁻¹ = f₁ ⁻¹ `⁏ f₀ ⁻¹
    `0↔1 ⁻¹ = `0↔1
    (fᴬ `∷ f) ⁻¹ = fᴬ⁻¹ `∷ λ x → (f (evalᴬ fᴬ⁻¹ x))⁻¹ where fᴬ⁻¹ = fᴬ ⁻¹ᴬ

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

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

    _≗′_ : ∀ {n} → Bij n → Bij n → Set _
    f ≗′ g = ∀ xs → f ∙ xs ≡ g ∙ xs

    _⁻¹-inverse : ∀ {n} (f : Bij 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
    ((fᴬ `∷ f) ⁻¹-inverse) (x ∷ xs)
      rewrite (fᴬ ⁻¹-inverseᴬ) x | (f x ⁻¹-inverse) xs = refl

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

    Vec-bijKit : ∀ n → BijKit _ (Vec A n)
    Vec-bijKit n = mk (Bij n) eval _⁻¹ `id _`⁏_ (λ _ → refl) (λ _ _ _ → refl)
                (λ f x → _⁻¹-inverse f x) (λ f x → _⁻¹-involutive f x)

    module VecBijKit n = BijKit (Vec-bijKit n)

    `tl : ∀ {n} → Bij n → Bij (1 + n)
    `tl f = idᴬ `∷ const f

    private
      module P where
        open PermutationSyntax public
        open PermutationSemantics {A = A} public
    open P using (Perm; `id; `0↔1; _`⁏_)
    fromPerm : ∀ {n} → Perm n → Bij n
    fromPerm `id = `id
    fromPerm `0↔1 = `0↔1
    fromPerm (π₀ `⁏ π₁) = fromPerm π₀ `⁏ fromPerm π₁
    fromPerm (P.`tl π) = `tl (fromPerm π)

    fromPerm-spec : ∀ {n} π (xs : Vec A n) → π P.∙ xs ≡ fromPerm π ∙ xs
    fromPerm-spec `id xs = refl
    fromPerm-spec `0↔1 xs = refl
    fromPerm-spec (π `⁏ π₁) xs rewrite fromPerm-spec π xs | fromPerm-spec π₁ (fromPerm π ∙ xs) = refl
    fromPerm-spec (P.`tl π) (x ∷ xs) rewrite idᴬ-spec x | fromPerm-spec π xs = refl

    private
      module Unused where
        `⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Bij (1 + n)
        `⟨0↔1+ i ⟩ = fromPerm P.`⟨0↔1+ i ⟩

        `⟨0↔1+_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A (suc n)) → `⟨0↔1+ i ⟩ ∙ xs ≡ ⟨0↔1+ i ⟩ xs
        `⟨0↔1+ i ⟩-spec xs rewrite sym (P.`⟨0↔1+ i ⟩-spec xs) | fromPerm-spec P.`⟨0↔1+ i ⟩ xs = refl

        `⟨0↔_⟩ : ∀ {n} (i : Fin n) → Bij n
        `⟨0↔ i ⟩ = fromPerm P.`⟨0↔ i ⟩

        `⟨0↔_⟩-spec : ∀ {n} (i : Fin n) (xs : Vec A n) → `⟨0↔ i ⟩ ∙ xs ≡ ⟨0↔ i ⟩ xs
        `⟨0↔ i ⟩-spec xs rewrite sym (P.`⟨0↔ i ⟩-spec xs) | fromPerm-spec P.`⟨0↔ i ⟩ xs = refl

    `⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Bij n
    `⟨ i ↔ j ⟩ = fromPerm P.`⟨ i ↔ j ⟩

    `⟨_↔_⟩-spec : ∀ {n} (i j : Fin n) (xs : Vec A n) → `⟨ i ↔ j ⟩ ∙ xs ≡ ⟨ i ↔ j ⟩ xs
    `⟨ i ↔ j ⟩-spec xs rewrite sym (P.`⟨ i ↔ j ⟩-spec xs) | fromPerm-spec P.`⟨ i ↔ j ⟩ xs = refl

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

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

    ⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set 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 : Set 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 : Set 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 : Set 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 : Set 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 : Set 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


Explain file contents.

Explain file contents.

Old-commit-hash: ee63b553e1dfecc4fc7d70052659a3a2909b86e6

module incremental where

-- INCREMENTAL λ-CALCULUS
--   with (one-variable) partial derivatives
--
-- Features:
--   * Changes and derivatives are different.
--   * Δ x e  maps changes of x to changes of e.
--   * a full denotational semantics is given.
--   * the domain of change types `⟦Δ τ⟧` is uniformly defined as `⟦τ⟧ → ⟦τ⟧`.

open import Relation.Binary.PropositionalEquality

open import meaning

-- SIMPLE TYPES

-- Syntax

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

  -- `Δ τ` is the type of changes to `τ`
  Δ : (τ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

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

meaningOfType : Meaning Type
meaningOfType = meaning Set ⟦_⟧Type

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

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

  -- `Δ x dx t` maps changes `dx` in `x` to changes in `t`
  Δ : ∀ {Γ τ₁ τ₂} → (x : Var Γ τ₁) (dx : Var Γ (Δ τ₁)) → (t : Term Γ τ₂) → Term Γ (Δ τ₂)

-- Denotational Semantics

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

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

-- 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 {Γ₁} {Γ₂} (Δ x dx t) = Δ (lift {Γ₁} {Γ₂} x) (lift {Γ₁} {Γ₂} dx) (weaken {Γ₁} {Γ₂} t)

module incremental where

open import Relation.Binary.PropositionalEquality

open import meaning

-- SIMPLE TYPES

-- Syntax

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

  -- `Δ τ` is the type of changes to `τ`
  Δ : (τ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

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

meaningOfType : Meaning Type
meaningOfType = meaning Set ⟦_⟧Type

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

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

  -- `Δ x dx t` maps changes `dx` in `x` to changes in `t`
  Δ : ∀ {Γ τ₁ τ₂} → (x : Var Γ τ₁) (dx : Var Γ (Δ τ₁)) → (t : Term Γ τ₂) → Term Γ (Δ τ₂)

-- Denotational Semantics

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

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

-- 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 {Γ₁} {Γ₂} (Δ x dx t) = Δ (lift {Γ₁} {Γ₂} x) (lift {Γ₁} {Γ₂} dx) (weaken {Γ₁} {Γ₂} t)


added an actual implementation of ex-fresh + proof

module Core where

open import Data.Empty
open import Data.Nat
open import Data.List
open import Data.List.Any as Any
open Any.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Data.Sum
open import Data.Nat.Properties

Atom = ℕ

data Type : Set where
  σ : Type
  _⟶_ : (t₁ : Type) -> (t₂ : Type) -> Type

data PTerm : Set where
  bv : (i : ℕ) -> PTerm
  fv : (x : Atom) -> PTerm
  lam : (e : PTerm) -> PTerm
  app : (e₁ : PTerm) -> (e₂ : PTerm) -> PTerm
  Y : (t₁ : Type) -> PTerm

[_>>_] : ℕ -> PTerm -> PTerm -> PTerm
[ k >> u ] (bv i) with k ≟ i
... | yes _ = u
... | no _ = bv i
[ k >> u ] (fv x) = fv x
[ k >> u ] (lam t) = lam ([ (suc k) >> u ] t)
[ k >> u ] (app t1 t2) = app ([ k >> u ] t1) ([ k >> u ] t2)
[ k >> u ] (Y t) = Y t

_^_ : PTerm -> PTerm -> PTerm
t ^ u = [ 0 >> u ] t

_^'_ : PTerm -> Atom -> PTerm
t ^' x = t ^ (fv x)

[_<<_] : ℕ -> Atom -> PTerm -> PTerm
[ k << x ] (bv i) = bv i
[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
[ k << x ] (lam t) = lam ([ (suc k) << x ] t)
[ k << x ] (app t1 t2) = app ([ k << x ] t1) ([ k << x ] t2)
[ k << x ] (Y t) = Y t

*_^_ : Atom -> PTerm -> PTerm
* x ^ t = [ 0 << x ] t

_[_::=_] : PTerm -> Atom -> PTerm -> PTerm
bv i [ x ::= u ] = bv i
fv y [ x ::= u ] with x ≟ y
... | yes _ = u
... | no _ = fv y
lam t [ x ::= u ] = lam (t [ x ::= u ])
app t1 t2 [ x ::= u ] = app (t1 [ x ::= u ]) (t2 [ x ::= u ])
Y t₁ [ x ::= u ] = Y t₁

FVars = List Atom

FV : PTerm -> FVars
FV (bv i) = []
FV (fv x) = x ∷ []
FV (lam e) = FV e
FV (app e₁ e₂) = FV e₁ ++ FV e₂
FV (Y t) = []

data Term : PTerm -> Set where
  var : ∀ {x} -> Term (fv x)
  lam : (L : FVars) -> ∀ {e} ->
    (cf : ∀ {x} -> (x∉L : x ∉ L) -> Term (e ^' x)) -> Term (lam e)
  app : ∀ {e₁ e₂} -> Term e₁ -> Term e₂ -> Term (app e₁ e₂)
  Y : ∀ {t} -> Term (Y t)

postulate ∃fresh : FVars -> Atom
postulate ∃fresh-spec : ∀ L -> ∃fresh L ∉ L

∪ : FVars -> Atom
∪ [] = 0
∪ (x ∷ xs) = x ⊔ (∪ xs)

∃fresh-impl : FVars -> Atom
∃fresh-impl list = suc (∪ list)

_∨_ = _⊎_

ℕ-meet-dist : ∀ {x y z : ℕ} -> (x ≤ y) ∨ (x ≤ z) -> x ≤ y ⊔ z
ℕ-meet-dist {zero} x≤y⊎x≤z = z≤n
ℕ-meet-dist {suc x} {zero} {zero} (inj₁ ())
ℕ-meet-dist {suc x} {zero} {zero} (inj₂ ())
ℕ-meet-dist {suc x} {zero} {suc z} (inj₁ ())
ℕ-meet-dist {suc x} {zero} {suc z} (inj₂ sx≤sz) = sx≤sz
ℕ-meet-dist {suc x} {suc y} {zero} (inj₁ sx≤sy) = sx≤sy
ℕ-meet-dist {suc x} {suc y} {zero} (inj₂ ())
ℕ-meet-dist {suc x} {suc y} {suc z} (inj₁ (s≤s x≤y)) = s≤s (ℕ-meet-dist (inj₁ x≤y))
ℕ-meet-dist {suc x} {suc y} {suc z} (inj₂ (s≤s y≤z)) = s≤s (ℕ-meet-dist {_} {y} {z} (inj₂ y≤z))

≤-refl : ∀ {x : ℕ} -> x ≤ x
≤-refl {zero} = z≤n
≤-refl {suc x} = s≤s ≤-refl

∈-cons : ∀ {L} {x y : ℕ} -> x ∈ (y ∷ L) -> ¬(x ≡ y) -> x ∈ L
∈-cons {[]} (here refl) ¬x≡y = ⊥-elim (¬x≡y refl)
∈-cons {[]} (there ()) ¬x≡y
∈-cons {y ∷ L} {x} (here refl) ¬x≡y = ⊥-elim (¬x≡y refl)
∈-cons {y ∷ L} {x} (there x∈L) ¬x≡y = x∈L

∃fresh-impl-spec' : ∀ x L -> x ∈ L -> x ≤ ∪ L
∃fresh-impl-spec' x [] ()
∃fresh-impl-spec' x (y ∷ L) x∈y∷L with x ≟ y
∃fresh-impl-spec' x (.x ∷ L) x∈y∷L | yes refl = ℕ-meet-dist {x} {x} (inj₁ ≤-refl)
∃fresh-impl-spec' x (y ∷ L) x∈y∷L | no ¬x≡y = ℕ-meet-dist {x} {y} (inj₂ (∃fresh-impl-spec' x L (∈-cons x∈y∷L ¬x≡y)))

∃fresh-impl-spec'' : ∀ x L -> x ∈ L -> ¬ (x ≡ ∃fresh-impl L)
∃fresh-impl-spec'' .(suc (∪ L)) L x∈L refl = 1+n≰n {∪ L} (∃fresh-impl-spec' (suc (∪ L)) L x∈L)

∃fresh-impl-spec : ∀ L -> ∃fresh-impl L ∉ L
∃fresh-impl-spec L ∃fresh-implL∈L = ∃fresh-impl-spec'' (∃fresh-impl L) L ∃fresh-implL∈L refl

module Core where

open import Data.Empty
open import Data.Nat
open import Data.List
open import Data.List.Any as Any
open Any.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

Atom = ℕ

data Type : Set where
  σ : Type
  _⟶_ : (t₁ : Type) -> (t₂ : Type) -> Type

data PTerm : Set where
  bv : (i : ℕ) -> PTerm
  fv : (x : Atom) -> PTerm
  lam : (e : PTerm) -> PTerm
  app : (e₁ : PTerm) -> (e₂ : PTerm) -> PTerm
  Y : (t₁ : Type) -> PTerm

[_>>_] : ℕ -> PTerm -> PTerm -> PTerm
[ k >> u ] (bv i) with k ≟ i
... | yes _ = u
... | no _ = bv i
[ k >> u ] (fv x) = fv x
[ k >> u ] (lam t) = lam ([ (suc k) >> u ] t)
[ k >> u ] (app t1 t2) = app ([ k >> u ] t1) ([ k >> u ] t2)
[ k >> u ] (Y t) = Y t

_^_ : PTerm -> PTerm -> PTerm
t ^ u = [ 0 >> u ] t

_^'_ : PTerm -> Atom -> PTerm
t ^' x = t ^ (fv x)

[_<<_] : ℕ -> Atom -> PTerm -> PTerm
[ k << x ] (bv i) = bv i
[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
[ k << x ] (lam t) = lam ([ (suc k) << x ] t)
[ k << x ] (app t1 t2) = app ([ k << x ] t1) ([ k << x ] t2)
[ k << x ] (Y t) = Y t

cls : Atom -> PTerm -> PTerm
cls x = [ 0 << x ]

_[_::=_] : PTerm -> Atom -> PTerm -> PTerm
bv i [ x ::= u ] = bv i
fv y [ x ::= u ] with x ≟ y
... | yes _ = u
... | no _ = fv y
lam t [ x ::= u ] = lam (t [ x ::= u ])
app t1 t2 [ x ::= u ] = app (t1 [ x ::= u ]) (t2 [ x ::= u ])
Y t₁ [ x ::= u ] = Y t₁

FVars = List Atom

FV : PTerm -> FVars
FV (bv i) = []
FV (fv x) = x ∷ []
FV (lam e) = FV e
FV (app e₁ e₂) = FV e₁ ++ FV e₂
FV (Y t) = []

data Term : PTerm -> Set where
  var : ∀ {x} -> Term (fv x)
  lam : (L : FVars) -> ∀ {e} ->
    (cf : ∀ {x} -> (x∉L : x ∉ L) -> Term (e ^' x)) -> Term (lam e)
  app : ∀ {e₁ e₂} -> Term e₁ -> Term e₂ -> Term (app e₁ e₂)
  Y : ∀ {t} -> Term (Y t)

postulate ∃fresh : FVars -> Atom
postulate ∃fresh-spec : ∀ L -> ∃fresh L ∉ L


cases of progress; collapsing a couple of redundant ones into catch all pattern matches

open import Nat
open import Prelude
open import List
open import core
open import contexts

module progress where

  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → Δ ⊢ d err → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d Δ
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | _
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp (TALam D1) MAArr D2) | V VLam | I x₁ = S (_ , Step (FAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!})
  progress (TAAp D1 x₂ D2) | _ | E x₁ = E (EAp2 x₁)
  progress (TAAp D1 x₂ D2) | E x | _ = E (EAp1 x)
  progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole x x₁) = I IEHole
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V VConst = I (INEHole (FVal VConst))
  progress (TANEHole x₁ (TALam D) x₂) | V VLam = I (INEHole (FVal VLam))
  progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  progress (TANEHole x₃ D x₄) | S (d , Step x x₁ x₂) = S (_ , (Step (FNEHole x) x₁ (FNEHole x₂)))
  progress (TACast D x)
    with progress D
  progress (TACast TAConst TCRefl)  | V VConst = {!!}
  progress (TACast TAConst TCHole2) | V VConst = {!!}
  progress (TACast D x₁) | V VLam = {!!}
  progress (TACast D x₁) | I x = I (ICast x)
  progress (TACast D x₁) | E x = E (ECastProp x)
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S ( _ , Step (FCast x) x₁ (FCast x₂))

open import Nat
open import Prelude
open import List
open import core
open import contexts

module progress where

  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → d err[ Δ ] → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d Δ
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | V x₁
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp TAConst () D2) | V VConst | I x₁
  progress (TAAp (TALam D1) MAArr D2) | V VLam | I x₁ = S (_ , Step (FAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!})
  progress (TAAp D1 x₂ D2) | V x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole x x₁) = I IEHole
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V VConst = I (INEHole (FVal VConst))
  progress (TANEHole x₁ (TALam D) x₂) | V VLam = I (INEHole (FVal VLam))
  progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole x₁ D x₂) | E x = E {!!}
  progress (TANEHole x₃ D x₄) | S (d , Step x x₁ x₂) = S (_ , (Step (FNEHole x) x₁ (FNEHole x₂)))
  progress (TACast D x)
    with progress D
  progress (TACast TAConst TCRefl)  | V VConst = E {!!}
  progress (TACast TAConst TCHole2) | V VConst = E {!!}
  progress (TACast D x₁) | V VLam = E {!!}
  progress (TACast D x₁) | I x = I (ICast x)
  progress (TACast D x₁) | E x = E {!!}
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S ( _ , Step (FCast x) x₁ (FCast x₂))


flipping the cast syntax to match the paper (and make sense)

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_]    : (Nat × subst) → ë
    ⦇_⦈[_]   : ë → (Nat × subst) → ë
    _∘_      : ë → ë → ë
    <_>_     : τ̇ → ë → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< t2 > e1') ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< t2 > e2') ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ⟦ u ::[ Γ ] ⦇⦈ ⟧
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< t > e') ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      EALam : ∀{Γ x t1 t2 e e' t2' Δ } →
              (Γ ,, (x , t1)) ⊢ e ⇐ t2 ~> e' :: t2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ (t1 ==> t2) ~> ·λ x [ t1 ] e' :: (t1 ==> t2') ⊣ Δ
      EASubsume : ∀{e u m Γ t' e' Δ t} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ m ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                  t ~ t' →
                  Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ
      EAEHole : ∀{ Γ u t  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ t ~> ⦇⦈[ u , id Γ ] :: t ⊣ ⟦ u ::[ Γ ] t ⟧
      EANEHole : ∀{ Γ e u t e' t' Δ  } →
                 Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                 t ~ t' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ t ~> ⦇ e' ⦈[ u , id Γ ] :: t ⊣ (Δ ,, u ::[ Γ ] t)

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where
    TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
    TAVar : ∀{Δ Γ x t} → Δ , (Γ ,, (x , t)) ⊢ X x :: t
    TALam : ∀{ Δ Γ x t1 e t2} →
            Δ , (Γ ,, (x , t1)) ⊢ e :: t2 →
            Δ , Γ ⊢ ·λ x [ t1 ] e :: (t1 ==> t2)
    TAAp : ∀{ Δ Γ e1 e2 t1 t2 t} →
           Δ , Γ ⊢ e1 :: t1 →
           t1 ▸arr (t2 ==> t) →
           Δ , Γ ⊢ e2 :: t2 →
           Δ , Γ ⊢ e1 ∘ e2 :: t
    -- TAEHole : ∀{ Δ Γ σ u Γ' } → -- todo: overloaded form in the paper here
    -- TANEHole : ∀ { Δ Γ e t' Γ' u σ t }
    TACast : ∀{ Δ Γ e t t'} →
           Δ , Γ ⊢ e :: t' →
           t ~ t' →
           Δ , Γ ⊢ < t > e :: t

  -- todo: substition goes here

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u , σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< t > e) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- error
  data _err[_] : ë → hctx → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : ë → ë → Set where
    STHole : ∀{ e e' u σ } →
             e ↦ e' →
             ⦇ e ⦈[ u , σ ] ↦ ⦇ e' ⦈[ u , σ ]
    -- STCast
    STAp1 : ∀{ e1 e2 e1' } →
            e1 ↦ e1' →
            (e1 ∘ e2) ↦ (e1' ∘ e2)
    STAp2 : ∀{ e1 e2 e2' } →
            e1 final →
            e2 ↦ e2' →
            (e1 ∘ e2) ↦ (e1 ∘ e2')
    STApβ : ∀{ e1 e2 t x } →
            e2 final →
            ((·λ x [ t ] e1) ∘ e2) ↦ ([ ⟦ x , {!!} ⟧ ] e2)

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_]    : (Nat × subst) → ë
    ⦇_⦈[_]   : ë → (Nat × subst) → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< e2' > t2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ⟦ u ::[ Γ ] ⦇⦈ ⟧
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< e' > t) ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      EALam : ∀{Γ x t1 t2 e e' t2' Δ } →
              (Γ ,, (x , t1)) ⊢ e ⇐ t2 ~> e' :: t2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ (t1 ==> t2) ~> ·λ x [ t1 ] e' :: (t1 ==> t2') ⊣ Δ
      EASubsume : ∀{e u m Γ t' e' Δ t} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ m ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                  t ~ t' →
                  Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ
      EAEHole : ∀{ Γ u t  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ t ~> ⦇⦈[ u , id Γ ] :: t ⊣ ⟦ u ::[ Γ ] t ⟧
      EANEHole : ∀{ Γ e u t e' t' Δ  } →
                 Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                 t ~ t' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ t ~> ⦇ e' ⦈[ u , id Γ ] :: t ⊣ (Δ ,, u ::[ Γ ] t)

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where
    TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
    TAVar : ∀{Δ Γ x t} → Δ , (Γ ,, (x , t)) ⊢ X x :: t
    TALam : ∀{ Δ Γ x t1 e t2} →
            Δ , (Γ ,, (x , t1)) ⊢ e :: t2 →
            Δ , Γ ⊢ ·λ x [ t1 ] e :: (t1 ==> t2)
    TAAp : ∀{ Δ Γ e1 e2 t1 t2 t} →
           Δ , Γ ⊢ e1 :: t1 →
           t1 ▸arr (t2 ==> t) →
           Δ , Γ ⊢ e2 :: t2 →
           Δ , Γ ⊢ e1 ∘ e2 :: t
    -- TAEHole : ∀{ Δ Γ σ u Γ' } → -- todo: overloaded form in the paper here
    -- TANEHole : ∀ { Δ Γ e t' Γ' u σ t }
    TACast : ∀{ Δ Γ e t t'} →
           Δ , Γ ⊢ e :: t' →
           t ~ t' →
           Δ , Γ ⊢ < e > t :: t

  -- todo: substition goes here

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u , σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- error
  data _err[_] : ë → hctx → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : ë → ë → Set where
    STHole : ∀{ e e' u σ } →
             e ↦ e' →
             ⦇ e ⦈[ u , σ ] ↦ ⦇ e' ⦈[ u , σ ]
    -- STCast
    STAp1 : ∀{ e1 e2 e1' } →
            e1 ↦ e1' →
            (e1 ∘ e2) ↦ (e1' ∘ e2)
    STAp2 : ∀{ e1 e2 e2' } →
            e1 final →
            e2 ↦ e2' →
            (e1 ∘ e2) ↦ (e1 ∘ e2')
    STApβ : ∀{ e1 e2 t x } →
            e2 final →
            ((·λ x [ t ] e1) ∘ e2) ↦ ([ ⟦ x , {!!} ⟧ ] e2)


knocked out a bunch of easy preservation cases #2

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) D1 D2 D3 (FHAp1 D4) = TAAp {!!} {!!}
  pres-lem (FHAp2 eps) D1 D2 D3 (FHAp2 D4) = TAAp {!!} {!!}
  pres-lem (FHNEHole eps) D1 D2 D3 (FHNEHole D4) = TANEHole {!!} {!!} {!!}
  pres-lem (FHCast eps) D1 D2 D3 (FHCast D4) = {!!}
  pres-lem (FHFailedCast eps) D1 D2 D3 (FHFailedCast D4) = {!!}

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x y z w) (FHFailedCast FHOuter) = _ , TACast x TCHole1
  pres-lem2 (TAFailedCast x y z w) (FHFailedCast (FHCast eps)) = pres-lem2 x eps

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = {!!} -- todo: this is a lemma
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) D1 D2 D3 (FHAp1 D4) = {!!}
  pres-lem (FHAp2 eps) D1 D2 D3 (FHAp2 D4) = {!!}
  pres-lem (FHNEHole eps) D1 D2 D3 (FHNEHole D4) = {!!}
  pres-lem (FHCast eps) D1 D2 D3 (FHCast D4) = {!!}
  pres-lem (FHFailedCast eps) D1 D2 D3 (FHFailedCast D4) = {!!}

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) eps = {!!}

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp ta ta₁) (ITLam) = {!!}
  pres-lem3 (TAAp ta ta₁) (ITApCast) = {!!}
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) () -- todo: this is a little surprising; nehole doesn't take a transition but it defieately can still step
  pres-lem3 (TACast ta x) (ITCastID) = {!!}
  pres-lem3 (TACast ta x) (ITCastSucceed x₂) = {!!}
  pres-lem3 (TACast ta x) (ITGround y) = {!!}
  pres-lem3 (TACast ta x) (ITExpand x₂) = {!!}
  pres-lem3 (TACast ta x) (ITCastFail w y z) = {!!}
  pres-lem3 (TAFailedCast x y z q) xx  = {!!}

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂


Fixed wrong importation.

Fixed wrong importation.

Ignore-this: b91d2c992b8642e6c3b42facc2c7ffb

darcs-hash:20100716151338-3bd4e-120a3d65a2b01e7dfe3f436a5ceb23ec962fa2b9.gz

------------------------------------------------------------------------------
-- Equations for the division
------------------------------------------------------------------------------

module Examples.DivisionPCF.EquationsPCF where

open import LTC.Minimal

open import Examples.DivisionPCF.DivisionPCF
open import LTC.Data.NatPCF
open import LTC.Data.NatPCF.InequalitiesPCF
open import LTC.Data.NatPCF.InequalitiesPCF.PropertiesPCF using ( x≥y→x≮y )

----------------------------------------------------------------------
-- The division result when the dividend is minor than the
-- the divisor

postulate
  div-x<y : {i j : D} → LT i j → div i j ≡ zero
{-# ATP prove div-x<y #-}

-- The division result when the dividend is greater or equal than the
-- the divisor

postulate
  div-x≥y : {i j : D} → N i → N j → GE i j → div i j ≡ succ (div (i - j) j)
{-# ATP prove div-x≥y x≥y→x≮y #-}

------------------------------------------------------------------------------
-- Equations for the division
------------------------------------------------------------------------------

module Examples.DivisionPCF.EquationsPCF where

open import LTC.Minimal

open import Examples.DivisionPCF.DivisionPCF
open import LTC.Data.NatPCF
open import LTC.Data.NatPCF.InequalitiesPCF
open import LTC.Data.NatPCF.InequalitiesPCF.PropertiesPCF-ER using ( x≥y→x≮y )

----------------------------------------------------------------------
-- The division result when the dividend is minor than the
-- the divisor

postulate
  div-x<y : {i j : D} → LT i j → div i j ≡ zero
{-# ATP prove div-x<y #-}

-- The division result when the dividend is greater or equal than the
-- the divisor

postulate
  div-x≥y : {i j : D} → N i → N j → GE i j → div i j ≡ succ (div (i - j) j)
{-# ATP prove div-x≥y x≥y→x≮y #-}


Removed unnecessary hypothesis.

Removed unnecessary hypothesis.

Ignore-this: 25c9053c3019cb1adfc7df8c66c7c691

darcs-hash:20110405150506-3bd4e-991423ec03c050d8695db68e7e3bcceecf07d500.gz

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 zN      = nest-0
nest-x≡0 (sN {n} Nn) =
  begin
    nest (succ n)
      ≡⟨ nest-S n ⟩
    nest (nest n)
      ≡⟨ subst (λ t → nest (nest n) ≡ nest t)
               (nest-x≡0 Nn)  -- IH.
               refl
      ⟩
    nest zero
      ≡⟨ nest-0 ⟩
    zero
  ∎

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-DN : ∀ {d} → Dom d → N (nest d)
nest-DN dom0           = subst N (sym nest-0) zN
nest-DN (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-DN h₂)

-- The nest function is total.
nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) zN

nest-≤ : ∀ {n} → Dom n → LE (nest n) n
nest-≤ dom0 =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ (domS n h₁ h₂) =
  ≤-trans (nest-N (sN (dom-N n h₁))) (nest-N (dom-N n h₁)) (sN Nn) prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N (dom-N n h₁)) Nn (sN Nn) (nest-≤ h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N Nx ) (x≤y→x<Sy (nest-N Nx) Nx (nest-≤ dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 zN      = nest-0
nest-x≡0 (sN {n} Nn) =
  begin
    nest (succ n)
      ≡⟨ nest-S n ⟩
    nest (nest n)
      ≡⟨ subst (λ t → nest (nest n) ≡ nest t)
               (nest-x≡0 Nn)  -- IH.
               refl
      ⟩
    nest zero
      ≡⟨ nest-0 ⟩
    zero
  ∎

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-DN : ∀ {d} → Dom d → N (nest d)
nest-DN dom0           = subst N (sym nest-0) zN
nest-DN (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-DN h₂)

-- The nest function is total.
nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) zN

nest-≤ : ∀ {n} → N n → Dom n → LE (nest n) n
nest-≤ Nz dom0           =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ NSn (domS n h₁ h₂) =
  ≤-trans (nest-N (sN (dom-N n h₁))) (nest-N (dom-N n h₁)) NSn prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ (dom-N (nest n) h₂) h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N (dom-N n h₁)) Nn NSn (nest-≤ Nn h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N Nx ) (x≤y→x<Sy (nest-N Nx) Nx (nest-≤ Nx dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)