module Syntax.Language.Calculus where

-- Full description of a calculus in Plotkin style
--
-- Users should supply
-- - base types
-- - constants
-- - Δtype of base types
-- - derivatives of constants

open import Syntax.Type.Plotkin public
open import Syntax.Term.Plotkin public
open import Syntax.Context public
open import Syntax.Context.Plotkin public
open import Syntax.DeltaContext public

record Calculus : Set₁ where
  constructor
    calculus-with
  field
    basetype : Set
    constant : Context {Type basetype} → Type basetype → Set
    Δtype : Type basetype → Type basetype
    Δconst : ∀ {Γ Σ τ} → (c : constant Σ τ) →
      Term {basetype} {constant} Γ
        (internalizeContext basetype (ΔContext′ (Type basetype) Δtype Σ) (Δtype τ))

open Calculus public

type : Calculus → Set
type L = Type (basetype L)

context : Calculus → Set
context L = Context {type L}

term : (L : Calculus) → context L → type L → Set
term L = Term {basetype L} {constant L}

module Syntax.Language.Calculus where

-- Full description of a calculus in Plotkin style
--
-- Users should supply
-- - base types
-- - constants
-- - Δtype of base types
-- - derivatives of constants

open import Syntax.Type.Plotkin public
open import Syntax.Term.Plotkin public
open import Syntax.Context public
open import Syntax.Context.Plotkin public
open import Syntax.DeltaContext public

record Calculus : Set₁ where
  constructor
    calculus-with
  field
    basetype : Set
    constant : Context {Type basetype} → Type basetype → Set
    Δtype : Type basetype → Type basetype
    Δconst : ∀ {Γ Σ τ} → (c : constant Σ τ) →
      Term {basetype} {constant} Γ
        (internalizeContext basetype (ΔContext′ (Type basetype) Δtype Σ) (Δtype τ))

  type : Set
  type = Type basetype

  context : Set
  context = Context {type}

  term : context → type → Set
  term = Term {basetype} {constant}

open Calculus public

Refactor Syntax/Language/Calculus.agda

Refactor Syntax/Language/Calculus.agda

Move helpers inside record, so that if we open the record module with a
record value:

  open Calculus some-specific-calculus

We get all of the helper functions specialized to
`some-specific-calculus`, like the fields.

Old-commit-hash: dafe67297ca04cb5ab0369e8d1d7a8e2109a6c6d


import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    Change-base : Base → Set
    valid-base : ∀ {ι} → ⟦ ι ⟧Base → Change-base ι → Set
    apply-change-base : ∀ ι → ⟦ ι ⟧Base → Change-base ι → ⟦ ι ⟧Base
    diff-change-base : ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → Change-base ι
    R[v,u-v]-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → valid-base {ι} v (diff-change-base ι u v)
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-change-base ι v (diff-change-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  Change : Type → Set
  valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set

  apply-change : ∀ τ → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  diff-change : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ

  infixl 6 apply-change diff-change -- as with + - in GHC.Num
  syntax apply-change τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-change τ u v = u ⊟₍ τ ₎ v

  -- Lemma diff-is-valid
  R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟₍ τ ₎ v)

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (Change τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (Change (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- Change τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
  ValidChange : Type → Set
  ValidChange τ = Triple
    ⟦ τ ⟧
    (λ _ → Change τ)
    (λ v dv → valid {τ} v dv)

  -- Change : Type → Set
  Change (base ι) = Change-base ι
  Change (σ ⇒ τ) = ValidChange σ → Change τ

  before : ValidChange ⊆ ⟦_⟧
  before (cons v _ _) = v

  after : ValidChange ⊆ ⟦_⟧
  after {τ} (cons v dv R[v,dv]) = v ⊞₍ τ ₎ dv

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  n ⊞₍ base ι ₎ Δn = apply-change-base ι n Δn
  f ⊞₍ σ ⇒ τ ₎ Δf = λ v → f v ⊞₍ τ ₎ Δf (cons v (v ⊟₍ σ ₎ v) (R[v,u-v] {σ}))

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  m ⊟₍ base ι ₎ n = diff-change-base ι m n
  g ⊟₍ σ ⇒ τ ₎ f = λ v → g (after v) ⊟₍ τ ₎ f (before v)

  -- valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set
  valid {base ι} n Δn = valid-base {ι} n Δn
  valid {σ ⇒ τ} f Δf =
    ∀ (v : ValidChange σ)
    → valid {τ} (f (before v)) (Δf v)
    -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
    × (f ⊞₍ σ ⇒ τ ₎ Δf) (after v) ≡ f (before v) ⊞₍ τ ₎ Δf v

  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  R[v,u-v] {base ι} {u} {v} = R[v,u-v]-base {ι} {u} {v}
  R[v,u-v] {σ ⇒ τ} {u} {v} = λ w →
    let
      w′ = after {σ} w
    in
      R[v,u-v] {τ}
      ,
      (begin
        (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w′
      ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
        u w′
      ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v (before {σ} w)}) ⟩
        v (before {σ} w) ⊞₍ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v) w
      ∎) where open ≡-Reasoning

  -- helpers
  nil-valid-change : ∀ τ → ⟦ τ ⟧ → ValidChange τ
  nil-valid-change τ v = cons v (v ⊟₍ τ ₎ v) (R[v,u-v] {τ} {v} {v})

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  ΔEnv : Context → Set
  ΔEnv = DependentList ValidChange

  ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  ignore = map (λ {τ} → before {τ})

  update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  update = map (λ {τ} → after {τ})

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    Change-base : Base → Set
    valid-base : ∀ {ι} → ⟦ ι ⟧Base → Change-base ι → Set
    apply-change-base : ∀ ι → ⟦ ι ⟧Base → Change-base ι → ⟦ ι ⟧Base
    diff-change-base : ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → Change-base ι
    R[v,u-v]-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → valid-base {ι} v (diff-change-base ι u v)
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-change-base ι v (diff-change-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  Change : Type → Set
  valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set

  apply-change : ∀ τ → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  diff-change : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ

  infixl 6 apply-change diff-change -- as with + - in GHC.Num
  syntax apply-change τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-change τ u v = u ⊟₍ τ ₎ v

  -- Lemma diff-is-valid
  R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟₍ τ ₎ v)

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (Change τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (Change (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- Change τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
  ValidChange : Type → Set
  ValidChange τ = Triple
    ⟦ τ ⟧
    (λ _ → Change τ)
    (λ v dv → valid {τ} v dv)

  -- Change : Type → Set
  Change (base ι) = Change-base ι
  Change (σ ⇒ τ) = ValidChange σ → Change τ

  before : ValidChange ⊆ ⟦_⟧
  before (cons v _ _) = v

  after : ValidChange ⊆ ⟦_⟧
  after {τ} (cons v dv R[v,dv]) = v ⊞₍ τ ₎ dv

  nil-valid-change : ∀ τ → ⟦ τ ⟧ → ValidChange τ
  nil-valid-change τ v = cons v (v ⊟₍ τ ₎ v) (R[v,u-v] {τ} {v} {v})

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  n ⊞₍ base ι ₎ Δn = apply-change-base ι n Δn
  f ⊞₍ σ ⇒ τ ₎ Δf = λ v → f v ⊞₍ τ ₎ Δf (nil-valid-change σ v)

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  m ⊟₍ base ι ₎ n = diff-change-base ι m n
  g ⊟₍ σ ⇒ τ ₎ f = λ v → g (after v) ⊟₍ τ ₎ f (before v)

  -- valid : ∀ {τ} → ⟦ τ ⟧ → Change τ → Set
  valid {base ι} n Δn = valid-base {ι} n Δn
  valid {σ ⇒ τ} f Δf =
    ∀ (v : ValidChange σ)
    → valid {τ} (f (before v)) (Δf v)
    -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
    × (f ⊞₍ σ ⇒ τ ₎ Δf) (after v) ≡ f (before v) ⊞₍ τ ₎ Δf v

  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  R[v,u-v] {base ι} {u} {v} = R[v,u-v]-base {ι} {u} {v}
  R[v,u-v] {σ ⇒ τ} {u} {v} = λ w →
    let
      w′ = after {σ} w
    in
      R[v,u-v] {τ}
      ,
      (begin
        (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w′
      ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
        u w′
      ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v (before {σ} w)}) ⟩
        v (before {σ} w) ⊞₍ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v) w
      ∎) where open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → ⟦ τ ⟧ → Change τ → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → Change τ
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  ΔEnv : Context → Set
  ΔEnv = DependentList ValidChange

  ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  ignore = map (λ {τ} → before {τ})

  update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  update = map (λ {τ} → after {τ})

Move nil-valid-change to use it in ⊞.

Move nil-valid-change to use it in ⊞.

What I learned from this project: To implement apply, you need nil.

Old-commit-hash: 3af743a00cc7e7cad69e57ec30364639c1b5e928


open import Type
open import Function
open import Data.Nat.NP using (ℕ; module ℕ°)
open import Data.Fin.NP as Fin using (Fin; inject+; raise; bound; free)
open import Data.Vec.NP using (lookup)
open import FunUniverse.Data
open import FunUniverse.Core
open import FunUniverse.Rewiring.Linear
open import FunUniverse.Category
open import FunUniverse.Category.Op
open import FunUniverse.Fin

module FunUniverse.Fin.Op where

_ᶠ→_ : (i o : ℕ) → ★
i ᶠ→ o = Fin o → Fin i

finOpFunU : FunUniverse ℕ
finOpFunU = Bits-U , _ᶠ→_

finOpCat : Category _ᶠ→_
finOpCat = op finCat

open FunUniverse finOpFunU
open Cong-*1 _`→_

finOpLinRewiring : LinRewiring finOpFunU
finOpLinRewiring = mk finOpCat first (λ {x} → swap {x}) (λ {x} → assoc {x}) id id <_×_> (λ {x} → second {x}) id id id id
  where
    -- NOTE that doing:
    --   swap {A} {B} rewrite ℕ°.+-comm A B = id
    -- would be totally wrong.
    swap : ∀ {A B} → (A `× B) `→ (B `× A)
    swap {A} {B} x with Fin.cmp B A x
    swap {A} {B} ._ | Fin.bound y = raise A y
    swap {A} {B} ._ | Fin.free  y = inject+ B y

    -- Since the order of elements is preserved this is OK to rewrite
    assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
    assoc {A} {B} {C} rewrite ℕ°.+-assoc A B C = id

    <_×_>  : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
    <_×_> {A} {B} {C} {D} f g x with Fin.cmp C D x
    <_×_> {A} {B} {C} {D} f g ._ | Fin.bound y = inject+ B (f y)
    <_×_> {A} {B} {C} {D} f g ._ | Fin.free  y = raise A   (g y)

    idᶠ : ∀ {A} → A `→ A
    idᶠ = id

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

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

finOpRewiring : Rewiring finOpFunU
finOpRewiring = mk finOpLinRewiring (λ ()) dup (λ()) (λ f g → dup ⁏ < f × g >) (inject+ _) (λ {x} → raise x) cong-*1 (cong-*1 ∘ flip lookup)
  where
    open LinRewiring finOpLinRewiring using (<_×_>; _⁏_)
    dup : ∀ {A} → A `→ (A `× A)
    dup {A} x with Fin.cmp A A x
    dup    ._ | Fin.bound y = y
    dup    ._ | Fin.free  y = y

Add FunUniverse/Fin/Op.agda

Add FunUniverse/Fin/Op.agda


module NormalizationByEvaluation where

-- NORMALIZATION BY EVALUATION
--
-- for the simply-typed λ calculus with base types

open import Level hiding (Lift; lift)
open import Data.Bool

open import Relation.Binary hiding (_⇒_)

-- The rest of this file is parametric in the set of base types.

module Parametric (Base : Set) where

  -- SYNTAX OF TYPES
  --
  -- We support function types and base types.

  data Type : Set where
    _⇒_ : (τ₁ τ₂ : Type) → Type
    base : (b : Base) → Type

  open import Syntactic.Contexts Type public

  -- DOMAIN CONSTRUCTION
  --
  -- The meaning of types is defined using Kripke structures.

  record IsKripke {w ℓ₁ ℓ₂} {World : Set w}
                  (_≈_ : Rel World ℓ₁)
                  (_≤_ : Rel World ℓ₂)
                  (_⊩⟦_⟧Base : World → Base → Set (ℓ₂ ⊔ w))
                  : Set (w ⊔ ℓ₁ ⊔ ℓ₂) where
    Lift : ∀ {A : Set} (_⊩⟦_⟧ : World → A → Set (ℓ₂ ⊔ w)) → Set (ℓ₂ ⊔ w)
    Lift _⊩⟦_⟧ = ∀ {a w₁ w₂} → w₁ ≤ w₂ → w₁ ⊩⟦ a ⟧ → w₂ ⊩⟦ a ⟧

    field
      isPreorder : IsPreorder _≈_ _≤_
      liftBase : Lift _⊩⟦_⟧Base

    open IsPreorder isPreorder public

    _⊩⟦_⟧Type : World → Type → Set (ℓ₂ ⊔ w)
    w₁ ⊩⟦ τ₁ ⇒ τ₂ ⟧Type = ∀ {w₂} → w₁ ≤ w₂ → w₂ ⊩⟦ τ₁ ⟧Type → w₂ ⊩⟦ τ₂ ⟧Type
    w₁ ⊩⟦ base b ⟧Type = w₁ ⊩⟦ b ⟧Base

    liftType : Lift _⊩⟦_⟧Type
    liftType {τ₁ ⇒ τ₂} w₁≤w₂ w₁⊩τ₁⇒τ₂ = λ w₂≤w₃ w₃⊩τ₁ → w₁⊩τ₁⇒τ₂ (trans w₁≤w₂ w₂≤w₃) w₃⊩τ₁
    liftType {base b} w₁≤w₂ w₁⊩b = liftBase w₁≤w₂ w₁⊩b

    module _ (w : World) where
      open import Denotational.Environments Type (λ τ → w ⊩⟦ τ ⟧Type) public
        renaming (⟦_⟧Context to _⊩⟦_⟧Context; ⟦_⟧Var to _⊩⟦_⟧Var)

    liftContext : Lift {Context} _⊩⟦_⟧Context
    liftContext {∅} w₁≤w₂ w₁⊩Γ = ∅
    liftContext {τ • Γ} w₁≤w₂ (w₁⊩τ • w₁⊩Γ) = liftType {τ} w₁≤w₂ w₁⊩τ • liftContext w₁≤w₂ w₁⊩Γ

  record Kripke w ℓ₁ ℓ₂ : Set (suc (w ⊔ ℓ₁ ⊔ ℓ₂)) where
    field
      World : Set w
      _≈_ : Rel World ℓ₁
      _≤_ : Rel World ℓ₂
      _⊩⟦_⟧Base : World → Base → Set (ℓ₂ ⊔ w)
      isKripke : IsKripke _≈_ _≤_ _⊩⟦_⟧Base

    open IsKripke isKripke public

  -- TERMS
  --
  -- The syntax of terms is parametric in the set of constants.

  module Terms (Constant : Type → Set) where
    data Term : Context → Type → Set where
      abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
      app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
      var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ
      con : ∀ {Γ τ} → (c : Constant τ) → Term Γ τ

    weaken : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Term Γ₁ τ → Term Γ₂ τ
    weaken Γ₁≼Γ₂ (abs t) = abs (weaken (keep _ • Γ₁≼Γ₂) t)
    weaken Γ₁≼Γ₂ (app t₁ t₂) = app (weaken Γ₁≼Γ₂ t₁) (weaken Γ₁≼Γ₂ t₂)
    weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
    weaken Γ₁≼Γ₂ (con c) = con c

  -- SYMBOLIC EXECUTION and REIFICATION
  --
  -- The Kripke structure of symbolic computation, using typing
  -- contexts as worlds. Base types are interpreted as
  -- terms. This is parametric in the set of available constants.

  module Symbolic (Constant : Type → Set) where
    open import Relation.Binary.PropositionalEquality
    open Terms Constant

    BaseTerm : Context → Base → Set
    BaseTerm Γ b = Term Γ (base b)

    isKripke : IsKripke _≡_ _≼_ BaseTerm
    isKripke = record {
      isPreorder = ≼-isPreorder;
      liftBase = weaken }

    symbolic : Kripke zero zero zero
    symbolic = record {
      World = Context;
      _≈_ = _≡_;
      _≤_ = _≼_;
      _⊩⟦_⟧Base = BaseTerm;
      isKripke = isKripke }

    open Kripke symbolic

    ↓ : ∀ {Γ} τ → Γ ⊩⟦ τ ⟧Type → Term Γ τ
    ↑ : ∀ {Γ} τ → Term Γ τ → Γ ⊩⟦ τ ⟧Type

    ↓ (τ₁ ⇒ τ₂) v = abs (↓ τ₂ (v (drop τ₁ • ≼-refl) (↑ τ₁ (var this))))
    ↓ (base b) v = v

    ↑ (τ₁ ⇒ τ₂) t = λ Γ₁≼Γ₂ v → ↑ τ₂ (app (weaken Γ₁≼Γ₂ t) (↓ τ₁ v))
    ↑ (base b) t = t

    Γ⊩Γ : ∀ {Γ} → Γ ⊩⟦ Γ ⟧Context
    Γ⊩Γ {∅} = ∅
    Γ⊩Γ {τ • Γ} = ↑ τ (var this) • liftContext (drop τ • ≼-refl) Γ⊩Γ

  -- EVALUATION
  --
  -- Evaluation is defined for every Kripke structure and every
  -- set of constants. We have to provide the interpretation of
  -- the constants in the choosen Kripke structure, though.
  module _ {w ℓ₁ ℓ₂} (K : Kripke w ℓ₁ ℓ₂) where
    open Kripke K

    module Evaluation (Constant : Type → Set)
                      (_⊩⟦_⟧Constant : ∀ w {τ} → Constant τ → w ⊩⟦ τ ⟧Type) where
      open Terms Constant

      _⊩⟦_⟧Term_ : ∀ w {Γ τ} → Term Γ τ → w ⊩⟦ Γ ⟧Context → w ⊩⟦ τ ⟧Type
      w₁ ⊩⟦ abs t ⟧Term w₁⊩Γ = λ {w₂} w₁≤w₂ w₂⊩τ₁ → w₂ ⊩⟦ t ⟧Term (w₂⊩τ₁ • liftContext w₁≤w₂ w₁⊩Γ)
      w₁ ⊩⟦ app t₁ t₂ ⟧Term w₁⊩Γ = (w₁ ⊩⟦ t₁ ⟧Term w₁⊩Γ) refl (w₁ ⊩⟦ t₂ ⟧Term w₁⊩Γ)
      w₁ ⊩⟦ var x ⟧Term w₁⊩Γ = (w₁ ⊩⟦ x ⟧Var) w₁⊩Γ
      w₁ ⊩⟦ con c ⟧Term w₁⊩Γ = w₁ ⊩⟦ c ⟧Constant

  -- NORMALIZATION
  --
  -- Given a set of constants and their interpretation in the
  -- Kripke structure for symbolic computation, we can normalize
  -- terms.

  module _ (Constant : Type → Set) where
    open Terms Constant
    open Symbolic Constant
    open Kripke symbolic

    module Normalization (_⊩⟦_⟧Constant : ∀ Γ {τ} → Constant τ → Γ ⊩⟦ τ ⟧Type) where
      open Evaluation symbolic Constant _⊩⟦_⟧Constant

      norm : ∀ {Γ τ} → Term Γ τ → Term Γ τ
      norm {Γ} {τ} t = ↓ τ (Γ ⊩⟦ t ⟧Term Γ⊩Γ)

Implement NbE for lambda calculus with base types (see #50).

Old-commit-hash: 26dd0dee4e73552fe51a52999922812354a03188


open import Type
open import Data.Nat.NP
open import Data.Bool using (if_then_else_)
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Function.NP hiding (id)
open import FunUniverse.Core hiding (_,_)
open import Data.Fin using (Fin; zero; suc; #_; inject+; raise) renaming (toℕ to Fin▹ℕ)

module adder where

module FunAdder
  {t}
  {T : ★_ t}
  {funU : FunUniverse T}
  (funOps : FunOps funU)
  where

    open FunUniverse funU renaming (`⊤ to `𝟙; `Bit to `𝟚)
    open FunOps funOps renaming (_∘_ to _`∘_)

    open import Solver.Linear

    module LinSolver = Syntaxᶠ linRewiring

    --iter : ∀ {n A B S} → (S `× A `→ S `× B) → S `× `Vec A n `→ `Vec B n

    iter : ∀ {n A B C D} → (D `× A `× B `→ D `× C) → D `× `Vec A n `× `Vec B n `→ `Vec C n
    iter {zero}  F = <[]>
    iter {suc n} F = < id × < uncons × uncons > >
                  ⁏ (helper ⁏ < F ⁏ swap × id > ⁏ assoc ⁏ < id × iter F >)
                  ⁏ <∷>

      where
        open LinSolver
        helper = λ {A} {B} {D} {VA} {VB} →
          rewireᶠ (A ∷ B ∷ D ∷ VA ∷ VB ∷ [])
                  (λ a b d va vb → (d , (a , va) , (b , vb)) ↦ (d , a , b) , (va , vb))

    -- TODO reverses all over the places... switch to lsb first?

    adder : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
    adder = <tt⁏ <0b> , < reverse × reverse > > ⁏ iter full-adder ⁏ reverse

    open import Data.Digit

    bits : ∀ ℓ → ℕ → `𝟙 `→ `Bits ℓ
    bits ℓ n₀ = constBits (V.reverse (L▹V (L.map F▹𝟚 (proj₁ (toDigits 2 n₀)))))
      where open import Data.List as L
            open import Data.Product
            open import Data.Two
            L▹V : ∀ {n} → List 𝟚 → Vec 𝟚 n
            L▹V {zero} xs = []
            L▹V {suc n} [] = V.replicate 0'
            L▹V {suc n} (x ∷ xs) = x ∷ L▹V xs
            F▹𝟚 : Fin 2 → 𝟚
            F▹𝟚 zero    = 0'
            F▹𝟚 (suc _) = 1'

open import IO
import IO.Primitive
open import Data.One
open import Data.Two
open import Data.Product
open import Coinduction
open import FunUniverse.Agda
open FunAdder agdaFunOps
open FunOps agdaFunOps
putBit : 𝟚 → IO 𝟙
putBit 1' = putStr "1"
putBit 0' = putStr "0"
putBits : ∀ {n} → Vec 𝟚 n → IO 𝟙
putBits [] = return _
putBits (x ∷ bs) = ♯ putBit x >> ♯ putBits bs
arg1   = bits 8 0x0b _
arg2   = bits 8 0x1f _
result = adder (arg1 , arg2)
mainIO : IO 𝟙
mainIO = ♯ putBits arg1 >>
      ♯ (♯ putStr " + " >>
      ♯ (♯ putBits arg2 >>
      ♯ (♯ putStr " = " >>
         ♯ putBits result)))
main : IO.Primitive.IO 𝟙
main = IO.run mainIO

add a "simple" circuit adder capable of 11+31=42


{-# OPTIONS --without-K #-}
module Data.Nat.Primality.NP where

open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Nat.Divisibility.NP
open import Data.Nat.Primality public
  hiding (prime?) -- was slow

open import Data.Fin.Dec
open import Relation.Unary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Negation
open import Relation.Nullary

-- same code but imports the fast _∣?_
prime? : Decidable Prime
prime? 0             = no λ()
prime? 1             = no λ()
prime? (suc (suc n)) = all? λ _ → ¬? (_ ∣? _)

prime-≥2 : ∀ {n} → Prime n → n ≥ 2
prime-≥2 {0}    ()
prime-≥2 {1}    ()
prime-≥2 {2+ _} _ = s≤s (s≤s z≤n)

prime-≢0 : ∀ {n} → Prime n → n ≢ 0
prime-≢0 {0}    () _
prime-≢0 {1+ _} _  ()

prime-≢1 : ∀ {n} → Prime n → n ≢ 1
prime-≢1 {0}    () _
prime-≢1 {1}    () _
prime-≢1 {2+ _} _  ()

Add Nat.Primality.NP

Add Nat.Primality.NP


{-# OPTIONS --without-K #-}
open import Type.Param.Binary
open import Data.Unit renaming (⊤ to 𝟙; tt to 0₁)

module Data.One.Param.Binary where

record ⟦𝟙⟧ (x₁ x₂ : 𝟙) : Set₀ where
  constructor ⟦0₁⟧

Add Data.One.Param.Binary

Add Data.One.Param.Binary


{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq using (Eq?; _==_; ≡⇒==; ==⇒≡)
open import Data.Product.NP using (_×_; _,_; fst; snd; map)
open import Data.Bit using (Bit; 0b; 1b; proj′; ✓→≡; ≡→✓)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

module Crypto.Sig.Lamport.OneBit.Abstract
          (Secret : Type)
          (Digest : Type)
          (hash   : Secret → Digest)
          (eq?    : Eq? Digest)
          where

SignKey    = Secret × Secret
Signature  = Secret
VerifKey   = Digest × Digest

module signkey (sk : SignKey) where
  skL = fst sk
  skH = snd sk
  vkL = hash skL
  vkH = hash skH

-- Derive the public key by hashing each secret
verif-key : SignKey → VerifKey
verif-key sk = vkL , vkH
  where open signkey sk

module verifkey (vk : VerifKey) where
  vkL = fst vk
  vkH = snd vk

-- Key generation
key-gen : SignKey → VerifKey × SignKey
key-gen sk = vk , sk
  module key-gen where
    vk = verif-key sk

-- Sign a single bit message
sign : SignKey → Bit → Signature
sign = proj′

-- Verify the signature of a single bit message
verify : VerifKey → Bit → Signature → Bit
verify vk b sig = proj′ vk b == hash sig

verify-correct-sig : ∀ sk b → verify (verif-key sk) b (sign sk b) ≡ 1b
verify-correct-sig sk 0b = ✓→≡ (≡⇒== (hash (fst sk) ∎))
verify-correct-sig sk 1b = ✓→≡ (≡⇒== (hash (snd sk) ∎))

import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits

module Assuming-injectivity (hash-inj : Injective hash) where

  -- If one considers the hash function injective, then, so is verif-key
  verif-key-inj : ∀ {sk1 sk2} → verif-key sk1 ≡ verif-key sk2 → sk1 ≡ sk2
  verif-key-inj {sk1} {sk2} e
    = ap₂ _,_ (hash-inj (ap fst e)) (hash-inj (ap snd e))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2

  -- Therefor under this assumption, different secret keys means different public keys
  verif-key-corrolary : ∀ {sk1 sk2} → sk1 ≢ sk2 → verif-key sk1 ≢ verif-key sk2
  verif-key-corrolary {sk1} {sk2} sk≢ vk= = sk≢ (verif-key-inj vk=)

  -- If one considers the hash function injective then there is
  -- only one signing key which can sign correctly all (0 and 1)
  -- the messages
  signkey-uniqness :
        ∀ sk1 sk2 →
          (∀ b → verify (verif-key sk1) b (sign sk2 b) ≡ 1b) →
          sk1 ≡ sk2
  signkey-uniqness sk1 sk2 e
    = ap₂ _,_ (hash-inj (==⇒≡ (≡→✓ (e 0b))))
              (hash-inj (==⇒≡ (≡→✓ (e 1b))))

module Assuming-invertibility
         (unhash : Digest → Secret)
         (unhash-hash : ∀ x → unhash (hash x) ≡ x)
         (hash-unhash : ∀ x → hash (unhash x) ≡ x)
         where

  -- EXERCISES
  {-
  recover-signkey : VerifKey → SignKey
  recover-signkey = {!!}

  recover-signkey-correct : ∀ sk → recover-signkey (verif-key sk) ≡ sk
  recover-signkey-correct = {!!}

  forgesig : VerifKey → Bit → Signature
  forgesig = {!!}

  forgesig-correct : ∀ vk b → verify vk b (forgesig vk b) ≡ 1b
  forgesig-correct = {!!}
  -}

-- -}

Add Crypto.Sig.Lamport.OneBit.Abstract

Add Crypto.Sig.Lamport.OneBit.Abstract


open import Data.Product

module FunUniverse.Nand.Function where

module FromNand {A} (nand : A × A → A) where

    open import FunUniverse.Agda
    open import FunUniverse.Nand (Abstract𝟚.funRewiring A)

    open FromNand nand public

open import Data.Two

module Nand𝟚 = FromNand (uncurry nand)

open import Data.Tree.Binary

module NandTree {A} = FromNand {BinTree A} (uncurry fork)

Add FunUniverse/Nand/Function.agda

Add FunUniverse/Nand/Function.agda


module SemiRingRecord where

import Algebra.FunctionProperties
  using (LeftIdentity; RightIdentity)
import Function using (_on_)
import Relation.Binary.EqReasoning as EqReasoning
import Relation.Binary.On using (isEquivalence)
import Algebra.Structures using (module IsCommutativeMonoid; IsCommutativeMonoid)
open import Relation.Binary
  using (module IsEquivalence; IsEquivalence; _Preserves₂_⟶_⟶_ ; Setoid)
open import Data.Product renaming (_,_ to _,,_) -- just to avoid clash with other commas

open import Preliminaries

open import SemiNearRingRecord

record SemiRing : Set₁ where
  field
    snr : SemiNearRing

  open SemiNearRing snr

  field
    1s : s

  open Algebra.FunctionProperties _≃s_ using (LeftIdentity; RightIdentity)

  field
    ∙-identityl : LeftIdentity 1s _∙s_
    ∙-identityr : RightIdentity 1s _∙s_

Add SemiRing

Add SemiRing


{-
  On the one hand this module has nothing to do with JS, on the other
  hand our JS binding relies on this particular type definition.
-}
module Control.Process.Type where

open import Data.String.Base using (String)

data Proc (C {-channels-} : Set₀) (M {-messages-} : Set₀) : Set₀ where
  end   : Proc C M
  send  : (d : C) (m : M) (p : Proc C M) → Proc C M
  recv  : (d : C) (p : M → Proc C M) → Proc C M
  spawn : (p : C → Proc C M)
          (q : C → Proc C M) → Proc C M
  error : (err : String) → Proc C M

Add Control.Process.Type

Add Control.Process.Type


-- Implements ℤq with Data.Fin
open import Type
open import Data.Nat
open import Data.Fin.NP as Fin
open import Relation.Binary.PropositionalEquality

open import Explore.Type
open import Explore.Explorable

open Fin.Modulo renaming (sucmod to [suc]; sucmod-inj to [suc]-inj)

module FiniteField.FinImplem (q-1 : ℕ) ([0]' [1]' : Fin (suc q-1)) where
  -- open Sum
  q : ℕ
  q = suc q-1

  ℤq : ★
  ℤq = Fin q

  μℤq : Explorable ℤq
  μℤq = {!μFinSuc q-1!}

  sumℤq : Sum ℤq
  sumℤq = sum μℤq

  [0] : ℤq
  [0] = [0]'

  [1] : ℤq
  [1] = [1]'

  [suc]-stable : SumStableUnder (sum μℤq) [suc]
  [suc]-stable = {!μFinSUI [suc] [suc]-inj!}

  _ℕ⊞_ : ℕ → ℤq → ℤq
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = m ℕ⊞ ([suc] n)

  ℕ⊞-inj : ∀ n {x y} → n ℕ⊞ x ≡ n ℕ⊞ y → x ≡ y
  ℕ⊞-inj zero    eq = eq
  ℕ⊞-inj (suc n) eq = [suc]-inj (ℕ⊞-inj n eq)

  ℕ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_ℕ⊞_ m)
  ℕ⊞-stable m = {!μFinSUI (_ℕ⊞_ m) (ℕ⊞-inj m)!}

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin▹ℕ m ℕ⊞ n

  ⊞-inj : ∀ m {x y} → m ⊞ x ≡ m ⊞ y → x ≡ y
  ⊞-inj m = ℕ⊞-inj (Fin▹ℕ m)

  ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_⊞_ m)
  ⊞-stable m = {!μFinSUI (_⊞_ m) (⊞-inj m)!}

  _ℕ⊠_ : ℕ → ℤq → ℤq
  zero  ℕ⊠ n = [0]
  suc m ℕ⊠ n = n ⊞ (m ℕ⊠ n)

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin▹ℕ m ℕ⊠ n

  _[^]ℕ_ : ℤq → ℕ → ℤq
  m [^]ℕ zero  = [1]
  m [^]ℕ suc n = m ⊠ (m [^]ℕ n)

  _[^]_ : ℤq → ℤq → ℤq
  m [^] n = m [^]ℕ (Fin▹ℕ n)

Add FiniteField/FinImplem.agda (unfinished)


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Equivalence
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

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} {{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
    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 true for functions
    -- using changes parametrically, for derivatives and function changes, and
    -- for functions using only the interface to changes (including the fact
    -- that function changes are functions). Stating the general result, though,
    -- seems hard, we should rather have lemmas proving that certain classes of
    -- functions respect this equivalence.

Implement delta-observational equivalence (#244, #299)

This proof shows that delta-observational equivalence is an equivalence
relation.

Known limitations of this commit:
* it does not show that any function respects this relation;
* it does not rephrase existing results;
* this might better belong in Base.Change.Equivalence.

Old-commit-hash: 46789e08b7a8bbd95738f9bf14b3ff8644151772


module meaning where

open import Level

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

open Meaning {{...}} public

Add missing file.

Add missing file.

Forgot to add this file in commit ba1d8a8be0778b4d917c4d98c7db8f78f8f3cbbc.

Old-commit-hash: 02fcec1035aa2e0190d1ba3fc335cecbade97c9b


module New.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Product
open import Postulate.Extensionality

open import New.Changes

module _ {a} {A : Set a} {{CA : ChAlg 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 : Ch A) : 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 a
  ≙-setoid = record
    { Carrier       = Ch A
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

≙-syntax : ∀ {a} {A : Set a} {{CA : ChAlg A}} (x : A) (dx₁ dx₂ : Ch A) → Set a
≙-syntax x dx₁ dx₂ = _≙_ {x = x} dx₁ dx₂
syntax ≙-syntax x dx₁ dx₂ = dx₁ ≙[ x ] dx₂

module BinaryValid
  {A : Set} {{CA : ChAlg A}}
  {B : Set} {{CB : ChAlg B}}
  {C : Set} {{CC : ChAlg C}}
  (f : A → B → C) (df : A → Ch A → B → Ch B → Ch C)
  where
  open import Data.Product

  binary-valid-preserve-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
    → valid (f a b) (df a da b db)

  binary-valid-eq-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
    → (f ⊕ df) (a ⊕ da) (b ⊕ db) ≡ f a b ⊕ df a da b db

  binary-valid :
    binary-valid-preserve-hp →
    binary-valid-eq-hp →
    valid f df
  binary-valid ext-valid proof a da ada =
      (λ b db bdb → ext-valid a da ada b db bdb , lem2 b db bdb)
    , ext lem1
    where
      lem1 : ∀ b → f (a ⊕ da) b ⊕ df (a ⊕ da) (nil (a ⊕ da)) b (nil b) ≡
        f a b ⊕ df a da b (nil b)
      lem1 b
        rewrite sym (update-nil b)
        | proof a da ada b (nil b) (nil-valid b)
        | update-nil b = refl
      lem2 : ∀ b (db : Ch B) (bdb : valid b db) →
        f a (b ⊕ db) ⊕ df a da (b ⊕ db) (nil (b ⊕ db)) ≡
        f a b ⊕ df a da b db
      lem2 b db bdb
        rewrite sym (proof a da ada (b ⊕ db) (nil (b ⊕ db)) (nil-valid (b ⊕ db)))
        | update-nil (b ⊕ db) = proof a da ada b db bdb

module TernaryValid
  {A : Set} {{CA : ChAlg A}}
  {B : Set} {{CB : ChAlg B}}
  {C : Set} {{CC : ChAlg C}}
  {D : Set} {{CD : ChAlg D}}
  (f : A → B → C → D) (df : A → Ch A → B → Ch B → C → Ch C → Ch D)
  where

  ternary-valid-preserve-hp =
    ∀ a da (ada : valid a da)
      b db (bdb : valid b db)
      c dc (cdc : valid c dc)
    → valid (f a b c) (df a da b db c dc)

  -- These are explicit definitions only to speed up typechecking.
  CA→B→C→D : ChAlg (A → B → C → D)
  CA→B→C→D = funCA
  f⊕df = (_⊕_ {{CA→B→C→D}} f df)

  -- Already this definition takes a while to typecheck.
  ternary-valid-eq-hp =
    ∀ a (da : Ch A {{CA}}) (ada : valid {{CA}} a da)
      b (db : Ch B {{CB}}) (bdb : valid {{CB}} b db)
      c (dc : Ch C {{CC}}) (cdc : valid {{CC}} c dc)
    → f⊕df (a ⊕ da) (b ⊕ db) (c ⊕ dc) ≡ f a b c ⊕ df a da b db c dc

  ternary-valid :
    ternary-valid-preserve-hp →
    ternary-valid-eq-hp →
    valid f df
  ternary-valid ext-valid proof a da ada =
    binary-valid
      (λ b db bdb c dc cdc → ext-valid a da ada b db bdb c dc cdc)
      lem2
    , ext (λ b → ext (lem1 b))
    where
      open BinaryValid (f a) (df a da)
      lem1 : ∀ b c → f⊕df (a ⊕ da) b c ≡ (f a ⊕ df a da) b c
      lem1 b c
        rewrite sym (update-nil b)
        | sym (update-nil c)
        |
          proof
            a da ada
            b (nil b) (nil-valid b)
            c (nil c) (nil-valid c)
        | update-nil b
        | update-nil c = refl
        -- rewrite
        --   sym
        --   (proof
        --     (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))
        --     b (nil b) (nil-valid b)
        --     c (nil c) (nil-valid c))
        -- | update-nil (a ⊕ da)
        -- | update-nil b
        -- | update-nil c = {! !}
      lem2 : ∀ b db (bdb : valid b db)
               c dc (cdc : valid c dc) →
                 (f a ⊕ df a da) (b ⊕ db) (c ⊕ dc)
               ≡ f a b c ⊕ df a da b db c dc
      lem2 b db bdb c dc cdc
        rewrite sym
          (proof
            a da ada
            (b ⊕ db) (nil (b ⊕ db)) (nil-valid (b ⊕ db))
            (c ⊕ dc) (nil (c ⊕ dc)) (nil-valid (c ⊕ dc))
          )
        | update-nil (b ⊕ db)
        | update-nil (c ⊕ dc) = proof a da ada b db bdb c dc cdc

Add lemmas to prove function changes valid


-- A traversable functor that is not regular.

open import Data.Nat
open import Data.Vec
open import Data.Product

record Applicative : Set₁ where
  constructor
    appl
  field
    Map   : Set → Set
    pure  : ∀ {A} → A → Map A
    call  : ∀ {A B} → Map (A → B) → Map A → Map B

Traversable : (Set → Set) → Set₁
Traversable F = (G : Applicative) →
                ∀ {A B} → (A → Map G B) → F A → Map G (F B)
  where open Applicative

infixr 10 _^_

-- exponents for naturals
_^_ : ℕ → ℕ → ℕ
m ^ zero = 1
m ^ suc n = m * (m ^ n)

-- a regular container
RegCon : Set → Set
RegCon A = Σ ℕ (Vec A)

-- a regular traversal
regTrav : Traversable RegCon

regTrav G f (0 , []) = pure G ((0 , []))
  where open Applicative

regTrav G f (suc n , x ∷ xs) =
  call G (call G
    (pure G (λ y nys → (suc (proj₁ nys) , y ∷ proj₂ nys)))
    (f x)) (regTrav G f (n , xs))
  where open Applicative

-- a nonregular language: 0, 10, 1100, 111000, ....
nonreg : ℕ → ℕ
nonreg n = let 2n = 2 ^ n in 2n * pred 2n

-- a nonregular finitary container
NonregCon : Set → Set
NonregCon A = Σ ℕ (λ n → Vec A (nonreg n))

fmap : ∀ {A B} (G : Applicative) → (A → B) →
       let open Applicative in Map G A → Map G B
fmap G f gx = call G (pure G f) gx
  where open Applicative

-- a nonregular traversable functor
nonregTrav : Traversable NonregCon
nonregTrav G f (n , xs) =
  let
    gnnys = regTrav G f ((nonreg n , xs))
  in
    fmap G (λ{(nn , ys) → (n , {!ys!})}) gnnys
    -- should be well-typed but is not

add example of non-regular traversable functor


-- This module is an example of the use of the circuit building library.
-- The point is to start with a tiny bytecode evaluator for bit operations.
module bytecode where

open import Function
open import Data.Nat
open import Data.Vec
open import Data.Product.NP
open import Data.Bits
open import Data.Bool
open import Algebra.FunctionProperties

data I : ℕ → Set where
  `[]  : I 1
  `op₀ : ∀ {i} (b : Bit) (is : I (1 + i)) → I i
  `op₁ : ∀ {i} (op₁ : Op₁ Bit) (is : I (1 + i)) → I (1 + i)
  `op₂ : ∀ {i} (op₂ : Op₂ Bit) (is : I (1 + i)) → I (2 + i)

eval : ∀ {i} → I i → Bits i → Bit
eval `[] (x ∷ []) = x
eval (`op₀ b is) st = eval is (b ∷ st)
eval (`op₁ op₁ is) (b ∷ st) = eval is (op₁ b ∷ st)
eval (`op₂ op₂ is) (b₀ ∷ b₁ ∷ st) = eval is (op₂ b₀ b₁ ∷ st)

eval₀ : I 0 → Bit
eval₀ i₀ = eval i₀ []

open import circuit

module Ck {C} (cb : CircuitBuilder C) where
  open CircuitBuilder cb

  data IC : ℕ → Set where
    `[] : IC 1
    `op : ∀ {i ki ko} (op : C ki ko) (is : IC (ko + i)) → IC (ki + i)

  module Eval (runC : RunCircuit C) where
    module CF = CircuitBuilder bitsFunCircuitBuilder
    ckIC : ∀ {i} → IC i → C i 1
    ckIC `[]         = idC
    ckIC (`op op is) = op *** idC >>> ckIC is

    evalIC : ∀ {i} → IC i → Bits i → Bit
    evalIC is bs = head (runC (ckIC is) bs)

  ck : ∀ {i} → I i → C i 1
  ck `[]           = idC
  ck (`op₀ b   is) = bit b *** idC >>> ck is
  ck (`op₁ op₁ is) = unOp op₁ *** idC >>> ck is
  ck (`op₂ op₂ is) = binOp op₂ *** idC >>> ck is

  I2IC : ∀ {i} → I i → IC i
  I2IC `[] = `[]
  I2IC (`op₀ b is) = `op (bit b) (I2IC is)
  I2IC (`op₁ op₁ is) = `op (unOp op₁) (I2IC is)
  I2IC (`op₂ op₂ is) = `op (binOp op₂) (I2IC is)

  ck₀ : I 0 → C 0 1
  ck₀ = ck

module CheckCk where
  open Ck bitsFunCircuitBuilder
  open CircuitBuilder bitsFunCircuitBuilder
  open import Relation.Binary.PropositionalEquality

  ck-eval : ∀ {i} (is : I i) bs → ck is bs ≡ eval is bs ∷ []
  ck-eval `[] (x ∷ []) = refl
  ck-eval (`op₀ b is) bs = ck-eval is (b ∷ bs)
  ck-eval (`op₁ op₁ is) (b ∷ bs) = ck-eval is (op₁ b ∷ bs)
  ck-eval (`op₂ op₂ is) (b₀ ∷ b₁ ∷ bs) = ck-eval is (op₂ b₀ b₁ ∷ bs)

Add bytecode.agda to experiment with circuits


open import Type                 using (Type)
open import Data.Bool.Base       using (Bool; true)
open import Relation.Binary.Core using (_≡_; _≢_)

-- This module assumes the exact statement of the Zero-Knowledge proof to be
-- known by all parties.
module ZK.SigmaProtocol.KnownStatement
          (Commitment : Type) -- Prover commitments
          (Challenge  : Type) -- Verifier challenges, picked at random
          (Response   : Type) -- Prover responses/proofs to challenges
          (Randomness : Type) -- Prover's randomness
          (Witness    : Type) -- Prover's witness
          (ValidWitness : Witness → Type) -- Valid witness for the statement
       where

-- The prover is made of two steps.
-- * First, send the commitment.
-- * Second, receive a challenge and send back the response.
--
-- Therefor one represents a prover as a pair (a record) made
-- of a commitment (get-A) and a function (get-f) from challenges
-- to responses.
--
-- Note that one might wish the function get-f to be partial.
--
-- This covers any kind of prover, either honest or dishonest
-- Notice as well that such should depend on some randomness.
-- So such a prover as type: SomeRandomness → Prover
record Prover-Interaction : Type where
  constructor _,_
  field
    get-A : Commitment
    get-f : Challenge → Response

Prover : Type
Prover = (r : Randomness)(w : Witness) → Prover-Interaction

-- A transcript of the interaction between the prover and the
-- verifier.
--
-- Note that in the case of an interactive zero-knowledge
-- proof the transcript alone does not prove anything. It can usually
-- be simulated if one knows the challenge before the commitment.
--
-- The only way to be convinced by an interactive prover is to be/trust the verifier,
-- namely to receive the commitment first and send a randomly picked challenge
-- thereafter. So the proof is not transferable.
--
-- The other way is by making the zero-knowledge proof non-interactive, which forces the
-- challenge to be a cryptographic hash of the commitment and the statement.
-- See the StrongFiatShamir module and the corresponding paper for more details.
record Transcript : Type where
  constructor mk
  field
    get-A : Commitment
    get-c : Challenge
    get-f : Response

-- The actual behavior of an interactive verifier is as follows:
-- * Given a statement
-- * Receive a commitment from the prover
-- * Send a randomly chosen challenge to the prover
-- * Receive a response to that challenge
-- Since the first two points are common to all Σ-protocols we describe
-- the verifier behavior as a computable test on the transcript.
Verifier : Type
Verifier = (t : Transcript) → Bool

-- To run the interaction, one only needs the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover-Interaction → Challenge → Transcript
run (A , f) c = mk A c (f c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

  Verified : (t : Transcript) → Type
  Verified t = verifier t ≡ true

-- Correctness (also called completeness in some papers): a Σ-protocol is said
-- to be correct if for any challenge, the (honest) verifier accepts what
-- the (honest) prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ r {w} c → ValidWitness w → verifier (run (prover r w) c) ≡ true

-- A simulator takes a challenge and a response and returns a commitment.
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ c s → let A = simulator c s in
            verifier (mk A c s) ≡ true

{-
  A Σ-protocol, more specifically a verifier which is equipped with
  a correct simulator is said to be Special Honest Verifier Zero Knowledge.
  This property is one of the condition to apply the Strong Fiat Shamir
  transformation.

  The Special part of Special-Honest-Verifier-Zero-Knowledge is covered by the
  simulator being correct.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if the challenge c and response s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the (honest) prover and the (honest) verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator         : Simulator
    correct-simulator : Correct-simulator verifier simulator

-- A pair of "Transcript"s such that the commitment is shared
-- and the challenges are different.
record Transcript² (verifier : Verifier) : Type where
  constructor mk
  field
    -- The commitment is shared
    get-A         : Commitment

    -- The challenges...
    get-c₀ get-c₁ : Challenge

    -- ...are different
    c₀≢c₁         : get-c₀ ≢ get-c₁

    -- The responses/proofs are arbitrary
    get-f₀ get-f₁ : Response

  -- The two transcripts
  t₀ : Transcript
  t₀ = mk get-A get-c₀ get-f₀
  t₁ : Transcript
  t₁ = mk get-A get-c₁ get-f₁

  field
    -- The transcripts verify
    verify₀ : verifier t₀ ≡ true
    verify₁ : verifier t₁ ≡ true

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = Transcript² verifier → Witness

Extract-Valid-Witness : (verifier : Verifier) → Extractor verifier → Type
Extract-Valid-Witness verifier extractor = ∀ t² → ValidWitness (extractor t²)

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct extractor is said to have the Special Soundness property.
-- This property is one of the condition to apply the Strong Fiat Shamir
-- transformation.
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
  -- TODO Challenge should exp large wrt the security param
    extractor             : Extractor verifier
    extract-valid-witness : Extract-Valid-Witness verifier extractor

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public

Add ZK.SigmaProtocol.KnowStatement

Add ZK.SigmaProtocol.KnowStatement


{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
open import Function
module Spire.Examples.CompLev where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Branches : (E : Enum) (P : Tag E → Set) → Set
Branches [] P = ⊤
Branches (l ∷ E) P = P here × Branches E (λ t → P (there t))

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Tel : Set where
  End : Tel
  Arg : (A : Set) (B : A → Tel) → Tel

Elᵀ  : Tel → Set
Elᵀ End = ⊤
Elᵀ (Arg A B) = Σ A (λ a → Elᵀ (B a))

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

data Desc (I : Set) : Set where
  End : Desc I
  Rec : (i : I) (D : Desc I) → Desc I
  RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I
  Arg : (A : Set) (B : A → Desc I) → Desc I

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

ISet : Set → Set
ISet I = I → Set

Elᴰ : {I : Set} (D : Desc I) → ISet I → Set
Elᴰ End X = ⊤
Elᴰ (Rec j D) X = X j × Elᴰ D X
Elᴰ (RecFun A B D) X = ((a : A) → X (B a)) × Elᴰ D X
Elᴰ (Arg A B) X = Σ A (λ a → Elᴰ (B a) X)

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (xs : Elᴰ D X) → Set
Hyps End X P tt = ⊤
Hyps (Rec i D) X P (x , xs) = P i x × Hyps D X P xs
Hyps (RecFun A B D) X P (f , xs) = ((a : A) → P (B a) (f a)) × Hyps D X P xs
Hyps (Arg A B) X P (a , xs) = Hyps (B a) X P xs

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

data μ {I : Set} (R : I → Desc I) (i : I) : Set where
  init : Elᴰ (R i) (μ R) → μ R i

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

ind : {I : Set} (R : I → Desc I)
  (M : (i : I) → μ R i → Set)
  (α : ∀ i (xs : Elᴰ (R i) (μ R)) (ihs : Hyps (R i) (μ R) M xs) → M i (init xs))
  (i : I)
  (x : μ R i)
  → M i x

prove : {I : Set} (D : Desc I) (R : I → Desc I)
  (M : (i : I) → μ R i → Set)
  (α : ∀ i (xs : Elᴰ (R i) (μ R)) (ihs : Hyps (R i) (μ R) M xs) → M i (init xs))
  (xs : Elᴰ D (μ R)) → Hyps D (μ R) M xs

ind R M α i (init xs) = α i xs (prove (R i) R M α xs)

prove End R M α tt = tt
prove (Rec j D) R M α (x , xs) = ind R M α j x , prove D R M α xs
prove (RecFun A B D) R M α (f , xs) = (λ a → ind R M α (B a) (f a)) , prove D R M α xs
prove (Arg A B) R M α (a , xs) = prove (B a) R M α xs

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

DescE : Enum
DescE = "End" ∷ "Rec" ∷ "Arg" ∷ []

DescT : Set
DescT = Tag DescE

-- EndT : DescT
pattern EndT = here

-- RecT : DescT
pattern RecT = there here

-- ArgT : DescT
pattern ArgT = there (there here)

DescR : Set → ⊤ → Desc ⊤
DescR I tt = Arg (Tag DescE)
  (case (λ _ → Desc ⊤) (
      (Arg I λ i → End)
    , (Arg I λ i → Rec tt End)
    , (Arg Set λ A → RecFun A (λ a → tt) End)
    , tt
  ))

`Desc : (I : Set) → Set
`Desc I = μ (DescR I) tt

-- `End : {I : Set} (i : I) → `Desc I
pattern `End i = init (EndT , i , tt)

-- `Rec : {I : Set} (i : I) (D : `Desc I) → `Desc I
pattern `Rec i D = init (RecT , i , D , tt)

-- `Arg : {I : Set} (A : Set) (B : A → `Desc I) → `Desc I
pattern `Arg A B = init (ArgT , A , B , tt)

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

FixI : (I : Set) → Set
FixI I = I × `Desc I

FixR' : (I : Set) (D : `Desc I) → I → `Desc I → Desc (FixI I)
FixR' I D i (`End j) = Arg (j ≡ i) λ q → End
FixR' I D i (`Rec j E) = Rec (j , D) (FixR' I D i E)
FixR' I D i (`Arg A B) = Arg A λ a → FixR' I D i (B a)
FixR' I D i (init (there (there (there ())) , xs))

FixR : (I : Set) (D : `Desc I) → FixI I → Desc (FixI I)
FixR I D E,i = FixR' I D (proj₁ E,i) (proj₂ E,i)

`Fix : (I : Set) (D : `Desc I) (i : I) → Set
`Fix I D i = μ (FixR I D) (i , D)

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

Fix internalized as a computational description.

The idea is that the core could have computatial descriptions,
which do not mention things like which arguments are implicit,
and Desc can be internalized as a description like the current
primitive (non-computational) description that also mentions
which arguments are implicit. Then you can define the fixpoint
of that description as a computational description, parameterized
by (I : Set) (D : DescI) and indexed by (i : I) (E : Desc I).

It's cool that you can do this but I think it's one step too far
in the direction of making the core type theory simple in exchange
for more complicated derivable programs.

If anything, defining `Desc, making an interpretation function for
it, along with a toDesc function might be okay. But, again I think
defining `Fix is probably not worthwhile.


module Language.Greek where

data Maybe A : Set where
  none : Maybe A
  just : A → Maybe A

data Unicode : Set where
  Α Β Γ Δ Ε Ζ Η Θ Ι Κ Λ Μ Ν Ξ Ο Π Ρ Σ Τ Υ Φ Χ Ψ Ω α β γ δ ε ζ η θ ι κ λ′ μ ν ξ ο π ρ σ ς τ υ φ χ ψ ω : Unicode
  grave acute diaeresis smooth rough circumflex iotaSubscript : Unicode

postulate
  Char : Set

{-# BUILTIN CHAR Char #-}
{-# COMPILED_TYPE Char Char #-}

charToUnicode : Char -> Maybe Unicode
charToUnicode 'Α' = just Α
charToUnicode 'Β' = just Β
charToUnicode 'Γ' = just Γ
charToUnicode 'Δ' = just Δ
charToUnicode 'Ε' = just Ε
charToUnicode 'Ζ' = just Ζ
charToUnicode 'Η' = just Η
charToUnicode 'Θ' = just Θ
charToUnicode 'Ι' = just Ι
charToUnicode 'Κ' = just Κ
charToUnicode 'Λ' = just Λ
charToUnicode 'Μ' = just Μ
charToUnicode 'Ν' = just Ν
charToUnicode 'Ξ' = just Ξ
charToUnicode 'Ο' = just Ο
charToUnicode 'Π' = just Π
charToUnicode 'Ρ' = just Ρ
charToUnicode 'Σ' = just Σ
charToUnicode 'Τ' = just Τ
charToUnicode 'Υ' = just Υ
charToUnicode 'Φ' = just Φ
charToUnicode 'Χ' = just Χ
charToUnicode 'Ψ' = just Ψ
charToUnicode 'Ω' = just Ω
charToUnicode 'α' = just α
charToUnicode 'β' = just β
charToUnicode 'γ' = just γ
charToUnicode 'δ' = just δ
charToUnicode 'ε' = just ε
charToUnicode 'ζ' = just ζ
charToUnicode 'η' = just η
charToUnicode 'θ' = just θ
charToUnicode 'ι' = just ι
charToUnicode 'κ' = just κ
charToUnicode 'λ' = just λ′
charToUnicode 'μ' = just μ
charToUnicode 'ν' = just ν
charToUnicode 'ξ' = just ξ
charToUnicode 'ο' = just ο
charToUnicode 'π' = just π
charToUnicode 'ρ' = just ρ
charToUnicode 'ς' = just ς
charToUnicode 'σ' = just σ
charToUnicode 'τ' = just τ
charToUnicode 'υ' = just υ
charToUnicode 'φ' = just φ
charToUnicode 'χ' = just χ
charToUnicode 'ψ' = just ψ
charToUnicode 'ω' = just ω
charToUnicode '\x0300' = just grave          -- COMBINING GRAVE ACCENT
charToUnicode '\x0301' = just acute          -- COMBINING ACUTE ACCENT
charToUnicode '\x0308' = just diaeresis      -- COMBINING DIAERESIS
charToUnicode '\x0313' = just smooth         -- COMBINING COMMA ABOVE
charToUnicode '\x0314' = just rough          -- COMBINING REVERSED COMMA ABOVE
charToUnicode '\x0342' = just circumflex     -- COMBINING GREEK PERISPOMENI
charToUnicode '\x0345' = just iotaSubscript  -- COMBINING GREEK YPOGEGRAMMENI
charToUnicode _ = none

data UnicodeCategory : Set where
  letter mark : UnicodeCategory

unicodeToCategory : Unicode → UnicodeCategory
unicodeToCategory Α = letter
unicodeToCategory Β = letter
unicodeToCategory Γ = letter
unicodeToCategory Δ = letter
unicodeToCategory Ε = letter
unicodeToCategory Ζ = letter
unicodeToCategory Η = letter
unicodeToCategory Θ = letter
unicodeToCategory Ι = letter
unicodeToCategory Κ = letter
unicodeToCategory Λ = letter
unicodeToCategory Μ = letter
unicodeToCategory Ν = letter
unicodeToCategory Ξ = letter
unicodeToCategory Ο = letter
unicodeToCategory Π = letter
unicodeToCategory Ρ = letter
unicodeToCategory Σ = letter
unicodeToCategory Τ = letter
unicodeToCategory Υ = letter
unicodeToCategory Φ = letter
unicodeToCategory Χ = letter
unicodeToCategory Ψ = letter
unicodeToCategory Ω = letter
unicodeToCategory α = letter
unicodeToCategory β = letter
unicodeToCategory γ = letter
unicodeToCategory δ = letter
unicodeToCategory ε = letter
unicodeToCategory ζ = letter
unicodeToCategory η = letter
unicodeToCategory θ = letter
unicodeToCategory ι = letter
unicodeToCategory κ = letter
unicodeToCategory λ′ = letter
unicodeToCategory μ = letter
unicodeToCategory ν = letter
unicodeToCategory ξ = letter
unicodeToCategory ο = letter
unicodeToCategory π = letter
unicodeToCategory ρ = letter
unicodeToCategory σ = letter
unicodeToCategory ς = letter
unicodeToCategory τ = letter
unicodeToCategory υ = letter
unicodeToCategory φ = letter
unicodeToCategory χ = letter
unicodeToCategory ψ = letter
unicodeToCategory ω = letter
unicodeToCategory grave = mark
unicodeToCategory acute = mark
unicodeToCategory diaeresis = mark
unicodeToCategory smooth = mark
unicodeToCategory rough = mark
unicodeToCategory circumflex = mark
unicodeToCategory iotaSubscript = mark

data List A : Set where
  [] : List A
  _∷_ : A → List A -> List A

infixr 6 _∷_

foldr : {A B : Set} → (A → B → B) → B → List A → B
foldr f y [] = y
foldr f y (x ∷ xs) = f x (foldr f y xs)

data _And_ : (A : Set) → (B : Set) → Set₁ where
  _and_ : {A B : Set} → A → B → A And B

data ConcreteLetter : Set where
  Α Β Γ Δ Ε Ζ Η Θ Ι Κ Λ Μ Ν Ξ Ο Π Ρ Σ Τ Υ Φ Χ Ψ Ω α β γ δ ε ζ η θ ι κ λ′ μ ν ξ ο π ρ σ ς τ υ φ χ ψ ω : ConcreteLetter

data ConcreteMark : Set where
  grave acute diaeresis smooth rough circumflex iotaSubscript : ConcreteMark

Add an initial start for an Agda model.

Add an initial start for an Agda model.


{-# OPTIONS --without-K #-}
open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Function.Extensionality
open import Data.Product.NP
open import Data.Nat.NP using (ℕ; zero; fold) renaming (suc to 1+)
open import Data.Integer using (ℤ; +_; -[1+_])
open import Algebra.Raw
open import Algebra.Monoid
open import Algebra.Monoid.Commutative
open import Algebra.Group
open import Algebra.Group.Abelian
open import HoTT

module Algebra.Nearring where

record Nearring+1-Struct {ℓ} {A : Set ℓ} (rng-ops : Ring-Ops A) : Set ℓ where
  open Ring-Ops rng-ops

  open ≡-Reasoning

  field
    +-grp-struct : Group-Struct +-grp-ops
    *-mon-struct : Monoid-Struct *-mon-ops
    *-+-distrʳ   : _*_ DistributesOverʳ _+_

  open Additive-Group-Struct +-grp-struct public
  -- 0−-involutive   : Involutive 0−_
  -- cancels-+-left  : LeftCancel _+_
  -- cancels-+-right : RightCancel _+_
  -- ...

  open Multiplicative-Monoid-Struct *-mon-struct public

  open From-Ring-Ops rng-ops
  open From-+Group-1*Identity-DistributesOverʳ
             +-assoc
             0+-identity
             +0-identity
             (snd 0−-inverse)
             1*-identity
             *-+-distrʳ
             public

  +-grp : Group A
  +-grp = +-grp-ops , +-grp-struct

  module +-Grp = Group +-grp

  *-mon : Monoid A
  *-mon = *-mon-ops , *-mon-struct

  module *-Mon = Monoid *-mon

record Nearring+1 {ℓ} (A : Set ℓ) : Set ℓ where
  field
    rng-ops           : Ring-Ops A
    nearring+1-struct : Nearring+1-Struct rng-ops
  open Ring-Ops          rng-ops           public
  open Nearring+1-Struct nearring+1-struct public
-- -}
-- -}
-- -}
-- -}
-- -}

Add Nearring+1

Add Nearring+1


open import FFI.JS hiding (toString)

module FFI.JS.BigI where

abstract
  BigI : Set
  BigI = JSValue

  BigI▹JSValue : BigI → JSValue
  BigI▹JSValue x = x

  unsafe-JSValue▹BigI : BigI → JSValue
  unsafe-JSValue▹BigI x = x

postulate
  bigI     : (x base : String) → BigI
  add      : (x y : BigI) → BigI
  multiply : (x y : BigI) → BigI
  mod      : (x y : BigI) → BigI
  modPow   : (this e m : BigI) → BigI
  modInv   : (this m   : BigI) → BigI
  equals   : (x y : BigI) → Bool
  toString : (x : BigI) → String
  fromHex  : String → BigI
  toHex    : BigI → String

{-# COMPILED_JS bigI       function(x) { return function (y) { return require("bigi")(x,y); }; } #-}
{-# COMPILED_JS add        function(x) { return function (y) { return x.add(y); }; } #-}
{-# COMPILED_JS multiply   function(x) { return function (y) { return x.multiply(y); }; } #-}
{-# COMPILED_JS mod        function(x) { return function (y) { return x.mod(y); }; } #-}
{-# COMPILED_JS modPow     function(x) { return function (y) { return function (z) { return x.modPow(y,z); }; }; } #-}
{-# COMPILED_JS modInv     function(x) { return function (y) { return x.modInverse(y); }; } #-}
{-# COMPILED_JS equals     function(x) { return function (y) { return x.equals(y); }; } #-}
{-# COMPILED_JS toString   function(x) { return x.toString(); } #-}
{-# COMPILED_JS fromHex    require("bigi").fromHex #-}
{-# COMPILED_JS toHex      function(x) { return x.toHex(); } #-}

0I 1I 2I : BigI
0I = bigI "0" "10"
1I = bigI "1" "10"
2I = bigI "2" "10"

Add FFI.JS.BigI

Add FFI.JS.BigI


module Base.Change.Sums where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra
open import Base.Change.Equivalence
open import Postulate.Extensionality
open import Data.Sum

module SumChanges ℓ (X Y : Set ℓ) {{CX : ChangeAlgebra ℓ X}} {{CY : ChangeAlgebra ℓ Y}} where
  open ≡-Reasoning

  data SumChange : X ⊎ Y → Set ℓ where
    ch₁ : ∀ {x} → (dx : Δ x) → SumChange (inj₁ x)
    rp₁₂ : ∀ {x} → (y : Y) → SumChange (inj₁ x)
    ch₂ : ∀ {y} → (dy : Δ y) → SumChange (inj₂ y)
    rp₂₁ : ∀ {y} → (x : X) → SumChange (inj₂ y)

  _⊕_ : (v : X ⊎ Y) → SumChange v → X ⊎ Y
  inj₁ x ⊕ ch₁ dx = inj₁ (x ⊞ dx)
  inj₂ y ⊕ ch₂ dy = inj₂ (y ⊞ dy)
  inj₁ x ⊕ rp₁₂ y = inj₂ y
  inj₂ y ⊕ rp₂₁ x = inj₁ x

  _⊝_ : ∀ (v₂ v₁ : X ⊎ Y) → SumChange v₁
  inj₁ x₂ ⊝ inj₁ x₁ = ch₁ (x₂ ⊟ x₁)
  inj₂ y₂ ⊝ inj₂ y₁ = ch₂ (y₂ ⊟ y₁)
  inj₂ y₂ ⊝ inj₁ x₁ = rp₁₂ y₂
  inj₁ x₂ ⊝ inj₂ y₁ = rp₂₁ x₂

  s-nil : (v : X ⊎ Y) → SumChange v
  s-nil (inj₁ x) = ch₁ (nil x)
  s-nil (inj₂ y) = ch₂ (nil y)

  s-update-diff : ∀ (u v : X ⊎ Y) → v ⊕ (u ⊝ v) ≡ u
  s-update-diff (inj₁ x₂) (inj₁ x₁) = cong inj₁ (update-diff x₂ x₁)
  s-update-diff (inj₂ y₂) (inj₂ y₁) = cong inj₂ (update-diff y₂ y₁)
  s-update-diff (inj₁ x₂) (inj₂ y₁) = refl
  s-update-diff (inj₂ y₂) (inj₁ x₁) = refl

  s-update-nil : ∀ v → v ⊕ (s-nil v) ≡ v
  s-update-nil (inj₁ x) = cong inj₁ (update-nil x)
  s-update-nil (inj₂ y) = cong inj₂ (update-nil y)

  changeAlgebra : ChangeAlgebra ℓ (X ⊎ Y)
  changeAlgebra = record
    { Change = SumChange
    ; update = _⊕_
    ; diff = _⊝_
    ; nil = s-nil
    ; isChangeAlgebra = record
      { update-diff = s-update-diff
      ; update-nil = s-update-nil
      }
    }

  inj₁′ : (x : X) → (dx : Δ x) → Δ (inj₁ x)
  inj₁′ x dx = ch₁ dx

  inj₁′Derivative : Derivative inj₁ inj₁′
  inj₁′Derivative x dx = refl

  inj₂′ : (y : Y) → (dy : Δ y) → Δ (inj₂ y)
  inj₂′ y dy = ch₂ dy

  inj₂′Derivative : Derivative inj₂ inj₂′
  inj₂′Derivative y dy = refl

  -- Elimination form for sums. This is a less dependently-typed version of
  -- [_,_].
  match : ∀ {Z : Set ℓ} → (X → Z) → (Y → Z) → X ⊎ Y → Z
  match f g (inj₁ x) = f x
  match f g (inj₂ y) = g y

  module _ {Z : Set ℓ} {{CZ : ChangeAlgebra ℓ Z}} where
    X→Z = FunctionChanges.changeAlgebra X Z
    --module ΔX→Z = FunctionChanges X Z {{CX}} {{CZ}}
    Y→Z = FunctionChanges.changeAlgebra Y Z
    --module ΔY→Z = FunctionChanges Y Z {{CY}} {{CZ}}
    X⊎Y→Z = FunctionChanges.changeAlgebra (X ⊎ Y) Z
    Y→Z→X⊎Y→Z = FunctionChanges.changeAlgebra (Y → Z) (X ⊎ Y → Z)

    open FunctionChanges using (apply; correct)

    match′₀-realizer : (f : X → Z) → Δ f → (g : Y → Z) → Δ g → (s : X ⊎ Y) → Δ s → Δ (match f g s)
    match′₀-realizer f df g dg (inj₁ x) (ch₁ dx) = apply df x dx
    match′₀-realizer f df g dg (inj₁ x) (rp₁₂ y) = ((g ⊞ dg) y) ⊟ (f x)
    match′₀-realizer f df g dg (inj₂ y) (rp₂₁ x) = ((f ⊞ df) x) ⊟ (g y)
    match′₀-realizer f df g dg (inj₂ y) (ch₂ dy) = apply dg y dy

    match′₀-realizer-correct : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) → (s : X ⊎ Y) → (ds : Δ s) → match f g (s ⊕ ds) ⊞ match′₀-realizer f df g dg (s ⊕ ds) (nil (s ⊕ ds)) ≡ match f g s ⊞ match′₀-realizer f df g dg s ds
    match′₀-realizer-correct f df g dg (inj₁ x) (ch₁ dx) = correct df x dx
    match′₀-realizer-correct f df g dg (inj₂ y) (ch₂ dy) = correct dg y dy
    match′₀-realizer-correct f df g dg (inj₁ x) (rp₁₂ y) rewrite update-diff ((g ⊞ dg) y) (f x) = refl
    match′₀-realizer-correct f df g dg (inj₂ y) (rp₂₁ x) rewrite update-diff ((f ⊞ df) x) (g y) = refl

    match′₀ : (f : X → Z) → Δ f → (g : Y → Z) → Δ g → Δ (match f g)
    match′₀ f df g dg = record { apply = match′₀-realizer f df g dg ; correct = match′₀-realizer-correct f df g dg }

    match′-realizer-correct-body : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) → (s : X ⊎ Y) →
      (match f (g ⊞ dg) ⊞ match′₀ f df (g ⊞ dg) (nil (g ⊞ dg))) s ≡ (match f g ⊞ match′₀ f df g dg) s

    match′-realizer-correct-body f df g dg (inj₁ x) = refl
    -- refl doesn't work here. That seems a *huge* bad smell. However, that's simply because we're only updating g, not f
    match′-realizer-correct-body f df g dg (inj₂ y) rewrite update-nil y = update-diff (g y ⊞ apply dg y (nil y)) (g y ⊞ apply dg y (nil y))

    match′-realizer-correct : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) →
      (match f (g ⊞ dg)) ⊞ match′₀ f df (g ⊞ dg) (nil (g ⊞ dg)) ≡ match f g ⊞ match′₀ f df g dg
    match′-realizer-correct f df g dg = ext (match′-realizer-correct-body f df g dg)
    match′ : (f : X → Z) → Δ f → Δ (match f)
    match′ f df = record { apply = λ g dg → match′₀ f df g dg ; correct = match′-realizer-correct f df }

Implement change structure for sum types


{-# OPTIONS --without-K #-}
open import Function using (_∘_)
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP hiding (map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP
import Crypto.Sig.LamportOneBit

module Crypto.Sig.Lamport
          (#digest  : ℕ)
          (#seed    : ℕ)
          (#secret  : ℕ)
          (#message : ℕ)
          (hash-secret    : Bits #secret → Bits #digest)
          (seed-expansion : Bits #seed   → Bits (#message * 2* #secret))
          where

module OTS1 = Crypto.Sig.LamportOneBit #secret #digest hash-secret

H = hash-secret

#seckey1    = 2* #secret
#pubkey1    = 2* #digest
#signature1 = #secret
#seckey     = #message * #seckey1
#pubkey     = #message * #pubkey1
#signature  = #message * #signature1

Digest     = Bits #digest
Seed       = Bits #seed
Secret     = Bits #secret
SignKey    = Bits #seckey
Message    = Bits #message
Signature  = Bits #signature
VerifKey   = Bits #pubkey

verif-key : SignKey → VerifKey
verif-key = map* #message OTS1.verif-key

module verifkey (vk : VerifKey) where
  vk1s = group #message #pubkey1 vk

module signkey (sk : SignKey) where
  sk1s = group #message #seckey1 sk
  vk   = verif-key sk
  open verifkey vk public

module signature (sig : Signature) where
  sig1s = group #message #signature1 sig

key-gen : Seed → VerifKey × SignKey
key-gen s = vk , sk
  module key-gen where
    sk = seed-expansion s
    vk = verif-key sk

sign : SignKey → Message → Signature
sign sk m = sig
  module sign where
    open signkey sk public
    sig1s = map OTS1.sign sk1s ⊛ m
    sig   = concat sig1s

verify : VerifKey → Message → Signature → Bit
verify vk m sig = and (map OTS1.verify vk1s ⊛ m ⊛ sig1s)
  module verify where
    open verifkey  vk  public
    open signature sig public

verify-correct-sig : ∀ sk m → verify (verif-key sk) m (sign sk m) ≡ 1b
verify-correct-sig = lemma
  where
    module lemma {#m} sk b m where
      skL  = take #seckey1 sk
      skH  = drop #seckey1 sk
      vkL  = OTS1.verif-key skL
      vkH  = map* #m OTS1.verif-key skH
      sigL = OTS1.sign skL b
      sigH = concat (map OTS1.sign (group #m #seckey1 skH) ⊛ m)

    lemma : ∀ {#m} sk m → and (map OTS1.verify (group #m #pubkey1 (map* #m OTS1.verif-key sk)) ⊛ m ⊛ group #m #signature1
                               (concat (map OTS1.sign (group #m #seckey1 sk) ⊛ m))) ≡ 1b
    lemma sk [] = refl
    lemma sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #pubkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #pubkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signature1 sigL sigH)
            | (let open lemma sk b m in drop-++ #signature1 sigL sigH)
            | (let open lemma sk b m in OTS1.verify-correct-sig skL b)
            | (let open lemma sk b m in lemma skH m)
            = refl
-- -}
-- -}
-- -}
-- -}

Add Crypto.Sig.Lamport

Add Crypto.Sig.Lamport


{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.Product
open import Control.Strategy renaming (map to mapS)

module Control.Strategy.Utils where

record Proto : ★₁ where
  constructor P[_,_]
  field
    Q : ★
    R : Q → ★

Client : Proto → ★ → ★
Client P[ Q , R ] A = Strategy Q R A

{-
data Bisim {P P' A A'} (RA : A → A' → ★) : Client P A → Client P' A' → ★ where
  ask-nop : ∀ {q? cont clt} r
            → Bisim RA (cont r) clt
            → Bisim RA (ask q? cont) clt
  ask-ask : ∀ q₀ q₁ cont₀ cont₁ r₀ r₁
            → ({!!} → Bisim RA (cont₀ r₀) (cont₁ r₁))
            → Bisim RA (ask q₀ cont₀) (ask q₁ cont₁)
-}
module Unused where
  mapS' : ∀ {A B Q Q' R} (f : A → B) (g : Q → Q') → Strategy Q (R ∘ g) A → Strategy Q' R B
  mapS' f g (ask q cont) = ask (g q) (λ r → mapS' f g (cont r))
  mapS' f g (done x)     = done (f x)

[_,_]=<<_ : ∀ {A B Q Q' R} (f : A → Strategy Q' R B) (g : Q → Q') → Strategy Q (R ∘ g) A → Strategy Q' R B
[ f , g ]=<< ask q? cont = ask (g q?) (λ r → [ f , g ]=<< cont r)
[ f , g ]=<< done x      = f x

module Rec {A B Q : ★} {R : Q → ★} {M : ★ → ★}
           (runAsk : ∀ {A} → (q : Q) → (R q → M A) → M A)
           (runDone : A → M B) where
  runMM : Strategy Q R A → M B
  runMM (ask q? cont) = runAsk q? (λ r → runMM (cont r))
  runMM (done x)      = runDone x

module MM {A B Q : ★} {R : Q → ★} {M : ★ → ★}
         (_>>=M_ : ∀ {A B : ★} → M A → (A → M B) → M B)
         (runAsk : (q : Q) → M (R q))
         (runDone : A → M B) where
  runMM : Strategy Q R A → M B
  runMM (ask q? cont) = runAsk q? >>=M (λ r → runMM (cont r))
  runMM (done x)      = runDone x

module _ {A B Q Q' : ★} {R : Q → ★} {R'}
         (f : (q : Q) → Strategy Q' R' (R q))
         (g : A → Strategy Q' R' B) where
  [_,_]=<<'_ : Strategy Q R A → Strategy Q' R' B
  [_,_]=<<'_ (ask q? cont) = f q? >>= λ r → [_,_]=<<'_ (cont r)
  [_,_]=<<'_ (done x)      = g x

record ServerResp (P : Proto) (q : Proto.Q P) (A : ★₀) : ★₀ where
  coinductive
  open Proto P
  field
      srv-resp : R q
      srv-cont : ∀ q → ServerResp P q A
open ServerResp

Server : Proto → ★₀ → ★₀
Server P A = ∀ q → ServerResp P q A

OracleServer : Proto → ★₀
OracleServer P[ Q , R ] = (q : Q) → R q

module _ {P : Proto} {A : ★} where
  open Proto P
  com : Server P A → Client P A → A
  com srv (ask q κc) = com (srv-cont r) (κc (srv-resp r)) where r = srv q
  com srv (done x)   = x

module _ {P P' : Proto} {A A' : ★} where
  module P = Proto P
  module P' = Proto P'
  record MITM : ★ where
    coinductive
    field
      hack-query : (q' : P'.Q) → Client P (P'.R q' × MITM)
      hack-result : A' → Client P A
  open MITM

  module WithOutBind where
      hacked-com-client : Server P A → MITM → Client P' A' → A
      hacked-com-mitm : ∀ {q'} → Server P A → Client P (P'.R q' × MITM) → (P'.R q' → Client P' A') → A
      hacked-com-srv-resp : ∀ {q q'} → ServerResp P q A → (P.R q → Client P (P'.R q' × MITM)) → (P'.R q' → Client P' A') → A

      hacked-com-srv-resp r mitm clt = hacked-com-mitm (srv-cont r) (mitm (srv-resp r)) clt

      hacked-com-mitm srv (ask q? mitm) clt = hacked-com-srv-resp (srv q?) mitm clt
      hacked-com-mitm srv (done (r' , mitm)) clt = hacked-com-client srv mitm (clt r')

      hacked-com-client srv mitm (ask q' κc) = hacked-com-mitm srv (hack-query mitm q') κc
      hacked-com-client srv mitm (done x) = com srv (hack-result mitm x)

  mitm-to-client-trans : MITM → Client P' A' → Client P A
  mitm-to-client-trans mitm (ask q? cont) = hack-query mitm q? >>= λ { (r' , mitm') → mitm-to-client-trans mitm' (cont r') }
  mitm-to-client-trans mitm (done x)      = hack-result mitm x

  hacked-com : Server P A → MITM → Client P' A' → A
  hacked-com srv mitm clt = com srv (mitm-to-client-trans mitm clt)

module _ (P : Proto) (A : ★) where
  open Proto P
  open MITM
  honest : MITM {P} {P} {A} {A}
  hack-query  honest q = ask q λ r → done (r , honest)
  hack-result honest a = done a

module _ (P : Proto) (A : ★) (Oracle : OracleServer P) where
  oracle-server : Server P A
  srv-resp (oracle-server q) = Oracle q
  srv-cont (oracle-server q) = oracle-server

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

Add Control.Strategy.Utils

Add Control.Strategy.Utils


{-# OPTIONS --without-K #-}
open import Level
open import Data.Product
  renaming (proj₁ to fst; proj₂ to snd)

open import Function.Param.Binary

module Data.Product.Param.Binary where

record ⟦Σ⟧ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
           {A₁ : Set a₁} {A₂ : Set a₂}
           {B₁ : A₁ → Set b₁}
           {B₂ : A₂ → Set b₂}
           (Aᵣ : A₁ → A₂ → Set aᵣ)
           (Bᵣ : {x₁ : A₁} {x₂ : A₂} (xᵣ : Aᵣ x₁ x₂)
                → B₁ x₁ → B₂ x₂ → Set bᵣ)
           (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) : Set (aᵣ ⊔ bᵣ) where
  constructor _⟦,⟧_
  field
    ⟦fst⟧ : Aᵣ (fst p₁) (fst p₂)
    ⟦snd⟧ : Bᵣ ⟦fst⟧ (snd p₁) (snd p₂)
open ⟦Σ⟧ public
infixr 4 _⟦,⟧_

syntax ⟦Σ⟧ Aᵣ (λ xᵣ → e) = [ xᵣ ∶ Aᵣ ]⟦×⟧[ e ]

⟦∃⟧ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
        {A₁ : Set a₁} {A₂ : Set a₂}
        {Aᵣ : A₁ → A₂ → Set aᵣ}
        {B₁ : A₁ → Set b₁}
        {B₂ : A₂ → Set b₂}
        (Bᵣ : ⟦Pred⟧ bᵣ Aᵣ B₁ B₂)
        (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) → Set _
⟦∃⟧ = ⟦Σ⟧ _

syntax ⟦∃⟧ (λ xᵣ → e) = ⟦∃⟧[ xᵣ ] e

_⟦×⟧_ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
          {A₁ : Set a₁} {A₂ : Set a₂}
          {B₁ : Set b₁} {B₂ : Set b₂}
          (Aᵣ : A₁ → A₂ → Set aᵣ)
          (Bᵣ : B₁ → B₂ → Set bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → Set (aᵣ ⊔ bᵣ)
_⟦×⟧_ Aᵣ Bᵣ = ⟦Σ⟧ Aᵣ (λ _ → Bᵣ)

{-
_⟦×⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → Set _
_⟦×⟧_ Aᵣ Bᵣ = λ p₁ p₂ → Aᵣ (fst p₁) (fst p₂) ×
                        Bᵣ (snd p₁) (snd p₂)
-}

{- One can give these two types to ⟦_,_⟧:

⟦_,_⟧' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : Set a₁} {A₂ : Set a₂}
       {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
       {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {x₁ x₂ y₁ y₂}
       (xᵣ : Aᵣ x₁ x₂)
       (yᵣ : Bᵣ xᵣ y₁ y₂)
     → ⟦Σ⟧ Aᵣ Bᵣ (x₁ , y₁) (x₂ , y₂)
⟦_,_⟧' = ⟦_,_⟧

⟦_,_⟧'' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : Set a₁} {A₂ : Set a₂}
       {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
       {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {p₁ p₂}
       (⟦fst⟧ : Aᵣ (fst p₁) (fst p₂))
       (⟦snd⟧ : Bᵣ ⟦fst⟧ (snd p₁) (snd p₂))
     → ⟦Σ⟧ Aᵣ Bᵣ p₁ p₂
⟦_,_⟧'' = ⟦_,_⟧
-}

add Data.Product.Param.Binary

add Data.Product.Param.Binary


{-# OPTIONS --without-K #-}
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP hiding (map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP

module Crypto.Sig.LamportOneBit
          (#secret : ℕ)
          (#digest : ℕ)
          (hash    : Bits #secret → Bits #digest)
          where

#signkey   = 2* #secret
#verifkey  = 2* #digest
#signature = #secret

Digest     = Bits #digest
Secret     = Bits #secret
SignKey    = Bits #signkey
Signature  = Bits #signature
VerifKey   = Bits #verifkey

module signkey (sk : SignKey) where
  skL = take #secret sk
  skH = drop #secret sk
  vkL = hash skL
  vkH = hash skH

-- Derive the public key by hashing each secret
verif-key : SignKey → VerifKey
verif-key = map2* #secret #digest hash

module verifkey (vk : VerifKey) where
  vkL = take #digest vk
  vkH = drop #digest vk

-- Key generation
key-gen : SignKey → VerifKey × SignKey
key-gen sk = vk , sk
  module key-gen where
    vk = verif-key sk

-- Sign a single bit message
sign : SignKey → Bit → Signature
sign sk b = take2* _ b sk

-- Verify the signature of a single bit message
verify : VerifKey → Bit → Signature → Bit
verify vk b sig = take2* _ b vk == hash sig

verify-correct-sig : ∀ sk b → verify (verif-key sk) b (sign sk b) ≡ 1b
verify-correct-sig sk 0b = ==-reflexive (take-++ #digest (hash (take #secret sk)) _)
verify-correct-sig sk 1b = ==-reflexive (drop-++ #digest (hash (take #secret sk)) _)

import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits

module Assuming-injectivity (hash-inj : Injective hash) where

  -- If one considers the hash function injective, then, so is verif-key
  verif-key-inj : ∀ {sk1 sk2} → verif-key sk1 ≡ verif-key sk2 → sk1 ≡ sk2
  verif-key-inj {sk1} {sk2} e
    = take-drop= #secret sk1 sk2
        (hash-inj (++-inj₁ e))
        (hash-inj (++-inj₂ sk1.vkL sk2.vkL e))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2

  -- Therefor under this assumption, different secret keys means different public keys
  verif-key-corrolary : ∀ {sk1 sk2} → sk1 ≢ sk2 → verif-key sk1 ≢ verif-key sk2
  verif-key-corrolary {sk1} {sk2} sk≢ vk= = sk≢ (verif-key-inj vk=)

  -- If one considers the hash function injective then there is
  -- only one signing key which can sign correctly all (0 and 1)
  -- the messages
  signkey-uniqness :
        ∀ sk1 sk2 →
          (∀ b → verify (verif-key sk1) b (sign sk2 b) ≡ 1b) →
          sk1 ≡ sk2
  signkey-uniqness sk1 sk2 e
    = take-drop= #secret sk1 sk2 (lemmaL (e 0b)) (lemmaH (e 1b))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2
      lemmaL : verify (verif-key sk1) 0b (sign sk2 0b) ≡ 1b →
              sk1.skL ≡ sk2.skL
      lemmaL e0
        rewrite take-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e0)
              = refl

      lemmaH : verify (verif-key sk1) 1b (sign sk2 1b) ≡ 1b →
               sk1.skH ≡ sk2.skH
      lemmaH e1
        rewrite drop-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e1)
              = refl

module Assuming-invertibility
         (unhash : Digest → Secret)
         (unhash-hash : ∀ x → unhash (hash x) ≡ x)
         (hash-unhash : ∀ x → hash (unhash x) ≡ x)
         where

  -- EXERCISES
  {-
  recover-signkey : VerifKey → SignKey
  recover-signkey = {!!}

  recover-signkey-correct : ∀ sk → recover-signkey (verif-key sk) ≡ sk
  recover-signkey-correct = {!!}

  forgesig : VerifKey → Bit → Signature
  forgesig = {!!}

  forgesig-correct : ∀ vk b → verify vk b (forgesig vk b) ≡ 1b
  forgesig-correct = {!!}
  -}

-- -}

Add Crypto.Sig.LamportOneBit

Add Crypto.Sig.LamportOneBit


module Control.Strategy where

open import Function
open import Type using (★)
open import Category.Monad
open import Relation.Binary.PropositionalEquality.NP

data Strategy (Q R A : ★) : ★ where
  ask  : (q? : Q) (cont : R → Strategy Q R A) → Strategy Q R A
  done : A → Strategy Q R A

infix 2 _≈_
data _≈_ {Q R A} : (s₀ s₁ : Strategy Q R A) → ★ where
  ask-ask : ∀ {k₀ k₁} → (q? : Q) (cont : ∀ r → k₀ r ≈ k₁ r) → ask q? k₀ ≈ ask q? k₁
  done-done : ∀ x → done x ≈ done x

≈-refl : ∀ {Q R A} {s : Strategy Q R A} → s ≈ s
≈-refl {s = ask q? cont} = ask-ask q? (λ r → ≈-refl)
≈-refl {s = done x}      = done-done x

module _ {Q R : ★} where
  private
    M : ★ → ★
    M = Strategy Q R

  _=<<_ : ∀ {A B} → (A → M B) → M A → M B
  f =<< ask q? cont = ask q? (λ r → f =<< cont r)
  f =<< done x      = f x

  return : ∀ {A} → A → M A
  return = done

  map : ∀ {A B} → (A → B) → M A → M B
  map f s = (done ∘ f) =<< s

  join : ∀ {A} → M (M A) → M A
  join s = id =<< s

  _>>=_ : ∀ {A B} → M A → (A → M B) → M B
  _>>=_ = flip _=<<_

  rawMonad : RawMonad M
  rawMonad = record { return = return; _>>=_ = _>>=_ }

  return-=<< : ∀ {A} (m : M A) → return =<< m ≈ m
  return-=<< (ask q? cont) = ask-ask q? (λ r → return-=<< (cont r))
  return-=<< (done x)      = done-done x

  return->>= : ∀ {A B} (x : A) (f : A → M B) → return x >>= f ≡ f x
  return->>= _ _ = refl

  >>=-assoc : ∀ {A B C} (mx : M A) (my : A → M B) (f : B → M C) → (mx >>= λ x → (my x >>= f)) ≈ (mx >>= my) >>= f
  >>=-assoc (ask q? cont) my f = ask-ask q? (λ r → >>=-assoc (cont r) my f)
  >>=-assoc (done x)      my f = ≈-refl

  map-id : ∀ {A} (s : M A) → map id s ≈ s
  map-id = return-=<<

  map-∘ : ∀ {A B C} (f : A → B) (g : B → C) s → map (g ∘ f) s ≈ (map g ∘ map f) s
  map-∘ f g s = >>=-assoc s (done ∘ f) (done ∘ g)

  module EffectfulRun
           (E : ★ → ★)
           (_>>=E_  : ∀ {A B} → E A → (A → E B) → E B)
           (returnE : ∀ {A} → A → E A)
           (Oracle  : Q → E R) where
    runE : ∀ {A} → M A → E A
    runE (ask q? cont) = Oracle q? >>=E (λ r → runE (cont r))
    runE (done x)      = returnE x

  module _ (Oracle : Q → R) where
    run : ∀ {A} → M A → A
    run (ask q? cont) = run (cont (Oracle q?))
    run (done x)      = x

    module _ {A B : ★} (f : A → M B) where
        run->>= : (s : M A) → run (s >>= f) ≡ run (f (run s))
        run->>= (ask q? cont) = run->>= (cont (Oracle q?))
        run->>= (done x)      = refl

    module _ {A B : ★} (f : A → B) where
        run-map : (s : M A) → run (map f s) ≡ f (run s)
        run-map = run->>= (return ∘ f)

    module _ {A B : ★} where
        run-≈ : {s₀ s₁ : M A} → s₀ ≈ s₁ → run s₀ ≡ run s₁
        run-≈ (ask-ask q? cont) = run-≈ (cont (Oracle q?))
        run-≈ (done-done x)     = refl

Add Control.Strategy

Add Control.Strategy


-- some excises for learning ttfp (type theory for functional programming).
-- most of the code is *borrowed* from learn you an agda shamelessly

-- Function composition
_∘_ : {A : Set} { B : A -> Set} { C : (x : A) -> B x -> Set}
      (f : {x : A}(y : B x) -> C x y) (g : (x : A) -> B x)
      (x : A) -> C x (g x)
(f ∘ g) x = f (g x)

-- Conjuntion, ∏-type in haskell

data _∧_ (α : Set) (β : Set) : Set where
  ∧-intro : α → β → (α ∧ β)

∧-elim₁ : {α β : Set} → (α ∧ β) → α
∧-elim₁ (∧-intro p q) = p

∧-elim₂ : {α β : Set} → (α ∧ β) → β
∧-elim₂ (∧-intro p q) = q

_⇔_ : (α : Set) → (β : Set) → Set
a ⇔ b = (a → b) ∧ (b → a)

∧-comm′ : {α β : Set} → (α ∧ β) → (β ∧ α)
∧-comm′ (∧-intro a b) = ∧-intro b a

∧-comm : {α β : Set} → (α ∧ β) ⇔ (β ∧ α)
∧-comm = ∧-intro ∧-comm′ ∧-comm′

-- type signature cannot be eliminated, was expecting type could be infered but it wasn't the case.
e₁e₁ : { P Q R : Set} → ( (P ∧ Q) ∧ R ) → P
e₁e₁ = ∧-elim₁ ∘ ∧-elim₁
e₂e₁ : { P Q R : Set} → ( (P ∧ Q) ∧ R) → Q
e₂e₁ = ∧-elim₂ ∘ ∧-elim₁

∧-assoc₁ : { P Q R : Set } → ((P ∧ Q) ∧ R) → (P ∧ (Q ∧ R))
∧-assoc₁ = λ x → ∧-intro (∧-elim₁ (∧-elim₁ x)) (∧-intro (∧-elim₂ (∧-elim₁ x)) (∧-elim₂ x))

∧-assoc₂ : {P Q R : Set} → (P ∧ (Q ∧ R)) → ((P ∧ Q) ∧ R)
∧-assoc₂ = λ x → ∧-intro (∧-intro (∧-elim₁ x) (∧-elim₁ (∧-elim₂ x))) (∧-elim₂ (∧-elim₂ x))

∧-assoc : {P Q R : Set} → ((P ∧ Q) ∧ R) ⇔ (P ∧ (Q ∧ R))
∧-assoc = ∧-intro ∧-assoc₁ ∧-assoc₂

-- Disjunctions, ∑-type in haskell

data _∨_ (P Q : Set) : Set where
  ∨-intro₁ : P → P ∨ Q
  ∨-intro₂ : Q → P ∨ Q

∨-elim : {A B C : Set} → (A ∨ B) → (A → C) → (B → C) → C
∨-elim (∨-intro₁ a) ac bc = ac a
∨-elim (∨-intro₂ b) ac bc = bc b

∨-comm′ : {P Q : Set} → (P ∨ Q) → (Q ∨ P)
∨-comm′ (∨-intro₁ p) = ∨-intro₂ p
∨-comm′ (∨-intro₂ q) = ∨-intro₁ q

∨-comm : {P Q : Set} → (P ∨ Q) ⇔ (Q ∨ P)
∨-comm = ∧-intro ∨-comm′ ∨-comm′

Create ttfp1.agda

Create ttfp1.agda

notes while learning ttfp


module incremental where

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

-- Semantics

Dom⟦_⟧ : Type -> Set
Dom⟦ τ₁ ⇒ τ₂ ⟧ = Dom⟦ τ₁ ⟧ → Dom⟦ τ₂ ⟧

-- TYPING CONTEXTS

-- Syntax

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

-- Semantics

data Empty : Set where
  ∅ : Empty

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

Env⟦_⟧ : Context → Set
Env⟦ ∅ ⟧ = Empty
Env⟦ τ • Γ ⟧ = Bind Dom⟦ τ ⟧ Env⟦ Γ ⟧

-- VARIABLES

-- Syntax

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

-- Semantics

lookup⟦_⟧ : ∀ {Γ τ} → Var Γ τ → Env⟦ Γ ⟧ → Dom⟦ τ ⟧
lookup⟦ this ⟧ (v • ρ) = v
lookup⟦ that x ⟧ (v • ρ) = lookup⟦ x ⟧ ρ

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

-- Semantics

eval⟦_⟧ : ∀ {Γ τ} → Term Γ τ → Env⟦ Γ ⟧ → Dom⟦ τ ⟧
eval⟦ abs t ⟧ ρ = λ v → eval⟦ t ⟧ (v • ρ)
eval⟦ app t₁ t₂ ⟧ ρ = (eval⟦ t₁ ⟧ ρ) (eval⟦ t₂ ⟧ ρ)
eval⟦ var x ⟧ ρ = lookup⟦ x ⟧ ρ

-- WEAKENING

-- Extend a context to a super context

infixr 10 _⋎_

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

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

-- Weaken a term to a super context

weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app compose (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Γ

-- CHANGING TERMS WHEN THE ENVIRONMENT CHANGES

Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)
Δ-term {Γ} (app t₁ t₂) = {!!}
Δ-term {Γ} (var x) = {!!}

Implement STLC in AGDA (fix #13).

Implement STLC in AGDA (fix #13).

Old-commit-hash: 8c8d0d1e3a7f67f1a6640d7526542321b3a5a424


module Data.Nat.GCD.NP where

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Divisibility as Div
open import Relation.Binary
private module P = Poset Div.poset
open import Data.Product
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)
open import Induction
open import Induction.Nat
open import Induction.Lexicographic
open import Function
open import Data.Nat.GCD.Lemmas

------------------------------------------------------------------------
-- Greatest common divisor

module GCD where

  -- Specification of the greatest common divisor (gcd) of two natural
  -- numbers.

  record GCD (m n gcd : ℕ) : Set where
    constructor is
    field
      -- The gcd is a common divisor.
      commonDivisor : gcd ∣ m × gcd ∣ n

      -- All common divisors divide the gcd, i.e. the gcd is the
      -- greatest common divisor according to the partial order _∣_.
      greatest : ∀ {d} → d ∣ m × d ∣ n → d ∣ gcd

  open GCD public

  -- The gcd is unique.

  unique : ∀ {d₁ d₂ m n} → GCD m n d₁ → GCD m n d₂ → d₁ ≡ d₂
  unique d₁ d₂ = P.antisym (GCD.greatest d₂ (GCD.commonDivisor d₁))
                           (GCD.greatest d₁ (GCD.commonDivisor d₂))

  -- The gcd relation is "symmetric".

  sym : ∀ {d m n} → GCD m n d → GCD n m d
  sym g = is (swap $ GCD.commonDivisor g) (GCD.greatest g ∘ swap)

  -- The gcd relation is "reflexive".

  refl : ∀ {n} → GCD n n n
  refl = is (P.refl , P.refl) proj₁

  -- The GCD of 0 and n is n.

  base : ∀ {n} → GCD 0 n n
  base {n} = is (n ∣0 , P.refl) proj₂

  -- If d is the gcd of n and k, then it is also the gcd of n and
  -- n + k.

  step : ∀ {n k d} → GCD n k d → GCD n (n + k) d
  step g with GCD.commonDivisor g
  step {n} {k} {d} g | (d₁ , d₂) = is (d₁ , ∣-+ d₁ d₂) greatest′
    where
    greatest′ : ∀ {d′} → d′ ∣ n × d′ ∣ n + k → d′ ∣ d
    greatest′ (d₁ , d₂) = GCD.greatest g (d₁ , ∣-∸ d₂ d₁)

open GCD public using (GCD)

------------------------------------------------------------------------
-- Calculating the gcd

-- The calculation also proves Bézout's lemma.

module Bézout where

  module Identity where

    -- If m and n have greatest common divisor d, then one of the
    -- following two equations is satisfied, for some numbers x and y.
    -- The proof is "lemma" below (Bézout's lemma).
    --
    -- (If this identity was stated using integers instead of natural
    -- numbers, then it would not be necessary to have two equations.)

    data Identity (d m n : ℕ) : Set where
    --  +- : (x y : ℕ) (eq : d + y * n ≡ x * m) → Identity d m n
      -+ : (x y : ℕ) (eq : d + x * m ≡ y * n) → Identity d m n

    -- Various properties about Identity.

{-
    sym : ∀ {d} → Symmetric (Identity d)
    sym (+- x y eq) = -+ y x eq
    sym (-+ x y eq) = +- y x eq
    -}

    refl : ∀ {d} → Identity d d d
    refl = -+ 0 1 PropEq.refl

    base : ∀ {d} → Identity d 0 d
    base = -+ 0 1 PropEq.refl

    private
      infixl 7 _⊕_

      _⊕_ : ℕ → ℕ → ℕ
      m ⊕ n = 1 + m + n

    step : ∀ {d n k} → Identity d n k → Identity d n (n + k)
    {-
    step {d}     (+-  x  y       eq) with compare x y
    step {d}     (+- .x .x       eq) | equal x     = +- (2 * x)     x       (lem₂ d x   eq)
    step {d}     (+- .x .(x ⊕ i) eq) | less x i    = +- (2 * x ⊕ i) (x ⊕ i) (lem₃ d x   eq)
    step {d} {n} (+- .(y ⊕ i) .y eq) | greater y i = +- (2 * y ⊕ i) y       (lem₄ d y n eq)
    -}
    step {d}     (-+  x  y       eq) with compare x y
    step {d}     (-+ .x .x       eq) | equal x     = -+ (2 * x)     x       (lem₅ d x   eq)
    step {d}     (-+ .x .(x ⊕ i) eq) | less x i    = -+ (2 * x ⊕ i) (x ⊕ i) (lem₆ d x   eq)
    step {d} {n} (-+ .(y ⊕ i) .y eq) | greater y i = -+ (2 * y ⊕ i) y       (lem₇ d y n eq)

  open Identity public using (Identity) -- ; +-; -+)

  module Lemma where

    -- This type packs up the gcd, the proof that it is a gcd, and the
    -- proof that it satisfies Bézout's identity.

    data Lemma (m n : ℕ) : Set where
      result : (d : ℕ) (g : GCD m n d) (b : Identity d m n) → Lemma m n

    -- Various properties about Lemma.

    {-
    sym : Symmetric Lemma
    sym (result d g b) = result d (GCD.sym g) (Identity.sym b)
    -}

    base : ∀ d → Lemma 0 d
    base d = result d GCD.base Identity.base

    refl : ∀ d → Lemma d d
    refl d = result d GCD.refl Identity.refl

    stepˡ : ∀ {n k} → Lemma n (suc k) → Lemma n (suc (n + k))
    stepˡ {n} {k} (result d g b) =
      PropEq.subst (Lemma n) (lem₀ n k) $
        result d (GCD.step g) (Identity.step b)

    {-
    stepʳ : ∀ {n k} → Lemma (suc k) n → Lemma (suc (n + k)) n
    stepʳ = sym ∘ stepˡ ∘ sym
    -}

  open Lemma public using (Lemma; result)

  -- Bézout's lemma proved using some variant of the extended
  -- Euclidean algorithm.

  lemma : (m n : ℕ) → Lemma m n
  lemma zero n = Lemma.base n
  lemma m zero = {!Lemma.sym (Lemma.base m)!}
  lemma (suc m) (suc n) = build [ <-rec-builder ⊗ <-rec-builder ] P gcd (m , n)
    where
    P : ℕ × ℕ → Set
    P (m , n) = Lemma (suc m) (suc n)

    gcd : ∀ p → (<-Rec ⊗ <-Rec) P p → P p
    gcd (m , n           ) rec with compare m n
    gcd (m , .m          ) rec | equal .m     = Lemma.refl (suc m)
    gcd (m , .(suc m + k)) rec | less .m k    =
                      -- "gcd m k"
                      -- k < n
                      -- m < n
                      -- n = suc m + k
                      -- dist m n = suc k

                      -- m + k < m + suc m + k
                      --    k < suc m + k
                      --    0 < suc m
      Lemma.stepˡ $ proj₁ rec k (≤⇒≤′ (s≤s (≤-steps {k} {k} m (≤′⇒≤ ≤′-refl))))
    gcd (.(suc n + k) , n) rec | greater .n k =
                      -- "gcd k n"
                      -- m > n
                      -- m ≡ suc n + k
                      -- dist m n = suc k

                      -- k + n < suc n + k + n
                      --    k < suc n + k
                      --    0 < suc n
                      -- gcd n k
      {!Lemma.stepʳ $ proj₂ rec k (≤⇒≤′ (s≤s (≤-steps {k} {k} n (≤′⇒≤ ≤′-refl)))) n!}

  -- Bézout's identity can be recovered from the GCD.

  identity : ∀ {m n d} → GCD m n d → Identity d m n
  identity {m} {n} g with lemma m n
  identity g | result d g′ b with GCD.unique g g′
  identity g | result d g′ b | PropEq.refl = b

-- Calculates the gcd of the arguments.

gcd : (m n : ℕ) → ∃ λ d → GCD m n d
gcd m n with Bézout.lemma m n
gcd m n | Bézout.result d g _ = (d , g)
-- -}
-- -}
-- -}
-- -}
-- -}

Add a broken attempt at simplifying Nat.GCD: Nat.GCD.NP


{-# OPTIONS --without-K #-}
open import Type
open import Data.Product
open import Data.Bit

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

  -- randomness supply for: encryption, key-generation, adversary, extensions
  (Rₑ Rₖ Rₐ : ★)

  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)

where

M² = Bit → Message

-- IND-CPA adversary in two parts
Adv : ★
Adv = Rₐ → PubKey → (M² × (CipherText → Bit))

-- IND-CPA randomness supply
R : ★
R = (Rₐ × Rₖ × Rₑ)

-- IND-CPA games:
--   * input: adversary and randomness supply
--   * output b: adversary claims we are in game ⅁ b
Game : ★
Game = Adv → R → Bit

-- The game step by step:
-- (pk) key-generation, only the public-key is needed
-- (mb) send randomness, public-key and bit
--      receive which message to encrypt
-- (c)  encrypt the message
-- (b′) send randomness, public-key and ciphertext
--      receive the guess from the adversary
⅁ : Bit → Game
⅁ b m (rₐ , rₖ , rₑ) = b′
  where
  pk = proj₁ (KeyGen rₖ)
  ad = m rₐ pk
  mb = proj₁ ad b
  c  = Enc pk mb rₑ
  b′ = proj₂ ad c

⅁₀ ⅁₁ : Game
⅁₀ = ⅁ 0b
⅁₁ = ⅁ 1b

Add alternative defintion for IND CPA

Add alternative defintion for IND CPA