Bits: + sum-≗₂

Bits: + sum-≗₂

module Data.Bits where

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

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

Bit : Set
Bit = Bool

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

Bits : ℕ → Set
Bits = Vec Bit

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

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

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

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

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

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

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

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

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

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

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

-- Negate all bits, i.e. "xor"ing them by one.
vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open M public

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

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

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 SimpleSearch {a} {A : Set a} (_·_ : A → A → A) where

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

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

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

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

    module Interchange (·-interchange : ∀ x y z t → (x · y) · (z · t) ≡ (x · z) · (y · t)) 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-+ : ∀ {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

        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

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

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

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

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

module Count where
    open Sum

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open SimpleSearch public
open Sum public
open Count public

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Defs public

module Data.Bits where

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

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

Bit : Set
Bit = Bool

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

Bits : ℕ → Set
Bits = Vec Bit

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

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

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

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

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

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

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

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

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

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

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

-- Negate all bits, i.e. "xor"ing them by one.
vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open M public

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

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

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 SimpleSearch {a} {A : Set a} (_·_ : A → A → A) where

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

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

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

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

    module Interchange (·-interchange : ∀ x y z t → (x · y) · (z · t) ≡ (x · z) · (y · t)) 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-+ : ∀ {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

        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

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

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

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

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

module Count where
    open Sum

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open SimpleSearch public
open Sum public
open Count public

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Defs public


Changed rev-ListTree by reverse-ListTree.

Ignore-this: 9fa338cf5a7edf48fcacfde2c78cde76

darcs-hash:20110220160725-3bd4e-56827edae047bdc954128142183b060ef4dcd4d8.gz

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

module Draft.Mirror.PropertiesI where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesI
open import Draft.Mirror.ListTree.Closures
open import Draft.Mirror.Tree.Closures

open import LTC.Data.List
open import LTC.Data.List.PropertiesI using ( reverse-[x]≡[x] )

open import LTC.Relation.Binary.EqReasoning

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

mutual
  mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
  mirror² (treeT d nilLT) =
    begin
      mirror · (mirror · (node d []))
        ≡⟨ subst (λ x → mirror · (mirror · (node d [])) ≡ mirror · x )
                 (mirror-eq d [])
                 refl
        ⟩
      mirror · node d (reverse (map mirror []))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror [])) ≡
                        mirror · node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      mirror · node d (reverse [])
        ≡⟨ subst (λ x → mirror · node d (reverse []) ≡ mirror · node d x)
                 (rev-[] [])
                 refl
        ⟩
      mirror · node d []
        ≡⟨ mirror-eq d [] ⟩
      node d (reverse (map mirror []))
        ≡⟨ subst (λ x → node d (reverse (map mirror [])) ≡
                        node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      node d (reverse [])
        ≡⟨ subst (λ x → node d (reverse []) ≡ node d x)
                 (rev-[] [])
                 refl
        ⟩
      node d []
    ∎

  mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
    begin
      mirror · (mirror · node d (t ∷ ts))
        ≡⟨ subst (λ x → mirror · (mirror · node d (t ∷ ts)) ≡ mirror · x)
                 (mirror-eq d (t ∷ ts))
                 refl
        ⟩
      mirror · node d (reverse (map mirror (t ∷ ts)))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror (t ∷ ts))) ≡
                        x)
                 (mirror-eq d (reverse (map mirror (t ∷ ts))))
                 refl
        ⟩
      node d (reverse (map mirror (reverse (map mirror (t ∷ ts)))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (reverse (map mirror (t ∷ ts))))) ≡
                      node d x)
               (helper (consLT Tt LTts))
               refl
      ⟩
      node d (t ∷ ts)
    ∎

  helper : ∀ {ts} → ListTree ts →
           reverse (map mirror (reverse (map mirror ts))) ≡ ts
  helper nilLT =
    begin
      reverse (map mirror (reverse (map mirror [])))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror []))) ≡
                        reverse (map mirror (reverse x)))
                 (map-[] mirror)
                 refl
        ⟩
      reverse (map mirror (reverse []))
        ≡⟨ subst (λ x → reverse (map mirror (reverse [])) ≡
                        reverse (map mirror x))
                 (rev-[] [])
                 refl
        ⟩
      reverse (map mirror [])
        ≡⟨ subst (λ x → reverse (map mirror []) ≡
                        reverse x)
                 (map-[] mirror)
                 refl
        ⟩
      reverse []
        ≡⟨ rev-[] [] ⟩
      []
    ∎

  helper (consLT {t} {ts} Tt LTts) =
    begin
      reverse (map mirror (reverse (map mirror (t ∷ ts))))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror (t ∷ ts)))) ≡
                        reverse (map mirror (reverse x)))
                 (map-∷ mirror t ts)
                 refl
        ⟩
      reverse (map mirror (reverse (mirror · t ∷ map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (mirror · t ∷ map mirror ts))) ≡
                        reverse (map mirror x))
                 (reverse-∷ (mirror-Tree Tt) (map-ListTree mirror mirror-Tree LTts))
                 refl
        ⟩
      reverse (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror · t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror
                   mirror-Tree
                   (reverse-ListTree (map-ListTree mirror mirror-Tree LTts))
                   (consLT (mirror-Tree Tt) nilLT))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror · t ∷ [])))) ≡
                        x)
                 (reverse-++-commute
                   (map-ListTree mirror mirror-Tree
                                 (reverse-ListTree
                                 (map-ListTree mirror mirror-Tree LTts)))
                   (map-ListTree mirror mirror-Tree
                                 (consLT (mirror-Tree Tt) nilLT)))
                 refl
        ⟩
      reverse (map mirror (mirror · t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (mirror · t ∷ [])) ++ n₁ ≡
                        reverse x ++ n₁)
                 (map-∷ mirror (mirror · t) [])
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁ ≡
                        reverse (mirror · (mirror · t) ∷ x) ++ n₁)
                 (map-[] mirror)
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ []) ++ n₁ ≡
                        x ++ n₁)
                 (reverse-[x]≡[x] (mirror · (mirror · t)))
                 refl
        ⟩
      (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ ++-∷ (mirror · (mirror · t)) [] n₁ ⟩
      mirror · (mirror · t) ∷ [] ++ n₁
        ≡⟨ subst (λ x →  mirror · (mirror · t) ∷ [] ++ n₁ ≡
                         mirror · (mirror · t) ∷ x)
                 (++-leftIdentity LTn₁)
                 refl
        ⟩
      mirror · (mirror · t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror · (mirror · t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² Tt)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (helper LTts)
                 refl
        ⟩
      t ∷ ts
    ∎
      where
        n₁ : D
        n₁ = reverse (map mirror (reverse (map mirror ts)))

        LTn₁ : ListTree n₁
        LTn₁ = rev-ListTree
                 (map-ListTree mirror mirror-Tree
                               (reverse-ListTree (map-ListTree mirror mirror-Tree LTts)))
                 nilLT

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

module Draft.Mirror.PropertiesI where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesI
open import Draft.Mirror.ListTree.Closures
open import Draft.Mirror.Tree.Closures

open import LTC.Data.List
open import LTC.Data.List.PropertiesI using ( reverse-[x]≡[x] )

open import LTC.Relation.Binary.EqReasoning

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

mutual
  mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
  mirror² (treeT d nilLT) =
    begin
      mirror · (mirror · (node d []))
        ≡⟨ subst (λ x → mirror · (mirror · (node d [])) ≡ mirror · x )
                 (mirror-eq d [])
                 refl
        ⟩
      mirror · node d (reverse (map mirror []))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror [])) ≡
                        mirror · node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      mirror · node d (reverse [])
        ≡⟨ subst (λ x → mirror · node d (reverse []) ≡ mirror · node d x)
                 (rev-[] [])
                 refl
        ⟩
      mirror · node d []
        ≡⟨ mirror-eq d [] ⟩
      node d (reverse (map mirror []))
        ≡⟨ subst (λ x → node d (reverse (map mirror [])) ≡
                        node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      node d (reverse [])
        ≡⟨ subst (λ x → node d (reverse []) ≡ node d x)
                 (rev-[] [])
                 refl
        ⟩
      node d []
    ∎

  mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
    begin
      mirror · (mirror · node d (t ∷ ts))
        ≡⟨ subst (λ x → mirror · (mirror · node d (t ∷ ts)) ≡ mirror · x)
                 (mirror-eq d (t ∷ ts))
                 refl
        ⟩
      mirror · node d (reverse (map mirror (t ∷ ts)))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror (t ∷ ts))) ≡
                        x)
                 (mirror-eq d (reverse (map mirror (t ∷ ts))))
                 refl
        ⟩
      node d (reverse (map mirror (reverse (map mirror (t ∷ ts)))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (reverse (map mirror (t ∷ ts))))) ≡
                      node d x)
               (helper (consLT Tt LTts))
               refl
      ⟩
      node d (t ∷ ts)
    ∎

  helper : ∀ {ts} → ListTree ts →
           reverse (map mirror (reverse (map mirror ts))) ≡ ts
  helper nilLT =
    begin
      reverse (map mirror (reverse (map mirror [])))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror []))) ≡
                        reverse (map mirror (reverse x)))
                 (map-[] mirror)
                 refl
        ⟩
      reverse (map mirror (reverse []))
        ≡⟨ subst (λ x → reverse (map mirror (reverse [])) ≡
                        reverse (map mirror x))
                 (rev-[] [])
                 refl
        ⟩
      reverse (map mirror [])
        ≡⟨ subst (λ x → reverse (map mirror []) ≡
                        reverse x)
                 (map-[] mirror)
                 refl
        ⟩
      reverse []
        ≡⟨ rev-[] [] ⟩
      []
    ∎

  helper (consLT {t} {ts} Tt LTts) =
    begin
      reverse (map mirror (reverse (map mirror (t ∷ ts))))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror (t ∷ ts)))) ≡
                        reverse (map mirror (reverse x)))
                 (map-∷ mirror t ts)
                 refl
        ⟩
      reverse (map mirror (reverse (mirror · t ∷ map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (mirror · t ∷ map mirror ts))) ≡
                        reverse (map mirror x))
                 (reverse-∷ (mirror-Tree Tt) (map-ListTree mirror mirror-Tree LTts))
                 refl
        ⟩
      reverse (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror · t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror
                   mirror-Tree
                   (rev-ListTree (map-ListTree mirror mirror-Tree LTts) nilLT)
                   (consLT (mirror-Tree Tt) nilLT))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror · t ∷ [])))) ≡
                        x)
                 (reverse-++-commute (map-ListTree mirror
                                           mirror-Tree
                                           (rev-ListTree (map-ListTree mirror
                                                                       mirror-Tree
                                                                       LTts)
                                                         nilLT))
                             (map-ListTree mirror
                                           mirror-Tree
                                           (consLT (mirror-Tree Tt) nilLT)))
                 refl
        ⟩
      reverse (map mirror (mirror · t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (mirror · t ∷ [])) ++ n₁ ≡
                        reverse x ++ n₁)
                 (map-∷ mirror (mirror · t) [])
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁ ≡
                        reverse (mirror · (mirror · t) ∷ x) ++ n₁)
                 (map-[] mirror)
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ []) ++ n₁ ≡
                        x ++ n₁)
                 (reverse-[x]≡[x] (mirror · (mirror · t)))
                 refl
        ⟩
      (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ ++-∷ (mirror · (mirror · t)) [] n₁ ⟩
      mirror · (mirror · t) ∷ [] ++ n₁
        ≡⟨ subst (λ x →  mirror · (mirror · t) ∷ [] ++ n₁ ≡
                         mirror · (mirror · t) ∷ x)
                 (++-leftIdentity LTn₁)
                 refl
        ⟩
      mirror · (mirror · t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror · (mirror · t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² Tt)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (helper LTts)
                 refl
        ⟩
      t ∷ ts
    ∎
      where
        n₁ : D
        n₁ = reverse (map mirror (reverse (map mirror ts)))

        LTn₁ : ListTree n₁
        LTn₁ = rev-ListTree (map-ListTree mirror
                                          mirror-Tree
                                          (rev-ListTree (map-ListTree mirror
                                                                      mirror-Tree
                                                                      LTts)
                                                        nilLT))
                            nilLT


Updated the alea stub

Updated the alea stub

{-# OPTIONS --copatterns #-}
module alea.cpo where

import Data.Nat.NP as Nat

import Relation.Binary.PropositionalEquality as ≡

record Order (A : Set) : Set₁ where
  constructor mk
  infix 4 _≡_ _≤_
  field
    _≤_ : A → A → Set
    _≡_ : A → A → Set
    reflexive : ∀ {x} → x ≤ x
    antisym : ∀ {x y} → x ≤ y → y ≤ x → x ≡ y
    transitive : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z

  ≡-reflexive : ∀ {x} → x ≡ x
  ≡-reflexive = antisym reflexive reflexive

ℕ : Order Nat.ℕ
ℕ = mk Nat._≤_ ≡._≡_ Nat.ℕ≤.refl Nat.ℕ≤.antisym Nat.ℕ≤.trans

funOrder : ∀ {A B : Set} → Order B → Order (A → B)
funOrder or = mk (λ f g  → ∀ x → f x ≤ g x) (λ f g → ∀ x → f x ≡ g x)
              (λ x₁ → reflexive)
              (λ f g x → antisym (f x) (g x))
              (λ f g x  → transitive (f x) (g x))
  where open Order or

_o→_ : ∀ A {B} → Order B → Order (A → B)
A o→ ob = funOrder {A} ob

record _→m_ {A B}(oa : Order A)(ob : Order B) : Set where
  coinductive
  constructor mk
  field
    _$_ : A → B
    .mon : ∀ {x y} → Order._≤_ oa x y → Order._≤_ ob (_$_ x) (_$_ y)
open _→m_ using (_$_ ; mon)

_o→m_ : ∀ {A B}(oa : Order A)(ob : Order B) → Order (oa →m ob)
_o→m_ {A} oa ob = mk (λ f g → _$_ f ≤ _$_ g)
                     (λ f g → _$_ f ≡ _$_ g)
                     reflexive antisym transitive
  where open Order (A o→ ob)

swapm : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
swapm f = mk (λ b → mk (λ a → (f $ a) $ b) (λ r → mon f r b )) (λ r x → mon (f $ x) r)

swapm' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
_$_ (_$_ (swapm' f) b) a = (f $ a) $ b
mon (_$_ (swapm' f) b) r = mon f r b
mon (swapm' f) r x = mon (f $ x) r

{-
swapm'' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
(swapm'' f $ b)    $ a = (f $ a) $ b
mon (swapm' f $ b) r   = mon f r b
mon (swapm' f)     r x = mon (f $ x) r
-}

_∘m_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
f ∘m g = mk (λ x → f $ (g $ x)) (λ x → mon f (mon g x))

_∘m'_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
_$_ (f ∘m' g) x = f $ (g $ x)
mon (f ∘m' g) x = mon f (mon g x)

_$m_ : ∀ {A B C}{oa : Order A}{oc : Order C}
       → oa →m (B o→ oc) → B → oa →m oc
_$m_ {oa = oa}{oc} f b = mk (λ a → (f $ a) b) (λ x≤y → mon f x≤y b )

_$m'_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$_ (f $m' b) a   = (f $ a) b
mon (f $m' b) x≤y = mon f x≤y b

UB : ∀ {A} → Order A → A → Set
UB or a = ∀ x → x ≤ a
  where open Order or

record cpo {D} (o : Order D) : Set where
  constructor mk
  open Order o

  field
    d0 : D
    lub : (f : ℕ →m o) → D

  -- proofs
  field
    .Dbot : ∀ x → d0 ≤ x
    .lubUB : ∀ (f : ℕ →m o) n → (f $ n) ≤ lub f
    .lubLUB : ∀ (f : ℕ →m o) x → (∀ n → (f $ n) ≤ x) → lub f ≤ x

  .lub-ext : ∀ {f g} → Order._≤_ (ℕ o→m o) f g → lub f ≤ lub g
  lub-ext {f} {g} f≤g = lubLUB f (lub g) (λ n → transitive (f≤g n) (lubUB g n))

  lubm : (ℕ o→m o) →m o
  lubm = mk lub (λ {a}{b} x₁ → lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁)

  lubm' : (ℕ o→m o) →m o
  _$_ lubm' = lub
  mon lubm' {a}{b} x₁ = lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁

module _ where
  .lub-swap : ∀ {D}{o : Order D}(c : cpo o)
             → let open cpo c
                   open Order o
               in ∀ f → lub (lubm ∘m f) ≤ lub (lubm ∘m swapm f)
  lub-swap {D}{o} c f = lubLUB (lubm ∘m f) (lub (lubm ∘m swapm f))
                     (λ n → lubLUB (f $ n) (lub (lubm ∘m swapm f))
                     (λ n₁ → transitive (lubUB (swapm f $ n₁) n) (lubUB (lubm ∘m swapm f) n₁)))
    where
      open cpo c
      open Order o

  funcpo : ∀ {A D}{od : Order D} → cpo od → cpo (A o→ od)
  funcpo {A}{D}{od}cpod = mk fbot flub fDbot flubUB flubLUB
    where
      module D = cpo cpod
      open Nat
      open ≡ using (_≡_)
      fbot : A → D
      fbot _ = D.d0
      flub : _ → _
      flub f = λ x → D.lub (f $m x)
      .fDbot : (_ : _) → _
      fDbot f = λ x → D.Dbot (f x)
      .flubUB : (_ : _) → _
      flubUB f = λ n x → D.lubUB (f $m x) n
      .flubLUB : (_ : _) → _
      flubLUB f = λ x x₁ x₂ → D.lubLUB (f $m x₂) (x x₂) (λ n → x₁ n x₂)

  _c→m_ : ∀ {A D}(oa : Order A){od : Order D} → cpo od → cpo (oa o→m od)
  _c→m_ {A} oa {od} cpod = mk (mk (λ x → d0) (λ x₁ → Order.reflexive od))
                          (λ f → mk (cpo.lub (funcpo {A} cpod)
                                       (mk (λ n a → (f $ n) $ a) (mon f)))
                                    (λ {x}{y}x≤y → lubLUB _ _ (λ n → transitive (mon (f $ n) x≤y) (lubUB (mk (λ v → (f $ v) $ y) (λ r → mon f r y)) n))))
                          (λ x x₁ → Dbot (x $ x₁))
                          (λ f n x → lubUB (mk (λ m → (f $ m) $ x) (λ x₂ → mon f x₂ x)) n)
                          (λ f x x₁ x₂ → lubLUB (mk (λ n → _$_ (f $ n)) (mon f) $m x₂) (x $ x₂) (λ n → x₁ n x₂))
    where
      open cpo cpod
      open Order od renaming (_≤_ to _≤ᵈ_)
      open Order oa using () renaming (_≤_ to _≤ᵃ_)

record continous {A B}{oa : Order A}{ob : Order B}
                 (c1 : cpo oa)(c2 : cpo ob)(f : oa →m ob) : Set where
  constructor mk
  open cpo c1 renaming (lub to luba ; lubUB to lubUBa ; lubLUB to lubLUBa)
  open cpo c2
  open Order ob
  field
    .contIntro : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≤ lub (f ∘m h)

  .contIntro' : ∀ (h : ℕ →m oa) → lub (f ∘m h) ≤ f $ luba h
  contIntro' h = lubLUB (f ∘m h) (f $ luba h) (λ n → mon f (lubUBa _ n))

  .contEq : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≡ lub (f ∘m h)
  contEq h = antisym (contIntro h) (contIntro' h)

open continous

module Distr
  (Ur  : Set) -- the set [0,1]
  (1/_+1 : Nat.ℕ → Ur)
  (_+_ : Ur → Ur → Ur)
  (_×_ : Ur → Ur → Ur)
  (oUr : Order Ur)
  (≤-cong-+ : let open Order oUr in ∀ {x y z w} → x ≤ z → y ≤ w → x + y ≤ z + w)
  (≤-cong-× : let open Order oUr in ∀ {x y z w} → x ≤ z → y ≤ w → x × y ≤ z × w)
  (U   : cpo oUr) where

  record distr A : Set where
    constructor mk
    field
      μ : (A o→ oUr) →m oUr
      .muContinous : ∀ (h : ℕ →m (A o→ oUr)) → Order._≤_ oUr (μ $ cpo.lub (funcpo U) h) (cpo.lub U (μ ∘m h)) -- continous (funcpo U) U μ

  open distr

  module _ A where
    module M = cpo ((A o→ oUr) c→m U)

    distrOrder : Order (distr A)
    distrOrder = mk (λ f g → μ f ≤ μ g) (λ f g → μ f ≡ μ g)
      (λ {x} → reflexive {μ x}) (λ {x} {y} → antisym {μ x} {μ y}) (λ {x} {y} {z} → transitive {μ x} {μ y} {μ z})
      where open Order ((A o→ oUr) o→m oUr)

    μm : distrOrder →m ((A o→ oUr) o→m oUr)
    μm = mk μ (λ x₁ x₂ → x₁ x₂)

    distrcpo : cpo distrOrder
    distrcpo = mk (mk M.d0 (λ h → cpo.Dbot U (cpo.lub U (M.d0 ∘m h))))

                    (λ f → mk (M.lub (μm ∘m f)) (λ h → transitive
                                                       (cpo.lub-ext U (λ a → muContinous (f $ a) h))
                                                       (lub-swap U (mk (λ z → mk (λ z₁ → μ (f $ z) $ (h $ z₁))
                                                                                (λ x → mon (μ (f $ z)) (mon h x)))
                                                                       (λ {x}{y} x₁ x₂ →
                                                                              mon f x₁ (λ x₃ → (h $ x₂) x₃))))))
                    (λ x x₁ → cpo.Dbot U (μ x $ x₁))
                    (λ f n x → cpo.lubUB U _ _ )
                    (λ f x x₁ x₂ → cpo.lubLUB U _ _ (λ n → x₁ n x₂))
       where open Order oUr

  module FIXPOINTS {d} {D : Order d} {c : cpo D} where
    open cpo c
    open Order D

    iter : (f : D →m D) → Nat.ℕ → d
    iter f Nat.zero = d0
    iter f (Nat.suc n) = f $ iter f n

    iter-mon : (f : D →m D) → ℕ →m D
    iter-mon f = mk (iter f) mono
      where
        .mono : ∀ {x y} → x Nat.≤ y → iter f x ≤ iter f y
        mono Nat.z≤n = Dbot _
        mono (Nat.s≤s prf) = mon f (mono prf)

    fix : (f : D →m D) → d
    fix f = lub (iter-mon f)

    .fix-le : (F : D →m D) → fix F ≤ F $ (fix F)
    fix-le F = lubLUB _ _ prf
      where
        .prf : (n : Nat.ℕ) → iter-mon F $ n ≤ F $ fix F
        prf Nat.zero = Dbot (F $ fix F)
        prf (Nat.suc n) = mon F (lubUB (iter-mon F) n)

  module _ where

    open Order oUr
    open cpo U
    open import Data.Bool

    postulate
      EXPLODE : ∀ {A : Set} → A

    flip : distr Bool
    _$_ (μ flip) f = (1/ 1 +1 × f true) + (1/ 1 +1 × f false)
    mon (μ flip) r = ≤-cong-+ (≤-cong-× reflexive (r true)) (≤-cong-× reflexive (r false))
    muContinous flip h = EXPLODE

    Munit : ∀ {A} → A → distr A
    Munit x = mk (mk (λ f → f x) (λ x≤y → x≤y x)) (λ h → reflexive)

    Mlet : ∀ {A B} → distr A → (A → distr B) → distr B
    Mlet m k = mk (mk (λ f → μ m $ (λ x → μ (k x) $ f)) (λ x≤y → mon (μ m) (λ x → mon (μ (k x)) x≤y)))
       (λ h →  transitive (mon (μ m) (λ x → muContinous (k x) h))
                   (muContinous m (mk (λ z z₁ → μ (k z₁) $ (h $ z)) (λ x₁ x₂ → mon (μ (k x₂)) (mon h x₁)))))

    Munit-simpl : ∀ {A}(q : A → Ur) x → μ (Munit x) $ q ≡ q x
    Munit-simpl q x = ≡-reflexive

    Mlet-simpl : ∀ {A B}(m : distr A)(M : A → distr B)(f : B → Ur)
               → μ (Mlet m M) $ f ≡ μ m $ (λ x → μ (M x) $ f)
    Mlet-simpl m M f = ≡-reflexive

    .Mlet-le-compat : ∀ {A B} (m1 m2 : distr A)(M1 M2 : A → distr B)
      → Order._≤_ (distrOrder A) m1 m2
      → Order._≤_ (A o→ distrOrder B) M1 M2
      → Order._≤_ (distrOrder B) (Mlet m1 M1) (Mlet m2 M2)
    Mlet-le-compat m1 m2 M1 M2 m1≤m2 M1≤M2 f = transitive (mon (μ m1) (λ x → M1≤M2 x f)) (m1≤m2 _)

    -- Monad laws

    Mlet-unit : ∀ {A B} (x : A)(m : A → distr B)
              → Order._≡_ (distrOrder B) (Mlet (Munit x) m) (m x)
    Mlet-unit x m f = ≡-reflexive

    Mlet-ext : ∀ {A}(m : distr A) → Order._≡_ (distrOrder A) (Mlet m Munit) m
    Mlet-ext m f = ≡-reflexive

    Mlet-assoc : ∀ {A B C}(m1 : distr A)(m2 : A → distr B)(m3 : B → distr C)
               → Order._≡_ (distrOrder C)
                  (Mlet (Mlet m1 m2) m3)
                  (Mlet m1 (λ x → Mlet (m2 x) m3))
    Mlet-assoc m1 m2 m3 f = ≡-reflexive

{-# OPTIONS --copatterns #-}
module alea.cpo where

import Data.Nat.NP as Nat

import Relation.Binary.PropositionalEquality as ≡

record Order (A : Set) : Set₁ where
  constructor mk
  infix 4 _≡_ _≤_
  field
    _≤_ : A → A → Set
    _≡_ : A → A → Set
    reflexive : ∀ {x} → x ≤ x
    antisym : ∀ {x y} → x ≤ y → y ≤ x → x ≡ y
    transitive : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z

  ≡-reflexive : ∀ {x} → x ≡ x
  ≡-reflexive = antisym reflexive reflexive

ℕ : Order Nat.ℕ
ℕ = mk Nat._≤_ ≡._≡_ Nat.ℕ≤.refl Nat.ℕ≤.antisym Nat.ℕ≤.trans

funOrder : ∀ {A B : Set} → Order B → Order (A → B)
funOrder or = mk (λ f g  → ∀ x → f x ≤ g x) (λ f g → ∀ x → f x ≡ g x)
              (λ x₁ → reflexive)
              (λ f g x → antisym (f x) (g x))
              (λ f g x  → transitive (f x) (g x))
  where open Order or

_o→_ : ∀ A {B} → Order B → Order (A → B)
A o→ ob = funOrder {A} ob

record _→m_ {A B}(oa : Order A)(ob : Order B) : Set where
  coinductive
  constructor mk
  field
    _$_ : A → B
    .mon : ∀ {x y} → Order._≤_ oa x y → Order._≤_ ob (_$_ x) (_$_ y)
open _→m_ using (_$_ ; mon)

_o→m_ : ∀ {A B}(oa : Order A)(ob : Order B) → Order (oa →m ob)
_o→m_ {A} oa ob = mk (λ f g → _$_ f ≤ _$_ g)
                     (λ f g → _$_ f ≡ _$_ g)
                     reflexive antisym transitive
  where open Order (A o→ ob)

swapm : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
swapm f = mk (λ b → mk (λ a → (f $ a) $ b) (λ r → mon f r b )) (λ r x → mon (f $ x) r)

swapm' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
_$_ (_$_ (swapm' f) b) a = (f $ a) $ b
mon (_$_ (swapm' f) b) r = mon f r b
mon (swapm' f) r x = mon (f $ x) r

{-
swapm'' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
(swapm'' f $ b)    $ a = (f $ a) $ b
mon (swapm' f $ b) r   = mon f r b
mon (swapm' f)     r x = mon (f $ x) r
-}

_∘m_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
f ∘m g = mk (λ x → f $ (g $ x)) (λ x → mon f (mon g x))

_∘m'_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
_$_ (f ∘m' g) x = f $ (g $ x)
mon (f ∘m' g) x = mon f (mon g x)

_$m_ : ∀ {A B C}{oa : Order A}{oc : Order C}
       → oa →m (B o→ oc) → B → oa →m oc
_$m_ {oa = oa}{oc} f b = mk (λ a → (f $ a) b) (λ x≤y → mon f x≤y b )

_$m'_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$_ (f $m' b) a   = (f $ a) b
mon (f $m' b) x≤y = mon f x≤y b

UB : ∀ {A} → Order A → A → Set
UB or a = ∀ x → x ≤ a
  where open Order or

record cpo {D} (o : Order D) : Set where
  constructor mk
  open Order o

  field
    d0 : D
    lub : (f : ℕ →m o) → D

  -- proofs
  field
    .Dbot : ∀ x → d0 ≤ x
    .lubUB : ∀ (f : ℕ →m o) n → (f $ n) ≤ lub f
    .lubLUB : ∀ (f : ℕ →m o) x → (∀ n → (f $ n) ≤ x) → lub f ≤ x

  .lub-ext : ∀ {f g} → Order._≤_ (ℕ o→m o) f g → lub f ≤ lub g
  lub-ext {f} {g} f≤g = lubLUB f (lub g) (λ n → transitive (f≤g n) (lubUB g n))

  lubm : (ℕ o→m o) →m o
  lubm = mk lub (λ {a}{b} x₁ → lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁)

  lubm' : (ℕ o→m o) →m o
  _$_ lubm' = lub
  mon lubm' {a}{b} x₁ = lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁

module _ where
  .lub-swap : ∀ {D}{o : Order D}(c : cpo o)
             → let open cpo c
                   open Order o
               in ∀ f → lub (lubm ∘m f) ≤ lub (lubm ∘m swapm f)
  lub-swap {D}{o} c f = lubLUB (lubm ∘m f) (lub (lubm ∘m swapm f))
                     (λ n → lubLUB (f $ n) (lub (lubm ∘m swapm f))
                     (λ n₁ → transitive (lubUB (swapm f $ n₁) n) (lubUB (lubm ∘m swapm f) n₁)))
    where
      open cpo c
      open Order o

  funcpo : ∀ {A D}{od : Order D} → cpo od → cpo (A o→ od)
  funcpo cpod = mk (λ x → d0) (λ f x → lub (f $m x)) (λ x x₁ → Dbot (x x₁)) (λ f n x → lubUB (f $m x) n)
    (λ f x x₁ x₂ → lubLUB (f $m x₂) (x x₂) (λ n → x₁ n x₂))
    where
      open cpo cpod
      open Nat
      open ≡ using (_≡_)

  _c→m_ : ∀ {A D}(oa : Order A){od : Order D} → cpo od → cpo (oa o→m od)
  _c→m_ {A} oa {od} cpod = mk (mk (λ x → d0) (λ x₁ → Order.reflexive od))
                          (λ f → mk (cpo.lub (funcpo {A} cpod)
                                       (mk (λ n a → (f $ n) $ a) (mon f)))
                                    (λ {x}{y}x≤y → lubLUB _ _ (λ n → transitive (mon (f $ n) x≤y) (lubUB (mk (λ v → (f $ v) $ y) (λ r → mon f r y)) n))))
                          (λ x x₁ → Dbot (x $ x₁))
                          (λ f n x → lubUB (mk (λ m → (f $ m) $ x) (λ x₂ → mon f x₂ x)) n)
                          (λ f x x₁ x₂ → lubLUB (mk (λ n → _$_ (f $ n)) (mon f) $m x₂) (x $ x₂) (λ n → x₁ n x₂))
    where
      open cpo cpod
      open Order od renaming (_≤_ to _≤ᵈ_)
      open Order oa using () renaming (_≤_ to _≤ᵃ_)

record continous {A B}{oa : Order A}{ob : Order B}
                 (c1 : cpo oa)(c2 : cpo ob)(f : oa →m ob) : Set where
  constructor mk
  open cpo c1 renaming (lub to luba ; lubUB to lubUBa ; lubLUB to lubLUBa)
  open cpo c2
  open Order ob
  field
    .contIntro : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≤ lub (f ∘m h)

  .contIntro' : ∀ (h : ℕ →m oa) → lub (f ∘m h) ≤ f $ luba h
  contIntro' h = lubLUB (f ∘m h) (f $ luba h) (λ n → mon f (lubUBa _ n))

  .contEq : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≡ lub (f ∘m h)
  contEq h = antisym (contIntro h) (contIntro' h)

open continous

module Distr
  (Ur  : Set) -- the set [0,1]
  (1/_+1 : Nat.ℕ → Ur)
  (_+_ : Ur → Ur → Ur)
  (_×_ : Ur → Ur → Ur)
  (oUr : Order Ur)
  (≤-cong-+ : let open Order oUr in ∀ {x y z w} → x ≤ z → y ≤ w → x + y ≤ z + w)
  (≤-cong-× : let open Order oUr in ∀ {x y z w} → x ≤ z → y ≤ w → x × y ≤ z × w)
  (U   : cpo oUr) where

  record distr A : Set where
    constructor mk
    field
      μ : (A o→ oUr) →m oUr
      .muContinous : ∀ (h : ℕ →m (A o→ oUr)) → Order._≤_ oUr (μ $ cpo.lub (funcpo U) h) (cpo.lub U (μ ∘m h)) -- continous (funcpo U) U μ

  open distr

  module _ A where
    module M = cpo ((A o→ oUr) c→m U)

    distrOrder : Order (distr A)
    distrOrder = mk (λ f g → μ f ≤ μ g) (λ f g → μ f ≡ μ g)
      (λ {x} → reflexive {μ x}) (λ {x} {y} → antisym {μ x} {μ y}) (λ {x} {y} {z} → transitive {μ x} {μ y} {μ z})
      where open Order ((A o→ oUr) o→m oUr)

    μm : distrOrder →m ((A o→ oUr) o→m oUr)
    μm = mk μ (λ x₁ x₂ → x₁ x₂)

    distrcpo : cpo distrOrder
    distrcpo = mk (mk M.d0 (λ h → cpo.Dbot U (cpo.lub U (M.d0 ∘m h))))

                    (λ f → mk (M.lub (μm ∘m f)) (λ h → transitive
                                                       (cpo.lub-ext U (λ a → muContinous (f $ a) h))
                                                       (lub-swap U (mk (λ z → mk (λ z₁ → μ (f $ z) $ (h $ z₁))
                                                                                (λ x → mon (μ (f $ z)) (mon h x)))
                                                                       (λ {x}{y} x₁ x₂ →
                                                                              mon f x₁ (λ x₃ → (h $ x₂) x₃))))))
                    (λ x x₁ → cpo.Dbot U (μ x $ x₁))
                    (λ f n x → cpo.lubUB U _ _ )
                    (λ f x x₁ x₂ → cpo.lubLUB U _ _ (λ n → x₁ n x₂))
       where open Order oUr

  module FIXPOINTS {d} {D : Order d} {c : cpo D} where
    open cpo c
    open Order D

    iter : (f : D →m D) → Nat.ℕ → d
    iter f Nat.zero = d0
    iter f (Nat.suc n) = f $ iter f n

    iter-mon : (f : D →m D) → ℕ →m D
    iter-mon f = mk (iter f) mono
      where
        .mono : ∀ {x y} → x Nat.≤ y → iter f x ≤ iter f y
        mono Nat.z≤n = Dbot _
        mono (Nat.s≤s prf) = mon f (mono prf)

    fix : (f : D →m D) → d
    fix f = lub (iter-mon f)

    .fix-le : (F : D →m D) → fix F ≤ F $ (fix F)
    fix-le F = lubLUB _ _ prf
      where
        .prf : (n : Nat.ℕ) → iter-mon F $ n ≤ F $ fix F
        prf Nat.zero = Dbot (F $ fix F)
        prf (Nat.suc n) = mon F (lubUB (iter-mon F) n)

  module _ where

    open Order oUr
    open cpo U
    open import Data.Bool

    postulate
      EXPLODE : ∀ {A : Set} → A

    flip : distr Bool
    _$_ (μ flip) f = (1/ 1 +1 × f true) + (1/ 1 +1 × f false)
    mon (μ flip) r = ≤-cong-+ (≤-cong-× reflexive (r true)) (≤-cong-× reflexive (r false))
    muContinous flip h = EXPLODE

    Munit : ∀ {A} → A → distr A
    Munit x = mk (mk (λ f → f x) (λ x≤y → x≤y x)) (λ h → reflexive)

    Mlet : ∀ {A B} → distr A → (A → distr B) → distr B
    Mlet m k = mk (mk (λ f → μ m $ (λ x → μ (k x) $ f)) (λ x≤y → mon (μ m) (λ x → mon (μ (k x)) x≤y)))
       (λ h →  transitive (mon (μ m) (λ x → muContinous (k x) h))
                   (muContinous m (mk (λ z z₁ → μ (k z₁) $ (h $ z)) (λ x₁ x₂ → mon (μ (k x₂)) (mon h x₁)))))

    Munit-simpl : ∀ {A}(q : A → Ur) x → μ (Munit x) $ q ≡ q x
    Munit-simpl q x = ≡-reflexive

    Mlet-simpl : ∀ {A B}(m : distr A)(M : A → distr B)(f : B → Ur)
               → μ (Mlet m M) $ f ≡ μ m $ (λ x → μ (M x) $ f)
    Mlet-simpl m M f = ≡-reflexive

    .Mlet-le-compat : ∀ {A B} (m1 m2 : distr A)(M1 M2 : A → distr B)
      → Order._≤_ (distrOrder A) m1 m2
      → Order._≤_ (A o→ distrOrder B) M1 M2
      → Order._≤_ (distrOrder B) (Mlet m1 M1) (Mlet m2 M2)
    Mlet-le-compat m1 m2 M1 M2 m1≤m2 M1≤M2 f = transitive (mon (μ m1) (λ x → M1≤M2 x f)) (m1≤m2 _)

    -- Monad laws

    Mlet-unit : ∀ {A B} (x : A)(m : A → distr B)
              → Order._≡_ (distrOrder B) (Mlet (Munit x) m) (m x)
    Mlet-unit x m f = ≡-reflexive

    Mlet-ext : ∀ {A}(m : distr A) → Order._≡_ (distrOrder A) (Mlet m Munit) m
    Mlet-ext m f = ≡-reflexive

    Mlet-assoc : ∀ {A B C}(m1 : distr A)(m2 : A → distr B)(m3 : B → distr C)
               → Order._≡_ (distrOrder C)
                  (Mlet (Mlet m1 m2) m3)
                  (Mlet m1 (λ x → Mlet (m2 x) m3))
    Mlet-assoc m1 m2 m3 f = ≡-reflexive