Bits: some cleanups and more props on #

Bits: some cleanups and more props on #

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
import Data.Bool.NP as Bool
open Bool hiding (_==_; toℕ)
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; sum) 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_

-- Negate all bits, i.e. "xor"ing them by one.
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 | vnot∘vnot≗id xs = refl

-- Negate the i-th bit.
notᵢ : ∀ {n} (i : Fin n) → Bits n → Bits n
notᵢ = onᵢ not

⊕-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

-- "Xor"ing the i-th bit with `b' is the same thing as "xor"ing with a vector of zeros
-- except at the i-th position.
-- Such a vector can be obtained by "xor"ing the i-th bit of a vector of zeros.
onᵢ-xor-⊕ : ∀ b {n} (i : Fin n) → onᵢ (_xor_ b) i ≗ _⊕_ (onᵢ (_xor_ b) i 0ⁿ)
onᵢ-xor-⊕ b zero    (x ∷ xs) rewrite proj₂ Xor°.+-identity b | ⊕-left-identity xs = refl
onᵢ-xor-⊕ b (suc i) (x ∷ xs) rewrite onᵢ-xor-⊕ b i xs = refl

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

module Search {i} {I : Set i} (`1 : I) (`2*_ : I → I)
              {a} {A : I → Set a} (_·_ : ∀ {m} → A m → A m → A (`2* m)) where

  `2^_ : ℕ → I
  `2^_ = fold `1 `2*_

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

search′ : ∀ {n a} {A : ℕ → Set a} → (∀ {m} → A m → A m → A (2* m)) → (Bits n → A 1) → A (2^ n)
search′ {n} {a} {A} op f = Search.search 1 2*_ {a} {A} (λ {m} → op {m}) f

search : ∀ {n a} {A : Set a} → (A → A → A) → (Bits n → A) → A
search {n} {a} {A} _·_ f = search′ {n} {a} {const A} _·_ f

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

sum : ∀ {n} → (Bits n → ℕ) → ℕ
sum = search _+_

sum-const : ∀ n x → sum {n} (const x) ≡ ⟨2^ n * x ⟩
sum-const zero    _ = refl
sum-const (suc n) x = cong₂ _+_ (sum-const n x) (sum-const n x)

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → ℕ
#⟨ pred ⟩ = sum (Bool.toℕ ∘ pred)

#⟨⟩-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^ n = sum-const n 1

==-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

==-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)

#∧ : ∀ {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)

#-bound : ∀ c (f : Bits c → Bit) → #⟨ f ⟩ ≤ 2^ c
#-bound zero    f = Bool.toℕ≤1 (f [])
#-bound (suc c) f = #-bound c (f ∘ 0∷_) +-mono #-bound c (f ∘ 1∷_)

#-⊕ : ∀ {c} (bs : Bits c) (f : Bits c → Bit) → #⟨ f ⟩ ≡ #⟨ f ∘ _⊕_ bs ⟩
#-⊕ [] f = ≡.refl
#-⊕ (b ∷ bs) f
  rewrite #-⊕ bs (f ∘ 0∷_)
        | #-⊕ bs (f ∘ 1∷_)
  with b
... | false = refl
... | true  = ℕ°.+-comm #⟨ f ∘ 0∷_ ∘ _⊕_ bs ⟩ _

#-∘vnot : ∀ c (f : Bits c → Bit) → #⟨ f ⟩ ≡ #⟨ f ∘ vnot ⟩
#-∘vnot _ f = #-⊕ 1ⁿ f

#-∘xorᵢ : ∀ {c} (i : Fin c) (f : Bits c → Bit) b → #⟨ f ⟩ ≡ #⟨ f ∘ onᵢ (_xor_ b) i ⟩
#-∘xorᵢ i f b = pf
  where pad = onᵢ (_xor_ b) i 0ⁿ
        pf : #⟨ f ⟩ ≡ #⟨ f ∘ onᵢ (_xor_ b) i ⟩
        pf rewrite #-⊕ pad f = ≗-cong-# (f ∘ _⊕_ pad) (f ∘ onᵢ (_xor_ b) i) (cong (_$_ f) ∘ sym ∘ onᵢ-xor-⊕ b i)

#-∘notᵢ : ∀ {c} (i : Fin c) (f : Bits c → Bit) → #⟨ f ⟩ ≡ #⟨ f ∘ notᵢ i ⟩
#-∘notᵢ i f = #-∘xorᵢ i f true

#-not∘ : ∀ c (f : Bits c → Bit) → #⟨ f ⟩ ≡ 2^ c ∸ #⟨ not ∘ f ⟩
#-not∘ zero f with f []
... | true  = ≡.refl
... | false = ≡.refl
#-not∘ (suc c) f
  rewrite #-not∘ c (f ∘ 0∷_)
        | #-not∘ c (f ∘ 1∷_) = factor-+-∸ (#-bound c (not ∘ f ∘ 0∷_)) (#-bound c (not ∘ f ∘ 1∷_))

|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 (|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))

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.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; sum) 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

module Search {i} {I : Set i} (`1 : I) (`2*_ : I → I)
              {a} {A : I → Set a} (_·_ : ∀ {m} → A m → A m → A (`2* m)) where

  `2^_ : ℕ → I
  `2^_ = fold `1 `2*_

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

search′ : ∀ {n a} {A : ℕ → Set a} → (∀ {m} → A m → A m → A (2* m)) → (Bits n → A 1) → A (2^ n)
search′ {n} {a} {A} op f = Search.search 1 2*_ {a} {A} (λ {m} → op {m}) f

search : ∀ {n a} {A : Set a} → (A → A → A) → (Bits n → A) → A
search {n} {a} {A} _·_ f = search′ {n} {a} {const A} _·_ f

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

sum : ∀ {n} → (Bits n → ℕ) → ℕ
sum = search _+_

sum-const : ∀ n x → sum {n} (const x) ≡ ⟨2^ n * x ⟩
sum-const zero    _ = refl
sum-const (suc n) x = cong₂ _+_ (sum-const n x) (sum-const n x)

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → ℕ
#⟨ pred ⟩ = sum (λ 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


+bitsfun

+bitsfun

module flat-funs where

open import Data.Nat
import Level as L
open import composable
open import vcomp

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `Bits : ℕ → T
    `Bit  : T
    _`×_  : T → T → T
    _`→_  : T → T → Set
  infixr 2 _`×_
  infix 0 _`→_

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  field
    idO : ∀ {A} → A `→ A
    isComposable  : Composable  _`→_
    isVComposable : VComposable _`×_ _`→_

    -- Fanout
    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

  open FlatFuns ♭Funs public
  open Composable isComposable public
  open VComposable isVComposable public

open import Data.Bits
open import Data.Product
open import Function

fun♭Funs : FlatFuns Set
fun♭Funs = mk Bits Bit _×_ (λ A B → A → B)

bitsfun♭Funs : FlatFuns ℕ
bitsfun♭Funs = mk id 1 _+_ (λ i o → Bits i → Bits o)

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id funComp funVComp _&&&_
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)

module flat-funs where

open import Data.Nat
import Level as L
open import composable
open import vcomp

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `Bits : ℕ → T
    `Bit  : T
    _`×_  : T → T → T
    _`→_  : T → T → Set
  infixr 2 _`×_
  infix 0 _`→_

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  field
    idO : ∀ {A} → A `→ A
    isComposable  : Composable  _`→_
    isVComposable : VComposable _`×_ _`→_

    -- Fanout
    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

  open FlatFuns ♭Funs public
  open Composable isComposable public
  open VComposable isVComposable public

open import Data.Bits
open import Data.Product
open import Function

fun♭Funs : FlatFuns Set
fun♭Funs = mk Bits Bit _×_ (λ A B → A → B)

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id funComp funVComp _&&&_
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)


WIP implement composition for sum changes STUCK

Goal: implement change composition without using ⊝ for any datatype, so
that we can also drop the base value index for compose.

Problem: if I compose a change from inj₁ a1 to inj₂ b2, and a change
from inj₂ b2 to inj₁ a3, I need to produce a change from inj₁ a1 to inj₁
a3. I can either use a3 ⊝ a1, and we don't want, or produce a
replacement change from a inj₁ to inj₁, which is not valid. So I'll need
to widen validity.

module Thesis.Changes where

open import Data.Product
open import Data.Sum
open import Data.Unit
open import Relation.Binary.PropositionalEquality

record IsChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  infixl 6 _⊕_ _⊝_
  field
    _⊕_ : A → ChA → A
    fromto→⊕ : ∀ dv v1 v2 →
      ch dv from v1 to v2 →
      v1 ⊕ dv ≡ v2
    _⊝_ : A → A → ChA
    ⊝-fromto : ∀ (a b : A) → ch (b ⊝ a) from a to b

  update-diff : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  update-diff b a = fromto→⊕ (b ⊝ a) a b (⊝-fromto a b)
  nil : A → ChA
  nil a = a ⊝ a
  nil-fromto : (a : A) → ch (nil a) from a to a
  nil-fromto a = ⊝-fromto a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  valid : ∀ (a : A) (da : ChA) → Set
  valid a da = ch da from a to (a ⊕ da)
  Δ : (a : A) → Set
  Δ a = Σ[ da ∈ ChA ] valid a da
  Δ₂ : (a1 : A) (a2 : A) → Set
  Δ₂ a1 a2 = Σ[ da ∈ ChA ] ch da from a1 to a2

  _⊕'_ : (a1 : A) -> {a2 : A} -> (da : Δ₂ a1 a2) -> A
  a1 ⊕' (da , daa) = a1 ⊕ da

record IsCompChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  field
    isChangeStructure : IsChangeStructure A ChA ch_from_to_
    _⊚[_]_ : ChA → A → ChA → ChA
    ⊚-fromto : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
      ch da1 from a1 to a2 → ch da2 from a2 to a3 → ch da1 ⊚[ a1 ] da2 from a1 to a3

  open IsChangeStructure isChangeStructure public
  ⊚-correct : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
    ch da1 from a1 to a2 → ch da2 from a2 to a3 →
    a1 ⊕ (da1 ⊚[ a1 ] da2) ≡ a3
  ⊚-correct a1 a2 a3 da1 da2 daa1 daa2 = fromto→⊕ _ _ _ (⊚-fromto _ _ _ da1 da2 daa1 daa2)

IsChangeStructure→IsCompChangeStructure : ∀ {A ChA ch_from_to_} → IsChangeStructure A ChA ch_from_to_ → IsCompChangeStructure A ChA ch_from_to_
IsChangeStructure→IsCompChangeStructure {A} {ChA} {ch_from_to_} isCS = record
  { isChangeStructure = isCS
  ; _⊚[_]_ = λ da1 a da2 → a ⊕ da1 ⊕ da2 ⊝ a
  ; ⊚-fromto = body
  }
  where
    _⊕_ = IsChangeStructure._⊕_ isCS
    _⊝_ = IsChangeStructure._⊝_ isCS
    fromto→⊕ = IsChangeStructure.fromto→⊕ isCS
    ⊝-fromto = IsChangeStructure.⊝-fromto isCS
    infixl 6 _⊕_ _⊝_
    body : ∀ (a1 a2 a3 : A) da1 da2 →
      ch da1 from a1 to a2 →
      ch da2 from a2 to a3 → ch a1 ⊕ da1 ⊕ da2 ⊝ a1 from a1 to a3
    body a1 a2 a3 da1 da2 daa1 daa2 rewrite fromto→⊕ _ _ _ daa1 | fromto→⊕ _ _ _ daa2 =
      ⊝-fromto a1 a3

record ChangeStructure (A : Set) : Set₁ where
  field
    Ch : Set
    ch_from_to_ : (dv : Ch) → (v1 v2 : A) → Set
    isCompChangeStructure : IsCompChangeStructure A Ch ch_from_to_
  open IsCompChangeStructure isCompChangeStructure public

open ChangeStructure {{...}} public hiding (Ch)
Ch : ∀ (A : Set) → {{CA : ChangeStructure A}} → Set
Ch A {{CA}} = ChangeStructure.Ch CA

{-# DISPLAY IsChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY ChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY ChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY IsChangeStructure.nil x = nil #-}
{-# DISPLAY ChangeStructure.nil x = nil #-}
{-# DISPLAY IsCompChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure.ch_from_to_ x = ch_from_to_ #-}

module _ {A B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  -- In this module, given change structures CA and CB for A and B, we define
  -- change structures for A → B, A × B and A ⊎ B.

  open import Postulate.Extensionality

  -- Functions
  instance
    funCS : ChangeStructure (A → B)

  infixl 6 _f⊕_ _f⊝_
  private
    fCh = A → Ch A → Ch B

    fCh_from_to_ : (df : fCh) → (f1 f2 : A → B) → Set
    fCh_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2

    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)

    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

    f⊝-fromto : ∀ (f1 f2 : A → B) → fCh (f2 f⊝ f1) from f1 to f2
    f⊝-fromto f1 f2 da a1 a2 daa
      rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))

    _f⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f⊚[_]_ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)

    _f2⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f2⊚[_]_ df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))

    f⊚-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f⊚[ f1 ] df2 from f1 to f3
    f⊚-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a1) (f3 a2)
        (df1 a1 (nil a1))
        (df2 a1 da)
        (dff1 (nil a1) a1 a1 (nil-fromto a1))
        (dff2 da a1 a2 daa)

    f⊚2-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f2⊚[ f1 ] df2 from f1 to f3
    f⊚2-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa rewrite fromto→⊕ da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a2) (f3 a2)
        (df1 a1 da)
        (df2 a2 (nil a2))
        (dff1 da a1 a2 daa)
        (dff2 (nil a2) a2 a2 (nil-fromto a2))

  funCS = record
    { Ch = fCh
    ; ch_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _f⊕_
        ; fromto→⊕ = λ df f1 f2 dff →
          ext (λ v →
            fromto→⊕ (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
        ; _⊝_ = _f⊝_
        ; ⊝-fromto = f⊝-fromto
        }
      ; _⊚[_]_ = _f⊚[_]_
      ; ⊚-fromto = f⊚-fromto
      }
    }

  -- Products
  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pch_from_to_ : pCh → A × B → A × B → Set
    pch (da , db) from (a1 , b1) to (a2 , b2) = ch da from a1 to a2 × ch db from b1 to b2
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    pfromto→⊕ : ∀ dp p1 p2 →
      pch dp from p1 to p2 → p1 p⊕ dp ≡ p2
    pfromto→⊕ (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
      cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
    p⊝-fromto : ∀ (p1 p2 : A × B) → pch p2 p⊝ p1 from p1 to p2
    p⊝-fromto (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
    p⊚-fromto : ∀ p1 p2 p3 dp1 dp2 →
      pch dp1 from p1 to p2 → (pch dp2 from p2 to p3) → pch dp1 p⊚[ p1 ] dp2 from p1 to p3
    p⊚-fromto (a1 , b1) (a2 , b2) (a3 , b3) (da1 , db1) (da2 , db2)
      (daa1 , dbb1) (daa2 , dbb2) =
        ⊚-fromto a1 a2 a3 da1 da2 daa1 daa2 , ⊚-fromto b1 b2 b3 db1 db2 dbb1 dbb2

  instance
    pairCS : ChangeStructure (A × B)
  pairCS = record
    { Ch = pCh
    ; ch_from_to_ = pch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _p⊕_
        ; fromto→⊕ = pfromto→⊕
        ; _⊝_ = _p⊝_
        ; ⊝-fromto = p⊝-fromto
        }
      ; _⊚[_]_ = _p⊚[_]_
      ; ⊚-fromto = p⊚-fromto
      }
    }

  -- Sums
  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    _s⊕2_ : A ⊎ B → SumChange2 → A ⊎ B
    _s⊕2_ (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    _s⊕2_ (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    _s⊕2_ (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    _s⊕2_ (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    _s⊕2_ s (rp s₁) = s₁

    _s⊕_ : A ⊎ B → SumChange → A ⊎ B
    s s⊕ ds = s s⊕2 (convert ds)

    _s⊝2_ : A ⊎ B → A ⊎ B → SumChange2
    _s⊝2_ (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    _s⊝2_ (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    _s⊝2_ s2 s1 = rp s2

    _s⊝_ : A ⊎ B → A ⊎ B → SumChange
    s2 s⊝ s1 = convert₁ (s2 s⊝2 s1)

  data sch_from_to_ : SumChange → A ⊎ B → A ⊎ B → Set where
    -- sft = Sum From To
    sft₁ : ∀ {da a1 a2} (daa : ch da from a1 to a2) → sch (convert₁ (ch₁ da)) from (inj₁ a1) to (inj₁ a2)
    sft₂ : ∀ {db b1 b2} (dbb : ch db from b1 to b2) → sch (convert₁ (ch₂ db)) from (inj₂ b1) to (inj₂ b2)
    sftrp₁ : ∀ a1 b2 → sch (convert₁ (rp (inj₂ b2))) from (inj₁ a1) to (inj₂ b2)
    sftrp₂ : ∀ b1 a2 → sch (convert₁ (rp (inj₁ a2))) from (inj₂ b1) to (inj₁ a2)

  sfromto→⊕2 : (ds : SumChange2) (s1 s2 : A ⊎ B) →
    sch convert₁ ds from s1 to s2 → s1 s⊕2 ds ≡ s2
  sfromto→⊕2 (ch₁ da) (inj₁ a1) (inj₁ a2) (sft₁ daa) = cong inj₁ (fromto→⊕ _ _ _ daa)
  sfromto→⊕2 (ch₂ db) (inj₂ b1) (inj₂ b2) (sft₂ dbb) = cong inj₂ (fromto→⊕ _ _ _ dbb)
  sfromto→⊕2 (rp .(inj₂ y)) (inj₁ x) (inj₂ y) (sftrp₁ .x .y) = refl
  sfromto→⊕2 (rp .(inj₁ x)) (inj₂ y) (inj₁ x) (sftrp₂ .y .x) = refl

  sfromto→⊕ : (ds : SumChange) (s1 s2 : A ⊎ B) →
    sch ds from s1 to s2 → s1 s⊕ ds ≡ s2
  sfromto→⊕ ds s1 s2 dss =
    sfromto→⊕2 (convert ds) s1 s2
      (subst (sch_from s1 to s2) (sym (inv1 ds))
        dss)
  s⊝-fromto : (s1 s2 : A ⊎ B) → sch s2 s⊝ s1 from s1 to s2
  s⊝-fromto (inj₁ a1) (inj₁ a2) = sft₁ (⊝-fromto a1 a2)
  s⊝-fromto (inj₁ a1) (inj₂ b2) = sftrp₁ a1 b2
  s⊝-fromto (inj₂ b1) (inj₁ a2) = sftrp₂ b1 a2
  s⊝-fromto (inj₂ b1) (inj₂ b2) = sft₂ (⊝-fromto b1 b2)
  _s⊚2[_]_ : SumChange2 → A ⊎ B → SumChange2 → SumChange2
  ch₁ da1 s⊚2[ inj₁ a ] ch₁ da2 = ch₁ (da1 ⊚[ a ] da2)
  ch₁ da1 s⊚2[ inj₂ b ] ch₁ da2 = {!!}
  ch₂ db s⊚2[ s ] ch₁ da = {!!}
  rp (inj₁ a2) s⊚2[ s ] ch₁ da2 = rp (inj₁ (a2 ⊕ da2))
  rp (inj₂ y) s⊚2[ s ] ch₁ da2 = {!!}
  ch₁ da s⊚2[ s ] ch₂ db = {!!}
  ch₂ db1 s⊚2[ inj₁ a ] ch₂ db2 = ch₂ {!!}
  ch₂ db1 s⊚2[ inj₂ b ] ch₂ db2 = ch₂ (db1 ⊚[ b ] db2)
  rp (inj₁ a2) s⊚2[ s ] ch₂ db2 = {!!}
  rp (inj₂ b2) s⊚2[ s ] ch₂ db2 = rp (inj₂ (b2 ⊕ db2))
  ch₁ da s⊚2[ s ] rp s₁ = rp s₁
  ch₂ db s⊚2[ s ] rp s₁ = rp s₁
  rp s2 s⊚2[ s1 ] rp s3 = rp s3

  _s⊚[_]_ : SumChange → A ⊎ B → SumChange → SumChange
  ds1 s⊚[ s ] ds2 = convert₁ (convert ds1 s⊚2[ s ] convert ds2)

  s⊚-fromto : (s1 s2 s3 : A ⊎ B) (ds1 ds2 : SumChange) →
      sch ds1 from s1 to s2 →
      sch ds2 from s2 to s3 → sch ds1 s⊚[ s1 ] ds2 from s1 to s3
  s⊚-fromto (inj₁ a1) (inj₁ a2) (inj₁ a3) (inj₁ (inj₁ da1)) (inj₁ (inj₁ da2)) (sft₁ daa1) (sft₁ daa2) = sft₁ (⊚-fromto a1 a2 a3 _ _ daa1 daa2)
  s⊚-fromto .(inj₂ b1) .(inj₁ a2) (inj₁ a3) .(inj₂ (inj₁ a2)) (inj₁ (inj₁ da2)) (sftrp₂ b1 a2) (sft₁ daa2) with sfromto→⊕ (inj₁ (inj₁ da2)) _ _ (sft₁ daa2)
  s⊚-fromto .(inj₂ b1) .(inj₁ a2) (inj₁ .(a2 ⊕ da2)) .(inj₂ (inj₁ a2)) (inj₁ (inj₁ da2)) (sftrp₂ b1 a2) (sft₁ daa2) | refl = sftrp₂ b1 (a2 ⊕ da2)
  s⊚-fromto (inj₂ b1) (inj₂ b2) (inj₂ b3) (inj₁ (inj₂ db1)) (inj₁ (inj₂ db2)) (sft₂ dbb1) (sft₂ dbb2) = sft₂ (⊚-fromto b1 b2 b3 _ _ dbb1 dbb2)
  s⊚-fromto .(inj₁ a1) .(inj₂ b2) .(inj₂ _) .(inj₂ (inj₂ b2)) (inj₁ (inj₂ db2)) (sftrp₁ a1 b2) (sft₂ dbb2) with sfromto→⊕ (inj₁ (inj₂ db2)) _ _ (sft₂ dbb2)
  s⊚-fromto .(inj₁ a1) .(inj₂ b2) .(inj₂ (b2 ⊕ db2)) .(inj₂ (inj₂ b2)) (inj₁ (inj₂ db2)) (sftrp₁ a1 b2) (sft₂ dbb2) | refl = sftrp₁ a1 (b2 ⊕ db2)
  s⊚-fromto (inj₁ a1) .(inj₁ a2) .(inj₂ b2) .(inj₁ (inj₁ _)) .(inj₂ (inj₂ b2)) (sft₁ daa) (sftrp₁ a2 b2) = sftrp₁ a1 b2
  s⊚-fromto .(inj₂ b1) .(inj₁ a1) .(inj₂ b2) .(inj₂ (inj₁ a1)) .(inj₂ (inj₂ b2)) (sftrp₂ b1 .a1) (sftrp₁ a1 b2) = {!!}
  s⊚-fromto .(inj₂ _) .(inj₂ b2) .(inj₁ a2) .(inj₁ (inj₂ _)) .(inj₂ (inj₁ a2)) (sft₂ dbb2) (sftrp₂ b2 a2) = sftrp₂ _ _
  s⊚-fromto .(inj₁ a1) .(inj₂ b1) .(inj₁ a2) .(inj₂ (inj₂ b1)) .(inj₂ (inj₁ a2)) (sftrp₁ a1 .b1) (sftrp₂ b1 a2) = {!!}

  instance
    sumCS : ChangeStructure (A ⊎ B)
  sumCS = record
    { Ch = SumChange
    ; ch_from_to_ = sch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
      { _⊕_ = _s⊕_
      ; fromto→⊕ = sfromto→⊕
      ; _⊝_ = _s⊝_
      ; ⊝-fromto = s⊝-fromto
      }
      ; _⊚[_]_ = _s⊚[_]_
      ; ⊚-fromto = s⊚-fromto
      }
    }

instance
  unitCS : ChangeStructure ⊤

  unitCS = record
    { Ch = ⊤
    ; ch_from_to_ = λ dv v1 v2 → ⊤
    ; isCompChangeStructure = record
      { isChangeStructure = record
      { _⊕_ = λ _ _ → tt
      ; fromto→⊕ = λ { _ _ tt _ → refl }
      ; _⊝_ = λ _ _ → tt
      ; ⊝-fromto = λ a b → tt
      }
      ; _⊚[_]_ = λ da1 a da2 → tt
      ; ⊚-fromto = λ a1 a2 a3 da1 da2 daa1 daa2 → tt
      }
    }

module Thesis.Changes where

open import Data.Product
open import Data.Sum
open import Data.Unit
open import Relation.Binary.PropositionalEquality

record IsChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  infixl 6 _⊕_ _⊝_
  field
    _⊕_ : A → ChA → A
    fromto→⊕ : ∀ dv v1 v2 →
      ch dv from v1 to v2 →
      v1 ⊕ dv ≡ v2
    _⊝_ : A → A → ChA
    ⊝-fromto : ∀ (a b : A) → ch (b ⊝ a) from a to b

  update-diff : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  update-diff b a = fromto→⊕ (b ⊝ a) a b (⊝-fromto a b)
  nil : A → ChA
  nil a = a ⊝ a
  nil-fromto : (a : A) → ch (nil a) from a to a
  nil-fromto a = ⊝-fromto a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  valid : ∀ (a : A) (da : ChA) → Set
  valid a da = ch da from a to (a ⊕ da)
  Δ : (a : A) → Set
  Δ a = Σ[ da ∈ ChA ] valid a da
  Δ₂ : (a1 : A) (a2 : A) → Set
  Δ₂ a1 a2 = Σ[ da ∈ ChA ] ch da from a1 to a2

  _⊕'_ : (a1 : A) -> {a2 : A} -> (da : Δ₂ a1 a2) -> A
  a1 ⊕' (da , daa) = a1 ⊕ da

record IsCompChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  field
    isChangeStructure : IsChangeStructure A ChA ch_from_to_
    _⊚[_]_ : ChA → A → ChA → ChA
    ⊚-fromto : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
      ch da1 from a1 to a2 → ch da2 from a2 to a3 → ch da1 ⊚[ a1 ] da2 from a1 to a3

  open IsChangeStructure isChangeStructure public
  ⊚-correct : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
    ch da1 from a1 to a2 → ch da2 from a2 to a3 →
    a1 ⊕ (da1 ⊚[ a1 ] da2) ≡ a3
  ⊚-correct a1 a2 a3 da1 da2 daa1 daa2 = fromto→⊕ _ _ _ (⊚-fromto _ _ _ da1 da2 daa1 daa2)

IsChangeStructure→IsCompChangeStructure : ∀ {A ChA ch_from_to_} → IsChangeStructure A ChA ch_from_to_ → IsCompChangeStructure A ChA ch_from_to_
IsChangeStructure→IsCompChangeStructure {A} {ChA} {ch_from_to_} isCS = record
  { isChangeStructure = isCS
  ; _⊚[_]_ = λ da1 a da2 → a ⊕ da1 ⊕ da2 ⊝ a
  ; ⊚-fromto = body
  }
  where
    _⊕_ = IsChangeStructure._⊕_ isCS
    _⊝_ = IsChangeStructure._⊝_ isCS
    fromto→⊕ = IsChangeStructure.fromto→⊕ isCS
    ⊝-fromto = IsChangeStructure.⊝-fromto isCS
    infixl 6 _⊕_ _⊝_
    body : ∀ (a1 a2 a3 : A) da1 da2 →
      ch da1 from a1 to a2 →
      ch da2 from a2 to a3 → ch a1 ⊕ da1 ⊕ da2 ⊝ a1 from a1 to a3
    body a1 a2 a3 da1 da2 daa1 daa2 rewrite fromto→⊕ _ _ _ daa1 | fromto→⊕ _ _ _ daa2 =
      ⊝-fromto a1 a3

record ChangeStructure (A : Set) : Set₁ where
  field
    Ch : Set
    ch_from_to_ : (dv : Ch) → (v1 v2 : A) → Set
    isCompChangeStructure : IsCompChangeStructure A Ch ch_from_to_
  open IsCompChangeStructure isCompChangeStructure public

open ChangeStructure {{...}} public hiding (Ch)
Ch : ∀ (A : Set) → {{CA : ChangeStructure A}} → Set
Ch A {{CA}} = ChangeStructure.Ch CA

{-# DISPLAY IsChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY ChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY ChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY IsChangeStructure.nil x = nil #-}
{-# DISPLAY ChangeStructure.nil x = nil #-}
{-# DISPLAY IsCompChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure.ch_from_to_ x = ch_from_to_ #-}

module _ {A B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  -- In this module, given change structures CA and CB for A and B, we define
  -- change structures for A → B, A × B and A ⊎ B.

  open import Postulate.Extensionality

  -- Functions
  instance
    funCS : ChangeStructure (A → B)

  infixl 6 _f⊕_ _f⊝_
  private
    fCh = A → Ch A → Ch B

    fCh_from_to_ : (df : fCh) → (f1 f2 : A → B) → Set
    fCh_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2

    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)

    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

    f⊝-fromto : ∀ (f1 f2 : A → B) → fCh (f2 f⊝ f1) from f1 to f2
    f⊝-fromto f1 f2 da a1 a2 daa
      rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))

    _f⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f⊚[_]_ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)

    _f2⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f2⊚[_]_ df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))

    f⊚-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f⊚[ f1 ] df2 from f1 to f3
    f⊚-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a1) (f3 a2)
        (df1 a1 (nil a1))
        (df2 a1 da)
        (dff1 (nil a1) a1 a1 (nil-fromto a1))
        (dff2 da a1 a2 daa)

    f⊚2-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f2⊚[ f1 ] df2 from f1 to f3
    f⊚2-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa rewrite fromto→⊕ da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a2) (f3 a2)
        (df1 a1 da)
        (df2 a2 (nil a2))
        (dff1 da a1 a2 daa)
        (dff2 (nil a2) a2 a2 (nil-fromto a2))

  funCS = record
    { Ch = fCh
    ; ch_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _f⊕_
        ; fromto→⊕ = λ df f1 f2 dff →
          ext (λ v →
            fromto→⊕ (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
        ; _⊝_ = _f⊝_
        ; ⊝-fromto = f⊝-fromto
        }
      ; _⊚[_]_ = _f⊚[_]_
      ; ⊚-fromto = f⊚-fromto
      }
    }

  -- Products
  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pch_from_to_ : pCh → A × B → A × B → Set
    pch (da , db) from (a1 , b1) to (a2 , b2) = ch da from a1 to a2 × ch db from b1 to b2
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    pfromto→⊕ : ∀ dp p1 p2 →
      pch dp from p1 to p2 → p1 p⊕ dp ≡ p2
    pfromto→⊕ (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
      cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
    p⊝-fromto : ∀ (p1 p2 : A × B) → pch p2 p⊝ p1 from p1 to p2
    p⊝-fromto (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
    p⊚-fromto : ∀ p1 p2 p3 dp1 dp2 →
      pch dp1 from p1 to p2 → (pch dp2 from p2 to p3) → pch dp1 p⊚[ p1 ] dp2 from p1 to p3
    p⊚-fromto (a1 , b1) (a2 , b2) (a3 , b3) (da1 , db1) (da2 , db2)
      (daa1 , dbb1) (daa2 , dbb2) =
        ⊚-fromto a1 a2 a3 da1 da2 daa1 daa2 , ⊚-fromto b1 b2 b3 db1 db2 dbb1 dbb2

  instance
    pairCS : ChangeStructure (A × B)
  pairCS = record
    { Ch = pCh
    ; ch_from_to_ = pch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _p⊕_
        ; fromto→⊕ = pfromto→⊕
        ; _⊝_ = _p⊝_
        ; ⊝-fromto = p⊝-fromto
        }
      ; _⊚[_]_ = _p⊚[_]_
      ; ⊚-fromto = p⊚-fromto
      }
    }

  -- Sums
  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    _s⊕2_ : A ⊎ B → SumChange2 → A ⊎ B
    _s⊕2_ (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    _s⊕2_ (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    _s⊕2_ (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    _s⊕2_ (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    _s⊕2_ s (rp s₁) = s₁

    _s⊕_ : A ⊎ B → SumChange → A ⊎ B
    s s⊕ ds = s s⊕2 (convert ds)

    _s⊝2_ : A ⊎ B → A ⊎ B → SumChange2
    _s⊝2_ (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    _s⊝2_ (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    _s⊝2_ s2 s1 = rp s2

    _s⊝_ : A ⊎ B → A ⊎ B → SumChange
    s2 s⊝ s1 = convert₁ (s2 s⊝2 s1)

  data sch_from_to_ : SumChange → A ⊎ B → A ⊎ B → Set where
    -- sft = Sum From To
    sft₁ : ∀ {da a1 a2} (daa : ch da from a1 to a2) → sch (convert₁ (ch₁ da)) from (inj₁ a1) to (inj₁ a2)
    sft₂ : ∀ {db b1 b2} (dbb : ch db from b1 to b2) → sch (convert₁ (ch₂ db)) from (inj₂ b1) to (inj₂ b2)
    sftrp₁ : ∀ a1 b2 → sch (convert₁ (rp (inj₂ b2))) from (inj₁ a1) to (inj₂ b2)
    sftrp₂ : ∀ b1 a2 → sch (convert₁ (rp (inj₁ a2))) from (inj₂ b1) to (inj₁ a2)

  sfromto→⊕2 : (ds : SumChange2) (s1 s2 : A ⊎ B) →
    sch convert₁ ds from s1 to s2 → s1 s⊕2 ds ≡ s2
  sfromto→⊕2 (ch₁ da) (inj₁ a1) (inj₁ a2) (sft₁ daa) = cong inj₁ (fromto→⊕ _ _ _ daa)
  sfromto→⊕2 (ch₂ db) (inj₂ b1) (inj₂ b2) (sft₂ dbb) = cong inj₂ (fromto→⊕ _ _ _ dbb)
  sfromto→⊕2 (rp .(inj₂ y)) (inj₁ x) (inj₂ y) (sftrp₁ .x .y) = refl
  sfromto→⊕2 (rp .(inj₁ x)) (inj₂ y) (inj₁ x) (sftrp₂ .y .x) = refl

  sfromto→⊕ : (ds : SumChange) (s1 s2 : A ⊎ B) →
    sch ds from s1 to s2 → s1 s⊕ ds ≡ s2
  sfromto→⊕ ds s1 s2 dss =
    sfromto→⊕2 (convert ds) s1 s2
      (subst (sch_from s1 to s2) (sym (inv1 ds))
        dss)
  s⊝-fromto : (s1 s2 : A ⊎ B) → sch s2 s⊝ s1 from s1 to s2
  s⊝-fromto (inj₁ a1) (inj₁ a2) = sft₁ (⊝-fromto a1 a2)
  s⊝-fromto (inj₁ a1) (inj₂ b2) = sftrp₁ a1 b2
  s⊝-fromto (inj₂ b1) (inj₁ a2) = sftrp₂ b1 a2
  s⊝-fromto (inj₂ b1) (inj₂ b2) = sft₂ (⊝-fromto b1 b2)
  instance
    sumCS : ChangeStructure (A ⊎ B)
  sumCS = record
    { Ch = SumChange
    ; ch_from_to_ = sch_from_to_
    ; isCompChangeStructure = IsChangeStructure→IsCompChangeStructure (record
      { _⊕_ = _s⊕_
      ; fromto→⊕ = sfromto→⊕
      ; _⊝_ = _s⊝_
      ; ⊝-fromto = s⊝-fromto
      })
    }

instance
  unitCS : ChangeStructure ⊤

  unitCS = record
    { Ch = ⊤
    ; ch_from_to_ = λ dv v1 v2 → ⊤
    ; isCompChangeStructure = record
      { isChangeStructure = record
      { _⊕_ = λ _ _ → tt
      ; fromto→⊕ = λ { _ _ tt _ → refl }
      ; _⊝_ = λ _ _ → tt
      ; ⊝-fromto = λ a b → tt
      }
      ; _⊚[_]_ = λ da1 a da2 → tt
      ; ⊚-fromto = λ a1 a2 a3 da1 da2 daa1 daa2 → tt
      }
    }


Just fixed some comments

Just fixed some comments

{-# OPTIONS --without-K #-}
open import Type                 using (Type)
open import Data.Bool.Base       using (Bool) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; _≢_)
import ZK.SigmaProtocol.Types

-- This module assumes the exact statement of the Zero-Knowledge proof to be
-- known by all parties.
module ZK.SigmaProtocol.KnownStatement
          (Commitment : Type) -- Prover commitments
  -- TODO Challenge should exp large wrt the security param
          (Challenge  : Type) -- Verifier challenges, picked at random
          (Response   : Type) -- Prover responses/proofs to challenges
          (Randomness : Type) -- Prover's randomness
          (Witness    : Type) -- Prover's witness
          (ValidWitness : Witness → Type) -- Valid witness for the statement
       where

-- See the module ZK.Types for details about the types:
--   * Prover-Interaction
--   * Verifier
--   * Transcript
--   * Transcript²
open ZK.SigmaProtocol.Types Commitment Challenge Response public

Prover : Type
Prover = (r : Randomness)(w : Witness) → Prover-Interaction

-- To run the interaction, one only needs the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover-Interaction → Challenge → Transcript
run (A , f) c = mk A c (f c)

_⇆_ : Verifier → Prover → (r : Randomness)(w : Witness)(c : Challenge) → Bool
(verifier ⇆ prover) r w c = verifier (run (prover r w) c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

  Verified : (t : Transcript) → Type
  Verified t = ✓ (verifier t)

  prover-commitment : (r : Randomness)(w : Witness) → Commitment
  prover-commitment r w = Prover-Interaction.get-A (prover r w)

  prover-response : (r : Randomness)(w : Witness)(c : Challenge) → Response
  prover-response r w = Prover-Interaction.get-f (prover r w)

-- Correctness (also called completeness in some papers): a Σ-protocol is said
-- to be correct if for any challenge, the (honest) verifier accepts what
-- the honest prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ w r c (w? : ValidWitness w) →
                              ✓ ((verifier ⇆ prover) r w c)

-- A simulator takes a challenge and a response and returns a commitment (to be used to prove the Special Honest Verifier Zero-Knowledge property).
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ c s → let A = simulator c s in
            ✓ (verifier (mk A c s))

{-
  A Σ-protocol is said to be Special Honest Verifier Zero-Knowledge if there is a correct simulator.
  This property is one of the necessary conditions to apply the Strong Fiat Shamir
  transformation.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if the challenge c and response s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the honest prover and the (honest) verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator          : Simulator
    .correct-simulator : Correct-simulator verifier simulator

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = (t² : Transcript² verifier) → Witness

Extract-Valid-Witness : (verifier : Verifier) → Extractor verifier → Type
Extract-Valid-Witness verifier extractor = ∀ t² → ValidWitness (extractor t²)

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct knowledge extractor is said to have the Special Soundness property.
-- This property is one of the conditions needed to apply the Strong Fiat Shamir
-- transformation.
-- Also called 2-extractable
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
    extractor              : Extractor verifier
    .extract-valid-witness : Extract-Valid-Witness verifier extractor

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    .correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type                 using (Type)
open import Data.Bool.Base       using (Bool) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; _≢_)
import ZK.SigmaProtocol.Types

-- This module assumes the exact statement of the Zero-Knowledge proof to be
-- known by all parties.
module ZK.SigmaProtocol.KnownStatement
          (Commitment : Type) -- Prover commitments
  -- TODO Challenge should exp large wrt the security param
          (Challenge  : Type) -- Verifier challenges, picked at random
          (Response   : Type) -- Prover responses/proofs to challenges
          (Randomness : Type) -- Prover's randomness
          (Witness    : Type) -- Prover's witness
          (ValidWitness : Witness → Type) -- Valid witness for the statement
       where

-- See the module ZK.Types for details about the types:
--   * Prover-Interaction
--   * Verifier
--   * Transcript
--   * Transcript²
open ZK.SigmaProtocol.Types Commitment Challenge Response public

Prover : Type
Prover = (r : Randomness)(w : Witness) → Prover-Interaction

-- To run the interaction, one only needs the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover-Interaction → Challenge → Transcript
run (A , f) c = mk A c (f c)

_⇆_ : Verifier → Prover → (r : Randomness)(w : Witness)(c : Challenge) → Bool
(verifier ⇆ prover) r w c = verifier (run (prover r w) c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

  Verified : (t : Transcript) → Type
  Verified t = ✓ (verifier t)

  prover-commitment : (r : Randomness)(w : Witness) → Commitment
  prover-commitment r w = Prover-Interaction.get-A (prover r w)

  prover-response : (r : Randomness)(w : Witness)(c : Challenge) → Response
  prover-response r w = Prover-Interaction.get-f (prover r w)

-- Correctness (also called completeness in some papers): a Σ-protocol is said
-- to be correct if for any challenge, the (honest) verifier accepts what
-- the (honest) prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ w r c (w? : ValidWitness w) →
                              ✓ ((verifier ⇆ prover) r w c)

-- A simulator takes a challenge and a response and returns a commitment.
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ c s → let A = simulator c s in
            ✓ (verifier (mk A c s))

{-
  A Σ-protocol, more specifically a verifier which is equipped with
  a correct simulator is said to be Special Honest Verifier Zero Knowledge.
  This property is one of the condition to apply the Strong Fiat Shamir
  transformation.

  The Special part of Special-Honest-Verifier-Zero-Knowledge is covered by the
  simulator being correct.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if the challenge c and response s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the (honest) prover and the (honest) verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator          : Simulator
    .correct-simulator : Correct-simulator verifier simulator

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = (t² : Transcript² verifier) → Witness

Extract-Valid-Witness : (verifier : Verifier) → Extractor verifier → Type
Extract-Valid-Witness verifier extractor = ∀ t² → ValidWitness (extractor t²)

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct extractor is said to have the Special Soundness property.
-- This property is one of the condition to apply the Strong Fiat Shamir
-- transformation.
-- Also called 2-extractable
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
    extractor              : Extractor verifier
    .extract-valid-witness : Extract-Valid-Witness verifier extractor

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    .correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public
-- -}
-- -}
-- -}
-- -}


Convert to stdlib

Convert to stdlib

open import Data.Bool
open import Data.List
open import Data.Nat

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

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

_∈_ : ℕ → List ℕ → Bool
x ∈ []       = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) ∧ (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []       = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) ∨ (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ []))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ []

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ []) (5 ∷ 3 ∷ 7 ∷ 7 ∷ [])) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (5 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ []) (6 ∷ 3 ∷ [])) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (6 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ []) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ []) (3 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ [])) ∷
  (model (10 ∷ 9 ∷ []) (1 ∷ [])) ∷
  (model (3 ∷ 4 ∷ 11 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 7 ∷ 1 ∷ []) (4 ∷ 11 ∷ 8 ∷ [])) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ []) (11 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ []) (11 ∷ 3 ∷ [])) ∷
  (model (3 ∷ 6 ∷ 5 ∷ []) ([])) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ []) (12 ∷ [])) ∷ []

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

main = (closure proofs (5 ∷ []))

open import Agda.Builtin.Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

infixr 5 _∷_

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A
{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  ∘    #-}
{-# BUILTIN CONS _∷_  #-}

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ ∘

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (5 ∷ 3 ∷ 7 ∷ 7 ∷ ∘)) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (5 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (6 ∷ 3 ∷ ∘)) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (6 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ ∘) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ ∘) (3 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ ∘)) ∷
  (model (10 ∷ 9 ∷ ∘) (1 ∷ ∘)) ∷
  (model (3 ∷ 4 ∷ 11 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 7 ∷ 1 ∷ ∘) (4 ∷ 11 ∷ 8 ∷ ∘)) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ ∘) (11 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ ∘) (11 ∷ 3 ∷ ∘)) ∷
  (model (3 ∷ 6 ∷ 5 ∷ ∘) (∘)) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ ∘) (12 ∷ ∘)) ∷ ∘

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

main = (closure proofs (5 ∷ ∘))


distance: upgrade count, and add antisym

module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count; countᶠ)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
    ]-[-antisym : ∀ {n} (f : ⅁ n) → ¬ (f ]-[ f)
    ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
    ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h

  ]-[-cong-right-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ]-[ g → g ≈⅁ h → f ]-[ h
  ]-[-cong-right-≈↺ pf pf' = ]-[-sym (]-[-cong-left-≈↺ (sym pf') (]-[-sym pf))

  ]-[-cong-≗↺ : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong-≗↺ {c} {c'} {f} {g} {f'} {g'} f≗g f'≗g' pf
     = ]-[-cong-left-≈↺ {f = g} {g = f} {h = g'}
         ((≗⇒≈⅁ (λ x → sym (f≗g x)))) (]-[-cong-right-≈↺ pf (≗⇒≈⅁ f'≗g'))

  breaks : ∀ {c} (EXP : Bit → ⅁ c) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ⅁ c₀) (⅁₁ : Bit → ⅁ c₁) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ⅁ c}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong-≗↺ (same-games 0b) (same-games 1b)

private
  2^_≥1 : ∀ n → 2^ n ≥ 1
  2^ zero ≥1  = s≤s z≤n
  2^ suc n ≥1 = z≤n {2^ n} +-mono 2^ n ≥1

module HomImplem k where
  --  | Pr[ f ≡ 1 ] - Pr[ g ≡ 1 ] | ≥ ε            [ on reals ]
  --  dist Pr[ f ≡ 1 ] Pr[ g ≡ 1 ] ≥ ε             [ on reals ]
  --  dist (#1 f / 2^ c) (#1 g / 2^ c) ≥ ε          [ on reals ]
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c where ε = 2^ -k [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(-k) * 2^ c            [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c - k)                [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c ∸ k)               [ on natural ]
  _]-[_ : ∀ {n} (f g : ⅁ n) → Set
  _]-[_ {n} f g = dist (count↺ f) (count↺ g) ≥ 2^(n ∸ k)

  ]-[-antisym : ∀ {n} (f : ⅁ n) → ¬ (f ]-[ f)
  ]-[-antisym {n} f f]-[g rewrite dist-refl (count↺ f) with ℕ≤.trans (2^ (n ∸ k) ≥1) f]-[g
  ... | ()

  ]-[-sym : ∀ {n} {f g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {n} {f} {g} f]-[g rewrite dist-sym (count↺ f) (count↺ g) = f]-[g

  ]-[-cong-left-≈↺ : ∀ {n} {f g h : ⅁ n} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {n} {f} {g} f≈g g]-[h rewrite ≈⅁⇒≈⅁′ {n} {f} {g} f≈g = g]-[h
  -- dist #g #h ≥ 2^(n ∸ k)
  -- dist #f #h ≥ 2^(n ∸ k)

module Implem k where
  _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
  _]-[_ {m} {n} f g = dist ⟨2^ n * count↺ f ⟩ ⟨2^ m * count↺ g ⟩ ≥ 2^((m + n) ∸ k)

  ]-[-antisym : ∀ {n} (f : ⅁ n) → ¬ (f ]-[ f)
  ]-[-antisym {n} f f]-[g rewrite dist-refl ⟨2^ n * count↺ f ⟩ with ℕ≤.trans (2^ (n + n ∸ k) ≥1) f]-[g
  ... | ()

  ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {m} {n} {f} {g} f]-[g rewrite dist-sym ⟨2^ n * count↺ f ⟩ ⟨2^ m * count↺ g ⟩ | ℕ°.+-comm m n = f]-[g

  postulate
      helper : ∀ m n o k → m + ((n + o) ∸ k) ≡ n + ((m + o) ∸ k)
      helper′ : ∀ m n o k → ⟨2^ m * (2^((n + o) ∸ k))⟩ ≡ ⟨2^ n * (2^((m + o) ∸ k))⟩

  ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} f≈g g]-[h
      with 2^*-mono m g]-[h
           -- 2ᵐ(dist 2ᵒ#g 2ⁿ#h) ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
  ... | q rewrite sym (dist-2^* m ⟨2^ o * count↺ g ⟩ ⟨2^ n * count↺ h ⟩)
           -- dist 2ᵐ2ᵒ#g 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm m o (count↺ g)
           -- dist 2ᵒ2ᵐ#g 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | sym f≈g
           -- dist 2ᵒ2ⁿ#f 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm o n (count↺ f)
           -- dist 2ⁿ2ᵒ#f 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm m n (count↺ h)
           -- dist 2ⁿ2ᵒ#f 2ⁿ2ᵐ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | dist-2^* n ⟨2^ o * count↺ f ⟩ ⟨2^ m * count↺ h ⟩
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-+ m (n + o ∸ k) 1
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ᵐ⁺ⁿ⁺ᵒ⁻ᵏ
                | helper m n o k
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ⁿ⁺ᵐ⁺ᵒ⁻ᵏ
                | sym (2^-+ n (m + o ∸ k) 1)
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ⁿ2ᵐ⁺ᵒ⁻ᵏ
                = 2^*-mono′ n q
           -- dist 2ᵒ#f 2ᵐ#h ≤ 2ᵐ⁺ᵒ⁻ᵏ

  prgDist : PrgDist
  prgDist = mk _]-[_
               ]-[-antisym
               (λ {m n f g} → ]-[-sym {f = f} {g})
               (λ {m n o f g h} → ]-[-cong-left-≈↺ {f = f} {g} {h})

module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count; countᶠ)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
    ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
    ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h

  ]-[-cong-right-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ]-[ g → g ≈⅁ h → f ]-[ h
  ]-[-cong-right-≈↺ pf pf' = ]-[-sym (]-[-cong-left-≈↺ (sym pf') (]-[-sym pf))

  ]-[-cong-≗↺ : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong-≗↺ {c} {c'} {f} {g} {f'} {g'} f≗g f'≗g' pf
     = ]-[-cong-left-≈↺ {f = g} {g = f} {h = g'}
         ((≗⇒≈⅁ (λ x → sym (f≗g x)))) (]-[-cong-right-≈↺ pf (≗⇒≈⅁ f'≗g'))

  breaks : ∀ {c} (EXP : Bit → ⅁ c) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ⅁ c₀) (⅁₁ : Bit → ⅁ c₁) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ⅁ c}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong-≗↺ (same-games 0b) (same-games 1b)

module HomImplem k where
  --  | Pr[ f ≡ 1 ] - Pr[ g ≡ 1 ] | ≥ ε            [ on reals ]
  --  dist Pr[ f ≡ 1 ] Pr[ g ≡ 1 ] ≥ ε             [ on reals ]
  --  dist (#1 f / 2^ c) (#1 g / 2^ c) ≥ ε          [ on reals ]
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c where ε = 2^ -k [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(-k) * 2^ c            [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c - k)                [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c ∸ k)               [ on natural ]
  _]-[_ : ∀ {n} (f g : ⅁ n) → Set
  _]-[_ {n} f g = dist (count↺ f) (count↺ g) ≥ 2^(n ∸ k)

  ]-[-sym : ∀ {n} {f g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {n} {f} {g} f]-[g rewrite dist-sym (count↺ f) (count↺ g) = f]-[g

  ]-[-cong-left-≈↺ : ∀ {n} {f g h : ⅁ n} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {n} {f} {g} f≈g g]-[h rewrite ≈⅁⇒≈⅁′ {n} {f} {g} f≈g = g]-[h
  -- dist #g #h ≥ 2^(n ∸ k)
  -- dist #f #h ≥ 2^(n ∸ k)

module Implem k where
  _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
  _]-[_ {m} {n} f g = dist (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) ≥ 2^((m + n) ∸ k)

  ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {m} {n} {f} {g} f]-[g rewrite dist-sym (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) | ℕ°.+-comm m n = f]-[g

  postulate
      helper : ∀ x y z t → x + ((y + z) ∸ t) ≡ y + ((x + z) ∸ t)

  ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} f≈g g]-[h
      with 2^*-mono m g]-[h
           -- 2ᵐ(dist 2ᵒ#g 2ⁿ#h) ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
  ... | q rewrite sym (dist-2^* m (⟨2^ o ⟩* (count↺ g)) (⟨2^ n ⟩* (count↺ h)))
           -- dist 2ᵐ2ᵒ#g 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm m o (count↺ g)
           -- dist 2ᵒ2ᵐ#g 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | sym f≈g
           -- dist 2ᵒ2ⁿ#f 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm o n (count↺ f)
           -- dist 2ⁿ2ᵒ#f 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm m n (count↺ h)
           -- dist 2ⁿ2ᵒ#f 2ⁿ2ᵐ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | dist-2^* n (⟨2^ o ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ h))
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-+ m (n + o ∸ k) 1
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ᵐ⁺ⁿ⁺ᵒ⁻ᵏ
                | helper m n o k
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ⁿ⁺ᵐ⁺ᵒ⁻ᵏ
                | sym (2^-+ n (m + o ∸ k) 1)
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ⁿ2ᵐ⁺ᵒ⁻ᵏ
                = 2^*-mono′ n q
           -- dist 2ᵒ#f 2ᵐ#h ≤ 2ᵐ⁺ᵒ⁻ᵏ

  prgDist : PrgDist
  prgDist = mk _]-[_ (λ {m n f g} x → ]-[-sym {m} {n} {f} {g} x) (λ {m n o f g h} x y → ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} x y)


Use HOAS-enabled helpers for nested abstractions.

Old-commit-hash: 4efbb3abc5e02e14285a2e9c6998ee6f663cbc2d

module Popl14.Change.Term where

-- Terms Calculus Popl14
--
-- Contents
-- - Term constructors
-- - Weakening on terms
-- - `fit`: weaken a term to its ΔContext
-- - diff-term, apply-term and their syntactic sugars

open import Data.Integer

open import Popl14.Syntax.Type public
open import Popl14.Syntax.Term public
open import Popl14.Change.Type public

import Parametric.Change.Term Const ΔBase as ChangeTerm

diff-base : ChangeTerm.DiffStructure
diff-base {base-int} = abs₂ (λ x y → add x (minus y))
diff-base {base-bag} = abs₂ (λ x y → union x (negate y))

apply-base : ChangeTerm.ApplyStructure
apply-base {base-int} = abs₂ (λ Δx x → add x Δx)
apply-base {base-bag} = abs₂ (λ Δx x → union x Δx)

diff-term  : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

-- Sugars for diff-term and apply-term
infixl 6 _⊕_ _⊝_
_⊕_ : ∀ {τ Γ} → Term Γ τ → Term Γ (ΔType τ) → Term Γ τ
_⊝_ : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (ΔType τ)
t ⊕ Δt = app (app apply-term Δt) t
s ⊝ t  = app (app  diff-term  s) t

apply-term {base ι} = apply-base {ι}
apply-term {σ ⇒ τ} =
    abs₃ (λ Δf f x →
      app f x ⊕ app (app Δf x) (x ⊝ x))

diff-term {base ι} = diff-base {ι}
diff-term {σ ⇒ τ} =
  abs₄ (λ g f x Δx →
    app g (x ⊕ Δx) ⊝ app f x)

module Popl14.Change.Term where

-- Terms Calculus Popl14
--
-- Contents
-- - Term constructors
-- - Weakening on terms
-- - `fit`: weaken a term to its ΔContext
-- - diff-term, apply-term and their syntactic sugars

open import Data.Integer

open import Popl14.Syntax.Type public
open import Popl14.Syntax.Term public
open import Popl14.Change.Type public

import Parametric.Change.Term Const ΔBase as ChangeTerm

diff-base : ChangeTerm.DiffStructure
diff-base {base-int} = abs₂ (λ x y → add x (minus y))
diff-base {base-bag} = abs₂ (λ x y → union x (negate y))

apply-base : ChangeTerm.ApplyStructure
apply-base {base-int} = abs₂ (λ Δx x → add x Δx)
apply-base {base-bag} = abs₂ (λ Δx x → union x Δx)

diff-term  : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

-- Sugars for diff-term and apply-term
infixl 6 _⊕_ _⊝_
_⊕_ : ∀ {τ Γ} → Term Γ τ → Term Γ (ΔType τ) → Term Γ τ
_⊝_ : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (ΔType τ)
t ⊕ Δt = app (app apply-term Δt) t
s ⊝ t  = app (app  diff-term  s) t

apply-term {base ι} = apply-base {ι}
apply-term {σ ⇒ τ} =
  let
    Δf = var (that (that this))
    f  = var (that this)
    x  = var this
  in
  -- Δf   f    x
    abs (abs (abs
      (app f x ⊕ app (app Δf x) (x ⊝ x))))

diff-term {base ι} = diff-base {ι}
diff-term {σ ⇒ τ} =
  let
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
  in
  -- g    f    x    Δx
    abs (abs (abs (abs
      (app g (x ⊕ Δx) ⊝ app f x))))


We are not using the induction principle for N.

Ignore-this: d4db0e016b44ac1278d071501fae50e2

darcs-hash:20100503135901-3bd4e-f27604c8ecc5865e2dfb311c3790883a9f9c24f0.gz

------------------------------------------------------------------------------
-- Inductive predicate for the total natural numbers
------------------------------------------------------------------------------

module LTC.Data.N where

open import LTC.Minimal

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

-- The inductive predicate 'N' represents the type of the natural
-- numbers. They are a subset of 'D'.

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)
-- {-# ATP hint zN #-}
-- {-# ATP hint sN #-}

-- Induction principle for N (elimination rule).
-- indN : (P : D → Set) →
--        P zero →
--        ({n : D} → N n → P n → P (succ n)) →
--        {n : D} → N n → P n
-- indN P p0 h zN      = p0
-- indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

-- -- Other version
-- indN : (P : {m : D} → N m → Set) →
--        P zN →
--        ({n : D} → (Nn : N n) → P Nn → P (sN Nn)) →
--        {n : D} → (Nn : N n) → P Nn
-- indN P p0 h zN      = p0
-- indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

------------------------------------------------------------------------------
-- Inductive predicate for the total natural numbers
------------------------------------------------------------------------------

module LTC.Data.N where

open import LTC.Minimal

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

-- The inductive predicate 'N' represents the type of the natural
-- numbers. They are a subset of 'D'.

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)
-- {-# ATP hint zN #-}
-- {-# ATP hint sN #-}

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)


Possibly useful dead code

Possibly useful dead code

{-# OPTIONS --allow-unsolved-metas #-}
module New.LangOps where

open import Data.List.All
open import Data.Unit
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Data.Integer

open import New.Lang
open import New.Changes
open import New.LangChanges

oplusτo : ∀ {Γ} τ → Term Γ (τ ⇒ Δt τ ⇒ τ)
ominusτo : ∀ {Γ} τ → Term Γ (τ ⇒ τ ⇒ Δt τ)

onilτo : ∀ {Γ} τ → Term Γ (τ ⇒ Δt τ)
onilτo τ = abs (app₂ (ominusτo τ) (var this) (var this))

oplusτo (σ ⇒ τ) = abs (abs (abs
  (app₂ (oplusτo τ)
    (app (var (that (that this))) (var this))
    (app₂ (var (that this)) (var this) (app (onilτo σ) (var this))))))
oplusτo int = const plus
oplusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (oplusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (oplusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
oplusτo (sum σ τ) = {!!}

ominusτo (σ ⇒ τ) = abs (abs (abs (abs (app₂ (ominusτo τ)
  (app (var (that (that (that this)))) (app₂ (oplusτo σ) (var (that this)) (var this)))
  (app (var (that (that this))) (var (that this)))))))
ominusτo int = const minus
ominusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (ominusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (ominusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
ominusτo (sum σ τ) = {!!}

open import Postulate.Extensionality

syntax oplusτo t a da = a ⊞[ t ] da

oplusτ : ∀ τ → ⟦ τ ⟧Type → ⟦ Δt τ ⟧Type → ⟦ τ ⟧Type

oplusτ τ = ⟦ oplusτo τ ⟧Term ∅
ominusτ : ∀ τ → ⟦ τ ⟧Type → ⟦ τ ⟧Type → ⟦ Δt τ ⟧Type
ominusτ τ = ⟦ ominusτo τ ⟧Term ∅

⟦oplusτ⟧ : ∀ τ → ⟦ τ ⟧Type → ⟦ Δt τ ⟧Type → ⟦ τ ⟧Type
⟦ominusτ⟧ : ∀ τ → ⟦ τ ⟧Type → ⟦ τ ⟧Type → ⟦ Δt τ ⟧Type
⟦oplusτ⟧ τ = _⊕_
⟦ominusτ⟧ τ = _⊝_

oplusτ-equiv : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ a da → ⟦ oplusτo τ ⟧Term ρ a da ≡ ⟦oplusτ⟧ τ a da
ominusτ-equiv : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ a da → ⟦ ominusτo τ ⟧Term ρ a da ≡ ⟦ominusτ⟧ τ a da

oplusτ-equiv-ext : ∀ τ → oplusτ τ ≡ ⟦oplusτ⟧ τ
oplusτ-equiv-ext τ = ext (λ a → ext (oplusτ-equiv ∅ ∅ τ a))
ominusτ-equiv-ext : ∀ τ → ominusτ τ ≡ ⟦ominusτ⟧ τ
ominusτ-equiv-ext τ = ext (λ a → ext (ominusτ-equiv ∅ ∅ τ a))

oplusτ-equiv Γ ρ (σ ⇒ τ) f df = ext (λ a → lemma a)
  where
    module _ (a : ⟦ σ ⟧Type) where
      ρ′ : ⟦ σ • Δt (σ ⇒ τ) • (σ ⇒ τ) • Γ ⟧Context
      ρ′ = a ∷ df ∷ f ∷ ρ
      ρ′′ = a ∷ ρ′
      lemma : ⟦ oplusτo τ ⟧Term ρ′ (f a)
         (df a (⟦ ominusτo σ ⟧Term ρ′′ a a))
         ≡ ⟦oplusτ⟧ τ (f a) (df a (⟦ominusτ⟧ σ a a))
      lemma
        rewrite ominusτ-equiv _ ρ′′ σ a a
        | oplusτ-equiv _ ρ′ τ (f a) (df a (⟦ominusτ⟧ σ a a))
        = refl
oplusτ-equiv Γ ρ int a da = refl
oplusτ-equiv Γ ρ (pair σ τ) (a , b) (da , db)
  rewrite oplusτ-equiv _ ((da , db) ∷ (a , b) ∷ ρ) σ a da
  | oplusτ-equiv _ ((da , db) ∷ (a , b) ∷ ρ) τ b db
  = refl
oplusτ-equiv Γ ρ (sum σ τ) s ds = {!!}

ominusτ-equiv Γ ρ (σ ⇒ τ) g f = ext (λ a → ext (lemma a))
  where
    module _ (a : ⟦ σ ⟧Type) (da : Cht σ) where
      ρ′ = da ∷ a ∷ f ∷ g ∷ ρ
      lemma : ⟦ ominusτo τ ⟧Term (da ∷ a ∷ f ∷ g ∷ ρ)
        (g (⟦ oplusτo σ ⟧Term (da ∷ a ∷ f ∷ g ∷ ρ) a da)) (f a)
        ≡ ⟦ominusτ⟧ τ (g (⟦oplusτ⟧ σ a da)) (f a)
      lemma
        rewrite oplusτ-equiv _ ρ′ σ a da
        | ominusτ-equiv _ ρ′ τ (g (⟦oplusτ⟧ σ a da)) (f a) = refl
ominusτ-equiv Γ ρ int b a = refl
ominusτ-equiv Γ ρ (pair σ τ) (a2 , b2) (a1 , b1)
  rewrite ominusτ-equiv _ ((a1 , b1) ∷ (a2 , b2) ∷ ρ) σ a2 a1
  | ominusτ-equiv _ ((a1 , b1) ∷ (a2 , b2) ∷ ρ) τ b2 b1
  = refl
ominusτ-equiv Γ ρ (sum σ τ) s2 s1 = {!!}

-- synIsChAlgτ : (τ : Type) → IsChAlg ⟦ τ ⟧Type ⟦ Δt τ ⟧Type (oplusτ τ) (ominusτ τ)

-- synChAlgt : (τ : Type) → ChAlg ⟦ τ ⟧Type
-- synChAlgt τ = record { Ch = Cht τ ; _⊕_ = oplusτ τ ; _⊝_ = ominusτ τ ; isChAlg = isChAlgτ τ}
-- private
--   instance
--     synIchAlgt : ∀ {τ} → ChAlg ⟦ τ ⟧Type
-- synIchAlgt {τ} = chAlgt τ

-- synIsChAlgτ τ rewrite oplusτ-equiv-ext τ | ominusτ-equiv-ext τ = ⟦isChAlgτ⟧ τ

-- oplusτo-invariant : ∀ τ {Γ₁ Γ₂} (ρ₁ : ⟦ Γ₁ ⟧Context) (ρ₂ : ⟦ Γ₂ ⟧Context) →
--   ⟦ oplusτo τ ⟧Term ρ₁ ≡ ⟦ oplusτo τ ⟧Term ρ₂
-- ominusτo-invariant : ∀ τ {Γ₁ Γ₂} (ρ₁ : ⟦ Γ₁ ⟧Context) (ρ₂ : ⟦ Γ₂ ⟧Context) →
--   ⟦ ominusτo τ ⟧Term ρ₁ ≡ ⟦ ominusτo τ ⟧Term ρ₂
-- ominusτo-invariant (σ ⇒ τ) ρ₁ ρ₂ = {!!}
-- ominusτo-invariant int ρ₁ ρ₂ = refl
-- ominusτo-invariant (pair σ τ) ρ₁ ρ₂ = {!!}
-- ominusτo-invariant (sum σ τ) ρ₁ ρ₂ = {!!}
-- oplusτo-invariant (σ ⇒ τ) ρ₁ ρ₂ = ext³ lemma
--   where
--     module _ (f : ⟦ σ ⇒ τ ⟧Type) (df : Cht (σ ⇒ τ)) (a : ⟦ σ ⟧Type) where
--       ρ₁′ = a ∷ df ∷ f ∷ ρ₁
--       ρ₁′′ = a ∷ ρ₁′
--       ρ₂′ = a ∷ df ∷ f ∷ ρ₂
--       ρ₂′′ = a ∷ ρ₂′
--       lemma : ⟦ oplusτo τ ⟧Term (a ∷ df ∷ f ∷ ρ₁) (f a)
--         (df a (⟦ ominusτo σ ⟧Term (a ∷ a ∷ df ∷ f ∷ ρ₁) a a))
--         ≡
--         ⟦ oplusτo τ ⟧Term (a ∷ df ∷ f ∷ ρ₂) (f a)
--         (df a (⟦ ominusτo σ ⟧Term (a ∷ a ∷ df ∷ f ∷ ρ₂) a a))
--       lemma  rewrite oplusτo-invariant τ ρ₁′ ρ₂′ | ominusτo-invariant σ ρ₁′′ ρ₂′′ = refl
-- oplusτo-invariant int ρ₁ ρ₂ = refl
-- oplusτo-invariant (pair σ τ) ρ₁ ρ₂ = ext (λ p → ext (lemma p))
--   where
--     module _ (p : ⟦ pair σ τ ⟧Type) (dp : Cht (pair σ τ)) where
--       ρ₁′ = dp ∷ p ∷ ρ₁
--       ρ₂′ = dp ∷ p ∷ ρ₂
--       lemma :
--         (⟦ oplusτo σ ⟧Term (dp ∷ p ∷ ρ₁) (proj₁ p) (proj₁ dp) ,
--          ⟦ oplusτo τ ⟧Term (dp ∷ p ∷ ρ₁) (proj₂ p) (proj₂ dp))
--         ≡
--         (⟦ oplusτo σ ⟧Term (dp ∷ p ∷ ρ₂) (proj₁ p) (proj₁ dp) ,
--          ⟦ oplusτo τ ⟧Term (dp ∷ p ∷ ρ₂) (proj₂ p) (proj₂ dp))
--       lemma rewrite oplusτo-invariant σ ρ₁′ ρ₂′ | oplusτo-invariant τ ρ₁′ ρ₂′ = refl
-- oplusτo-invariant (sum σ τ) ρ₁ ρ₂ = {!!}