Vec: Bij is now typed

Vec: Bij is now typed

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

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 `0↔1 : Perm
      _`⁏_ : Perm → Perm → Perm
      `tl : Perm → Perm

    _⁻¹ : Endo Perm
    `id ⁻¹ = `id
    (f₀ `⁏ f₁) ⁻¹ = f₁ ⁻¹ `⁏ f₀ ⁻¹
    `0↔1 ⁻¹ = `0↔1
    (`tl f) ⁻¹ = `tl (f ⁻¹)

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

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

    `⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Perm
    `⟨ 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 : Perm → ∀ {n} → Endo (Vec A n)
    eval `id             = id
    eval (f `⁏ g)        = eval g ∘ eval f
    eval `0↔1            = 0↔1
    eval (`tl f) {zero}  = id
    eval (`tl f) {suc n} = λ xs → head xs ∷ eval f (tail xs)

    infixr 9 _∙_
    _∙_ : 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

    _≗′_ : Perm → Perm → Set _
    f ≗′ g = ∀ {n} (xs : Vec A n) → f ∙ xs ≡ g ∙ xs

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

    _⁻¹-inverse : ∀ f → (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) [] = refl
    ((`tl f) ⁻¹-inverse) (x ∷ xs)
      rewrite (f ⁻¹-inverse) xs = refl

    _⁻¹-involutive : ∀ f → (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) [] = refl
    ((`tl f) ⁻¹-involutive) (x ∷ xs)
      rewrite (f ⁻¹-involutive) xs
            = refl

    _⁻¹-inverse′ : ∀ f → (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) xs → (f ∙ fs ⊛ f ∙ xs) ≡ f ∙ (fs ⊛ xs)
    ⊛-dist-∙ _       `id        _  = refl
    ⊛-dist-∙ fs      `0↔1       xs = ⊛-dist-0↔1 fs xs
    ⊛-dist-∙ []       (`tl _)   [] = refl
    ⊛-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 → f ∙ replicate {n = n} x ≡ replicate x
    ∙-replicate n x `id = refl
    ∙-replicate zero x `0↔1 = refl
    ∙-replicate (suc zero) x `0↔1 = refl
    ∙-replicate (suc (suc n)) x `0↔1 = refl
    ∙-replicate zero x (`tl _) = refl
    ∙-replicate (suc n) x (`tl f) rewrite ∙-replicate n x f = refl
    ∙-replicate n x (f `⁏ g) rewrite ∙-replicate n x f | ∙-replicate n 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 {n} f g xs rewrite sym (⊛-dist-∙ (replicate f) g xs) | ∙-replicate n f g = refl

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

module BijectionLib where
    open BijectionSyntax
    mapBij : ∀ {a bᴬ} {A : Set a} {Bijᴬ : Set bᴬ}
               {b bᴮ} {B : Set b} {Bijᴮ : Set bᴮ}
             → (B → A)
             → (Bijᴬ → Bijᴮ)
             → Bij A Bijᴬ → Bij B Bijᴮ
    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ᴬ

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

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

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

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

    _⁻¹-inverse : ∀ f → (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) [] = refl
    ((fᴬ `∷ f) ⁻¹-inverse) (x ∷ xs)
      rewrite (fᴬ ⁻¹-inverseᴬ) x | (f x ⁻¹-inverse) xs = refl

    _⁻¹-involutive : ∀ f → (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) [] = 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 (λ f → eval f {n}) _⁻¹ `id _`⁏_ (λ _ → refl) (λ _ _ _ → refl)
                (λ f x → _⁻¹-inverse f x) (λ f x → _⁻¹-involutive f x)

    module VecBijKit n = BijKit (Vec-bijKit n)

    `tl : Endo Bij
    `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 : Perm → Bij
    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 π) [] = 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
        `⟨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
        `⟨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
    `⟨ 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


Make some arguments of correctness explicit.

Old-commit-hash: b8f4ff3d6b2f0ea72c79a94c10ae3ec1b545c2ca

module Denotation.Specification.Canon-Popl14 where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality
⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (dρ : ΔEnv Γ) → Change τ

-- better name is: ⟦_⟧Δ reacts to future arguments
validity : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ) →
  valid {τ} (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)

-- better name is: ⟦_⟧Δ reacts to free variables
correctness : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ)
  → ⟦ t ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ ≡ ⟦ t ⟧ (update dρ)

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

⟦_⟧Δ (intlit n) dρ = + 0
⟦_⟧Δ (add s t) dρ = ⟦ s ⟧Δ dρ + ⟦ t ⟧Δ dρ
⟦_⟧Δ (minus t) dρ = - ⟦ t ⟧Δ dρ
⟦_⟧Δ empty dρ = emptyBag
⟦_⟧Δ (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) dρ = ⟦ s ⟧Δ dρ ++ ⟦ t ⟧Δ dρ
⟦_⟧Δ (negate t) dρ = negateBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) dρ = sumBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (var x) dρ = ⟦ x ⟧ΔVar dρ
⟦_⟧Δ (app {σ} {τ} s t) dρ =
     (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)
  (validity {σ} t dρ))
⟦_⟧Δ (abs t) dρ = λ v →
  ⟦ t ⟧Δ (v • dρ)

validVar : ∀ {τ Γ} (x : Var Γ τ) →
  (dρ : ΔEnv Γ) → valid {τ} (⟦ x ⟧ (ignore dρ)) (⟦ x ⟧ΔVar dρ)
validVar this (cons v Δv R[v,Δv] • _) = R[v,Δv]
validVar {τ} (that x) (cons _ _ _ • dρ) = validVar {τ} x dρ

validity (intlit n)    dρ = tt
validity (add s t)     dρ = tt
validity (minus t)     dρ = tt
validity (empty)       dρ = tt
validity (insert s t)  dρ = tt
validity (union s t)   dρ = tt
validity (negate t)    dρ = tt
validity (flatmap s t) dρ = tt
validity (sum t)       dρ = tt

validity {τ} (var x) dρ = validVar {τ} x dρ

validity (app s t) dρ =
  let
    v = ⟦ t ⟧ (ignore dρ)
    Δv = ⟦ t ⟧Δ dρ
  in
    proj₁ (validity s dρ (cons v Δv (validity t dρ)))

validity {σ ⇒ τ} (abs t) dρ = λ v →
  let
    v′ = after {σ} v
    Δv′ = v′ ⊟₍ σ ₎ v′
    dρ₁ = v • dρ
    dρ₂ = nil-valid-change σ v′ • dρ
  in
    validity t dρ₁
    ,
    (begin
      ⟦ t ⟧ (ignore dρ₂) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₂
    ≡⟨ correctness t dρ₂ ⟩
      ⟦ t ⟧ (update dρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (update dρ₁)
    ≡⟨ sym (correctness t dρ₁) ⟩
      ⟦ t ⟧ (ignore dρ₁) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {dρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ x ⟧ΔVar dρ ≡ ⟦ x ⟧ (update dρ)
correctVar {x = this  } {cons v dv R[v,dv] • dρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] • dρ} = correctVar {x = y} {dρ}

correctness (intlit n) dρ = right-id-int n
correctness (add s t) dρ = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _+_ (correctness s dρ) (correctness t dρ))
correctness (minus t) dρ = trans
  (-m·-n=-mn {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong -_ (correctness t dρ))

correctness empty dρ = right-id-bag emptyBag
correctness (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness s dρ))
         (correctness t dρ) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness (union s t) dρ = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _++_ (correctness s dρ) (correctness t dρ))
correctness (negate t) dρ = trans
  (-a·-b=-ab {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong negateBag (correctness t dρ))

correctness (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness s dρ) (correctness t dρ))
correctness (sum t) dρ =
  let
    b = ⟦ t ⟧ (ignore dρ)
    Δb = ⟦ t ⟧Δ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness t dρ))

correctness {τ} (var x) dρ = correctVar {τ} {x = x}
correctness (app {σ} {τ} s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ (ignore dρ)
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δu = ⟦ t ⟧Δ dρ
  in
    begin
      f u ⊞₍ τ ₎ Δf (cons u Δu (validity {σ} t dρ))
    ≡⟨ sym (proj₂ (validity {σ ⇒ τ} s dρ (cons u Δu (validity {σ} t dρ)))) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} s dρ ⟨$⟩ correctness {σ} t dρ ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} (abs t) dρ = ext (λ v →
  let
    dρ′ : ΔEnv (σ • Γ)
    dρ′ = nil-valid-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ′
    ≡⟨ correctness {τ} t dρ′ ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv
corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {dρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore dρ) ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ dρ)
      (⟦ t ⟧ (ignore dρ) ⊞₍ σ ₎ ⟦ t ⟧Δ dρ)
  ≡ (⟦ s ⟧ (ignore dρ)) (⟦ t ⟧ (ignore dρ))
    ⊞₍ τ ₎
    (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ) (validity {σ} t dρ))

corollary {σ} {τ} s t {dρ} = proj₂
  (validity {σ ⇒ τ} s dρ (cons (⟦ t ⟧ (ignore dρ))
     (⟦ t ⟧Δ dρ) (validity {σ} t dρ)))

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  (v : ValidChange σ)
  → ⟦ t ⟧ ∅ (after {σ} v)
  ≡ ⟦ t ⟧ ∅ (before {σ} v) ⊞₍ τ ₎ ⟦ t ⟧Δ ∅ v

corollary-closed {σ} {τ} {t = t} v =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅
  in
    begin
      f (after {σ} v)
    ≡⟨ cong (λ hole → hole (after {σ} v))
            (sym (correctness {σ ⇒ τ} t ∅)) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} v)
    ≡⟨ proj₂ (validity {σ ⇒ τ} t ∅ v) ⟩
      f (before {σ} v) ⊞₍ τ ₎ Δf v
    ∎ where open ≡-Reasoning

module Denotation.Specification.Canon-Popl14 where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality
⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (dρ : ΔEnv Γ) → Change τ

-- better name is: ⟦_⟧Δ reacts to future arguments
validity : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ) →
  valid {τ} (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)

-- better name is: ⟦_⟧Δ reacts to free variables
correctness : ∀ {τ Γ} {t : Term Γ τ} {dρ : ΔEnv Γ}
  → ⟦ t ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ ≡ ⟦ t ⟧ (update dρ)

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

⟦_⟧Δ (intlit n) dρ = + 0
⟦_⟧Δ (add s t) dρ = ⟦ s ⟧Δ dρ + ⟦ t ⟧Δ dρ
⟦_⟧Δ (minus t) dρ = - ⟦ t ⟧Δ dρ
⟦_⟧Δ empty dρ = emptyBag
⟦_⟧Δ (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) dρ = ⟦ s ⟧Δ dρ ++ ⟦ t ⟧Δ dρ
⟦_⟧Δ (negate t) dρ = negateBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) dρ = sumBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (var x) dρ = ⟦ x ⟧ΔVar dρ
⟦_⟧Δ (app {σ} {τ} s t) dρ =
     (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)
  (validity {σ} t dρ))
⟦_⟧Δ (abs t) dρ = λ v →
  ⟦ t ⟧Δ (v • dρ)

validVar : ∀ {τ Γ} (x : Var Γ τ) →
  (dρ : ΔEnv Γ) → valid {τ} (⟦ x ⟧ (ignore dρ)) (⟦ x ⟧ΔVar dρ)
validVar this (cons v Δv R[v,Δv] • _) = R[v,Δv]
validVar {τ} (that x) (cons _ _ _ • dρ) = validVar {τ} x dρ

validity (intlit n)    dρ = tt
validity (add s t)     dρ = tt
validity (minus t)     dρ = tt
validity (empty)       dρ = tt
validity (insert s t)  dρ = tt
validity (union s t)   dρ = tt
validity (negate t)    dρ = tt
validity (flatmap s t) dρ = tt
validity (sum t)       dρ = tt

validity {τ} (var x) dρ = validVar {τ} x dρ

validity (app s t) dρ =
  let
    v = ⟦ t ⟧ (ignore dρ)
    Δv = ⟦ t ⟧Δ dρ
  in
    proj₁ (validity s dρ (cons v Δv (validity t dρ)))

validity {σ ⇒ τ} (abs t) dρ = λ v →
  let
    v′ = after {σ} v
    Δv′ = v′ ⊟₍ σ ₎ v′
    dρ₁ = v • dρ
    dρ₂ = nil-valid-change σ v′ • dρ
  in
    validity t dρ₁
    ,
    (begin
      ⟦ t ⟧ (ignore dρ₂) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₂
    ≡⟨ correctness {t = t} {dρ₂} ⟩
      ⟦ t ⟧ (update dρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (update dρ₁)
    ≡⟨ sym (correctness {t = t} {dρ₁}) ⟩
      ⟦ t ⟧ (ignore dρ₁) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {dρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ x ⟧ΔVar dρ ≡ ⟦ x ⟧ (update dρ)
correctVar {x = this  } {cons v dv R[v,dv] • dρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] • dρ} = correctVar {x = y} {dρ}

correctness {t = intlit n} = right-id-int n
correctness {t = add s t} {dρ} = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _+_ (correctness {t = s}) (correctness {t = t}))
correctness {t = minus t} {dρ} = trans
  (-m·-n=-mn {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong -_ (correctness {t = t}))

correctness {t = empty} = right-id-bag emptyBag
correctness {t = insert s t} {dρ} =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness {t = s}))
         (correctness {t = t}) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness {t = union s t} {dρ} = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _++_ (correctness {t = s}) (correctness {t = t}))
correctness {t = negate t} {dρ} = trans
  (-a·-b=-ab {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong negateBag (correctness {t = t}))

correctness {t = flatmap s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness {t = s}) (correctness {t = t}))
correctness {t = sum t} {dρ} =
  let
    b = ⟦ t ⟧ (ignore dρ)
    Δb = ⟦ t ⟧Δ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness {t = t}))

correctness {τ} {t = var x} = correctVar {τ} {x = x}
correctness {t = app {σ} {τ} s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ (ignore dρ)
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δu = ⟦ t ⟧Δ dρ
  in
    begin
      f u ⊞₍ τ ₎ Δf (cons u Δu (validity {σ} t dρ))
    ≡⟨ sym (proj₂ (validity {σ ⇒ τ} s dρ (cons u Δu (validity {σ} t dρ)))) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} {t = s} ⟨$⟩ correctness {σ} {t = t} ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} {abs t} {dρ} = ext (λ v →
  let
    dρ′ : ΔEnv (σ • Γ)
    dρ′ = nil-valid-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ′
    ≡⟨ correctness {τ} {t = t} {dρ′} ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv
corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {dρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore dρ) ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ dρ)
      (⟦ t ⟧ (ignore dρ) ⊞₍ σ ₎ ⟦ t ⟧Δ dρ)
  ≡ (⟦ s ⟧ (ignore dρ)) (⟦ t ⟧ (ignore dρ))
    ⊞₍ τ ₎
    (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ) (validity {σ} t dρ))

corollary {σ} {τ} s t {dρ} = proj₂
  (validity {σ ⇒ τ} s dρ (cons (⟦ t ⟧ (ignore dρ))
     (⟦ t ⟧Δ dρ) (validity {σ} t dρ)))

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  (v : ValidChange σ)
  → ⟦ t ⟧ ∅ (after {σ} v)
  ≡ ⟦ t ⟧ ∅ (before {σ} v) ⊞₍ τ ₎ ⟦ t ⟧Δ ∅ v

corollary-closed {σ} {τ} {t = t} v =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅
  in
    begin
      f (after {σ} v)
    ≡⟨ cong (λ hole → hole (after {σ} v))
            (sym (correctness {σ ⇒ τ} {t = t})) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} v)
    ≡⟨ proj₂ (validity {σ ⇒ τ} t ∅ v) ⟩
      f (before {σ} v) ⊞₍ τ ₎ Δf v
    ∎ where open ≡-Reasoning