Bits: remove/comment the broken stuff

Bits: remove/comment the broken stuff

module Data.Bits where

-- cleanup
import Level
open import Category.Applicative.NP
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; swap to vswap)
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.NP
import Data.List.NP as L

open import Data.Bool.NP public using (_xor_; not; true; false; if_then_else_)
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₁

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

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

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

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

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

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

_|∨|_ : ∀ {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

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∷_)

  searchBit : (Bit → A `1) → A (`2* `1)
  searchBit f = f 0b ∙ f 1b

  -- search-ext
  search-≗ : ∀ {n} (f g : Bits n → A `1) → f ≗ g → search f ≡ search g
  search-≗ {zero}  f g f≗g = f≗g []
  search-≗ {suc n} f g f≗g
    rewrite search-≗ (f ∘ 0∷_) (g ∘ 0∷_) (f≗g ∘ 0∷_)
          | search-≗ (f ∘ 1∷_) (g ∘ 1∷_) (f≗g ∘ 1∷_) = refl

  module Comm (∙-comm : ∀ {m} (x y : A m) → x ∙ y ≡ y ∙ x) where

    {- This pad bit vector allows to specify which bit do we negate in the vector. -}
    search-comm : ∀ {n} (pad : Bits n) (f : Bits n → A `1) → search f ≡ search (f ∘ _⊕_ pad)
    search-comm {zero} pad f = refl
    search-comm {suc n} (b ∷ pad) f
      rewrite search-comm pad (f ∘ 0∷_)
            | search-comm pad (f ∘ 1∷_)
      with b
    ... | true  = ∙-comm (search (f ∘ 0∷_ ∘ _⊕_ pad)) _
    ... | false = refl
  open Comm public

open Search 1 2*_ public using () renaming (search to search′; search-≗ to search′-≗; search-comm to search′-comm)

module OperationSyntax where
    infixr 1 _`⁏_
    data Op : Set where
      `id `0↔1 `not : Op
      `tl : Op → Op
      `if0 : Op → Op
      _`⁏_ : Op → Op → Op

    {-
       id   ε          id
       0↔1  swp-inners interchange
       not  swap       comm
       if0  first      ...
       if1  second     ...
     -}

    infixr 9 _∙_
    _∙_ : Op → ∀ {n} → Endo (Bits n)
    `id   ∙ xs       = xs
    `0↔1  ∙ xs       = 0↔1 xs
    `not  ∙ []       = []
    `not  ∙ (x ∷ xs) = not x ∷ xs
    `tl f ∙ []       = []
    `tl f ∙ (x ∷ xs) = x ∷ f ∙ xs
    `if0 f ∙ []           = []
    `if0 f ∙ (false ∷ xs) = false ∷ f ∙ xs
    `if0 f ∙ (true  ∷ xs) = true  ∷ xs
    (f `⁏ g) ∙ xs = g ∙ f ∙ xs

    `if1 : Op → Op
    `if1 f = `not `⁏ `if0 f `⁏ `not

    --   (a ∙ b) ∙ (c ∙ d)
    -- ≡ right swap
    --   (a ∙ b) ∙ (d ∙ c)
    -- ≡ interchange
    --   (a ∙ d) ∙ (b ∙ c)
    -- ≡ right swap
    --   (a ∙ d) ∙ (c ∙ b)
    swp-seconds : Op
    swp-seconds = `if1 `not `⁏ `0↔1 `⁏ `if1 `not

    on-extremes : Op → Op
    on-extremes f = swp-seconds `⁏ `if0 f `⁏ swp-seconds

    on-firsts : Op → Op
    on-firsts f = `0↔1 `⁏ `if0 f `⁏ `0↔1

    0↔1∷_ : ∀ {n} → Bits n → Op
    0↔1∷ [] = `not
    0↔1∷ (true {-1-} ∷ p) = on-extremes (0↔1∷ p)
    0↔1∷ (false{-0-} ∷ p) = on-firsts   (0↔1∷ p)

    0↔_ : ∀ {n} → Bits n → Op
    0↔ [] = `id
    0↔ (false{-0-} ∷ p) = `if0 (0↔ p)
    0↔ (true{-1-}  ∷ p) = 0↔1∷ p

    ⟨0↔_⟩-sem : ∀ {n} (p : Bits n) → Bits n → Bits n
    ⟨0↔ p ⟩-sem xs = if 0ⁿ == xs then p else if p == xs then 0ⁿ else xs

    if∷ : ∀ {n} a x (xs ys : Bits n) → (if a then (x ∷ xs) else (x ∷ ys)) ≡ x ∷ (if a then xs else ys)
    if∷ true x xs ys = refl
    if∷ false x xs ys = refl

    if-not∷ : ∀ {n} a (xs ys : Bits n) → (if a then (false ∷ xs) else (true ∷ ys)) ≡ (not a) ∷ (if a then xs else ys)
    if-not∷ true xs ys = refl
    if-not∷ false xs ys = refl

    if∷′ : ∀ {n} a (xs ys : Bits n) → (if a then (true ∷ xs) else (false ∷ ys)) ≡ a ∷ (if a then xs else ys)
    if∷′ true xs ys = refl
    if∷′ false xs ys = refl

    ⟨0↔1∷_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔1∷ p ∙ xs ≡ ⟨0↔ (1∷ p) ⟩-sem xs
    ⟨0↔1∷_⟩-spec [] (true ∷ []) = refl
    ⟨0↔1∷_⟩-spec [] (false ∷ []) = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (true ∷ true ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
         with ps == xs
    ... | true = refl
    ... | false = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (true ∷ false ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (false ∷ true ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (false ∷ false ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
         with 0ⁿ == xs
    ... | true = refl
    ... | false = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (true ∷ true ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (true ∷ false ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
         with ps == xs
    ... | true = refl
    ... | false = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (false ∷ true ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (false ∷ false ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
         with 0ⁿ == xs
    ... | true = refl
    ... | false = refl

    ⟨0↔_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔ p ∙ xs ≡ ⟨0↔ p ⟩-sem xs
    ⟨0↔_⟩-spec [] [] = refl
    ⟨0↔_⟩-spec (false ∷ ps) (true ∷ xs) = refl
    ⟨0↔_⟩-spec (false ∷ ps) (false ∷ xs)
       rewrite ⟨0↔ ps ⟩-spec xs
             | if∷ (ps == xs) 0b 0ⁿ xs
             | if∷ (0ⁿ == xs) 0b ps (if ps == xs then 0ⁿ else xs)
        = refl
    ⟨0↔_⟩-spec (true ∷ p) xs = ⟨0↔1∷ p ⟩-spec xs

    open PermutationSyntax using (Perm; `id; `0↔1; `tl; _`⁏_)
    module P = PermutationSemantics

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

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

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

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

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

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

    `xor-head : Bit → Op
    `xor-head b = if b then `not else `id

    `xor-head-spec : ∀ b {n} x (xs : Bits n) → `xor-head b ∙ (x ∷ xs) ≡ (b xor x) ∷ xs
    `xor-head-spec true x xs  = refl
    `xor-head-spec false x xs = refl

    `⟨_⊕⟩ : ∀ {n} → Bits n → Op
    `⟨ []     ⊕⟩ = `id
    `⟨ b ∷ xs ⊕⟩ = `xor-head b `⁏ `tl `⟨ xs ⊕⟩

    `⟨_⊕⟩-spec : ∀ {n} (xs ys : Bits n) → `⟨ xs ⊕⟩ ∙ ys ≡ xs ⊕ ys
    `⟨ []         ⊕⟩-spec []       = refl
    `⟨ true  ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl
    `⟨ false ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl

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

module PermutationSyntax-Props where
    open PermutationSyntax
    open PermutationSemantics
    open PermutationProperties

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

    {-
 -- ⊛-dist-∙ : ∀ {n a} {A : Set a} (fs : Vec (A → A) n) π xs → π ∙ fs ⊛ π ∙ xs ≡ π ∙ (fs ⊛ xs)
    ⊕-dist-∙ : ∀ {n} (pad : Bits n) π xs → π ∙ pad ⊕ π ∙ xs ≡ π ∙ (pad ⊕ xs)
    ⊕-dist-∙ pad π xs = π ∙ pad ⊕ π ∙ xs
                      ≡⟨ refl ⟩
                        vmap _xor_ (π ∙ pad) ⊛ π ∙ xs
                      ≡⟨ {!!} ⟩
                        π ∙ vmap _xor_ pad ⊛ π ∙ xs
                      ≡⟨ ⊛-dist-∙ _ (vmap _xor_ pad) π xs ⟩
                        π ∙ (vmap _xor_ pad ⊛ xs)
                      ≡⟨ refl ⟩
                        π ∙ (pad ⊕ xs)
                      ∎ where open ≡-Reasoning
     -- rans {!⊛-dist-∙ (vmap _xor_ (op ∙ pad)) op xs!} (⊛-dist-∙ (vmap _xor_ pad) op xs)
-}
module SimpleSearch {a} {A : Set a} (_∙_ : A → A → A) where

    open Search 1 2*_ {A = const A} _∙_ public

    search-constε≡ε : ∀ ε (ε∙ε : ε ∙ ε ≡ ε) n → search {n = n} (const ε) ≡ ε
    search-constε≡ε ε ε∙ε = go
      where
        go : ∀ n → search {n = n} (const ε) ≡ ε
        go zero = refl
        go (suc n) rewrite go n = ε∙ε

    searchBit-search : ∀ n (f : Bits (suc n) → A) → searchBit (λ b → search (f ∘ _∷_ b)) ≡ search f
    searchBit-search n f = refl

    search-≗₂ : ∀ {m n} (f g : Bits m → Bits n → A) → f ≗₂ g
                  → search (search ∘ f) ≡ search (search ∘ g)
    search-≗₂ f g f≗g = search-≗ (search ∘ f) (search ∘ g) (λ xs →
                          search-≗ (f xs) (g xs) (λ ys →
                            f≗g xs ys))

    search-+ : ∀ {m n} (f : Bits (m + n) → A) →
                 search {m + n} f
               ≡ search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
    search-+ {zero} f = refl
    search-+ {suc m} f rewrite search-+ {m} (f ∘ 0∷_)
                             | search-+ {m} (f ∘ 1∷_) = refl

    module SearchInterchange (∙-interchange : Interchange _≡_ _∙_ _∙_) where

        search-dist : ∀ {n} (f₀ f₁ : Bits n → A) → search (λ x → f₀ x ∙ f₁ x) ≡ search f₀ ∙ search f₁
        search-dist {zero}  _ _ = refl
        search-dist {suc n} f₀ f₁
          rewrite search-dist (f₀ ∘ 0∷_) (f₁ ∘ 0∷_)
                | search-dist (f₀ ∘ 1∷_) (f₁ ∘ 1∷_)
                = ∙-interchange _ _ _ _

        search-searchBit : ∀ {n} (f : Bits (suc n) → A) →
                             search (λ xs → searchBit (λ b → f (b ∷ xs))) ≡ search f
        search-searchBit f = search-dist (f ∘ 0∷_) (f ∘ 1∷_)

        search-search : ∀ {m n} (f : Bits (m + n) → A) →
                          search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                        ≡ search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
        search-search {zero} f = refl
        search-search {suc m} {n} f
          rewrite search-search {m} {n} (f ∘ 0∷_)
                | search-search {m} {n} (f ∘ 1∷_)
                | search-searchBit {n} (λ { (b ∷ ys) → search {m} (λ xs → f (b ∷ xs ++ ys)) })
                = refl
        {- -- It might also be done by using search-dist twice and commutativity of addition.
           -- However, this also affect 'f' and makes this proof actually longer.
           search-search {m} {n} f =
                             search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                           ≡⟨ {!!} ⟩
                             search {m + n} f
                           ≡⟨ {!!} ⟩
                             search {n + m} (f ∘ vswap n)
                           ≡⟨ {!!} ⟩
                             search {n} (λ ys → search {m} (λ xs → f (vswap n (ys ++ xs))))
                           ≡⟨ {!!} ⟩
                             search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
                           ∎
                           where open ≡-Reasoning
         -}

        search-swap : ∀ {m n} (f : Bits (m + n) → A) → search {n + m} (f ∘ vswap n) ≡ search {m + n} f
        search-swap {m} {n} f =
                     search {n + m} (f ∘ vswap n)
                   ≡⟨ search-+ {n} {m} (f ∘ vswap n) ⟩
                     search {n} (λ ys → search {m} (λ xs → f (vswap n (ys ++ xs))))
                   ≡⟨ search-≗₂ {n} {m}
                                (λ ys → f ∘ vswap n ∘ _++_ ys)
                                (λ ys → f ∘ flip _++_ ys)
                                (λ ys xs → cong f (swap-++ n ys xs)) ⟩
                     search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
                   ≡⟨ sym (search-search {m} {n} f) ⟩
                     search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                   ≡⟨ sym (search-+ {m} {n} f) ⟩
                     search {m + n} f
                   ∎
                        where open ≡-Reasoning

        search-0↔1 : ∀ {n} (f : Bits n → A) → search {n} (f ∘ 0↔1) ≡ search {n} f
        search-0↔1 {zero}        _ = refl
        search-0↔1 {suc zero}    _ = refl
        search-0↔1 {suc (suc n)} _ = ∙-interchange _ _ _ _

    module Op (∙-comm : Commutative _≡_ _∙_)
              (∙-interchange : Interchange _≡_ _∙_ _∙_) where
        open SearchInterchange ∙-interchange using (search-0↔1)
        open OperationSyntax renaming (_∙_ to op)
        search-op : ∀ {n} (f : Bits n → A) (g : Op) → search {n} (f ∘ op g) ≡ search {n} f
        search-op f `id = refl
        search-op f `0↔1 = search-0↔1 f
        search-op {zero} f `not = refl
        search-op {suc n} f `not = ∙-comm _ _
        search-op {zero} f (`tl g) = refl
        search-op {suc n} f (`tl g) rewrite search-op (f ∘ 0∷_) g | search-op (f ∘ 1∷_) g = refl
        search-op {zero} f (`if0 g) = refl
        search-op {suc n} f (`if0 g) rewrite search-op (f ∘ 0∷_) g = refl
        search-op f (g `⁏ h) rewrite search-op (f ∘ op h) g = search-op f h

module Sum where
    open SimpleSearch _+_ using (module Comm; module SearchInterchange; search-constε≡ε; module Op)
    open SimpleSearch _+_ public using () renaming (search to sum; search-≗ to sum-≗; searchBit to sumBit;
                                                    search-≗₂ to sum-≗₂;
                                                    search-+ to sum-+)
    open Comm ℕ°.+-comm public renaming (search-comm to sum-comm)
    open SearchInterchange +-interchange public renaming (
        search-dist to sum-dist;
        search-searchBit to sum-sumBit;
        search-search to sum-sum;
        search-swap to sum-swap)
    open Op ℕ°.+-comm +-interchange public renaming (search-op to sum-op)

    sum-const0≡0 : ∀ n → sum {n = n} (const 0) ≡ 0
    sum-const0≡0 n = search-constε≡ε 0 refl n

    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) → Fin (suc (2^ n))
#⟨ pred ⟩ᶠ = countᶠ pred (allBits _)

module Count where
    open Sum
    open OperationSyntax renaming (_∙_ to op)

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

    -- #-ext
    #-≗ : ∀ {n} (f g : Bits n → Bool) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
    #-≗ f g f≗g = sum-≗ (Bool.toℕ ∘ f) (Bool.toℕ ∘ g) (λ x → ≡.cong Bool.toℕ (f≗g x))

    #-comm : ∀ {n} (pad : Bits n) (f : Bits n → Bool) → #⟨ f ⟩ ≡ #⟨ f ∘ _⊕_ pad ⟩
    #-comm pad f = sum-comm pad (Bool.toℕ ∘ f)

    #-op : ∀ {n} (f : Bits n → Bit) (g : Op) → #⟨ f ∘ op g ⟩ ≡ #⟨ f ⟩
    #-op f = sum-op (Bool.toℕ ∘ f)

    #-⊕ : ∀ {c} (bs : Bits c) (f : Bits c → Bit) → #⟨ f ⟩ ≡ #⟨ f ∘ _⊕_ bs ⟩
    #-⊕ = #-comm

    #-const : ∀ n b → #⟨ (λ (_ : Bits n) → b) ⟩ ≡ ⟨2^ n * Bool.toℕ b ⟩
    #-const n b = sum-const n (Bool.toℕ b)

    #never≡0 : ∀ n → #⟨ never n ⟩ ≡ 0
    #never≡0 = sum-const0≡0

    #always≡2^_ : ∀ n → #⟨ always n ⟩ ≡ 2^ n
    #always≡2^ n = sum-const n 1

    #-dist : ∀ {n} (f₀ f₁ : Bits n → Bit) → sum (λ x → Bool.toℕ (f₀ x) + Bool.toℕ (f₁ x)) ≡ #⟨ f₀ ⟩ + #⟨ f₁ ⟩
    #-dist f₀ f₁ = sum-dist (Bool.toℕ ∘ f₀) (Bool.toℕ ∘ f₁)

    #-+ : ∀ {m n} (f : Bits (m + n) → Bit) →
                     #⟨ f ⟩ ≡ sum {m} (λ xs → #⟨ (λ ys → f (xs ++ ys)) ⟩ )
    #-+ {m} {n} f = sum-+ {m} {n} (Bool.toℕ ∘ f)

    #-# : ∀ {m n} (f : Bits (m + n) → Bit) →
                          sum {m} (λ xs → #⟨ (λ ys → f (xs ++ ys)) ⟩)
                        ≡ sum {n} (λ ys → #⟨ (λ (xs : Bits m) → f (xs ++ ys)) ⟩)
    #-# {m} {n} f = sum-sum {m} {n} (Bool.toℕ ∘ f)

    #-swap : ∀ {m n} (f : Bits (m + n) → Bit) → #⟨ f ∘ vswap n {m} ⟩ ≡ #⟨ f ⟩
    #-swap {m} {n} f = sum-swap {m} {n} (Bool.toℕ ∘ f)

    #⟨==_⟩ : ∀ {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-# : ∀ {n} (f g : Bits n → Bit) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
    ≗-cong-# f g f≗g = sum-≗ _ _ (cong Bool.toℕ ∘ 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-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
      rewrite ≗-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
            | ≗-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 → Bool.toℕ (x ∧ y) + Bool.toℕ (x ∨ y) ≡ Bool.toℕ x + Bool.toℕ y
    #-∧-∨ᵇ true y rewrite ℕ°.+-comm (Bool.toℕ 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∷_)

    #-∘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∷_))

    #-not∘′ : ∀ c (f : Bits c → Bit) → #⟨ not ∘ f ⟩ ≡ 2^ c ∸ #⟨ f ⟩
    #-not∘′ c f = #⟨ not ∘ f ⟩
               ≡⟨ #-not∘ c (not ∘ f) ⟩
                 2^ c ∸ #⟨ not ∘ not ∘ f ⟩
               ≡⟨ ≡.cong (λ g → 2^ c ∸ g) (≗-cong-# (not ∘ not ∘ f) f (not-involutive ∘ f)) ⟩
                 2^ c ∸ #⟨ f ⟩
               ∎
      where open ≡-Reasoning

open SimpleSearch public
open Sum public
open Count public

#⟨⟩-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)

|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 = search-≗ op _ _ (|de-morgan| f g)

search-hom :
  ∀ {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-hom {zero}  _   _   _ _ _   = refl
search-hom {suc n} _+_ _*_ f p hom =
   trans (hom _ _)
         (cong₂ _*_ (search-hom _+_ _*_ f (p ∘ 0∷_) hom)
                    (search-hom _+_ _*_ f (p ∘ 1∷_) hom))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Defs public

module Data.Bits where

-- cleanup
import Level
open import Category.Applicative.NP
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; swap to vswap)
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.NP
import Data.List.NP as L

open import Data.Bool.NP public using (_xor_; not; true; false; if_then_else_)
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₁

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

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

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

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

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

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

_|∨|_ : ∀ {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

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∷_)

  searchBit : (Bit → A `1) → A (`2* `1)
  searchBit f = f 0b ∙ f 1b

  -- search-ext
  search-≗ : ∀ {n} (f g : Bits n → A `1) → f ≗ g → search f ≡ search g
  search-≗ {zero}  f g f≗g = f≗g []
  search-≗ {suc n} f g f≗g
    rewrite search-≗ (f ∘ 0∷_) (g ∘ 0∷_) (f≗g ∘ 0∷_)
          | search-≗ (f ∘ 1∷_) (g ∘ 1∷_) (f≗g ∘ 1∷_) = refl

  module Comm (∙-comm : ∀ {m} (x y : A m) → x ∙ y ≡ y ∙ x) where

    {- This pad bit vector allows to specify which bit do we negate in the vector. -}
    search-comm : ∀ {n} (pad : Bits n) (f : Bits n → A `1) → search f ≡ search (f ∘ _⊕_ pad)
    search-comm {zero} pad f = refl
    search-comm {suc n} (b ∷ pad) f
      rewrite search-comm pad (f ∘ 0∷_)
            | search-comm pad (f ∘ 1∷_)
      with b
    ... | true  = ∙-comm (search (f ∘ 0∷_ ∘ _⊕_ pad)) _
    ... | false = refl
  open Comm public

open Search 1 2*_ public using () renaming (search to search′; search-≗ to search′-≗; search-comm to search′-comm)

module OperationSyntax where
    infixr 1 _`⁏_
    data Op : Set where
      `id `0↔1 `not : Op
      `tl : Op → Op
      `if0 : Op → Op
      _`⁏_ : Op → Op → Op

    {-
       id   ε          id
       0↔1  swp-inners interchange
       not  swap       comm
       if0  first      ...
       if1  second     ...
     -}

    infixr 9 _∙_
    _∙_ : Op → ∀ {n} → Endo (Bits n)
    `id   ∙ xs       = xs
    `0↔1  ∙ xs       = 0↔1 xs
    `not  ∙ []       = []
    `not  ∙ (x ∷ xs) = not x ∷ xs
    `tl f ∙ []       = []
    `tl f ∙ (x ∷ xs) = x ∷ f ∙ xs
    `if0 f ∙ []           = []
    `if0 f ∙ (false ∷ xs) = false ∷ f ∙ xs
    `if0 f ∙ (true  ∷ xs) = true  ∷ xs
    (f `⁏ g) ∙ xs = g ∙ f ∙ xs

    `if1 : Op → Op
    `if1 f = `not `⁏ `if0 f `⁏ `not

    --   (a ∙ b) ∙ (c ∙ d)
    -- ≡ right swap
    --   (a ∙ b) ∙ (d ∙ c)
    -- ≡ interchange
    --   (a ∙ d) ∙ (b ∙ c)
    -- ≡ right swap
    --   (a ∙ d) ∙ (c ∙ b)
    swp-seconds : Op
    swp-seconds = `if1 `not `⁏ `0↔1 `⁏ `if1 `not

    on-extremes : Op → Op
    on-extremes f = swp-seconds `⁏ `if0 f `⁏ swp-seconds

    on-firsts : Op → Op
    on-firsts f = `0↔1 `⁏ `if0 f `⁏ `0↔1

    0↔1∷_ : ∀ {n} → Bits n → Op
    0↔1∷ [] = `not
    0↔1∷ (true {-1-} ∷ p) = on-extremes (0↔1∷ p)
    0↔1∷ (false{-0-} ∷ p) = on-firsts   (0↔1∷ p)

    0↔_ : ∀ {n} → Bits n → Op
    0↔ [] = `id
    0↔ (false{-0-} ∷ p) = `if0 (0↔ p)
    0↔ (true{-1-}  ∷ p) = 0↔1∷ p

    ⟨0↔_⟩-sem : ∀ {n} (p : Bits n) → Bits n → Bits n
    ⟨0↔ p ⟩-sem xs = if 0ⁿ == xs then p else if p == xs then 0ⁿ else xs

    if∷ : ∀ {n} a x (xs ys : Bits n) → (if a then (x ∷ xs) else (x ∷ ys)) ≡ x ∷ (if a then xs else ys)
    if∷ true x xs ys = refl
    if∷ false x xs ys = refl

    if-not∷ : ∀ {n} a (xs ys : Bits n) → (if a then (false ∷ xs) else (true ∷ ys)) ≡ (not a) ∷ (if a then xs else ys)
    if-not∷ true xs ys = refl
    if-not∷ false xs ys = refl

    if∷′ : ∀ {n} a (xs ys : Bits n) → (if a then (true ∷ xs) else (false ∷ ys)) ≡ a ∷ (if a then xs else ys)
    if∷′ true xs ys = refl
    if∷′ false xs ys = refl

    ⟨0↔1∷_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔1∷ p ∙ xs ≡ ⟨0↔ (1∷ p) ⟩-sem xs
    ⟨0↔1∷_⟩-spec [] (true ∷ []) = refl
    ⟨0↔1∷_⟩-spec [] (false ∷ []) = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (true ∷ true ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
         with ps == xs
    ... | true = refl
    ... | false = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (true ∷ false ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (false ∷ true ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (true ∷ ps) (false ∷ false ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
         with 0ⁿ == xs
    ... | true = refl
    ... | false = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (true ∷ true ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (true ∷ false ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
         with ps == xs
    ... | true = refl
    ... | false = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (false ∷ true ∷ xs) = refl
    ⟨0↔1∷_⟩-spec (false ∷ ps) (false ∷ false ∷ xs)
       rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
         with 0ⁿ == xs
    ... | true = refl
    ... | false = refl

    ⟨0↔_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔ p ∙ xs ≡ ⟨0↔ p ⟩-sem xs
    ⟨0↔_⟩-spec [] [] = refl
    ⟨0↔_⟩-spec (false ∷ ps) (true ∷ xs) = refl
    ⟨0↔_⟩-spec (false ∷ ps) (false ∷ xs)
       rewrite ⟨0↔ ps ⟩-spec xs
             | if∷ (ps == xs) 0b 0ⁿ xs
             | if∷ (0ⁿ == xs) 0b ps (if ps == xs then 0ⁿ else xs)
        = refl
    ⟨0↔_⟩-spec (true ∷ p) xs = ⟨0↔1∷ p ⟩-spec xs

    open PermutationSyntax using (Perm; `id; `0↔1; `tl; _`⁏_)
    module P = PermutationSemantics

    toPerm : Op → Perm
    toPerm `id     = `id
    toPerm `0↔1    = `0↔1
    toPerm `not    = `id -- Important
    toPerm (`tl f) = `tl (toPerm f)
    toPerm (f `⁏ g) = toPerm f `⁏ toPerm g

    infixr 9 _∙′_
    _∙′_ : Op → ∀ {n} → Endo (Bits n)
    f ∙′ xs = toPerm f P.∙ xs

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

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

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

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

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

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

    `xor-head : Bit → Op
    `xor-head b = if b then `not else `id

    `xor-head-spec : ∀ b {n} x (xs : Bits n) → `xor-head b ∙ (x ∷ xs) ≡ (b xor x) ∷ xs
    `xor-head-spec true x xs  = refl
    `xor-head-spec false x xs = refl

    `⟨_⊕⟩ : ∀ {n} → Bits n → Op
    `⟨ []     ⊕⟩ = `id
    `⟨ b ∷ xs ⊕⟩ = `xor-head b `⁏ `tl `⟨ xs ⊕⟩

    `⟨_⊕⟩-spec : ∀ {n} (xs ys : Bits n) → `⟨ xs ⊕⟩ ∙ ys ≡ xs ⊕ ys
    `⟨ []         ⊕⟩-spec []       = refl
    `⟨ true  ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl
    `⟨ false ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl

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

    almost-⊕-dist-∙ : ∀ {n} (pad : Bits n) f xs → f ∙′ pad ⊕ f ∙ xs ≡ f ∙ (pad ⊕ xs)
    almost-⊕-dist-∙ pad           `id     xs = refl
    almost-⊕-dist-∙ pad           `0↔1    xs = ⊕-dist-0↔1 pad xs
    almost-⊕-dist-∙ []            `not    [] = refl
    almost-⊕-dist-∙ (true  ∷ pad) `not    (x ∷ xs) = refl
    almost-⊕-dist-∙ (false ∷ pad) `not    (x ∷ xs) = refl
    almost-⊕-dist-∙ []            (`tl f) [] = refl
    almost-⊕-dist-∙ (p ∷ pad)     (`tl f) (x ∷ xs) rewrite almost-⊕-dist-∙ pad f xs = refl
    almost-⊕-dist-∙ pad           (f `⁏ g) xs rewrite almost-⊕-dist-∙ (f ∙′ pad) g (f ∙ xs)
                                                   | almost-⊕-dist-∙ pad f xs = refl

module PermutationSyntax-Props where
    open PermutationSyntax
    open PermutationSemantics
    open PermutationProperties

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

 -- ⊛-dist-∙ : ∀ {n a} {A : Set a} (fs : Vec (A → A) n) π xs → π ∙ fs ⊛ π ∙ xs ≡ π ∙ (fs ⊛ xs)
    ⊕-dist-∙ : ∀ {n} (pad : Bits n) π xs → π ∙ pad ⊕ π ∙ xs ≡ π ∙ (pad ⊕ xs)
    ⊕-dist-∙ pad π xs = π ∙ pad ⊕ π ∙ xs
                      ≡⟨ refl ⟩
                        vmap _xor_ (π ∙ pad) ⊛ π ∙ xs
                      ≡⟨ {!!} ⟩
                        π ∙ vmap _xor_ pad ⊛ π ∙ xs
                      ≡⟨ ⊛-dist-∙ _ (vmap _xor_ pad) π xs ⟩
                        π ∙ (vmap _xor_ pad ⊛ xs)
                      ≡⟨ refl ⟩
                        π ∙ (pad ⊕ xs)
                      ∎ where open ≡-Reasoning
     -- rans {!⊛-dist-∙ (vmap _xor_ (op ∙ pad)) op xs!} (⊛-dist-∙ (vmap _xor_ pad) op xs)

module SimpleSearch {a} {A : Set a} (_∙_ : A → A → A) where

    open Search 1 2*_ {A = const A} _∙_ public

    search-constε≡ε : ∀ ε (ε∙ε : ε ∙ ε ≡ ε) n → search {n = n} (const ε) ≡ ε
    search-constε≡ε ε ε∙ε = go
      where
        go : ∀ n → search {n = n} (const ε) ≡ ε
        go zero = refl
        go (suc n) rewrite go n = ε∙ε

    searchBit-search : ∀ n (f : Bits (suc n) → A) → searchBit (λ b → search (f ∘ _∷_ b)) ≡ search f
    searchBit-search n f = refl

    search-≗₂ : ∀ {m n} (f g : Bits m → Bits n → A) → f ≗₂ g
                  → search (search ∘ f) ≡ search (search ∘ g)
    search-≗₂ f g f≗g = search-≗ (search ∘ f) (search ∘ g) (λ xs →
                          search-≗ (f xs) (g xs) (λ ys →
                            f≗g xs ys))

    search-+ : ∀ {m n} (f : Bits (m + n) → A) →
                 search {m + n} f
               ≡ search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
    search-+ {zero} f = refl
    search-+ {suc m} f rewrite search-+ {m} (f ∘ 0∷_)
                             | search-+ {m} (f ∘ 1∷_) = refl

    module SearchInterchange (∙-interchange : Interchange _≡_ _∙_ _∙_) where

        search-dist : ∀ {n} (f₀ f₁ : Bits n → A) → search (λ x → f₀ x ∙ f₁ x) ≡ search f₀ ∙ search f₁
        search-dist {zero}  _ _ = refl
        search-dist {suc n} f₀ f₁
          rewrite search-dist (f₀ ∘ 0∷_) (f₁ ∘ 0∷_)
                | search-dist (f₀ ∘ 1∷_) (f₁ ∘ 1∷_)
                = ∙-interchange _ _ _ _

        search-searchBit : ∀ {n} (f : Bits (suc n) → A) →
                             search (λ xs → searchBit (λ b → f (b ∷ xs))) ≡ search f
        search-searchBit f = search-dist (f ∘ 0∷_) (f ∘ 1∷_)

        search-search : ∀ {m n} (f : Bits (m + n) → A) →
                          search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                        ≡ search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
        search-search {zero} f = refl
        search-search {suc m} {n} f
          rewrite search-search {m} {n} (f ∘ 0∷_)
                | search-search {m} {n} (f ∘ 1∷_)
                | search-searchBit {n} (λ { (b ∷ ys) → search {m} (λ xs → f (b ∷ xs ++ ys)) })
                = refl
        {- -- It might also be done by using search-dist twice and commutativity of addition.
           -- However, this also affect 'f' and makes this proof actually longer.
           search-search {m} {n} f =
                             search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                           ≡⟨ {!!} ⟩
                             search {m + n} f
                           ≡⟨ {!!} ⟩
                             search {n + m} (f ∘ vswap n)
                           ≡⟨ {!!} ⟩
                             search {n} (λ ys → search {m} (λ xs → f (vswap n (ys ++ xs))))
                           ≡⟨ {!!} ⟩
                             search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
                           ∎
                           where open ≡-Reasoning
         -}

        search-swap : ∀ {m n} (f : Bits (m + n) → A) → search {n + m} (f ∘ vswap n) ≡ search {m + n} f
        search-swap {m} {n} f =
                     search {n + m} (f ∘ vswap n)
                   ≡⟨ search-+ {n} {m} (f ∘ vswap n) ⟩
                     search {n} (λ ys → search {m} (λ xs → f (vswap n (ys ++ xs))))
                   ≡⟨ search-≗₂ {n} {m}
                                (λ ys → f ∘ vswap n ∘ _++_ ys)
                                (λ ys → f ∘ flip _++_ ys)
                                (λ ys xs → cong f (swap-++ n ys xs)) ⟩
                     search {n} (λ ys → search {m} (λ xs → f (xs ++ ys)))
                   ≡⟨ sym (search-search {m} {n} f) ⟩
                     search {m} (λ xs → search {n} (λ ys → f (xs ++ ys)))
                   ≡⟨ sym (search-+ {m} {n} f) ⟩
                     search {m + n} f
                   ∎
                        where open ≡-Reasoning

        search-0↔1 : ∀ {n} (f : Bits n → A) → search {n} (f ∘ 0↔1) ≡ search {n} f
        search-0↔1 {zero}        _ = refl
        search-0↔1 {suc zero}    _ = refl
        search-0↔1 {suc (suc n)} _ = ∙-interchange _ _ _ _

    module Op (∙-comm : Commutative _≡_ _∙_)
              (∙-interchange : Interchange _≡_ _∙_ _∙_) where
        open SearchInterchange ∙-interchange using (search-0↔1)
        open OperationSyntax renaming (_∙_ to op)
        search-op : ∀ {n} (f : Bits n → A) (g : Op) → search {n} (f ∘ op g) ≡ search {n} f
        search-op f `id = refl
        search-op f `0↔1 = search-0↔1 f
        search-op {zero} f `not = refl
        search-op {suc n} f `not = ∙-comm _ _
        search-op {zero} f (`tl g) = refl
        search-op {suc n} f (`tl g) rewrite search-op (f ∘ 0∷_) g | search-op (f ∘ 1∷_) g = refl
        search-op {zero} f (`if0 g) = refl
        search-op {suc n} f (`if0 g) rewrite search-op (f ∘ 0∷_) g = refl
        search-op f (g `⁏ h) rewrite search-op (f ∘ op h) g = search-op f h

module Sum where
    open SimpleSearch _+_ using (module Comm; module SearchInterchange; search-constε≡ε; module Op)
    open SimpleSearch _+_ public using () renaming (search to sum; search-≗ to sum-≗; searchBit to sumBit;
                                                    search-≗₂ to sum-≗₂;
                                                    search-+ to sum-+)
    open Comm ℕ°.+-comm public renaming (search-comm to sum-comm)
    open SearchInterchange +-interchange public renaming (
        search-dist to sum-dist;
        search-searchBit to sum-sumBit;
        search-search to sum-sum;
        search-swap to sum-swap)
    open Op ℕ°.+-comm +-interchange public renaming (search-op to sum-op)

    sum-const0≡0 : ∀ n → sum {n = n} (const 0) ≡ 0
    sum-const0≡0 n = search-constε≡ε 0 refl n

    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) → Fin (suc (2^ n))
#⟨ pred ⟩ᶠ = countᶠ pred (allBits _)

module Count where
    open Sum
    open OperationSyntax renaming (_∙_ to op)

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

    -- #-ext
    #-≗ : ∀ {n} (f g : Bits n → Bool) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
    #-≗ f g f≗g = sum-≗ (Bool.toℕ ∘ f) (Bool.toℕ ∘ g) (λ x → ≡.cong Bool.toℕ (f≗g x))

    #-comm : ∀ {n} (pad : Bits n) (f : Bits n → Bool) → #⟨ f ⟩ ≡ #⟨ f ∘ _⊕_ pad ⟩
    #-comm pad f = sum-comm pad (Bool.toℕ ∘ f)

    #-op : ∀ {n} (f : Bits n → Bit) (g : Op) → #⟨ f ∘ op g ⟩ ≡ #⟨ f ⟩
    #-op f = sum-op (Bool.toℕ ∘ f)

    #-⊕ : ∀ {c} (bs : Bits c) (f : Bits c → Bit) → #⟨ f ⟩ ≡ #⟨ f ∘ _⊕_ bs ⟩
    #-⊕ = #-comm

    #-const : ∀ n b → #⟨ (λ (_ : Bits n) → b) ⟩ ≡ ⟨2^ n * Bool.toℕ b ⟩
    #-const n b = sum-const n (Bool.toℕ b)

    #never≡0 : ∀ n → #⟨ never n ⟩ ≡ 0
    #never≡0 = sum-const0≡0

    #always≡2^_ : ∀ n → #⟨ always n ⟩ ≡ 2^ n
    #always≡2^ n = sum-const n 1

    #-dist : ∀ {n} (f₀ f₁ : Bits n → Bit) → sum (λ x → Bool.toℕ (f₀ x) + Bool.toℕ (f₁ x)) ≡ #⟨ f₀ ⟩ + #⟨ f₁ ⟩
    #-dist f₀ f₁ = sum-dist (Bool.toℕ ∘ f₀) (Bool.toℕ ∘ f₁)

    #-+ : ∀ {m n} (f : Bits (m + n) → Bit) →
                     #⟨ f ⟩ ≡ sum {m} (λ xs → #⟨ (λ ys → f (xs ++ ys)) ⟩ )
    #-+ {m} {n} f = sum-+ {m} {n} (Bool.toℕ ∘ f)

    #-# : ∀ {m n} (f : Bits (m + n) → Bit) →
                          sum {m} (λ xs → #⟨ (λ ys → f (xs ++ ys)) ⟩)
                        ≡ sum {n} (λ ys → #⟨ (λ (xs : Bits m) → f (xs ++ ys)) ⟩)
    #-# {m} {n} f = sum-sum {m} {n} (Bool.toℕ ∘ f)

    #-swap : ∀ {m n} (f : Bits (m + n) → Bit) → #⟨ f ∘ vswap n {m} ⟩ ≡ #⟨ f ⟩
    #-swap {m} {n} f = sum-swap {m} {n} (Bool.toℕ ∘ f)

    #⟨==_⟩ : ∀ {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-# : ∀ {n} (f g : Bits n → Bit) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
    ≗-cong-# f g f≗g = sum-≗ _ _ (cong Bool.toℕ ∘ 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-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
      rewrite ≗-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
            | ≗-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 → Bool.toℕ (x ∧ y) + Bool.toℕ (x ∨ y) ≡ Bool.toℕ x + Bool.toℕ y
    #-∧-∨ᵇ true y rewrite ℕ°.+-comm (Bool.toℕ 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∷_)

    #-∘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∷_))

    #-not∘′ : ∀ c (f : Bits c → Bit) → #⟨ not ∘ f ⟩ ≡ 2^ c ∸ #⟨ f ⟩
    #-not∘′ c f = #⟨ not ∘ f ⟩
               ≡⟨ #-not∘ c (not ∘ f) ⟩
                 2^ c ∸ #⟨ not ∘ not ∘ f ⟩
               ≡⟨ ≡.cong (λ g → 2^ c ∸ g) (≗-cong-# (not ∘ not ∘ f) f (not-involutive ∘ f)) ⟩
                 2^ c ∸ #⟨ f ⟩
               ∎
      where open ≡-Reasoning

open SimpleSearch public
open Sum public
open Count public

#⟨⟩-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)

|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 = search-≗ op _ _ (|de-morgan| f g)

search-hom :
  ∀ {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-hom {zero}  _   _   _ _ _   = refl
search-hom {suc n} _+_ _*_ f p hom =
   trans (hom _ _)
         (cong₂ _*_ (search-hom _+_ _*_ f (p ∘ 0∷_) hom)
                    (search-hom _+_ _*_ f (p ∘ 1∷_) hom))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Defs public


Added infor for an issue.

Added infor for an issue.

Ignore-this: 3d18d25b01fdd40e186f7f1195c43154

darcs-hash:20120619225108-3bd4e-09bf31bb63af16215eb30f7625f2746506400e2a.gz

------------------------------------------------------------------------------
-- The translation is badly erasing the universal quantification
------------------------------------------------------------------------------

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

module Issues.BadErase where

postulate
  _↔_ : Set → Set → Set
  D   : Set
  A   : Set

postulate bad₁ : ((x : D) → A) → A
{-# ATP prove bad₁ #-}

-- Before the patch
--
-- Wed Sep 21 04:50:43 COT 2011  ulfn@chalmers.se
--   * got rid of the Fun constructor in internal syntax (using Pi _ (NoAbs _ _) instead)
--
-- the type of bad₁ was:
--
-- Type: El (Type (Max [])) (Fun r(El (Type (Max [])) (Pi r(El (Type (Max [])) (Def BadErase.D [])) (Abs "x" El (Type (Max [])) (Def BadErase.A [])))) (El (Type (Max [])) (Def BadErase.A [])))
--
--
-- After the above patch the type of bad₁ was:
--
-- Type: El (Type (Max [])) (Pi r(El (Type (Max [])) (Pi r(El (Type (Max [])) (Def BadErase.D [])) (Abs "x" El (Type (Max [])) (Def BadErase.A [])))) (NoAbs "_" El (Type (Max [])) (Def BadErase.A [])))
--
--
-- On 19 June 2012, the type of bad₁ is:
--
-- Type: El {getSort = Type (Max []), unEl = Pi r(El {getSort = Type (Max []), unEl = Pi r(El {getSort = Type (Max []), unEl = Def BadErase.D []}) (NoAbs "x" El {getSort = Type (Max []), unEl = Def BadErase.A []})}) (NoAbs "_" El {getSort = Type (Max []), unEl = Def BadErase.A []})}

postulate bad₂ : A → ((x : D) → A)
{-# ATP prove bad₂ #-}

postulate bad₃ : ((x : D) → A) ↔ A
{-# ATP prove bad₃ #-}

------------------------------------------------------------------------------
-- The translation is badly erasing the universal quantification
------------------------------------------------------------------------------

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

-- Found on 14 March 2012.

module Issues.BadErase where

postulate
  _↔_ : Set → Set → Set
  D   : Set
  A   : Set

postulate bad₁ : ((x : D) → A) → A
{-# ATP prove bad₁ #-}

postulate bad₂ : A → ((x : D) → A)
{-# ATP prove bad₂ #-}

postulate bad₃ : ((x : D) → A) ↔ A
{-# ATP prove bad₃ #-}


Added arithmetic properties (by Ana Bove).

Ignore-this: f4f694d231eb13a003e65c404d641cb2

darcs-hash:20110218163424-3bd4e-631646d7d2092969a662e91b13a18d35345a889a.gz

------------------------------------------------------------------------------
-- Arithmetic properties used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesATP
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  91≡[100+11∸10]∸10 : (one-hundred + eleven ∸ ten) ∸ ten ≡ ninety-one
{-# ATP prove 91≡[100+11∸10]∸10 #-}

postulate
  100≡89+11     : eighty-nine + eleven         ≡ one-hundred
  101≡90+11≡101 : ninety + eleven              ≡ hundred-one
  101≡100+11-10 : (one-hundred + eleven) ∸ ten ≡ hundred-one
  102≡91+11     : ninety-one + eleven          ≡ hundred-two
  103≡92+1      : ninety-two + eleven          ≡ hundred-three
  104≡93+11     : ninety-three + eleven        ≡ hundred-four
  105≡94+11     : ninety-four + eleven         ≡ hundred-five
  106≡95+11     : ninety-five + eleven         ≡ hundred-six
  107≡96+11     : ninety-six + eleven          ≡ hundred-seven
  108≡97+11     : ninety-seven + eleven        ≡ hundred-eight
  109≡99+11     : ninety-eight + eleven        ≡ hundred-nine
  110≡99+11     : ninety-nine + eleven         ≡ hundred-ten
  111≡100+11    : one-hundred + eleven         ≡ hundred-eleven

{-# ATP prove 100≡89+11 #-}
{-# ATP prove 101≡90+11≡101 #-}
{-# ATP prove 101≡100+11-10 #-}
{-# ATP prove 102≡91+11 #-}
{-# ATP prove 103≡92+1 #-}
{-# ATP prove 104≡93+11 #-}
{-# ATP prove 105≡94+11 #-}
{-# ATP prove 106≡95+11 #-}
{-# ATP prove 107≡96+11 #-}
{-# ATP prove 108≡97+11 #-}
{-# ATP prove 109≡99+11 #-}
{-# ATP prove 110≡99+11 #-}
{-# ATP prove 111≡100+11 #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  102>100  : GT hundred-two one-hundred
  103>100  : GT hundred-three one-hundred
  104>100  : GT hundred-four one-hundred
  105>100  : GT hundred-five one-hundred
  106>100  : GT hundred-six one-hundred
  107>100  : GT hundred-seven one-hundred
  108>100  : GT hundred-eight one-hundred
  109>100  : GT hundred-nine one-hundred
  110>100  : GT hundred-ten one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' 101≡100+11-10 #-}
{-# ATP prove 102>100 #-}
{-# ATP prove 103>100 #-}
{-# ATP prove 104>100 #-}
{-# ATP prove 105>100 #-}
{-# ATP prove 106>100 #-}
{-# ATP prove 107>100 #-}
{-# ATP prove 108>100 #-}
{-# ATP prove 109>100 #-}
{-# ATP prove 110>100 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' 111≡100+11 #-}

postulate
  99+11>100 : GT (ninety-nine + eleven) one-hundred
  98+11>100 : GT (ninety-eight + eleven) one-hundred
  97+11>100 : GT (ninety-seven + eleven) one-hundred
  96+11>100 : GT (ninety-six + eleven) one-hundred
  95+11>100 : GT (ninety-five + eleven) one-hundred
  94+11>100 : GT (ninety-four + eleven) one-hundred
  93+11>100 : GT (ninety-three + eleven) one-hundred
  92+11>100 : GT (ninety-two + eleven) one-hundred
  91+11>100 : GT (ninety-one + eleven) one-hundred
  90+11>100 : GT (ninety + eleven) one-hundred
{-# ATP prove 99+11>100 110>100 110≡99+11 #-}
{-# ATP prove 98+11>100 109>100 109≡99+11 #-}
{-# ATP prove 97+11>100 108>100 108≡97+11 #-}
{-# ATP prove 96+11>100 107>100 107≡96+11 #-}
{-# ATP prove 95+11>100 106>100 106≡95+11 #-}
{-# ATP prove 94+11>100 105>100 105≡94+11 #-}
{-# ATP prove 93+11>100 104>100 104≡93+11 #-}
{-# ATP prove 92+11>100 103>100 103≡92+1 #-}
{-# ATP prove 91+11>100 102>100 102≡91+11 #-}
{-# ATP prove 90+11>100 101>100' 101≡90+11≡101 #-}

postulate
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' 102≡91+11 #-}

postulate 91>100→⊥ : GT ninety-one one-hundred → ⊥
{-# ATP prove 91>100→⊥ #-}

postulate x+1≤x∸10+11 : ∀ {n} → N n → LE (n + one) ((n ∸ ten) + eleven)
{-# ATP prove x+1≤x∸10+11 x≤y+x∸y N10 1+x-N 11+x-N x∸10-N +-comm #-}

postulate x≤89→x+11>100→⊥ : ∀ {n} → N n → LE n eighty-nine →
                            GT (n + eleven) one-hundred → ⊥
{-# ATP prove x≤89→x+11>100→⊥ x>y→x≤y→⊥ x≤y→x+k≤y+k x+11-N N89 N100 100≡89+11 #-}

------------------------------------------------------------------------------
-- Arithmetic stuff used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesATP
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  91≡[100+11∸10]∸10 : (one-hundred + eleven ∸ ten) ∸ ten ≡ ninety-one
{-# ATP prove 91≡[100+11∸10]∸10 #-}

postulate
  100≡89+11     : eighty-nine + eleven         ≡ one-hundred
  101≡90+11≡101 : ninety + eleven              ≡ hundred-one
  101≡100+11-10 : (one-hundred + eleven) ∸ ten ≡ hundred-one
  102≡91+11     : ninety-one + eleven          ≡ hundred-two
  103≡92+1      : ninety-two + eleven          ≡ hundred-three
  104≡93+11     : ninety-three + eleven        ≡ hundred-four
  105≡94+11     : ninety-four + eleven         ≡ hundred-five
  106≡95+11     : ninety-five + eleven         ≡ hundred-six
  107≡96+11     : ninety-six + eleven          ≡ hundred-seven
  108≡97+11     : ninety-seven + eleven        ≡ hundred-eight
  109≡99+11     : ninety-eight + eleven        ≡ hundred-nine
  110≡99+11     : ninety-nine + eleven         ≡ hundred-ten
  111≡100+11    : one-hundred + eleven         ≡ hundred-eleven

{-# ATP prove 100≡89+11 #-}
{-# ATP prove 101≡90+11≡101 #-}
{-# ATP prove 101≡100+11-10 #-}
{-# ATP prove 102≡91+11 #-}
{-# ATP prove 103≡92+1 #-}
{-# ATP prove 104≡93+11 #-}
{-# ATP prove 105≡94+11 #-}
{-# ATP prove 106≡95+11 #-}
{-# ATP prove 107≡96+11 #-}
{-# ATP prove 108≡97+11 #-}
{-# ATP prove 109≡99+11 #-}
{-# ATP prove 110≡99+11 #-}
{-# ATP prove 111≡100+11 #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' 101≡100+11-10 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' 111≡100+11 #-}
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' 102≡91+11 #-}

postulate 91>100→⊥ : GT ninety-one one-hundred → ⊥
{-# ATP prove 91>100→⊥ #-}

postulate x+1≤x∸10+11 : ∀ {n} → N n → LE (n + one) ((n ∸ ten) + eleven)
{-# ATP prove x+1≤x∸10+11 x≤y+x∸y N10 1+x-N 11+x-N x∸10-N +-comm #-}

postulate x≤89→x+11>100→⊥ : ∀ {n} → N n → LE n eighty-nine →
                            GT (n + eleven) one-hundred → ⊥
{-# ATP prove x≤89→x+11>100→⊥ x>y→x≤y→⊥ x≤y→x+k≤y+k x+11-N N89 N100 100≡89+11 #-}


Data.Vec.NP: count, countᶠ and properties

module Data.Vec.NP where

open import Data.Vec public
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product hiding (map)
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

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

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

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

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

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

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

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

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

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

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

{-
open import Data.Vec.Equality

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

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

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

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

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

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

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

module Data.Vec.NP where

open import Data.Vec public
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin hiding (_+_)
open import Data.Fin.Props
open import Data.Bool
open import Data.Product
open import Function
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
count pred [] = zero
count pred (x ∷ xs) = (if pred x then suc else inject₁) (count pred xs)

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

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

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

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

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

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

{-
open import Data.Vec.Equality

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

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

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

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

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

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

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


Add support for general vector to our flat-funs abstraction

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
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T
    _`→_  : T → T → Set

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 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

    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

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

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Product
open import Function

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

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk 0 1 _+_ _*_ (λ i o → Bits i → Bits o)

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

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id bitsFunComp bitsFunVComp _&&&_ (λ {A} → take A) (λ {A} → drop A)
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (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)

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)


Added doc.

Added doc.

------------------------------------------------------------------------------
-- Co-inductive natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module GreatestFixedPoints.Conat where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Conat is a greatest fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The co-natural numbers are the greatest fixed-point of NatF.
postulate
  Conat : D → Set

  -- Conat is a post-fixed point of NatF, i.e.
  --
  -- Conat ≤ NatF Conat.
  Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  -- The higher-order version.
  Conat-unf-ho : ∀ {n} → Conat n → NatF Conat n

  -- Conat is the greatest post-fixed point of NatF, i.e
  --
  -- ∀ P. P ≤ NatF P ⇒ P ≤ Conat.
  Conat-coind :
    ∀ (A : D → Set) →
    -- A is post-fixed point of ConatF.
    (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    -- Conat is greater than A.
    ∀ {n} → A n → Conat n

  -- The higher-order version.
  Conat-coind-ho :
    ∀ (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n

  -- 22 December 2013. This is a stronger induction principle. If we
  -- use it, we can use the trivial A = λ x → x ≡ x in the
  -- proofs. Unfortunately, we don't have a justification for this
  -- principle.
  Conat-coind-stronger :
    ∀ (A : D → Set) {n} →
    (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    A n → Conat n

------------------------------------------------------------------------------
-- Conat-unf and Conat-unf-ho are equivalents

Conat-unf' : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-unf' = Conat-unf-ho

Conat-unf-ho' : ∀ {n} → Conat n → NatF Conat n
Conat-unf-ho' = Conat-unf

------------------------------------------------------------------------------
-- Conat-coind and Conat-coind-ho are equivalents

Conat-coind' :
  ∀ (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind' = Conat-coind-ho

Conat-coind-ho' :
  ∀ (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n
Conat-coind-ho' = Conat-coind

------------------------------------------------------------------------------
-- From Conat-coind/Conat-coind-stronger to Conat-coind-stronger/Conat-coind

Conat-coind'' :
  ∀ (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind'' A h An = Conat-coind-stronger A h An

-- 22 December 2013: We cannot prove Conat-coind-stronger using
-- Conat-coind.
Conat-coind-stronger'' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-coind-stronger'' A h An = Conat-coind A {!!} An

------------------------------------------------------------------------------
-- Co-inductive natural numbers
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module GreatestFixedPoints.Conat where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Conat is a greatest fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The co-natural numbers are the greatest fixed-point of NatF.
postulate
  Conat : D → Set

  -- Conat is a post-fixed point of NatF, i.e.
  --
  -- Conat ≤ NatF Conat.
  Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  -- The higher-order version.
  Conat-unf-ho : ∀ {n} → Conat n → NatF Conat n

  -- Conat is the greatest post-fixed point of NatF, i.e
  --
  -- ∀ P. P ≤ NatF P ⇒ P ≤ Conat.
  Conat-coind : ∀ (A : D → Set) →
                (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
                ∀ {n} → A n → Conat n

  -- The higher-order version.
  Conat-coind-ho : ∀ (A : D → Set) →
                   (∀ {n} → A n → NatF A n) →
                   ∀ {n} → A n → Conat n

  Conat-coind-wrong : ∀ (A : D → Set) {n} →
                      -- A is post-fixed point of ConatF.
                      (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
                      -- Conat is greater than A.
                      A n → Conat n

------------------------------------------------------------------------------
-- Conat-unf and Conat-unf-ho are equivalents

Conat-unf' : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-unf' = Conat-unf-ho

Conat-unf-ho' : ∀ {n} → Conat n → NatF Conat n
Conat-unf-ho' = Conat-unf

------------------------------------------------------------------------------
-- Conat-coind and Conat-coind-ho are equivalents

Conat-coind' : ∀ (A : D → Set) →
               (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
               ∀ {n} → A n → Conat n
Conat-coind' = Conat-coind-ho

Conat-coind-ho' : ∀ (A : D → Set) →
                  (∀ {n} → A n → NatF A n) →
                  ∀ {n} → A n → Conat n
Conat-coind-ho' = Conat-coind

------------------------------------------------------------------------------
-- From Conat-coind/Conat-coind-wrong to Conat-coind-wrong/Conat-coind

Conat-coind'' : ∀ (A : D → Set) →
               (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
               ∀ {n} → A n → Conat n
Conat-coind'' A h An = Conat-coind-wrong A h An

-- 22 December 2013: We cannot prove Conat-coind-wrong'' using
-- Conat-coind.
Conat-coind-wrong'' : ∀ (A : D → Set) {n} →
                      (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
                      A n → Conat n
Conat-coind-wrong'' A h An = Conat-coind A {!!} An


forking-lemma: some progress

forking-lemma: some progress

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Vec.NP hiding (sum)
open import Data.Maybe
open import Data.One using (𝟙)
open import Data.Two.Base hiding (_==_; _²)
open import Data.Fin.NP as Fin hiding (_+_; _-_; _≤_)
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP hiding (J)

module forking-lemma where

{-
_≥1 : ∀ {n} → Fin n → 𝟚
zero  ≥1 = 0₂
suc _ ≥1 = 1₂
-}

replace : ∀ {A : Type} {q} (I : Fin q)
            (hs hs' : Vec A q) → Vec A q
replace zero         hs       hs'  = hs'
replace (suc I) (h ∷ hs) (_ ∷ hs') = h ∷ replace I hs hs'

test-replace : replace (suc zero) (40 ∷ 41 ∷ 42 ∷ []) (60 ∷ 61 ∷ 62 ∷ []) ≡ 40 ∷ 61 ∷ 62 ∷ []
test-replace = refl

≡-prefix : ∀ {A : Type} {q} (I : Fin (suc q))
             (v₀ v₁ : Vec A q) → Type
≡-prefix zero    _         _         = 𝟙
≡-prefix (suc I) (x₀ ∷ v₀) (x₁ ∷ v₁) = (x₀ ≡ x₁) × ≡-prefix I v₀ v₁

≡-prefix (suc ()) [] []

postulate
  -- Pub    : Type
  Res    : Type -- Side output
  {-RndIG  : Type-}

  -- IG : RndIG → Pub

  q     : ℕ

  instance
    q≥1   : q ≥ 1

  #h     : ℕ
  #h≥2   : #h ≥ 2

  #ρ : ℕ
  #ρ≥1 : #ρ ≥ 1

RndAdv : Type -- Coin
RndAdv = Fin #ρ

H : Type
H = Fin #h

Adv = {-(x : Pub)-}(hs : Vec H q)(ρ : RndAdv) → Fin (suc q) × Res

postulate
  A : Adv
-- A x hs ρ
-- A x hs = ρ ←$ ...H ; A x hs ρ

-- IO : Type → Type
-- print : String → IO ()
-- #r : ℕ
-- #r≥1 : #r ≥ 1
-- Rnd = Fin #r
-- random : IO Rnd
-- run : (A : Input → Rnd → Res) → Input → IO Res
-- run A i = do r ← random
--              return (A i r)

-- Not used yet
well-def : Adv → Type
well-def A =
  ∀ {-x-} hs ρ →
    case A {-x-} hs ρ of λ { (I , σ) →
    ∀ hs' → ≡-prefix I hs hs' →  A {-x-} hs' ρ ≡ (I , σ) }

record Ω : Type where
  field
    -- rIG : RndIG
    hs hs' : Vec H q
    ρ      : RndAdv

Event = Ω → 𝟚

#Ω = ((#h ^ q) ^2) * #ρ
-- Ω ≃ Fin #Ω

instance
  #Ω≥1 : #Ω ≥ 1
  #Ω≥1 = {!!}

module M (r : Ω) where
  open Ω r

  F' : (I-1 : Fin q)(σ : Res) → Maybe (Res × Res)
  F' I-1 σ =
    case I=I' ∧ h=h'
      0: nothing
      1: just (σ , σ')
    module F' where
      res' = A (replace I-1 hs hs') ρ
      I'   = fst res'
      σ'   = snd res'
      h    = hs  ‼ I-1
      h'   = hs' ‼ I-1
      I    = suc I-1
      I=I' = I == I'
      h=h' = h == h'

  F : Maybe (Res × Res)
  F =
    case I of λ
    { zero      → nothing
    ; (suc I-1) → F' I-1 σ
    }
    module F where
      res  = A hs ρ
      I    = fst res
      σ    = snd res
      -- I≥1  = not (I == zero)

I≥1∧_ : (f : Ω → Fin q → Res → 𝟚) → Event
(I≥1∧ f) r = case I of λ
             { zero → 0₂
             ; (suc I-1) → f r I-1 σ
             }
  where open M.F r

I≥1 I≥1∧I=I' I≥1∧h=h' I≥1∧I=I'∧h≢h' : Event

I≥1 = I≥1∧ λ _ _ _ → 1₂

I≥1∧I=I'      = I≥1∧ λ r I-1 σ → let open M.F' r I-1 σ in I=I'
I≥1∧h=h'      = I≥1∧ λ r I-1 σ → let open M.F' r I-1 σ in h=h'
I≥1∧I=I'∧h≢h' = I≥1∧ λ r I-1 σ → let open M.F' r I-1 σ in I=I' ∧ not h=h'

I=1+_ I=I'=1+_ : (i : Fin q) → Event

I=1+    i = I≥1∧ λ r I-1 σ → let open M.F' r I-1 σ in I == suc i
I=I'=1+ i = I≥1∧ λ r I-1 σ → let open M.F' r I-1 σ in I == suc i ∧ I=I'

-- Acceptance event for A
acc : Event
acc = I≥1

frk : Event
frk = is-just ∘ M.F

instance
    #h≥1 : #h ≥ 1
    #h≥1 = ℕ≤.trans (s≤s z≤n) #h≥2

infix 0 _≥'_
infixr 2 _≥⟨_⟩_ _≡⟨_⟩_ _≡⟨by-definition⟩_
infix 2 _∎

postulate
  -- [0,1] : Type
  ℝ : Type
  -- [0,1]▹ℝ : [0,1] → ℝ
  -- x - y requires x ≥ y
  -- _·_ : [0,1] → [0,1] → [0,1]
  _-_ _·_ : ℝ → ℝ → ℝ
  -- _-_ :
  -- _-_ : [0,1] → [0,1] → ℝ
  -- _≥'_ : [0,1] → [0,1] → Type
  _≥'_ : ℝ → ℝ → Type
  1/_ : (d : ℕ){{_ : d ≥ 1}} → ℝ

  _≥⟨_⟩_ : ∀ x {y} → x ≥' y → ∀ {z} → y ≥' z → x ≥' z
  _≡⟨_⟩_ : ∀ x {y} → x ≡  y → ∀ {z} → y ≥' z → x ≥' z
  _∎ : ∀ x → x ≥' x

  ℕ▹ℝ : ℕ → ℝ

  sum : Event → ℕ
  sum-ext : {A B : Event} → (∀ r → A r ≡ B r) → sum A ≡ sum B

  sumFin : (q : ℕ) (f : Fin q → ℝ) → ℝ

RndVar = Ω → ℝ

_² : ℝ → ℝ
x ² = x · x

_²' : RndVar → RndVar
(X ²') r = (X r)²

postulate
  E[_] : RndVar → ℝ

  lemma2 : ∀ X → E[ X ²' ] ≥' E[ X ] ²

_≡⟨by-definition⟩_ : ∀ x {z} → x ≥' z → x ≥' z
x ≡⟨by-definition⟩ y = x ≡⟨ refl ⟩ y

-- _/_ : [0,1] → (d : ℕ){{_ : d ≥ 1}} → [0,1]
_/_ : ℝ → (d : ℕ){{_ : d ≥ 1}} → ℝ
x / y = x · 1/ y

Pr : Event → ℝ -- [0,1]
Pr A = ℕ▹ℝ (sum A) / #Ω

Pr-ext : ∀ {A B : Event} → (∀ r → A r ≡ B r) → Pr A ≡ Pr B
Pr-ext f = ap (λ x → ℕ▹ℝ x / #Ω) (sum-ext f)

-- Lemma 1, equation (3)
lemma1-3 : Pr frk ≥' Pr acc · ((Pr acc / q) - (1/ #h))
lemma1-3 = Pr frk
       ≡⟨ {!Pr!} ⟩
         Pr I≥1∧I=I'∧h≢h'
       ≥⟨ {!!} ⟩
         Pr I≥1∧I=I' - Pr I≥1∧h=h'
       ≡⟨ ap (λ x → Pr I≥1∧I=I' - x) {!!} ⟩
         Pr I≥1∧I=I' - (Pr I≥1 / #h)
       ≡⟨by-definition⟩
         Pr I≥1∧I=I' - (Pr acc / #h)
       ≡⟨ {!!} ⟩
         Pr acc · ((Pr acc / q) - (1/ #h))
       ∎

lemma1-4 : Pr I≥1∧I=I' ≥' (Pr acc)² / q
lemma1-4
  = Pr I≥1∧I=I'
  ≡⟨ {!!} ⟩
    sumFin q (λ i → Pr (I=I'=1+ i))
  ≡⟨ {!!} ⟩ -- Conditional probabilities
    sumFin q (λ i → Pr (I=1+ i) · Pr (I=I'=1+ i))
  ≡⟨ {!!} ⟩
    (Pr acc)² / q
  ∎

-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Vec
open import Data.Maybe
open import Data.One using (𝟙)
open import Data.Two.Base hiding (_==_)
open import Data.Fin.NP as Fin hiding (_+_; _-_; _≤_)
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

module forking-lemma where

_≥1 : ∀ {n} → Fin n → 𝟚
zero  ≥1 = 0₂
suc _ ≥1 = 1₂

infix 8 _‼_
_‼_ : ∀ {n a}{A : Set a} → Vec A n → Fin n → A
_‼_ = flip lookup

replace : ∀ {A : Type} {q} (I : Fin q)
            (hs hs' : Vec A q) → Vec A q
replace zero    hs             hs' = hs'
replace (suc I) (h ∷ hs) (_ ∷ hs') = h ∷ replace I hs hs'

test-replace : replace (suc zero) (40 ∷ 41 ∷ 42 ∷ []) (60 ∷ 61 ∷ 62 ∷ []) ≡ 40 ∷ 61 ∷ 62 ∷ []
test-replace = refl

≡-prefix : ∀ {A : Type} {q} (I : Fin (suc q))
             (v₀ v₁ : Vec A q) → Type
≡-prefix zero    _         _         = 𝟙
≡-prefix (suc I) (x₀ ∷ v₀) (x₁ ∷ v₁) = (x₀ ≡ x₁) × ≡-prefix I v₀ v₁

≡-prefix (suc ()) [] []

postulate
  -- Pub    : Type
  Res    : Type -- Side output
  RndAdv : Type -- Coin
  {-RndIG  : Type-}

  -- IG : RndIG → Pub

  q     : ℕ

  instance
    q≥1   : q ≥ 1

  #h     : ℕ
  #h≥2   : #h ≥ 2

H : Type
H = Fin #h

Adv = {-(x : Pub)-}(hs : Vec H q)(ρ : RndAdv) → Fin (suc q) × Res

postulate
  A : Adv
-- A x hs ρ
-- A x hs = ρ ←$ ...H ; A x hs ρ

-- IO : Type → Type
-- print : String → IO ()
-- #r : ℕ
-- #r≥1 : #r ≥ 1
-- Rnd = Fin #r
-- random : IO Rnd
-- run : (A : Input → Rnd → Res) → Input → IO Res
-- run A i = do r ← random
--              return (A i r)

-- Not used yet
well-def : Adv → Type
well-def A =
  ∀ {-x-} hs ρ →
    case A {-x-} hs ρ of λ { (I , σ) →
    ∀ hs' → ≡-prefix I hs hs' →  A {-x-} hs' ρ ≡ (I , σ) }

record Ω : Type where
  field
    -- rIG : RndIG
    hs hs' : Vec H q
    ρ      : RndAdv

Event = Ω → 𝟚

module M (r : Ω) where
  open Ω r

  F' : (I-1 : Fin q)(σ : Res) → Maybe (Res × Res)
  F' I-1 σ =
    case I=I' ∧ h=h' of λ
    { 1₂ → just (σ , σ')
    ; 0₂ → nothing
    }
    module F' where
      res' = A (replace I-1 hs hs') ρ
      I'   = fst res'
      σ'   = snd res'
      h    = hs  ‼ I-1
      h'   = hs' ‼ I-1
      I    = suc I-1
      I=I' = I == I'
      h=h' = h == h'

  F : Maybe (Res × Res)
  F =
    case I of λ
    { zero      → nothing
    ; (suc I-1) → F' I-1 σ
    }
    module F where
      res  = A hs ρ
      I    = fst res
      σ    = snd res
      I≥1  = not (I == zero)

-- Acceptance event for A
acc : Event
acc r = J ≥1
  where open Ω r
     -- x = IG rIG
        J = fst (A {-x-} hs ρ)

frk : Event
frk r = case M.F r of λ { (just _) → 1₂ ; nothing → 0₂ }

instance
    #h≥1 : #h ≥ 1
    #h≥1 = ℕ≤.trans (s≤s z≤n) #h≥2

infix 0 _≥'_
infixr 2 _≥⟨_⟩_ _≡⟨_⟩_
infix 2 _∎

postulate
  [0,1] : Type
  Pr : Event → [0,1]
  _-_ _·_ : [0,1] → [0,1] → [0,1]
  _≥'_ : [0,1] → [0,1] → Type
  1/_ : (d : ℕ){{_ : d ≥ 1}} → [0,1]

  _≥⟨_⟩_ : ∀ x {y} → x ≥' y → ∀ {z} → y ≥' z → x ≥' z
  _≡⟨_⟩_ : ∀ x {y} → x ≡  y → ∀ {z} → y ≥' z → x ≥' z
  _∎ : ∀ x → x ≥' x

_/_ : [0,1] → (d : ℕ){{_ : d ≥ 1}} → [0,1]
x / y = x · 1/ y

{-
lemma3 : Pr frk ≥' Pr acc · ((Pr acc / q) - (1/ #h))
lemma3 = Pr frk
       ≡⟨ {!!} ⟩
         Pr {!λ r → I=I' r ∧ I≥1 r!}
       ≥⟨ {!!} ⟩
         Pr acc · ((Pr acc / q) - (1/ #h))
       ∎
  where
    open M.F
    -- open M.F' I-1 σ

-- -}
-- -}
-- -}
-- -}
-- -}