module flipbased-implem where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Vec
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
import Data.Fin as Fin
open ≡ using (_≗_; _≡_)
open Fin using (Fin; suc)

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
record ↺ {a} n (A : Set a) : Set a where
  constructor mk
  field
    run↺ : Bits n → A

open ↺ public

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

runDet : ∀ {a} {A : Set a} → Det A → A
runDet f = run↺ f []

toss : ↺ 1 Bit
toss = mk head

return↺ : ∀ {n a} {A : Set a} → A → ↺ n A
return↺ = mk ∘ const

map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B
map↺ f x = mk (f ∘ run↺ x)
-- map↺ f x ≗ x >>=′ (return {0} ∘ f)

join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A
join↺ {n₁} x = mk (λ bs → run↺ (run↺ x (take _ bs)) (drop n₁ bs))
-- join↺ x = x >>= id

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → ↺ m A → ↺ n A
comap f (mk g) = mk (g ∘ f)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → ↺ m A → ↺ n A
weaken≤ p = comap (take≤ p)

open flipbased ↺ toss weaken≤ return↺ map↺ join↺ public

_≗↺_ : ∀ {c a} {A : Set a} (f g : ↺ c A) → Set a
f ≗↺ g = run↺ f ≗ run↺ g

⅁ : ℕ → Set
⅁ n = ↺ n Bit

_≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ⅁ c) → Set
⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
≗⅁-trans p q b R = ≡.trans (p b R) (q b R)

count↺ᶠ : ∀ {c} → ⅁ c → Fin (suc (2^ c))
count↺ᶠ f = #⟨ run↺ f ⟩ᶠ

count↺ : ∀ {c} → ⅁ c → ℕ
count↺ = Fin.toℕ ∘ count↺ᶠ

_∼[_]⅁_ : ∀ {m n} → ⅁ m → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁_ {m} {n} f _∼_ g = ⟨2^ n * count↺ f ⟩ ∼ ⟨2^ m * count↺ g ⟩

_∼[_]⅁′_ : ∀ {n} → ⅁ n → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁′_ {n} f _∼_ g = count↺ f ∼ count↺ g

_≈⅁_ : ∀ {m n} → ⅁ m → ⅁ n → Set
f ≈⅁ g = f ∼[ _≡_ ]⅁ g

_≈⅁′_ : ∀ {n} (f g : ⅁ n) → Set
f ≈⅁′ g = f ∼[ _≡_ ]⅁′ g

≈⅁-refl : ∀ {n} {f : ⅁ n} → f ≈⅁ f
≈⅁-refl = ≡.refl

≈⅁-sym : ∀ {n} → Symmetric {A = ⅁ n} _≈⅁_
≈⅁-sym = ≡.sym

≈⅁-trans : ∀ {n} → Transitive {A = ⅁ n} _≈⅁_
≈⅁-trans = ≡.trans

≗⇒≈⅁ : ∀ {c} {f g : ⅁ c} → f ≗↺ g → f ≈⅁ g
≗⇒≈⅁ pf rewrite ext-# pf = ≡.refl

≈⅁′⇒≈⅁ : ∀ {n} {f g : ⅁ n} → f ≈⅁′ g → f ≈⅁ g
≈⅁′⇒≈⅁ eq rewrite eq = ≡.refl

≈⅁⇒≈⅁′ : ∀ {n} {f g : ⅁ n} → f ≈⅁ g → f ≈⅁′ g
≈⅁⇒≈⅁′ {n} = 2^-inj n

≈⅁-cong : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ≈⅁ f' → g ≈⅁ g'
≈⅁-cong f≗g f'≗g' f≈f' rewrite ext-# f≗g | ext-# f'≗g' = f≈f'

≈⅁′-cong : ∀ {c} {f g f' g' : ⅁ c} → f ≗↺ g → f' ≗↺ g' → f ≈⅁′ f' → g ≈⅁′ g'
≈⅁′-cong f≗g f'≗g' f≈f' rewrite ext-# f≗g | ext-# f'≗g' = f≈f'

module flipbased-implem where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Vec
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
import Data.Fin as Fin
open ≡ using (_≗_; _≡_)
open Fin using (Fin; suc)

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
record ↺ {a} n (A : Set a) : Set a where
  constructor mk
  field
    run↺ : Bits n → A

open ↺ public

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

runDet : ∀ {a} {A : Set a} → Det A → A
runDet f = run↺ f []

toss : ↺ 1 Bit
toss = mk head

return↺ : ∀ {n a} {A : Set a} → A → ↺ n A
return↺ = mk ∘ const

map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B
map↺ f x = mk (f ∘ run↺ x)
-- map↺ f x ≗ x >>=′ (return {0} ∘ f)

join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A
join↺ {n₁} x = mk (λ bs → run↺ (run↺ x (take _ bs)) (drop n₁ bs))
-- join↺ x = x >>= id

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → ↺ m A → ↺ n A
comap f (mk g) = mk (g ∘ f)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → ↺ m A → ↺ n A
weaken≤ p = comap (take≤ p)

open flipbased ↺ toss weaken≤ return↺ map↺ join↺ public

_≗↺_ : ∀ {c a} {A : Set a} (f g : ↺ c A) → Set a
f ≗↺ g = run↺ f ≗ run↺ g

⅁ : ℕ → Set
⅁ n = ↺ n Bit

_≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ⅁ c) → Set
⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
≗⅁-trans p q b R = ≡.trans (p b R) (q b R)

count↺ᶠ : ∀ {c} → ⅁ c → Fin (suc (2^ c))
count↺ᶠ f = #⟨ run↺ f ⟩ᶠ

count↺ : ∀ {c} → ⅁ c → ℕ
count↺ f = #⟨ run↺ f ⟩

≗↺-cong-# : ∀ {n} {f g : ⅁ n} → f ≗↺ g → count↺ f ≡ count↺ g
≗↺-cong-# {f = f} {g} = ≗-cong-# (run↺ f) (run↺ g)

_∼[_]⅁_ : ∀ {m n} → ⅁ m → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁_ {m} {n} f _∼_ g = ⟨2^ n * count↺ f ⟩ ∼ ⟨2^ m * count↺ g ⟩

_∼[_]⅁′_ : ∀ {n} → ⅁ n → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁′_ {n} f _∼_ g = count↺ f ∼ count↺ g

_≈⅁_ : ∀ {m n} → ⅁ m → ⅁ n → Set
f ≈⅁ g = f ∼[ _≡_ ]⅁ g

_≈⅁′_ : ∀ {n} (f g : ⅁ n) → Set
f ≈⅁′ g = f ∼[ _≡_ ]⅁′ g

≈⅁-refl : ∀ {n} {f : ⅁ n} → f ≈⅁ f
≈⅁-refl = ≡.refl

≈⅁-sym : ∀ {n} → Symmetric {A = ⅁ n} _≈⅁_
≈⅁-sym = ≡.sym

≈⅁-trans : ∀ {n} → Transitive {A = ⅁ n} _≈⅁_
≈⅁-trans = ≡.trans

≗⇒≈⅁ : ∀ {c} {f g : ⅁ c} → f ≗↺ g → f ≈⅁ g
≗⇒≈⅁ pf rewrite ≗↺-cong-# pf = ≡.refl

≈⅁′⇒≈⅁ : ∀ {n} {f g : ⅁ n} → f ≈⅁′ g → f ≈⅁ g
≈⅁′⇒≈⅁ eq rewrite eq = ≡.refl

≈⅁⇒≈⅁′ : ∀ {n} {f g : ⅁ n} → f ≈⅁ g → f ≈⅁′ g
≈⅁⇒≈⅁′ {n} = 2^-inj n

≈⅁-cong : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ≈⅁ f' → g ≈⅁ g'
≈⅁-cong f≗g f'≗g' f≈f' rewrite ≗↺-cong-# f≗g | ≗↺-cong-# f'≗g' = f≈f'

≈⅁′-cong : ∀ {c} {f g f' g' : ⅁ c} → f ≗↺ g → f' ≗↺ g' → f ≈⅁′ f' → g ≈⅁′ g'
≈⅁′-cong f≗g f'≗g' f≈f' rewrite ≗↺-cong-# f≗g | ≗↺-cong-# f'≗g' = f≈f'

data Rat : Set where _/_ : (num denom : ℕ) → Rat

Pr[_≡1] : ∀ {n} (f : ⅁ n) → Rat
Pr[_≡1] {n} f = count↺ f / 2^ n

Switch count↺ to be based on search

Switch count↺ to be based on search


{-# OPTIONS --without-K #-}
module ZK.PartialHeliosVerifier where

open import Type
open import Function hiding (case_of_)
open import Data.Bool.Base
open import Data.Product
open import Data.List.Base using (List; []; _∷_; and; foldr)
open import Data.String.Base  using (String)

open import FFI.JS as JS hiding (_+_; _/_; _*_; join)
open import FFI.JS.BigI as BigI
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS
open import FFI.JS.SHA1
open import FFI.JS.Proc
open import Control.Process.Type

join : String → List String → String
join sep []       = ""
join sep (x ∷ xs) = x ++ foldr (λ y z → sep ++ y ++ z) "" xs

{-
instance
  showBigI = mk λ _ → showString ∘ BigI.toString
-}

G  = BigI
ℤq = BigI

BigI▹G : BigI → G
BigI▹G = id

BigI▹ℤq : BigI → ℤq
BigI▹ℤq = id

non0I : BigI → BigI
non0I x with equals x 0I
... | true  = throw "Should be non zero!" 0I
... | false = x

module BigICG (p q : BigI) where
  _^_  : G  → ℤq → G
  _·_  : G  → G  → G
  _/_  : G  → G  → G
  _+_  : ℤq → ℤq → ℤq
  _*_  : ℤq → ℤq → ℤq
  _==_ : (x y : G) → Bool

  _^_ = λ x y → modPow x y p
  _·_ = λ x y → mod (multiply x y) p
  _/_ = λ x y → mod (multiply x (modInv (non0I y) p)) p
  _+_ = λ x y → mod (add x y) q
  _*_ = λ x y → mod (multiply x y) q
  _==_ = equals

  sumI : List BigI → BigI
  sumI = foldr _+_ 0I

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

{-
print : {A : Set}{{_ : Show A}} → A → Callback0
print = Console.log ∘ show
-}

PubKey         = G
EncRnd         = ℤq {- randomness used for encryption of ct -}
Message        = G {- plain text message -}
Challenge      = ℤq
Response       = ℤq
CommitmentPart = G
CipherTextPart = G

module HeliosVerifyV3 (g : G) p q (y : PubKey) where
  open BigICG p q

  verify-chaum-pedersen : (α β : CipherTextPart)(M : Message)(A B : G)(c : Challenge)(s : Response) → Bool
  verify-chaum-pedersen α β M A B c s
      = trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
        (g ^ s) == (A · (α ^ c))
      ∧ (y ^ s) == (B · ((β / M) ^ c))

  verify-individual-proof : (α β : CipherTextPart)(ix : Number)(π : JSValue) → Bool
  verify-individual-proof α β ix π
      = trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "commitmentA=" A λ _ →
        trace "commitmentB=" B λ _ →
        trace "challenge=" c λ _ →
        trace "response=" s λ _ →
        res
      where
        m  = bignum ix
        M  = g ^ m
        A  = bigdec (π ·« "commitment" » ·« "A" »)
        B  = bigdec (π ·« "commitment" » ·« "B" »)
        c  = bigdec (π ·« "challenge" »)
        s  = bigdec (π ·« "response" »)
        res = verify-chaum-pedersen α β M A B c s

  -- Conform to HeliosV3 but it is too weak.
  -- One should follow a "Strong Fiat Shamir" transformation
  -- from interactive ZK proof to non-interactive ZK proofs.
  -- Namely one should hash the statement as well.
  --
  -- SHA1(A0 + "," + B0 + "," + A1 + "," + B1 + ... + "Amax" + "," + Bmax)
  hash-commitments : JSArray JSValue → BigI
  hash-commitments πs =
    fromHex $
    trace-call "SHA1(commitments)=" SHA1       $
    trace-call "commitments="       (join ",") $
    decodeJSArray πs λ _ π →
      (castString (π ·« "commitment" » ·« "A" »))
      ++ "," ++
      (castString (π ·« "commitment" » ·« "B" »))

  sum-challenges : JSArray JSValue → BigI
  sum-challenges πs =
    sumI $ decodeJSArray πs λ _ π → bigdec (π ·« "challenge" »)

  verify-challenges : JSArray JSValue → Bool
  verify-challenges πs =
      trace "hash(commitments)=" h λ _ →
      trace "sum(challenge)="    c λ _ →
      h == c
    where
      h = hash-commitments πs
      c = sum-challenges   πs

  verify-choice : (v : JSValue)(πs : JSArray JSValue) → Bool
  verify-choice v πs =
      trace "α=" α λ _ →
      trace "β=" β λ _ →
      verify-challenges πs
      ∧
      and (decodeJSArray πs $ verify-individual-proof α β)
    where
      α = bigdec (v ·« "alpha" »)
      β = bigdec (v ·« "beta"  »)

  verify-choices : (choices πs : JSArray JSValue) → Bool
  verify-choices choices πs =
    trace "TODO: check the array size of choices πs together election data" "" λ _ →
    and $ decodeJSArray choices λ ix choice →
      trace "verify choice " ix λ _ →
      verify-choice choice (castJSArray (πs Array[ ix ]))

  verify-answer : (answer : JSValue) → Bool
  verify-answer answer =
      trace "TODO: CHECK the overall_proof" "" λ _ →
      verify-choices choices individual-proofs
    where
      choices           = answer ·« "choices" »A
      individual-proofs = answer ·« "individual_proofs" »A
      overall-proof     = answer ·« "overall_proof" »A

  verify-answers : (answers : JSArray JSValue) → Bool
  verify-answers answers =
    and $ decodeJSArray answers λ ix a →
      trace "verify answer " ix λ _ →
      verify-answer a

  {-
  verify-election-hash =
  ""
  -- notice the whitespaces and the alphabetical order of keys
  -- {"email": ["ben@adida.net", "ben@mit.edu"], "first_name": "Ben", "last_name": "Adida"}
    computed_hash = base64.b64encode(hash.new(election.toJSON()).digest())[:-1]
    computed_hash == vote.election_hash:
  ""
  -}

  -- module _ {-(election : JSValue)-} where
  verify-ballot : (ballot : JSValue) → Bool
  verify-ballot ballot =
        trace "TODO: CHECK the election_hash: " election_hash λ _ →
        trace "TODO: CHECK the election_uuid: " election_uuid λ _ →
        verify-answers answers
      where
        answers       = ballot ·« "answers" »A
        election_hash = ballot ·« "election_hash" »
        election_uuid = ballot ·« "election_uuid" »

  verify-ballots : (ballots : JSArray JSValue) → Bool
  verify-ballots ballots =
      and $ decodeJSArray ballots λ ix ballot →
        trace "verify ballot " ix λ _ →
        verify-ballot ballot

-- Many checks are still missing!
verify-helios-election : (arg : JSValue) → Bool
verify-helios-election arg = trace "res=" res id
 where
    ed = arg ·« "election_data" »
    bs = arg ·« "ballots" »A
    pk = ed  ·« "public_key" »
    g  = bigdec (pk ·« "g" »)
    p  = bigdec (pk ·« "p" »)
    q  = bigdec (pk ·« "q" »)
    y  = bigdec (pk ·« "y" »)
    res =
        trace "g=" g λ _ →
        trace "p=" p λ _ →
        trace "q=" q λ _ →
        trace "y=" y λ _ →
        HeliosVerifyV3.verify-ballots g p q y bs

srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (verify-helios-election q))
  end

-- Working around Agda.Primitive.lsuc being undefined
case_of_ : {A : Set} {B : Set} → A → (A → B) → B
case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
          server "127.0.0.1" "1337" srv !₁ λ uri →
          Console.log (showURI uri)
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              let opts =
                 -- fromJSObject (fromObject (("encoding" , fromString "utf8") ∷ []))
                 -- nullJS
                    JSON-parse "{\"encoding\":\"utf8\"}"
              in
              Console.log ("readFile=" ++ arg) >>
              FS.readFile arg opts !₂ λ err dat →
                Console.log ("readFile: err=" ++ JS.toString err) >>
                Console.log (Bool▹String (verify-helios-election (JSON-parse (castString dat))))
          ; _ →
              Console.log "usage"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module ZK.PartialHeliosVerifier where

open import Type
open import Function hiding (case_of_)
open import Data.Bool.Base
open import Data.Product
open import Data.List.Base using (List; []; _∷_; and; foldr)
open import Data.String.Base  using (String)

open import FFI.JS as JS hiding (_+_; _/_; _*_; join)
open import FFI.JS.BigI as BigI
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS
open import FFI.JS.SHA1
open import FFI.JS.Proc
open import Control.Process.Type

join : String → List String → String
join sep []       = ""
join sep (x ∷ xs) = x ++ foldr (λ y z → sep ++ y ++ z) "" xs

{-
instance
  showBigI = mk λ _ → showString ∘ BigI.toString
-}

G  = BigI
ℤq = BigI

BigI▹G : BigI → G
BigI▹G = id

BigI▹ℤq : BigI → ℤq
BigI▹ℤq = id

non0I : BigI → BigI
non0I x with equals x 0I
... | true  = throw "Should be non zero!" 0I
... | false = x

module BigICG (p q : BigI) where
  _^_  : G  → ℤq → G
  _·_  : G  → G  → G
  _/_  : G  → G  → G
  _+_  : ℤq → ℤq → ℤq
  _*_  : ℤq → ℤq → ℤq
  _==_ : (x y : G) → Bool

  _^_ = λ x y → modPow x y p
  _·_ = λ x y → mod (multiply x y) p
  _/_ = λ x y → mod (multiply x (modInv (non0I y) p)) p
  _+_ = λ x y → mod (add x y) q
  _*_ = λ x y → mod (multiply x y) q
  _==_ = equals

  sumI : List BigI → BigI
  sumI = foldr _+_ 0I

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

{-
print : {A : Set}{{_ : Show A}} → A → Callback0
print = Console.log ∘ show
-}

PubKey         = G
EncRnd         = ℤq {- randomness used for encryption of ct -}
Message        = G {- plain text message -}
Challenge      = ℤq
Response       = ℤq
CommitmentPart = G
CipherTextPart = G

module HeliosVerifyV3 (g : G) p q (y : PubKey) where
  open BigICG p q

  verify-chaum-pedersen : (α β : CipherTextPart)(M : Message)(A B : G)(c : Challenge)(s : Response) → Bool
  verify-chaum-pedersen α β M A B c s
      = trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
        (g ^ s) == (A · (α ^ c))
      ∧ (y ^ s) == (B · ((β / M) ^ c))

  verify-individual-proof : (α β : CipherTextPart)(ix : Number)(π : JSValue) → Bool
  verify-individual-proof α β ix π
      = trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "commitmentA=" A λ _ →
        trace "commitmentB=" B λ _ →
        trace "challenge=" c λ _ →
        trace "response=" s λ _ →
        res
      where
        m  = bignum ix
        M  = g ^ m
        A  = bigdec (π ·« "commitment" » ·« "A" »)
        B  = bigdec (π ·« "commitment" » ·« "B" »)
        c  = bigdec (π ·« "challenge" »)
        s  = bigdec (π ·« "response" »)
        res = verify-chaum-pedersen α β M A B c s

  -- Conform to HeliosV3 but it is too weak.
  -- One should follow a "Strong Fiat Shamir" transformation
  -- from interactive ZK proof to non-interactive ZK proofs.
  -- Namely one should hash the statement as well.
  --
  -- SHA1(A0 + "," + B0 + "," + A1 + "," + B1 + ... + "Amax" + "," + Bmax)
  hash-commitments : JSArray JSValue → BigI
  hash-commitments πs =
    fromHex $
    trace-call "SHA1(commitments)=" SHA1       $
    trace-call "commitments="       (join ",") $
    decodeJSArray πs λ _ π →
      (castString (π ·« "commitment" » ·« "A" »))
      ++ "," ++
      (castString (π ·« "commitment" » ·« "B" »))

  sum-challenges : JSArray JSValue → BigI
  sum-challenges πs =
    sumI $ decodeJSArray πs λ _ π → bigdec (π ·« "challenge" »)

  verify-challenges : JSArray JSValue → Bool
  verify-challenges πs =
      trace "hash(commitments)=" h λ _ →
      trace "sum(challenge)="    c λ _ →
      h == c
    where
      h = hash-commitments πs
      c = sum-challenges   πs

  verify-choice : (v : JSValue)(πs : JSArray JSValue) → Bool
  verify-choice v πs =
      trace "α=" α λ _ →
      trace "β=" β λ _ →
      verify-challenges πs
      ∧
      and (decodeJSArray πs $ verify-individual-proof α β)
    where
      α = bigdec (v ·« "alpha" »)
      β = bigdec (v ·« "beta"  »)

  verify-choices : (choices πs : JSArray JSValue) → Bool
  verify-choices choices πs =
    trace "TODO: check the array size of choices πs together election data" "" λ _ →
    and $ decodeJSArray choices λ ix choice →
      trace "verify choice " ix λ _ →
      verify-choice choice (castJSArray (πs Array[ ix ]))

  verify-answer : (answer : JSValue) → Bool
  verify-answer answer =
      trace "TODO: CHECK the overall_proof" "" λ _ →
      verify-choices choices individual-proofs
    where
      choices           = answer ·« "choices" »A
      individual-proofs = answer ·« "individual_proofs" »A
      overall-proof     = answer ·« "overall_proof" »A

  verify-answers : (answers : JSArray JSValue) → Bool
  verify-answers answers =
    and $ decodeJSArray answers λ ix a →
      trace "verify answer " ix λ _ →
      verify-answer a

  {-
  verify-election-hash =
  ""
  -- notice the whitespaces and the alphabetical order of keys
  -- {"email": ["ben@adida.net", "ben@mit.edu"], "first_name": "Ben", "last_name": "Adida"}
    computed_hash = base64.b64encode(hash.new(election.toJSON()).digest())[:-1]
    computed_hash == vote.election_hash:
  ""
  -}

  -- module _ {-(election : JSValue)-} where
  verify-ballot : (ballot : JSValue) → Bool
  verify-ballot ballot =
        trace "TODO: CHECK the election_hash: " election_hash λ _ →
        trace "TODO: CHECK the election_uuid: " election_uuid λ _ →
        verify-answers answers
      where
        answers       = ballot ·« "answers" »A
        election_hash = ballot ·« "election_hash" »
        election_uuid = ballot ·« "election_uuid" »

  verify-ballots : (ballots : JSArray JSValue) → Bool
  verify-ballots ballots =
      and $ decodeJSArray ballots λ ix ballot →
        trace "verify ballot " ix λ _ →
        verify-ballot ballot

-- Many checks are still missing!
verify-helios-election : (arg : JSValue) → Bool
verify-helios-election arg = trace "res=" res id
 where
    ed = arg ·« "election_data" »
    bs = arg ·« "ballots" »A
    pk = ed  ·« "public_key" »
    g  = bigdec (pk ·« "g" »)
    p  = bigdec (pk ·« "p" »)
    q  = bigdec (pk ·« "q" »)
    y  = bigdec (pk ·« "y" »)
    res =
        trace "g=" g λ _ →
        trace "p=" p λ _ →
        trace "q=" q λ _ →
        trace "y=" y λ _ →
        HeliosVerifyV3.verify-ballots g p q y bs

srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (verify-helios-election q))
  end

-- Working around Agda.Primitive.lsuc being undefined
case_of_ : {A : Set} {B : Set} → A → (A → B) → B
case x of f = f x

main : JS!
main =
  Process.argv >>= λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
          server "127.0.0.1" "1337" srv >>= λ uri →
          Console.log (showURI uri)
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              let opts =
                 -- fromJSObject (fromObject (("encoding" , fromString "utf8") ∷ []))
                 -- nullJS
                    JSON-parse "{\"encoding\":\"utf8\"}"
              in
              Console.log ("readFile=" ++ arg) >>
              FS.readFile arg opts >>== λ err dat →
                Console.log ("readFile: err=" ++ JS.toString err) >>
                Console.log (Bool▹String (verify-helios-election (JSON-parse (castString dat))))
          ; _ →
              Console.log "usage"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}
-- -}

Update binds

Update binds


import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Derive
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

Structure : Set
Structure = ∀ {Γ Σ τ} →
  Const Σ τ →
  Terms (ΔContext Γ) Σ →
  Terms (ΔContext Γ) (mapContext ΔType Σ) →
  Term (ΔContext Γ) (ΔType τ)

module Structure (deriveConst : Structure) where
  fit : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) τ
  fit = weaken Γ≼ΔΓ

  fit-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) Σ
  fit-terms = weaken-terms Γ≼ΔΓ

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

  derive-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) (mapContext ΔType Σ)
  derive : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) (ΔType τ)

  derive-terms {∅}    ∅ = ∅
  derive-terms {τ • Σ} (t • ts) = derive t • derive-terms ts

  derive (var x) = var (deriveVar x)
  derive (app s t) = app (app (derive s) (fit t)) (derive t)
  derive (abs t) = abs (abs (derive t))
  derive (const c ts) = deriveConst c (fit-terms ts) (derive-terms ts)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Incrementalization as term-to-term transformation (Fig. 4g).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Derive
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

-- Extension point: Incrementalization of fully applied primitives.
Structure : Set
Structure = ∀ {Γ Σ τ} →
  Const Σ τ →
  Terms (ΔContext Γ) Σ →
  Terms (ΔContext Γ) (mapContext ΔType Σ) →
  Term (ΔContext Γ) (ΔType τ)

module Structure (deriveConst : Structure) where
  fit : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) τ
  fit = weaken Γ≼ΔΓ

  fit-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) Σ
  fit-terms = weaken-terms Γ≼ΔΓ

  -- In the paper, we transform "x" to "dx". Here, we work with
  -- de Bruijn indices, so we have to manipulate the indices to
  -- account for a bigger context after transformation.
  deriveVar : ∀ {τ Γ} → Var Γ τ → Var (ΔContext Γ) (ΔType τ)
  deriveVar this = this
  deriveVar (that x) = that (that (deriveVar x))

  derive-terms : ∀ {Σ Γ} → Terms Γ Σ → Terms (ΔContext Γ) (mapContext ΔType Σ)
  derive : ∀ {τ Γ} → Term Γ τ → Term (ΔContext Γ) (ΔType τ)

  derive-terms {∅}    ∅ = ∅
  derive-terms {τ • Σ} (t • ts) = derive t • derive-terms ts

  -- We provide: Incrementalization of arbitrary terms.
  derive (var x) = var (deriveVar x)
  derive (app s t) = app (app (derive s) (fit t)) (derive t)
  derive (abs t) = abs (abs (derive t))
  derive (const c ts) = deriveConst c (fit-terms ts) (derive-terms ts)

Document P.C.Derive.

Document P.C.Derive.

Old-commit-hash: 962425cf9bb190e1b8fb2c400bd9765180081dd0


module Popl14.Change.Term where

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

open import Data.Integer

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

import Parametric.Change.Term Const ΔBase as ChangeTerm

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

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

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

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

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

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

module Popl14.Change.Term where

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

open import Data.Integer

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

import Parametric.Change.Term Const ΔBase as ChangeTerm

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

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

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

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

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

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

Move (apply|diff)-base to the top of the module.

This commit separates the POPL14-specific code from the
language-independent code in this module. The following commits will
remove the language-independent code.

Old-commit-hash: 245a7b618b2ac811d28d702089482e9aed8b8425


{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (JS[_]; return; Bool; _++_; _>>_)
open import FFI.JS.Check using (check!)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → JS[ ℤp★ ]
  BigI▹ℤ[_]★ x =
    -- Console.log "BigI▹ℤ[_]★" >>
    check! "below modulus" (x <I p)
           (λ _ → "Not below the modulus: p:" ++
                  toString p ++
                  " is less than x:" ++
                  toString x) >>
    check! "strictcly positive" (x >I 0I)
           (λ _ → "Should be strictly positive: " ++
                  toString x ++
                  " <= 0") >>
    return x

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv x p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (JS[_]; return; _++_; _>>_)
open import FFI.JS.Check using (check!)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → JS[ ℤp★ ]
  BigI▹ℤ[_]★ x =
    -- Console.log "BigI▹ℤ[_]★" >>
    check! "below modulus" (x <I p)
           (λ _ → "Not below the modulus: p:" ++
                  toString p ++
                  " is less than x:" ++
                  toString x) >>
    check! "strictcly positive" (x >I 0I)
           (λ _ → "Should be strictly positive: " ++
                  toString x ++
                  " <= 0") >>
    return x

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv x p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

remove useless import

CyclicGroup: remove useless import


module Postulate.Extensionality where

-- POSTULATE EXTENSIONALITY
--
-- Justification on Agda mailing list:
-- http://permalink.gmane.org/gmane.comp.lang.agda/2343

open import Relation.Binary.PropositionalEquality

postulate ext : ∀ {a b} → Extensionality a b

-- Convenience of using extensionality 3 times in a row
-- (using it twice in a row is moderately tolerable)
ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Postulate extensionality of functions.
--
-- Justification on Agda mailing list:
-- http://permalink.gmane.org/gmane.comp.lang.agda/2343
------------------------------------------------------------------------

module Postulate.Extensionality where

open import Relation.Binary.PropositionalEquality

postulate ext : ∀ {a b} → Extensionality a b

-- Convenience of using extensionality 3 times in a row
-- (using it twice in a row is moderately tolerable)
ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))

Document Postulate.Extensionality regularly.

Old-commit-hash: 35222e92088dbd2313ec7252e50cd68e85b340bf


module flat-funs where

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

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T
    _`→_  : T → T → Set

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

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

  infixr 2 _`×_
  infixl 2 _`^_
  infix 0 _`→_

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

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

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

  open Composable isComposable
  open VComposable isVComposable

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

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

  open Composable isComposable public
  open VComposable isVComposable public

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

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

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

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

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id bitsFunComp bitsFunVComp _&&&_ (λ {A} → take A) (λ {A} → drop A)
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-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 = ?
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T

module flat-funs where

open import Data.Nat
open import Data.Bits using (Bits)
import Level as L
import Function as F
open import composable
open import vcomp
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
  field
    idO : ∀ {A} → A `→ A

    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)

    _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)

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

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

    constBits : ∀ {n} → Bits n → `⊤ `→ `Bits n

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

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

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
open import Data.Product renaming (zip to ×-zip; map to ×-map)
open import Function

-→- : 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 -→-

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

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

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

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id (λ f g → g ∘ f) (VComposable._***_ bitsFunVComp) _&&&_ (λ {A} → take A)
                    (λ {A} → drop A) (λ xs _ → xs ++ [] {- ugly? -})
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)

×-♭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.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                        (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                        (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭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.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                         (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                         (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

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

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ _⊔_ _⊔_ 0 0 (const 0)

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ _+_ _+_ 0 0 (λ {n} _ → n)

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

flat-funs: put the type interface in the universe module


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely.
    --
    -- * That should be be true for
    --   functions using changes parametrically.
    --
    -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
    --   this is proved below on both contexts at once by fun-change-respects.
    --
    -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
    --   it by definition, and ⊟ doesn't take change arguments - we will only
    --   need a proof for compose, when we define it.
    --
    -- Stating the general result, though, seems hard, we should
    -- rather have lemmas proving that certain classes of functions respect this
    -- equivalence.

  module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
    {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

    module FC = FunctionChanges A B {{CA}} {{CB}}
    open FC using (changeAlgebra; incrementalization)
    open FC.FunctionChange

    fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
      df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
    fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
      where
        open ≡-Reasoning
        open import Postulate.Extensionality
        -- This type signature just expands the goal manually a bit.
        lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
        -- Informally: use incrementalization on both sides and then apply
        -- congruence.
        lemma =
          begin
            f x ⊞ apply df₁ x dx₁
          ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
            (f ⊞ df₁) (x ⊞ dx₁)
          ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
            (f ⊞ df₁) (x ⊞ dx₂)
          ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
            (f ⊞ df₂) (x ⊞ dx₂)
          ≡⟨ incrementalization f df₂ x dx₂ ⟩
            f x ⊞ apply df₂ x dx₂
          ∎

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

module Structure where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely.
    --
    -- * That should be be true for
    --   functions using changes parametrically.
    --
    -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
    --   this is proved below on both contexts at once by fun-change-respects.
    --
    -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
    --   it by definition, and ⊟ doesn't take change arguments - we will only
    --   need a proof for compose, when we define it.
    --
    -- Stating the general result, though, seems hard, we should
    -- rather have lemmas proving that certain classes of functions respect this
    -- equivalence.

  module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
    {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

    module FC = FunctionChanges A B {{CA}} {{CB}}
    open FC using (changeAlgebra; incrementalization)
    open FC.FunctionChange

    fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
      df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
    fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
      where
        open ≡-Reasoning
        -- This type signature just expands the goal manually a bit.
        lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
        -- Informally: use incrementalization on both sides and then apply
        -- congruence.
        lemma =
          begin
            f x ⊞ apply df₁ x dx₁
          ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
            (f ⊞ df₁) (x ⊞ dx₁)
          ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
            (f ⊞ df₁) (x ⊞ dx₂)
          ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
            (f ⊞ df₂) (x ⊞ dx₂)
          ≡⟨ incrementalization f df₂ x dx₂ ⟩
            f x ⊞ apply df₂ x dx₂
          ∎

Remove more

Remove more

No Structure in Base.

Old-commit-hash: 81cee315c1ade9b842f0400fbc2bd215a189e8dc


import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

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

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    let
      -- for diff
      g  = var (that (that (that this)))
      f  = var (that (that this))
      x  = var (that this)
      Δx = var this
      -- for apply
      Δh = var (that (that this))
      h  = var (that this)
      y  = var this
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
      _⊝σ_ = λ {Γ} s t  → app₂ (diffσ {Γ}) s t
      _⊝τ_ = λ {Γ} s t  → app₂ (diffτ {Γ}) s t
      _⊕σ_ = λ {Γ} t Δt → app₂ (applyσ {Γ}) Δt t
      _⊕τ_ = λ {Γ} t Δt → app₂ (applyτ {Γ}) Δt t
    in
      abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
      ,
      abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

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

  lift-diff = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

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

  lift-apply = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

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

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    let
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
      _⊝σ_ = λ {Γ} s t  → app₂ (diffσ {Γ}) s t
      _⊝τ_ = λ {Γ} s t  → app₂ (diffτ {Γ}) s t
      _⊕σ_ = λ {Γ} t Δt → app₂ (applyσ {Γ}) Δt t
      _⊕τ_ = λ {Γ} t Δt → app₂ (applyτ {Γ}) Δt t
    in
      abs₄ (λ g f x Δx → app f (x ⊕σ Δx) ⊝τ app g x)
      ,
      abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y))

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

  lift-diff = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

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

  lift-apply = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})

Use HOAS-enabled helpers for nested abstractions.

Old-commit-hash: f5006b448dcc30a8ff103cf5de501e945e14faa1


{-# OPTIONS --without-K #-}

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.Unit

open import Data.Nat.NP
open import Rat

open import Explore.Type
open import Explore.Explorable
open import Explore.Product
open Operators
open import Relation.Binary.PropositionalEquality

module Game.IND-CCA2
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where
open import Game.CCA-Common Message CipherText

Adv : ★
Adv = Rₐ → PubKey → Strategy ((Message × Message) × (CipherText → Strategy Bit))

{-
Valid-Adv : Adv → Set
Valid-Adv adv = ∀ {rₐ rₓ pk c} → Valid (λ x → x ≢ c) {!!}
-}

R : ★
R = Rₐ × Rₖ × Rₑ

Game : ★
Game = Adv → R → Bit

⅁ : Bit → Game
⅁ b m (rₐ , rₖ , rₑ) with KeyGen rₖ
... | pk , sk = b′ where
  open Eval Dec sk

  ev = eval (m rₐ pk)
  mb = proj (proj₁ ev) b
  d = proj₂ ev

  c  = Enc pk mb rₑ
  b′ = eval (d c)

module Advantage
  (μₑ : Explore₀ Rₑ)
  (μₖ : Explore₀ Rₖ)
  (μₐ : Explore₀ Rₐ)
  where
  μR : Explore₀ R
  μR = μₐ ×ᵉ μₖ ×ᵉ μₑ

  module μR = FromExplore₀ μR

  run : Bit → Adv → ℕ
  run b adv = μR.count (⅁ b adv)

  Advantage : Adv → ℕ
  Advantage adv = dist (run 0b adv) (run 1b adv)

  Advantageℚ : Adv → ℚ
  Advantageℚ adv = Advantage adv / μR.Card

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

{-# OPTIONS --without-K #-}

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.Unit

open import Data.Nat.NP
--open import Rat

open import Explore.Type
open import Explore.Explorable
open import Explore.Product
open Operators
open import Relation.Binary.PropositionalEquality

module Game.IND-CCA2
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where
open import Game.CCA-Common Message CipherText

Adv : ★
Adv = Rₐ → PubKey → Strategy ((Message × Message) × (CipherText → Strategy Bit))

{-
Valid-Adv : Adv → Set
Valid-Adv adv = ∀ {rₐ rₓ pk c} → Valid (λ x → x ≢ c) {!!}
-}

R : ★
R = Rₐ × Rₖ × Rₑ

Game : ★
Game = Adv → R → Bit

⅁ : Bit → Game
⅁ b m (rₐ , rₖ , rₑ) with KeyGen rₖ
... | pk , sk = b′ where
  open Eval Dec sk

  ev = eval (m rₐ pk)
  mb = proj (proj₁ ev) b
  d = proj₂ ev

  c  = Enc pk mb rₑ
  b′ = eval (d c)

module Advantage
  (μₑ : Explore₀ Rₑ)
  (μₖ : Explore₀ Rₖ)
  (μₐ : Explore₀ Rₐ)
  where
  μR : Explore₀ R
  μR = μₐ ×ᵉ μₖ ×ᵉ μₑ

  module μR = FromExplore₀ μR

  run : Bit → Adv → ℕ
  run b adv = μR.count (⅁ b adv)

  Advantage : Adv → ℕ
  Advantage adv = dist (run 0b adv) (run 1b adv)

  --Advantageℚ : Adv → ℚ
  --Advantageℚ adv = Advantage adv / μR.Card

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

Hide the Rat code

IND-CCA2: Hide the Rat code


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Value domains for languages described in Plotkin style
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type

module Parametric.Denotation.Value
    (Base : Type.Structure)
  where

open import Base.Denotation.Notation

open Type.Structure Base

Structure : Set₁
Structure = Base → Set

module Structure (⟦_⟧Base : Structure) where
  ⟦_⟧Type : Type -> Set
  ⟦ base ι ⟧Type = ⟦ ι ⟧Base
  ⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type

  meaningOfType : Meaning Type
  meaningOfType = meaning ⟦_⟧Type

  open import Base.Denotation.Environment Type ⟦_⟧Type public

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for standard evaluation (Def. 3.1 and 3.2, Fig. 4c and 4f).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type

module Parametric.Denotation.Value
    (Base : Type.Structure)
  where

open import Base.Denotation.Notation

open Type.Structure Base

-- Extension point: Values for base types.
Structure : Set₁
Structure = Base → Set

module Structure (⟦_⟧Base : Structure) where
  -- We provide: Values for arbitrary types.
  ⟦_⟧Type : Type -> Set
  ⟦ base ι ⟧Type = ⟦ ι ⟧Base
  ⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type

  -- This means: Overload ⟦_⟧ to mean ⟦_⟧Type.
  meaningOfType : Meaning Type
  meaningOfType = meaning ⟦_⟧Type

  -- We also provide: Environments of such values.
  open import Base.Denotation.Environment Type ⟦_⟧Type public

Document P.D.Value.

Document P.D.Value.

Old-commit-hash: bfaab88fbd6365ff0b9046dd999ccd1362c526d6


module Propositional where

open import Data.Nat
open import Relation.Binary.PropositionalEquality

open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open ≡-Reasoning

--------------------------------------------------------------------------------
--  Some easy lemmas
--------------------------------------------------------------------------------

+-zero : ∀ a → a + zero ≡ a
+-zero zero = refl
+-zero (suc a) rewrite +-zero a = refl

+-suc : ∀ a b → a + suc b ≡ suc (a + b)
+-suc zero b = refl
+-suc (suc a) b rewrite +-suc a b = refl

+-assoc : ∀ a b c → a + b + c ≡ a + (b + c)
+-assoc zero b c = refl
+-assoc (suc a) b c rewrite +-assoc a b c = refl

--------------------------------------------------------------------------------
--  Proofs by equational reasoning
--------------------------------------------------------------------------------

-- commutativity of addition proved traditionally

+-comm₁ : ∀ a b → a + b ≡ b + a
+-comm₁ zero b = sym (+-zero b)
+-comm₁ (suc a) b =
  suc ⌞ a + b ⌟   ≡⟨ cong suc (+-comm₁ a b) ⟩
  suc (b + a)     ≡⟨ sym (+-suc b a) ⟩
  b + suc a       ∎

-- commutativity of addition proved with holes

+-comm : ∀ a b → a + b ≡ b + a
+-comm zero b = sym (+-zero b)
+-comm (suc a) b =
  suc ⌞ a + b ⌟   ≡⟨ cong! (+-comm a b) ⟩
  suc (b + a)     ≡⟨ cong! (+-suc b a) ⟩
  b + suc a       ∎

-- distributivity of multiplication over addition proved traditionally

*-distrib-+₁ : ∀ a b c → a * (b + c) ≡ a * b + a * c
*-distrib-+₁ zero b c = refl
*-distrib-+₁ (suc a) b c =
    b + c + a * (b + c)          ≡⟨ cong (λ h → b + c + h) (*-distrib-+₁ a b c) ⟩
    (b + c) + (a * b + a * c)    ≡⟨ sym (+-assoc (b + c) (a * b) (a * c)) ⟩
    ((b + c) + a * b) + a * c    ≡⟨ cong (λ h → h + a * c) (+-assoc b c (a * b)) ⟩
    (b + (c + a * b)) + a * c    ≡⟨ cong (λ h → (b + h) + a * c) (+-comm c (a * b)) ⟩
    (b + (a * b + c)) + a * c    ≡⟨ cong (λ h → h + a * c) (sym (+-assoc b (a * b) c)) ⟩
    ((b + a * b) + c) + a * c    ≡⟨ +-assoc (b + a * b) c (a * c) ⟩
    (b + a * b) + (c + a * c)
  ∎

-- distributivity of multiplication over addition proved with holes

*-distrib-+ : ∀ a b c → a * (b + c) ≡ a * b + a * c
*-distrib-+ zero b c = refl
*-distrib-+ (suc a) b c =
  b + c + ⌞ a * (b + c) ⌟         ≡⟨ cong! (*-distrib-+ a b c) ⟩
  (b + c) + (a * b + a * c)       ≡⟨ cong! (+-assoc (b + c) (a * b) (a * c)) ⟩
  ⌞ (b + c) + a * b ⌟ + a * c     ≡⟨ cong! (+-assoc b c (a * b)) ⟩
  (b + ⌞ c + a * b ⌟) + a * c     ≡⟨ cong! (+-comm c (a * b)) ⟩
  ⌞ b + (a * b + c) ⌟ + a * c     ≡⟨ cong! (+-assoc b (a * b) c) ⟩
  ⌞ ((b + a * b) + c) + a * c ⌟   ≡⟨ cong! (+-assoc (b + a * b) c (a * c)) ⟩
  (b + a * b) + (c + a * c)
  ∎

module Propositional where

open import Data.Nat
open import Relation.Binary.PropositionalEquality

open import Holes.Term using (⌞_⌟)
open import Holes.Cong.Propositional

open ≡-Reasoning

--------------------------------------------------------------------------------
--  Some easy lemmas
--------------------------------------------------------------------------------

+-zero : ∀ a → a + zero ≡ a
+-zero zero = refl
+-zero (suc a) rewrite +-zero a = refl

+-suc : ∀ a b → a + suc b ≡ suc (a + b)
+-suc zero b = refl
+-suc (suc a) b rewrite +-suc a b = refl

+-assoc : ∀ a b c → a + b + c ≡ a + (b + c)
+-assoc zero b c = refl
+-assoc (suc a) b c rewrite +-assoc a b c = refl

--------------------------------------------------------------------------------
--  Proofs by equational reasoning
--------------------------------------------------------------------------------

-- commutativity of addition proved traditionally

+-comm₁ : ∀ a b → a + b ≡ b + a
+-comm₁ zero b = sym (+-zero b)
+-comm₁ (suc a) b =
  suc ⌞ a + b ⌟   ≡⟨ cong suc (+-comm₁ a b) ⟩
  suc (b + a)     ≡⟨ sym (+-suc b a) ⟩
  b + suc a       ∎

-- commutativity of addition proved with holes

+-comm : ∀ a b → a + b ≡ b + a
+-comm zero b = sym (+-zero b)
+-comm (suc a) b =
  suc ⌞ a + b ⌟   ≡⟨ cong! (+-comm a b) ⟩
  suc (b + a)     ≡⟨ cong! (+-suc b a) ⟩
  b + suc a       ∎

-- distributivity of multiplication over addition proved traditionally

*-distrib-+₁ : ∀ a b c → a * (b + c) ≡ a * b + a * c
*-distrib-+₁ zero b c = refl
*-distrib-+₁ (suc a) b c =
    b + c + a * (b + c)          ≡⟨ cong (λ h → b + c + h) (*-distrib-+₁ a b c) ⟩
    (b + c) + (a * b + a * c)    ≡⟨ sym (+-assoc (b + c) (a * b) (a * c)) ⟩
    ((b + c) + a * b) + a * c    ≡⟨ cong (λ h → h + a * c) (+-assoc b c (a * b)) ⟩
    (b + (c + a * b)) + a * c    ≡⟨ cong (λ h → (b + h) + a * c) (+-comm c (a * b)) ⟩
    (b + (a * b + c)) + a * c    ≡⟨ cong (λ h → h + a * c) (sym (+-assoc b (a * b) c)) ⟩
    ((b + a * b) + c) + a * c    ≡⟨ +-assoc (b + a * b) c (a * c) ⟩
    (b + a * b) + (c + a * c)
  ∎

-- distributivity of multiplication over addition proved with holes

*-distrib-+ : ∀ a b c → a * (b + c) ≡ a * b + a * c
*-distrib-+ zero b c = refl
*-distrib-+ (suc a) b c =
  b + c + ⌞ a * (b + c) ⌟         ≡⟨ cong! (*-distrib-+ a b c) ⟩
  ⌞ (b + c) + (a * b + a * c) ⌟   ≡⟨ cong! (+-assoc (b + c) (a * b) (a * c)) ⟩
  ⌞ (b + c) + a * b ⌟ + a * c     ≡⟨ cong! (+-assoc b c (a * b)) ⟩
  (b + ⌞ c + a * b ⌟) + a * c     ≡⟨ cong! (+-comm c (a * b)) ⟩
  ⌞ b + (a * b + c) ⌟ + a * c     ≡⟨ cong! (+-assoc b (a * b) c) ⟩
  ⌞ ((b + a * b) + c) + a * c ⌟   ≡⟨ cong! (+-assoc (b + a * b) c (a * c)) ⟩
  (b + a * b) + (c + a * c)
  ∎

Add a hole in the examples that's strictly unnecessary

... but potentially confusing if it isn't there


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts, prefixes of
-- contexts and variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
--
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- TYPING CONTEXTS

-- Syntax

import Data.List as List
open List public
  using ()
  renaming
    ( [] to ∅ ; _∷_ to _•_
    ; map to mapContext
    )

Context : Set
Context = List.List Type

-- VARIABLES

-- Syntax

data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- WEAKENING

-- CONTEXT PREFIXES
--
-- Useful for making lemmas strong enough to prove by induction.
--
-- Consider using the Subcontexts module instead.

module Prefixes where

-- Prefix of a context

  data Prefix : Context → Set where
    ∅ : ∀ {Γ} → Prefix Γ
    _•_ : ∀ {Γ} → (τ : Type) → Prefix Γ → Prefix (τ • Γ)

-- take only the prefix of a context

  take : (Γ : Context) → Prefix Γ → Context
  take Γ ∅ = ∅
  take (τ • Γ) (.τ • Γ′) = τ • take Γ Γ′

-- drop the prefix of a context

  drop : (Γ : Context) → Prefix Γ → Context
  drop Γ ∅ = Γ
  drop (τ • Γ) (.τ • Γ′) = drop Γ Γ′

-- Extend a context to a super context

  infixr 10 _⋎_

  _⋎_ : (Γ₁ Γ₂ : Context) → Context
  ∅ ⋎ Γ₂ = Γ₂
  (τ • Γ₁) ⋎ Γ₂ = τ • (Γ₁ ⋎ Γ₂)

  take-drop : ∀ Γ Γ′ → take Γ Γ′ ⋎ drop Γ Γ′ ≡ Γ
  take-drop ∅ ∅ = refl
  take-drop (τ • Γ) ∅ = refl
  take-drop (τ • Γ) (.τ • Γ′) rewrite take-drop Γ Γ′ = refl

  or-unit : ∀ Γ → Γ ⋎ ∅ ≡ Γ
  or-unit ∅ = refl
  or-unit (τ • Γ) rewrite or-unit Γ = refl

  move-prefix : ∀ Γ τ Γ′ →
    Γ ⋎ (τ • Γ′) ≡ (Γ ⋎ (τ • ∅)) ⋎ Γ′
  move-prefix ∅ τ Γ′ = refl
  move-prefix (τ • Γ) τ₁ ∅ = sym (or-unit (τ • Γ ⋎ (τ₁ • ∅)))
  move-prefix (τ • Γ) τ₁ (τ₂ • Γ′) rewrite move-prefix Γ τ₁ (τ₂ • Γ′) = refl

-- Lift a variable to a super context

  lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
  lift {∅} {∅} x = x
  lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
  lift {τ • Γ₁} {Γ₂} this = this
  lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- SUBCONTEXTS
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

module Subcontexts where
  infix 4 _≼_

  data _≼_ : (Γ₁ Γ₂ : Context) → Set where
    ∅ : ∅ ≼ ∅
    keep_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      τ • Γ₁ ≼ τ • Γ₂
    drop_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      Γ₁ ≼ τ • Γ₂

  -- Properties

  ∅≼Γ : ∀ {Γ} → ∅ ≼ Γ
  ∅≼Γ {∅} = ∅
  ∅≼Γ {τ • Γ} = drop τ • ∅≼Γ

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation as well as the
-- definition of _⋎_.

open Subcontexts public
open Prefixes public using (_⋎_)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts, prefixes of
-- contexts and variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
--
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- TYPING CONTEXTS

-- Syntax

import Data.List as List
open List public
  using ()
  renaming
    ( [] to ∅ ; _∷_ to _•_
    ; map to mapContext
    )

Context : Set
Context = List.List Type

-- VARIABLES

-- Syntax

data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- WEAKENING

-- CONTEXT PREFIXES
--
-- Useful for making lemmas strong enough to prove by induction.
--
-- Consider using the Subcontexts module instead.

module Prefixes where

-- Prefix of a context

  data Prefix : Context → Set where
    ∅ : ∀ {Γ} → Prefix Γ
    _•_ : ∀ {Γ} → (τ : Type) → Prefix Γ → Prefix (τ • Γ)

-- take only the prefix of a context

  take : (Γ : Context) → Prefix Γ → Context
  take Γ ∅ = ∅
  take (τ • Γ) (.τ • Γ′) = τ • take Γ Γ′

-- drop the prefix of a context

  drop : (Γ : Context) → Prefix Γ → Context
  drop Γ ∅ = Γ
  drop (τ • Γ) (.τ • Γ′) = drop Γ Γ′

-- Extend a context to a super context

  infixr 10 _⋎_

  _⋎_ : (Γ₁ Γ₂ : Context) → Context
  ∅ ⋎ Γ₂ = Γ₂
  (τ • Γ₁) ⋎ Γ₂ = τ • (Γ₁ ⋎ Γ₂)

  take-drop : ∀ Γ Γ′ → take Γ Γ′ ⋎ drop Γ Γ′ ≡ Γ
  take-drop ∅ ∅ = refl
  take-drop (τ • Γ) ∅ = refl
  take-drop (τ • Γ) (.τ • Γ′) rewrite take-drop Γ Γ′ = refl

  or-unit : ∀ Γ → Γ ⋎ ∅ ≡ Γ
  or-unit ∅ = refl
  or-unit (τ • Γ) rewrite or-unit Γ = refl

  move-prefix : ∀ Γ τ Γ′ →
    Γ ⋎ (τ • Γ′) ≡ (Γ ⋎ (τ • ∅)) ⋎ Γ′
  move-prefix ∅ τ Γ′ = refl
  move-prefix (τ • Γ) τ₁ ∅ = sym (or-unit (τ • Γ ⋎ (τ₁ • ∅)))
  move-prefix (τ • Γ) τ₁ (τ₂ • Γ′) rewrite move-prefix Γ τ₁ (τ₂ • Γ′) = refl

-- Lift a variable to a super context

  lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
  lift {∅} {∅} x = x
  lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
  lift {τ • Γ₁} {Γ₂} this = this
  lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- SUBCONTEXTS
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

-- This handling of contexts is recommended by [this
-- email](https://lists.chalmers.se/pipermail/agda/2011/003423.html) and
-- attributed to Conor McBride.
--
-- The associated thread discusses a few alternatives solutions, including one
-- where beta-reduction can handle associativity of ++.

module Subcontexts where
  infix 4 _≼_

  data _≼_ : (Γ₁ Γ₂ : Context) → Set where
    ∅ : ∅ ≼ ∅
    keep_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      τ • Γ₁ ≼ τ • Γ₂
    drop_•_ : ∀ {Γ₁ Γ₂} →
      (τ : Type) →
      Γ₁ ≼ Γ₂ →
      Γ₁ ≼ τ • Γ₂

  -- Properties

  ∅≼Γ : ∀ {Γ} → ∅ ≼ Γ
  ∅≼Γ {∅} = ∅
  ∅≼Γ {τ • Γ} = drop τ • ∅≼Γ

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation as well as the
-- definition of _⋎_.

open Subcontexts public
open Prefixes public using (_⋎_)

Comment on handling of contexts

Comment on handling of contexts

Old-commit-hash: 0bfc0dfdc024921016f8df0d8252aa20f5f0f8d6


module Thesis.LangOps where

open import Thesis.Lang
open import Thesis.Changes
open import Thesis.LangChanges
open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality

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

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

-- Do NOT try to read this, such terms are write-only. But the behavior is
-- specified to be oplusτ-equiv and ominusτ-equiv.
oplusτo (σ ⇒ τ) = abs (abs (abs
  (app₂ (oplusτo τ)
    (app (var (that (that this))) (var this))
    (app₂ (var (that this)) (var this) (app (onilτo σ) (var this))))))
oplusτo unit = abs (abs (const unit))
oplusτo int = const plus
oplusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (oplusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (oplusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
oplusτo (sum σ τ) = abs (abs (app₃ (const match) (var (that this))
  (abs (app₃ (const match) (var (that this))
    (abs (app₃ (const match) (var this)
      (abs (app (const linj) (app₂ (oplusτo σ) (var (that (that this))) (var this))))
      (abs (app (const linj) (var (that (that this)))))))
    (abs (var this))))
  (abs (app₃ (const match) (var (that this))
    (abs (app₃ (const match) (var this)
      (abs (app (const rinj) (var (that (that this)))))
      (abs (app (const rinj) (app₂ (oplusτo τ) (var (that (that this))) (var this))))))
    (abs (var this))))))

ominusτo (σ ⇒ τ) = abs (abs (abs (abs (app₂ (ominusτo τ)
  (app (var (that (that (that this)))) (app₂ (oplusτo σ) (var (that this)) (var this)))
  (app (var (that (that this))) (var (that this)))))))
ominusτo unit = abs (abs (const unit))
ominusτo int = const minus
ominusτo (pair σ τ) = abs (abs (app₂ (const cons)
  (app₂ (ominusτo σ) (app (const fst) (var (that this))) (app (const fst) (var this)))
  (app₂ (ominusτo τ) (app (const snd) (var (that this))) (app (const snd) (var this)))))
ominusτo (sum σ τ) = abs (abs (app₃ (const match) (var (that this))
  (abs (app₃ (const match) (var (that this))
    (abs (app (const linj) (app (const linj) (app₂ (ominusτo σ) (var (that this)) (var this)))))
    (abs (app (const rinj) (var (that (that (that this))))))))
  (abs (app₃ (const match) (var (that this))
    (abs (app (const rinj) (var (that (that (that this))))))
    (abs (app (const linj) (app (const rinj) (app₂ (ominusτo τ) (var (that this)) (var this)))))))))

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

oplusτ-equiv-ext : ∀ τ Γ → ⟦ oplusτo {Γ} τ ⟧Term ≡ λ ρ → _⊕_
oplusτ-equiv-ext τ _ = ext³ (λ ρ a da → oplusτ-equiv _ ρ τ a da)
ominusτ-equiv-ext : ∀ τ Γ → ⟦ ominusτo {Γ} τ ⟧Term ≡ λ ρ → _⊝_
ominusτ-equiv-ext τ _ = ext³ (λ ρ a da → ominusτ-equiv _ ρ τ a da)

oplusτ-equiv Γ ρ (σ ⇒ τ) f df = ext (λ a → lemma a)
  where
    module _ (a : ⟦ σ ⟧Type) where
      ρ′ = a • df • f • ρ
      ρ′′ = a • ρ′
      lemma : ⟦ oplusτo τ ⟧Term ρ′ (f a)
         (df a (⟦ ominusτo σ ⟧Term ρ′′ a a))
         ≡ f a ⊕ df a (nil a)
      lemma
        rewrite ominusτ-equiv _ ρ′′ σ a a
        | oplusτ-equiv _ ρ′ τ (f a) (df a (nil a))
        = refl
oplusτ-equiv Γ ρ unit tt tt = refl
oplusτ-equiv Γ ρ int a da = refl
oplusτ-equiv Γ ρ (pair σ τ) (a , b) (da , db)
  rewrite oplusτ-equiv _ ((da , db) • (a , b) • ρ) σ a da
  | oplusτ-equiv _ ((da , db) • (a , b) • ρ) τ b db
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ (inj₁ dx))
  rewrite oplusτ-equiv-ext σ (Δt σ • sum (Δt σ) (Δt τ) • σ • Δt (sum σ τ) • sum σ τ • Γ)
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ (inj₂ dy)) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₂ y) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ (inj₁ dx)) = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ (inj₂ dy))
  rewrite oplusτ-equiv-ext τ (Δt τ • sum (Δt σ) (Δt τ) • τ • Δt (sum σ τ) • sum σ τ • Γ)
  = refl
oplusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₂ y₁) = refl

ominusτ-equiv Γ ρ (σ ⇒ τ) g f = ext (λ a → ext (lemma a))
  where
    module _ (a : ⟦ σ ⟧Type) (da : Chτ σ) where
      ρ′ = da • a • f • g • ρ
      lemma : ⟦ ominusτo τ ⟧Term (da • a • f • g • ρ)
        (g (⟦ oplusτo σ ⟧Term (da • a • f • g • ρ) a da)) (f a)
        ≡ g (a ⊕ da) ⊝ f a
      lemma
        rewrite oplusτ-equiv _ ρ′ σ a da
        | ominusτ-equiv _ ρ′ τ (g (a ⊕ da)) (f a) = refl
ominusτ-equiv Γ ρ unit tt tt = refl
ominusτ-equiv Γ ρ int b a = refl
ominusτ-equiv Γ ρ (pair σ τ) (a2 , b2) (a1 , b1)
  rewrite ominusτ-equiv _ ((a1 , b1) • (a2 , b2) • ρ) σ a2 a1
  | ominusτ-equiv _ ((a1 , b1) • (a2 , b2) • ρ) τ b2 b1
  = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₁ x₁)
  rewrite ominusτ-equiv-ext σ (σ • σ • sum σ τ • sum σ τ • Γ)
  = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₁ x) (inj₂ y) = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₁ x) = refl
ominusτ-equiv Γ ρ (sum σ τ) (inj₂ y) (inj₂ y₁)
  rewrite ominusτ-equiv-ext τ (τ • τ • sum σ τ • sum σ τ • Γ)
  = refl

-- Proved these lemmas to show them in thesis.
oplusτ-equiv-term : ∀ dΓ (dρ : ⟦ dΓ ⟧Context) τ t dt  →
  ⟦ app₂ (oplusτo τ) t dt ⟧Term dρ ≡ ⟦ t ⟧Term dρ ⊕ ⟦ dt ⟧Term dρ
oplusτ-equiv-term dΓ dρ τ t dt = oplusτ-equiv dΓ dρ τ (⟦ t ⟧Term dρ) (⟦ dt ⟧Term dρ)
ominusτ-equiv-term : ∀ Γ (ρ : ⟦ Γ ⟧Context) τ t2 t1  →
  ⟦ app₂ (ominusτo τ) t2 t1 ⟧Term ρ ≡ ⟦ t2 ⟧Term ρ ⊝ ⟦ t1 ⟧Term ρ
ominusτ-equiv-term Γ ρ τ t2 t1 = ominusτ-equiv Γ ρ τ (⟦ t2 ⟧Term ρ) (⟦ t1 ⟧Term ρ)

Add lemmas I present in thesis

Add lemmas I present in thesis


{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (Bool; trace-call; _++_)
open import FFI.JS.Check
  renaming (check      to check?)
--renaming (warn-check to check?)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  -- ℤp*
  𝔾 : Set
  𝔾 = BigI

  private
    mod-p : BigI → 𝔾
    mod-p x = mod x p

  -- There are two ways to go from BigI to 𝔾: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹𝔾 : BigI → 𝔾
  BigI▹𝔾 = -- trace-call "BigI▹𝔾 "
    λ x →
      (check? (x <I p)
         (λ _ → "Not below the modulus: p:" ++ toString p ++ " is less than x:" ++ toString x)
         (check? (x >I 0I)
            (λ _ → "Should be strictly positive: " ++ toString x ++ " <= 0") x))

  check-non-zero : 𝔾 → BigI
  check-non-zero = -- trace-call "check-non-zero "
    λ x → check? (x >I 0I) (λ _ → "Should be non zero") x

  repr : 𝔾 → BigI
  repr x = x

  1# : 𝔾
  1# = 1I

  1/_ : 𝔾 → 𝔾
  1/ x = modInv (check-non-zero x) p

  _^_ : 𝔾 → BigI → 𝔾
  x ^ y = modPow x y p

_*_ _/_ : 𝔾 → 𝔾 → 𝔾

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  𝔾-Eq? : Eq? 𝔾
  𝔾-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : 𝔾 → 𝔾 → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List 𝔾 → 𝔾
prod = foldr _*_ 1#

mon-ops : Monoid-Ops 𝔾
mon-ops = _*_ , 1#

grp-ops : Group-Ops 𝔾
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group 𝔾
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type.Eq
open import FFI.JS using (Bool; trace-call; _++_)
open import FFI.JS.Check
  renaming (check      to check?)
--renaming (warn-check to check?)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Data.Two hiding (_==_)
open import Relation.Binary.PropositionalEquality
open import Algebra.Raw
open import Algebra.Group

-- TODO carry on a primality proof of p
module Crypto.JS.BigI.CyclicGroup (p : BigI) where

abstract
  ℤ[_]★ : Set
  ℤ[_]★ = BigI

  private
    ℤp★ : Set
    ℤp★ = BigI

    mod-p : BigI → ℤp★
    mod-p x = mod x p

  -- There are two ways to go from BigI to ℤp★: check and mod-p
  -- Use check for untrusted input data and mod-p for internal
  -- computation.
  BigI▹ℤ[_]★ : BigI → ℤp★
  BigI▹ℤ[_]★ = -- trace-call "BigI▹ℤ[_]★ "
    λ x →
      (check? (x <I p)
         (λ _ → "Not below the modulus: p:" ++ toString p ++ " is less than x:" ++ toString x)
         (check? (x >I 0I)
            (λ _ → "Should be strictly positive: " ++ toString x ++ " <= 0") x))

  check-non-zero : ℤp★ → BigI
  check-non-zero = -- trace-call "check-non-zero "
    λ x → check? (x >I 0I) (λ _ → "Should be non zero") x

  repr : ℤp★ → BigI
  repr x = x

  1# : ℤp★
  1# = 1I

  1/_ : ℤp★ → ℤp★
  1/ x = modInv (check-non-zero x) p

  _^_ : ℤp★ → BigI → ℤp★
  x ^ y = modPow x y p

_*_ _/_ : ℤp★ → ℤp★ → ℤp★

x * y = mod-p (multiply (repr x) (repr y))
x / y = x * 1/ y

instance
  ℤ[_]★-Eq? : Eq? ℤp★
  ℤ[_]★-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤp★ → ℤp★ → 𝟚
      x ==' y = equals (repr x) (repr y)
      postulate
        ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
        ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y

prod : List ℤp★ → ℤp★
prod = foldr _*_ 1#

mon-ops : Monoid-Ops ℤp★
mon-ops = _*_ , 1#

grp-ops : Group-Ops ℤp★
grp-ops = mon-ops , 1/_

postulate
  grp-struct : Group-Struct grp-ops

grp : Group ℤp★
grp = grp-ops , grp-struct

module grp = Group grp
-- -}
-- -}
-- -}
-- -}
-- -}

rename 𝔾 as ℤ[ p ]★

CyclicGroup: rename 𝔾 as ℤ[ p ]★


module Base.Denotation.Notation where

-- OVERLOADING ⟦_⟧ NOTATION
--
-- This module defines a general mechanism for overloading the
-- ⟦_⟧ notation, using Agda’s instance arguments.

open import Level

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

open Meaning public
  using (⟨_⟩⟦_⟧)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Overloading ⟦_⟧ notation
--
-- This module defines a general mechanism for overloading the
-- ⟦_⟧ notation, using Agda’s instance arguments.
------------------------------------------------------------------------

module Base.Denotation.Notation where

open import Level

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

open Meaning public
  using (⟨_⟩⟦_⟧)

Improve commentary in Base.Denotation.Notation.

Old-commit-hash: f51d5958c73259a9120fc8a2ad20854bb12f8870


-- This is an implementation of the equality type for Sets. Agda's
-- standard equality is more powerful. The main idea here is to
-- illustrate the equality type.
module Equality where

open import Level
-- The equality of two elements of type A. The type a ≡ b is a family
-- of types which captures the statement of equality in A. Not all of
-- the types are inhabited as in general not all elements are equal
-- here. The only type that are inhabited are a ≡ a by the element
-- that we call definition. This is called refl (for reflection in
-- agda).
data _≡_  {ℓ} {A : Set ℓ} : (a b : A) → Set ℓ where
  definition : {x : A} → x ≡ x

-- ≡ is a symmetric relation.
sym : ∀{ℓ} {A : Set ℓ} {a b : A} → a ≡ b → b ≡ a
sym definition = definition

-- ≡ is a transitive relation.
trans : ∀ {ℓ} {A : Set ℓ} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans pAB definition = pAB
-- trans definition pBC = pBC  -- alternate proof of transitivity.

-- Congruence. If we apply f to equals the result are also equal.
cong : ∀{ℓ₀ ℓ₁} {A : Set ℓ₀} {B : Set ℓ₁}
       {a₀ a₁ : A} → (f : A → B) → a₀ ≡ a₁ → f a₀ ≡ f a₁
cong f definition = definition

-- Pretty way of doing equational reasoning.  If we want to prove a₀ ≡
-- b through an intermediate set of equations use this. The general
-- form will look like.
--
-- begin a  ≈ a₀ by p₀
--          ≈ a₁ by p₁
--          ...
--          ≈ b  by p
-- ∎

begin : ∀{ℓ} {A : Set ℓ} (a : A) →  a ≡ a
_≈_by_ : ∀{ℓ} {A : Set ℓ} {a b : A} → a ≡ b → (c : A) → b ≡ c → a ≡ c
_∎ : ∀{ℓ} {A : Set ℓ} (a : A) → A

begin a = definition
aEb ≈ c by bEc = trans aEb bEc
x ∎ = x

infixl 1 _≈_by_
infixl 1 _≡_

-- This is an implementation of the equality type for Sets. Agda's
-- standard equality is more powerful. The main idea here is to
-- illustrate the equality type.
module Equality where

open import Level
-- The equality of two elements of type A. The type a ≡ b is a family
-- of types which captures the statement of equality in A. Not all of
-- the types are inhabited as in general not all elements are equal
-- here. The only type that are inhabited are a ≡ a by the element
-- that we call definition. This is called refl (for reflection in
-- agda).
data _≡_  {ℓ} {A : Set ℓ} : (a b : A) → Set ℓ where
  refl : {x : A} → x ≡ x

-- ≡ is a symmetric relation.
sym : ∀{ℓ} {A : Set ℓ} {a b : A} → a ≡ b → b ≡ a
sym refl = refl

-- ≡ is a transitive relation.
trans : ∀ {ℓ} {A : Set ℓ} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans pAB refl = pAB
-- trans refl pBC = pBC  -- alternate proof of transitivity.

-- Congruence. If we apply f to equals the result are also equal.
cong : ∀{ℓ₀ ℓ₁} {A : Set ℓ₀} {B : Set ℓ₁}
       {a₀ a₁ : A} → (f : A → B) → a₀ ≡ a₁ → f a₀ ≡ f a₁
cong f refl = refl

-- Pretty way of doing equational reasoning.  If we want to prove a₀ ≡
-- b through an intermediate set of equations use this. The general
-- form will look like.
--
-- begin a  ≈ a₀ by p₀
--          ≈ a₁ by p₁
--          ...
--          ≈ b  by p
-- ∎

begin : ∀{ℓ} {A : Set ℓ} (a : A) →  a ≡ a
_≈_by_ : ∀{ℓ} {A : Set ℓ} {a b : A} → a ≡ b → (c : A) → b ≡ c → a ≡ c
_∎ : ∀{ℓ} {A : Set ℓ} (a : A) → A

begin a = refl
aEb ≈ c by bEc = trans aEb bEc
x ∎ = x

infixl 1 _≈_by_
infixl 1 _≡_

use the standard terminology refl.

use the standard terminology refl.


module Theorem.CongApp where

-- Theorem CongApp.
-- If f ≡ g and x ≡ y, then (f x) ≡ (g y).

open import Relation.Binary.PropositionalEquality public

infixl 0 _⟨$⟩_

_⟨$⟩_ : ∀ {a b} {A : Set a} {B : Set b}
  {f g : A → B} {x y : A} →
  f ≡ g → x ≡ y → f x ≡ g y

_⟨$⟩_ = cong₂ (λ x y → x y)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Congruence of application.
--
-- If f ≡ g and x ≡ y, then (f x) ≡ (g y).
------------------------------------------------------------------------

module Theorem.CongApp where

open import Relation.Binary.PropositionalEquality public

infixl 0 _⟨$⟩_

_⟨$⟩_ : ∀ {a b} {A : Set a} {B : Set b}
  {f g : A → B} {x y : A} →
  f ≡ g → x ≡ y → f x ≡ g y

_⟨$⟩_ = cong₂ (λ x y → x y)

Document Theorem.CongApp regularly.

Document Theorem.CongApp regularly.

Old-commit-hash: f16f3e3d0b8e59230bd86a0c223af263a8db75e8


open import Data.Nat.NP
open import Data.Nat.Properties as Props
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Data.Nat.Distance where

dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y

dist-refl : ∀ x → dist x x ≡ 0
dist-refl zero = idp
dist-refl (suc x) rewrite dist-refl x = idp

dist-0≡id : ∀ x → dist 0 x ≡ x
dist-0≡id _ = idp

dist-x-x+y≡y : ∀ x y → dist x (x + y) ≡ y
dist-x-x+y≡y zero    y = idp
dist-x-x+y≡y (suc x) y = dist-x-x+y≡y x y

dist-comm : ∀ x y → dist x y ≡ dist y x
dist-comm zero zero = idp
dist-comm zero (suc y) = idp
dist-comm (suc x) zero = idp
dist-comm (suc x) (suc y) = dist-comm x y

dist-x+ : ∀ x y z → dist (x + y) (x + z) ≡ dist y z
dist-x+ zero    y z = idp
dist-x+ (suc x) y z = dist-x+ x y z

dist-2* : ∀ x y → dist (2* x) (2* y) ≡ 2* dist x y
dist-2* zero y = idp
dist-2* (suc x) zero = idp
dist-2* (suc x) (suc y) rewrite +-assoc-comm x 1 x | +-assoc-comm y 1 y = dist-2* x y

dist-asym-def : ∀ {x y} → x ≤ y → x + dist x y ≡ y
dist-asym-def z≤n = idp
dist-asym-def (s≤s pf) = ap suc (dist-asym-def pf)

dist-sym-wlog : ∀ (f : ℕ → ℕ) → (∀ x k → dist (f x) (f (x + k)) ≡ f k) → ∀ x y → dist (f x) (f y) ≡ f (dist x y)
dist-sym-wlog f pf x y with compare x y
dist-sym-wlog f pf x .(suc (x + k)) | less .x k with pf x (suc k)
... | q rewrite +-assoc-comm x 1 k | q | ! +-assoc-comm x 1 k | dist-x-x+y≡y x (suc k) = idp
dist-sym-wlog f pf .y y | equal .y with pf y 0
... | q rewrite ℕ°.+-comm y 0 | dist-refl y = q
dist-sym-wlog f pf .(suc (y + k)) y | greater .y k with pf y (suc k)
... | q rewrite +-assoc-comm 1 y k | dist-comm (y + suc k) y | dist-x-x+y≡y y (suc k) | dist-comm (f (y + suc k)) (f y) = q

dist-x* : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
dist-x* x = dist-sym-wlog (_*_ x) pf
  where pf : ∀ a k → dist (x * a) (x * (a + k)) ≡ x * k
        pf a k rewrite proj₁ ℕ°.distrib x a k = dist-x-x+y≡y (x * a) _

dist-2^* : ∀ x y z → dist ⟨2^ x * y ⟩ ⟨2^ x * z ⟩ ≡ ⟨2^ x * dist y z ⟩
dist-2^* x = dist-sym-wlog (2^⟨ x ⟩*) pf
  where pf : ∀ a k → dist ⟨2^ x * a ⟩ ⟨2^ x * (a + k) ⟩ ≡ ⟨2^ x * k ⟩
        pf a k rewrite 2^*-distrib x a k = dist-x-x+y≡y ⟨2^ x * a ⟩ ⟨2^ x * k ⟩

dist-bounded : ∀ {x y f} → x ≤ f → y ≤ f → dist x y ≤ f
dist-bounded z≤n       y≤f = y≤f
dist-bounded (s≤s x≤f) z≤n = s≤s x≤f
dist-bounded (s≤s x≤f) (s≤s y≤f) = ≤-step (dist-bounded x≤f y≤f)

-- Triangular inequality
dist-sum : ∀ x y z → dist x z ≤ dist x y + dist y z
dist-sum zero    zero    z       = ℕ≤.refl
dist-sum zero    (suc y) zero    = z≤n
dist-sum zero    (suc y) (suc z) = s≤s (dist-sum zero y z)
dist-sum (suc x) zero    zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 x))
dist-sum (suc x) (suc y) zero
  rewrite ℕ°.+-comm (dist x y) (suc y)
        | dist-comm x y = s≤s (dist-sum zero y x)
dist-sum (suc x) zero    (suc z) = dist-sum x zero z
                                ∙≤ ℕ≤.reflexive (ap₂ _+_ (dist-comm x 0) idp)
                                ∙≤ ≤-step (ℕ≤.refl {x} +-mono ≤-step ℕ≤.refl)
dist-sum (suc x) (suc y) (suc z) = dist-sum x y z

dist≡0 : ∀ x y → dist x y ≡ 0 → x ≡ y
dist≡0 zero zero d≡0 = refl
dist≡0 zero (suc y) ()
dist≡0 (suc x) zero ()
dist≡0 (suc x) (suc y) d≡0 = ap suc (dist≡0 x y d≡0)

∸-dist : ∀ x y → y ≤ x → x ∸ y ≡ dist x y
∸-dist x .0 z≤n = ! dist-comm x 0
∸-dist ._ ._ (s≤s y≤x) = ∸-dist _ _ y≤x

{-
post--ulate
  dist-≤     : ∀ x y → dist x y ≤ x
  dist-mono₁ : ∀ x y z t → x ≤ y → dist z t ≤ dist (x + z) (y + t)
-}

-- Haskell
-- let dist x y = abs (x - y)
-- quickCheck (forAll (replicateM 3 (choose (0,100))) (\ [x,y,z] -> dist (x * y) (x * z) == x * dist y z))

open import Function.NP
open import Data.Nat.NP
open import Data.Nat.Properties as Props
open import Data.Nat.Properties.Simple
open import Data.Product.NP
open import Relation.Binary.PropositionalEquality.NP
open import Relation.Binary
open import Relation.Nullary

module Data.Nat.Distance where

{-
dist : ℕ → ℕ → ℕ
dist zero    y       = y
dist x       zero    = x
dist (suc x) (suc y) = dist x y
-}

-- `symIter` from Conor McBride
-- Since symIter is essentially `dist` with callbacks, I
-- include it here.
module Generic {a}{A : Set a}(z : ℕ → A)(s : A → A) where
  dist : ℕ → ℕ → A
  dist zero    y       = z y
  dist x       zero    = z x
  dist (suc x) (suc y) = s (dist x y)

  dist-comm : ∀ x y → dist x y ≡ dist y x
  dist-comm zero    zero    = idp
  dist-comm zero    (suc y) = idp
  dist-comm (suc x) zero    = idp
  dist-comm (suc x) (suc y) = ap s (dist-comm x y)

  dist-0≡id : ∀ x → dist 0 x ≡ z x
  dist-0≡id _ = idp

  dist-0≡id′ : ∀ x → dist x 0 ≡ z x
  dist-0≡id′ zero    = idp
  dist-0≡id′ (suc _) = idp

open Generic id id public

module Add where
  open Generic id (suc ∘ suc)
    public
    renaming ( dist to _+'_
             ; dist-0≡id to +'0-identity
             ; dist-0≡id′ to 0+'-identity
             ; dist-comm to +'-comm
             )

  +-spec : ∀ x y → x +' y ≡ x + y
  +-spec zero    _       = idp
  +-spec (suc x) zero    = ap suc (ℕ°.+-comm 0 x)
  +-spec (suc x) (suc y) = ap suc (ap suc (+-spec x y) ∙ ! +-suc x y)

module AddMult where
  open Generic (λ x → x , 0)
               (λ { (s , p) → (2 + s , 1 + s + p) })
    public
    renaming ( dist to _+*_
             ; dist-0≡id to +*0-identity
             ; dist-0≡id′ to 0+*-identity
             ; dist-comm to +*-comm
             )

  _+'_ : ℕ → ℕ → ℕ
  x +' y = fst (x +* y)

  _*'_ : ℕ → ℕ → ℕ
  x *' y = snd (x +* y)

  +*-spec : ∀ x y → (x +' y ≡ x + y) × (x *' y ≡ x * y)
  +*-spec zero    _       = idp , idp
  +*-spec (suc x) zero    = ap suc (ℕ°.+-comm 0 x) , ℕ°.*-comm 0 x
  +*-spec (suc x) (suc y) = ap suc p+ , ap suc p*
    where p = +*-spec x y
          p+ = ap suc (fst p) ∙ ! +-suc x y
          p* = ap₂ _+_ (fst p) (snd p)
             ∙ +-assoc x y (x * y)
             ∙ ap (λ z → x + (y + z)) (ℕ°.*-comm x y)
             ∙ ! +-assoc-comm y x (y * x)
             ∙ ap (_+_ y) (ℕ°.*-comm (suc y) x)

module Min where
  open Generic (const zero) suc
    public
    renaming ( dist to _⊓'_
             ; dist-0≡id to ⊓'0-zero
             ; dist-0≡id′ to 0⊓'-zero
             ; dist-comm to ⊓'-comm
             )

  ⊓'-spec : ∀ x y → x ⊓' y ≡ x ⊓ y
  ⊓'-spec zero    zero    = idp
  ⊓'-spec zero    (suc y) = idp
  ⊓'-spec (suc x) zero    = idp
  ⊓'-spec (suc x) (suc y) = ap suc (⊓'-spec x y)

module Max where
  open Generic id suc
    public
    renaming ( dist to _⊔'_
             ; dist-0≡id to ⊔'0-identity
             ; dist-0≡id′ to 0⊔'-identity
             ; dist-comm to ⊔'-comm
             )

  ⊔'-spec : ∀ x y → x ⊔' y ≡ x ⊔ y
  ⊔'-spec zero    zero    = idp
  ⊔'-spec zero    (suc y) = idp
  ⊔'-spec (suc x) zero    = idp
  ⊔'-spec (suc x) (suc y) = ap suc (⊔'-spec x y)

dist-refl : ∀ x → dist x x ≡ 0
dist-refl zero = idp
dist-refl (suc x) rewrite dist-refl x = idp

dist-x-x+y≡y : ∀ x y → dist x (x + y) ≡ y
dist-x-x+y≡y zero    y = idp
dist-x-x+y≡y (suc x) y = dist-x-x+y≡y x y

dist-x+ : ∀ x y z → dist (x + y) (x + z) ≡ dist y z
dist-x+ zero    y z = idp
dist-x+ (suc x) y z = dist-x+ x y z

dist-2* : ∀ x y → dist (2* x) (2* y) ≡ 2* dist x y
dist-2* zero y = idp
dist-2* (suc x) zero = idp
dist-2* (suc x) (suc y) rewrite +-assoc-comm x 1 x | +-assoc-comm y 1 y = dist-2* x y

dist-asym-def : ∀ {x y} → x ≤ y → x + dist x y ≡ y
dist-asym-def z≤n = idp
dist-asym-def (s≤s pf) = ap suc (dist-asym-def pf)

dist-sym-wlog : ∀ (f : ℕ → ℕ) → (∀ x k → dist (f x) (f (x + k)) ≡ f k) → ∀ x y → dist (f x) (f y) ≡ f (dist x y)
dist-sym-wlog f pf x y with compare x y
dist-sym-wlog f pf x .(suc (x + k)) | less .x k with pf x (suc k)
... | q rewrite +-assoc-comm x 1 k | q | ! +-assoc-comm x 1 k | dist-x-x+y≡y x (suc k) = idp
dist-sym-wlog f pf .y y | equal .y with pf y 0
... | q rewrite ℕ°.+-comm y 0 | dist-refl y = q
dist-sym-wlog f pf .(suc (y + k)) y | greater .y k with pf y (suc k)
... | q rewrite +-assoc-comm 1 y k | dist-comm (y + suc k) y | dist-x-x+y≡y y (suc k) | dist-comm (f (y + suc k)) (f y) = q

dist-x* : ∀ x y z → dist (x * y) (x * z) ≡ x * dist y z
dist-x* x = dist-sym-wlog (_*_ x) pf
  where pf : ∀ a k → dist (x * a) (x * (a + k)) ≡ x * k
        pf a k rewrite fst ℕ°.distrib x a k = dist-x-x+y≡y (x * a) _

dist-2^* : ∀ x y z → dist ⟨2^ x * y ⟩ ⟨2^ x * z ⟩ ≡ ⟨2^ x * dist y z ⟩
dist-2^* x = dist-sym-wlog (2^⟨ x ⟩*) pf
  where pf : ∀ a k → dist ⟨2^ x * a ⟩ ⟨2^ x * (a + k) ⟩ ≡ ⟨2^ x * k ⟩
        pf a k rewrite 2^*-distrib x a k = dist-x-x+y≡y ⟨2^ x * a ⟩ ⟨2^ x * k ⟩

dist-bounded : ∀ {x y f} → x ≤ f → y ≤ f → dist x y ≤ f
dist-bounded z≤n       y≤f = y≤f
dist-bounded (s≤s x≤f) z≤n = s≤s x≤f
dist-bounded (s≤s x≤f) (s≤s y≤f) = ≤-step (dist-bounded x≤f y≤f)

-- Triangular inequality
dist-sum : ∀ x y z → dist x z ≤ dist x y + dist y z
dist-sum zero    zero    z       = ℕ≤.refl
dist-sum zero    (suc y) zero    = z≤n
dist-sum zero    (suc y) (suc z) = s≤s (dist-sum zero y z)
dist-sum (suc x) zero    zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 x))
dist-sum (suc x) (suc y) zero
  rewrite ℕ°.+-comm (dist x y) (suc y)
        | dist-comm x y = s≤s (dist-sum zero y x)
dist-sum (suc x) zero    (suc z) = dist-sum x zero z
                                ∙≤ ℕ≤.reflexive (ap₂ _+_ (dist-comm x 0) idp)
                                ∙≤ ≤-step (ℕ≤.refl {x} +-mono ≤-step ℕ≤.refl)
dist-sum (suc x) (suc y) (suc z) = dist-sum x y z

dist≡0 : ∀ x y → dist x y ≡ 0 → x ≡ y
dist≡0 zero zero d≡0 = idp
dist≡0 zero (suc y) ()
dist≡0 (suc x) zero ()
dist≡0 (suc x) (suc y) d≡0 = ap suc (dist≡0 x y d≡0)

∸-≤-dist : ∀ x y → x ∸ y ≤ dist x y
∸-≤-dist zero zero       = z≤n
∸-≤-dist zero (suc y)    = z≤n
∸-≤-dist (suc x) zero    = ℕ≤.refl
∸-≤-dist (suc x) (suc y) = ∸-≤-dist x y

∸-dist : ∀ x y → y ≤ x → x ∸ y ≡ dist x y
∸-dist x .0  z≤n       = ! dist-comm x 0
∸-dist ._ ._ (s≤s y≤x) = ∸-dist _ _ y≤x

dist-min-max : ∀ x y → dist x y ≡ (x ⊔ y) ∸ (x ⊓ y)
dist-min-max zero    zero    = idp
dist-min-max zero    (suc y) = idp
dist-min-max (suc x) zero    = idp
dist-min-max (suc x) (suc y) = dist-min-max x y
-- -}
-- -}
-- -}
-- -}
-- -}

Dist: add the `symIter` from Conor and some lemmas


module Syntax.Type.Plotkin where

-- Types for language description à la Plotkin (LCF as PL)
--
-- Given base types, we build function types.

infixr 5 _⇒_

data Type (B : Set {- of base types -}) : Set where
  base : (ι : B) → Type B
  _⇒_ : (σ : Type B) → (τ : Type B) → Type B

-- Lift (Δ : B → Type B) to (Δtype : Type B → Type B)
-- according to Δ (σ ⇒ τ) = σ ⇒ Δ σ ⇒ Δ τ
lift-Δtype : ∀ {B} → (B → Type B) → (Type B → Type B)
lift-Δtype f (base ι) = f ι
lift-Δtype f (σ ⇒ τ) = let Δ = lift-Δtype f in σ ⇒ Δ σ ⇒ Δ τ

-- Note: the above is *not* a monadic bind.
--
-- Proof. base` is the most straightforward `return` of the
-- functor `Type`.
--
--     return : B → Type B
--     return = base
--
-- Let
--
--     m : Type B
--     m = base κ ⇒ base ι
--
-- then
--
--     m >>= return = lift-Δtype return m
--                  = base κ ⇒ base κ ⇒ base ι
--
-- violating the second monadic law, m >>= return ≡ m. ∎

open import Function

-- Variant of lift-Δtype for (Δ : B → B).
lift-Δtype₀ : ∀ {B} → (B → B) → (Type B → Type B)
lift-Δtype₀ f = lift-Δtype $ base ∘ f
-- This has a similar type to the type of `fmap`,
-- and `base` has a similar type to the type of `return`.
--
-- Similarly, for collections map can be defined from flatMap,
-- like lift-Δtype₀ can be defined in terms of lift-Δtype.

module Syntax.Type.Plotkin where

-- Types for language description à la Plotkin (LCF as PL)
--
-- Given base types, we build function types.

open import Function

infixr 5 _⇒_

data Type (B : Set {- of base types -}) : Set where
  base : (ι : B) → Type B
  _⇒_ : (σ : Type B) → (τ : Type B) → Type B

-- Lift (Δ : B → Type B) to (Δtype : Type B → Type B)
-- according to Δ (σ ⇒ τ) = σ ⇒ Δ σ ⇒ Δ τ
lift-Δtype : ∀ {B} → (B → Type B) → (Type B → Type B)
lift-Δtype f (base ι) = f ι
lift-Δtype f (σ ⇒ τ) = let Δ = lift-Δtype f in σ ⇒ Δ σ ⇒ Δ τ

-- Note: the above is *not* a monadic bind.
--
-- Proof. base` is the most straightforward `return` of the
-- functor `Type`.
--
--     return : B → Type B
--     return = base
--
-- Let
--
--     m : Type B
--     m = base κ ⇒ base ι
--
-- then
--
--     m >>= return = lift-Δtype return m
--                  = base κ ⇒ base κ ⇒ base ι
--
-- violating the second monadic law, m >>= return ≡ m. ∎

-- Variant of lift-Δtype for (Δ : B → B).
lift-Δtype₀ : ∀ {B} → (B → B) → (Type B → Type B)
lift-Δtype₀ f = lift-Δtype $ base ∘ f
-- This has a similar type to the type of `fmap`,
-- and `base` has a similar type to the type of `return`.
--
-- Similarly, for collections map can be defined from flatMap,
-- like lift-Δtype₀ can be defined in terms of lift-Δtype.

Agda: move import to top of file in Syntax.Type.Plotkin

Old-commit-hash: 0d789d2318a5215ac4ba2f68286e7db5826593ec


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence - base definitions
------------------------------------------------------------------------
module Base.Change.Equivalence.Base where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- Delta-observational equivalence: these asserts that two changes
  -- give the same result when applied to a base value.

  -- To avoid unification problems, use a one-field record.
  record _≙_ dx dy : Set a where
    -- doe = Delta-Observational Equivalence.
    constructor doe
    field
      proof : x ⊞ dx ≡ x ⊞ dy

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

  -- _≙_ is indeed an equivalence relation:
  ≙-refl : ∀ {dx} → dx ≙ dx
  ≙-refl = doe refl

  ≙-sym : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
  ≙-sym ≙ = doe $ sym $ proof ≙

  ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
  ≙-trans ≙₁ ≙₂ = doe $ trans (proof ≙₁) (proof ≙₂)

  -- That's standard congruence applied to ≙
  ≙-cong  : ∀ {b} {B : Set b}
       (f : A → B) {dx dy} → dx ≙ dy → f (x ⊞ dx) ≡ f (x ⊞ dy)
  ≙-cong f da≙db = cong f $ proof da≙db

  ≙-isEquivalence : IsEquivalence (_≙_)
  ≙-isEquivalence = record
    { refl  = ≙-refl
    ; sym   = ≙-sym
    ; trans = ≙-trans
    }

  ≙-setoid : Setoid ℓ a
  ≙-setoid = record
    { Carrier       = Δ x
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence - base definitions
------------------------------------------------------------------------
module Base.Change.Equivalence.Base where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- Delta-observational equivalence: these asserts that two changes
  -- give the same result when applied to a base value.

  -- To avoid unification problems, use a one-field record (a Haskell "newtype")
  -- instead of a "type synonym".
  record _≙_ dx dy : Set a where
    -- doe = Delta-Observational Equivalence.
    constructor doe
    field
      proof : x ⊞ dx ≡ x ⊞ dy

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

  -- _≙_ is indeed an equivalence relation:
  ≙-refl : ∀ {dx} → dx ≙ dx
  ≙-refl = doe refl

  ≙-sym : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
  ≙-sym ≙ = doe $ sym $ proof ≙

  ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
  ≙-trans ≙₁ ≙₂ = doe $ trans (proof ≙₁) (proof ≙₂)

  -- That's standard congruence applied to ≙
  ≙-cong  : ∀ {b} {B : Set b}
       (f : A → B) {dx dy} → dx ≙ dy → f (x ⊞ dx) ≡ f (x ⊞ dy)
  ≙-cong f da≙db = cong f $ proof da≙db

  ≙-isEquivalence : IsEquivalence (_≙_)
  ≙-isEquivalence = record
    { refl  = ≙-refl
    ; sym   = ≙-sym
    ; trans = ≙-trans
    }

  ≙-setoid : Setoid ℓ a
  ≙-setoid = record
    { Carrier       = Δ x
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

Clarify Agda comment

Clarify Agda comment

Old-commit-hash: e00f9f0bb80cb86372669d674900a9abd43b7ef4