module ModalLogic where

-- Implement Frank Pfenning's lambda calculus based on modal logic S4, as
-- described in "A Modal Analysis of Staged Computation".

open import Denotational.Notation

data BaseType : Set where
  Base : BaseType
  Next : BaseType → BaseType

data Type : Set where
  base : BaseType → Type
  _⇒_ : Type → Type → Type
  □_ : Type → Type

-- Reuse contexts, variables and weakening from Tillmann's library.
open import Syntactic.Contexts Type

-- No semantics for these types.

data Term : Context → Context → Type → Set where
  abs : ∀ {τ₁ τ₂ Γ Δ} → (t : Term (τ₁ • Γ) Δ τ₂) → Term Γ Δ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ Δ} → (t₁ : Term Γ Δ (τ₁ ⇒ τ₂)) (t₂ : Term Γ Δ τ₁) → Term Γ Δ τ₂
  ovar : ∀ {Γ Δ τ} → (x : Var Γ τ) → Term Γ Δ τ
  mvar : ∀ {Γ Δ τ} → (u : Var Δ τ) → Term Γ Δ τ
  -- Note the builtin weakening
  box : ∀ {Γ Δ τ} → Term ∅ Δ τ → Term Γ Δ (□ τ)
  let-box_in-_ : ∀ {τ₁ τ₂ Γ Δ} → (e₁ : Term Γ Δ (□ τ₁)) → (e₂ : Term Γ (τ₁ • Δ) τ₂) → Term Γ Δ τ₂

-- Lemma 1 includes weakening.
-- Most of the proof can be generated by C-c C-a, but syntax errors must then be fixed.

weaken : ∀ {Γ₁ Γ₂ Δ₁ Δ₂ τ} → (Γ′ : Γ₁ ≼ Γ₂) → (Δ′ : Δ₁ ≼ Δ₂) → Term Γ₁ Δ₁ τ → Term Γ₂ Δ₂ τ
weaken Γ′ Δ′ (abs {τ₁} t) = abs (weaken (keep τ₁ • Γ′) Δ′ t)
weaken Γ′ Δ′ (app t t₁) = app (weaken Γ′ Δ′ t) (weaken Γ′ Δ′ t₁)
weaken Γ′ Δ′ (ovar x) = ovar (lift Γ′ x)
weaken Γ′ Δ′ (mvar u) = mvar (lift Δ′ u)
weaken Γ′ Δ′ (box t) = box (weaken ∅ Δ′ t)
weaken Γ′ Δ′ (let-box_in-_ {τ₁} t t₁) =
  let-box weaken Γ′ Δ′ t in-
          weaken Γ′ (keep τ₁ • Δ′) t₁

module ModalLogic where

-- Implement Frank Pfenning's lambda calculus based on modal logic S4, as
-- described in "A Modal Analysis of Staged Computation".

open import Denotational.Notation

data BaseType : Set where
  Base : BaseType
  Next : BaseType → BaseType

data Type : Set where
  base : BaseType → Type
  _⇒_ : Type → Type → Type
  □_ : Type → Type

-- Reuse contexts, variables and weakening from Tillmann's library.
open import Syntactic.Contexts Type

-- No semantics for these types.

data Term : Context → Context → Type → Set where
  abs : ∀ {τ₁ τ₂ Γ Δ} → (t : Term (τ₁ • Γ) Δ τ₂) → Term Γ Δ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ Δ} → (t₁ : Term Γ Δ (τ₁ ⇒ τ₂)) (t₂ : Term Γ Δ τ₁) → Term Γ Δ τ₂
  ovar : ∀ {Γ Δ τ} → (x : Var Γ τ) → Term Γ Δ τ
  mvar : ∀ {Γ Δ τ} → (u : Var Δ τ) → Term Γ Δ τ
  -- Note the builtin weakening
  box : ∀ {Γ Δ τ} → Term ∅ Δ τ → Term Γ Δ (□ τ)
  let-box_in-_ : ∀ {τ₁ τ₂ Γ Δ} → (e₁ : Term Γ Δ (□ τ₁)) → (e₂ : Term Γ (τ₁ • Δ) τ₂) → Term Γ Δ τ₂

-- Lemma 1 includes weakening.
-- Attempt 1 at weakening, subcontext-based. This works, but it is not what we need later.
--
-- Most of the proof can be generated by C-c C-a, but syntax errors must then be
-- fixed and lift introduced by hand.

weaken : ∀ {Γ₁ Γ₂ Δ₁ Δ₂ τ} → (Γ′ : Γ₁ ≼ Γ₂) → (Δ′ : Δ₁ ≼ Δ₂) → Term Γ₁ Δ₁ τ → Term Γ₂ Δ₂ τ
weaken Γ′ Δ′ (abs {τ₁} t) = abs (weaken (keep τ₁ • Γ′) Δ′ t)
weaken Γ′ Δ′ (app t t₁) = app (weaken Γ′ Δ′ t) (weaken Γ′ Δ′ t₁)
weaken Γ′ Δ′ (ovar x) = ovar (lift Γ′ x)
weaken Γ′ Δ′ (mvar u) = mvar (lift Δ′ u)
weaken Γ′ Δ′ (box t) = box (weaken ∅ Δ′ t)
weaken Γ′ Δ′ (let-box_in-_ {τ₁} t t₁) =
  let-box weaken Γ′ Δ′ t in-
          weaken Γ′ (keep τ₁ • Δ′) t₁

open import Relation.Binary.PropositionalEquality

weaken-≼ : ∀ {Γ₁ Γ₂ Γ₃ Δ τ} → Term (Γ₁ ⋎ Γ₃) Δ τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) Δ τ
weaken-≼ {Γ₁} {Γ₂} {Γ₃} (abs {τ₁} t) =  abs (weaken-≼ {τ₁ • Γ₁} {Γ₂} t)
weaken-≼ {Γ₁} {Γ₂} (app t t₁) = app (weaken-≼ {Γ₁} {Γ₂} t) (weaken-≼ {Γ₁} {Γ₂} t₁)
weaken-≼ {Γ₁} {Γ₂} (ovar x) = ovar (Prefixes.lift {Γ₁} {Γ₂} x)
weaken-≼ (mvar u) = mvar u
weaken-≼ (box t) = box t
weaken-≼ {Γ₁} {Γ₂} (let-box t in- t₁) = let-box weaken-≼ {Γ₁} {Γ₂} t in- weaken-≼ {Γ₁} {Γ₂} t₁

substVar : ∀ {Γ Γ′ Δ τ₁ τ₂} → (t : Term Γ′ Δ τ₁) → (v : Var (Γ ⋎ (τ₁ • Γ′)) τ₂) → Term (Γ ⋎ Γ′) Δ τ₂
substVar {∅} t  this = t
substVar {∅} t (that v) = ovar v
substVar {τ • Γ} t  this = ovar this
substVar {τ • Γ} t (that v) = weaken-≼ {∅} {τ • ∅} (substVar {Γ} t v)

substTerm : ∀ {Γ Γ′ Δ τ₁ τ₂} → (t₁ : Term Γ′ Δ τ₁) → (t₂ : Term (Γ ⋎ (τ₁ • Γ′)) Δ τ₂) → Term (Γ ⋎ Γ′) Δ τ₂
substTerm {Γ} {Γ′} t₁ (abs {τ₂} t₂) = abs ( substTerm {τ₂ • Γ} {Γ′} t₁ t₂ )
substTerm {Γ} {Γ′} t₁ (app t₂ t₃) =  app (substTerm {Γ} {Γ′} t₁ t₂) (substTerm {Γ} {Γ′} t₁ t₃)
substTerm {Γ} {Γ′} t₁ (ovar v) =  substVar {Γ} {Γ′} t₁ v
substTerm t₁ (mvar u) = mvar u
substTerm t₁ (box t₂) = box t₂
substTerm {Γ} {Γ′} t₁ (let-box_in-_ {τ₃} t₂ t₃) =
  let-box substTerm {Γ} {Γ′} t₁ t₂ in-
    substTerm {Γ} {Γ′}
      (weaken ≼-refl (drop τ₃ • ≼-refl) t₁)
      t₃

implement substitution for modal logic

Agda: implement substitution for modal logic

Old-commit-hash: e8580d4ac39e998fdf42c16064112cd2c0326763


module Syntax.Context
    {Type : Set}
  where

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

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

-- TYPING CONTEXTS

-- Syntax

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

infixr 9 _•_

-- Specialized congruence rules

⟨∅⟩ : ∅ ≡ ∅
⟨∅⟩ = refl

_⟨•⟩_ : ∀ {τ₁ τ₂ Γ₁ Γ₂} → τ₁ ≡ τ₂ → Γ₁ ≡ Γ₂ → τ₁ • Γ₁ ≡ τ₂ • Γ₂
_⟨•⟩_ = cong₂ _•_

-- VARIABLES

-- Syntax

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

-- WEAKENING

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

module Prefixes where

-- Prefix of a context

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

-- take only the prefix of a context

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

-- drop the prefix of a context

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

-- Extend a context to a super context

  infixr 10 _⋎_

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

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

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

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

-- Lift a variable to a super context

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

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

module Subcontexts where
  infix 8 _≼_

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

  -- Properties

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

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

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

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

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

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

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

  -- Lift a variable to a super context

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

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

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

module Syntax.Context
    {Type : Set}
  where

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

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

-- TYPING CONTEXTS

-- Syntax

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

infixr 9 _•_

-- Specialized congruence rules

⟨∅⟩ : ∅ ≡ ∅
⟨∅⟩ = refl

_⟨•⟩_ : ∀ {τ₁ τ₂ Γ₁ Γ₂} → τ₁ ≡ τ₂ → Γ₁ ≡ Γ₂ → τ₁ • Γ₁ ≡ τ₂ • Γ₂
_⟨•⟩_ = cong₂ _•_

-- VARIABLES

-- Syntax

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

-- WEAKENING

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

module Prefixes where

-- Prefix of a context

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

-- take only the prefix of a context

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

-- drop the prefix of a context

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

-- Extend a context to a super context

  infixr 10 _⋎_

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

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

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

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

-- Lift a variable to a super context

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

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

module Subcontexts where
  infix 8 _≼_

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

  -- Properties

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

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

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

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

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

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

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

  -- Lift a variable to a super context

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

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

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

rename type parameter of `that`

Agda: rename type parameter of `that`

Old-commit-hash: 0b30e5858214cb3ecab7a1661b7a2a79ac6bc871


open import Type
open import Type.Identities
open import Level.NP
open import Explore.Core
open import Explore.Properties
open import Explore.Explorable
open import Data.Zero
open import Function.NP
open import Function.Extensionality
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP using (_≡_; refl; _∙_; !_)
open import HoTT
open Equivalences

import Explore.Monad

module Explore.Zero where

module _ {ℓ} where
    𝟘ᵉ : Explore ℓ 𝟘
    𝟘ᵉ = empty-explore
    {- or
    𝟘ᵉ ε _ _ = ε
    -}

    𝟘ⁱ : ∀ {p} → ExploreInd p 𝟘ᵉ
    𝟘ⁱ = empty-explore-ind
    {- or
    𝟘ⁱ _ Pε _ _ = Pε
    -}

module _ {ℓ₁ ℓ₂ ℓᵣ} {R : 𝟘 → 𝟘 → ★₀} where
    ⟦𝟘ᵉ⟧ : ⟦Explore⟧ᵤ ℓ₁ ℓ₂ ℓᵣ R 𝟘ᵉ 𝟘ᵉ
    ⟦𝟘ᵉ⟧ _ εᵣ _ _ = εᵣ

open Explorable₀  𝟘ⁱ public using () renaming (sum     to 𝟘ˢ; product to 𝟘ᵖ)

module _ {ℓ} where
    open Explorableₛ  {ℓ} 𝟘ⁱ public using () renaming (reify    to 𝟘ʳ)
    open Explorableₛₛ {ℓ} 𝟘ⁱ public using () renaming (unfocus  to 𝟘ᵘ)

    𝟘ˡ : Lookup {ℓ} 𝟘ᵉ
    𝟘ˡ _ ()

    𝟘ᶠ : Focus {ℓ} 𝟘ᵉ
    𝟘ᶠ ((), _)

    module _ {{_ : UA}} where
        Σᵉ𝟘-ok : Adequate-Σᵉ {ℓ} 𝟘ᵉ
        Σᵉ𝟘-ok _ = ! Σ𝟘-lift∘fst

    module _ {{_ : UA}}{{_ : FunExt}} where
        Πᵉ𝟘-ok : Adequate-Πᵉ {ℓ} 𝟘ᵉ
        Πᵉ𝟘-ok _ = ! Π𝟘-uniq _

module _ {{_ : UA}} where
    𝟘ˢ-ok : Adequate-sum 𝟘ˢ
    𝟘ˢ-ok _ = Fin0≡𝟘 ∙ ! Σ𝟘-fst

module _ {{_ : UA}}{{_ : FunExt}} where
    𝟘ᵖ-ok : Adequate-product 𝟘ᵖ
    𝟘ᵖ-ok _ = Fin1≡𝟙 ∙ ! (Π𝟘-uniq₀ _)

explore𝟘          = 𝟘ᵉ
explore𝟘-ind      = 𝟘ⁱ
lookup𝟘           = 𝟘ˡ
reify𝟘            = 𝟘ʳ
focus𝟘            = 𝟘ᶠ
unfocus𝟘          = 𝟘ᵘ
sum𝟘              = 𝟘ˢ
adequate-sum𝟘     = 𝟘ˢ-ok
product𝟘          = 𝟘ᵖ
adequate-product𝟘 = 𝟘ᵖ-ok

-- DEPRECATED
module _ {{_ : UA}} where
    open ExplorableRecord
    μ𝟘 : Explorable 𝟘
    μ𝟘 = mk _ 𝟘ⁱ 𝟘ˢ-ok
-- -}

open import Type
open import Type.Identities
open import Level.NP
open import Explore.Core
open import Explore.Properties
open import Explore.Explorable
open import Data.Zero
open import Function.NP
open import Function.Extensionality
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP using (_≡_; refl; _∙_; !_)
open import HoTT
open Equivalences

import Explore.Monad
open import Explore.Isomorphism

module Explore.Zero where

module _ {ℓ} where
    𝟘ᵉ : Explore ℓ 𝟘
    𝟘ᵉ = empty-explore
    {- or
    𝟘ᵉ ε _ _ = ε
    -}

    𝟘ⁱ : ∀ {p} → ExploreInd p 𝟘ᵉ
    𝟘ⁱ = empty-explore-ind
    {- or
    𝟘ⁱ _ Pε _ _ = Pε
    -}

module _ {ℓ₁ ℓ₂ ℓᵣ} {R : 𝟘 → 𝟘 → ★₀} where
    ⟦𝟘ᵉ⟧ : ⟦Explore⟧ᵤ ℓ₁ ℓ₂ ℓᵣ R 𝟘ᵉ 𝟘ᵉ
    ⟦𝟘ᵉ⟧ _ εᵣ _ _ = εᵣ

open Explorable₀  𝟘ⁱ public using () renaming (sum     to 𝟘ˢ; product to 𝟘ᵖ)

module _ {ℓ} where
    open Explorableₛ  {ℓ} 𝟘ⁱ public using () renaming (reify    to 𝟘ʳ)
    open Explorableₛₛ {ℓ} 𝟘ⁱ public using () renaming (unfocus  to 𝟘ᵘ)

    𝟘ˡ : Lookup {ℓ} 𝟘ᵉ
    𝟘ˡ _ ()

    𝟘ᶠ : Focus {ℓ} 𝟘ᵉ
    𝟘ᶠ ((), _)

    module _ {{_ : UA}} where
        Σᵉ𝟘-ok : Adequate-Σᵉ {ℓ} 𝟘ᵉ
        Σᵉ𝟘-ok _ = ! Σ𝟘-lift∘fst

    module _ {{_ : UA}}{{_ : FunExt}} where
        Πᵉ𝟘-ok : Adequate-Πᵉ {ℓ} 𝟘ᵉ
        Πᵉ𝟘-ok _ = ! Π𝟘-uniq _

module _ {{_ : UA}} where
    𝟘ˢ-ok : Adequate-sum 𝟘ˢ
    𝟘ˢ-ok _ = Fin0≡𝟘 ∙ ! Σ𝟘-fst

module _ {{_ : UA}}{{_ : FunExt}} where
    𝟘ᵖ-ok : Adequate-product 𝟘ᵖ
    𝟘ᵖ-ok _ = Fin1≡𝟙 ∙ ! (Π𝟘-uniq₀ _)

explore𝟘          = 𝟘ᵉ
explore𝟘-ind      = 𝟘ⁱ
lookup𝟘           = 𝟘ˡ
reify𝟘            = 𝟘ʳ
focus𝟘            = 𝟘ᶠ
unfocus𝟘          = 𝟘ᵘ
sum𝟘              = 𝟘ˢ
adequate-sum𝟘     = 𝟘ˢ-ok
product𝟘          = 𝟘ᵖ
adequate-product𝟘 = 𝟘ᵖ-ok

Lift𝟘ᵉ : ∀ {m} → Explore m (Lift 𝟘)
Lift𝟘ᵉ = explore-iso (≃-sym Lift≃id) 𝟘ᵉ

ΣᵉLift𝟘-ok : ∀ {{_ : UA}}{{_ : FunExt}}{m} → Adequate-Σᵉ {m} Lift𝟘ᵉ
ΣᵉLift𝟘-ok = Σ-iso-ok (≃-sym Lift≃id) {Aᵉ = 𝟘ᵉ} Σᵉ𝟘-ok

-- DEPRECATED
module _ {{_ : UA}} where
    open ExplorableRecord
    μ𝟘 : Explorable 𝟘
    μ𝟘 = mk _ 𝟘ⁱ 𝟘ˢ-ok
-- -}

add explore function for Lift 𝟘

add explore function for Lift 𝟘


module Atlas.Change.Derivation where

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

open import Base.Syntax.Context Type
open import Base.Change.Context ΔType

Atlas-Δconst : ∀ {Γ Σ τ} → (c : Const Σ τ) →
  Term Γ (internalizeContext (ΔContext′ Σ) (ΔType τ))

Atlas-Δconst true  = false!
Atlas-Δconst false = false!

Atlas-Δconst xor = abs₄ (λ x Δx y Δy → xor! Δx Δy)

Atlas-Δconst empty = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update = abs₆ (λ k Δk v Δv m Δm →
  insert (apply Δk k) (apply Δv v) (delete k v Δm))

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
Atlas-Δconst lookup = abs₄ (λ k Δk m Δm →
  let
    k′ = apply Δk k
  in
    (diff (apply {base _} (lookup! k′ Δm) (lookup! k′ m))
          (lookup! k m)))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip = abs₆ (λ f Δf m₁ Δm₁ m₂ Δm₂ →
  let
    g = abs (app₂ (weaken₁ Δf) (var this) nil-term)
  in
    zip4! g m₁ Δm₁ m₂ Δm₂)

-- Δfold f Δf z Δz m Δm = proj₂
--   (fold (λ k [a,Δa] [b,Δb] →
--           uncurry (λ a Δa → uncurry (λ b Δb →
--             pair (f k a b) (Δf k nil a Δa b Δb))
--             [b,Δb]) [a,Δa])
--        (pair z Δz)
--        (zip-pair m Δm))
--
-- Δfold is efficient only if evaluation is lazy and Δf is
-- self-maintainable: it doesn't look at the argument
-- (b = fold f k a b₀) at all.
Atlas-Δconst (fold {κ} {α} {β}) =
    let -- TODO (tedius): write weaken₇
      f  = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that (that this))))))))
      Δf = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that this)))))))
      z  = var (that (that (that this)))
      Δz = var (that (that this))
      m  = var (that this)
      Δm = var this
      k = weaken₃ (weaken₁ (var (that (that this))))
      [a,Δa] = var (that this)
      [b,Δb] = var this
      a  = var (that (that (that this)))
      Δa = var (that (that this))
      b  = var (that this)
      Δb = var this
      g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
            (pair (app₃ f k a b)
                  (app₆ Δf k nil-term a Δa b Δb))))
            (weaken₂ [b,Δb])))) [a,Δa])))
      proj₂ = uncurry (abs (abs (var this)))
    in
      abs (abs (abs (abs (abs (abs
        (proj₂ (fold! g (pair z Δz) (zip-pair m Δm))))))))

module Atlas.Change.Derivation where

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

open import Base.Syntax.Context Type
open import Base.Change.Context ΔType

ΔConst : ∀ {Γ Σ τ} → (c : Const Σ τ) →
  Term Γ (internalizeContext (ΔContext′ Σ) (ΔType τ))

ΔConst true  = false!
ΔConst false = false!

ΔConst xor = abs₄ (λ x Δx y Δy → xor! Δx Δy)

ΔConst empty = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
ΔConst update = abs₆ (λ k Δk v Δv m Δm →
  insert (apply Δk k) (apply Δv v) (delete k v Δm))

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
ΔConst lookup = abs₄ (λ k Δk m Δm →
  let
    k′ = apply Δk k
  in
    (diff (apply {base _} (lookup! k′ Δm) (lookup! k′ m))
          (lookup! k m)))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
ΔConst zip = abs₆ (λ f Δf m₁ Δm₁ m₂ Δm₂ →
  let
    g = abs (app₂ (weaken₁ Δf) (var this) nil-term)
  in
    zip4! g m₁ Δm₁ m₂ Δm₂)

-- Δfold f Δf z Δz m Δm = proj₂
--   (fold (λ k [a,Δa] [b,Δb] →
--           uncurry (λ a Δa → uncurry (λ b Δb →
--             pair (f k a b) (Δf k nil a Δa b Δb))
--             [b,Δb]) [a,Δa])
--        (pair z Δz)
--        (zip-pair m Δm))
--
-- Δfold is efficient only if evaluation is lazy and Δf is
-- self-maintainable: it doesn't look at the argument
-- (b = fold f k a b₀) at all.
ΔConst (fold {κ} {α} {β}) =
    let -- TODO (tedius): write weaken₇
      f  = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that (that this))))))))
      Δf = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that this)))))))
      z  = var (that (that (that this)))
      Δz = var (that (that this))
      m  = var (that this)
      Δm = var this
      k = weaken₃ (weaken₁ (var (that (that this))))
      [a,Δa] = var (that this)
      [b,Δb] = var this
      a  = var (that (that (that this)))
      Δa = var (that (that this))
      b  = var (that this)
      Δb = var this
      g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
            (pair (app₃ f k a b)
                  (app₆ Δf k nil-term a Δa b Δb))))
            (weaken₂ [b,Δb])))) [a,Δa])))
      proj₂ = uncurry (abs (abs (var this)))
    in
      abs (abs (abs (abs (abs (abs
        (proj₂ (fold! g (pair z Δz) (zip-pair m Δm))))))))

Rename Atlas-Δconst to ΔConst.

Rename Atlas-Δconst to ΔConst.

Old-commit-hash: e7ed19ec0ca363e486fe72ac858facfcd192e057


module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count; countᶠ)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
    ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
    ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h

  ]-[-cong-right-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ]-[ g → g ≈⅁ h → f ]-[ h
  ]-[-cong-right-≈↺ pf pf' = ]-[-sym (]-[-cong-left-≈↺ (sym pf') (]-[-sym pf))

  ]-[-cong-≗↺ : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong-≗↺ {c} {c'} {f} {g} {f'} {g'} f≗g f'≗g' pf
     = ]-[-cong-left-≈↺ {f = g} {g = f} {h = g'}
         ((≗⇒≈⅁ (λ x → sym (f≗g x)))) (]-[-cong-right-≈↺ pf (≗⇒≈⅁ f'≗g'))

  breaks : ∀ {c} (EXP : Bit → ⅁ c) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ⅁ c₀) (⅁₁ : Bit → ⅁ c₁) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ⅁ c}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong-≗↺ (same-games 0b) (same-games 1b)

module HomImplem k where
  --  | Pr[ f ≡ 1 ] - Pr[ g ≡ 1 ] | ≥ ε            [ on reals ]
  --  dist Pr[ f ≡ 1 ] Pr[ g ≡ 1 ] ≥ ε             [ on reals ]
  --  dist (#1 f / 2^ c) (#1 g / 2^ c) ≥ ε          [ on reals ]
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c where ε = 2^ -k [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(-k) * 2^ c            [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c - k)                [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c ∸ k)               [ on natural ]
  _]-[_ : ∀ {n} (f g : ⅁ n) → Set
  _]-[_ {n} f g = dist (count↺ f) (count↺ g) ≥ 2^(n ∸ k)

  ]-[-sym : ∀ {n} {f g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {n} {f} {g} f]-[g rewrite dist-sym (count↺ f) (count↺ g) = f]-[g

  ]-[-cong-left-≈↺ : ∀ {n} {f g h : ⅁ n} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {n} {f} {g} f≈g g]-[h rewrite ≈⅁⇒≈⅁′ {n} {f} {g} f≈g = g]-[h
  -- dist #g #h ≥ 2^(n ∸ k)
  -- dist #f #h ≥ 2^(n ∸ k)

module Implem k where
  _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
  _]-[_ {m} {n} f g = dist (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) ≥ 2^((m + n) ∸ k)

  ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {m} {n} {f} {g} f]-[g rewrite dist-sym (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) | ℕ°.+-comm m n = f]-[g

  postulate
      helper : ∀ x y z t → x + ((y + z) ∸ t) ≡ y + ((x + z) ∸ t)

  ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} f≈g g]-[h
      with 2^*-mono m g]-[h
  ... | q rewrite sym (dist-2^* m (⟨2^ o ⟩* (count↺ g)) (⟨2^ n ⟩* (count↺ h)))
                | 2^-comm m o (count↺ g)
                | sym f≈g
                | 2^-comm o n (count↺ f)
                | 2^-comm m n (count↺ h)
                | dist-2^* n (⟨2^ o ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ h))
                | 2^-+ m (n + o ∸ k) 1
                | helper m n o k
                | sym (2^-+ n (m + o ∸ k) 1)
                = 2^*-mono′ n q

  prgDist : PrgDist
  prgDist = mk _]-[_ (λ {m n f g} x → ]-[-sym {m} {n} {f} {g} x) (λ {m n o f g h} x y → ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} x y)

module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count; countᶠ)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
    ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
    ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h

  ]-[-cong-right-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ]-[ g → g ≈⅁ h → f ]-[ h
  ]-[-cong-right-≈↺ pf pf' = ]-[-sym (]-[-cong-left-≈↺ (sym pf') (]-[-sym pf))

  ]-[-cong-≗↺ : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong-≗↺ {c} {c'} {f} {g} {f'} {g'} f≗g f'≗g' pf
     = ]-[-cong-left-≈↺ {f = g} {g = f} {h = g'}
         ((≗⇒≈⅁ (λ x → sym (f≗g x)))) (]-[-cong-right-≈↺ pf (≗⇒≈⅁ f'≗g'))

  breaks : ∀ {c} (EXP : Bit → ⅁ c) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ⅁ c₀) (⅁₁ : Bit → ⅁ c₁) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ⅁ c}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong-≗↺ (same-games 0b) (same-games 1b)

module HomImplem k where
  --  | Pr[ f ≡ 1 ] - Pr[ g ≡ 1 ] | ≥ ε            [ on reals ]
  --  dist Pr[ f ≡ 1 ] Pr[ g ≡ 1 ] ≥ ε             [ on reals ]
  --  dist (#1 f / 2^ c) (#1 g / 2^ c) ≥ ε          [ on reals ]
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c where ε = 2^ -k [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(-k) * 2^ c            [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c - k)                [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c ∸ k)               [ on natural ]
  _]-[_ : ∀ {n} (f g : ⅁ n) → Set
  _]-[_ {n} f g = dist (count↺ f) (count↺ g) ≥ 2^(n ∸ k)

  ]-[-sym : ∀ {n} {f g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {n} {f} {g} f]-[g rewrite dist-sym (count↺ f) (count↺ g) = f]-[g

  ]-[-cong-left-≈↺ : ∀ {n} {f g h : ⅁ n} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {n} {f} {g} f≈g g]-[h rewrite ≈⅁⇒≈⅁′ {n} {f} {g} f≈g = g]-[h
  -- dist #g #h ≥ 2^(n ∸ k)
  -- dist #f #h ≥ 2^(n ∸ k)

module Implem k where
  _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
  _]-[_ {m} {n} f g = dist (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) ≥ 2^((m + n) ∸ k)

  ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {m} {n} {f} {g} f]-[g rewrite dist-sym (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) | ℕ°.+-comm m n = f]-[g

  postulate
      helper : ∀ x y z t → x + ((y + z) ∸ t) ≡ y + ((x + z) ∸ t)

  ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} f≈g g]-[h
      with 2^*-mono m g]-[h
           -- 2ᵐ(dist 2ᵒ#g 2ⁿ#h) ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
  ... | q rewrite sym (dist-2^* m (⟨2^ o ⟩* (count↺ g)) (⟨2^ n ⟩* (count↺ h)))
           -- dist 2ᵐ2ᵒ#g 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm m o (count↺ g)
           -- dist 2ᵒ2ᵐ#g 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | sym f≈g
           -- dist 2ᵒ2ⁿ#f 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm o n (count↺ f)
           -- dist 2ⁿ2ᵒ#f 2ᵐ2ⁿ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-comm m n (count↺ h)
           -- dist 2ⁿ2ᵒ#f 2ⁿ2ᵐ#h ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | dist-2^* n (⟨2^ o ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ h))
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ᵐ2ⁿ⁺ᵒ⁻ᵏ
                | 2^-+ m (n + o ∸ k) 1
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ᵐ⁺ⁿ⁺ᵒ⁻ᵏ
                | helper m n o k
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ⁿ⁺ᵐ⁺ᵒ⁻ᵏ
                | sym (2^-+ n (m + o ∸ k) 1)
           -- 2ⁿ(dist 2ᵒ#f 2ᵐ#h) ≤ 2ⁿ2ᵐ⁺ᵒ⁻ᵏ
                = 2^*-mono′ n q
           -- dist 2ᵒ#f 2ᵐ#h ≤ 2ᵐ⁺ᵒ⁻ᵏ

  prgDist : PrgDist
  prgDist = mk _]-[_ (λ {m n f g} x → ]-[-sym {m} {n} {f} {g} x) (λ {m n o f g h} x y → ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} x y)

document a broken (so far) proof

document a broken (so far) proof


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

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

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality

module Structure where
  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit
  open import Level

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  open import Parametric.Syntax.MType as MType
  open MType.Structure Base
  open import Parametric.Syntax.MTerm as MTerm
  open MTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

  ⟦ U c ⟧ValType = ⟦ c ⟧CompType
  ⟦ B ι ⟧ValType = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValType = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType × ⟦ τ₂ ⟧ValType
  ⟦ τ₁ v+ τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType ⊎ ⟦ τ₂ ⟧ValType

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType

  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCacheWrong × τ₁ )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  {-# NO_TERMINATION_CHECK #-}
  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  --
  -- XXX The termination checker isn't happy with it, and it may be right ─ if
  -- you keep substituting τ₁ = U (F τ), you can make the cache arbitrarily big.
  -- I think we don't do that unless we are caching a non-terminating
  -- computation to begin with, but I'm not entirely sure.
  --
  -- However, the termination checker can't prove that the function is
  -- terminating because it's not structurally recursive, but one call of the
  -- function will produce another call of the function stuck on a neutral term:
  -- So the computation will have terminated, just in an unusual way!
  --
  -- Anyway, I need not mechanize this part of the proof for my goals.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCache × ⟦ τ₁ ⟧ValTypeHidCache )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧TermCache ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache (abs t) ρ x = , (⟦ t ⟧TermCache (x • ρ) , tt)

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

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

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality

module Structure where
  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit
  open import Level

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧TermCache ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache (abs t) ρ x = , (⟦ t ⟧TermCache (x • ρ) , tt)

  open import Parametric.Syntax.MType as MType
  open MType.Structure Base
  open import Parametric.Syntax.MTerm as MTerm
  open MTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

  ⟦ U c ⟧ValType = ⟦ c ⟧CompType
  ⟦ B ι ⟧ValType = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValType = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType × ⟦ τ₂ ⟧ValType
  ⟦ τ₁ v+ τ₂ ⟧ValType = ⟦ τ₁ ⟧ValType ⊎ ⟦ τ₂ ⟧ValType

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType

  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧ValTypeHidCacheWrong × τ₁ )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  {-# NO_TERMINATION_CHECK #-}
  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  --
  -- XXX The termination checker isn't happy with it, and it may be right ─ if
  -- you keep substituting τ₁ = U (F τ), you can make the cache arbitrarily big.
  -- I think we don't do that unless we are caching a non-terminating
  -- computation to begin with, but I'm not entirely sure.
  --
  -- However, the termination checker can't prove that the function is
  -- terminating because it's not structurally recursive, but one call of the
  -- function will produce another call of the function stuck on a neutral term:
  -- So the computation will have terminated, just in an unusual way!
  --
  -- Anyway, I need not mechanize this part of the proof for my goals.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCache × ⟦ τ₁ ⟧ValTypeHidCache )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

Reorder code

Reorder code

Separate non-CBPV and CBPV version of the code


module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable
open import flat-funs
open import program-distance
open import one-time-semantic-security
import bit-guessing-game

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

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

open BitsExtra

module CompRed {t} {T : Set t}
               {♭Funs : FlatFuns T}
               (♭ops : FlatFunsOps ♭Funs)
               (ep ep' : EncParams) where
    open FlatFunsOps ♭ops
    open AbsSemSec ♭Funs

    open EncParams ep using (|M|; |C|)
    open EncParams ep' using () renaming (|M| to |M|'; |C| to |C|')

    M = `Bits |M|
    C = `Bits |C|
    M' = `Bits |M|'
    C' = `Bits |C|'

    comp-red : (pre-E : M' `→ M)
               (post-E : C `→ C') → SemSecReduction ep' ep _
    comp-red pre-E post-E (mk A₀ A₁) = mk (A₀ >>> (pre-E *** pre-E) *** idO) (post-E *** idO >>> A₁)

module Comp (ep : EncParams) (|M|' |C|' : ℕ) where
  open EncParams ep

  ep' : EncParams
  ep' = EncParams.mk |M|' |C|' |R|e

  open EncParams ep' using () renaming (Enc to Enc'; M to M'; C to C')

  Tr = Enc → Enc'

  open FlatFunsOps fun♭Ops

  comp : (pre-E : M' → M) (post-E : C → C') → Tr
  comp pre-E post-E E = pre-E >>> E >>> {-weaken≤ |R|e≤|R|e' ∘-} map↺ post-E

module CompSec (prgDist : PrgDist) (ep : EncParams) (|M|' |C|' : ℕ) where
  open PrgDist prgDist
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist
  open AbsSemSec fun♭Funs

  open EncParams ep

  ep' : EncParams
  ep' = EncParams.mk |M|' |C|' |R|e

  open EncParams ep' using () renaming (Enc to Enc'; M to M'; C to C')

  module CompSec' (pre-E : M' → M) (post-E : C → C') where
    open SemSecReductions ep ep'
    open CompRed fun♭Ops ep ep' hiding (M; C)
    open Comp ep |M|' |C|'

    comp-pres-sem-sec : SemSecTr id (comp pre-E post-E)
    comp-pres-sem-sec = comp-red pre-E post-E , λ E A → id

  open SemSecReductions ep ep'
  open CompRed fun♭Ops ep ep' hiding (M; C)
  open CompSec' public
  module Comp' {x y z} = Comp x y z
  open Comp' hiding (Tr)
  comp-pres-sem-sec⁻¹ : ∀ pre-E pre-E⁻¹
                          (pre-E-right-inv : pre-E ∘ pre-E⁻¹ ≗ id)
                          post-E post-E⁻¹
                          (post-E-left-inv : post-E⁻¹ ∘ post-E ≗ id)
                        → SemSecTr⁻¹ id (comp pre-E post-E)
  comp-pres-sem-sec⁻¹ pre-E pre-E⁻¹ pre-E-inv post-E post-E⁻¹ post-E-inv =
    SemSecTr→SemSecTr⁻¹
      (comp pre-E⁻¹ post-E⁻¹)
      (comp pre-E post-E)
      (λ E m R → trans (post-E-inv _) (cong (λ x → run↺ (E x) R) (pre-E-inv _)))
      (comp-pres-sem-sec pre-E⁻¹ post-E⁻¹)

module PostNegSec (prgDist : PrgDist) ep where
  open EncParams ep
  open Comp ep |M| |C| hiding (Tr)
  open CompSec prgDist ep |M| |C|
  open FunSemSec prgDist
  open SemSecReductions ep ep

  post-neg : Tr
  post-neg = comp id vnot

  post-neg-pres-sem-sec : SemSecTr id post-neg
  post-neg-pres-sem-sec = comp-pres-sem-sec id vnot

  post-neg-pres-sem-sec⁻¹ : SemSecTr⁻¹ id post-neg
  post-neg-pres-sem-sec⁻¹ = comp-pres-sem-sec⁻¹ id id (λ _ → refl) vnot vnot vnot∘vnot

module Concrete k where
  open program-distance.Implem k
  module Guess' = bit-guessing-game prgDist
  module FunSemSec' = FunSemSec prgDist
  module CompSec' = CompSec prgDist

module composition-sem-sec-reduction where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP using (_,_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable
open import flat-funs
open import program-distance
open import one-time-semantic-security
import bit-guessing-game

-- One focuses on a particular kind of transformation
-- over a cipher, namely pre and post composing functions
-- to a given cipher E.
-- This transformation can change the size of input/output
-- of the given cipher.
module Comp (ep₀ : EncParams) (|M|₁ |C|₁ : ℕ) where
  open EncParams²-same-|R|ᵉ ep₀ |M|₁ |C|₁
  open FlatFunsOps fun♭Ops

  comp : (pre-E : M₁ → M₀) (post-E : C₀ → C₁) → Tr
  comp pre-E post-E E = pre-E >>> E >>> map↺ post-E

-- This module shows how to adapt an adversary that is supposed to break
-- one time semantic security of some cipher E enhanced by pre and post
-- composition to an adversary breaking one time semantic security of the
-- original cipher E.
--
-- The adversary transformation works for any notion of function space
-- (FlatFuns) and the corresponding operations (FlatFunsOps).
-- Because of this abstraction the following construction can be safely
-- instantiated for at least three uses:
--   * When provided with a concrete notion of function like circuits
--     or at least functions over bit-vectors, one get a concrete circuit
--     transformation process.
--   * When provided with a high-level function space with real products
--     then proving properties about the code is made easy.
--   * When provided with a notion of cost such as time or space then
--     one get a the cost of the resulting adversary given the cost of
--     the inputs (adversary...).
module CompRed {t} {T : Set t}
               {♭Funs   : FlatFuns T}
               (♭ops    : FlatFunsOps ♭Funs)
               (ep₀ ep₁ : EncParams) where
  open FlatFuns ♭Funs
  open FlatFunsOps ♭ops
  open AbsSemSec ♭Funs
  open ♭EncParams² ♭Funs ep₀ ep₁ using (`M₀; `C₀; `M₁; `C₁)

  comp-red : (pre-E  : `M₁ `→ `M₀)
             (post-E : `C₀ `→ `C₁)
           → SemSecReduction ep₁ ep₀ _
  comp-red pre-E post-E (mk A₀ A₁) =
    mk (A₀ >>> (pre-E *** pre-E) *** idO) (post-E *** idO >>> A₁)

module CompSec (prgDist : PrgDist) (ep₀ : EncParams) (|M|₁ |C|₁ : ℕ) where
  open PrgDist prgDist
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist
  open AbsSemSec fun♭Funs
  open EncParams²-same-|R|ᵉ ep₀ |M|₁ |C|₁
  open SemSecReductions ep₀ ep₁ id
  open CompRed fun♭Ops ep₀ ep₁

  private
    module Comp-implicit {x y z} = Comp x y z
  open Comp-implicit public

  comp-pres-sem-sec : ∀ pre-E post-E → SemSecTr (comp pre-E post-E)
  comp-pres-sem-sec pre-E post-E = comp-red pre-E post-E , λ E A → id

  comp-pres-sem-sec⁻¹ : ∀ pre-E pre-E⁻¹
                          (pre-E-right-inv : pre-E ∘ pre-E⁻¹ ≗ id)
                          post-E post-E⁻¹
                          (post-E-left-inv : post-E⁻¹ ∘ post-E ≗ id)
                        → SemSecTr⁻¹ (comp pre-E post-E)
  comp-pres-sem-sec⁻¹ pre-E pre-E⁻¹ pre-E-inv post-E post-E⁻¹ post-E-inv =
    SemSecTr→SemSecTr⁻¹
      (comp pre-E⁻¹ post-E⁻¹)
      (comp pre-E post-E)
      (λ E m R → trans (post-E-inv _) (cong (λ x → run↺ (E x) R) (pre-E-inv _)))
      (comp-pres-sem-sec pre-E⁻¹ post-E⁻¹)

module PostNegSec (prgDist : PrgDist) ep where
  open EncParams ep
  open EncParams² ep ep using (Tr)
  open CompSec prgDist ep |M| |C|
  open FunSemSec prgDist
  open SemSecReductions ep ep id

  post-neg : Tr
  post-neg = comp id vnot

  post-neg-pres-sem-sec : SemSecTr post-neg
  post-neg-pres-sem-sec = comp-pres-sem-sec id vnot

  post-neg-pres-sem-sec⁻¹ : SemSecTr⁻¹ post-neg
  post-neg-pres-sem-sec⁻¹ = comp-pres-sem-sec⁻¹ id id (λ _ → refl) vnot vnot vnot∘vnot≗id

module Concrete k where
  open program-distance.Implem k
  module Guess-prgDist     = bit-guessing-game prgDist
  module FunSemSec-prgDist = FunSemSec prgDist
  module CompSec-prgDist   = CompSec prgDist

Rework composition-sem-sec-reduction.agda


module Thesis.ANormalDTerm where

open import Thesis.ANormal

{-
Try defining an alternative syntax for differential terms. We'll need this for
cache terms. Maybe?

Options:

1. use standard untyped lambda calculus as a target language. This requires much
more weakening in the syntax, which is a nuisance in proofs. Maybe use de Bruijn
levels instead?

2. use a specialized syntax as a target language.

3. use separate namespaces, environments, and so on?

Also, caching uses quite a bit of sugar on top of lambda calculus, with pairs
and what not.
-}

{-
-- To define an alternative syntax for the derivation output, let's remember that:
derive (var x) = dvar dx
derive (let y = f x in t) = let y = f x ; dy = df x dx in derive t
-}

-- Attempt 1 leads to function calls in datatype indexes. That's very very bad!
module Try1 where

-- data DTerm : (Γ : Context) (τ : Type) → Set where
--   dvar : ∀ {Γ τ} (x : Var Γ τ) →
--     DTerm (ΔΓ Γ) (Δt τ)
--   dlett : ∀ {Γ σ τ₁ τ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) → DTerm (Δt τ₁ • τ₁ • ΔΓ Γ) (Δt τ) → DTerm (ΔΓ Γ) (Δt τ)

-- derive-dterm : ∀ {Γ τ} → Term Γ τ → DTerm (ΔΓ Γ) (Δt τ)
-- derive-dterm (var x) = dvar x
-- derive-dterm (lett f x t) = dlett f x (derive-dterm t)

-- Case split on dt FAILS!
-- ⟦_⟧DTerm : ∀ {Γ τ} → DTerm (ΔΓ Γ) (Δt τ) → ⟦ ΔΓ Γ ⟧Context → ⟦ Δt τ ⟧Type
-- ⟦ dt ⟧DTerm ρ = {!dt!}

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

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = ⟦ ΔΔ Δ ⟧Context

-- changeStructureΔ : ∀ Δ → ChangeStructure ⟦ Δ ⟧Context
-- changeStructureΔ = {!!}
-- ch_from_to_ {{changeStructureΔ Δ}}
-- [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set
-- [ ∅ ]Δ ∅ from ∅ to ∅ = ⊤
-- [ τ • Δ ]Δ dv • dρ from v1 • ρ1 to (v2 • ρ2) = [ τ ]τ dv from v1 to v2 × [ Δ ]Δ dρ from ρ1 to ρ2

-- Δ is bound to the change type! Not good!
data [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set where
  v∅ : [ ∅ ]Δ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Δ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Δ ]Δ dρ from ρ1 to ρ2) →
    [ τ • Δ ]Δ (dv • dρ) from (v1 • ρ1) to (v2 • ρ2)

module Try3 where
  derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
  derive-dvar this = this
  derive-dvar (that x) = that (derive-dvar x)

  fromtoDeriveDVar : ∀ {Δ τ} → (x : Var Δ τ) →
    ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ derive-dvar x ⟧Var dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
  fromtoDeriveDVar this (dvv v• dρρ) = dvv
  fromtoDeriveDVar (that x) (dvv v• dρρ) = fromtoDeriveDVar x dρρ

  -- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
  -- a result of type (Δt τ).
  data DTerm : (Δ : Context) (τ : Type) → Set where
    dvar : ∀ {Δ τ} (x : Var (ΔΔ Δ) (Δt τ)) →
      DTerm Δ τ
    dlett : ∀ {Δ τ σ τ₁} →
      (f : Var Δ (σ ⇒ τ₁)) →
      (x : Var Δ σ) →
      (t : Term (τ₁ • Δ) τ) →
      (df : Var (ΔΔ Δ) (Δτ (σ ⇒ τ₁))) →
      (dx : Var (ΔΔ Δ) (Δτ σ)) →
      (dt : DTerm (τ₁ • Δ) τ) →
      DTerm Δ τ

  data DFun (Δ : Context) : (τ : Type) → Set where
    dterm : ∀ {τ} → DTerm Δ τ → DFun Δ τ
    dabs : ∀ {σ τ} → DFun (σ • Δ) τ → DFun Δ (σ ⇒ τ)

  derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ
  derive-dterm (var x) = dvar (derive-dvar x)
  derive-dterm (lett f x t) =
    dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

  ⟦_⟧DTerm : ∀ {Δ τ} → DTerm Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
  ⟦ dvar x ⟧DTerm ρ dρ = ⟦ x ⟧Var dρ
  ⟦ dlett f x t df dx dt ⟧DTerm ρ dρ =
    let v = (⟦ x ⟧Var ρ)
    in
      ⟦ dt ⟧DTerm
        (⟦ f ⟧Var ρ v • ρ)
        (⟦ df ⟧Var dρ v (⟦ dx ⟧Var dρ) • dρ)

  fromtoDeriveDTerm : ∀ {Δ τ} → (t : Term Δ τ) →
    ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ derive-dterm t ⟧DTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
  fromtoDeriveDTerm (var x) dρρ = fromtoDeriveDVar x dρρ
  fromtoDeriveDTerm (lett f x t) dρρ =
    let fromToF = fromtoDeriveDVar f dρρ
        fromToX = fromtoDeriveDVar x dρρ
        fromToFX = fromToF _ _ _ fromToX
    in fromtoDeriveDTerm t (fromToFX v• dρρ)

  derive-dfun : ∀ {Δ σ} → (t : Fun Δ σ) → DFun Δ σ
  derive-dfun (term t) = dterm (derive-dterm t)
  derive-dfun (abs f) = dabs (derive-dfun f)

  ⟦_⟧DFun : ∀ {Δ τ} → DFun Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
  ⟦ dterm t ⟧DFun = ⟦ t ⟧DTerm
  ⟦ dabs df ⟧DFun ρ dρ = λ v dv → ⟦ df ⟧DFun (v • ρ) (dv • dρ)

  fromtoDeriveDFun : ∀ {Δ τ} → (f : Fun Δ τ) →
    ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ derive-dfun f ⟧DFun ρ1 dρ) from (⟦ f ⟧Fun ρ1) to (⟦ f ⟧Fun ρ2)
  fromtoDeriveDFun (term t) = fromtoDeriveDTerm t
  fromtoDeriveDFun (abs f) dρρ = λ dv v1 v2 dvv → fromtoDeriveDFun f (dvv v• dρρ)

module Try2 where
  -- This is literally isomorphic to the source type :-| derivation is part of erasure...
  data DTerm : (Γ : Context) (τ : Type) → Set where
    dvar : ∀ {Γ τ} (x : Var Γ τ) →
      DTerm Γ τ
  --  dlett : ∀ {Γ σ τ₁ τ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) → DTerm (Δt τ₁ • τ₁ • ΔΓ Γ) (Δt τ) → DTerm (ΔΓ Γ) (Δt τ)

    dlett : ∀ {Γ τ σ τ₁} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
      DTerm (τ₁ • Γ) τ →
      DTerm Γ τ

  derive-dterm : ∀ {Γ τ} → Term Γ τ → DTerm Γ τ
  derive-dterm (var x) = dvar x
  derive-dterm (lett f x t) = dlett f x (derive-dterm t)

  -- Incremental semantics over terms. Same results as base semantics over change
  -- terms. But less weakening.
  ⟦_⟧DTerm : ∀ {Γ τ} → DTerm Γ τ → ⟦ ΔΓ Γ ⟧Context → ⟦ Δt τ ⟧Type
  ⟦ dvar x ⟧DTerm dρ = ⟦ derive-var x ⟧Var dρ
  ⟦ dlett f x dt ⟧DTerm dρ =
    let ρ = ⟦ Γ≼ΔΓ ⟧≼ dρ
    in ⟦ dt ⟧DTerm
      ( ⟦ derive-var f ⟧Var dρ (⟦ x ⟧Var ρ) (⟦ derive-var x ⟧Var dρ)
      • ⟦ f ⟧Var ρ (⟦ x ⟧Var ρ)
      • dρ)

module Thesis.ANormalDTerm where

open import Thesis.ANormal

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

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = ⟦ ΔΔ Δ ⟧Context

-- [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set
-- [ ∅ ]Δ ∅ from ∅ to ∅ = ⊤
-- [ τ • Δ ]Δ dv • dρ from v1 • ρ1 to (v2 • ρ2) = [ τ ]τ dv from v1 to v2 × [ Δ ]Δ dρ from ρ1 to ρ2

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

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

fromtoDeriveDVar : ∀ {Δ τ} → (x : Var Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dvar x ⟧Var dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveDVar this (dvv v• dρρ) = dvv
fromtoDeriveDVar (that x) (dvv v• dρρ) = fromtoDeriveDVar x dρρ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm : (Δ : Context) (τ : Type) → Set where
  dvar : ∀ {Δ τ} (x : Var (ΔΔ Δ) (Δt τ)) →
    DTerm Δ τ
  dlett : ∀ {Δ τ σ τ₁} →
    (f : Var Δ (σ ⇒ τ₁)) →
    (x : Var Δ σ) →
    (t : Term (τ₁ • Δ) τ) →
    (df : Var (ΔΔ Δ) (Δτ (σ ⇒ τ₁))) →
    (dx : Var (ΔΔ Δ) (Δτ σ)) →
    (dt : DTerm (τ₁ • Δ) τ) →
    DTerm Δ τ

data DFun (Δ : Context) : (τ : Type) → Set where
  dterm : ∀ {τ} → DTerm Δ τ → DFun Δ τ
  dabs : ∀ {σ τ} → DFun (σ • Δ) τ → DFun Δ (σ ⇒ τ)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

⟦_⟧DTerm : ∀ {Δ τ} → DTerm Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦ dvar x ⟧DTerm ρ dρ = ⟦ x ⟧Var dρ
⟦ dlett f x t df dx dt ⟧DTerm ρ dρ =
  let v = (⟦ x ⟧Var ρ)
  in
    ⟦ dt ⟧DTerm
      (⟦ f ⟧Var ρ v • ρ)
      (⟦ df ⟧Var dρ v (⟦ dx ⟧Var dρ) • dρ)

fromtoDeriveDTerm : ∀ {Δ τ} → (t : Term Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dterm t ⟧DTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDeriveDTerm (var x) dρρ = fromtoDeriveDVar x dρρ
fromtoDeriveDTerm (lett f x t) dρρ =
  let fromToF = fromtoDeriveDVar f dρρ
      fromToX = fromtoDeriveDVar x dρρ
      fromToFX = fromToF _ _ _ fromToX
  in fromtoDeriveDTerm t (fromToFX v• dρρ)

derive-dfun : ∀ {Δ σ} → (t : Fun Δ σ) → DFun Δ σ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

⟦_⟧DFun : ∀ {Δ τ} → DFun Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦ dterm t ⟧DFun = ⟦ t ⟧DTerm
⟦ dabs df ⟧DFun ρ dρ = λ v dv → ⟦ df ⟧DFun (v • ρ) (dv • dρ)

fromtoDeriveDFun : ∀ {Δ τ} → (f : Fun Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dfun f ⟧DFun ρ1 dρ) from (⟦ f ⟧Fun ρ1) to (⟦ f ⟧Fun ρ2)
fromtoDeriveDFun (term t) = fromtoDeriveDTerm t
fromtoDeriveDFun (abs f) dρρ = λ dv v1 v2 dvv → fromtoDeriveDFun f (dvv v• dρρ)

remove bad experiments

ANormalDTerm: remove bad experiments


{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function using (flip; _∘_)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Data.Two
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Constructions
open import Algebra.Group.Homomorphism
import ZK.SigmaProtocol.KnownStatement
import ZK.GroupHom
open import ZK.GroupHom.Types

module ZK.GroupHom.ElGamal
  (G+ G* : Type)
  (𝔾+ : Group G+)
  (𝔾* : Group G*)
  (_==_ : G* → G* → 𝟚)
  (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
  (==-✓ : ∀ {x y} → ✓ (x == y) → x ≡ y)
  (_^_ : G* → G+ → G*)
  (^-hom : ∀ b → GroupHomomorphism 𝔾+ 𝔾* (_^_ b))
  (g : G*)
  where

  open Additive-Group 𝔾+
  open Multiplicative-Group 𝔾* hiding (_^_)

-- TODO: Re-use another module
  module ElGamal-encryption where
    record CipherText : Type where
      constructor _,_
      field
        α β : G*

    PubKey  = G*
    PrivKey = G+
    EncRnd  = G+ {- randomness used for encryption of ct -}
    Message = G* {- plain text message -}

    enc : PubKey → EncRnd → Message → CipherText
    enc y r M = α , β where
      α = g ^ r
      β = (y ^ r) * M

    dec : PrivKey → CipherText → Message
    dec x ct = (α ^ x)⁻¹ * β where
      open CipherText ct

  open ElGamal-encryption

  -- CP : (g₀ g₁ u₀ u₁ : G) (w : ℤq) → Type
  -- CP g₀ g₁ u₀ u₁ w = (g₀ ^ w ≡ u₀) × (g₁ ^ w ≡ u₁)

  -- CP : (g₀ g₁ u₀ u₁ : G*) (w : G+) → Type
  -- CP g₀ g₁ u₀ u₁ w = ✓ (((g₀ ^ w) == u₀) ∧ ((g₁ ^ w) == u₁))

  module _ (y  : PubKey)
           (M  : Message)
           (ct : CipherText)
           where
    module CT = CipherText ct

    KnownEncRnd : EncRnd → Type
    KnownEncRnd r = enc y r M ≡ ct

    known-enc-rnd : GrpHom _ _ KnownEncRnd
    known-enc-rnd = record
      { 𝔾+ = 𝔾+
      ; 𝔾* = Product.×-grp 𝔾* 𝔾*
      ; _==_ = λ x y → fst x == fst y ∧ snd x == snd y
      ; ✓-== = λ e → ✓∧ (✓-== (ap fst e)) (✓-== (ap snd e))
      ; ==-✓ = λ e → let p = ✓∧× e in
                     ap₂ _,_ (==-✓ (fst p))
                             (==-✓ (snd p))
      ; φ = _
      ; φ-hom = Pair.pair-hom _ _ _ (_^_ g) (^-hom g)
                                    (_^_ y) (^-hom y)
      ; y = CT.α , CT.β / M
      ; φ⇒P = λ _ e → ap₂ (λ p q → fst p , q) e
                          (ap (flip _*_ M ∘ snd) e ∙ ! /-*)
      ; P⇒φ = λ _ e → ap₂ _,_ (ap CipherText.α e)
                              (*-/ ∙ ap (flip _/_ M) (ap CipherText.β e))
      }

    KnownDec : PrivKey → Type
    KnownDec x = (g ^ x ≡ y) × (dec x ct ≡ M)

    open ≡-Reasoning

    /⁻¹-* : ∀ {x y} → (x / y)⁻¹ * x ≡ y
    /⁻¹-* {x} {y} =
      (x / y)⁻¹ * x        ≡⟨ ap (λ z → z * x) ⁻¹-hom′ ⟩
      y ⁻¹ ⁻¹ * x ⁻¹ * x   ≡⟨ *-assoc ⟩
      y ⁻¹ ⁻¹ * (x ⁻¹ * x) ≡⟨ ap₂ _*_ ⁻¹-involutive (fst ⁻¹-inverse) ⟩
      y * 1#               ≡⟨ *1-identity ⟩
      y                    ∎

    /-⁻¹* : ∀ {x y} → x / (y ⁻¹ * x) ≡ y
    /-⁻¹* {x} {y} =
      x * (y ⁻¹ * x) ⁻¹    ≡⟨ ap (_*_ x) ⁻¹-hom′ ⟩
      x * (x ⁻¹ * y ⁻¹ ⁻¹) ≡⟨ ! *-assoc ⟩
      (x * x ⁻¹) * y ⁻¹ ⁻¹ ≡⟨ *= (snd ⁻¹-inverse) ⁻¹-involutive ⟩
      1# * y               ≡⟨ 1*-identity ⟩
      y                    ∎

    known-dec : GrpHom _ _ KnownDec
    known-dec = record
      { 𝔾+ = 𝔾+
      ; 𝔾* = Product.×-grp 𝔾* 𝔾*
      ; _==_ = λ x y → fst x == fst y ∧ snd x == snd y
      ; ✓-== = λ e → ✓∧ (✓-== (ap fst e)) (✓-== (ap snd e))
      ; ==-✓ = λ e → let p = ✓∧× e in
                     ap₂ _,_ (==-✓ (fst p))
                             (==-✓ (snd p))
      ; φ = _
      ; φ-hom = Pair.pair-hom _ _ _ (_^_ g)    (^-hom g)
                                    (_^_ CT.α) (^-hom CT.α)
      ; y = y , CT.β / M
      ; φ⇒P = λ x e → ap fst e , ap (λ z → z ⁻¹ * CT.β) (ap snd e) ∙ /⁻¹-*
      ; P⇒φ = λ x e → ap₂ _,_ (fst e) (! /-⁻¹* ∙ ap (_/_ CT.β) (snd e))
      }

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

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq
open import Function.NP using (flip; _∘_; it)
open import Data.Product.NP
open import Data.Two hiding (_²)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (idp; _≡_; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Constructions
open import Algebra.Group.Homomorphism
import ZK.GroupHom
open import ZK.GroupHom.Types

module ZK.GroupHom.ElGamal
  (G+ G* : Type)
  (𝔾+ : Group G+)
  (𝔾* : Group G*)
  (G*-eq? : Eq? G*)
  (_^_ : G* → G+ → G*)
  (^-hom : ∀ b → GroupHomomorphism 𝔾+ 𝔾* (_^_ b))
  (g : G*)
  where

module 𝔾* = Group 𝔾*
open Additive-Group 𝔾+
open module MG = Multiplicative-Group 𝔾* hiding (_^_; _²)
module ^ b = GroupHomomorphism (^-hom b)

_² : Type → Type
A ² = A × A

-- TODO: Re-use another module
module ElGamal-encryption where
  PubKey  = G*
  PrivKey = G+
  EncRnd  = G+ {- randomness used for encryption of ct -}
  Message = G* {- plain text message -}
  CipherText = G* × G*

  module CipherText (ct : CipherText) where
    α β : G*
    α = fst ct
    β = snd ct

  pub-of : PrivKey → PubKey
  pub-of sk = g ^ sk

  enc : PubKey → Message → EncRnd → CipherText
  enc y M r = α , β
    module enc where
      α = g ^ r
      β = (y ^ r) * M

  dec : PrivKey → CipherText → Message
  dec sk (α , β) = (α ^ sk)⁻¹ * β

open ElGamal-encryption

open Product

_²-grp : {A : Type} → Group A → Group (A ²)
𝔸 ²-grp = ×-grp 𝔸 𝔸

𝕄 : Group Message
𝕄 = 𝔾*

ℂ𝕋 : Group CipherText
ℂ𝕋 = ×-grp 𝔾* 𝔾*

-- CP : (g₀ g₁ u₀ u₁ : G) (w : ℤq) → Type
-- CP g₀ g₁ u₀ u₁ w = (g₀ ^ w ≡ u₀) × (g₁ ^ w ≡ u₁)

-- CP : (g₀ g₁ u₀ u₁ : G*) (w : G+) → Type
-- CP g₀ g₁ u₀ u₁ w = ✓ (((g₀ ^ w) == u₀) ∧ ((g₁ ^ w) == u₁))

module Known-enc-rnd
         (y  : PubKey)
         (M  : Message)
         (ct : CipherText)
         where
  module ct = CipherText ct

  Valid-witness : EncRnd → Type
  Valid-witness r = enc y M r ≡ ct

  zk-hom : ZK-hom _ _ Valid-witness
  zk-hom = record
    { φ-hom = < ^-hom g , ^-hom y >-hom
    ; y = ct.α , ct.β / M
    ; φ⇒P = λ _ e → ap₂ (λ p q → fst p , q) e
                        (ap (flip _*_ M ∘ snd) e ∙ ! /-*)
    ; P⇒φ = λ _ e → ap₂ _,_ (ap fst e)
                            (*-/ ∙ ap (flip _/_ M) (ap snd e))
    }

open ≡-Reasoning

/⁻¹-* : ∀ {x y} → (x / y)⁻¹ * x ≡ y
/⁻¹-* {x} {y} =
  (x / y)⁻¹ * x        ≡⟨ ap (λ z → z * x) ⁻¹-hom′ ⟩
  y ⁻¹ ⁻¹ * x ⁻¹ * x   ≡⟨ *-assoc ⟩
  y ⁻¹ ⁻¹ * (x ⁻¹ * x) ≡⟨ ap₂ _*_ ⁻¹-involutive (fst ⁻¹-inverse) ⟩
  y * 1#               ≡⟨ *1-identity ⟩
  y                    ∎

/-⁻¹* : ∀ {x y} → x / (y ⁻¹ * x) ≡ y
/-⁻¹* {x} {y} =
  x * (y ⁻¹ * x) ⁻¹    ≡⟨ ap (_*_ x) ⁻¹-hom′ ⟩
  x * (x ⁻¹ * y ⁻¹ ⁻¹) ≡⟨ ! *-assoc ⟩
  (x * x ⁻¹) * y ⁻¹ ⁻¹ ≡⟨ *= (snd ⁻¹-inverse) ⁻¹-involutive ⟩
  1# * y               ≡⟨ 1*-identity ⟩
  y                    ∎

x⁻¹y≡1→x≡y : ∀ {x y} → x ⁻¹ * y ≡ 1# → x ≡ y
x⁻¹y≡1→x≡y e = cancels-*-left (fst ⁻¹-inverse ∙ ! e)

module Known-dec
         (y  : PubKey)
         (M  : Message)
         (ct : CipherText)
         where
  module ct = CipherText ct

  Valid-witness : PrivKey → Type
  Valid-witness sk = (g ^ sk ≡ y) × (dec sk ct ≡ M)

  zk-hom : ZK-hom _ _ Valid-witness
  zk-hom = record
    { φ-hom = < ^-hom g , ^-hom ct.α >-hom
    ; y = y , ct.β / M
    ; φ⇒P = λ x e → ap fst e , ap (λ z → z ⁻¹ * ct.β) (ap snd e) ∙ /⁻¹-*
    ; P⇒φ = λ x e → ap₂ _,_ (fst e) (! /-⁻¹* ∙ ap (_/_ ct.β) (snd e))
    }

-- Inverse of ciphertexts
_⁻¹CT : CipherText → CipherText
(α , β)⁻¹CT = α ⁻¹ , β ⁻¹

-- Division of ciphertexts
_/CT_ : CipherText → CipherText → CipherText
(α₀ , β₀) /CT (α₁ , β₁) = (α₀ / α₁) , (β₀ / β₁)

-- TODO: Move this elsewhere (Cipher.ElGamal.Homomorphic)
import Algebra.FunctionProperties.Eq as FP
open FP.Implicits
open import Algebra.Group.Abelian
module From-*-comm
         (*-comm : Commutative _*_)
         where
  private
    module 𝔾*-comm = Abelian-Group-Struct (𝔾*.grp-struct , *-comm)

  hom-enc : (y : PubKey) → GroupHomomorphism (×-grp 𝕄 𝔾+) ℂ𝕋 (uncurry (enc y))
  hom-enc y = mk λ { {M₀ , r₀} {M₁ , r₁} →
    ap₂ _,_ (^.hom _)
        (enc.β y (M₀ * M₁) (r₀ + r₁)   ≡⟨by-definition⟩
         y ^ (r₀ + r₁)     * (M₀ * M₁) ≡⟨ *= (^.hom y) idp ⟩
         (y ^ r₀ * y ^ r₁) * (M₀ * M₁) ≡⟨ 𝔾*-comm.interchange ⟩
         enc.β y M₀ r₀ * enc.β y M₁ r₁ ∎) }

  module hom-enc y = GroupHomomorphism (hom-enc y)

  -- The encryption of the inverse is the inverse of the encryption
  -- (notice that the randomnesses seems to be negated only because we give an additive notation to our G+ group)
  enc-⁻¹ : ∀ {y M r} → enc y (M ⁻¹) (0− r) ≡ enc y M r ⁻¹CT
  enc-⁻¹ = hom-enc.pres-inv _

  -- The encryption of the division is the division of the encryptions
  -- (notice that the randomnesses seems to be subtracted only because we give an additive notation to our G+ group)
  enc-/ : ∀ {y M₀ r₀ M₁ r₁} → enc y (M₀ / M₁) (r₀ − r₁) ≡ enc y M₀ r₀ /CT enc y M₁ r₁
  enc-/ = hom-enc.−-/ _

  -- Alice wants to prove to the public that she encrypted the
  -- same message for two (potentially different) recepients
  -- without revealing the content of the message or the randomness
  -- used for the encryptions.
  module Message-equality-enc
           (y₀  y₁  : PubKey)
           (ct₀ ct₁ : CipherText)
           where
    module ct₀ = CipherText ct₀
    module ct₁ = CipherText ct₁

    Witness = Message × EncRnd ²
    Statement = CipherText ²

    Valid-witness : Witness → Type
    Valid-witness (M , r₀ , r₁) = enc y₀ M r₀ ≡ ct₀ × enc y₁ M r₁ ≡ ct₁

    private
        θ : Message × EncRnd ² → (Message × EncRnd)²
        θ (M , r₀ , r₁) = ((M , r₀) , (M , r₁))

        θ-hom : GroupHomomorphism (×-grp 𝕄 (𝔾+ ²-grp)) ((×-grp 𝕄 𝔾+)²-grp) θ
        θ-hom = mk idp

    φ-hom : GroupHomomorphism _ _ _
    φ-hom = < hom-enc y₀ × hom-enc y₁ >-hom ∘-hom θ-hom

    zk-hom : ZK-hom _ _ Valid-witness
    zk-hom = record
      { φ-hom = φ-hom
      ; y = ct₀ , ct₁
      ; φ⇒P = λ _ e → ap fst e , ap snd e
      ; P⇒φ = λ x e → ap₂ _,_ (fst e) (snd e)
      }

  module From-flip-^-hom
           (flip-^-hom : ∀ x → GroupHomomorphism 𝔾* 𝔾* (flip _^_ x))
         where
    module flip-^ x = GroupHomomorphism (flip-^-hom x)

    hom-dec : (x : PrivKey) → GroupHomomorphism ℂ𝕋 𝕄 (dec x)
    hom-dec x = mk λ { {α₀ , β₀} {α₁ , β₁} →
      dec x (α₀ * α₁ , β₀ * β₁)           ≡⟨by-definition⟩
      ((α₀ * α₁) ^ x)⁻¹ * (β₀ * β₁)       ≡⟨ ap (λ z → _*_ (_⁻¹ z) (_*_ β₀ β₁)) (flip-^.hom x) ⟩
      (α₀ ^ x * α₁ ^ x)⁻¹ * (β₀ * β₁)     ≡⟨ *= 𝔾*-comm.⁻¹-hom idp ⟩
      (α₀ ^ x)⁻¹ * (α₁ ^ x)⁻¹ * (β₀ * β₁) ≡⟨ 𝔾*-comm.interchange ⟩
      dec x (α₀ , β₀) * dec x (α₁ , β₁)   ∎ }

    module hom-dec x = GroupHomomorphism (hom-dec x)

    -- Bob wants to prove to the public that he decrypted two
    -- ciphertexts which decrypt to the same message,
    -- without revealing the content of the message or his
    -- secret key.
    -- The two ciphertexts are encrypted using the same public key.
    module Message-equality-dec
         (y : PubKey)
         (ct₀ ct₁ : CipherText)
         where
      private
        module ct₀ = CipherText ct₀
        module ct₁ = CipherText ct₁

        α/ = ct₀.α / ct₁.α
        β/ = ct₀.β / ct₁.β

      Valid-witness : PrivKey → Type
      Valid-witness sk = pub-of sk ≡ y × dec sk ct₀ ≡ dec sk ct₁

      zk-hom : ZK-hom _ _ Valid-witness
      zk-hom = record
        { φ-hom = < ^-hom g , ^-hom (ct₀.α / ct₁.α) >-hom
        ; y = y , ct₀.β / ct₁.β
        ; φ⇒P = λ x e →
                  ap fst e ,
                  x/y≡1→x≡y
                  (dec x ct₀ / dec x ct₁ ≡⟨ ! hom-dec.−-/ x ⟩
                   dec x (ct₀ /CT ct₁) ≡⟨by-definition⟩
                   dec x (α/ , β/) ≡⟨ ! ap (λ z → dec x (α/ , snd z)) e ⟩
                   dec x (α/ , (α/)^ x) ≡⟨ fst ⁻¹-inverse ⟩
                   1# ∎)
        ; P⇒φ = λ x e → ap₂ _,_ (fst e)
                  (x⁻¹y≡1→x≡y
                     (dec x (α/ , β/)       ≡⟨ hom-dec.−-/ x ⟩
                      dec x ct₀ / dec x ct₁ ≡⟨ /= (snd e) idp ⟩
                      dec x ct₁ / dec x ct₁ ≡⟨ snd ⁻¹-inverse ⟩
                      1#                    ∎))
        }

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

ZK.GroupHom.ElGamal: add proofs of equality of message (two styles)


module Denotational.ValidChanges where

open import Data.Product
open import Data.Unit
open import Relation.Binary.PropositionalEquality

open import Syntactic.Types

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Equivalence

open import Changes

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data ValidΔ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds (valid : ValidΔ s ds) → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}
-- What I had to write:
-- Note: now I could go back to using a datatype, since the datatype is now strictly positive.
Valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
Valid-Δ {bool} v dv = ⊤
Valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds {- (valid-w : Valid-Δ s ds) -} →
    Valid-Δ (f s) (df s ds) ×
    (apply df f) (apply ds s) ≡ apply (df s ds) (f s)

diff-is-valid : ∀ {τ} (v′ v : ⟦ τ ⟧) → Valid-Δ {τ} v (diff v′ v)
diff-is-valid {bool} v′ v = tt
diff-is-valid {τ ⇒ τ₁} v′ v =
  λ s ds →
    diff-is-valid (v′ (apply ds s)) (v s) , (
    begin
      apply (diff v′ v) v (apply ds s)
    ≡⟨ refl ⟩
      apply
        (diff (v′ (apply (derive (apply ds s)) (apply ds s))) (v (apply ds s)))
        (v (apply ds s))
    ≡⟨ ≡-cong (λ x → apply (diff (v′ x) (v (apply ds s))) (v (apply ds s))) (apply-derive (apply ds s)) ⟩
      apply (diff (v′ (apply ds s)) (v (apply ds s))) (v (apply ds s))
    ≡⟨ apply-diff (v (apply ds s)) (v′ (apply ds s)) ⟩
      v′ (apply ds s)
    ≡⟨ sym (apply-diff (v s) (v′ (apply ds s))) ⟩
      apply ((diff v′ v) s ds) (v s)
    ∎) where open ≡-Reasoning

derive-is-valid : ∀ {τ} (v : ⟦ τ ⟧) → Valid-Δ {τ} v (derive v)
derive-is-valid v rewrite sym (diff-derive v) = diff-is-valid v v

-- This is a postulate elsewhere, but here I provide a proper proof.

diff-apply-proof : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
    (Valid-Δ v dv) → diff (apply dv v) v ≡ dv

diff-apply-proof {τ₁ ⇒ τ₂} df f df-valid = ext (λ v → ext (λ dv →
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv)) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ≡⟨ diff-apply-proof {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv)) ⟩
    df v dv
  ∎)) where open ≡-Reasoning

diff-apply-proof {bool} db b _ = xor-cancellative b db

module Denotational.ValidChanges where

open import Data.Product
open import Data.Unit
open import Relation.Binary.PropositionalEquality

open import Syntactic.Types

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Equivalence

open import Changes

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data Valid-Δ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}

-- What I had to write:
-- Note: now I could go back to using a datatype, since the datatype is now strictly positive.
Valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
Valid-Δ {bool} v dv = ⊤
Valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds {- (valid-w : Valid-Δ s ds) -} →
    Valid-Δ (f s) (df s ds) ×
    (apply df f) (apply ds s) ≡ apply (df s ds) (f s)

diff-is-valid : ∀ {τ} (v′ v : ⟦ τ ⟧) → Valid-Δ {τ} v (diff v′ v)
diff-is-valid {bool} v′ v = tt
diff-is-valid {τ ⇒ τ₁} v′ v =
  λ s ds →
    diff-is-valid (v′ (apply ds s)) (v s) , (
    begin
      apply (diff v′ v) v (apply ds s)
    ≡⟨ refl ⟩
      apply
        (diff (v′ (apply (derive (apply ds s)) (apply ds s))) (v (apply ds s)))
        (v (apply ds s))
    ≡⟨ ≡-cong (λ x → apply (diff (v′ x) (v (apply ds s))) (v (apply ds s))) (apply-derive (apply ds s)) ⟩
      apply (diff (v′ (apply ds s)) (v (apply ds s))) (v (apply ds s))
    ≡⟨ apply-diff (v (apply ds s)) (v′ (apply ds s)) ⟩
      v′ (apply ds s)
    ≡⟨ sym (apply-diff (v s) (v′ (apply ds s))) ⟩
      apply ((diff v′ v) s ds) (v s)
    ∎) where open ≡-Reasoning

derive-is-valid : ∀ {τ} (v : ⟦ τ ⟧) → Valid-Δ {τ} v (derive v)
derive-is-valid v rewrite sym (diff-derive v) = diff-is-valid v v

-- This is a postulate elsewhere, but here I provide a proper proof.

diff-apply-proof : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
    (Valid-Δ v dv) → diff (apply dv v) v ≡ dv

diff-apply-proof {τ₁ ⇒ τ₂} df f df-valid = ext (λ v → ext (λ dv →
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv)) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ≡⟨ diff-apply-proof {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv)) ⟩
    df v dv
  ∎)) where open ≡-Reasoning

diff-apply-proof {bool} db b _ = xor-cancellative b db

agda: Update alternative definition of Valid-Δ

Rationale for maintaining this alternative definition: If all proofs
go through with the current definition of Valid-Δ, which can be
expressed as a datatype, we'll switch to defining it with a datatype.

Old-commit-hash: a21df87af1c12f4d94d3710d37e6e4eedfcc83b0


data Bool : Set where
  true  : Bool
  false : Bool

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘ = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

modusponens : ℕ → Arrow → Arrow
modusponens n (⇒ q)   = (⇒ q)
modusponens n (p ⇒ q) with (n ≡ p)
...                      | true  = modusponens n q
...                      | false = p ⇒ (modusponens n q)

reduce : ℕ → List Arrow → List Arrow
reduce n ∘ = ∘
reduce n (arr ∷ rst) = (modusponens n arr) ∷ (reduce n rst)

search : List Arrow → List ℕ
search ∘ = ∘
search ((⇒ n) ∷ rst)   = n ∷ (search (reduce n rst))
search ((n ⇒ q) ∷ rst) with (n ∈ (search rst))
...                       | true  = search (q ∷ rst)
...                       | false = search rst

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q) = q ∈ (search cs)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

Add turnstile

Add turnstile


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {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 Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily ⟦_⟧Base

module Structure {{change-algebra-base : Structure}} where
  -- change algebras

  open CA public renaming
    -- Constructors for All′
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  instance
    change-algebra : ∀ τ → ChangeAlgebra ⟦ τ ⟧Type
    change-algebra (base ι) = change-algebra₍ ι ₎
    change-algebra (τ₁ ⇒ τ₂) = changeAlgebraFun {{change-algebra τ₁}} {{change-algebra τ₂}}

    change-algebra-family : ChangeAlgebraFamily ⟦_⟧Type
    change-algebra-family = family change-algebra

  -- function changes

  module _ {τ₁ τ₂ : Type} where
    open FunctionChange {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebraListChanges to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍ Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍_₎ Γ

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {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 Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily ⟦_⟧Base

module Structure {{change-algebra-base : Structure}} where
  -- change algebras

  open CA public renaming
    -- Constructors for All′
    ( [] to ∅
    ; _∷_ to _•_
    )

  change-algebra : ∀ τ → ChangeAlgebra ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = changeAlgebraFun {{change-algebra τ₁}} {{change-algebra τ₂}}

  -- We provide: change algebra for every type
  instance
    change-algebra-family : ChangeAlgebraFamily ⟦_⟧Type
    change-algebra-family = family change-algebra

  -- function changes

  module _ {τ₁ τ₂ : Type} where
    open FunctionChange {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebraListChanges to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍ Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍_₎ Γ

Disable unused instance

Disable unused instance

Agda will not infer explicit arguments of instance arguments. On the
other hand, trying to make this into a proper instance (with an implicit
argument) makes typechecking too much slower or not terminating (more
precisely, on some modules typechecking took longer than I wanted to
wait and I didn't investigate further).