Bits: fx

Bits: fx

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 (_→⟨_⟩_)
open import Relation.Nullary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties.NP
import Data.List.NP as L
open import Function.Bijection.SyntaxKit

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
    module BitBij = BoolBijection
    open BitBij public using (`id) renaming (BoolBij to BitBij; bool-bijKit to bitBijKit; `not to `notᴮ)
    open BijectionSyntax Bit BitBij public
    open BijectionSemantics bitBijKit public

    {-
       id   ε          id
       0↔1  swp-inners interchange
       not  swap       comm
       if0  first      ...
       if1  second     ...
     -}
    `not : Bij
    `not = BitBij.`not `∷ const `id

    `xor : Bit → Bij
    `xor b = BitBij.`xor b `∷ const `id

    `if : Bij → Bij → Bij
    `if f g = BitBij.`id `∷ cond f g

    `if0 : Bij → Bij
    `if0 f = `if `id f

    `if1 : Bij → Bij
    `if1 f = `if f `id

    -- law: `if0 f `⁏ `if1 g ≡ `if1 g `; `if0 f

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

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

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

    -- (a ∙ b) ∙ (c ∙ d)
    -- ≡ right swap ≡ if1 not
    -- (a ∙ b) ∙ (d ∙ c)
    -- ≡ interchange ≡ 0↔1
    -- (a ∙ d) ∙ (b ∙ c)
    -- ≡ left f ≡ if0 f
    -- (A ∙ D) ∙ (b ∙ c)
    --     where A ∙ D = f (a ∙ d)
    -- ≡ interchange ≡ 0↔1
    -- (A ∙ b) ∙ (D ∙ c)
    -- ≡ right swap ≡ if1 not
    -- (A ∙ b) ∙ (c ∙ D)
    on-extremes f = `if1 `not `⁏ `0↔1 `⁏ `if0 f `⁏ `0↔1 `⁏ `if1 `not

    map-inner : Bij → Bij
    map-inner f = `if1 `not `⁏ `0↔1 `⁏ `if1 f `⁏ `0↔1 `⁏ `if1 `not

    map-outer : Bij → Bij → Bij
    map-outer f g = `if g f

    0↔1∷_ : ∀ {n} → Bits n → Bij
    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 → Bij
    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

    private
        module P where
           open PermutationSyntax public
           open PermutationSemantics public
    open P using (Perm; `id; `0↔1; _`⁏_)

    `⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Bij
    `⟨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) → Bij
    `⟨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) → Bij
    `⟨ 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 → Bij
    `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 → Bij
    `⟨ []     ⊕⟩ = `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

    -- TODO make use of ⊛-dist-∙
    ⊕-dist-∙ : ∀ {n} (pad : Bits n) π xs → π ∙ pad ⊕ π ∙ xs ≡ π ∙ (pad ⊕ xs)
    ⊕-dist-∙ fs      `id        xs = refl
    ⊕-dist-∙ fs      `0↔1       xs = ⊕-dist-0↔1 fs xs
    ⊕-dist-∙ []       (`tl π)   [] = refl
    ⊕-dist-∙ (f ∷ fs) (`tl π)   (x ∷ xs) rewrite ⊕-dist-∙ fs π xs = refl
    ⊕-dist-∙ fs       (π₀ `⁏ π₁) xs rewrite ⊕-dist-∙ (π₀ ∙ fs) π₁ (π₀ ∙ xs)
                                         | ⊕-dist-∙ fs π₀ xs = 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
                      ≡⟨ TODO ⟩
                        π ∙ 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

    module SearchUnit ε (ε∙ε : ε ∙ ε ≡ ε) where
        search-constε≡ε : ∀ n → search {n = n} (const ε) ≡ ε
        search-constε≡ε zero = refl
        search-constε≡ε (suc n) rewrite search-constε≡ε 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 Bij (∙-comm : Commutative _≡_ _∙_)
              (∙-interchange : Interchange _≡_ _∙_ _∙_) where
        open SearchInterchange ∙-interchange using (search-0↔1)
        open OperationSyntax hiding (_∙_)
        search-bij : ∀ {n} f (g : Bits n → A) → search (g ∘ eval f) ≡ search g
        search-bij `id     _ = refl
        search-bij `0↔1    f = search-0↔1 f
        search-bij (f `⁏ g) h
          rewrite search-bij f (h ∘ eval g)
                | search-bij g h
                = refl
        search-bij {zero}  (_     `∷ _) _ = refl
        search-bij {suc n} (`id   `∷ f) g
          rewrite search-bij (f 0b) (g ∘ 0∷_)
                | search-bij (f 1b) (g ∘ 1∷_)
                = refl
        search-bij {suc n} (`notᴮ `∷ f) g
          rewrite search-bij (f 1b) (g ∘ 0∷_)
                | search-bij (f 0b) (g ∘ 1∷_)
                = ∙-comm _ _

module Sum where
    open SimpleSearch _+_ using (module Comm; module SearchInterchange; module SearchUnit; module Bij)
    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 SearchUnit 0 refl public renaming
       (search-constε≡ε to sum-const0≡0)
    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 Bij ℕ°.+-comm +-interchange public renaming (search-bij to sum-bij)

    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

    #⟨_⟩ : ∀ {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)

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

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

toℕ-bound : ∀ {n} (xs : Bits n) → toℕ xs < 2^ n
toℕ-bound         [] = s≤s z≤n
toℕ-bound {suc n} (1b ∷ xs) rewrite +-assoc-comm 1 (2^ n) (toℕ xs) = ℕ≤.refl {2^ n} +-mono toℕ-bound xs
toℕ-bound {suc n} (0b ∷ xs) = ≤-steps (2^ n) (toℕ-bound xs)

toℕ≤2ⁿ+ : ∀ {n} (x : Bits n) {y} → toℕ {n} x ≤ 2^ n + y
toℕ≤2ⁿ+ {n} x {y} = ℕ≤.trans (≤-steps y (≤-pred (≤-steps 1 (toℕ-bound x))))
                             (ℕ≤.reflexive (ℕ°.+-comm y (2^ n)))

2ⁿ+≰toℕ : ∀ {n x} (y : Bits n) → 2^ n + x ≰ toℕ {n} y
2ⁿ+≰toℕ {n} {x} y p = ¬n+≤y<n (2^ n) p (toℕ-bound y)

toℕ-inj : ∀ {n} (x y : Bits n) → toℕ x ≡ toℕ y → x ≡ y
toℕ-inj         []        []        _ = refl
toℕ-inj         (0b ∷ xs) (0b ∷ ys) p = cong 0∷_ (toℕ-inj xs ys p)
toℕ-inj {suc n} (1b ∷ xs) (1b ∷ ys) p = cong 1∷_ (toℕ-inj xs ys (cancel-+-left (2^ n) p))
toℕ-inj {suc n} (0b ∷ xs) (1b ∷ ys) p = ⊥-elim (2ⁿ+≰toℕ xs (ℕ≤.reflexive (≡.sym p)))
toℕ-inj {suc n} (1b ∷ xs) (0b ∷ ys) p = ⊥-elim (2ⁿ+≰toℕ ys (ℕ≤.reflexive p))

data _≤ᴮ_ : ∀ {n} (p q : Bits n) → Set where
  []    : [] ≤ᴮ []
  there : ∀ {n} {p q : Bits n} b → p ≤ᴮ q → (b ∷ p) ≤ᴮ (b ∷ q)
  0-1   : ∀ {n} (p q : Bits n) → 0∷ p ≤ᴮ 1∷ q

toℕ-≤-inj : ∀ {n} (x y : Bits n) → toℕ x ≤ toℕ y → x ≤ᴮ y
toℕ-≤-inj     [] [] p = []
toℕ-≤-inj         (0b ∷ xs) (0b ∷ ys) p = there 0b (toℕ-≤-inj xs ys p)
toℕ-≤-inj         (0b ∷ xs) (1b ∷ ys) p = 0-1 _ _
toℕ-≤-inj {suc n} (1b ∷ xs) (0b ∷ ys) p = ⊥-elim (2ⁿ+≰toℕ ys p)
toℕ-≤-inj {suc n} (1b ∷ xs) (1b ∷ ys) p = there 1b (toℕ-≤-inj xs ys (+-≤-inj (2^ n) p))

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ {zero}  _ = []
fromℕ {suc n} x = if 2^ n <= x then 1∷ fromℕ (x ∸ 2^ n) else 0∷ fromℕ x

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 (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} (drop (2^ n) tbl)
        = take-drop-lem (2^ n) tbl

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

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

2ⁿ≰toℕ : ∀ {n} (xs : Bits n) → 2^ n ≰ toℕ xs
2ⁿ≰toℕ xs p = ¬n≤x<n _ p (toℕ-bound xs)

Tnot2ⁿ<=toℕ : ∀ {n} (xs : Bits n) → T (not (2^ n <= (toℕ xs)))
Tnot2ⁿ<=toℕ {n} xs with (2^ n) <= (toℕ xs) | ≡.inspect (_<=_ (2^ n)) (toℕ xs)
... | true  | [ p ] = 2ⁿ≰toℕ xs (<=.sound (2^ n) (toℕ xs) (≡→T p))
... | false |   _   = _

fromℕ∘toℕ : ∀ {n} (x : Bits n) → fromℕ (toℕ x) ≡ x
fromℕ∘toℕ [] = ≡.refl
fromℕ∘toℕ {suc n} (true ∷ xs)
  rewrite T→≡ (<=-steps′ {2^ n} (toℕ xs))
        | ℕ°.+-comm (2^ n) (toℕ xs)
        | m+n∸n≡m (toℕ xs) (2^ n)
        | fromℕ∘toℕ xs
        = ≡.refl
fromℕ∘toℕ (false ∷ xs)
  rewrite Tnot→≡ (Tnot2ⁿ<=toℕ xs)
        | fromℕ∘toℕ xs
        = ≡.refl

toℕ∘fromℕ : ∀ {n} x → x ℕ< 2^ n → toℕ {n} (fromℕ x) ≡ x
toℕ∘fromℕ {zero} .0 (s≤s z≤n) = ≡.refl
toℕ∘fromℕ {suc n} x x<2ⁿ with 2^ n ℕ<= x | ≡.inspect (_ℕ<=_ (2^ n)) x
... | true  | [ p ] rewrite toℕ∘fromℕ {n} (x ∸ 2^ n) (x<2y→x∸y<y x (2^ n) x<2ⁿ) = m+n∸m≡n {2^ n} {x} (ℕ<=.sound (2^ n) x (≡→T p))
... | false | [ p ] = toℕ∘fromℕ {n} x (ℕ<=.sound (suc x) (2^ n) (not<=→< (2^ n) x (≡→Tnot p)))

fromℕ-inj : ∀ {n} {x y : ℕ} → x ℕ< 2^ n → y ℕ< 2^ n → fromℕ {n} x ≡ fromℕ y → x ≡ y
fromℕ-inj {n} {x} {y} x< y< fx≡fy
  = x
  ≡⟨ ≡.sym (toℕ∘fromℕ {n} x x<) ⟩
    toℕ (fromℕ {n} x)
  ≡⟨ ≡.cong toℕ fx≡fy ⟩
    toℕ (fromℕ {n} y)
  ≡⟨ toℕ∘fromℕ {n} y y< ⟩
    y
  ∎ where open ≡-Reasoning

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 (_→⟨_⟩_)
open import Relation.Nullary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties.NP
import Data.List.NP as L
open import Function.Bijection.SyntaxKit

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
    module BitBij = BoolBijection
    open BitBij public using (`id) renaming (BoolBij to BitBij; bool-bijKit to bitBijKit; `not to `notᴮ)
    open BijectionSyntax Bit BitBij public
    open BijectionSemantics bitBijKit public

    {-
       id   ε          id
       0↔1  swp-inners interchange
       not  swap       comm
       if0  first      ...
       if1  second     ...
     -}
    `not : Bij
    `not = BitBij.`not `∷ const `id

    `xor : Bit → Bij
    `xor b = BitBij.`xor b `∷ const `id

    `if : Bij → Bij → Bij
    `if f g = BitBij.`id `∷ cond f g

    `if0 : Bij → Bij
    `if0 f = `if `id f

    `if1 : Bij → Bij
    `if1 f = `if f `id

    -- law: `if0 f `⁏ `if1 g ≡ `if1 g `; `if0 f

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

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

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

    -- (a ∙ b) ∙ (c ∙ d)
    -- ≡ right swap ≡ if1 not
    -- (a ∙ b) ∙ (d ∙ c)
    -- ≡ interchange ≡ 0↔1
    -- (a ∙ d) ∙ (b ∙ c)
    -- ≡ left f ≡ if0 f
    -- (A ∙ D) ∙ (b ∙ c)
    --     where A ∙ D = f (a ∙ d)
    -- ≡ interchange ≡ 0↔1
    -- (A ∙ b) ∙ (D ∙ c)
    -- ≡ right swap ≡ if1 not
    -- (A ∙ b) ∙ (c ∙ D)
    on-extremes f = `if1 `not `⁏ `0↔1 `⁏ `if0 f `⁏ `0↔1 `⁏ `if1 `not

    map-inner : Bij → Bij
    map-inner f = `if1 `not `⁏ `0↔1 `⁏ `if1 f `⁏ `0↔1 `⁏ `if1 `not

    map-outer : Bij → Bij → Bij
    map-outer f g = `if g f

    0↔1∷_ : ∀ {n} → Bits n → Bij
    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 → Bij
    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

    private
        module P where
           open PermutationSyntax public
           open PermutationSemantics public
    open P using (Perm; `id; `0↔1; _`⁏_)

    `⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Bij
    `⟨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) → Bij
    `⟨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) → Bij
    `⟨ 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 → Bij
    `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 → Bij
    `⟨ []     ⊕⟩ = `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

    -- TODO make use of ⊛-dist-∙
    ⊕-dist-∙ : ∀ {n} (pad : Bits n) π xs → π ∙ pad ⊕ π ∙ xs ≡ π ∙ (pad ⊕ xs)
    ⊕-dist-∙ fs      `id        xs = refl
    ⊕-dist-∙ fs      `0↔1       xs = ⊕-dist-0↔1 fs xs
    ⊕-dist-∙ []       (`tl π)   [] = refl
    ⊕-dist-∙ (f ∷ fs) (`tl π)   (x ∷ xs) rewrite ⊕-dist-∙ fs π xs = refl
    ⊕-dist-∙ fs       (π₀ `⁏ π₁) xs rewrite ⊕-dist-∙ (π₀ ∙ fs) π₁ (π₀ ∙ xs)
                                         | ⊕-dist-∙ fs π₀ xs = 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
                      ≡⟨ TODO ⟩
                        π ∙ 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

    module SearchUnit ε (ε∙ε : ε ∙ ε ≡ ε) where
        search-constε≡ε : ∀ n → search {n = n} (const ε) ≡ ε
        search-constε≡ε zero = refl
        search-constε≡ε (suc n) rewrite search-constε≡ε 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 Bij (∙-comm : Commutative _≡_ _∙_)
              (∙-interchange : Interchange _≡_ _∙_ _∙_) where
        open SearchInterchange ∙-interchange using (search-0↔1)
        open OperationSyntax hiding (_∙_)
        search-bij : ∀ {n} f (g : Bits n → A) → search (g ∘ eval f) ≡ search g
        search-bij `id     _ = refl
        search-bij `0↔1    f = search-0↔1 f
        search-bij (f `⁏ g) h
          rewrite search-bij f (h ∘ eval g)
                | search-bij g h
                = refl
        search-bij {zero}  (_     `∷ _) _ = refl
        search-bij {suc n} (`id   `∷ f) g
          rewrite search-bij (f 0b) (g ∘ 0∷_)
                | search-bij (f 1b) (g ∘ 1∷_)
                = refl
        search-bij {suc n} (`notᴮ `∷ f) g
          rewrite search-bij (f 1b) (g ∘ 0∷_)
                | search-bij (f 0b) (g ∘ 1∷_)
                = ∙-comm _ _

module Sum where
    open SimpleSearch _+_ using (module Comm; module SearchInterchange; module SearchUnit; module Bij)
    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 SearchUnit 0 refl public renaming
       (search-constε≡ε to sum-const0≡0)
    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 Bij ℕ°.+-comm +-interchange public renaming (search-bij to sum-bij)

    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

    #⟨_⟩ : ∀ {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)

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

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

toℕ-bound : ∀ {n} (xs : Bits n) → toℕ xs < 2^ n
toℕ-bound         [] = s≤s z≤n
toℕ-bound {suc n} (1b ∷ xs) rewrite +-assoc-comm 1 (2^ n) (toℕ xs) = ℕ≤.refl {2^ n} +-mono toℕ-bound xs
toℕ-bound {suc n} (0b ∷ xs) = ≤-steps (2^ n) (toℕ-bound xs)

toℕ≤2ⁿ+ : ∀ {n} (x : Bits n) {y} → toℕ {n} x ≤ 2^ n + y
toℕ≤2ⁿ+ {n} x {y} = ℕ≤.trans (≤-steps y (≤-pred (≤-steps 1 (toℕ-bound x))))
                             (ℕ≤.reflexive (ℕ°.+-comm y (2^ n)))

2ⁿ+≰toℕ : ∀ {n x} (y : Bits n) → 2^ n + x ≰ toℕ {n} y
2ⁿ+≰toℕ {n} {x} y p = ¬n+≤y<n (2^ n) p (toℕ-bound y)

toℕ-inj : ∀ {n} (x y : Bits n) → toℕ x ≡ toℕ y → x ≡ y
toℕ-inj         []        []        _ = refl
toℕ-inj         (0b ∷ xs) (0b ∷ ys) p = cong 0∷_ (toℕ-inj xs ys p)
toℕ-inj {suc n} (1b ∷ xs) (1b ∷ ys) p = cong 1∷_ (toℕ-inj xs ys (cancel-+-left (2^ n) p))
toℕ-inj {suc n} (0b ∷ xs) (1b ∷ ys) p = ⊥-elim (2ⁿ+≰toℕ xs (ℕ≤.reflexive (≡.sym p)))
toℕ-inj {suc n} (1b ∷ xs) (0b ∷ ys) p = ⊥-elim (2ⁿ+≰toℕ ys (ℕ≤.reflexive p))

data _≤ᴮ_ : ∀ {n} (p q : Bits n) → Set where
  []    : [] ≤ᴮ []
  there : ∀ {n} {p q : Bits n} b → p ≤ᴮ q → (b ∷ p) ≤ᴮ (b ∷ q)
  0-1   : ∀ {n} (p q : Bits n) → 0∷ p ≤ᴮ 1∷ q

toℕ-≤-inj : ∀ {n} (x y : Bits n) → toℕ x ≤ toℕ y → x ≤ᴮ y
toℕ-≤-inj     [] [] p = []
toℕ-≤-inj         (0b ∷ xs) (0b ∷ ys) p = there 0b (toℕ-≤-inj xs ys p)
toℕ-≤-inj         (0b ∷ xs) (1b ∷ ys) p = 0-1 _ _
toℕ-≤-inj {suc n} (1b ∷ xs) (0b ∷ ys) p = ⊥-elim (2ⁿ+≰toℕ ys p)
toℕ-≤-inj {suc n} (1b ∷ xs) (1b ∷ ys) p = there 1b (toℕ-≤-inj xs ys (+-≤-inj (2^ n) p))

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ {zero}  _ = []
fromℕ {suc n} x = if 2^ n <= x then 1∷ fromℕ (x ∸ 2^ n) else 0∷ fromℕ x

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 (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} (drop (2^ n) tbl)
        = take-drop-lem (2^ n) tbl

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

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

2ⁿ≰toℕ : ∀ {n} (xs : Bits n) → 2^ n ≰ toℕ xs
2ⁿ≰toℕ xs p = ¬n≤x<n _ p (toℕ-bound xs)

Tnot2ⁿ<=toℕ : ∀ {n} (xs : Bits n) → T (not (2^ n ℕ<= (toℕ xs)))
Tnot2ⁿ<=toℕ {n} xs with (2^ n) ℕ<= (toℕ xs) | ≡.inspect (_ℕ<=_ (2^ n)) (toℕ xs)
... | true  | [ p ] = 2ⁿ≰toℕ xs (ℕ<=.sound (2^ n) (toℕ xs) (≡→T p))
... | false |   _   = _

fromℕ∘toℕ : ∀ {n} (x : Bits n) → fromℕ (toℕ x) ≡ x
fromℕ∘toℕ [] = ≡.refl
fromℕ∘toℕ {suc n} (true ∷ xs)
  rewrite T→≡ (<=-steps′ {2^ n} (toℕ xs))
        | ℕ°.+-comm (2^ n) (toℕ xs)
        | m+n∸n≡m (toℕ xs) (2^ n)
        | fromℕ∘toℕ xs
        = ≡.refl
fromℕ∘toℕ (false ∷ xs)
  rewrite Tnot→≡ (Tnot2ⁿ<=toℕ xs)
        | fromℕ∘toℕ xs
        = ≡.refl

toℕ∘fromℕ : ∀ {n} x → x ℕ< 2^ n → toℕ {n} (fromℕ x) ≡ x
toℕ∘fromℕ {zero} .0 (s≤s z≤n) = ≡.refl
toℕ∘fromℕ {suc n} x x<2ⁿ with 2^ n ℕ<= x | ≡.inspect (_ℕ<=_ (2^ n)) x
... | true  | [ p ] rewrite toℕ∘fromℕ {n} (x ∸ 2^ n) (x<2y→x∸y<y x (2^ n) x<2ⁿ) = m+n∸m≡n {2^ n} {x} (ℕ<=.sound (2^ n) x (≡→T p))
... | false | [ p ] = toℕ∘fromℕ {n} x (ℕ<=.sound (suc x) (2^ n) (not<=→< (2^ n) x (≡→Tnot p)))

fromℕ-inj : ∀ {n} {x y : ℕ} → x ℕ< 2^ n → y ℕ< 2^ n → fromℕ {n} x ≡ fromℕ y → x ≡ y
fromℕ-inj {n} {x} {y} x< y< fx≡fy
  = x
  ≡⟨ ≡.sym (toℕ∘fromℕ {n} x x<) ⟩
    toℕ (fromℕ {n} x)
  ≡⟨ ≡.cong toℕ fx≡fy ⟩
    toℕ (fromℕ {n} y)
  ≡⟨ toℕ∘fromℕ {n} y y< ⟩
    y
  ∎ where open ≡-Reasoning

open Defs public


Add --allow-unsolved-metas to avoid CI failures

{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.BigStep where

open import Thesis.Syntax hiding (suc)
open import Thesis.Lang hiding (⟦_⟧Context; ⟦_⟧Var; suc)

open import Relation.Binary.PropositionalEquality

-- open import Base.Syntax.Context Type public
-- open import Base.Syntax.Vars Type public

-- data Const : (τ : Type) → Set where
--   lit : ℤ → Const int
--   -- succ : Const (int ⇒ int)

-- data Term (Γ : Context) :
--   (τ : Type) → Set where
--   -- constants aka. primitives
--   const : ∀ {τ} →
--     (c : Const τ) →
--     Term Γ τ
--   var : ∀ {τ} →
--     (x : Var Γ τ) →
--     Term Γ τ
--   app : ∀ {σ τ}
--     (s : Term Γ (σ ⇒ τ)) →
--     (t : Term Γ σ) →
--     Term Γ τ
--   -- we use de Bruijn indices, so we don't need binding occurrences.
--   abs : ∀ {σ τ}
--     (t : Term (σ • Γ) τ) →
--     Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public
open import Data.Nat using (ℕ; zero; suc; decTotalOrder)

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℤ) → Val int
  -- prim : ∀ {σ τ} → (f : Val σ → Val τ) → Val (σ ⇒ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⇒ τ ⟧Type) → Val (σ ⇒ τ)
  pairV : ∀ {σ τ} → Val σ → Val τ → Val (pair σ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⟧Type → Val τ) → Val (σ ⇒ τ)

-- TODO: add defunctionalized interpretations for primitives. Yes, annoying but mechanical.

-- Doesn't work
-- data Val2 : ℕ → Type → Set where
--   prim : ∀ {σ τ n} → (f : Val2 n σ → Val2 n τ) → Val2 (ℕ.suc n) (σ ⇒ τ)

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ intV n ⟧Val = n
-- ⟦ prim f ⟧Val = λ v → ⟦ f v ⟧Val
⟦ pairV a b ⟧Val = (⟦ a ⟧Val , ⟦ b ⟧Val)
-- ⟦ true ⟧Val = true
-- ⟦ false ⟧Val = false

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)
evalConst c n = {!!}

-- evalConst plus n = Done (prim (λ a → prim (λ b → intV (a + b))))
-- evalConst minus n = Done (prim (λ a → prim (λ b → intV (a - b))))
-- evalConst cons n = Done (prim (λ a → prim (λ b → {!pairV !})))
-- evalConst fst n = {!!}
-- evalConst snd n = {!!}
-- evalConst linj n = {!!}
-- evalConst rinj n = {!!}
-- evalConst match n = {!!}
-- evalConst zero = intV (+ 0)
-- evalConst succ = {!!}

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n
-- apply (prim f) a n = Done (f ⟦ a ⟧Val)

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut
-- eval t0 ρ (suc n) with t0
-- ... | const c = evalConst c n
-- ... | var x = Done (⟦ x ⟧Var ρ)
-- ... | abs t = Done (closure t ρ)
-- ... | app s t with eval s ρ n | eval t ρ n
-- ... | Done f | Done a = apply f a n
-- ... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool!
eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
  eval t ρ n ≡ Done v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
  ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
  apply f a n ≡ Done v →
  ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

eval-sound ρ v zero t ()
eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
  let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}

-- Next, we can try defining change structures and validity.

dapply : ∀ {σ τ} → Val (Δt (σ ⇒ τ)) → Val σ → Val (Δt σ) → Res (Δt τ)
dapply df a1 da zero = TimeOut
dapply df a1 da (suc zero) = TimeOut
dapply df a1 da (suc (suc n)) with apply df a1 n
... | Done dfa = apply dfa da (suc n)
... | TimeOut = TimeOut

-- apply (closure (abs (derive t)) dρ) a1 (suc (suc n))
-- eval (derive (abs t)) dρ (suc n) ≡
-- dapply-sound-0
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) n

dapply' : ∀ {σ τ} → ErrVal (Δt (σ ⇒ τ)) → ErrVal σ → ErrVal (Δt σ) → Res (Δt τ)
dapply' (Done df) (Done v) (Done dv) n = dapply df v dv n
dapply' _ _ _ _ = TimeOut

-- Which step-indexes should we use in dapply's specification and
-- implementation? That's highly non-obvious. To come up with them, I had to
-- step through the evaluation of eval (app (app ds t) dt), and verify that I
-- never invoke eval or apply on the same inputs at different step-indexes.
--
-- However, I expect I wouldn't be able to get a working proof if I got the
-- indexes wrong.
dapply-sound : ∀ {Γ σ τ} n ρ (ds : Term Γ (Δt (σ ⇒ τ))) t dt →
    eval (app (app ds t) dt) ρ (suc (suc n))
  ≡
    dapply' (eval ds ρ n) (eval t ρ n) (eval dt ρ (suc n)) (suc (suc n))
dapply-sound zero ρ ds t dt = refl
dapply-sound (suc n) ρ ds t dt with
  eval ds ρ (suc n) | eval t ρ (suc n) | eval dt ρ (suc (suc n))
dapply-sound (suc n) ρ ds t dt | Done df | Done v | Done dv with apply df v (suc n)
... | Done dfv = refl
... | TimeOut  = refl
dapply-sound (suc n) ρ ds t dt | Done df | Done v | TimeOut with apply df v (suc n)
... | Done dfv = refl
... | TimeOut = refl
dapply-sound (suc n) ρ ds t dt | Done df | TimeOut | dv = refl
dapply-sound (suc n) ρ ds t dt | TimeOut | v | dv = refl

open import Data.Empty
open import Data.Unit

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
deriveConst = {!!}

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

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

-- open import Thesis.Derive
Chτ : Type → Set
Chτ τ = Val (Δt τ)

deval : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → Res (Δt τ)
deval t ρ dρ = eval (derive t) dρ

dapply-equiv : ∀ {Γ σ τ} n
  (t : Term (σ • Γ) τ)
  (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 : Val σ) →
  dapply (closure (abs (derive t)) dρ) a1 da (suc (suc (suc n))) ≡
  eval (derive t) (da • a1 • dρ) (suc (suc n))
dapply-equiv n t dρ ρ1 da a1 = refl

-- Target statement:

_[_]τ_from_to_ : (n : ℕ) → ∀ τ → Val (Δt τ) → Val τ → Val τ → Set
_[_]τ'_from_to_ : (n : ℕ) → ∀ τ → ErrVal (Δt τ) → ErrVal τ → ErrVal τ → Set
n [ τ ]τ' Done dv from Done v1 to Done v2 = n [ τ ]τ dv from v1 to v2
n [ τ ]τ' TimeOut from Done v1 to Done v2 = ⊥
n [ τ ]τ' dv from _ to _ = ⊤

open import Data.Nat.Base using (_<_)

-- XXX: This is a lie for now, but all papers agree we'll want this in the end.
_[_]τmono_from_to : (n : ℕ) → ∀ τ → (dv : Val (Δt τ)) →
  ∀ v1 v2 n' →
  n' < n →
  n [ τ ]τ dv from v1 to v2 →
  n' [ τ ]τ dv from v1 to v2
_[_]τmono_from_to = {!!}

_[_]τ'_fromToTimeOut : ∀ n τ edv → n [ τ ]τ' edv from TimeOut to TimeOut ≡ ⊤
n [ τ ]τ' Done v fromToTimeOut = refl
n [ τ ]τ' TimeOut fromToTimeOut = refl
-- n [ τ ]τ' dv from Done v1 to TimeOut = ⊤
-- n [ τ ]τ' dv from TimeOut to Done v2 = ⊤
-- n [ τ ]τ' dv from TimeOut to TimeOut = ⊤

-- In the static-caching paper, the specification we use is similar to this one:
-- n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
--    Σ[ dv ∈ Val (Δt τ) ]
--        dapply df a1 da n ≡ Done dv
--      × n [ τ ]τ dv from v1 to v2
-- I defined _[_]τ'_from_to_ to be able to write an equivalent (hopefully) specification more quickly.

zero [ τ ]τ dv from v1 to v2 = ⊤
-- suc n [ σ ⇒ τ ]τ df from f1 to f2 =
--   ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    n [ τ ]τ' dapply df a1 da n from apply f1 a1 n to apply f2 a2 n

suc n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
   suc n [ σ ]τ da from a1 to a2 →

-- This definition violates all tips from Pitts tutorial (Step-Indexed
-- Biorthogonality: a Tutorial Example). Compare with Definition 4.1,
-- equation (10), and remark 4.4.
--
-- For extra complication, the setting is rather different, so a direct
-- comparison doesn't quite work.
   ∀ v1 v2 → apply f1 a1 (suc n) ≡ Done v1 → apply f2 a2 (suc n) ≡ Done v2 →
   Σ[ dv ∈ Val (Δt τ) ]
       dapply df a1 da (suc (suc n)) ≡ Done dv
     × n [ τ ]τ dv from v1 to v2

suc n [ int ]τ intV dn from intV n1 to intV n2 = n1 + dn ≡ n2
suc n [ pair σ τ ]τ pairV da db from pairV a1 b1 to pairV a2 b2 =
  suc n [ σ ]τ da from a1 to a2 × suc n [ τ ]τ db from b1 to b2
suc n [ sum σ τ ]τ () from v1 to v2

data _[_]Γ_from_to_ : ∀ ℕ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : ∀ {n} → n [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {n τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : n [ τ ]τ dv from v1 to v2) →
    (dρρ : n [ Γ ]Γ dρ from ρ1 to ρ2) →
    n [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

fromtoDeriveVar : ∀ {Γ} τ n → (x : Var Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ (⟦ deriveVar x ⟧Var dρ) from ⟦ x ⟧Var ρ1 to ⟦ x ⟧Var ρ2
fromtoDeriveVar τ n this (dv • .(v1 • _)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = dvv
fromtoDeriveVar τ n (that x) (dv • (.v1 • dρ)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = fromtoDeriveVar τ n x dρ ρ1 ρ2 dρρ

open import Relation.Binary hiding (_⇒_)
foo : ∀ {Γ σ τ v1 v2 dv} n (t : Term (σ • Γ) τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 a2 : Val σ) →
  (eqv1 : eval t (a1 • ρ1) (suc (suc n)) ≡ Done v1) →
  (eqv2 : eval t (a2 • ρ2) (suc (suc n)) ≡ Done v2) →
  (eqvv : eval (derive t) (da • a1 • dρ) (suc (suc n)) ≡ Done dv) →
  suc (suc n) [ τ ]τ' eval (derive t) (da • a1 • dρ) (suc (suc n)) from
      eval t (a1 • ρ1) (suc (suc n)) to eval t (a2 • ρ2) (suc (suc n)) →
  suc n [ τ ]τ dv from v1 to v2
foo n t dρ ρ1 ρ2 da a1 a2 eqv1 eqv2 eqvv dvv with eval t (a1 • ρ1) (suc (suc n)) | eval t (a2 • ρ2) (suc (suc n)) | eval (derive t) (da • a1 • dρ) (suc (suc n))
foo n t dρ ρ1 ρ2 da a1 a2 refl refl refl dvv | Done v1 | (Done v2) | (Done dv) = _[_]τmono_from_to (suc (suc n)) _ dv v1 v2 (suc n) (DecTotalOrder.reflexive Data.Nat.decTotalOrder refl) dvv
foo n t dρ ρ1 ρ2 da a1 a2 refl refl () dvv | Done v₁ | (Done v) | TimeOut
foo n t dρ ρ1 ρ2 da a1 a2 refl () eqvv dvv | Done v | TimeOut | s
foo n t dρ ρ1 ρ2 da a1 a2 () eqv2 eqvv dvv | TimeOut | r | s
-- q r s eqv1 eqv2 eqvv

fromtoDerive : ∀ {Γ} τ n → (t : Term Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ' (deval t ρ1 dρ n) from eval t ρ1 n to eval t ρ2 n
fromtoDerive τ zero t dρ ρ1 ρ2 dρρ rewrite zero [ τ ]τ' (deval t ρ1 dρ (suc zero)) fromToTimeOut = tt
fromtoDerive τ (suc n) (const c) dρ ρ1 ρ2 dρρ = {!!}
fromtoDerive τ (suc n) (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar τ (suc n) x dρ ρ1 ρ2 dρρ
fromtoDerive τ (suc n) (app s t) dρ ρ1 ρ2 dρρ = {!!}
-- fromtoDerive (σ ⇒ τ) (suc n) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   rewrite dapply-equiv n t dρ ρ1 da a1 =
--   fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ)
fromtoDerive (σ ⇒ τ) (suc zero) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 = {!!}
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 with
  eval (derive t) (da • a1 • dρ) (suc (suc n)) | inspect (eval (derive t) (da • a1 • dρ)) (suc (suc n))
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 | Done dv | [ eqvv ] = dv , refl , foo n t  dρ ρ1 ρ2 da a1 a2 eqv1 eqv2 eqvv (fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ))
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 | TimeOut | eq = {!!}
-- {!eval (derive t)!} , {!fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) ?!}

-- fromtoDerive (σ ⇒ τ) (suc (suc zero)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa = {!!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   with eval (abs (derive t)) (a1 • dρ) n | inspect (eval (abs (derive t)) (a1 • dρ)) n
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | Done v | [ eq ] = {!fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) _!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | TimeOut | _ = {!!}
-- --   fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• ?)
-- -- fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}
--   -- fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}


Fixe doc.

Fixe doc.

------------------------------------------------------------------------------
-- Properties of the Collatz function
------------------------------------------------------------------------------

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

module FOTC.Program.Collatz.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.PropertiesATP using ( ∸-N )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP using ( 2-N )
open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.PropertiesATP

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

helper : ∀ {n} → N n → collatz (2' ^ succ₁ n) ≡ collatz (2' ^ n)
helper nzero = prf
  where postulate prf : collatz (2' ^ succ₁ zero) ≡ collatz (2' ^ zero)
        {-# ATP prove prf #-}
helper (nsucc {n} Nn) = prf
  where postulate prf : collatz (2' ^ succ₁ (succ₁ n)) ≡ collatz (2' ^ succ₁ n)
        {-# ATP prove prf +∸2 ^-N 2-N 2^x≢0 2^[x+1]≢1 div-2^[x+1]-2≡2^x x-Even→SSx-Even ∸-N ∸-Even 2^[x+1]-Even 2-Even #-}

collatz-2^x : ∀ {n} → N n → collatz (2' ^ n) ≡ 1'
collatz-2^x nzero = prf
  where postulate prf : collatz (2' ^ 0') ≡ 1'
        {-# ATP prove prf #-}

collatz-2^x (nsucc {n} Nn) = prf (collatz-2^x Nn)
  where postulate prf : collatz (2' ^ n) ≡ 1' → collatz (2' ^ succ₁ n) ≡ 1'
        {-# ATP prove prf helper #-}

------------------------------------------------------------------------------
-- Properties of the Collatz function
------------------------------------------------------------------------------

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

module FOTC.Program.Collatz.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.PropertiesATP using ( ∸-N )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP using ( 2-N )
open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.PropertiesATP

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

helper : ∀ {n} → N n → collatz (2' ^ succ₁ n) ≡ collatz (2' ^ n)
helper nzero = prf
  where postulate prf : collatz (2' ^ succ₁ zero) ≡ collatz (2' ^ zero)
        {-# ATP prove prf #-}
helper (nsucc {n} Nn) = prf
  -- 18 December 2012: The ATPs could not prove the theorem (240 sec).
  where postulate prf : collatz (2' ^ succ₁ (succ₁ n)) ≡ collatz (2' ^ succ₁ n)
        {-# ATP prove prf +∸2 ^-N 2-N 2^x≢0 2^[x+1]≢1 div-2^[x+1]-2≡2^x x-Even→SSx-Even ∸-N ∸-Even 2^[x+1]-Even 2-Even #-}

collatz-2^x : ∀ {n} → N n → collatz (2' ^ n) ≡ 1'
collatz-2^x nzero = prf
  where postulate prf : collatz (2' ^ 0') ≡ 1'
        {-# ATP prove prf #-}

collatz-2^x (nsucc {n} Nn) = prf (collatz-2^x Nn)
  where postulate prf : collatz (2' ^ n) ≡ 1' → collatz (2' ^ succ₁ n) ≡ 1'
        {-# ATP prove prf helper #-}


update crypto-agda.agda

update crypto-agda.agda

module crypto-agda where
import Attack.Compression
import Attack.Reencryption
import Attack.Reencryption.OneBitMessage
import Cipher.ElGamal.Generic
import Cipher.ElGamal.Homomorphic
import Composition.Forkable
import Composition.Horizontal
import Composition.Vertical
import Crypto.Schemes
import FiniteField.FinImplem
import FunUniverse.Agda
import FunUniverse.BinTree
import FunUniverse.Bits
import FunUniverse.Category
import FunUniverse.Category.Op
import FunUniverse.Circuit
import FunUniverse.Const
import FunUniverse.Core
import FunUniverse.Cost
import FunUniverse.Data
import FunUniverse.Defaults.FirstPart
import FunUniverse.ExnArrow
import FunUniverse.Fin
import FunUniverse.Fin.Op
import FunUniverse.Fin.Op.Abstract
import FunUniverse.FlatFunsProd
import FunUniverse.Interface.Bits
import FunUniverse.Interface.Two
import FunUniverse.Interface.Vec
import FunUniverse.Inverse
import FunUniverse.Loop
import FunUniverse.Nand
import FunUniverse.Nand.Function
import FunUniverse.Nand.Properties
import FunUniverse.README
import FunUniverse.Rewiring.Linear
import FunUniverse.State
import FunUniverse.Syntax
import FunUniverse.Types
import Game.DDH
import Game.EntropySmoothing
import Game.EntropySmoothing.WithKey
import Game.IND-CCA
import Game.IND-CCA2-dagger
import Game.IND-CCA2
import Game.IND-CPA
import Game.Transformation.CCA-CPA
import Game.Transformation.CCA2-CCA
import Game.Transformation.CCA2-CCA2d
import Game.Transformation.CCA2d-CCA2
import Game.Transformation.InternalExternal
import Language.Simple.Abstract
import Language.Simple.Interface
import Language.Simple.Two.Mux
import Language.Simple.Two.Mux.Normalise
import Language.Simple.Two.Nand
import README
import Solver.AddMax
import Solver.Linear
import Solver.Linear.Examples
import Solver.Linear.Parser
import Solver.Linear.Syntax
import adder
import alea.cpo
import bijection-syntax.Bijection-Fin
import bijection-syntax.Bijection
import bijection-syntax.README
import circuits.bytecode
import circuits.circuit
import elgamal
import sha1

module crypto-agda where
import Cipher.ElGamal.Generic
import Composition.Forkable
import Composition.Horizontal
import Composition.Vertical
import Crypto.Schemes
--import FiniteField.FinImplem
import FunUniverse.Agda
import FunUniverse.BinTree
import FunUniverse.Bits
import FunUniverse.Category
import FunUniverse.Category.Op
import FunUniverse.Circuit
import FunUniverse.Const
import FunUniverse.Core
import FunUniverse.Cost
import FunUniverse.Data
import FunUniverse.Defaults.FirstPart
--import FunUniverse.ExnArrow
import FunUniverse.Fin
import FunUniverse.Fin.Op
import FunUniverse.Fin.Op.Abstract
--import FunUniverse.FlatFunsProd
--import FunUniverse.Interface.Bits
import FunUniverse.Interface.Two
import FunUniverse.Interface.Vec
import FunUniverse.Inverse
--import FunUniverse.Loop
import FunUniverse.Nand
import FunUniverse.Nand.Function
import FunUniverse.Nand.Properties
import FunUniverse.README
import FunUniverse.Rewiring.Linear
--import FunUniverse.State
import FunUniverse.Syntax
import FunUniverse.Types
import Game.DDH
import Game.EntropySmoothing
import Game.EntropySmoothing.WithKey
import Game.IND-CPA
import Game.Transformation.InternalExternal
import Language.Simple.Abstract
import Language.Simple.Interface
import Language.Simple.Two.Mux
import Language.Simple.Two.Mux.Normalise
import Language.Simple.Two.Nand
import README
import Solver.AddMax
import Solver.Linear
--import Solver.Linear.Examples
import Solver.Linear.Parser
import Solver.Linear.Syntax
import adder
import alea.cpo
import bijection-syntax.Bijection-Fin
import bijection-syntax.Bijection
import bijection-syntax.README
--import circuits.bytecode
import circuits.circuit
--import elgamal
--import sha1


SyntaxKit renamings

SyntaxKit renamings

module Function.Bijection.SyntaxKit where

open import Type hiding (★)
open import Level.NP using (₀; ₛ; _⊔_)
open import Function.NP
open import Data.One
open import Data.Two
open import Data.Bool.Properties
open import Relation.Binary.PropositionalEquality

record BijKit b {a} (A : ★ a) : ★ (ₛ b ⊔ a) where
  constructor mk
  field
    Bij   : ★ b
    eval  : Bij → Endo A
    _⁻¹   : Endo Bij
    idBij : Bij
    _⁏Bij_ : Bij → Bij → Bij

  eval⁻¹ : Bij → Endo A
  eval⁻¹ f = eval (f ⁻¹)

  _≗Bij_ : Bij → Bij → ★ _
  _≗Bij_ = λ f g → ∀ (x : A) → eval f x ≡ eval g x

  field
    id-spec : eval idBij ≗ id
    _⁏-spec_ : ∀ f g → eval (f ⁏Bij g) ≗ eval g ∘ eval f

    _⁻¹-inverse : ∀ f → eval (f ⁻¹) ∘ eval f ≗ id
    _⁻¹-involutive : ∀ f → (f ⁻¹) ⁻¹ ≗Bij f

  _⁻¹-inverseBij : ∀ f → (f ⁏Bij f ⁻¹) ≗Bij idBij
  (f ⁻¹-inverseBij) x rewrite (f ⁏-spec (f ⁻¹)) x
                            | id-spec x
                            | (f ⁻¹-inverse)
                            x = refl

  _⁻¹-inverse′ : ∀ f → (eval f ∘ eval (f ⁻¹)) ≗ id
  (f ⁻¹-inverse′) x with ((f ⁻¹) ⁻¹-inverse) x
  ... | p rewrite (f ⁻¹-involutive) (eval (f ⁻¹) x) = p

  _⁻¹-inverseBij′ : ∀ f → (f ⁻¹ ⁏Bij f) ≗Bij idBij
  (f ⁻¹-inverseBij′) x rewrite (f ⁻¹ ⁏-spec f) x
                             | id-spec x
                             | (f ⁻¹-inverse′)
                            x = refl

module 𝟚Bijection where
  data 𝟚Bij : ★₀ where
    `id `not : 𝟚Bij

  bool-bijKit : BijKit ₀ 𝟚
  bool-bijKit = mk 𝟚Bij eval id `id _⁏Bij_ (λ _ → refl) _⁏-spec_ _⁻¹-inverse (λ _ _ → refl)
   module BBK where
    eval  : 𝟚Bij → Endo 𝟚
    eval `id = id
    eval `not = not

    _⁏Bij_ : 𝟚Bij → 𝟚Bij → 𝟚Bij
    `id  ⁏Bij g    = g
    f    ⁏Bij `id  = f
    `not ⁏Bij `not = `id

    _⁏-spec_ : ∀ f g → eval (f ⁏Bij g) ≗ eval g ∘ eval f
    `id  ⁏-spec g    = λ _ → refl
    `not ⁏-spec `id  = λ _ → refl
    `not ⁏-spec `not = sym ∘ not-involutive

    _⁻¹-inverse : ∀ f → eval f ∘ eval f ≗ id
    (`id  ⁻¹-inverse) = λ _ → refl
    (`not ⁻¹-inverse) = not-involutive

  module 𝟚BijKit = BijKit bool-bijKit

  -- `xor can be seen as a from𝟚 function
  `xor : 𝟚 → 𝟚Bij
  `xor 0₂ = `id
  `xor 1₂ = `not

  -- `not? can be seen as a to𝟚 function
  `not? : 𝟚Bij → 𝟚
  `not? `id  = 0₂
  `not? `not = 1₂

  `xor∘`not? : `xor ∘ `not? ≗ id
  `xor∘`not? `id = refl
  `xor∘`not? `not = refl

  `not?∘`xor : `not? ∘ `xor ≗ id
  `not?∘`xor 1₂ = refl
  `not?∘`xor 0₂ = refl

module 1-Bijection {a} (A : ★ a) where
    1-bij : BijKit ₀ A
    1-bij = mk 𝟙 (λ _ → id) _ _ _ (λ _ → refl) (λ _ _ _ → refl) (λ _ _ → refl) (λ _ _ → refl)

    module 1-BijKit = BijKit 1-bij

module 𝟙Bijection where
    open 1-Bijection
    𝟙-bijKit : BijKit ₀ 𝟙
    𝟙-bijKit = 1-bij 𝟙

    module 𝟙BijKit = 1-BijKit 𝟙

module Function.Bijection.SyntaxKit where

open import Type hiding (★)
open import Level.NP using (₀; ₛ; _⊔_)
open import Function.NP
open import Data.One
open import Data.Two
open import Data.Bool.Properties
open import Relation.Binary.PropositionalEquality

record BijKit b {a} (A : ★ a) : ★ (ₛ b ⊔ a) where
  constructor mk
  field
    Bij   : ★ b
    eval  : Bij → Endo A
    _⁻¹   : Endo Bij
    idBij : Bij
    _⁏Bij_ : Bij → Bij → Bij

  eval⁻¹ : Bij → Endo A
  eval⁻¹ f = eval (f ⁻¹)

  _≗Bij_ : Bij → Bij → ★ _
  _≗Bij_ = λ f g → ∀ (x : A) → eval f x ≡ eval g x

  field
    id-spec : eval idBij ≗ id
    _⁏-spec_ : ∀ f g → eval (f ⁏Bij g) ≗ eval g ∘ eval f

    _⁻¹-inverse : ∀ f → eval (f ⁻¹) ∘ eval f ≗ id
    _⁻¹-involutive : ∀ f → (f ⁻¹) ⁻¹ ≗Bij f

  _⁻¹-inverseBij : ∀ f → (f ⁏Bij f ⁻¹) ≗Bij idBij
  (f ⁻¹-inverseBij) x rewrite (f ⁏-spec (f ⁻¹)) x
                            | id-spec x
                            | (f ⁻¹-inverse)
                            x = refl

  _⁻¹-inverse′ : ∀ f → (eval f ∘ eval (f ⁻¹)) ≗ id
  (f ⁻¹-inverse′) x with ((f ⁻¹) ⁻¹-inverse) x
  ... | p rewrite (f ⁻¹-involutive) (eval (f ⁻¹) x) = p

  _⁻¹-inverseBij′ : ∀ f → (f ⁻¹ ⁏Bij f) ≗Bij idBij
  (f ⁻¹-inverseBij′) x rewrite (f ⁻¹ ⁏-spec f) x
                             | id-spec x
                             | (f ⁻¹-inverse′)
                            x = refl

module BoolBijection where
  data BoolBij : ★₀ where
    `id `not : BoolBij

  bool-bijKit : BijKit ₀ Bool
  bool-bijKit = mk BoolBij eval id `id _⁏Bij_ (λ _ → refl) _⁏-spec_ _⁻¹-inverse (λ _ _ → refl)
   module BBK where
    eval  : BoolBij → Endo Bool
    eval `id = id
    eval `not = not

    _⁏Bij_ : BoolBij → BoolBij → BoolBij
    `id  ⁏Bij g    = g
    f    ⁏Bij `id  = f
    `not ⁏Bij `not = `id

    _⁏-spec_ : ∀ f g → eval (f ⁏Bij g) ≗ eval g ∘ eval f
    `id  ⁏-spec g    = λ _ → refl
    `not ⁏-spec `id  = λ _ → refl
    `not ⁏-spec `not = sym ∘ not-involutive

    _⁻¹-inverse : ∀ f → eval f ∘ eval f ≗ id
    (`id  ⁻¹-inverse) = λ _ → refl
    (`not ⁻¹-inverse) = not-involutive

  module BoolBijKit = BijKit bool-bijKit

  -- `xor can be seen as a fromBool function
  `xor : Bool → BoolBij
  `xor 0₂ = `id
  `xor 1₂ = `not

  -- `not? can be seen as a toBool function
  `not? : BoolBij → Bool
  `not? `id  = 0₂
  `not? `not = 1₂

  `xor∘`not? : `xor ∘ `not? ≗ id
  `xor∘`not? `id = refl
  `xor∘`not? `not = refl

  `not?∘`xor : `not? ∘ `xor ≗ id
  `not?∘`xor 1₂ = refl
  `not?∘`xor 0₂ = refl

module 1-Bijection {a} (A : ★ a) where
    1-bij : BijKit ₀ A
    1-bij = mk 𝟙 (λ _ → id) _ _ _ (λ _ → refl) (λ _ _ _ → refl) (λ _ _ → refl) (λ _ _ → refl)

    module 1-BijKit = BijKit 1-bij

module 𝟙Bijection where
    open 1-Bijection
    𝟙-bijKit : BijKit ₀ 𝟙
    𝟙-bijKit = 1-bij 𝟙

    module 𝟙BijKit = 1-BijKit 𝟙