Bits: propertis about search and count

Bits: propertis about search and count

module Data.Bits where

-- cleanup
import Level
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_==_)
open import Data.Nat.Properties
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Bool.Properties using (not-involutive)
open import Data.Maybe.NP
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise) renaming (_+_ to _+ᶠ_)
import Data.Vec.NP as V
open V hiding (_⊛_; rewire; rewireTbl) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)
open V public using ([]; _∷_; head; tail; replicate; RewireTbl)

Bit : Set
Bit = Bool

module Defs where
  0b = false
  1b = true
module Patterns where
  pattern 0b = false
  pattern 1b = true
open Patterns

Bits : ℕ → Set
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → Set
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0b

-- Warning: 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

vnot∘vnot≗id : ∀ {n} → vnot {n} ∘ vnot ≗ id
vnot∘vnot≗id [] = refl
vnot∘vnot≗id (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot≗id xs)

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ 0ⁿ
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ 1ⁿ
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1ⁿ ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1ⁿ x) ⟩
         x ⊕ (x ⊕ 1ⁿ) ≡⟨ sym (⊕-assoc x x 1ⁿ) ⟩
         (x ⊕ x) ⊕ 1ⁿ ≡⟨ cong (flip _⊕_ 1ⁿ) (⊕-≡ x) ⟩
         0ⁿ ⊕ 1ⁿ       ≡⟨ ⊕-left-identity 1ⁿ ⟩
         1ⁿ ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M : Set a → Set a} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad

allBits : ∀ n → Vec (Bits n) (2^ n)
allBits zero    = [] ∷ []
allBits (suc n) = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

search : ∀ {n a} {A : Set a} → (A → A → A) → (Bits n → A) → A
search {zero}  _   f = f []
search {suc n} _·_ f = search _·_ (f ∘ 0∷_) · search _·_ (f ∘ 1∷_)

#⟨_⟩ᶠ : ∀ {n} → (Bits n → Bool) → Fin (suc (2^ n))
#⟨ pred ⟩ᶠ = countᶠ pred (allBits _)

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → ℕ
#⟨ pred ⟩ = search _+_ (λ x → if pred x then 1 else 0)

#⟨⟩-spec : ∀ {n} (pred : Bits n → Bool) → #⟨ pred ⟩ ≡ Fin.toℕ #⟨ pred ⟩ᶠ
#⟨⟩-spec {zero}  pred with pred []
... | true = refl
... | false = refl
#⟨⟩-spec {suc n} pred rewrite count-++ pred (vmap 0∷_ (allBits n)) (vmap 1∷_ (allBits n))
                            | #⟨⟩-spec {n} (pred ∘ 0∷_)
                            | #⟨⟩-spec {n} (pred ∘ 1∷_)
                            | count-∘ 0∷_ pred (allBits n)
                            | count-∘ 1∷_ pred (allBits n) = refl

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ᶠ ≡ #⟨ g ⟩ᶠ
ext-# f≗g = ext-countᶠ f≗g (allBits _)

find? : ∀ {n a} {A : Set a} → (Bits n →? A) →? A
find? = search (M?._∣_ _)

findB : ∀ {n} → (Bits n → Bool) →? Bits n
findB pred = find? (λ x → if pred x then just x else nothing)

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry [] = 0b ∷ []
sucBCarry (0b ∷ xs) = 0b ∷ sucBCarry xs
sucBCarry (1b ∷ xs) with sucBCarry xs
... | 0b ∷ bs = 0b ∷ 1b ∷ bs
... | 1b ∷ bs = 1b ∷ 0b ∷ bs

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

rewire : ∀ {i o} → (Fin o → Fin i) → i →ᵇ o
rewire = V.rewire

rewireTbl : ∀ {i o} → RewireTbl i o → i →ᵇ o
rewireTbl = V.rewireTbl

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

lookupTbl : ∀ {n a} {A : Set a} → Bits n → Vec A (2 ^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0b ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1b ∷ key) tbl      = lookupTbl key (take (2 ^ n) (drop (2 ^ n) tbl))

funFromTbl : ∀ {n a} {A : Set a} → Vec A (2 ^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Vec A (2 ^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero} f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_) ++ []

funFromTbl∘tblFromFun : ∀ {n a} {A : Set a} (fun : Bits n → A) → funFromTbl (tblFromFun fun) ≗ fun
funFromTbl∘tblFromFun {zero} f [] = refl
funFromTbl∘tblFromFun {suc n} f (0b ∷ xs)
  rewrite take-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ []) =
    funFromTbl∘tblFromFun {n} (f ∘ 0∷_) xs
funFromTbl∘tblFromFun {suc n} f (1b ∷ xs)
  rewrite drop-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ [])
        | take-++ (2 ^ n) (tblFromFun {n} (f ∘ 1∷_)) [] =
    funFromTbl∘tblFromFun {n} (f ∘ 1∷_) xs

tblFromFun∘funFromTbl : ∀ {n a} {A : Set a} (tbl : Vec A (2 ^ n)) → tblFromFun {n} (funFromTbl tbl) ≡ tbl
tblFromFun∘funFromTbl {zero} (x ∷ []) = refl
tblFromFun∘funFromTbl {suc n} tbl
  rewrite tblFromFun∘funFromTbl {n} (take _ tbl)
        | tblFromFun∘funFromTbl {n} (take (2 ^ n) (drop (2 ^ n) tbl))
        | take-them-all (2 ^ n) (drop (2 ^ n) tbl)
        | take-drop-lem (2 ^ n) tbl
   = refl

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

always : ∀ n → Bits n → Bit
always _ _ = 1b
never  : ∀ n → Bits n → Bit
never _ _ = 0b

search-·-ε≡ε : ∀ {a} {A : Set a} ε (_·_ : A → A → A)
                 (ε·ε : ε · ε ≡ ε) n → search {n} _·_ (const ε) ≡ ε
search-·-ε≡ε ε _·_ ε·ε = go
  where
    go : ∀ n → search {n} _·_ (const ε) ≡ ε
    go zero = refl
    go (suc n) rewrite go n = ε·ε

#never≡0 : ∀ n → #⟨ never n ⟩ ≡ 0
#never≡0 = search-·-ε≡ε _ _ refl

#always≡2^_ : ∀ n → #⟨ always n ⟩ ≡ 2^ n
#always≡2^_ zero = refl
#always≡2^_ (suc n) = cong₂ _+_ pf pf where pf = #always≡2^ n

==-comm : ∀ {n} (xs ys : Bits n) → xs == ys ≡ ys == xs
==-comm [] [] = refl
==-comm (x ∷ xs) (x₁ ∷ ys) rewrite Xor°.+-comm x x₁ | ==-comm xs ys = refl

countᵇ : Bit → ℕ
countᵇ b = if b then 1 else 0

#⟨==_⟩ : ∀ {n} (xs : Bits n) → #⟨ _==_ xs ⟩ ≡ 1
#⟨== [] ⟩ = refl
#⟨==_⟩ {suc n} (true ∷ xs)  rewrite #never≡0 n | #⟨== xs ⟩ = refl
#⟨==_⟩ {suc n} (false ∷ xs) rewrite #never≡0 n | #⟨== xs ⟩ = refl

≗-cong-search : ∀ {n a} {A : Set a} op {f g : Bits n → A} → f ≗ g → search op f ≡ search op g
≗-cong-search {zero}  op f≗g = f≗g []
≗-cong-search {suc n} op f≗g = cong₂ op (≗-cong-search op (f≗g ∘ 0∷_))
                                        (≗-cong-search op (f≗g ∘ 1∷_))

≗-cong-# : ∀ {n} (f g : Bits n → Bit) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
≗-cong-# f g f≗g = ≗-cong-search _+_ (cong countᵇ ∘ f≗g)

#-+ : ∀ {n a b} (f : Bits (suc n) → Bit) → #⟨ f ∘ 0∷_ ⟩ ≡ a → #⟨ f ∘ 1∷_ ⟩ ≡ b → #⟨ f ⟩ ≡ a + b
#-+ f f0 f1 rewrite f0 | f1 = refl

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

==-refl : ∀ {n} (xs : Bits n) → (xs == xs) ≡ 1b
==-refl [] = refl
==-refl (true ∷ xs) = ==-refl xs
==-refl (false ∷ xs) = ==-refl xs

_|∨|_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_|∨|_ f g x = f x ∨ g x

_|∧|_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_|∧|_ f g x = f x ∧ g x

#-take-drop : ∀ m n (f : Bits m → Bit) (g : Bits n → Bit)
                → #⟨ (f ∘ take m) |∧| (g ∘ drop m) ⟩ ≡ #⟨ f ⟩ * #⟨ g ⟩
#-take-drop zero n f g with f []
... | true rewrite ℕ°.+-comm #⟨ g ⟩ 0 = refl
... | false = #never≡0 n
#-take-drop (suc m) n f g = trans (#-+ {a = #⟨ f ∘ 0∷_ ⟩ * #⟨ g ⟩} ((f ∘ take (suc m)) |∧| (g ∘ drop (suc m)))
                                  (trans (≗-cong-# ((f ∘ take (suc m)) |∧| (g ∘ drop (suc m)) ∘ 0∷_)
                                                ((f ∘ 0∷_ ∘ take m) |∧| (g ∘ drop m))
                                                (λ x → cong₂ (λ x y → f x ∧ g y) (take-∷ m 0b x) (drop-∷ m 0b x)))
                                       (#-take-drop m n (f ∘ 0∷_) g))
                                  (trans (≗-cong-# ((f ∘ take (suc m)) |∧| (g ∘ drop (suc m)) ∘ 1∷_)
                                                ((f ∘ 1∷_ ∘ take m) |∧| (g ∘ drop m))
                                                (λ x → cong₂ (λ x y → f x ∧ g y) (take-∷ m 1b x) (drop-∷ m 1b x)))
                                       (#-take-drop m n (f ∘ 1∷_) g)))
                           (sym (proj₂ ℕ°.distrib #⟨ g ⟩ #⟨ f ∘ 0∷_ ⟩ #⟨ f ∘ 1∷_ ⟩))

#-drop-take : ∀ m n (f : Bits n → Bit) (g : Bits m → Bit)
                → #⟨ (f ∘ drop m) |∧| (g ∘ take m) ⟩ ≡ #⟨ f ⟩ * #⟨ g ⟩
#-drop-take m n f g =
           #⟨ (f ∘ drop m) |∧| (g ∘ take m) ⟩
         ≡⟨ ≗-cong-# ((f ∘ drop m) |∧| (g ∘ take m)) ((g ∘ take m) |∧| (f ∘ drop m)) (λ x → Bool°.+-comm (f (drop m x)) _) ⟩
           #⟨ (g ∘ take m) |∧| (f ∘ drop m) ⟩
         ≡⟨ #-take-drop m n g f ⟩
           #⟨ g ⟩ * #⟨ f ⟩
         ≡⟨ ℕ°.*-comm #⟨ g ⟩ _ ⟩
           #⟨ f ⟩ * #⟨ g ⟩
         ∎
  where open ≡-Reasoning

#-take : ∀ m n (f : Bits m → Bit) → #⟨ f ∘ take m {n} ⟩ ≡ 2^ n * #⟨ f ⟩
#-take m n f = #⟨ f ∘ take m {n} ⟩
             ≡⟨ #-drop-take m n (always n) f ⟩
               #⟨ always n ⟩ * #⟨ f ⟩
             ≡⟨ cong (flip _*_ #⟨ f ⟩) (#always≡2^ n) ⟩
               2^ n * #⟨ f ⟩
             ∎
  where open ≡-Reasoning

#-drop : ∀ m n (f : Bits m → Bit) → #⟨ f ∘ drop n ⟩ ≡ 2^ n * #⟨ f ⟩
#-drop m n f = #⟨ f ∘ drop n ⟩
             ≡⟨ #-take-drop n m (always n) f ⟩
               #⟨ always n ⟩ * #⟨ f ⟩
             ≡⟨ cong (flip _*_ #⟨ f ⟩) (#always≡2^ n) ⟩
               2^ n * #⟨ f ⟩
             ∎
  where open ≡-Reasoning

#⟨_==⟩ : ∀ {n} (xs : Bits n) → #⟨ flip _==_ xs ⟩ ≡ 1
#⟨ xs ==⟩ = trans (≗-cong-# (flip _==_ xs) (_==_ xs) (flip ==-comm xs)) #⟨== xs ⟩

#⇒ : ∀ {n} (f g : Bits n → Bit) → (∀ x → T (f x) → T (g x)) → #⟨ f ⟩ ≤ #⟨ g ⟩
#⇒ {zero} f g f⇒g with f [] | g [] | f⇒g []
... | true  | true  | _ = s≤s z≤n
... | true  | false | p = ⊥-elim (p _)
... | false | _     | _ = z≤n
#⇒ {suc n} f g f⇒g = #⇒ (f ∘ 0∷_) (g ∘ 0∷_) (f⇒g ∘ 0∷_)
                +-mono #⇒ (f ∘ 1∷_) (g ∘ 1∷_) (f⇒g ∘ 1∷_)

#-∧-∨ᵇ : ∀ x y → countᵇ (x ∧ y) + countᵇ (x ∨ y) ≡ countᵇ x + countᵇ y
#-∧-∨ᵇ true y rewrite ℕ°.+-comm (countᵇ y) 1 = refl
#-∧-∨ᵇ false y = refl

#-∧-∨ : ∀ {n} (f g : Bits n → Bit) → #⟨ f |∧| g ⟩ + #⟨ f |∨| g ⟩ ≡ #⟨ f ⟩ + #⟨ g ⟩
#-∧-∨ {zero} f g = #-∧-∨ᵇ (f []) (g [])
#-∧-∨ {suc n} f g =
  trans
    (trans
       (helper #⟨ (f ∘ 0∷_) |∧| (g ∘ 0∷_) ⟩
               #⟨ (f ∘ 1∷_) |∧| (g ∘ 1∷_) ⟩
               #⟨ (f ∘ 0∷_) |∨| (g ∘ 0∷_) ⟩
               #⟨ (f ∘ 1∷_) |∨| (g ∘ 1∷_) ⟩)
       (cong₂ _+_ (#-∧-∨ (f ∘ 0∷_) (g ∘ 0∷_))
                  (#-∧-∨ (f ∘ 1∷_) (g ∘ 1∷_))))
    (helper #⟨ f ∘ 0∷_ ⟩ #⟨ g ∘ 0∷_ ⟩ #⟨ f ∘ 1∷_ ⟩ #⟨ g ∘ 1∷_ ⟩)
    where open SemiringSolver
          helper : ∀ x y z t → x + y + (z + t) ≡ x + z + (y + t)
          helper = solve 4 (λ x y z t → x :+ y :+ (z :+ t) := x :+ z :+ (y :+ t)) refl

#∨' : ∀ {n} (f g : Bits n → Bit) → #⟨ f |∨| g ⟩ ≤ #⟨ f ⟩ + #⟨ g ⟩
#∨' {zero} f g with f []
... | true  = s≤s z≤n
... | false = ℕ≤.refl
#∨' {suc _} f g = ℕ≤.trans (#∨' (f ∘ 0∷_) (g ∘ 0∷_) +-mono
                             #∨' (f ∘ 1∷_) (g ∘ 1∷_))
                    (ℕ≤.reflexive
                      (helper #⟨ f ∘ 0∷_ ⟩ #⟨ g ∘ 0∷_ ⟩ #⟨ f ∘ 1∷_ ⟩ #⟨ g ∘ 1∷_ ⟩))
    where open SemiringSolver
          helper : ∀ x y z t → x + y + (z + t) ≡ x + z + (y + t)
          helper = solve 4 (λ x y z t → x :+ y :+ (z :+ t) := x :+ z :+ (y :+ t)) refl

#∨ : ∀ {m n o} {f g : Bits o → Bit} → #⟨ f ⟩ ≤ m → #⟨ g ⟩ ≤ n → #⟨ (λ x → f x ∨ g x) ⟩ ≤ (m + n)
#∨ {m} {n} {o} {f} {g} pf pg = ℕ≤.trans (#∨' f g) (pf +-mono pg)

∧⇒∨ : ∀ x y → T (x ∧ y) → T (x ∨ y)
∧⇒∨ true y = _
∧⇒∨ false y = λ ()

#∧ : ∀ {m n o} {f g : Bits o → Bit} → #⟨ f ⟩ ≤ m → #⟨ g ⟩ ≤ n → #⟨ f |∧| g ⟩ ≤ (m + n)
#∧ {f = f} {g} pf pg = ℕ≤.trans (#⇒ (f |∧| g) (f |∨| g) (λ x → ∧⇒∨ (f x) (g x))) (#∨ {f = f} pf pg)

|de-morgan| : ∀ {n} (f g : Bits n → Bit) → f |∨| g ≗ not ∘ ((not ∘ f) |∧| (not ∘ g))
|de-morgan| f g x with f x
... | true = refl
... | false = sym (not-involutive _)

search-de-morgan : ∀ {n} op (f g : Bits n → Bit) → search op (f |∨| g) ≡ search op (not ∘ ((not ∘ f) |∧| (not ∘ g)))
search-de-morgan op f g = ≗-cong-search op {-(f |∨| g) (not ∘ ((not ∘ f) |∧| (not ∘ g)))-} (|de-morgan| f g)

search-comm :
  ∀ {n a b}
    {A : Set a} {B : Set b}
    (_+_ : A → A → A)
    (_*_ : B → B → B)
    (f : A → B)
    (p : Bits n → A)
    (hom : ∀ x y → f (x + y) ≡ f x * f y)
    → f (search _+_ p) ≡ search _*_ (f ∘ p)
search-comm {zero} _+_ _*_ f p hom = refl
search-comm {suc n} _+_ _*_ f p hom =
   trans (hom _ _)
         (cong₂ _*_ (search-comm {n} _+_ _*_ f (p ∘ 0∷_) hom)
                    (search-comm _+_ _*_ f (p ∘ 1∷_) hom))

[0↔_] : ∀ {n} → Fin n → Bits n → Bits n
[0↔_] {zero}  i xs = xs
[0↔_] {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

[0↔1] : Bits 2 → Bits 2
[0↔1] = [0↔ suc zero ]

[0↔1]-spec : [0↔1] ≗ (λ { (x ∷ y ∷ []) → y ∷ x ∷ [] })
[0↔1]-spec (x ∷ y ∷ []) = refl

open Defs public

module Data.Bits where

-- cleanup
import Level
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Bool.Properties using (not-involutive)
open import Data.Maybe.NP
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise) renaming (_+_ to _+ᶠ_)
import Data.Vec.NP as V
open V hiding (_⊛_; rewire; rewireTbl) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)
open V public using ([]; _∷_; head; tail; replicate; RewireTbl)

Bit : Set
Bit = Bool

module Defs where
  0b = false
  1b = true
module Patterns where
  pattern 0b = false
  pattern 1b = true
open Patterns

Bits : ℕ → Set
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → Set
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0b

-- Warning: 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

vnot∘vnot≗id : ∀ {n} → vnot {n} ∘ vnot ≗ id
vnot∘vnot≗id [] = refl
vnot∘vnot≗id (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot≗id xs)

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ 0ⁿ
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ 1ⁿ
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1ⁿ ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1ⁿ x) ⟩
         x ⊕ (x ⊕ 1ⁿ) ≡⟨ sym (⊕-assoc x x 1ⁿ) ⟩
         (x ⊕ x) ⊕ 1ⁿ ≡⟨ cong (flip _⊕_ 1ⁿ) (⊕-≡ x) ⟩
         0ⁿ ⊕ 1ⁿ       ≡⟨ ⊕-left-identity 1ⁿ ⟩
         1ⁿ ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M : Set a → Set a} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad

allBits : ∀ n → Vec (Bits n) (2^ n)
allBits zero    = [] ∷ []
allBits (suc n) = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

search : ∀ {n a} {A : Set a} → (A → A → A) → (Bits n → A) → A
search {zero}  _   f = f []
search {suc n} _·_ f = search _·_ (f ∘ 0∷_) · search _·_ (f ∘ 1∷_)

#⟨_⟩ᶠ : ∀ {n} → (Bits n → Bool) → Fin (suc (2^ n))
#⟨ pred ⟩ᶠ = countᶠ pred (allBits _)

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → ℕ
#⟨ pred ⟩ = search _+_ (λ x → if pred x then 1 else 0)

#⟨⟩-spec : ∀ {n} (pred : Bits n → Bool) → #⟨ pred ⟩ ≡ Fin.toℕ #⟨ pred ⟩ᶠ
#⟨⟩-spec {zero}  pred with pred []
... | true = refl
... | false = refl
#⟨⟩-spec {suc n} pred rewrite count-++ pred (vmap 0∷_ (allBits n)) (vmap 1∷_ (allBits n))
                            | #⟨⟩-spec {n} (pred ∘ 0∷_)
                            | #⟨⟩-spec {n} (pred ∘ 1∷_)
                            | count-∘ 0∷_ pred (allBits n)
                            | count-∘ 1∷_ pred (allBits n) = refl

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ᶠ ≡ #⟨ g ⟩ᶠ
ext-# f≗g = ext-countᶠ f≗g (allBits _)

find? : ∀ {n a} {A : Set a} → (Bits n →? A) →? A
find? = search (M?._∣_ _)

findB : ∀ {n} → (Bits n → Bool) →? Bits n
findB pred = find? (λ x → if pred x then just x else nothing)

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry [] = 0b ∷ []
sucBCarry (0b ∷ xs) = 0b ∷ sucBCarry xs
sucBCarry (1b ∷ xs) with sucBCarry xs
... | 0b ∷ bs = 0b ∷ 1b ∷ bs
... | 1b ∷ bs = 1b ∷ 0b ∷ bs

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

rewire : ∀ {i o} → (Fin o → Fin i) → i →ᵇ o
rewire = V.rewire

rewireTbl : ∀ {i o} → RewireTbl i o → i →ᵇ o
rewireTbl = V.rewireTbl

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

lookupTbl : ∀ {n a} {A : Set a} → Bits n → Vec A (2 ^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0b ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1b ∷ key) tbl      = lookupTbl key (take (2 ^ n) (drop (2 ^ n) tbl))

funFromTbl : ∀ {n a} {A : Set a} → Vec A (2 ^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Vec A (2 ^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero} f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_) ++ []

funFromTbl∘tblFromFun : ∀ {n a} {A : Set a} (fun : Bits n → A) → funFromTbl (tblFromFun fun) ≗ fun
funFromTbl∘tblFromFun {zero} f [] = refl
funFromTbl∘tblFromFun {suc n} f (0b ∷ xs)
  rewrite take-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ []) =
    funFromTbl∘tblFromFun {n} (f ∘ 0∷_) xs
funFromTbl∘tblFromFun {suc n} f (1b ∷ xs)
  rewrite drop-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ [])
        | take-++ (2 ^ n) (tblFromFun {n} (f ∘ 1∷_)) [] =
    funFromTbl∘tblFromFun {n} (f ∘ 1∷_) xs

tblFromFun∘funFromTbl : ∀ {n a} {A : Set a} (tbl : Vec A (2 ^ n)) → tblFromFun {n} (funFromTbl tbl) ≡ tbl
tblFromFun∘funFromTbl {zero} (x ∷ []) = refl
tblFromFun∘funFromTbl {suc n} tbl
  rewrite tblFromFun∘funFromTbl {n} (take _ tbl)
        | tblFromFun∘funFromTbl {n} (take (2 ^ n) (drop (2 ^ n) tbl))
        | take-them-all (2 ^ n) (drop (2 ^ n) tbl)
        | take-drop-lem (2 ^ n) tbl
   = refl

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

open Defs public


Drop ⟦_⟧*TypeHidCacheWrong

Drop ⟦_⟧*TypeHidCacheWrong

This wrong definition should not be counted among the failures before
CBPV, since it was created after and it is due to a separate limitation.

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for caching evaluation of MTerm
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Syntax.MType as MType

import Parametric.Denotation.Value as Value
import Parametric.Denotation.MValue as MValue

module Parametric.Denotation.CachingMValue
    (Base : Type.Structure)
    (⟦_⟧Base : Value.Structure Base)
  where

open import Base.Denotation.Notation

open Type.Structure Base
open MType.Structure Base
open Value.Structure Base ⟦_⟧Base
open MValue.Structure Base ⟦_⟧Base

open import Data.Product hiding (map)
open import Data.Sum hiding (map)
open import Data.Unit
open import Level
open import Function hiding (const)

module Structure where
  {-# NO_TERMINATION_CHECK #-}
  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  --
  -- XXX The termination checker isn't happy with it, and it may be right ─ if
  -- you keep substituting τ₁ = U (F τ), you can make the cache arbitrarily big.
  -- I think we don't do that unless we are caching a non-terminating
  -- computation to begin with, but I'm not entirely sure.
  --
  -- However, the termination checker can't prove that the function is
  -- terminating because it's not structurally recursive, but one call of the
  -- function will produce another call of the function stuck on a neutral term:
  -- So the computation will have terminated, just in an unusual way!
  --
  -- Anyway, I need not mechanize this part of the proof for my goals.
  --
  -- XXX: This line is the only change, up to now, for the caching semantics,
  -- the rest is copied. Inheritance would handle this precisely; without
  -- inheritance, we might want to use one of the standard encodings of related
  -- features (delegation?).
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCache × ⟦ τ₁ ⟧ValTypeHidCache )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for caching evaluation of MTerm
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Syntax.MType as MType

import Parametric.Denotation.Value as Value
import Parametric.Denotation.MValue as MValue

module Parametric.Denotation.CachingMValue
    (Base : Type.Structure)
    (⟦_⟧Base : Value.Structure Base)
  where

open import Base.Denotation.Notation

open Type.Structure Base
open MType.Structure Base
open Value.Structure Base ⟦_⟧Base
open MValue.Structure Base ⟦_⟧Base

open import Data.Product hiding (map)
open import Data.Sum hiding (map)
open import Data.Unit
open import Level
open import Function hiding (const)

module Structure where
  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCacheWrong × ⟦ τ₁ ⟧ValTypeHidCacheWrong )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  {-# NO_TERMINATION_CHECK #-}
  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  --
  -- XXX The termination checker isn't happy with it, and it may be right ─ if
  -- you keep substituting τ₁ = U (F τ), you can make the cache arbitrarily big.
  -- I think we don't do that unless we are caching a non-terminating
  -- computation to begin with, but I'm not entirely sure.
  --
  -- However, the termination checker can't prove that the function is
  -- terminating because it's not structurally recursive, but one call of the
  -- function will produce another call of the function stuck on a neutral term:
  -- So the computation will have terminated, just in an unusual way!
  --
  -- Anyway, I need not mechanize this part of the proof for my goals.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCache × ⟦ τ₁ ⟧ValTypeHidCache )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}


Embed62.agda:410: main theorem as stated in slides for Hessen Workshop
(fix #68)

Old-commit-hash: 7254a11f4c494091307a31436b4d31d567d52b12

module Embed62 where

open import TaggedDeltaTypes
open import ExplicitNil using (ext³)
open import Relation.Binary.PropositionalEquality
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Unit using (⊤ ; tt)
open import Data.Nat

natPairVisitor : Type
natPairVisitor = nats ⇒ nats ⇒ nats

Δ-Type : Type → Type
Δ-Type nats = natPairVisitor ⇒ nats -- Church pairs
Δ-Type bags = bags
Δ-Type (σ ⇒ τ) = σ ⇒ Δ-Type σ ⇒ Δ-Type τ

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

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • keep τ • Γ≼ΔΓ

weak : ∀ {τ Γ} → Term Γ τ → Term (Δ-Context Γ) τ
weak = weaken Γ≼ΔΓ

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

absurd! : ∀ {A B : Set} → A → A → B → B
absurd! _ _ b = b

fst : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
snd = abs (abs (var this))

oldFrom newFrom : ∀ {Γ} → Term Γ (Δ-Type nats) → Term Γ nats
oldFrom d = app d fst
newFrom d = app d snd

difff : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
apply : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ

apply {nats} dt t = app dt snd
apply {bags} dt t = union t dt
apply {σ ⇒ τ} dt t = abs (apply
  (app (app (weaken (drop _ • Γ≼Γ) dt)
    (var this)) (difff (var this) (var this)))
  (app (weaken (drop _ • Γ≼Γ) t) (var this)))

difff {nats} s t = abs (app (app (var this)
  (weaken (drop _ • Γ≼Γ) t)) (weaken (drop _ • Γ≼Γ) s))
difff {bags} s t = diff s t
difff {σ ⇒ τ} s t = abs (abs (difff
  (app (weaken (drop _ • drop _ • Γ≼Γ) s)
    (apply (var this) (var (that this))))
  (app (weaken (drop _ • drop _ • Γ≼Γ) t) (var (that this)))))

natPair : ∀ {Γ} → (old new : Term (natPairVisitor • Γ) nats) → Term Γ (Δ-Type nats)
natPair old new = abs (app (app (var this) old) new)

embed : ∀ {τ Γ} → ΔTerm Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
embed (Δnat old new) = natPair (nat old) (nat new)
embed (Δbag db) = bag db
embed (Δvar x) = var (deriveVar x)
embed (Δabs dt) = abs (abs (embed dt))
embed (Δapp ds t dt) = app (app (embed ds) (weak t)) (embed dt)
embed (Δadd ds dt) = natPair
  (add (oldFrom (embedWeaken ds))
       (oldFrom (embedWeaken dt)))
  (add (newFrom (embedWeaken ds))
       (newFrom (embedWeaken dt)))
  where
    embedWeaken : ∀ {Γ τ} → (d : ΔTerm Γ nats) →
      Term (τ • Δ-Context Γ) (natPairVisitor ⇒ nats)
    embedWeaken d = (weaken (drop _ • Γ≼Γ) (embed d))
embed (Δmap₀ s ds t dt) = diff
  (map (apply (embed ds) (weak s)) (apply (embed dt) (weak t)))
  (weak (map s t))
embed (Δmap₁ s dt) = map (weak s) (embed dt)
embed (Δunion ds dt) = union (embed ds) (embed dt)
embed (Δdiff ds dt) = diff (embed ds) (embed dt)

⟦fst⟧ : ∀ {A : Set} → A → A → A
⟦fst⟧ a b = a
⟦snd⟧ : ∀ {A : Set} → A → A → A
⟦snd⟧ a b = b

_≈_ : ∀ {τ} → ΔVal τ → ⟦ Δ-Type τ ⟧ → Set
_≈_ {nats} (old , new) v = old ≡ v ⟦fst⟧ × new ≡ v ⟦snd⟧
_≈_ {bags} u v = u ≡ v
_≈_ {σ ⇒ τ} u v =
  (w : ⟦ σ ⟧) (dw : ΔVal σ) (dw′ : ⟦ Δ-Type σ ⟧)
  (R[w,dw] : valid w dw) (eq : dw ≈ dw′) →
  u w dw R[w,dw] ≈ v w dw′

infix 4 _≈_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ Δ-Context Γ ⟧ → Set
compatible {∅} ∅ ∅ = EmptySet
compatible {τ • Γ} (cons v dv _ ρ) (dv′ • v′ • ρ′) =
  triple (v ≡ v′) (dv ≈ dv′) (compatible ρ ρ′)

deriveVar-correct : ∀ {τ Γ} {x : Var Γ τ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ x ⟧ΔVar ρ ≈ ⟦ deriveVar x ⟧ ρ′

deriveVar-correct {x = this} -- pattern-matching on ρ, ρ′ NOT optional
  {cons _ _ _ _} {_ • _ • _} {cons _ dv≈dv′ _ _} = dv≈dv′
deriveVar-correct {x = that y}
  {cons _ _ _ ρ} {_ • _ • ρ′} {cons _ _ C _} =
  deriveVar-correct {x = y} {ρ} {ρ′} {C}

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

weak-eq : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′

weak-eq {∅} {∅} {∅} _ = refl
weak-eq {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′} (cons v≡v′ _ C _) =
  cong₂ _•_ v≡v′ (weak-eq C)

weak-eq-term : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ′

weak-eq-term t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (weak-eq C)) (sym (weaken-sound t ρ′))

weaken-once : ∀ {τ Γ σ} {t : Term Γ τ} {v : ⟦ σ ⟧} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ≡ ⟦ weaken (drop σ • Γ≼Γ) t ⟧ (v • ρ)

weaken-once {t = t} {v} {ρ} = trans
  (cong ⟦ t ⟧ (sym weak-id))
  (sym (weaken-sound t (v • ρ)))

weaken-twice : ∀ {τ Γ σ₀ σ₁} {t : Term Γ τ}
  {u : ⟦ σ₀ ⟧} {v : ⟦ σ₁ ⟧} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ≡ ⟦ weaken (drop σ₀ • drop σ₁ • Γ≼Γ) t ⟧ (u • v • ρ)

weaken-twice {t = t} {u} {v} {ρ} = trans
  (cong ⟦ t ⟧ (sym weak-id))
  (sym (weaken-sound t (u • v • ρ)))

embed-correct : ∀ {τ Γ}
  {dt : ΔTerm Γ τ}
  {ρ : ΔEnv Γ} {V : dt is-valid-for ρ}
  {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ dt ⟧Δ ρ V ≈ ⟦ embed dt ⟧ ρ′

embed-correct {dt = Δnat old new} = refl , refl

embed-correct {dt = Δbag db} = refl

embed-correct {dt = Δvar x} {ρ} {ρ′ = ρ′} {C} =
  deriveVar-correct {x = x} {ρ} {ρ′} {C}

embed-correct {dt = Δadd ds dt} {ρ} {V} {ρ′} {C} =
  let
    s00 , s01 = ⟦ ds ⟧Δ ρ (car V)
    t00 , t01 = ⟦ dt ⟧Δ ρ (cadr V)
    s10 = ⟦ embed ds ⟧ ρ′ ⟦fst⟧
    s11 = ⟦ embed ds ⟧ ρ′ ⟦snd⟧
    t10 = ⟦ embed dt ⟧ ρ′ ⟦fst⟧
    t11 = ⟦ embed dt ⟧ ρ′ ⟦snd⟧
    rec-s = embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
    rec-t = embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C}
  in

    (begin
      s00 + t00
    ≡⟨ cong₂ _+_ (proj₁ rec-s) (proj₁ rec-t) ⟩
      s10 + t10
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦fst⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦fst⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed ds) (⟦fst⟧ • ρ′))))
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed dt) (⟦fst⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧
    ∎)
    ,
    (begin
      s01 + t01
    ≡⟨ cong₂ _+_ (proj₂ rec-s) (proj₂ rec-t) ⟩
      s11 + t11
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦snd⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦snd⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed ds) (⟦snd⟧ • ρ′))))
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed dt) (⟦snd⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧
    ∎)
  where open ≡-Reasoning

embed-correct {dt = Δunion ds dt} {ρ} {V} {ρ′} {C} = cong₂ _++_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δdiff ds dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δmap₁ s dt} {ρ} {V} {ρ′} {C} = cong₂ mapBag
  (weak-eq-term s C)
  (embed-correct {dt = dt} {ρ} {car V} {ρ′} {C})

embed-correct {dt = Δmap₀ s ds t dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (cong₂ mapBag
    (extensionality (λ v →
    begin
      proj₂ (⟦ ds ⟧Δ ρ (car V) v (v , v) refl)
    ≡⟨ proj₂ (embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
        v (v , v) (λ f → f v v) refl (refl , refl)) ⟩
      ⟦ embed ds ⟧ ρ′ v (λ f → f v v) ⟦snd⟧
    ≡⟨ cong (λ hole → hole v (λ f → f v v) ⟦snd⟧)
        (weaken-once {t = embed ds} {v} {ρ′}) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (v • ρ′) v (λ f → f v v) ⟦snd⟧
    ∎))
    (cong₂ _++_
      (weak-eq-term t C)
      (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})))
  (cong₂ mapBag (weak-eq-term s C) (weak-eq-term t C))
  where open ≡-Reasoning

embed-correct {dt = Δapp ds t dt} {ρ} {cons vds vdt R[t,dt] _} {ρ′} {C}
  rewrite sym (weak-eq-term t C) =
  embed-correct {dt = ds} {ρ} {vds} {ρ′} {C}
    (⟦ t ⟧Term (ignore ρ)) (⟦ dt ⟧Δ ρ vdt) (⟦ embed dt ⟧Term ρ′)
    R[t,dt] (embed-correct {dt = dt} {ρ} {vdt} {ρ′} {C})

embed-correct {dt = Δabs dt} {ρ} {V} {ρ′} {C} = λ w dw dw′ R[w,dw] dw≈dw′ →
  embed-correct {dt = dt}
    {cons w dw R[w,dw] ρ} {V w dw R[w,dw]}
    {dw′ • w • ρ′} {cons refl dw≈dw′ C tt}

_⊞_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧
_⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

_⊞_ {nats}  n dn = dn ⟦snd⟧
_⊞_ {bags}  b db = b ++ db
_⊞_ {σ ⇒ τ} f df = λ v → f v ⊞ df v (v ⊟ v)

_⊟_ {nats} m n = λ f → f n m
_⊟_ {bags} d b = d \\ b
_⊟_ {σ ⇒ τ} g f = λ v dv → g (v ⊞ dv) ⊟ f v

u⊝v≈u⊟v : ∀ {τ : Type} {u v : ⟦ τ ⟧} → u ⊝ v ≈ u ⊟ v

carry-over : ∀ {τ}
  {dv : ΔVal τ} {dv′ : ⟦ Δ-Type τ ⟧} (dv≈dv′ : dv ≈ dv′)
  {v : ⟦ τ ⟧} (R[v,dv] : valid v dv) →
  v ⊕ dv ≡ v ⊞ dv′

u⊝v≈u⊟v {nats} = refl , refl
u⊝v≈u⊟v {bags} = refl
u⊝v≈u⊟v {σ ⇒ τ} {g} {f} = result
  where
  result : ∀ (w : ⟦ σ ⟧) (dw : ΔVal σ) (dw′ : ⟦ Δ-Type σ ⟧)
    (R[w,dw] : valid w dw) (dw≈dw′ : dw ≈ dw′) →
    g (w ⊕ dw) ⊝ f w ≈ g (w ⊞ dw′) ⊟ f w
  result w dw dw′ R[w,dw] dw≈dw′
    rewrite carry-over dw≈dw′ R[w,dw] = u⊝v≈u⊟v
  -- Question: is there anyway not to write the signature
  -- of u⊝v≈u⊟v twice just so as to carry out the rewrite?

carry-over {nats} dv≈dv′ R[v,dv] = proj₂ dv≈dv′
carry-over {bags} dv≈dv′ {v} R[v,dv] = cong (_++_ v) dv≈dv′
carry-over {σ ⇒ τ} {df} {df′} df≈df′ {f} R[f,df] =
  extensionality (λ v → carry-over {τ}
    {df v (v ⊝ v) R[v,u⊝v]} {df′ v (v ⊟ v)}
    (df≈df′ v (v ⊝ v) (v ⊟ v) R[v,u⊝v] u⊝v≈u⊟v)
    {f v}
    (proj₁ (R[f,df] v (v ⊝ v) R[v,u⊝v])))

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

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

ignorance : ∀ {Γ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  (ignore ρ) ≡ (ignore′ ρ′)

ignorance {∅} {∅} {∅} _ = refl
ignorance {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′}
  (cons v≡v′ _ C _) = cong₂ _•_ v≡v′ (ignorance C)

-- ... because "updatedness" sounds horrible
actualité : ∀ {Γ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  (update ρ) ≡ (update′ ρ′)

actualité {∅} {∅} {∅} _ = refl
actualité {τ • Γ} {cons v dv R[v,dv] ρ} {dv′ • v′ • ρ′}
  (cons v≡v′ dv≈dv′ C _) rewrite v≡v′ =
  cong₂ _•_ (carry-over dv≈dv′ R[v,dv]) (actualité C)

ignore-both : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ t ⟧ (ignore′ ρ′)

ignore-both t C rewrite ignorance C = refl

update-both : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (update ρ) ≡ ⟦ t ⟧ (update′ ρ′)

update-both t C rewrite actualité C = refl

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  {v : ⟦ σ ⟧} {dv : ΔVal σ} {R[v,dv] : valid v dv}
  → ⟦ t ⟧ ∅ (v ⊕ dv)
  ≡ ⟦ t ⟧ ∅ v ⊕ ⟦ derive t ⟧Δ ∅ (unrestricted t) v dv R[v,dv]

corollary-closed {t = t} {v} {dv} {R[v,dv]} =
  let
    f  = ⟦ t ⟧ ∅
    df = ⟦ derive t ⟧Δ ∅ (unrestricted t)
  in
    begin
      f (v ⊕ dv)
    ≡⟨ cong (λ hole → hole (v ⊕ dv)) (sym (correctness {t = t})) ⟩
      (f ⊕ df) (v ⊕ dv)
    ≡⟨ proj₂ (validity {t = t} v dv R[v,dv]) ⟩
      f v ⊕ df v dv R[v,dv]
    ∎ where open ≡-Reasoning

⟦apply⟧ : ∀ {τ Γ}
  {t : Term Γ τ} {dt : Term Γ (Δ-Type τ)} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ⊞ ⟦ dt ⟧ ρ ≡ ⟦ apply dt t ⟧ ρ

⟦difff⟧ : ∀ {τ Γ}
  {s : Term Γ τ} {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
  ⟦ s ⟧ ρ ⊟ ⟦ t ⟧ ρ ≡ ⟦ difff s t ⟧ ρ

⟦apply⟧ {nats} {Γ} {t} {dt} {ρ} = refl
⟦apply⟧ {bags} {Γ} {t} {dt} {ρ} = refl
⟦apply⟧ {σ ⇒ τ} {Γ} {t} {dt} {ρ} = extensionality (λ v →
  let
    ρ′ : ⟦ σ • Γ ⟧Context
    ρ′ = v • ρ
    dv = ⟦ difff (var this) (var this) ⟧ ρ′
    t-v = app (weaken (drop σ • Γ≼Γ) t) (var this)
    dt-v-dv = app (app
      (weaken (drop σ • Γ≼Γ) dt) (var this)) (difff (var this) (var this))
  in
    begin
      ⟦ t ⟧ ρ v ⊞ ⟦ dt ⟧ ρ v (v ⊟ v)
    ≡⟨ cong (λ hole → ⟦ t ⟧ ρ v ⊞ ⟦ dt ⟧ ρ v hole)
        (⟦difff⟧ {s = var this} {var this} {ρ′}) ⟩
      ⟦ t ⟧ ρ v ⊞ ⟦ dt ⟧ ρ v dv
    ≡⟨ cong₂ _⊞_
        (cong (λ hole → hole v   ) (weaken-once {t = t}))
        (cong (λ hole → hole v dv) (weaken-once {t = dt})) ⟩
      ⟦ t-v ⟧ ρ′ ⊞ ⟦ dt-v-dv ⟧ ρ′
    ≡⟨ ⟦apply⟧ ⟩
      ⟦ apply dt-v-dv t-v ⟧ ρ′
    ∎) where
    open ≡-Reasoning

⟦difff⟧ {nats} {Γ} {s} {t} {ρ} = extensionality result
  where
  result : (f : ⟦ nats ⇒ nats ⇒ nats ⟧)
    → f (⟦ t ⟧ ρ) (⟦ s ⟧ ρ)
    ≡ f (⟦ weaken (drop _ • Γ≼Γ) t ⟧ (f • ρ))
        (⟦ weaken (drop _ • Γ≼Γ) s ⟧ (f • ρ))
  result f rewrite weaken-once {t = s} {f} {ρ}
                 | weaken-once {t = t} {f} {ρ} = refl
⟦difff⟧ {bags} {Γ} {s} {t} {ρ} = refl
⟦difff⟧ {σ ⇒ τ} {Γ} {s} {t} {ρ} =
  extensionality (λ v → extensionality (λ dv →
  let
    ρ′ : ⟦ (Δ-Type σ) • σ • Γ ⟧Context
    ρ′ = dv • v • ρ
    f = weaken (drop Δ-Type σ • (drop σ • Γ≼Γ)) s
    t-x = app (weaken (drop Δ-Type σ • (drop σ • Γ≼Γ)) t)
              (var (that this))
    x⊞dx = apply (var this) (var (that this))
  in
    begin
      ⟦ s ⟧ ρ (v ⊞ dv) ⊟ ⟦ t ⟧ ρ v
    ≡⟨ cong₂ _⊟_
        (cong₂ (λ f x → f x)
          (weaken-twice {t = s} {dv} {v} {ρ}) ⟦apply⟧)
        (cong (λ hole → hole v)
          (weaken-twice {t = t} {dv} {v} {ρ})) ⟩
      ⟦ f ⟧ ρ′ (⟦ x⊞dx ⟧ ρ′) ⊟ ⟦ t-x ⟧ ρ′
    ≡⟨ ⟦difff⟧ {s = app f x⊞dx} {t-x} ⟩
      ⟦ difff (app f x⊞dx) t-x ⟧ ρ′
    ∎)) where open ≡-Reasoning

main-theorem : ∀ {σ τ}
  {s : Term ∅ (σ ⇒ τ)} {t₀ : Term ∅ σ} {t₁ : Term ∅ σ}
  → ⟦ app s t₁ ⟧ ∅
  ≡ ⟦ apply (app (app (embed (derive s)) t₀) (difff t₁ t₀)) (app s t₀) ⟧ ∅

main-theorem {s = s} {t₀} {t₁} =
  let
    f  = ⟦ s ⟧ ∅
    df = ⟦ derive s ⟧Δ ∅ (unrestricted s)
    df′ = ⟦ embed (derive s) ⟧ ∅
    v  = ⟦ t₀ ⟧ ∅
    u  = ⟦ t₁ ⟧ ∅
  in
    begin
      f u
    ≡⟨ cong (λ hole → f hole) (sym v⊕[u⊝v]=u) ⟩
      f (v ⊕ (u ⊝ v))
    ≡⟨ corollary-closed {t = s} {v} {u ⊝ v} {R[v,u⊝v]} ⟩
      f v ⊕ df v (u ⊝ v) R[v,u⊝v]
    ≡⟨ carry-over
        (embed-correct {Γ = ∅} {dt = derive s}
          {∅} {unrestricted s} {∅} {∅}
          v (u ⊝ v) (u ⊟ v) R[v,u⊝v] u⊝v≈u⊟v)
        (proj₁ (validity {Γ = ∅} {s} v (u ⊝ v) R[v,u⊝v])) ⟩
      f v ⊞ df′ v (u ⊟ v)
    ≡⟨ trans (cong (λ hole → f v ⊞ df′ v hole)
        (⟦difff⟧ {s = t₁} {t₀})) ⟦apply⟧ ⟩
      ⟦ apply (app (app (embed (derive s)) t₀) (difff t₁ t₀))
              (app s t₀) ⟧ ∅
    ∎ where open ≡-Reasoning

module Embed62 where

open import TaggedDeltaTypes
open import ExplicitNil using (ext³)
open import Relation.Binary.PropositionalEquality
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Unit using (⊤ ; tt)
open import Data.Nat

natPairVisitor : Type
natPairVisitor = nats ⇒ nats ⇒ nats

Δ-Type : Type → Type
Δ-Type nats = natPairVisitor ⇒ nats -- Church pairs
Δ-Type bags = bags
Δ-Type (σ ⇒ τ) = σ ⇒ Δ-Type σ ⇒ Δ-Type τ

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

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • keep τ • Γ≼ΔΓ

weak : ∀ {τ Γ} → Term Γ τ → Term (Δ-Context Γ) τ
weak = weaken Γ≼ΔΓ

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

absurd! : ∀ {A B : Set} → A → A → B → B
absurd! _ _ b = b

fst : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
snd = abs (abs (var this))

oldFrom newFrom : ∀ {Γ} → Term Γ (Δ-Type nats) → Term Γ nats
oldFrom d = app d fst
newFrom d = app d snd

difff : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
apply : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ

apply {nats} dt t = app dt snd
apply {bags} dt t = union t dt
apply {σ ⇒ τ} dt t = abs (apply
  (app (app (weaken (drop _ • Γ≼Γ) dt)
    (var this)) (difff (var this) (var this)))
  (app (weaken (drop _ • Γ≼Γ) t) (var this)))

difff {nats} s t = abs (app (app (var this)
  (weaken (drop _ • Γ≼Γ) s)) (weaken (drop _ • Γ≼Γ) t))
difff {bags} s t = diff s t
difff {σ ⇒ τ} s t = abs (abs (difff
  (app (weaken (drop _ • drop _ • Γ≼Γ) s)
    (apply (var this) (var (that this))))
  (app (weaken (drop _ • drop _ • Γ≼Γ) t) (var (that this)))))

natPair : ∀ {Γ} → (old new : Term (natPairVisitor • Γ) nats) → Term Γ (Δ-Type nats)
natPair old new = abs (app (app (var this) old) new)

embed : ∀ {τ Γ} → ΔTerm Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
embed (Δnat old new) = natPair (nat old) (nat new)
embed (Δbag db) = bag db
embed (Δvar x) = var (deriveVar x)
embed (Δabs dt) = abs (abs (embed dt))
embed (Δapp ds t dt) = app (app (embed ds) (weak t)) (embed dt)
embed (Δadd ds dt) = natPair
  (add (oldFrom (embedWeaken ds))
       (oldFrom (embedWeaken dt)))
  (add (newFrom (embedWeaken ds))
       (newFrom (embedWeaken dt)))
  where
    embedWeaken : ∀ {Γ τ} → (d : ΔTerm Γ nats) →
      Term (τ • Δ-Context Γ) (natPairVisitor ⇒ nats)
    embedWeaken d = (weaken (drop _ • Γ≼Γ) (embed d))
embed (Δmap₀ s ds t dt) = diff
  (map (apply (embed ds) (weak s)) (apply (embed dt) (weak t)))
  (weak (map s t))
embed (Δmap₁ s dt) = map (weak s) (embed dt)
embed (Δunion ds dt) = union (embed ds) (embed dt)
embed (Δdiff ds dt) = diff (embed ds) (embed dt)

⟦fst⟧ : ∀ {A : Set} → A → A → A
⟦fst⟧ a b = a
⟦snd⟧ : ∀ {A : Set} → A → A → A
⟦snd⟧ a b = b

_≈_ : ∀ {τ} → ΔVal τ → ⟦ Δ-Type τ ⟧ → Set
_≈_ {nats} (old , new) v = old ≡ v ⟦fst⟧ × new ≡ v ⟦snd⟧
_≈_ {bags} u v = u ≡ v
_≈_ {σ ⇒ τ} u v =
  (w : ⟦ σ ⟧) (dw : ΔVal σ) (dw′ : ⟦ Δ-Type σ ⟧)
  (R[w,dw] : valid w dw) (eq : dw ≈ dw′) →
  u w dw R[w,dw] ≈ v w dw′

infix 4 _≈_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ Δ-Context Γ ⟧ → Set
compatible {∅} ∅ ∅ = EmptySet
compatible {τ • Γ} (cons v dv _ ρ) (dv′ • v′ • ρ′) =
  triple (v ≡ v′) (dv ≈ dv′) (compatible ρ ρ′)

deriveVar-correct : ∀ {τ Γ} {x : Var Γ τ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ x ⟧ΔVar ρ ≈ ⟦ deriveVar x ⟧ ρ′

deriveVar-correct {x = this} -- pattern-matching on ρ, ρ′ NOT optional
  {cons _ _ _ _} {_ • _ • _} {cons _ dv≈dv′ _ _} = dv≈dv′
deriveVar-correct {x = that y}
  {cons _ _ _ ρ} {_ • _ • ρ′} {cons _ _ C _} =
  deriveVar-correct {x = y} {ρ} {ρ′} {C}

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

weak-eq : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′

weak-eq {∅} {∅} {∅} _ = refl
weak-eq {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′} (cons v≡v′ _ C _) =
  cong₂ _•_ v≡v′ (weak-eq C)

weak-eq-term : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ′

weak-eq-term t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (weak-eq C)) (sym (weaken-sound t ρ′))

weaken-once : ∀ {τ Γ σ} {t : Term Γ τ} {v : ⟦ σ ⟧} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ≡ ⟦ weaken (drop σ • Γ≼Γ) t ⟧ (v • ρ)

weaken-once {t = t} {v} {ρ} = trans
  (cong ⟦ t ⟧ (sym weak-id))
  (sym (weaken-sound t (v • ρ)))

embed-correct : ∀ {τ Γ}
  {dt : ΔTerm Γ τ}
  {ρ : ΔEnv Γ} {V : dt is-valid-for ρ}
  {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ dt ⟧Δ ρ V ≈ ⟦ embed dt ⟧ ρ′

embed-correct {dt = Δnat old new} = refl , refl

embed-correct {dt = Δbag db} = refl

embed-correct {dt = Δvar x} {ρ} {ρ′ = ρ′} {C} =
  deriveVar-correct {x = x} {ρ} {ρ′} {C}

embed-correct {dt = Δadd ds dt} {ρ} {V} {ρ′} {C} =
  let
    s00 , s01 = ⟦ ds ⟧Δ ρ (car V)
    t00 , t01 = ⟦ dt ⟧Δ ρ (cadr V)
    s10 = ⟦ embed ds ⟧ ρ′ ⟦fst⟧
    s11 = ⟦ embed ds ⟧ ρ′ ⟦snd⟧
    t10 = ⟦ embed dt ⟧ ρ′ ⟦fst⟧
    t11 = ⟦ embed dt ⟧ ρ′ ⟦snd⟧
    rec-s = embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
    rec-t = embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C}
  in

    (begin
      s00 + t00
    ≡⟨ cong₂ _+_ (proj₁ rec-s) (proj₁ rec-t) ⟩
      s10 + t10
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦fst⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦fst⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed ds) (⟦fst⟧ • ρ′))))
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed dt) (⟦fst⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧
    ∎)
    ,
    (begin
      s01 + t01
    ≡⟨ cong₂ _+_ (proj₂ rec-s) (proj₂ rec-t) ⟩
      s11 + t11
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦snd⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦snd⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed ds) (⟦snd⟧ • ρ′))))
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed dt) (⟦snd⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧
    ∎)
  where open ≡-Reasoning

embed-correct {dt = Δunion ds dt} {ρ} {V} {ρ′} {C} = cong₂ _++_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δdiff ds dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δmap₁ s dt} {ρ} {V} {ρ′} {C} = cong₂ mapBag
  (weak-eq-term s C)
  (embed-correct {dt = dt} {ρ} {car V} {ρ′} {C})

embed-correct {dt = Δmap₀ s ds t dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (cong₂ mapBag
    (extensionality (λ v →
    begin
      proj₂ (⟦ ds ⟧Δ ρ (car V) v (v , v) refl)
    ≡⟨ proj₂ (embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
        v (v , v) (λ f → f v v) refl (refl , refl)) ⟩
      ⟦ embed ds ⟧ ρ′ v (λ f → f v v) ⟦snd⟧
    ≡⟨ cong (λ hole → hole v (λ f → f v v) ⟦snd⟧)
        (weaken-once {t = embed ds} {v} {ρ′}) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (v • ρ′) v (λ f → f v v) ⟦snd⟧
    ∎))
    (cong₂ _++_
      (weak-eq-term t C)
      (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})))
  (cong₂ mapBag (weak-eq-term s C) (weak-eq-term t C))
  where open ≡-Reasoning

embed-correct {dt = Δapp ds t dt} {ρ} {cons vds vdt R[t,dt] _} {ρ′} {C}
  rewrite sym (weak-eq-term t C) =
  embed-correct {dt = ds} {ρ} {vds} {ρ′} {C}
    (⟦ t ⟧Term (ignore ρ)) (⟦ dt ⟧Δ ρ vdt) (⟦ embed dt ⟧Term ρ′)
    R[t,dt] (embed-correct {dt = dt} {ρ} {vdt} {ρ′} {C})

embed-correct {dt = Δabs dt} {ρ} {V} {ρ′} {C} = λ w dw dw′ R[w,dw] dw≈dw′ →
  embed-correct {dt = dt}
    {cons w dw R[w,dw] ρ} {V w dw R[w,dw]}
    {dw′ • w • ρ′} {cons refl dw≈dw′ C tt}


allow the use of more natural notation in Nat

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC  succ #-}

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎


FLABloM: more lifting of seminearring

FLABloM: more lifting of seminearring

-- Matrices indexed by shape
module SquareMatrix where

open import Shape
open import Matrix

-- Square matrices have the same shape in both dimensions
Sq : Set → Shape → Set
Sq a shape = M a shape shape

open import SemiNearRingRecord
open import Algebra.Structures
open import Relation.Binary
open import Data.Product

-- Lifting a SNR to a to a Square matrix of some shape
Square : SemiNearRing → Shape → SemiNearRing
Square snr shape = SNR
  where
  open SemiNearRing snr

  S = Sq s shape

  open Operations s _∙ₛ_ _+ₛ_
    renaming (_+_ to _+S_; _*_ to _∙S_)

  0S : (r c : Shape) → M s r c
  0S L L = One 0ₛ
  0S L (B s s₁) = Row (0S L s) (0S L s₁)
  0S (B r r₁) L = Col (0S r L) (0S r₁ L)
  0S (B r r₁) (B s s₁) =
      Q (0S r s) (0S r s₁)
        (0S r₁ s) (0S r₁ s₁)

  ≃S : (r c : Shape) →
        M s r c → M s r c → Set
  ≃S L L (One x) (One x₁) = x ≃ₛ x₁
  ≃S L (B c₁ c₂) (Row m m₁) (Row n n₁) = ≃S L c₁ m n × ≃S L c₂ m₁ n₁
  ≃S (B r₁ r₂) L (Col m m₁) (Col n n₁) = ≃S r₁ L m n × ≃S r₂ L m₁ n₁
  ≃S (B r₁ r₂) (B c₁ c₂) (Q m00 m01 m10 m11) (Q n00 n01 n10 n11) =
    ≃S r₁ c₁ m00 n00 × ≃S r₁ c₂ m01 n01 ×
    ≃S r₂ c₁ m10 n10 × ≃S r₂ c₂ m11 n11

  _≃S'_ : {r c : Shape} → M s r c → M s r c → Set
  _≃S'_ {r} {c} m n = ≃S r c m n

  reflS : (r c : Shape) →
    {X : M s r c} → X ≃S' X
  reflS L L {X = One x} = reflₛ {x}
  reflS L (B c₁ c₂) {X = Row X Y} = reflS L c₁ , reflS L c₂
  reflS (B r₁ r₂) L {X = Col X Y} = reflS r₁ L , reflS r₂ L
  reflS (B r₁ r₂) (B c₁ c₂) {X = Q X Y Z W} =
    reflS r₁ c₁ , reflS r₁ c₂ ,
    reflS r₂ c₁ , reflS r₂ c₂

  symS : (r c : Shape) →
    {i j : M s r c} → i ≃S' j → j ≃S' i
  symS L L {One x} {One x₁} p = symₛ p
  symS L (B c₁ c₂) {Row i₁ i₂} {Row j₁ j₂} (p , q) = symS L c₁ p , symS L c₂ q
  symS (B r₁ r₂) L {Col i₁ i} {Col j j₁} (p , q) = symS r₁ L p , symS r₂ L q
  symS (B r r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j j₁ j₂ j₃} (p , q , x , y) =
    symS r c₁ p , symS r c₂ q ,
    symS r₂ c₁ x , symS r₂ c₂ y

  transS : (r c : Shape) →
    {i j k : M s r c} → i ≃S' j → j ≃S' k → i ≃S' k
  transS L L {One x} {One x₁} {One x₂} p q = trans p q
  transS L (B c₁ c₂) {Row i i₁} {Row j j₁} {Row k k₁} (p , q) (p' , q') =
    transS L c₁ p p' , transS L c₂ q q'
  transS (B r₁ r₂) L {Col i i₁} {Col j j₁} {Col k k₁} (p , q) (p' , q') =
    transS r₁ L p p' , transS r₂ L q q'
  transS (B r₁ r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j₂ j j₃ j₁} {Q k k₁ k₂ k₃}
    (p , q , x , y) (p' , q' , x' , y') =
    transS r₁ c₁ p p' , transS r₁ c₂ q q' ,
    transS r₂ c₁ x x' , transS r₂ c₂ y y'

  isEquivS =
    record
      { refl = reflS shape shape
      ; sym = symS shape shape
      ; trans = transS shape shape }

  liftAssoc : (r c : Shape) (x y z : M s r c) → ((x +S y) +S z) ≃S' (x +S (y +S z))
  liftAssoc L L (One x) (One y) (One z) = assocₛ x y z
  liftAssoc L (B c c₁) (Row x x₁) (Row y y₁) (Row z z₁) =
    liftAssoc L c x y z  , liftAssoc L c₁ x₁ y₁ z₁
  liftAssoc (B r r₁) L (Col x x₁) (Col y y₁) (Col z z₁) =
    liftAssoc r L x y z , liftAssoc r₁ L x₁ y₁ z₁
  liftAssoc (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (liftAssoc r c x y z) , (liftAssoc r c₁ x₁ y₁ z₁) ,
    (liftAssoc r₁ c x₂ y₂ z₂) , (liftAssoc r₁ c₁ x₃ y₃ z₃)

  lift<+> : (r c : Shape) {x y u v : M s r c} →
    x ≃S' y → u ≃S' v → (x +S u) ≃S' (y +S v)
  lift<+> L L {One x} {One x₁} {One x₂} {One x₃} p q = p <+> q
  lift<+> L (B c c₁) {Row x x₁} {Row y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    lift<+> L c p q , lift<+> L c₁ p₁ q₁
  lift<+> (B r r₁) L {Col x x₁} {Col y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    lift<+> r L p q , lift<+> r₁ L p₁ q₁
  lift<+> (B r r₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃}
    (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    lift<+> r c p q , lift<+> r c₁ p₁ q₁ ,
    lift<+> r₁ c p₂ q₂ , lift<+> r₁ c₁ p₃ q₃

  isSemgroupS =
    record
      { isEquivalence = isEquivS
      ; assoc = liftAssoc shape shape
      ; ∙-cong = lift<+> shape shape }

  liftIdentˡ : (r c : Shape) (x : M s r c) →
     0S r c +S x ≃S' x
  liftIdentˡ L L (One x) = identityˡₛ x
  liftIdentˡ L (B c c₁) (Row x x₁) = liftIdentˡ L c x , liftIdentˡ L c₁ x₁
  liftIdentˡ (B r r₁) L (Col x x₁) = liftIdentˡ r L x , liftIdentˡ r₁ L x₁
  liftIdentˡ (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    liftIdentˡ r c x , liftIdentˡ r c₁ x₁ ,
    liftIdentˡ r₁ c x₂ , liftIdentˡ r₁ c₁ x₃

  liftComm : (r c : Shape) → (x y : M s r c) →
    (x +S y) ≃S' (y +S x)
  liftComm L L (One x) (One x₁) = commₛ x x₁
  liftComm L (B c c₁) (Row x x₁) (Row y y₁) = (liftComm L c x y) , (liftComm L c₁ x₁ y₁)
  liftComm (B r r₁) L (Col x x₁) (Col y y₁) = (liftComm r L x y) , (liftComm r₁ L x₁ y₁)
  liftComm (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) =
    liftComm r c x y , liftComm r c₁ x₁ y₁ ,
    liftComm r₁ c x₂ y₂ , liftComm r₁ c₁ x₃ y₃

  isCommMonS =
    record
      { isSemigroup = isSemgroupS
      ; identityˡ = liftIdentˡ shape shape
      ; comm = liftComm shape shape }

  -- TODO: can I use ≃S to 'rewrite' types?
  liftZeroˡ : (a b c : Shape) (x : M s b c) →
    let 0ˡ = 0S a b
        0ʳ = 0S a c
    in (0ˡ ∙S x) ≃S' 0ʳ
  liftZeroˡ L L L (One x) = zeroˡ x
  liftZeroˡ L L (B c c₁) (Row x x₁) = (liftZeroˡ L L c x) , (liftZeroˡ L L c₁ x₁)
  liftZeroˡ L (B b b₁) L (Col x x₁) = {!!}
  liftZeroˡ L (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) = {!!} , {!!}
  liftZeroˡ (B a a₁) L L (One x) = liftZeroˡ a L L (One x) , liftZeroˡ a₁ L L (One x)
  liftZeroˡ (B a a₁) L (B c c₁) (Row x x₁) =
    liftZeroˡ a L c x , liftZeroˡ a L c₁ x₁ ,
    liftZeroˡ a₁ L c x , liftZeroˡ a₁ L c₁ x₁
  liftZeroˡ (B a a₁) (B b b₁) L (Col x x₁) = {!!} , {!!}
  liftZeroˡ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    {!liftZeroˡ a b c x!} , ({!!} , ({!!} , {!!}))

  SNR : SemiNearRing
  SNR =
    record
      { s = S
      ; _≃ₛ_ = ≃S shape shape
      ; 0ₛ = 0S shape shape
      ; _+ₛ_ = _+S_
      ; _∙ₛ_ = _∙S_
      ; isCommMon = isCommMonS
      ; zeroˡ = liftZeroˡ shape shape shape
      ; zeroʳ = {!!}
      ; _<∙>_ = {!!}
      }

-- Matrices indexed by shape
module SquareMatrix where

open import Shape
open import Matrix

-- Square matrices have the same shape in both dimensions
Sq : Set → Shape → Set
Sq a shape = M a shape shape

open import SemiNearRingRecord
open import Algebra.Structures
open import Relation.Binary
open import Data.Product

-- Lifting a SNR to a to a Square matrix of some shape
Square : SemiNearRing → Shape → SemiNearRing
Square snr shape = SNR
  where
  open SemiNearRing snr

  S = Sq s shape

  open Operations s _∙ₛ_ _+ₛ_
    renaming (_+_ to _+S_; _*_ to _∙S_)

  lift0 : (r c : Shape) → M s r c
  lift0 L L = One 0ₛ
  lift0 L (B s s₁) = Row (lift0 L s) (lift0 L s₁)
  lift0 (B r r₁) L = Col (lift0 r L) (lift0 r₁ L)
  lift0 (B r r₁) (B s s₁) =
      Q (lift0 r s) (lift0 r s₁)
        (lift0 r₁ s) (lift0 r₁ s₁)

  0S = lift0 shape shape

  lift≃ : (r c : Shape) →
        M s r c → M s r c → Set
  lift≃ L L (One x) (One x₁) = x ≃ₛ x₁
  lift≃ L (B c₁ c₂) (Row m m₁) (Row n n₁) = lift≃ L c₁ m n × lift≃ L c₂ m₁ n₁
  lift≃ (B r₁ r₂) L (Col m m₁) (Col n n₁) = lift≃ r₁ L m n × lift≃ r₂ L m₁ n₁
  lift≃ (B r₁ r₂) (B c₁ c₂) (Q m00 m01 m10 m11) (Q n00 n01 n10 n11) =
    lift≃ r₁ c₁ m00 n00 × lift≃ r₁ c₂ m01 n01 ×
    lift≃ r₂ c₁ m10 n10 × lift≃ r₂ c₂ m11 n11

  _≃S_ = lift≃ shape shape

  liftRefl : (r c : Shape) →
    {X : M s r c} → lift≃ r c X X
  liftRefl L L {X = One x} = reflₛ {x}
  liftRefl L (B c₁ c₂) {X = Row X Y} = liftRefl L c₁ , liftRefl L c₂
  liftRefl (B r₁ r₂) L {X = Col X Y} = liftRefl r₁ L , liftRefl r₂ L
  liftRefl (B r₁ r₂) (B c₁ c₂) {X = Q X Y Z W} =
    liftRefl r₁ c₁ , liftRefl r₁ c₂ ,
    liftRefl r₂ c₁ , liftRefl r₂ c₂

  reflS = liftRefl shape shape

  liftSym : (r c : Shape) →
    let R' = lift≃ r c
    in {i j : M s r c} → R' i j → R' j i
  liftSym L L {One x} {One x₁} p = symₛ p
  liftSym L (B c₁ c₂) {Row i₁ i₂} {Row j₁ j₂} (p , q) = liftSym L c₁ p , liftSym L c₂ q
  liftSym (B r₁ r₂) L {Col i₁ i} {Col j j₁} (p , q) = liftSym r₁ L p , liftSym r₂ L q
  liftSym (B r r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j j₁ j₂ j₃} (p , q , x , y) =
    liftSym r c₁ p , liftSym r c₂ q ,
    liftSym r₂ c₁ x , liftSym r₂ c₂ y

  symS : {i j : M s shape shape} → i ≃S j → j ≃S i
  symS p = liftSym shape shape p

  liftTrans : (r c : Shape) →
    let R' = lift≃ r c
    in {i j k : M s r c} → R' i j → R' j k → R' i k
  liftTrans L L {One x} {One x₁} {One x₂} p q = trans p q
  liftTrans L (B c₁ c₂) {Row i i₁} {Row j j₁} {Row k k₁} (p , q) (p' , q') =
    liftTrans L c₁ p p' , liftTrans L c₂ q q'
  liftTrans (B r₁ r₂) L {Col i i₁} {Col j j₁} {Col k k₁} (p , q) (p' , q') =
    liftTrans r₁ L p p' , liftTrans r₂ L q q'
  liftTrans (B r₁ r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j₂ j j₃ j₁} {Q k k₁ k₂ k₃}
    (p , q , x , y) (p' , q' , x' , y') =
    liftTrans r₁ c₁ p p' , liftTrans r₁ c₂ q q' ,
    liftTrans r₂ c₁ x x' , liftTrans r₂ c₂ y y'

  transS : {i j k : M s shape shape} → i ≃S j → j ≃S k → i ≃S k
  transS p q = liftTrans shape shape p q

  liftAssoc : (r c : Shape) (x y z : M s r c) → lift≃ r c ((x +S y) +S z) (x +S (y +S z))
  liftAssoc L L (One x) (One y) (One z) = assocₛ x y z
  liftAssoc L (B c c₁) (Row x x₁) (Row y y₁) (Row z z₁) =
    liftAssoc L c x y z  , liftAssoc L c₁ x₁ y₁ z₁
  liftAssoc (B r r₁) L (Col x x₁) (Col y y₁) (Col z z₁) =
    liftAssoc r L x y z , liftAssoc r₁ L x₁ y₁ z₁
  liftAssoc (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (liftAssoc r c x y z) , (liftAssoc r c₁ x₁ y₁ z₁) ,
    (liftAssoc r₁ c x₂ y₂ z₂) , (liftAssoc r₁ c₁ x₃ y₃ z₃)

  assocS : (x y z : M s shape shape) → ((x +S y) +S z) ≃S (x +S (y +S z))
  assocS x y z = liftAssoc shape shape x y z

  isEquivS =
    record
      { refl = reflS
      ; sym = symS
      ; trans = transS }
  isSemgroupS =
    record
      { isEquivalence = isEquivS
      ; assoc = assocS
      ; ∙-cong = {!!} }
  isCommMonS =
    record
      { isSemigroup = isSemgroupS
      ; identityˡ = {!!}
      ; comm = {!!} }

  SNR : SemiNearRing
  SNR =
    record
      { s = S
      ; _≃ₛ_ = _≃S_
      ; 0ₛ = 0S
      ; _+ₛ_ = _+S_
      ; _∙ₛ_ = _∙S_
      ; isCommMon = isCommMonS
      ; zeroˡ = {!!}
      ; zeroʳ = {!!}
      ; _<∙>_ = {!!}
      }


README

README

module README where

-- A module for bit-vectors which is used almost
-- everywhere in this development.
open import Data.Bits

open import elgamal
open import schnorr
open import generic-zero-knowledge-interactive
open import sum-properties

-- Randomized programs
open import flipbased
open import flipbased-counting
open import flipbased-running
open import flipbased-implem
open import flipbased-tree

-- A distance between randomized programs
open import program-distance

-- Pure guessing game, a game in which no strategy can
-- consistently win or consistently lose.
open import bit-guessing-game

-- Cryptographic pseudo-random generator game.
open import prg

-- “One time Semantic Security” of the “One time pad” cipher
-- on one bit messages. In other words, “xor”ing any bit with
-- a random bit will look random as well.
open import single-bit-one-time-pad

-- Ciphers, the “one time Semantic Security” game.
open import one-time-semantic-security

-- A simple reduction on ciphers.
open import composition-sem-sec-reduction

-- Tracking space and time through a restricted universe
-- of functions.
open import data-universe
open import fun-universe
open import agda-fun-universe
open import bits-fun-universe
open import fin-fun-universe
open import const-fun-universe
open import cost-fun-universe
open import inverse-fun-universe
open import circuit-fun-universe
open import syntax-fun-universe

-- TODO: Fix & restore the product of universes and ops

-- Draft modules of previous attempts.
-- There is still some code to rescue.
open import circuit
open import flipbased-tree-probas
open import flipbased-no-split
open import flipbased-product-implem

module README where

-- A module for bit-vectors which is used almost
-- everywhere in this development.
open import Data.Bits

-- Randomized programs
open import flipbased
open import flipbased-counting
open import flipbased-running
open import flipbased-implem
open import flipbased-tree

-- A distance between randomized programs
open import program-distance

-- Pure guessing game, a game in which no strategy can
-- consistently win or consistently lose.
open import bit-guessing-game

-- Cryptographic pseudo-random generator game.
open import prg

-- “One time Semantic Security” of the “One time pad” cipher
-- on one bit messages. In other words, “xor”ing any bit with
-- a random bit will look random as well.
open import single-bit-one-time-pad

-- Ciphers, the “one time Semantic Security” game.
open import one-time-semantic-security

-- A simple reduction on ciphers.
open import composition-sem-sec-reduction

-- Tracking space and time through a restricted universe
-- of functions.
open import data-universe
open import fun-universe
open import agda-fun-universe
open import bits-fun-universe
open import fin-fun-universe
open import const-fun-universe
open import cost-fun-universe
open import inverse-fun-universe
open import circuit-fun-universe
open import syntax-fun-universe

-- TODO: Fix & restore the product of universes and ops

-- Draft modules of previous attempts.
-- There is still some code to rescue.
open import circuit
open import flipbased-tree-probas
open import flipbased-no-split
open import flipbased-product-implem


Move parameter to module level.

Move parameter to module level.

All definitions in this module take the same parameter, so moving that
parameter to the module level makes it easier to instantiate all of the
definitions at once.

Old-commit-hash: c9a73b24cd02aed1ee75b46416c1893c8c37b130

import Parametric.Syntax.Type as Type
import Base.Syntax.Context as Context

module Parametric.Change.Term
    {Base : Set}
    (Constant : Context.Context (Type.Type Base) → Type.Type Base → Set {- of constants -})
    {Δbase : Base → Type.Type Base}
  where

-- Terms that operate on changes

open Type Base
open Context Type

open import Parametric.Change.Type Δbase
open import Parametric.Syntax.Term Constant

open import Data.Product

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

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

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

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

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

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

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

import Parametric.Syntax.Type as Type
import Base.Syntax.Context as Context

module Parametric.Change.Term
    {Base : Set}
    (Constant : Context.Context (Type.Type Base) → Type.Type Base → Set {- of constants -})
  where

-- Terms that operate on changes

open Type Base
open Context Type

open import Parametric.Change.Type Δbase
open import Parametric.Syntax.Term Constant

open import Data.Product

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

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

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

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

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

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

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