Add 3 more primitives to get a more precise account on space cost

module flat-funs where

open import Data.Unit using (⊤)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_; _⊔_)
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
open import Data.Bool using (if_then_else_)
import Data.Vec.NP as V
import Level as L
import Function as F
import Data.Product as ×
import Relation.Binary.PropositionalEquality as ≡
open F using (const)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_; _,_; proj₁; proj₂; uncurry)
open ≡ using (_≡_)

open import Data.Bits using (Bit; Bits; _→ᵇ_; 0b; 1b)

open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _∘_
  infixr 1 _⁏_
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    -- Functions
    id : ∀ {A} → A `→ A
    _∘_ : ∀ {A B C} → (B `→ C) → (A `→ B) → (A `→ C)

    -- Bit
    <0b> <1b> : ∀ {_A} → _A `→ `Bit
    cond      : ∀ {A} → `Bit `× A `× A `→ A

    -- Products
    dup   : ∀ {A} → A `→ A `× A
    fst   : ∀ {A B} → A `× B `→ A
    snd   : ∀ {A B} → A `× B `→ B
    <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
    swap  : ∀ {A B} → (A `× B) `→ (B `× A)
    assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))

    -- Unit
    tt : ∀ {_A} → _A `→ `⊤
    <tt,> : ∀ {A} → A `→ `⊤ `× A

    -- Vectors
    nil    : ∀ {_A B} → _A `→ `Vec B 0
    cons   : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  _⁏_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
  f ⁏ g = g ∘ f

  _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
  f >>> g = f ⁏ g

  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > = dup ⁏ < f × g >

  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  <_×_>-on-top-of-<,> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g >-on-top-of-<,> = < fst ⁏ f , snd ⁏ g >

  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  swap-on-top-<,> : ∀ {A B} → (A `× B) `→ (B `× A)
  swap-on-top-<,> = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = < f × id >

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = < id × f >

  fork : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  fork f g = second < f , g > ⁏ cond

  -- In case you wonder... one can also derive cond with fork
  cond-on-top-of-fork : ∀ {A} → `Bit `× A `× A `→ A
  cond-on-top-of-fork = fork fst snd

  constBit : ∀ {_A} → Bit → _A `→ `Bit
  constBit b = if b then <1b> else <0b>

  <,tt> : ∀ {A} → A `→ A `× `⊤
  <,tt> = <tt,> ⁏ swap

  assoc-default : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc-default = < fst ⁏ fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd ⁏ snd >

  <_`zip`_> : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  < f `zip` g > = < < fst × fst > ⁏ f ,
                    < snd × snd > ⁏ g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons ⁏ fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons ⁏ snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons ⁏ < f × g > ⁏ cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > ⁏ cons

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = < f ∷ ⊛ fs >

  ⊛′ : ∀ {n A B} → Vec (A `→ B) n → A `→ `Vec B n
  ⊛′ []       = nil
  ⊛′ (f ∷ fs) = < f ∷′ ⊛′ fs >

  constVec : ∀ {n b _A} {B : Set b} {C} → (B → _A `→ C) → Vec B n → _A `→ `Vec C n
  constVec f xs = ⊛′ (V.map f xs)

  constBits : ∀ {n _A} → Bits n → _A `→ `Bits n
  constBits = constVec constBit

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                  ⁏ assoc′
                  ⁏ first f
                  ⁏ foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons ⁏ foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                  ⁏ assoc
                  ⁏ second (foldr f)
                  ⁏ f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons ⁏ swap ⁏ foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map f = ⊛ (V.replicate f)

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                    ⁏ < f `zip` (zipWith f) >
                    ⁏ cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  <,nil> : ∀ {A B} → A `→ A `× `Vec B 0
  <,nil> = <,tt> ⁏ second nil

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = <,nil> ⁏ cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd ⁏ singleton
  snoc {suc n} = first uncons ⁏ assoc ⁏ second snoc ⁏ cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons ⁏ swap ⁏ first reverse ⁏ snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
                 ⁏ assoc
                 ⁏ second append
                 ⁏ cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , id >
  splitAt (suc m) = uncons
                  ⁏ second (splitAt m)
                  ⁏ assoc′
                  ⁏ first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail ⁏ drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) ⁏ < folda n f × folda n f > ⁏ f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail ⁏ last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons ⁏ second concat ⁏ append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k ⁏ second (group n k) ⁏ cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f ⁏ concat

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < id , replicate > ⁏ cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz ⁏ f , tabulate (fs ⁏ f) > ⁏ cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst ⁏ elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail ⁏ lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate id

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

module FunTypes = FlatFuns fun♭Funs

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

module BitsFunTypes = FlatFuns bitsFun♭Funs

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

module FinFunTypes = FlatFuns finFun♭Funs

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk F.id F._∘′_
             (F.const 0b) (F.const 1b) (λ { (b , x , y) → if b then x else y })
             (λ x → x , x) proj₁ proj₂ (λ f g → ×.map f g)
             ×.swap (λ {((x , y) , z) → x , (y , z) }) _ (λ x → _ , x) (F.const []) (uncurry _∷_) V.uncons

module FunOps = FlatFunsOps fun♭Ops

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id _∘_
                 (const [ 0b ]) (const [ 1b ]) condᵇ
                 dupᵇ fstᵇ (λ {x} → sndᵇ {x}) <_×_>ᵇ
                 (λ {x} → swapᵇ {x}) (λ {x} → assocᵇ {x}) (const []) id (const []) id id
  where
  open BitsFunTypes
  open FunOps
  fstᵇ : ∀ {A B} → A `× B `→ A
  fstᵇ {A} = V.take A
  sndᵇ : ∀ {A B} → A `× B `→ B
  sndᵇ {A} = V.drop A
  dupᵇ : ∀ {A} → A `→ A `× A
  dupᵇ xs = xs ++ xs
  <_×_>ᵇ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  <_×_>ᵇ {A} f g x = f (take A x) ++ g (drop A x)
  condᵇ : ∀ {A} → `Bit `× A `× A `→ A
  condᵇ {A} (b ∷ xs) = if b then take A xs else drop A xs
  swapᵇ : ∀ {A B} → (A `× B) `→ (B `× A)
  swapᵇ {A} xs = drop A xs ++ take A xs
  assocᵇ : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assocᵇ {A} {B} xs = take A (take (A + B) xs) ++ (drop A (take (A + B) xs) ++ drop (A + B) xs) -- < fstᵇ ⁏ fstᵇ , first sndᵇ >

module BitsFunOps = FlatFunsOps bitsFun♭Ops

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T
  = mk (S.id , T.id) (×.zip S._∘_ T._∘_)
       (S.<0b> , T.<0b>) (S.<1b> , T.<1b>) (S.cond , T.cond)
       (S.dup , T.dup) (S.fst , T.fst) (S.snd , T.snd) (×.zip S.<_×_> T.<_×_>)
       (S.swap , T.swap) (S.assoc , T.assoc)
       (S.tt , T.tt) (S.<tt,> , T.<tt,>)
       (S.nil , T.nil) (S.cons , T.cons) (S.uncons , T.uncons)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FunOps

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤
  = mk (S.id , T.id) (×.zip S._∘_ T._∘_)
       (S.<0b> , T.<0b>) (S.<1b> , T.<1b>) (S.cond , T.cond)
       (S.dup , T.dup) (S.fst , T.fst) (S.snd , T.snd) (×.zip S.<_×_> T.<_×_>)
       (S.swap , T.swap) (S.assoc , T.assoc)
       (S.tt , T.tt) (S.<tt,> , T.<tt,>)
       (S.nil , T.nil) (S.cons , T.id) (S.uncons , T.id)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FunOps

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

module ConstFunTypes A = FlatFuns (constFuns A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = record {
            id = 0; _∘_ = _+_;
            <0b> = 0; <1b> = 0; cond = 1;
            dup = 0; fst = 0; snd = 0; <_×_> = _⊔_; swap = 0; assoc = 0;
            tt = 0; <tt,> = 0;
            nil = 0; cons = 0; uncons = 0 }

module TimeOps = FlatFunsOps timeOps

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = record {
             id = 0; _∘_ = _+_;
             <0b> = 0; <1b> = 0; cond = 1;
             dup = 1; fst = 0; snd = 0; <_×_> = _+_; swap = 0; assoc = 0;
             tt = 0; <tt,> = 0;
             nil = 0; cons = 0; uncons = 0 }

module SpaceOps where
  Space = ℕ
  open FlatFunsOps spaceOps public

  singleton≡0 : singleton ≡ 0
  singleton≡0 = ≡.refl

  snoc≡0 : ∀ n → snoc {n} ≡ 0
  snoc≡0 zero = ≡.refl
  snoc≡0 (suc n) rewrite snoc≡0 n = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≡ 0
  reverse≡0 zero = ≡.refl
  reverse≡0 (suc n) rewrite snoc≡0 n | reverse≡0 n = ≡.refl

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps

module Time×SpaceOps = FlatFunsOps time×spaceOps

module flat-funs where

open import Data.Unit using (⊤)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_; _⊔_)
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
open import Data.Bool using (if_then_else_)
import Data.Vec.NP as V
import Level as L
import Function as F
import Data.Product as ×
open F using (const)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_; _,_; proj₁; proj₂; uncurry)

open import Data.Bits using (Bit; Bits; _→ᵇ_; 0b; 1b)

open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _∘_
  infixr 1 _⁏_
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    -- Functions
    id : ∀ {A} → A `→ A
    _∘_ : ∀ {A B C} → (B `→ C) → (A `→ B) → (A `→ C)

    -- Bit
    <0b> <1b> : ∀ {_A} → _A `→ `Bit
    cond      : ∀ {A} → `Bit `× A `× A `→ A

    -- Products
    dup   : ∀ {A} → A `→ A `× A
    fst   : ∀ {A B} → A `× B `→ A
    snd   : ∀ {A B} → A `× B `→ B
    <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)

    -- Unit
    tt : ∀ {_A} → _A `→ `⊤

    -- Vectors
    nil    : ∀ {_A B} → _A `→ `Vec B 0
    cons   : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  _⁏_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
  f ⁏ g = g ∘ f

  _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
  f >>> g = f ⁏ g

  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > = dup ⁏ < f × g >

  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  <_×_>-on-top-of-<,> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g >-on-top-of-<,> = < fst ⁏ f , snd ⁏ g >

  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  swap : ∀ {A B} → (A `× B) `→ (B `× A)
  swap = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = f *** id

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = id *** f

  fork : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  fork f g = second < f , g > ⁏ cond

  -- In case you wonder... one can also derive cond with fork
  cond-on-top-of-fork : ∀ {A} → `Bit `× A `× A `→ A
  cond-on-top-of-fork = fork fst snd

  constBit : ∀ {_A} → Bit → _A `→ `Bit
  constBit b = if b then <1b> else <0b>

  assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc = < fst ⁏ fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd ⁏ snd >

  <_`zip`_> : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  < f `zip` g > = < < fst × fst > ⁏ f ,
                    < snd × snd > ⁏ g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons ⁏ fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons ⁏ snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons ⁏ < f × g > ⁏ cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > ⁏ cons

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = < f ∷ ⊛ fs >

  ⊛′ : ∀ {n A B} → Vec (A `→ B) n → A `→ `Vec B n
  ⊛′ []       = nil
  ⊛′ (f ∷ fs) = < f ∷′ ⊛′ fs >

  constVec : ∀ {n b _A} {B : Set b} {C} → (B → _A `→ C) → Vec B n → _A `→ `Vec C n
  constVec f xs = ⊛′ (V.map f xs)

  constBits : ∀ {n _A} → Bits n → _A `→ `Bits n
  constBits = constVec constBit

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                  ⁏ assoc′
                  ⁏ first f
                  ⁏ foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons ⁏ foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                  ⁏ assoc
                  ⁏ second (foldr f)
                  ⁏ f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons ⁏ swap ⁏ foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map {zero}  f = nil
  map {suc n} f = < f ∷ map f >

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                    ⁏ < f `zip` (zipWith f) >
                    ⁏ cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = < id , nil > ⁏ cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd ⁏ singleton
  snoc {suc n} = first uncons ⁏ assoc ⁏ second snoc ⁏ cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons ⁏ swap ⁏ first reverse ⁏ snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
                 ⁏ assoc
                 ⁏ second append
                 ⁏ cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , id >
  splitAt (suc m) = uncons
                  ⁏ second (splitAt m)
                  ⁏ assoc′
                  ⁏ first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail ⁏ drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) ⁏ < folda n f × folda n f > ⁏ f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail ⁏ last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons ⁏ second concat ⁏ append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k ⁏ second (group n k) ⁏ cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f ⁏ concat

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < id , replicate > ⁏ cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz ⁏ f , tabulate (fs ⁏ f) > ⁏ cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst ⁏ elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail ⁏ lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate id

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

module FunTypes = FlatFuns fun♭Funs

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

module BitsFunTypes = FlatFuns bitsFun♭Funs

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

module FinFunTypes = FlatFuns finFun♭Funs

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk F.id F._∘′_
             (F.const 0b) (F.const 1b) (λ { (b , x , y) → if b then x else y })
             (λ x → x , x) proj₁ proj₂ (λ f g → ×.map f g)
             _ (F.const []) (uncurry _∷_) V.uncons

module FunOps = FlatFunsOps fun♭Ops

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id _∘_
                 (const [ 0b ]) (const [ 1b ]) condᵇ
                 dupᵇ (λ {A} → V.take A) (λ {A} → V.drop A) <_×_>ᵇ
                 (const []) (const []) id id
  where
  open BitsFunTypes
  open FunOps
  dupᵇ : ∀ {A} → A `→ A `× A
  dupᵇ xs = xs ++ xs
  <_×_>ᵇ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  <_×_>ᵇ {A} f g x = f (take A x) ++ g (drop A x)
  condᵇ : ∀ {A} → `Bit `× A `× A `→ A
  condᵇ {A} (b ∷ xs) = if b then take A xs else drop A xs

module BitsFunOps = FlatFunsOps bitsFun♭Ops

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T
  = mk (S.id , T.id) (×.zip S._∘_ T._∘_)
       (S.<0b> , T.<0b>) (S.<1b> , T.<1b>) (S.cond , T.cond)
       (S.dup , T.dup) (S.fst , T.fst) (S.snd , T.snd) (×.zip S.<_×_> T.<_×_>)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.cons) (S.uncons , T.uncons)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FunOps

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤
  = mk (S.id , T.id) (×.zip S._∘_ T._∘_)
       (S.<0b> , T.<0b>) (S.<1b> , T.<1b>) (S.cond , T.cond)
       (S.dup , T.dup) (S.fst , T.fst) (S.snd , T.snd) (×.zip S.<_×_> T.<_×_>)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.id) (S.uncons , T.id)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FunOps

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

module ConstFunTypes A = FlatFuns (constFuns A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = record {
            id = 0; _∘_ = _+_;
            <0b> = 0; <1b> = 0; cond = 1;
            dup = 0; fst = 0; snd = 0; <_×_> = _⊔_;
            tt = 0;
            nil = 0; cons = 0; uncons = 0 }

module TimeOps = FlatFunsOps timeOps

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = record {
             id = 0; _∘_ = _+_;
             <0b> = 0; <1b> = 0; cond = 1;
             dup = 1; fst = 0; snd = 0; <_×_> = _+_;
             tt = 0;
             nil = 0; cons = 0; uncons = 0 }

module SpaceOps = FlatFunsOps spaceOps

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps

module Time×SpaceOps = FlatFunsOps time×spaceOps


Cosmetic changes.

Cosmetic changes.

Ignore-this: 9679e5e5b7e04c672101f1626610d4a6

darcs-hash:20110406210038-3bd4e-9bc556a6e9785ce5d81eaff93aefd4284f80c4b9.gz

------------------------------------------------------------------------------
-- Auxiliary properties of the McCarthy 91 function
------------------------------------------------------------------------------

module FOTC.Program.McCarthy91.Properties.AuxiliaryATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.IsN-ATP
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP

open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.McCarthy91

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

--- Auxiliary properties

---- Case n > 100
postulate
  Nmc91>100      : ∀ {n} → N n → GT n one-hundred → N (mc91 n)
  x<mc91x+11>100 : ∀ {n} → N n → GT n one-hundred →
                           LT n (mc91 n + eleven)
{-# ATP prove Nmc91>100 10-N ∸-N #-}
{-# ATP prove x<mc91x+11>100 +-N ∸-N x<y→y≤z→x<z x<x+1 x+1≤x∸10+11 #-}

-- Most of them not needed
-- Case n ≡ 100 can be proved automatically
postulate
  Nmc91≡100     : N (mc91 one-hundred)
  mc91-res-100  : mc91 one-hundred ≡ ninety-one
  mc91-res-100' : ∀ {n} → n ≡ one-hundred → mc91 n ≡ ninety-one
  mc91<mc91+11  : LT  one-hundred (mc91 one-hundred + eleven)
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100' mc91-res-100 #-}
{-# ATP prove mc91<mc91+11 mc91-res-100 102≡91+11 100<102 #-}

---- Case n ≤ 100

postulate
  -- Here we only reduce the definition of mc91
  Nmc91≤100'        : ∀ n → LE n one-hundred → N (mc91 (mc91 (n + eleven))) →
                      N (mc91 n)
  x<mc91x+11≤100'   : ∀ n → LE n one-hundred →
                      LT n (mc91 (mc91 (n + eleven)) + eleven) →
                      LT n (mc91 n + eleven)
  mc91x+11<mc91x+11 : ∀ n → LE n one-hundred →
                      LT (mc91 (n + eleven)) (mc91 (mc91 (n + eleven)) + eleven) →
                      LT (mc91 (n + eleven)) (mc91 n + eleven)
{-# ATP prove Nmc91≤100' #-}
{-# ATP prove x<mc91x+11≤100' #-}
{-# ATP prove mc91x+11<mc91x+11 #-}

postulate
  mc91x-res≤100 : ∀ m n → LE m one-hundred →
                  mc91 (m + eleven) ≡ n → mc91 n ≡ ninety-one →
                  mc91 m ≡ ninety-one
{-# ATP prove mc91x-res≤100 #-}

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

postulate
  mc91-res-99 : mc91 ninety-nine  ≡ ninety-one
  mc91-res-98 : mc91 ninety-eight ≡ ninety-one
  mc91-res-97 : mc91 ninety-seven ≡ ninety-one
  mc91-res-96 : mc91 ninety-six   ≡ ninety-one
  mc91-res-95 : mc91 ninety-five  ≡ ninety-one
  mc91-res-94 : mc91 ninety-four  ≡ ninety-one
  mc91-res-93 : mc91 ninety-three ≡ ninety-one
  mc91-res-92 : mc91 ninety-two   ≡ ninety-one
  mc91-res-91 : mc91 ninety-one   ≡ ninety-one
  mc91-res-90 : mc91 ninety       ≡ ninety-one
{-# ATP prove mc91-res-99 mc91x-res≤100 mc91-res-110 mc91-res-100 #-}
{-# ATP prove mc91-res-98 mc91x-res≤100 mc91-res-109 mc91-res-99 #-}
{-# ATP prove mc91-res-97 mc91x-res≤100 mc91-res-108 mc91-res-98 #-}
{-# ATP prove mc91-res-96 mc91x-res≤100 mc91-res-107 mc91-res-97 #-}
{-# ATP prove mc91-res-95 mc91x-res≤100 mc91-res-106 mc91-res-96 #-}
{-# ATP prove mc91-res-94 mc91x-res≤100 mc91-res-105 mc91-res-95 #-}
{-# ATP prove mc91-res-93 mc91x-res≤100 mc91-res-104 mc91-res-94 #-}
{-# ATP prove mc91-res-92 mc91x-res≤100 mc91-res-103 mc91-res-93 #-}
{-# ATP prove mc91-res-91 mc91x-res≤100 mc91-res-102 mc91-res-92 #-}
{-# ATP prove mc91-res-90 mc91x-res≤100 mc91-res-101 mc91-res-91 #-}

mc91-res-99' : ∀ {n} → n ≡ ninety-nine → mc91 n ≡ ninety-one
mc91-res-99' refl = mc91-res-99

mc91-res-98' : ∀ {n} → n ≡ ninety-eight → mc91 n ≡ ninety-one
mc91-res-98' refl = mc91-res-98

mc91-res-97' : ∀ {n} → n ≡ ninety-seven → mc91 n ≡ ninety-one
mc91-res-97' refl = mc91-res-97

mc91-res-96' : ∀ {n} → n ≡ ninety-six → mc91 n ≡ ninety-one
mc91-res-96' refl = mc91-res-96

mc91-res-95' : ∀ {n} → n ≡ ninety-five → mc91 n ≡ ninety-one
mc91-res-95' refl = mc91-res-95

mc91-res-94' : ∀ {n} → n ≡ ninety-four → mc91 n ≡ ninety-one
mc91-res-94' refl = mc91-res-94

mc91-res-93' : ∀ {n} → n ≡ ninety-three → mc91 n ≡ ninety-one
mc91-res-93' refl = mc91-res-93

mc91-res-92' : ∀ {n} → n ≡ ninety-two → mc91 n ≡ ninety-one
mc91-res-92' refl = mc91-res-92

mc91-res-91' : ∀ {n} → n ≡ ninety-one → mc91 n ≡ ninety-one
mc91-res-91' refl = mc91-res-91

mc91-res-90' : ∀ {n} → n ≡ ninety → mc91 n ≡ ninety-one
mc91-res-90' refl = mc91-res-90


Fixed doc.

Fixed doc.

Ignore-this: ad938e7eafbcc12667861d22d0600f60

darcs-hash:20120216155813-3bd4e-d0de42d4bd483dac1f842f071dace36dc7211426.gz

-- Tested with FOT on 16 February 2012.

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

module Existential where

module LF where
  postulate
    D       : Set
    ∃       : (P : D → Set) → Set
    _,_     : {P : D → Set}(x : D) → P x → ∃ P
    ∃-proj₁ : {P : D → Set} → ∃ P → D
    ∃-proj₂ : {P : D → Set}(p : ∃ P) → P (∃-proj₁ p)

  syntax ∃ (λ x → e) = ∃[ x ] e

  postulate P : D → D → Set

  ∃∀ : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
  ∃∀ h y = ∃-proj₁ h , (∃-proj₂ h) y

module Inductive where

  open import Common.Universe
  open import Common.Data.Product

  postulate P : D → D → Set

  ∃∀-el : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
  ∃∀-el h y = ∃-proj₁ h , (∃-proj₂ h) y

  ∃∀ : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
  ∃∀ (x , Px) y = x , Px y

-- Tested with the development version of Agda on 07 February 2012.

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

module Existential where

module LF where
  postulate
    D       : Set
    ∃       : (P : D → Set) → Set
    _,_     : {P : D → Set}(x : D) → P x → ∃ P
    ∃-proj₁ : {P : D → Set} → ∃ P → D
    ∃-proj₂ : {P : D → Set}(p : ∃ P) → P (∃-proj₁ p)

  syntax ∃ (λ x → e) = ∃[ x ] e

  postulate P : D → D → Set

  ∃∀ : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
  ∃∀ h y = ∃-proj₁ h , (∃-proj₂ h) y

module Inductive where

  open import Common.Universe
  open import Common.Data.Product

  postulate P : D → D → Set

  ∃∀-el : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
  ∃∀-el h y = ∃-proj₁ h , (∃-proj₂ h) y

  ∃∀ : ∃[ x ](∀ y → P x y) → ∀ y → ∃[ x ] P x y
  ∃∀ (x , Px) y = x , Px y


Bool: +∧⇒∨, +toℕ, +toℕ≤1

Bool: +∧⇒∨, +toℕ, +toℕ≤1

{-# OPTIONS --universe-polymorphism #-}
module Data.Bool.NP where

open import Data.Bool using (Bool; true; false; T; if_then_else_; not)
import Algebra
import Data.Bool.Properties as B
open import Data.Unit using (⊤)
open import Data.Product
open import Data.Sum
open import Data.Nat using (ℕ; _≤_; z≤n; s≤s)
open import Function
open import Relation.Binary.NP
open import Relation.Binary.Logical
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Binary.PropositionalEquality as ≡
import Function.Equivalence as E
open E.Equivalence using (to; from)
open import Function.Equality using (_⟨$⟩_)
open ≡ using (_≡_)

module Xor° = Algebra.CommutativeRing B.commutativeRing-xor-∧
module Bool° = Algebra.CommutativeSemiring B.commutativeSemiring-∧-∨

check : ∀ b → {pf : T b} → ⊤
check = _

If_then_else_ : ∀ {ℓ} {A B : Set ℓ} b → (T b → A) → (T (not b) → B) → if b then A else B
If_then_else_ true  x _ = x _
If_then_else_ false _ x = x _

If′_then_else_ : ∀ {ℓ} {A B : Set ℓ} b → A → B → if b then A else B
If′_then_else_ true  x _ = x
If′_then_else_ false _ x = x

If-map : ∀ {A B C D : Set} b (f : T b → A → C) (g : T (not b) → B → D) →
           if b then A else B → if b then C else D
If-map true  f _ = f _
If-map false _ f = f _

If-elim : ∀ {A B : Set} {P : Bool → Set}
            b (f : T b → A → P true) (g : T (not b) → B → P false) → if b then A else B → P b
If-elim true  f _ = f _
If-elim false _ f = f _

If-true : ∀ {A B : Set} {b} → T b → (if b then A else B) ≡ A
If-true {b = true}  _ = ≡.refl
If-true {b = false} ()

If-false : ∀ {A B : Set} {b} → T (not b) → (if b then A else B) ≡ B
If-false {b = true}  ()
If-false {b = false} _ = ≡.refl

cong-if : ∀ {A B : Set} b {t₀ t₁} (f : A → B) → (if b then f t₀ else f t₁) ≡ f (if b then t₀ else t₁)
cong-if true  _ = ≡.refl
cong-if false _ = ≡.refl

if-not : ∀ {a} {A : Set a} b {t₀ t₁ : A} → (if b then t₀ else t₁) ≡ (if not b then t₁ else t₀)
if-not true  = ≡.refl
if-not false = ≡.refl

data ⟦Bool⟧ : (b₁ b₂ : Bool) → Set where
  ⟦true⟧   : ⟦Bool⟧ true true
  ⟦false⟧  : ⟦Bool⟧ false false

private
 module ⟦Bool⟧-Internals where
  refl : Reflexive ⟦Bool⟧
  refl {true}   = ⟦true⟧
  refl {false}  = ⟦false⟧

  sym : Symmetric ⟦Bool⟧
  sym ⟦true⟧  = ⟦true⟧
  sym ⟦false⟧ = ⟦false⟧

  trans : Transitive ⟦Bool⟧
  trans ⟦true⟧   = id
  trans ⟦false⟧  = id

  subst : ∀ {ℓ} → Substitutive ⟦Bool⟧ ℓ
  subst _ ⟦true⟧   = id
  subst _ ⟦false⟧  = id

  _≟_ : Decidable ⟦Bool⟧
  true   ≟  true   = yes ⟦true⟧
  false  ≟  false  = yes ⟦false⟧
  true   ≟  false  = no (λ())
  false  ≟  true   = no (λ())

  isEquivalence : IsEquivalence ⟦Bool⟧
  isEquivalence = record { refl = refl; sym = sym; trans = trans }

  isDecEquivalence : IsDecEquivalence ⟦Bool⟧
  isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

  setoid : Setoid _ _
  setoid = record { Carrier = Bool; _≈_ = ⟦Bool⟧; isEquivalence = isEquivalence }

  decSetoid : DecSetoid _ _
  decSetoid = record { Carrier = Bool; _≈_ = ⟦Bool⟧; isDecEquivalence = isDecEquivalence }

  equality : Equality ⟦Bool⟧
  equality = record { isEquivalence = isEquivalence; subst = subst }

module ⟦Bool⟧-Props where
  open ⟦Bool⟧-Internals public using (subst; decSetoid; equality)
  open DecSetoid decSetoid public
  open Equality equality public hiding (subst; isEquivalence; refl; reflexive; sym; trans)

⟦if⟨_⟩_then_else_⟧ : ∀ {a₁ a₂ aᵣ} → (∀⟨ Aᵣ ∶ ⟦Set⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧ ⟦Bool⟧ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ) if_then_else_ if_then_else_
⟦if⟨_⟩_then_else_⟧ _ ⟦true⟧  xᵣ _ = xᵣ
⟦if⟨_⟩_then_else_⟧ _ ⟦false⟧ _ xᵣ = xᵣ

⟦If′⟨_,_⟩_then_else_⟧ : ∀ {ℓ₁ ℓ₂ ℓᵣ} →
                       (∀⟨ Aᵣ ∶ ⟦Set⟧ {ℓ₁} {ℓ₂} ℓᵣ ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦Set⟧ {ℓ₁} {ℓ₂} ℓᵣ ⟩⟦→⟧
                           ⟨ bᵣ ∶ ⟦Bool⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ ⟦if⟨ ⟦Set⟧ _ ⟩ bᵣ then Aᵣ else Bᵣ ⟧)
                       If′_then_else_ If′_then_else_
⟦If′⟨_,_⟩_then_else_⟧ _ _ ⟦true⟧  xᵣ _ = xᵣ
⟦If′⟨_,_⟩_then_else_⟧ _ _ ⟦false⟧ _ xᵣ = xᵣ

_==_ : (x y : Bool) → Bool
true == true = true
true == false = false
false == true = false
false == false = true

module == where
  _≈_ : (x y : Bool) → Set
  x ≈ y = T (x == y)

  refl : Reflexive _≈_
  refl {true}  = _
  refl {false} = _

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {true}   {true}   _ = id
  subst _ {false}  {false}  _ = id
  subst _ {true}   {false}  ()
  subst _ {false}  {true}   ()

  sym : Symmetric _≈_
  sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

  trans : Transitive _≈_
  trans {x} {y} {z} x≈y y≈z = subst (_≈_ x) {y} {z} y≈z x≈y

  _≟_ : Decidable _≈_
  true   ≟  true   = yes _
  false  ≟  false  = yes _
  true   ≟  false  = no (λ())
  false  ≟  true   = no (λ())

  isEquivalence : IsEquivalence _≈_
  isEquivalence = record { refl = λ {x} → refl {x}
                         ; sym = λ {x} {y} → sym {x} {y}
                         ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

  isDecEquivalence : IsDecEquivalence _≈_
  isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

  setoid : Setoid _ _
  setoid = record { Carrier = Bool; _≈_ = _≈_ ; isEquivalence = isEquivalence }

  decSetoid : DecSetoid _ _
  decSetoid = record { Carrier = Bool; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }

module ⟦Bool⟧-Reasoning = Setoid-Reasoning ⟦Bool⟧-Props.setoid

open Data.Bool public

⟦true⟧′ : ∀ {b} → T b → ⟦Bool⟧ true b
⟦true⟧′ {true}  _ = ⟦true⟧
⟦true⟧′ {false} ()

⟦false⟧′ : ∀ {b} → T (not b) → ⟦Bool⟧ false b
⟦false⟧′ {true} ()
⟦false⟧′ {false} _ = ⟦false⟧

T∧ : ∀ {b₁ b₂} → T b₁ → T b₂ → T (b₁ ∧ b₂)
T∧ p q = _⟨$⟩_ (from B.T-∧) (p , q)

T∧₁ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) → T b₁
T∧₁ = proj₁ ∘ _⟨$⟩_ (to B.T-∧)

T∧₂ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) → T b₂
T∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (B.T-∧ {b₁}))

T∨'⊎ : ∀ {b₁ b₂} → T (b₁ ∨ b₂) → T b₁ ⊎ T b₂
T∨'⊎ {b₁} = _⟨$⟩_ (to (B.T-∨ {b₁}))

T∨₁ : ∀ {b₁ b₂} → T b₁ → T (b₁ ∨ b₂)
T∨₁ = _⟨$⟩_ (from B.T-∨) ∘ inj₁

T∨₂ : ∀ {b₁ b₂} → T b₂ → T (b₁ ∨ b₂)
T∨₂ {b₁} = _⟨$⟩_ (from (B.T-∨ {b₁})) ∘ inj₂

T'not'¬ : ∀ {b} → T (not b) → ¬ (T b)
T'not'¬ {false} _ = λ()
T'not'¬ {true} ()

T'¬'not : ∀ {b} → ¬ (T b) → T (not b)
T'¬'not {true}  f = f _
T'¬'not {false} _ = _

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

Tdec : ∀ b → Dec (T b)
Tdec true = yes _
Tdec false = no λ()

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan true  _ = ≡.refl
de-morgan false _ = ≡.refl

-- false is 0 and true is 1
toℕ : Bool → ℕ
toℕ b = if b then 1 else 0

toℕ≤1 : ∀ b → toℕ b ≤ 1
toℕ≤1 true  = s≤s z≤n
toℕ≤1 false = z≤n

{-# OPTIONS --universe-polymorphism #-}
module Data.Bool.NP where

open import Data.Bool using (Bool; true; false; T; if_then_else_; not)
import Algebra
import Data.Bool.Properties as B
open import Data.Unit using (⊤)
open import Data.Product
open import Data.Sum
open import Function
open import Relation.Binary.NP
open import Relation.Binary.Logical
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Binary.PropositionalEquality as ≡
import Function.Equivalence as E
open E.Equivalence using (to; from)
open import Function.Equality using (_⟨$⟩_)
open ≡ using (_≡_)

module Xor° = Algebra.CommutativeRing B.commutativeRing-xor-∧
module Bool° = Algebra.CommutativeSemiring B.commutativeSemiring-∧-∨

check : ∀ b → {pf : T b} → ⊤
check = _

If_then_else_ : ∀ {ℓ} {A B : Set ℓ} b → (T b → A) → (T (not b) → B) → if b then A else B
If_then_else_ true  x _ = x _
If_then_else_ false _ x = x _

If′_then_else_ : ∀ {ℓ} {A B : Set ℓ} b → A → B → if b then A else B
If′_then_else_ true  x _ = x
If′_then_else_ false _ x = x

If-map : ∀ {A B C D : Set} b (f : T b → A → C) (g : T (not b) → B → D) →
           if b then A else B → if b then C else D
If-map true  f _ = f _
If-map false _ f = f _

If-elim : ∀ {A B : Set} {P : Bool → Set}
            b (f : T b → A → P true) (g : T (not b) → B → P false) → if b then A else B → P b
If-elim true  f _ = f _
If-elim false _ f = f _

If-true : ∀ {A B : Set} {b} → T b → (if b then A else B) ≡ A
If-true {b = true}  _ = ≡.refl
If-true {b = false} ()

If-false : ∀ {A B : Set} {b} → T (not b) → (if b then A else B) ≡ B
If-false {b = true}  ()
If-false {b = false} _ = ≡.refl

cong-if : ∀ {A B : Set} b {t₀ t₁} (f : A → B) → (if b then f t₀ else f t₁) ≡ f (if b then t₀ else t₁)
cong-if true  _ = ≡.refl
cong-if false _ = ≡.refl

if-not : ∀ {a} {A : Set a} b {t₀ t₁ : A} → (if b then t₀ else t₁) ≡ (if not b then t₁ else t₀)
if-not true  = ≡.refl
if-not false = ≡.refl

data ⟦Bool⟧ : (b₁ b₂ : Bool) → Set where
  ⟦true⟧   : ⟦Bool⟧ true true
  ⟦false⟧  : ⟦Bool⟧ false false

private
 module ⟦Bool⟧-Internals where
  refl : Reflexive ⟦Bool⟧
  refl {true}   = ⟦true⟧
  refl {false}  = ⟦false⟧

  sym : Symmetric ⟦Bool⟧
  sym ⟦true⟧  = ⟦true⟧
  sym ⟦false⟧ = ⟦false⟧

  trans : Transitive ⟦Bool⟧
  trans ⟦true⟧   = id
  trans ⟦false⟧  = id

  subst : ∀ {ℓ} → Substitutive ⟦Bool⟧ ℓ
  subst _ ⟦true⟧   = id
  subst _ ⟦false⟧  = id

  _≟_ : Decidable ⟦Bool⟧
  true   ≟  true   = yes ⟦true⟧
  false  ≟  false  = yes ⟦false⟧
  true   ≟  false  = no (λ())
  false  ≟  true   = no (λ())

  isEquivalence : IsEquivalence ⟦Bool⟧
  isEquivalence = record { refl = refl; sym = sym; trans = trans }

  isDecEquivalence : IsDecEquivalence ⟦Bool⟧
  isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

  setoid : Setoid _ _
  setoid = record { Carrier = Bool; _≈_ = ⟦Bool⟧; isEquivalence = isEquivalence }

  decSetoid : DecSetoid _ _
  decSetoid = record { Carrier = Bool; _≈_ = ⟦Bool⟧; isDecEquivalence = isDecEquivalence }

  equality : Equality ⟦Bool⟧
  equality = record { isEquivalence = isEquivalence; subst = subst }

module ⟦Bool⟧-Props where
  open ⟦Bool⟧-Internals public using (subst; decSetoid; equality)
  open DecSetoid decSetoid public
  open Equality equality public hiding (subst; isEquivalence; refl; reflexive; sym; trans)

⟦if⟨_⟩_then_else_⟧ : ∀ {a₁ a₂ aᵣ} → (∀⟨ Aᵣ ∶ ⟦Set⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧ ⟦Bool⟧ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ) if_then_else_ if_then_else_
⟦if⟨_⟩_then_else_⟧ _ ⟦true⟧  xᵣ _ = xᵣ
⟦if⟨_⟩_then_else_⟧ _ ⟦false⟧ _ xᵣ = xᵣ

⟦If′⟨_,_⟩_then_else_⟧ : ∀ {ℓ₁ ℓ₂ ℓᵣ} →
                       (∀⟨ Aᵣ ∶ ⟦Set⟧ {ℓ₁} {ℓ₂} ℓᵣ ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦Set⟧ {ℓ₁} {ℓ₂} ℓᵣ ⟩⟦→⟧
                           ⟨ bᵣ ∶ ⟦Bool⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ ⟦if⟨ ⟦Set⟧ _ ⟩ bᵣ then Aᵣ else Bᵣ ⟧)
                       If′_then_else_ If′_then_else_
⟦If′⟨_,_⟩_then_else_⟧ _ _ ⟦true⟧  xᵣ _ = xᵣ
⟦If′⟨_,_⟩_then_else_⟧ _ _ ⟦false⟧ _ xᵣ = xᵣ

_==_ : (x y : Bool) → Bool
true == true = true
true == false = false
false == true = false
false == false = true

module == where
  _≈_ : (x y : Bool) → Set
  x ≈ y = T (x == y)

  refl : Reflexive _≈_
  refl {true}  = _
  refl {false} = _

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {true}   {true}   _ = id
  subst _ {false}  {false}  _ = id
  subst _ {true}   {false}  ()
  subst _ {false}  {true}   ()

  sym : Symmetric _≈_
  sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

  trans : Transitive _≈_
  trans {x} {y} {z} x≈y y≈z = subst (_≈_ x) {y} {z} y≈z x≈y

  _≟_ : Decidable _≈_
  true   ≟  true   = yes _
  false  ≟  false  = yes _
  true   ≟  false  = no (λ())
  false  ≟  true   = no (λ())

  isEquivalence : IsEquivalence _≈_
  isEquivalence = record { refl = λ {x} → refl {x}
                         ; sym = λ {x} {y} → sym {x} {y}
                         ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

  isDecEquivalence : IsDecEquivalence _≈_
  isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

  setoid : Setoid _ _
  setoid = record { Carrier = Bool; _≈_ = _≈_ ; isEquivalence = isEquivalence }

  decSetoid : DecSetoid _ _
  decSetoid = record { Carrier = Bool; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }

module ⟦Bool⟧-Reasoning = Setoid-Reasoning ⟦Bool⟧-Props.setoid

open Data.Bool public

⟦true⟧′ : ∀ {b} → T b → ⟦Bool⟧ true b
⟦true⟧′ {true}  _ = ⟦true⟧
⟦true⟧′ {false} ()

⟦false⟧′ : ∀ {b} → T (not b) → ⟦Bool⟧ false b
⟦false⟧′ {true} ()
⟦false⟧′ {false} _ = ⟦false⟧

T∧ : ∀ {b₁ b₂} → T b₁ → T b₂ → T (b₁ ∧ b₂)
T∧ p q = _⟨$⟩_ (from B.T-∧) (p , q)

T∧₁ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) → T b₁
T∧₁ = proj₁ ∘ _⟨$⟩_ (to B.T-∧)

T∧₂ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) → T b₂
T∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (B.T-∧ {b₁}))

T∨'⊎ : ∀ {b₁ b₂} → T (b₁ ∨ b₂) → T b₁ ⊎ T b₂
T∨'⊎ {b₁} = _⟨$⟩_ (to (B.T-∨ {b₁}))

T∨₁ : ∀ {b₁ b₂} → T b₁ → T (b₁ ∨ b₂)
T∨₁ = _⟨$⟩_ (from B.T-∨) ∘ inj₁

T∨₂ : ∀ {b₁ b₂} → T b₂ → T (b₁ ∨ b₂)
T∨₂ {b₁} = _⟨$⟩_ (from (B.T-∨ {b₁})) ∘ inj₂

T'not'¬ : ∀ {b} → T (not b) → ¬ (T b)
T'not'¬ {false} _ = λ()
T'not'¬ {true} ()

T'¬'not : ∀ {b} → ¬ (T b) → T (not b)
T'¬'not {true}  f = f _
T'¬'not {false} _ = _

Tdec : ∀ b → Dec (T b)
Tdec true = yes _
Tdec false = no λ()

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan true  _ = ≡.refl
de-morgan false _ = ≡.refl


Added ++-Stream.

Added ++-Stream.

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream

-----------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Stream predicate is also a pre-fixed point of the functional
-- StreamF, i.e.
--
-- StreamF Stream ≤ Stream (see FOTC.Data.Stream.Type).
Stream-pre-fixed : ∀ {xs} →
                   (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs') →
                   Stream xs
Stream-pre-fixed {xs} h = Stream-coind (λ ys → ys ≡ ys) h' refl
  where
  h' : xs ≡ xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ xs' ≡ xs'
  h' _ with h
  ... | x' , xs' , prf , _ = x' , xs' , prf , refl

++-Stream : ∀ {xs ys} → Stream xs → Stream ys → Stream (xs ++ ys)
++-Stream {xs} {ys} Sxs Sys with Stream-unf Sxs
... | x' , xs' , prf , Sxs' = subst Stream prf₁ prf₂
  where
  prf₁ : x' ∷ (xs' ++ ys) ≡ xs ++ ys
  prf₁ = trans (sym (++-∷ x' xs' ys)) (++-leftCong (sym prf))

  -- TODO (15 December 2013): Why the termination checker accepts the
  -- recursive called ++-Stream_Sxs'_Sys?
  prf₂ : Stream (x' ∷ xs' ++ ys)
  prf₂ = Stream-pre-fixed (x' , xs' ++ ys , refl , ++-Stream Sxs' Sys)

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS h with Stream-unf h
... | x' , xs' , prf , Sxs' =
  subst Stream (sym (∧-proj₂ (∷-injective prf))) Sxs'

streamLength : ∀ {xs} → Stream xs → length xs ≈N ∞
streamLength {xs} Sxs = ≈N-coind (λ m _ → m ≡ m) h refl
  where

  h : length xs ≡ length xs → length xs ≡ zero ∧ ∞ ≡ zero
        ∨ (∃[ m ] ∃[ n ] length xs ≡ succ₁ m ∧ ∞ ≡ succ₁ n ∧ m ≡ m)
  h _ with Stream-unf Sxs
  ... | x' , xs' , xs≡x'∷xs' , _ = inj₂ (length xs' , ∞ , prf , ∞-eq , refl)
    where
    prf : length xs ≡ succ₁ (length xs')
    prf = trans (lengthCong xs≡x'∷xs') (length-∷ x' xs')

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream

-----------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Stream predicate is also a pre-fixed point of the functional
-- StreamF, i.e.
--
-- StreamF Stream ≤ Stream (see FOTC.Data.Stream.Type).
Stream-pre-fixed : ∀ {xs} →
                   (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs') →
                   Stream xs
Stream-pre-fixed {xs} h = Stream-coind (λ ys → ys ≡ ys) h' refl
  where
  h' : xs ≡ xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ xs' ≡ xs'
  h' _ with h
  ... | x' , xs' , prf , _ = x' , xs' , prf , refl

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS h with Stream-unf h
... | x' , xs' , prf , Sxs' =
  subst Stream (sym (∧-proj₂ (∷-injective prf))) Sxs'

streamLength : ∀ {xs} → Stream xs → length xs ≈N ∞
streamLength {xs} Sxs = ≈N-coind (λ m _ → m ≡ m) h refl
  where

  h : length xs ≡ length xs → length xs ≡ zero ∧ ∞ ≡ zero
        ∨ (∃[ m ] ∃[ n ] length xs ≡ succ₁ m ∧ ∞ ≡ succ₁ n ∧ m ≡ m)
  h _ with Stream-unf Sxs
  ... | x' , xs' , xs≡x'∷xs' , _ = inj₂ (length xs' , ∞ , prf , ∞-eq , refl)
    where
    prf : length xs ≡ succ₁ (length xs')
    prf = trans (lengthCong xs≡x'∷xs') (length-∷ x' xs')


flipbased: waste and weaken

flipbased: waste and weaken

open import Algebra
import Level as L
open L using () renaming (_⊔_ to _L⊔_)
open import Function hiding (_⟨_⟩_)
open import Data.Nat.NP hiding (_==_)
open import Data.Bool
open import Data.Unit using (⊤)
open import Data.Nat.Properties
open import Data.Product using (proj₁; proj₂; _,_; swap; _×_)
open import Data.Bits
open import Data.Bool
open import Data.Vec using (Vec; []; _∷_; take; drop; head; tail) renaming (map to vmap)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module flipbased
   (↺ : ∀ {a} → ℕ → Set a → Set a)
   (toss : ↺ 1 Bit)
   (return↺ : ∀ {n a} {A : Set a} → A → ↺ n A)
   (map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B)
   (join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A)
 where

Coins = ℕ

-- If you are not allowed to toss any coin, then you are deterministic.
Det : ∀ {a} → Set a → Set a
Det = ↺ 0

-- An experiment
EXP : ℕ → Set
EXP n = ↺ n Bit

-- A guessing game
⅁? : ∀ c → Set
⅁? c = Bit → EXP c

returnᴰ : ∀ {a} {A : Set a} → A → Det A
returnᴰ = return↺

pureᴰ : ∀ {a} {A : Set a} → A → Det A
pureᴰ = returnᴰ

coerce : ∀ {m n a} {A : Set a} → m ≡ n → ↺ m A → ↺ n A
coerce ≡.refl = id

_>>=_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       ↺ n₁ A → (A → ↺ n₂ B) → ↺ (n₁ + n₂) B
_>>=_ x f = join↺ (map↺ f x)

_=<<_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       (A → ↺ n₁ B) → ↺ n₂ A → ↺ (n₁ + n₂) B
_=<<_ {n₁} {n₂} rewrite ℕ°.+-comm n₁ n₂ = flip _>>=_

_>>_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       ↺ n₁ A → ↺ n₂ B → ↺ (n₁ + n₂) B
_>>_ {n₁} x y = x >>= const y

_>=>_ : ∀ {n₁ n₂ a b c} {A : Set a} {B : Set b} {C : Set c}
        → (A → ↺ n₁ B) → (B → ↺ n₂ C) → A → ↺ (n₁ + n₂) C
(f >=> g) x = f x >>= g

waste : ∀ n → ↺ n ⊤
waste n = return↺ {n} _

weaken : ∀ m {n a} {A : Set a} → ↺ n A → ↺ (m + n) A
weaken m x = waste m >> x

weaken′ : ∀ {m n a} {A : Set a} → ↺ n A → ↺ (n + m) A
weaken′ x = x >>= return↺

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → ↺ m A → ↺ n A
weaken≤ pf x with ≤⇒∃ pf
... | k , ≡.refl = weaken′ x

pure↺ : ∀ {n a} {A : Set a} → A → ↺ n A
pure↺ = return↺

-- Weakened version of toss
tossᵂ : ∀ {n} → ↺ (1 + n) Bit
tossᵂ = toss >>= return↺

_▹↺_ : ∀ {n a b} {A : Set a} {B : Set b} → ↺ n A → (A → B) → ↺ n B
x ▹↺ f = map↺ f x

⟪_⟫ : ∀ {n} {a} {A : Set a} → A → ↺ n A
⟪_⟫ = pure↺

⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
⟪_⟫ᴰ = pureᴰ

⟪_·_⟫ : ∀ {a b} {A : Set a} {B : Set b} {n} → (A → B) → ↺ n A → ↺ n B
⟪ f · x ⟫ = map↺ f x

infixl 4 _⊛_
_⊛_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       ↺ n₁ (A → B) → ↺ n₂ A → ↺ (n₁ + n₂) B
_⊛_ {n₁} mf mx = mf >>= λ f → ⟪ f · mx ⟫

⟪_·_·_⟫ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
            (A → B → C) → ↺ m A → ↺ n B → ↺ (m + n) C
⟪ f · x · y ⟫ = map↺ f x ⊛ y

⟪_·_·_·_⟫ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} {m n o} →
              (A → B → C → D) → ↺ m A → ↺ n B → ↺ o C → ↺ (m + n + o) D
⟪ f · x · y · z ⟫ = map↺ f x ⊛ y ⊛ z

choose : ∀ {n a} {A : Set a} → ↺ n A → ↺ n A → ↺ (suc n) A
choose x y = toss >>= λ b → if b then x else y

zip↺ : ∀ {c₀ c₁ a b} {A : Set a} {B : Set b} → ↺ c₀ A → ↺ c₁ B → ↺ (c₀ + c₁) (A × B)
zip↺ x y = ⟪ _,_ · x · y ⟫

_⟨,⟩_ : ∀ {a b} {A : Set a} {B : Set b} {m n} → ↺ m A → ↺ n B → ↺ (m + n) (A × B)
_⟨,⟩_ = zip↺

_⟨xor⟩_ : ∀ {n₁ n₂} → ↺ n₁ Bit → ↺ n₂ Bit → ↺ (n₁ + n₂) Bit
x ⟨xor⟩ y = ⟪ _xor_ · x · y ⟫

_⟨⊕⟩_ : ∀ {n₁ n₂ m} → ↺ n₁ (Bits m) → ↺ n₂ (Bits m) → ↺ (n₁ + n₂) (Bits m)
x ⟨⊕⟩ y = ⟪ _⊕_ · x · y ⟫

_⟨∷⟩_ : ∀ {n₁ n₂ m a} {A : Set a} → ↺ n₁ A → ↺ n₂ (Vec A m) → ↺ (n₁ + n₂) (Vec A (suc m))
x ⟨∷⟩ xs = ⟪ _∷_ · x · xs ⟫

_⟨==⟩_ : ∀ {n₁ n₂ m} → ↺ n₁ (Bits m) → ↺ n₂ (Bits m) → ↺ (n₁ + n₂) Bit
x ⟨==⟩ y = ⟪ _==_ · x · y ⟫

T↺ : ∀ {k} → ↺ k Bit → ↺ k Set
T↺ p = ⟪ T · p ⟫

replicate↺ : ∀ {n m} {a} {A : Set a} → ↺ m A → ↺ (n * m) (Vec A n)
replicate↺ {zero}  _ = ⟪ [] ⟫
replicate↺ {suc _} x = x ⟨∷⟩ replicate↺ x

not↺ : ∀ {n} → EXP n → EXP n
not↺ = map↺ not

random : ∀ {n} → ↺ n (Bits n)
-- random = coerce ? (replicate↺ toss) -- specialized version for now to avoid coerce
random {zero}  = ⟪ [] ⟫
random {suc _} = ⟪ _∷_ · toss · random ⟫

randomTbl : ∀ m n → ↺ (2^ m * n) (Vec (Bits n) (2^ m))
randomTbl m n = replicate↺ random

randomFunFromTbl : ∀ m n → ↺ (2^ m * n) (Bits m → Bits n)
randomFunFromTbl m n = ⟪ funFromTbl · randomTbl m n ⟫

randomFunExt : ∀ {n k a} {A : Set a} → ↺ k (Bits n → A) → ↺ (k + k) (Bits (suc n) → A)
randomFunExt f = ⟪ comb · f · f ⟫
  where comb = λ g₁ g₂ xs → (if head xs then g₁ else g₂) (tail xs)

randomFun : ∀ m n → ↺ (2^⟨ m ⟩* n) (Bits m → Bits n)
randomFun zero    _ = ⟪ const · random ⟫
randomFun (suc m) _ = randomFunExt (randomFun m _)

record ProgEquiv a ℓ : Set (L.suc ℓ L⊔ L.suc a) where
  infix 2 _≈_ _≋_
  field
    _≈_ : ∀ {n} {A : Set a} → Rel (↺ n A) ℓ

    refl  : ∀ {n A} → Reflexive {A = ↺ n A} _≈_
    sym   : ∀ {n A} → Symmetric {A = ↺ n A} _≈_

    -- not strictly transitive

  reflexive : ∀ {n A} → _≡_ ⇒ _≈_ {n} {A}
  reflexive ≡.refl = refl

  _≋_ : ∀ {n₁ n₂} {A : Set a} → ↺ n₁ A → ↺ n₂ A → Set ℓ
  _≋_ {n₁} {n₂} p₁ p₂ = _≈_ {n = n₁ ⊔ n₂} (weaken≤ (m≤m⊔n _ _) p₁) (weaken≤ (m≤n⊔m _ n₁) p₂)
    where m≤n⊔m : ∀ m n → m ≤ n ⊔ m
          m≤n⊔m m n rewrite ⊔°.+-comm n m = m≤m⊔n m n

  -- Another name for _≋_
  _looks_ : ∀ {n₁ n₂} {A : Set a} → ↺ n₁ A → ↺ n₂ A → Set ℓ
  _looks_ = _≋_

module WithEquiv (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq

  SecPRG : ∀ {k n} (prg : (key : Bits k) → Bits n) → Set
  SecPRG prg = this looks random where this = ⟪ prg · random ⟫

  record PRG k n : Set where
    constructor _,_
    field
      prg : Bits k → Bits n
      sec : SecPRG prg

  OneTimeSecPRF : ∀ {k m n} (prf : (key : Bits k) (msg : Bits m) → Bits n) → Set
  OneTimeSecPRF prf = ∀ {xs} → let this = ⟪ prf · random · ⟪ xs ⟫ᴰ ⟫ in
                                this looks random

  record PRF k m n : Set where
    constructor _,_
    field
      prf : Bits k → Bits m → Bits n
      sec : OneTimeSecPRF prf

OTP : ∀ {n} → Bits n → Bits n → Bits n
OTP key msg = key ⊕ msg

init : ∀ {k a} {A : Set a} → (Bits k → A) → ↺ k A
init f = ⟪ f · random ⟫

module Examples (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq
  open WithEquiv progEq

  left-unit-law = ∀ {A B : Set} {n} {x : A} {f : A → ↺ n B} → returnᴰ x >>= f ≈ f x

  right-unit-law = ∀ {A : Set} {n} {x : ↺ n A} → returnᴰ =<< x ≈ x

  assoc-law = ∀ {A B C : Set} {n₁ n₂ n₃} {x : ↺ n₁ A} {f : A → ↺ n₂ B} {g : B → ↺ n₃ C}
              → (x >>= f) >>= g ≋ x >>= (λ x → f x >>= g)

  assoc-law′ = ∀ {A B C : Set} {n₁ n₂ n₃} {x : ↺ n₁ A} {f : A → ↺ n₂ B} {g : B → ↺ n₃ C}
              → (x >>= f) >>= g ≈ coerce (≡.sym (ℕ°.+-assoc n₁ n₂ n₃)) (x >>= (λ x → f x >>= g))

  ex₁ = ∀ {x} → toss ⟨xor⟩ ⟪ x ⟫ᴰ ≈ ⟪ x ⟫

  ex₂ = p ≈ map↺ swap p where p = toss ⟨,⟩ toss

  ex₃ = ∀ {n} → OneTimeSecPRF {n} OTP

  ex₄ = ∀ {k n} (prg : PRG k n) → OneTimeSecPRF (λ key xs → xs ⊕ PRG.prg prg key)

  ex₅ = ∀ {k n} → PRG k n → PRF k n n

open import Algebra
import Level as L
open L using () renaming (_⊔_ to _L⊔_)
open import Function hiding (_⟨_⟩_)
open import Data.Nat.NP hiding (_==_)
open import Data.Bool
open import Data.Nat.Properties
open import Data.Product using (proj₁; proj₂; _,_; swap; _×_)
open import Data.Bits
open import Data.Bool
open import Data.Vec using (Vec; []; _∷_; take; drop; head; tail) renaming (map to vmap)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module flipbased
   (↺ : ∀ {a} → ℕ → Set a → Set a)
   (toss : ↺ 1 Bit)
   (return↺ : ∀ {n a} {A : Set a} → A → ↺ n A)
   (map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B)
   (join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A)
 where

Coins = ℕ

-- If you are not allowed to toss any coin, then you are deterministic.
Det : ∀ {a} → Set a → Set a
Det = ↺ 0

-- An experiment
EXP : ℕ → Set
EXP n = ↺ n Bit

-- A guessing game
⅁? : ∀ c → Set
⅁? c = Bit → EXP c

returnᴰ : ∀ {a} {A : Set a} → A → Det A
returnᴰ = return↺

pureᴰ : ∀ {a} {A : Set a} → A → Det A
pureᴰ = returnᴰ

coerce : ∀ {m n a} {A : Set a} → m ≡ n → ↺ m A → ↺ n A
coerce ≡.refl = id

_>>=_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       ↺ n₁ A → (A → ↺ n₂ B) → ↺ (n₁ + n₂) B
_>>=_ x f = join↺ (map↺ f x)

_=<<_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       (A → ↺ n₁ B) → ↺ n₂ A → ↺ (n₁ + n₂) B
_=<<_ {n₁} {n₂} rewrite ℕ°.+-comm n₁ n₂ = flip _>>=_

_>>_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       ↺ n₁ A → ↺ n₂ B → ↺ (n₁ + n₂) B
_>>_ {n₁} x y = x >>= const y

_>=>_ : ∀ {n₁ n₂ a b c} {A : Set a} {B : Set b} {C : Set c}
        → (A → ↺ n₁ B) → (B → ↺ n₂ C) → A → ↺ (n₁ + n₂) C
(f >=> g) x = f x >>= g

weaken : ∀ m {n a} {A : Set a} → ↺ n A → ↺ (m + n) A
weaken m x = return↺ {m} 0 >> x

weaken′ : ∀ {m n a} {A : Set a} → ↺ n A → ↺ (n + m) A
weaken′ x = x >>= return↺

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → ↺ m A → ↺ n A
weaken≤ pf x with ≤⇒∃ pf
... | k , ≡.refl = weaken′ x

pure↺ : ∀ {n a} {A : Set a} → A → ↺ n A
pure↺ = return↺

-- Weakened version of toss
tossᵂ : ∀ {n} → ↺ (1 + n) Bit
tossᵂ = toss >>= return↺

_▹↺_ : ∀ {n a b} {A : Set a} {B : Set b} → ↺ n A → (A → B) → ↺ n B
x ▹↺ f = map↺ f x

⟪_⟫ : ∀ {n} {a} {A : Set a} → A → ↺ n A
⟪_⟫ = pure↺

⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
⟪_⟫ᴰ = pureᴰ

⟪_·_⟫ : ∀ {a b} {A : Set a} {B : Set b} {n} → (A → B) → ↺ n A → ↺ n B
⟪ f · x ⟫ = map↺ f x

infixl 4 _⊛_
_⊛_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       ↺ n₁ (A → B) → ↺ n₂ A → ↺ (n₁ + n₂) B
_⊛_ {n₁} mf mx = mf >>= λ f → ⟪ f · mx ⟫

⟪_·_·_⟫ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
            (A → B → C) → ↺ m A → ↺ n B → ↺ (m + n) C
⟪ f · x · y ⟫ = map↺ f x ⊛ y

⟪_·_·_·_⟫ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} {m n o} →
              (A → B → C → D) → ↺ m A → ↺ n B → ↺ o C → ↺ (m + n + o) D
⟪ f · x · y · z ⟫ = map↺ f x ⊛ y ⊛ z

choose : ∀ {n a} {A : Set a} → ↺ n A → ↺ n A → ↺ (suc n) A
choose x y = toss >>= λ b → if b then x else y

zip↺ : ∀ {c₀ c₁ a b} {A : Set a} {B : Set b} → ↺ c₀ A → ↺ c₁ B → ↺ (c₀ + c₁) (A × B)
zip↺ x y = ⟪ _,_ · x · y ⟫

_⟨,⟩_ : ∀ {a b} {A : Set a} {B : Set b} {m n} → ↺ m A → ↺ n B → ↺ (m + n) (A × B)
_⟨,⟩_ = zip↺

_⟨xor⟩_ : ∀ {n₁ n₂} → ↺ n₁ Bit → ↺ n₂ Bit → ↺ (n₁ + n₂) Bit
x ⟨xor⟩ y = ⟪ _xor_ · x · y ⟫

_⟨⊕⟩_ : ∀ {n₁ n₂ m} → ↺ n₁ (Bits m) → ↺ n₂ (Bits m) → ↺ (n₁ + n₂) (Bits m)
x ⟨⊕⟩ y = ⟪ _⊕_ · x · y ⟫

_⟨∷⟩_ : ∀ {n₁ n₂ m a} {A : Set a} → ↺ n₁ A → ↺ n₂ (Vec A m) → ↺ (n₁ + n₂) (Vec A (suc m))
x ⟨∷⟩ xs = ⟪ _∷_ · x · xs ⟫

_⟨==⟩_ : ∀ {n₁ n₂ m} → ↺ n₁ (Bits m) → ↺ n₂ (Bits m) → ↺ (n₁ + n₂) Bit
x ⟨==⟩ y = ⟪ _==_ · x · y ⟫

T↺ : ∀ {k} → ↺ k Bit → ↺ k Set
T↺ p = ⟪ T · p ⟫

replicate↺ : ∀ {n m} {a} {A : Set a} → ↺ m A → ↺ (n * m) (Vec A n)
replicate↺ {zero}  _ = ⟪ [] ⟫
replicate↺ {suc _} x = x ⟨∷⟩ replicate↺ x

not↺ : ∀ {n} → EXP n → EXP n
not↺ = map↺ not

random : ∀ {n} → ↺ n (Bits n)
-- random = coerce ? (replicate↺ toss) -- specialized version for now to avoid coerce
random {zero}  = ⟪ [] ⟫
random {suc _} = ⟪ _∷_ · toss · random ⟫

randomTbl : ∀ m n → ↺ (2^ m * n) (Vec (Bits n) (2^ m))
randomTbl m n = replicate↺ random

randomFunFromTbl : ∀ m n → ↺ (2^ m * n) (Bits m → Bits n)
randomFunFromTbl m n = ⟪ funFromTbl · randomTbl m n ⟫

randomFunExt : ∀ {n k a} {A : Set a} → ↺ k (Bits n → A) → ↺ (k + k) (Bits (suc n) → A)
randomFunExt f = ⟪ comb · f · f ⟫
  where comb = λ g₁ g₂ xs → (if head xs then g₁ else g₂) (tail xs)

randomFun : ∀ m n → ↺ (2^⟨ m ⟩* n) (Bits m → Bits n)
randomFun zero    _ = ⟪ const · random ⟫
randomFun (suc m) _ = randomFunExt (randomFun m _)

record ProgEquiv a ℓ : Set (L.suc ℓ L⊔ L.suc a) where
  infix 2 _≈_ _≋_
  field
    _≈_ : ∀ {n} {A : Set a} → Rel (↺ n A) ℓ

    refl  : ∀ {n A} → Reflexive {A = ↺ n A} _≈_
    sym   : ∀ {n A} → Symmetric {A = ↺ n A} _≈_

    -- not strictly transitive

  reflexive : ∀ {n A} → _≡_ ⇒ _≈_ {n} {A}
  reflexive ≡.refl = refl

  _≋_ : ∀ {n₁ n₂} {A : Set a} → ↺ n₁ A → ↺ n₂ A → Set ℓ
  _≋_ {n₁} {n₂} p₁ p₂ = _≈_ {n = n₁ ⊔ n₂} (weaken≤ (m≤m⊔n _ _) p₁) (weaken≤ (m≤n⊔m _ n₁) p₂)
    where m≤n⊔m : ∀ m n → m ≤ n ⊔ m
          m≤n⊔m m n rewrite ⊔°.+-comm n m = m≤m⊔n m n

  -- Another name for _≋_
  _looks_ : ∀ {n₁ n₂} {A : Set a} → ↺ n₁ A → ↺ n₂ A → Set ℓ
  _looks_ = _≋_

module WithEquiv (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq

  SecPRG : ∀ {k n} (prg : (key : Bits k) → Bits n) → Set
  SecPRG prg = this looks random where this = ⟪ prg · random ⟫

  record PRG k n : Set where
    constructor _,_
    field
      prg : Bits k → Bits n
      sec : SecPRG prg

  OneTimeSecPRF : ∀ {k m n} (prf : (key : Bits k) (msg : Bits m) → Bits n) → Set
  OneTimeSecPRF prf = ∀ {xs} → let this = ⟪ prf · random · ⟪ xs ⟫ᴰ ⟫ in
                                this looks random

  record PRF k m n : Set where
    constructor _,_
    field
      prf : Bits k → Bits m → Bits n
      sec : OneTimeSecPRF prf

OTP : ∀ {n} → Bits n → Bits n → Bits n
OTP key msg = key ⊕ msg

init : ∀ {k a} {A : Set a} → (Bits k → A) → ↺ k A
init f = ⟪ f · random ⟫

module Examples (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq
  open WithEquiv progEq

  left-unit-law = ∀ {A B : Set} {n} {x : A} {f : A → ↺ n B} → returnᴰ x >>= f ≈ f x

  right-unit-law = ∀ {A : Set} {n} {x : ↺ n A} → returnᴰ =<< x ≈ x

  assoc-law = ∀ {A B C : Set} {n₁ n₂ n₃} {x : ↺ n₁ A} {f : A → ↺ n₂ B} {g : B → ↺ n₃ C}
              → (x >>= f) >>= g ≋ x >>= (λ x → f x >>= g)

  assoc-law′ = ∀ {A B C : Set} {n₁ n₂ n₃} {x : ↺ n₁ A} {f : A → ↺ n₂ B} {g : B → ↺ n₃ C}
              → (x >>= f) >>= g ≈ coerce (≡.sym (ℕ°.+-assoc n₁ n₂ n₃)) (x >>= (λ x → f x >>= g))

  ex₁ = ∀ {x} → toss ⟨xor⟩ ⟪ x ⟫ᴰ ≈ ⟪ x ⟫

  ex₂ = p ≈ map↺ swap p where p = toss ⟨,⟩ toss

  ex₃ = ∀ {n} → OneTimeSecPRF {n} OTP

  ex₄ = ∀ {k n} (prg : PRG k n) → OneTimeSecPRF (λ key xs → xs ⊕ PRG.prg prg key)

  ex₅ = ∀ {k n} → PRG k n → PRF k n n


update protocols.agda

update protocols.agda

module protocols where
import Control.Protocol
import Control.Protocol.Additive
import Control.Protocol.CLL
import Control.Protocol.ClientServer
import Control.Protocol.Examples
import Control.Protocol.Extend
import Control.Protocol.Lift
import Control.Protocol.MultiParty
import Control.Protocol.Multiplicative
import Control.Protocol.Relation
import Control.Protocol.Sequence

module protocols where
import Control.Protocol
import Control.Protocol.Additive
import Control.Protocol.CLL
import Control.Protocol.ClientServer
import Control.Protocol.Examples
import Control.Protocol.MultiParty
import Control.Protocol.Multiplicative
import Control.Protocol.Relation
import Control.Protocol.Sequence


Cosmetic change.

Cosmetic change.

Ignore-this: 364ef2c60263dc8dc66151b308396671

darcs-hash:20120119215014-3bd4e-c2fdcf5ffb49d2aa51fe222d53b7ffd098ac17d1.gz

-- Tested on 08 December 2011.

module BottomBottom where

open import Common.Universe
open import Common.Data.Empty

postulate bot₁ bot₂ : ⊥
{-# ATP prove bot₁ bot₂ #-}
{-# ATP prove bot₂ bot₁ #-}

-- $ agda2atp -i src -i notes/papers/FoSSaCS-2012/ notes/papers/FoSSaCS-2012/BottomBottom.agda
-- Proving the conjecture in /tmp/BottomBottom.bot1_8.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/BottomBottom.bot1_8.tptp
-- Proving the conjecture in /tmp/BottomBottom.bot2_8.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/BottomBottom.bot2_8.tptp


generic-zero-knowledge-interactive: Finishing DLog

open import Data.Bool.NP as Bool hiding (check)
open import Data.Nat
open import Data.Maybe
open import Data.Product.NP
open import Data.Bits
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP

open import sum

module generic-zero-knowledge-interactive where

private
  ★ : Set₁
  ★ = Set

-- A random argument, this is only a formal notation to
-- indicate that the argument is supposed to be picked
-- at random uniformly. (do not confuse with our randomness
-- monad).
record ↺ (A : ★) : ★ where
  constructor rand
  field get : A

module M (Permutation : ★)
         (_⁻¹         : Endo Permutation)
         (sumπ        : Sum Permutation)
         (μπ          : SumProp sumπ)

         (Rₚ-xtra     : ★) -- extra prover/adversary randomness
         (sumRₚ-xtra  : Sum Rₚ-xtra)
         (μRₚ-xtra    : SumProp sumRₚ-xtra)

         (Problem     : ★)
         (_==_        : Problem → Problem → Bit)
         (==-refl     : ∀ {pb} → (pb == pb) ≡ true)
         (_∙P_        : Permutation → Endo Problem)
         (⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x)

         (Solution    : ★)
         (_∙S_        : Permutation → Endo Solution)
         (⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x)

         (check       : Problem → Solution → Bit)
         (check-∙     : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s)

         (easy-pb     : Permutation → Problem)
         (easy-sol    : Permutation → Solution)
         (check-easy  : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true)
    where

    -- prover/adversary randomness
    Rₚ : ★
    Rₚ = Permutation × Rₚ-xtra

    sumRₚ : Sum Rₚ
    sumRₚ = sumπ ×Sum sumRₚ-xtra

    μRₚ : SumProp sumRₚ
    μRₚ = μπ ×μ μRₚ-xtra

    R = Bit × Rₚ

    sumR : Sum R
    sumR = sumBit ×Sum sumRₚ

    μR : SumProp sumR
    μR = μBit ×μ μRₚ

    check-π : Problem → Solution → Rₚ → Bit
    check-π p s (π , _) = check (π ∙P p) (π ∙S s)

    otp-∙-check : let #_ = count μRₚ
                  in
                  ∀ p₀ s₀ p₁ s₁ →
                    check p₀ s₀ ≡ check p₁ s₁ →
                    #(check-π p₀ s₀) ≡ #(check-π p₁ s₁)
    otp-∙-check p₀ s₀ p₁ s₁ check-pf =
      count-ext μRₚ {f = check-π p₀ s₀} {check-π p₁ s₁} (λ π,r →
        check-π p₀ s₀ π,r ≡⟨ check-∙ p₀ s₀ (proj₁ π,r) ⟩
        check p₀ s₀       ≡⟨ check-pf ⟩
        check p₁ s₁       ≡⟨ sym (check-∙ p₁ s₁ (proj₁ π,r)) ⟩
        check-π p₁ s₁ π,r ∎)
        where open ≡-Reasoning

    #_ : (↺ (Bit × Permutation × Rₚ-xtra) → Bit) → ℕ
    # f = count μR (f ∘ rand)

    _≡#_ : (f g : ↺ (Bit × Rₚ) → Bit) → ★
    f ≡# g = # f ≡ # g

{-
    otp-∙ : let otp = λ O pb s → count μRₚ (λ { (π , _) → O (π ∙P pb) (π ∙S s) }) in
            ∀ pb₀ s₀ pb₁ s₁ →
              check pb₀ s₀ ≡ check pb₁ s₁ →
              (O : _ → _ → Bit) → otp O pb₀ s₀ ≡ otp O pb₁ s₁
    otp-∙ pb₀ s₀ pb₁ s₁ check-pf O = {!(μπ ×Sum-proj₂ μRₚ-xtra    ?!}
-}
    Answer : Bit → ★
    Answer false{-0b-} = Permutation
    Answer true {-1b-} = Solution

    answer : Permutation → Solution → ∀ b → Answer b
    answer π _ false = π
    answer _ s true  = s

    -- The prover is the advesary in the generic terminology,
    -- and the verifier is the challenger.
    DepProver : ★
    DepProver = Problem → ↺ Rₚ → (b : Bit) → Problem × Answer b

    Prover₀ : ★
    Prover₀ = Problem → ↺ Rₚ → Problem × Permutation

    Prover₁ : ★
    Prover₁ = Problem → ↺ Rₚ → Problem × Solution

    Prover : ★
    Prover = Prover₀ × Prover₁

    prover : DepProver → Prover
    prover dpr = (λ pb r → dpr pb r 0b) , (λ pb r → dpr pb r 1b)

    depProver : Prover → DepProver
    depProver (pr₀ , pr₁) pb r false = pr₀ pb r
    depProver (pr₀ , pr₁) pb r true  = pr₁ pb r

    -- Here we show that the explicit commitment step seems useless given
    -- the formalization. The verifier can "trust" the prover on the fact
    -- that any choice is going to be govern only by the problem and the
    -- randomness.
    module WithCommitment (Commitment : ★)
                          (AnswerWC   : Bit → ★)
                          (reveal     : ∀ b → Commitment → AnswerWC b → Problem × Answer b) where
        ProverWC = (Problem → Rₚ → Commitment)
                 × (Problem → Rₚ → (b : Bit) → AnswerWC b)

        depProver' : ProverWC → DepProver
        depProver' (pr₀ , pr₁) pb (rand rₚ) b = reveal b (pr₀ pb rₚ) (pr₁ pb rₚ b)

    Verif : Problem → ∀ b → Problem × Answer b → Bit
    Verif pb false{-0b-} (π∙pb , π)   = (π ∙P pb) == π∙pb
    Verif pb true {-1b-} (π∙pb , π∙s) = check π∙pb π∙s

    _⇄′_ : Problem → DepProver → Bit → ↺ Rₚ → Bit
    (pb ⇄′ pr) b (rand rₚ) = Verif pb b (pr pb (rand rₚ) b)

    _⇄_ : Problem → DepProver → ↺ (Bit × Rₚ) → Bit
    (pb ⇄ pr) (rand (b , rₚ)) = (pb ⇄′ pr) b (rand rₚ)

    _⇄''_ : Problem → Prover → ↺ (Bit × Rₚ) → Bit
    pb ⇄'' pr = pb ⇄ depProver pr

    honest : (Problem → Maybe Solution) → DepProver
    honest solve pb (rand (π , rₚ)) b = (π ∙P pb , answer π sol b)
      module Honest where
        sol : Solution
        sol with solve pb
        ...    | just sol = π ∙S sol
        ...    | nothing  = π ∙S easy-sol π

    module WithCorrectSolver (pb      : Problem)
                             (s       : Solution)
                             (check-s : check pb s ≡ true)
                             where

        -- When the honest prover has a solution, he gets accepted
        -- unconditionally by the verifier.
        honest-accepted : ∀ r → (pb ⇄ honest (const (just s))) r ≡ 1b
        honest-accepted (rand (true  , π , rₚ)) rewrite check-∙ pb s π = check-s
        honest-accepted (rand (false , π , rₚ)) = ==-refl

    honest-⅁ = λ pb s → (pb ⇄ honest (const (just s)))

    module HonestLeakZeroKnowledge (pb₀ pb₁  : Problem)
                                   (s₀ s₁    : Solution)
                                   (check-pf : check pb₀ s₀ ≡ check pb₁ s₁) where

        helper : ∀ rₚ → Bool.toℕ ((pb₀ ⇄′ honest (const (just s₀))) 0b (rand rₚ))
                      ≡ Bool.toℕ ((pb₁ ⇄′ honest (const (just s₁))) 0b (rand rₚ))
        helper (π , rₚ) rewrite ==-refl {π ∙P pb₀} | ==-refl {π ∙P pb₁} = refl

        honest-leak : honest-⅁ pb₀ s₀ ≡# honest-⅁ pb₁ s₁
        honest-leak rewrite otp-∙-check pb₀ s₀ pb₁ s₁ check-pf | sum-ext μRₚ helper = refl

    module HonestLeakZeroKnowledge' (pb       : Problem)
                                    (s₀ s₁    : Solution)
                                    (check-pf : check pb s₀ ≡ check pb s₁) where

        honest-leak : honest-⅁ pb s₀ ≡# honest-⅁ pb s₁
        honest-leak = HonestLeakZeroKnowledge.honest-leak pb pb s₀ s₁ check-pf

    -- Predicts b=b′
    cheater : ∀ b′ → DepProver
    cheater b′ pb (rand (π , _)) b = π ∙P (case b′ 0→ pb 1→ easy-pb π)
                                   , answer π (π ∙S easy-sol π) b

    -- If cheater predicts correctly, verifer accepts him
    cheater-accepted : ∀ b pb rₚ → (pb ⇄′ cheater b) b rₚ ≡ 1b
    cheater-accepted true  pb (rand (π , rₚ)) = check-easy π
    cheater-accepted false pb (rand (π , rₚ)) = ==-refl

    -- If cheater predicts incorrecty, verifier rejects him
    module CheaterRejected (pb : Problem)
                           (not-easy-sol : ∀ π → check (π ∙P pb) (π ∙S easy-sol π) ≡ false)
                           (not-easy-pb  : ∀ π → ((π ∙P pb) == (π ∙P easy-pb π)) ≡ false) where

        cheater-rejected : ∀ b rₚ → (pb ⇄′ cheater (not b)) b rₚ ≡ 0b
        cheater-rejected true  (rand (π , rₚ)) = not-easy-sol π
        cheater-rejected false (rand (π , rₚ)) = not-easy-pb π

module DLog (ℤq  : ★)
            (_⊞_ : ℤq → ℤq → ℤq)
            (⊟_  : ℤq → ℤq)
            (G   : ★)
            (g   : G)
            (_^_ : G → ℤq → G)
            (_∙_ : G → G → G)
            (⊟-⊞ : ∀ π x → (⊟ π) ⊞ (π ⊞ x) ≡ x)
            (^⊟-∙ : ∀ α β x → ((α ^ (⊟ x)) ∙ ((α ^ x) ∙ β)) ≡ β)
            -- (∙-assoc : ∀ α β γ → α ∙ (β ∙ γ) ≡ (α ∙ β) ∙ γ)
            (dist-^-⊞ : ∀ α x y → α ^ (x ⊞ y) ≡ (α ^ x) ∙ (α ^ y))
            (_==_ : G → G → Bool)
            (==-refl  : ∀ {α} → (α == α) ≡ true)
            (==-cong  : ∀ {α β b} (f : G → G) → α == β ≡ b → f α == f β ≡ b)
            (==-true  : ∀ {α β} → α == β ≡ true → α ≡ β)
            (sumℤq      : Sum ℤq)
            (μℤq        : SumProp sumℤq)
            (Rₚ-xtra    : ★) -- extra prover/adversary randomness
            (sumRₚ-xtra : Sum Rₚ-xtra)
            (μRₚ-xtra   : SumProp sumRₚ-xtra)
            (some-ℤq    : ℤq)
   where

   Permutation = ℤq
   Problem = G
   Solution = ℤq

   _⁻¹ : Endo Permutation
   π ⁻¹ = ⊟ π

   g^_ : ℤq → G
   g^ x = g ^ x

   _∙P_ : Permutation → Endo Problem
   π ∙P p = g^ π ∙ p

   ⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x
   ⁻¹-inverseP π x rewrite ^⊟-∙ g x π = refl

   _∙S_ : Permutation → Endo Solution
   π ∙S s = π ⊞ s

   ⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x
   ⁻¹-inverseS = ⊟-⊞

   check : Problem → Solution → Bit
   check p s = p == g^ s

   check-∙' : ∀ p s π b → check p s ≡ b → check (π ∙P p) (π ∙S s) ≡ b
   check-∙' p s π true  check-p-s rewrite dist-^-⊞ g π s | ==-true check-p-s = ==-refl
   check-∙' p s π false check-p-s rewrite dist-^-⊞ g π s = ==-cong (_∙_ (g^ π)) check-p-s

   check-∙ : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s
   check-∙ p s π = check-∙' p s π (check p s) refl

   easy-sol : Permutation → Solution
   easy-sol π = some-ℤq

   easy-pb : Permutation → Problem
   easy-pb π = g^(easy-sol π)

   check-easy : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true
   check-easy π rewrite dist-^-⊞ g π (easy-sol π) = ==-refl

   open M Permutation _⁻¹ sumℤq μℤq Rₚ-xtra sumRₚ-xtra μRₚ-xtra
          Problem _==_ ==-refl _∙P_ ⁻¹-inverseP Solution _∙S_ ⁻¹-inverseS check check-∙ easy-pb easy-sol check-easy
-- -}
-- -}
-- -}
-- -}
-- -}

open import Data.Bool.NP as Bool hiding (check)
open import Data.Nat
open import Data.Maybe
open import Data.Product.NP
open import Data.Bits
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP

open import sum

module generic-zero-knowledge-interactive where

private
  ★ : Set₁
  ★ = Set

-- A random argument, this is only a formal notation to
-- indicate that the argument is supposed to be picked
-- at random uniformly. (do not confuse with our randomness
-- monad).
record ↺ (A : ★) : ★ where
  constructor rand
  field get : A

module M (Permutation : ★)
         (_⁻¹         : Endo Permutation)
         (sumπ        : Sum Permutation)
         (μπ          : SumProp sumπ)

         (Rₚ-xtra     : ★) -- extra prover/adversary randomness
         (sumRₚ-xtra  : Sum Rₚ-xtra)
         (μRₚ-xtra    : SumProp sumRₚ-xtra)

         (Problem     : ★)
         (_==_        : Problem → Problem → Bit)
         (==-refl     : ∀ {pb} → (pb == pb) ≡ true)
         (_∙P_        : Permutation → Endo Problem)
         (⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x)

         (Solution    : ★)
         (_∙S_        : Permutation → Endo Solution)
         (⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x)

         (check       : Problem → Solution → Bit)
         (check-∙     : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s)

         (easy-pb     : Permutation → Problem)
         (easy-sol    : Permutation → Solution)
         (check-easy  : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true)
    where

    -- prover/adversary randomness
    Rₚ : ★
    Rₚ = Permutation × Rₚ-xtra

    sumRₚ : Sum Rₚ
    sumRₚ = sumπ ×Sum sumRₚ-xtra

    μRₚ : SumProp sumRₚ
    μRₚ = μπ ×μ μRₚ-xtra

    R = Bit × Rₚ

    sumR : Sum R
    sumR = sumBit ×Sum sumRₚ

    μR : SumProp sumR
    μR = μBit ×μ μRₚ

    check-π : Problem → Solution → Rₚ → Bit
    check-π p s (π , _) = check (π ∙P p) (π ∙S s)

    otp-∙-check : let #_ = count μRₚ
                  in
                  ∀ p₀ s₀ p₁ s₁ →
                    check p₀ s₀ ≡ check p₁ s₁ →
                    #(check-π p₀ s₀) ≡ #(check-π p₁ s₁)
    otp-∙-check p₀ s₀ p₁ s₁ check-pf =
      count-ext μRₚ {f = check-π p₀ s₀} {check-π p₁ s₁} (λ π,r →
        check-π p₀ s₀ π,r ≡⟨ check-∙ p₀ s₀ (proj₁ π,r) ⟩
        check p₀ s₀       ≡⟨ check-pf ⟩
        check p₁ s₁       ≡⟨ sym (check-∙ p₁ s₁ (proj₁ π,r)) ⟩
        check-π p₁ s₁ π,r ∎)
        where open ≡-Reasoning

    #_ : (↺ (Bit × Permutation × Rₚ-xtra) → Bit) → ℕ
    # f = count μR (f ∘ rand)

    _≡#_ : (f g : ↺ (Bit × Rₚ) → Bit) → ★
    f ≡# g = # f ≡ # g

{-
    otp-∙ : let otp = λ O pb s → count μRₚ (λ { (π , _) → O (π ∙P pb) (π ∙S s) }) in
            ∀ pb₀ s₀ pb₁ s₁ →
              check pb₀ s₀ ≡ check pb₁ s₁ →
              (O : _ → _ → Bit) → otp O pb₀ s₀ ≡ otp O pb₁ s₁
    otp-∙ pb₀ s₀ pb₁ s₁ check-pf O = {!(μπ ×Sum-proj₂ μRₚ-xtra    ?!}
-}
    Answer : Bit → ★
    Answer false{-0b-} = Permutation
    Answer true {-1b-} = Solution

    answer : Permutation → Solution → ∀ b → Answer b
    answer π _ false = π
    answer _ s true  = s

    -- The prover is the advesary in the generic terminology,
    -- and the verifier is the challenger.
    DepProver : ★
    DepProver = Problem → ↺ Rₚ → (b : Bit) → Problem × Answer b

    Prover₀ : ★
    Prover₀ = Problem → ↺ Rₚ → Problem × Permutation

    Prover₁ : ★
    Prover₁ = Problem → ↺ Rₚ → Problem × Solution

    Prover : ★
    Prover = Prover₀ × Prover₁

    prover : DepProver → Prover
    prover dpr = (λ pb r → dpr pb r 0b) , (λ pb r → dpr pb r 1b)

    depProver : Prover → DepProver
    depProver (pr₀ , pr₁) pb r false = pr₀ pb r
    depProver (pr₀ , pr₁) pb r true  = pr₁ pb r

    -- Here we show that the explicit commitment step seems useless given
    -- the formalization. The verifier can "trust" the prover on the fact
    -- that any choice is going to be govern only by the problem and the
    -- randomness.
    module WithCommitment (Commitment : ★)
                          (AnswerWC   : Bit → ★)
                          (reveal     : ∀ b → Commitment → AnswerWC b → Problem × Answer b) where
        ProverWC = (Problem → Rₚ → Commitment)
                 × (Problem → Rₚ → (b : Bit) → AnswerWC b)

        depProver' : ProverWC → DepProver
        depProver' (pr₀ , pr₁) pb (rand rₚ) b = reveal b (pr₀ pb rₚ) (pr₁ pb rₚ b)

    Verif : Problem → ∀ b → Problem × Answer b → Bit
    Verif pb false{-0b-} (π∙pb , π)   = (π ∙P pb) == π∙pb
    Verif pb true {-1b-} (π∙pb , π∙s) = check π∙pb π∙s

    _⇄′_ : Problem → DepProver → Bit → ↺ Rₚ → Bit
    (pb ⇄′ pr) b (rand rₚ) = Verif pb b (pr pb (rand rₚ) b)

    _⇄_ : Problem → DepProver → ↺ (Bit × Rₚ) → Bit
    (pb ⇄ pr) (rand (b , rₚ)) = (pb ⇄′ pr) b (rand rₚ)

    _⇄''_ : Problem → Prover → ↺ (Bit × Rₚ) → Bit
    pb ⇄'' pr = pb ⇄ depProver pr

    honest : (Problem → Maybe Solution) → DepProver
    honest solve pb (rand (π , rₚ)) b = (π ∙P pb , answer π sol b)
      module Honest where
        sol : Solution
        sol with solve pb
        ...    | just sol = π ∙S sol
        ...    | nothing  = π ∙S easy-sol π

    module WithCorrectSolver (pb      : Problem)
                             (s       : Solution)
                             (check-s : check pb s ≡ true)
                             where

        -- When the honest prover has a solution, he gets accepted
        -- unconditionally by the verifier.
        honest-accepted : ∀ r → (pb ⇄ honest (const (just s))) r ≡ 1b
        honest-accepted (rand (true  , π , rₚ)) rewrite check-∙ pb s π = check-s
        honest-accepted (rand (false , π , rₚ)) = ==-refl

    honest-⅁ = λ pb s → (pb ⇄ honest (const (just s)))

    module HonestLeakZeroKnowledge (pb₀ pb₁  : Problem)
                                   (s₀ s₁    : Solution)
                                   (check-pf : check pb₀ s₀ ≡ check pb₁ s₁) where

        helper : ∀ rₚ → Bool.toℕ ((pb₀ ⇄′ honest (const (just s₀))) 0b (rand rₚ))
                      ≡ Bool.toℕ ((pb₁ ⇄′ honest (const (just s₁))) 0b (rand rₚ))
        helper (π , rₚ) rewrite ==-refl {π ∙P pb₀} | ==-refl {π ∙P pb₁} = refl

        honest-leak : honest-⅁ pb₀ s₀ ≡# honest-⅁ pb₁ s₁
        honest-leak rewrite otp-∙-check pb₀ s₀ pb₁ s₁ check-pf | sum-ext μRₚ helper = refl

    module HonestLeakZeroKnowledge' (pb       : Problem)
                                    (s₀ s₁    : Solution)
                                    (check-pf : check pb s₀ ≡ check pb s₁) where

        honest-leak : honest-⅁ pb s₀ ≡# honest-⅁ pb s₁
        honest-leak = HonestLeakZeroKnowledge.honest-leak pb pb s₀ s₁ check-pf

    -- Predicts b=b′
    cheater : ∀ b′ → DepProver
    cheater b′ pb (rand (π , _)) b = π ∙P (case b′ 0→ pb 1→ easy-pb π)
                                   , answer π (π ∙S easy-sol π) b

    -- If cheater predicts correctly, verifer accepts him
    cheater-accepted : ∀ b pb rₚ → (pb ⇄′ cheater b) b rₚ ≡ 1b
    cheater-accepted true  pb (rand (π , rₚ)) = check-easy π
    cheater-accepted false pb (rand (π , rₚ)) = ==-refl

    -- If cheater predicts incorrecty, verifier rejects him
    module CheaterRejected (pb : Problem)
                           (not-easy-sol : ∀ π → check (π ∙P pb) (π ∙S easy-sol π) ≡ false)
                           (not-easy-pb  : ∀ π → ((π ∙P pb) == (π ∙P easy-pb π)) ≡ false) where

        cheater-rejected : ∀ b rₚ → (pb ⇄′ cheater (not b)) b rₚ ≡ 0b
        cheater-rejected true  (rand (π , rₚ)) = not-easy-sol π
        cheater-rejected false (rand (π , rₚ)) = not-easy-pb π

module DLog (ℤq  : ★)
            (_⊞_ : ℤq → ℤq → ℤq)
            (⊟_  : ℤq → ℤq)
            (G   : ★)
            (g   : G)
            (_^_ : G → ℤq → G)
            (_∙_ : G → G → G)
            (⊟-⊞ : ∀ π x → (⊟ π) ⊞ (π ⊞ x) ≡ x)
            (^⊟-∙ : ∀ α β x → ((α ^ (⊟ x)) ∙ ((α ^ x) ∙ β)) ≡ β)
            -- (∙-assoc : ∀ α β γ → α ∙ (β ∙ γ) ≡ (α ∙ β) ∙ γ)
            (dist-^-⊞ : ∀ α x y → α ^ (x ⊞ y) ≡ (α ^ x) ∙ (α ^ y))
            (_==_ : G → G → Bool)
            (==-refl  : ∀ {α} → (α == α) ≡ true)
            (==-true  : ∀ {α β} → α == β ≡ true → α ≡ β)
            (==-false : ∀ {α β} → α == β ≡ false → α ≢ β)
            (sumℤq      : Sum ℤq)
            (μℤq        : SumProp sumℤq)
            (Rₚ-xtra    : ★) -- extra prover/adversary randomness
            (sumRₚ-xtra : Sum Rₚ-xtra)
            (μRₚ-xtra   : SumProp sumRₚ-xtra)
            (some-ℤq    : ℤq)
   where

   Permutation = ℤq
   Problem = G
   Solution = ℤq

   _⁻¹ : Endo Permutation
   π ⁻¹ = ⊟ π

   g^_ : ℤq → G
   g^ x = g ^ x

   _∙P_ : Permutation → Endo Problem
   π ∙P p = g^ π ∙ p

   ⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x
   ⁻¹-inverseP π x rewrite ^⊟-∙ g x π = refl

   _∙S_ : Permutation → Endo Solution
   π ∙S s = π ⊞ s

   ⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x
   ⁻¹-inverseS = ⊟-⊞

   check : Problem → Solution → Bit
   check p s = p == g^ s

   check-∙' : ∀ p s π b → check p s ≡ b → check (π ∙P p) (π ∙S s) ≡ b
   check-∙' p s π true  check-p-s rewrite dist-^-⊞ g π s | ==-true check-p-s = ==-refl
   check-∙' p s π false check-p-s rewrite dist-^-⊞ g π s
      with ==-false check-p-s ?
   ... | ()

   check-∙ : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s
   check-∙ p s π = check-∙' p s π (check p s) refl

   easy-sol : Permutation → Solution
   easy-sol π = some-ℤq

   easy-pb : Permutation → Problem
   easy-pb π = g^(easy-sol π)

   check-easy : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true
   check-easy π rewrite dist-^-⊞ g π (easy-sol π) = ==-refl

   open M Permutation _⁻¹ sumℤq μℤq Rₚ-xtra sumRₚ-xtra μRₚ-xtra
          Problem _==_ ==-refl _∙P_ ⁻¹-inverseP Solution _∙S_ ⁻¹-inverseS check check-∙ easy-pb easy-sol check-easy
-- -}
-- -}
-- -}
-- -}
-- -}


Simplify Atlas-diff and Atlas-apply.

Simplify Atlas-diff and Atlas-apply.

Old-commit-hash: ada22ebb7416f8c4fb19882d4080166628b1b292

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (ΔBase ι))
nil-term {Bool}   = curriedConst (nil-const {Bool})
nil-term {Map κ ι} = curriedConst (nil-const {Map κ ι})

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
Atlas-diff {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-diff {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-diff) m₁ m₂)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-apply {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-apply) m₁ m₂)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (ΔType τ)
diff = app₂ (lift-diff Atlas-diff Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (ΔType τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply Atlas-diff Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (ΔBase ι))
nil-term {Bool}   = curriedConst (nil-const {Bool})
nil-term {Map κ ι} = curriedConst (nil-const {Map κ ι})

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
Atlas-diff {Bool} = abs (abs (curriedConst xor (var (that this)) (var this)))
Atlas-diff {Map κ ι} = abs (abs (curriedConst zip (abs Atlas-diff) (var (that this)) (var this)))

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs (abs (curriedConst xor (var (that this)) (var this)))
Atlas-apply {Map κ ι} = abs (abs (curriedConst zip (abs Atlas-apply) (var (that this)) (var this)))

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (ΔType τ)
diff = app₂ (lift-diff Atlas-diff Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (ΔType τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply Atlas-diff Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc