Added missing file.

Added missing file.

Ignore-this: f74085bc0060648712fb8cd9c6f11adc

darcs-hash:20100603041857-3bd4e-c1a3cff4fc9c542799499c761f9921a31a08829b.gz

------------------------------------------------------------------------------
-- Inequalities on partial natural numbers
------------------------------------------------------------------------------

module LTC.Relation.InequalitiesPCF where

open import LTC.Minimal

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

-- Version using lambda-abstraction.
-- lth : D → D
-- lth lt = lam (λ m → lam (λ n →
--               if (isZero n) then false
--                  else (if (isZero m) then true
--                           else (lt ∙ (pred m) ∙ (pred n)))))

-- Version using lambda lifting via super-combinators.
-- (Hughes. Super-combinators. 1982)

lt-aux₁ : D → D → D → D
lt-aux₁ d lt e = if (isZero e) then false
                    else (if (isZero d) then true
                          else (lt ∙ (pred d) ∙ (pred e)))
{-# ATP definition lt-aux₁ #-}

lt-aux₂ : D → D → D
lt-aux₂ lt d = lam (lt-aux₁ d lt)
{-# ATP definition lt-aux₂ #-}

lth : D → D
lth lt = lam (lt-aux₂ lt)
{-# ATP definition lth #-}

lt : D → D → D
lt d e = fix lth ∙ d ∙ e
{-# ATP definition lt #-}

gt : D → D → D
gt d e = lt e d
{-# ATP definition gt #-}

------------------------------------------------------------------------
-- The data types

-- infix 4 _≤_ _<_ _≥_ _>_

GT : D → D → Set
GT d e = lt e d ≡ true
{-# ATP definition GT #-}

LT : D → D  → Set
LT d e = lt d e ≡ true
{-# ATP definition LT #-}

LE : D → D → Set
LE d e = lt e d ≡ false
{-# ATP definition LE #-}

GE : D → D → Set
GE d e = lt d e ≡ false
{-# ATP definition GE #-}

------------------------------------------------------------------------------
-- The lexicographical order
LT₂ : D → D → D → D → Set
LT₂ x₁ y₁ x₂ y₂ = LT x₁ x₂ ∨ x₁ ≡ x₂ ∧ LT y₁ y₂
{-# ATP definition LT₂ #-}

error: pathspec 'LTC/Relation/InequalitiesPCF.agda' did not match any file(s) known to git


Some work on thre ballot

Some work on thre ballot

module ThreeBallot
   -- ()
   where

open import Data.Fin using (Fin ; zero ; suc )
open import Data.Nat
open import Data.Bool.NP using (toℕ) renaming (false to 0b ; true to 1b)

open import Data.List using (List ; [] ; _∷_ ; length)
open import Data.Bits hiding (toℕ ; 0b ; 1b)

open import Data.Vec.NP renaming (map to vmap)
open import Data.Product

import Function.Inverse.NP as Inv
open Inv using (_↔_; _∘_; sym; id; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)

import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_ ; refl)

data Cand : Set where
  Nice'Guy Bad'Guy : Cand

Vote = Bits 2
Tag  = ℕ

record Ballot : Set where
  constructor mk
  field
    vote : Vote
    tag  : Tag

open Ballot

record 3'_ (A : Set) : Set where
  constructor [_][_][_]
  field
    1t 2t 3t : A

3Vote = 3' Vote
3Ballot = 3' Ballot

[_][_] : Bit → Bit → Bits 2
[ x ][ y ] = x ∷ y ∷ []

svote : Vote
svote = [ 0b ][ 1b ]

example : 3Vote
example = [ [ 1b ][ 0b ] ][ [ 0b ][ 1b ] ][ [ 0b ][ 1b ] ]

row-const : Bit → 3' Bit → Set
row-const b [ 1t ][ 2t ][ 3t ] = 1 + toℕ b ≡ toℕ 1t + toℕ 2t + toℕ 3t

voteFor : Vote → 3Vote → Set
voteFor (n ∷ b ∷ []) [ x ∷ x₁ ∷ [] ][ x₂ ∷ x₃ ∷ [] ][ x₄ ∷ x₅ ∷ [] ] = row-const n [ x ][ x₂ ][ x₄ ]
                                                                     × row-const b [ x₁ ][ x₃ ][ x₅ ]

vote-example : voteFor svote example
vote-example = refl , refl

cast : (_ _ : Vote) → Vote
cast i r = vnot r

vote-any : (intent receipt : Vote) → voteFor intent [ intent ][ receipt ][ cast intent receipt ]
vote-any (true ∷ true ∷ []) (true ∷ true ∷ []) = refl , refl
vote-any (true ∷ true ∷ []) (true ∷ false ∷ []) = refl , refl
vote-any (true ∷ true ∷ []) (false ∷ true ∷ []) = refl , refl
vote-any (true ∷ true ∷ []) (false ∷ false ∷ []) = refl , refl
vote-any (true ∷ false ∷ []) (true ∷ true ∷ []) = refl , refl
vote-any (true ∷ false ∷ []) (true ∷ false ∷ []) = refl , refl
vote-any (true ∷ false ∷ []) (false ∷ true ∷ []) = refl , refl
vote-any (true ∷ false ∷ []) (false ∷ false ∷ []) = refl , refl
vote-any (false ∷ true ∷ []) (true ∷ true ∷ []) = refl , refl
vote-any (false ∷ true ∷ []) (true ∷ false ∷ []) = refl , refl
vote-any (false ∷ true ∷ []) (false ∷ true ∷ []) = refl , refl
vote-any (false ∷ true ∷ []) (false ∷ false ∷ []) = refl , refl
vote-any (false ∷ false ∷ []) (true ∷ true ∷ []) = refl , refl
vote-any (false ∷ false ∷ []) (true ∷ false ∷ []) = refl , refl
vote-any (false ∷ false ∷ []) (false ∷ true ∷ []) = refl , refl
vote-any (false ∷ false ∷ []) (false ∷ false ∷ []) = refl , refl

{-

NP :

  (R?×V)^n → (3V)^n → (3B)^n → B^3n -⟨ shuffle ⟩→ b^3n → T

-}

Perm : ℕ → Set
Perm n = Fin n ↔ Fin n

shuffle : ∀ {n}{A : Set} → Perm n → Vec A n → Vec A n
shuffle p xs = tabulate (λ i → lookup (to p i) xs)

module _
  (tally : ∀ {n} → Vec Vote n → ℕ)
  (tally-stable : ∀ {n} vs π → tally {n} vs ≡ tally (shuffle π vs))
  where

  3-tally : ∀ {n} → Vec Ballot (3 * n) → ℕ
  3-tally {n} bs = tally (vmap vote bs) ∸ n

  lookup-map : ∀ {n}{A B : Set}(f : A → B)(i : Fin n)(xs : Vec A n)
             → f (lookup i xs) ≡ lookup i (vmap f xs)
  lookup-map f zero (x ∷ xs) = refl
  lookup-map f (suc i) (x ∷ xs) = lookup-map f i xs

  -- map g (tabulate f) = tabulate (g ∘ f)
  -- f (lookup i xs) ≡ lookup i (map f xs)
  3-tally-stable : ∀ {n} bs π → 3-tally {n} bs ≡ 3-tally {n} (shuffle π bs)
  3-tally-stable {n} bs p rewrite tally-stable (vmap vote bs) p
                           | ≡.sym (tabulate-ext (λ i → lookup-map vote (to p i) bs))
                           = ≡.cong (λ p₁ → tally p₁ ∸ n) (tabulate-∘ _ _)

{-
  Ballot privacy ☺
-}

module BallotPrivacy
  (RA : Set)
  where

  data Msg : Set where
    vote! : (intent receipt : Vote) → Msg
    stop! : Msg

  Resp = List Ballot

  Adv₀ = RA → Vote
  Adv₁ = RA → Resp → Msg
  Adv₂ = RA → (l : Resp) → Vec Ballot (3 * length l) → Bit

  Adv = Adv₀ × Adv₁ × Adv₂

  G : Adv → (∀ {n} → Perm n) → RA → Bit →  Bit
  G (A₀ , A₁ , A₂) π Ra b = {!!} where
    ε = A₀ Ra

    go : (r : Resp) → Vec Ballot (3 * length r) → Bit
    go r bb with A₁ Ra r | b
    go r bb | vote! intent receipt | 1b = {!!}
    go r bb | vote! intent receipt | 0b = {!!}
    go r bb | stop!                | _ = A₂ Ra r (shuffle π bb)

3<4 : 3 < 4
3<4 =  s≤s (s≤s (s≤s (s≤s z≤n)))

error: pathspec 'ThreeBallot.agda' did not match any file(s) known to git


+Algebra/FunctionProperties/Eq

+Algebra/FunctionProperties/Eq

{-# OPTIONS --without-K #-}
-- Like Algebra.FunctionProperties but specialized to _≡_ and using implict arguments

-- These properties can (for instance) be used to define algebraic
-- structures.

open import Level
open import Data.Product
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP

-- The properties are specified using the following relation as
-- "equality".

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

------------------------------------------------------------------------
-- Unary and binary operations

open import Algebra.FunctionProperties.Core public

------------------------------------------------------------------------
-- Properties of operations

Associative : Op₂ A → Set _
Associative _·_ = ∀ {x y z} → ((x · y) · z) ≡ (x · (y · z))

Commutative : Op₂ A → Set _
Commutative _·_ = ∀ {x y} → (x · y) ≡ (y · x)

LeftIdentity : A → Op₂ A → Set _
LeftIdentity e _·_ = ∀ {x} → (e · x) ≡ x

RightIdentity : A → Op₂ A → Set _
RightIdentity e _·_ = ∀ {x} → (x · e) ≡ x

Identity : A → Op₂ A → Set _
Identity e · = LeftIdentity e · × RightIdentity e ·

LeftZero : A → Op₂ A → Set _
LeftZero z _·_ = ∀ {x} → (z · x) ≡ z

RightZero : A → Op₂ A → Set _
RightZero z _·_ = ∀ {x} → (x · z) ≡ z

Zero : A → Op₂ A → Set _
Zero z · = LeftZero z · × RightZero z ·

LeftInverse : A → Op₁ A → Op₂ A → Set _
LeftInverse e _⁻¹ _·_ = ∀ {x} → (x ⁻¹ · x) ≡ e

RightInverse : A → Op₁ A → Op₂ A → Set _
RightInverse e _⁻¹ _·_ = ∀ {x} → (x · (x ⁻¹)) ≡ e

Inverse : A → Op₁ A → Op₂ A → Set _
Inverse e ⁻¹ · = LeftInverse e ⁻¹ · × RightInverse e ⁻¹ ·

_DistributesOverˡ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverˡ _+_ =
  ∀ {x y z} → (x * (y + z)) ≡ ((x * y) + (x * z))

_DistributesOverʳ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverʳ _+_ =
  ∀ {x y z} → ((y + z) * x) ≡ ((y * x) + (z * x))

_DistributesOver_ : Op₂ A → Op₂ A → Set _
* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +)

_IdempotentOn_ : Op₂ A → A → Set _
_·_ IdempotentOn x = (x · x) ≡ x

Idempotent : Op₂ A → Set _
Idempotent · = ∀ {x} → · IdempotentOn x

IdempotentFun : Op₁ A → Set _
IdempotentFun f = ∀ {x} → f (f x) ≡ f x

_Absorbs_ : Op₂ A → Op₂ A → Set _
_·_ Absorbs _∘_ = ∀ {x y} → (x · (x ∘ y)) ≡ x

Absorptive : Op₂ A → Op₂ A → Set _
Absorptive · ∘ = (· Absorbs ∘) × (∘ Absorbs ·)

Involutive : Op₁ A → Set _
Involutive f = ∀ {x} → f (f x) ≡ x

Interchange : Op₂ A → Op₂ A → Set _
Interchange _·_ _∘_ = ∀ {x y z t} → ((x · y) ∘ (z · t)) ≡ ((x ∘ z) · (y ∘ t))

LeftCancel : Op₂ A → Set _
LeftCancel _·_ = ∀ {c x y} → c · x ≡ c · y → x ≡ y

RightCancel : Op₂ A → Set _
RightCancel _·_ = ∀ {c x y} → x · c ≡ y · c → x ≡ y

module InterchangeFromAssocComm
         (_·_     : Op₂ A)
         (·-assoc : Associative _·_)
         (·-comm  : Commutative _·_)
         where

    open ≡-Reasoning

    ·= : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → (x · y) ≡ (x' · y')
    ·= refl refl = refl

    ·-interchange : Interchange _·_ _·_
    ·-interchange {x} {y} {z} {t}
                = (x · y) · (z · t)
                ≡⟨ ·-assoc ⟩
                  x · (y · (z · t))
                ≡⟨ ·= refl (! ·-assoc) ⟩
                  x · ((y · z) · t)
                ≡⟨ ·= refl (·= ·-comm refl) ⟩
                  x · ((z · y) · t)
                ≡⟨ ·= refl ·-assoc ⟩
                  x · (z · (y · t))
                ≡⟨ ! ·-assoc ⟩
                  (x · z) · (y · t)
                ∎
-- -}
-- -}
-- -}
-- -}

error: pathspec 'lib/Algebra/FunctionProperties/Eq.agda' did not match any file(s) known to git


Added setoids draft.

Added setoids draft.

Ignore-this: 972580c96ceed8e6215d40030ce46100

darcs-hash:20110325220333-3bd4e-876f32f3d7f06dac74e8b78ec17c08dfc48b947b.gz

------------------------------------------------------------------------------
-- Using setoids to formalize the FOTC
------------------------------------------------------------------------------

module Setoid where

-- We add 3 to the fixities of the standard library.
infixl 9 _·_  -- The symbol is '\cdot'.
infix  7 _≐_

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

data D : Set where
  K S : D
  _·_ : D → D → D

data _≐_ : D → D → Set where
  refl  : ∀ x →                                       x ≐ x
  sym   : ∀ {x y} → x ≐ y →                           y ≐ x
  trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
  Kax   : ∀ x y →                            K · x · y  ≐ x
  Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

-- It seems we cannot define the identity elimination using the setoid
-- equality
subst : ∀ {x y} (P : D → Set) → x ≐ y → P x → P y
subst P x≐y Px = {!!}

error: pathspec 'Draft/Setoid.agda' did not match any file(s) known to git


Agda: add another bug example

Agda: add another bug example

Old-commit-hash: 82f681165ed59ccc36685cbf9c376026811e127f

module Future where

open import Denotational.Notation

-- Uses too much memory.
-- open import Data.Integer

open import Data.Product
open import Data.Sum
open import Data.Unit

postulate ⟦Int⟧ : Set
postulate ⟦Bag⟧ : Set → Set

--mutual
-- First, define a language of types, their denotations, and then the whole algebra of changes in the semantic domain
data Type : Set
⟦_⟧Type : Type → Set

data Type where
  Int : Type
  --Bag : Type → Type
  _⇒_ {- _⊠_ _⊞_ -} : Type → Type → Type
  Δ : (τ : Type) → (old : ⟦ τ ⟧Type) → Type

-- meaningOfType : Meaning Type
-- meaningOfType = meaning ⟦_⟧Type

-- Try out Δ old here

Change : (τ : Type) → ⟦ τ ⟧Type → Set
Change Int old₁ = {!!}
-- Change (Bag τ₁) old₁    = ⟦ Bag τ₁ ⟧Type ⊎ (Σ[ old ∈ (⟦ τ₁ ⟧Type) ] (⟦Bag⟧ ⟦ Δ τ₁ old ⟧Type))
Change (τ₁ ⇒ τ₂) oldF   = ⟦ Δ τ₂ (oldF ?) ⟧Type
-- oldF ? -- oldF ? -- (oldInput : ⟦ τ₁ ⟧Type) → ⟦ Δ τ₁ oldInput ⟧Type → ⟦ Δ τ₂ (oldF oldInput) ⟧Type
-- Change (τ₁ ⊠ τ₂) old₁ = {!⟦ τ₁ ⟧Type × ⟦ τ₂ ⟧Type!}
-- Change (τ₁ ⊞ τ₂) old₁ = {!!}
Change (Δ τ₁ old₁) old₂ = {!!}

⟦ Int ⟧Type = ⟦Int⟧
-- ⟦ Bag τ ⟧Type = ⟦Bag⟧ ⟦ τ ⟧Type
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
-- ⟦ σ ⊠ τ ⟧Type = ⟦ σ ⟧Type × ⟦ τ ⟧Type
-- ⟦ σ ⊞ τ ⟧Type = ⟦ σ ⟧Type ⊎ ⟦ τ ⟧Type
⟦ Δ τ old ⟧Type = {- ⊤ ⊎ ⟦ τ ⟧Type ⊎ -} Change τ old

error: pathspec 'bugs/Future.agda' did not match any file(s) known to git


Add FiniteField/JS

Add FiniteField/JS

{-# OPTIONS --without-K #-}
open import Function.NP
open import FFI.JS using (Number; Bool; true; false; String; warn-check; check; trace-call; _++_)
open import FFI.JS.BigI
open import Data.List.Base hiding (sum; _++_)
{-
open import Algebra.Raw
open import Algebra.Field
-}

module FiniteField.JS (q : BigI) where

abstract
  ℤq : Set
  ℤq = BigI

  private
    mod-q : BigI → ℤq
    mod-q x = mod x q

  -- There is two ways to go from BigI to ℤq: check and mod-q
  -- Use check for untrusted input data and mod-q for internal
  -- computation.
  BigI▹ℤq : BigI → ℤq
  BigI▹ℤq = -- trace-call "BigI▹ℤq "
    λ x →
    mod-q
      (warn-check (x <I q)
         (λ _ → "Not below the modulus: " ++ toString q ++ " < " ++ toString x)
         (warn-check (x ≥I 0I)
            (λ _ → "Should be positive: " ++ toString x ++ " < 0") x))

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

  repr : ℤq → BigI
  repr x = x

  0# 1# : ℤq
  0# = 0I
  1# = 1I

  1/_ : Op₁ ℤq
  1/ x = modInv (check-non-zero x) q

  _^_ : Op₂ ℤq
  x ^ y = modPow (repr x) (repr y) q

_+_ _−_ _*_ _/_ : Op₂ ℤq

x + y = mod-q (add      (repr x) (repr y))
x − y = mod-q (subtract (repr x) (repr y))
x * y = mod-q (multiply (repr x) (repr y))
x / y = x * 1/ y

0−_ : Op₁ ℤq
0− x = mod-q (negate (repr x))

_==_ : (x y : ℤq) → Bool
x == y = equals (repr x) (repr y)

sum prod : List ℤq → ℤq
sum  = foldr _+_ 0#
prod = foldr _*_ 1#

{-
+-mon-ops : Monoid-Ops ℤq
+-mon-ops = _+_ , 0#

+-grp-ops : Group-Ops ℤq
+-grp-ops = +-mon-ops , 0−_

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

*-grp-ops : Group-Ops ℤq
*-grp-ops = *-mon-ops , 1/_

fld-ops : Field-Ops ℤq
fld-ops = +-grp-ops , *-grp-ops

postulate
  fld-struct : Field-Struct fld-ops

fld : Field ℤq
fld = fld-ops , fld-struct
-- -}
-- -}
-- -}
-- -}
-- -}

error: pathspec 'FiniteField/JS.agda' did not match any file(s) known to git


created Head to ask for help

created Head to ask for help

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong₂; _≢_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List using (List; []; _∷_; dropWhile)
open import Data.Char using (Char)
open import Data.Bool using (Bool; true; false)
import Data.Char as Char using (_≟_)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)

data Head {A : Set} (P : A → Bool) : List A → Set where
  head : ∀ (c : A) (s : List A) → P c ≡ true → Head P (c ∷ s)

prime : Char
prime = '′'

isPrime : Char → Bool
isPrime c = ⌊ c Char.≟ prime ⌋

head-lemma : ∀ (s : List Char) → ¬ Head isPrime (dropWhile isPrime s)
head-lemma [] = λ()
head-lemma (c ∷ s) with isPrime c
...                   | true       =  head-lemma s
...                   | false      =  ¬h
  where
  ¬h : ¬ Head isPrime (c ∷ s)
  ¬h (head c s eqn′) = {!!}

{-
Goal: ⊥
————————————————————————————————————————————————————————————
s    : List Char
c    : Char
eqn′ : ⌊ (c Char.≟ '′' | .Agda.Builtin.Char.primCharEquality c '′')
       ⌋
       ≡ true
s    : List Char
c    : Char
-}

error: pathspec 'src/extra/Head.agda' did not match any file(s) known to git


open import Function.Related.TypeIsomorphisms.NP
open import Function.Inverse.NP
open import Data.Maybe.NP
open import Data.Nat

open import Search.Type
open import Search.Searchable
open import Search.Searchable.Sum

module Search.Searchable.Maybe where

μMaybe : ∀ {A} → Searchable A → Searchable (Maybe A)
μMaybe μA = μ-iso (sym Maybe↔⊤⊎) (μ⊤ ⊎-μ μA)

μMaybe^ : ∀ {A} n → Searchable A → Searchable (Maybe^ n A)
μMaybe^ zero    μA = μA
μMaybe^ (suc n) μA = μMaybe (μMaybe^ n μA)

error: pathspec 'Search/Searchable/Maybe.agda' did not match any file(s) known to git


ZK.GroupHom.NumChal: using an abstract type of natural number

{-# OPTIONS --without-K #-}
open import Type using (Type; Type₁)
open import Function using (flip)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum.NP
open import Data.Zero
open import Data.Fin.NP using (Fin▹ℕ)
open import Data.Bool.Base using (Bool) renaming (T to ✓)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; idp; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Homomorphism
import Data.Nat.ModInv
import ZK.SigmaProtocol.KnownStatement
import ZK.GroupHom

module ZK.GroupHom.NumChal where

record Package : Type₁ where
  infixl 6 _+ⁿ_ _∸ⁿ_
  infixl 7 _*ⁿ_
  field
    Num : Type
    Prime : Num → Type
    _<_ : (x y : Num) → Type
    0ⁿ  : Num
    1ⁿ  : Num
    _+ⁿ_ : (x y : Num) → Num
    _∸ⁿ_ : (x y : Num) → Num
    _*ⁿ_ : (x y : Num) → Num
    compare : Trichotomous _≡_ _<_
    <-∸≢0 : ∀ x y → y < x → x ∸ⁿ y ≢ 0ⁿ

    G+ G* : Type
    𝔾+ : Group G+
    𝔾* : Group G*

  _>_ : (x y : Num) → Type
  _>_ = flip _<_

  open Additive-Group 𝔾+ public
  open Multiplicative-Group 𝔾* public

  field
    _==_ : G* → G* → Bool
    ✓-== : ∀ {x y} → x ≡ y → ✓ (x == y)
    ==-✓ : ∀ {x y} → ✓ (x == y) → x ≡ y

    _⊗ⁿ_ : G+ → Num → G+
    _^ⁿ_ : G* → Num → G*
    1^ⁿ : ∀ x → 1# ^ⁿ x ≡ 1#

    φ : G+ → G*
    φ-hom : GroupHomomorphism 𝔾+ 𝔾* φ
    φ-hom-iterated : ∀ {x c} → φ (x ⊗ⁿ c) ≡ φ x ^ⁿ c

    q : Num
    q-prime : Prime q

    _div-q : Num → Num
    _mod-q : Num → Num
    div-mod-q-propⁿ : ∀ d → d ≡ d mod-q +ⁿ (d div-q) *ⁿ q

    inv-mod-q : Num → Num
    inv-mod-q-prop : ∀ x → x ≢ 0ⁿ → (inv-mod-q x *ⁿ x)mod-q ≡ 1ⁿ

    Y : G*

    -- Can be turned into a dynamic test!
    G*-order : Y ^ⁿ q ≡ 1#

    ^ⁿ1ⁿ+ⁿ : ∀ {x} → Y ^ⁿ(1ⁿ +ⁿ x) ≡ Y * Y ^ⁿ x
    ^ⁿ-*  : ∀ {x y} → Y ^ⁿ(y *ⁿ x) ≡ (Y ^ⁿ x)^ⁿ y
    ^ⁿ-∸ⁿ : ∀ {c₀ c₁}(c> : c₀ > c₁) → Y ^ⁿ(c₀ ∸ⁿ c₁) ≡ (Y ^ⁿ c₀) / (Y ^ⁿ c₁)

module FromPackage (p : Package) where
  open Package p
  open ≡-Reasoning

  private
    module φ = GroupHomomorphism φ-hom
    module 𝔾* = Group 𝔾*

  Y^-^-1/-id : ∀ {x y} → x > y → (Y ^ⁿ(x ∸ⁿ y))^ⁿ(inv-mod-q(x ∸ⁿ y)) ≡ Y
  Y^-^-1/-id {x} {y} x>y
    = (Y ^ⁿ d)^ⁿ(inv-mod-q d) ≡⟨ ! ^ⁿ-* ⟩
      Y ^ⁿ(inv-mod-q d *ⁿ d)  ≡⟨ ap (_^ⁿ_ Y) (div-mod-q-propⁿ e) ⟩
      Y ^ⁿ(r +ⁿ m *ⁿ q)        ≡⟨ ap (λ z → Y ^ⁿ(z +ⁿ m *ⁿ q)) (inv-mod-q-prop d (<-∸≢0 x y x>y)) ⟩
      Y ^ⁿ(1ⁿ +ⁿ(m *ⁿ q))      ≡⟨ ^ⁿ1ⁿ+ⁿ ⟩
      Y * Y ^ⁿ(m *ⁿ q)        ≡⟨ *= idp ^ⁿ-* ⟩
      Y * (Y ^ⁿ q)^ⁿ m        ≡⟨ ap (λ z → Y * z ^ⁿ m) G*-order ⟩
      Y * 1# ^ⁿ m            ≡⟨ *= idp (1^ⁿ m) ⟩
      Y * 1#                 ≡⟨ *1-identity ⟩
      Y ∎
      where d = x ∸ⁿ y
            e = inv-mod-q d *ⁿ d
            m = e div-q
            r = e mod-q

  swap? : {c₀ c₁ : Num} → c₀ ≢ c₁ → (c₀ > c₁) ⊎ (c₁ > c₀)
  swap? {x} {y} i with compare x y
  swap? i | tri< a ¬b ¬c = inr a
  swap? i | tri> ¬a ¬b c = inl c
  swap? i | tri≈ ¬a b ¬c = 𝟘-elim (i b)

  open ZK.GroupHom 𝔾+ 𝔾* _==_ ✓-== ==-✓ _>_ swap? _⊗ⁿ_ _^ⁿ_ _∸ⁿ_ inv-mod-q
                   φ φ-hom φ-hom-iterated
                   Y
                   ^ⁿ-∸ⁿ
                   Y^-^-1/-id
    public

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

error: pathspec 'ZK/GroupHom/NumChal.agda' did not match any file(s) known to git


Try proving fundamental theorem in simpler context

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "A verified framework for
-- higher-order uncurrying optimizations" (and a bit by "Functional Big-Step
-- Semantics"), though I deviate somewhere.
module Thesis.FunBigStepSILR where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool! (Commented out until I paste that semantics here.)
-- eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
--   eval t ρ n ≡ Done v →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

-- apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
--   ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
--   apply f a n ≡ Done v →
--   ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
-- apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

-- eval-sound ρ v zero t ()
-- eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
-- eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
-- eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
-- eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
-- eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
--   let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
-- eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
-- eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- -- eval-sound n (const c) eq = {!!}
-- -- eval-sound n (var x) eq = {!!}
-- -- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- -- eval-sound n (abs t) eq = {!!}
-- -- eval-sound n (const c) eq = {!!}
-- -- eval-sound n (var x) eq = {!!}
-- -- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- -- eval-sound n (abs t) eq = {!!}

relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

-- Indexing not according to source. But I can't quite write the correct
-- indexing without changing the definitions a lot.
relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
relT {τ} t1 t2 ρ1 ρ2 n =
  (v1 : Val τ) →
  eval t1 ρ1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (eval t2 ρ2 n ≡ Done v2 × relV τ v1 v2 n)

relV τ v1 v2 zero = ⊤
relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) =
  ∀ (k : ℕ) (k≤n : k ≤ n) →
  ∀ v1 v2 → relV σ v1 v2 k → relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
relV nat v1 v2 (suc n) = v1 ≡ v2

open import Data.Nat.Properties

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono zero n m≤n τ v1 v2 vv = tt
relV-mono (suc m) zero () τ v1 v2 vv
relV-mono (suc m) (suc n) m≤n nat v1 v2 vv = vv
relV-mono (suc m) (suc n) (_≤_.s≤s m≤n) (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) vv k k≤m = vv k (DecTotalOrder.trans decTotalOrder k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

-- relV-mono τ v1 v2 vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k ?

-- relV-mono : ∀ τ v1 v2 n → relV τ v1 v2 (suc n) → relV τ v1 v2 n
-- relV-mono τ v1 v2 zero vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k (≤-step k≤n)

-- fundamental lemma of logical relations.
fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero _ _ _ _ ()
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 refl = v2 , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ v ()
-- XXX trivial case for constants.
fundamental (const (lit nv)) (suc n) ρ1 ρ2 ρρ .(intV nv) refl = intV nv , refl , refl
fundamental (var x) (suc n) ρ1 ρ2 ρρ v1 refl = fundamentalV x (suc n) ρ1 ρ2 ρρ (⟦ x ⟧Var ρ1) refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ (closure .t .ρ1) refl =
  closure t ρ2 , refl , λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k _ (≤-step k≤n) _ _ _ ρρ)
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 with eval s ρ1 n | inspect (eval s ρ1) n | eval t ρ1 n
-- TODO: match sv2 before matching on fundamental s.
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq ] | Done tv1 with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq
fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq ] | Done tv1 | (sv2 , sρ2↓sv2 , svv) = v2 , {!!}
  where
    v2 : Val τ
    v2 = {!!}
    -- tρ2↓v2 : apply sv2 tv2 n ≡ Done v1
    -- tρ2↓v2 = ?
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv | _ | TimeOut
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | Done tv1
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | TimeOut

error: pathspec 'Thesis/FunBigStepSILR.agda' did not match any file(s) known to git


NCE: draft of non-commiting encryption

NCE: draft of non-commiting encryption

{- Separating Random Oracle Proofs from
   Complexity Theoretic Proofs:
   The Non-committing Encryption Case

NCE: Non-committing Encryption
-}

open import Function
open import Type using (★)
open import Data.Product
open import Data.One
open import Data.Two
open import Control.Beh

module Game.NCE
  (MId PId Msg Len : ★)
  (length : Msg → Len)
  (A : PId) -- adversary PId
  (F : PId) -- functionality PId (Fnce)
  where

S : 𝟚 → ★
S = [0: MId × PId × Msg
     1: MId × PId × PId × Len ]

Ideal-Fnce' : Beh PId 𝟙 𝟙 𝟙 (S 0₂) (Σ 𝟚 S) 𝟙
Ideal-Fnce' = input (λ { i (mid , j , msg) →
                 output j (0₂ , mid , i , msg)
                  (output A (1₂ , mid , i , j , length msg)
                   end) })

Ideal-Fnce : Beh PId 𝟙 𝟙 𝟙 (Σ 𝟚 S) (Σ 𝟚 S) 𝟙
Ideal-Fnce = input (λ i m →
               case m of λ
               { (0₂ , mid , j , msg) →
                 output j (0₂ , mid , i , msg)
                  (output A (1₂ , mid , i , j , length msg)
                   end)
               ; (1₂ , _) → end
               })

PlainText = Σ 𝟚 S
module Real
  (SecKey PubKey Rₑ CipherText : ★)
  (pk  : PId → PubKey)
  (Enc : PubKey → Rₑ → PlainText → CipherText)
  (Dec : SecKey → CipherText → PlainText)
  where

    Real-Fnce : Beh PId SecKey 𝟙 Rₑ CipherText CipherText 𝟙
    Real-Fnce =
     input λ i c →
      ask λ sk →
       case Dec sk c of λ
       { (0₂ , (mid , j , m)) →
        rand λ rₑ →
         output j (Enc (pk j) rₑ (0₂ , mid , i , m))
          (rand λ rₑ →
            output A
              (Enc (pk A) rₑ (1₂ , mid , i , j , length m))
            end)
       ; (1₂ , _) → end
       }

module Sim where
  open Sim[E=𝟙,R=1] {PId} {𝟙} {Σ 𝟚 S} {Σ 𝟚 S} {𝟙}
    public

  end-end : end ≈ end
  end-end = return-return _

module DummyCrypto where
  open Real 𝟙 𝟙 𝟙 (Σ 𝟚 S) (const _) (λ _ _ m → m) (λ _ m → m)
  open Sim

  p : Ideal-Fnce ≈ Real-Fnce
  p = input-input (λ i m → nop-ask (helper i m)) where
    helper : (i : PId) (m : Σ 𝟚 S) → _ ≈ _
    helper i (0₂ , m) =
      nop-rand
        (output-output
           (nop-rand
              (output-output end-end)))
    helper i (1₂ , m) =
      end-end
-- -}

error: pathspec 'Game/NCE.agda' did not match any file(s) known to git


Added information for the thesis.

Added information for the thesis.

module Erasing where

postulate
  D     : Set
  succ₁ : D → D

data N : D → Set where
  nsucc₁ : ∀ {n} → N n → N (succ₁ n)
  nsucc₂ : ∀ {n} → (Nn : N n) → N (succ₁ n)

-- The types of nsucc₁ and nsucc₂ are the same.

-- (18 April 2013)
-- $ dump-agdai Erasing

-- Qname: Erasing.N.nsucc₁
-- Type: El {getSort = Type (Max []), unEl = Pi []r{El {getSort = Type (Max []), unEl = Def Erasing.D []}} (Abs "n" El {getSort = Type (Max []), unEl = Pi []r(El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Var 0 [])]}) (NoAbs "_" El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Def Erasing.succ₁ [[]r(Var 0 [])])]})})}

-- Qname: Erasing.N.nsucc₂
-- Type: El {getSort = Type (Max []), unEl = Pi []r{El {getSort = Type (Max []), unEl = Def Erasing.D []}} (Abs "n" El {getSort = Type (Max []), unEl = Pi []r(El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Var 0 [])]}) (NoAbs "Nn" El {getSort = Type (Max []), unEl = Def Erasing.N [[]r(Def Erasing.succ₁ [[]r(Var 0 [])])]})})}

error: pathspec 'notes/thesis/CombiningProofs/Erasing.agda' did not match any file(s) known to git


Drop superseded TODO

Drop superseded TODO

The NewNew proof is MUCH simpler.

module New.Correctness where

open import Function hiding (const)
open import New.Lang
open import New.Changes
open import New.Derive
open import New.LangChanges
open import New.LangOps
open import New.FunctionLemmas
open import New.Unused

⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
  ρ ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ ∅ ∅ tt = refl
⟦Γ≼ΔΓ⟧ (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ ρdρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
  ⟦ t ⟧Term ρ ≡ ⟦ fit t ⟧Term dρ
fit-sound t ρ dρ ρdρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ ρ dρ ρdρ))
  (sym (weaken-sound t _))

validDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  validΓ ρ dρ → valid (⟦ x ⟧Var ρ) (⟦ x ⟧ΔVar ρ dρ)

validDeriveVar this (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = vdv
validDeriveVar (that x) (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = validDeriveVar x ρ dρ ρdρ

correctDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  IsDerivative ⟦ x ⟧Var (⟦ x ⟧ΔVar)
correctDeriveVar this (v • ρ) (dv • v' • dρ) ρdρ = refl
correctDeriveVar (that x) (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = correctDeriveVar x ρ dρ ρdρ

validDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
    valid (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
correctDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  IsDerivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm

-- module _ {t1 t2 t3 : Type}
--   (f : ⟦ t1 ⟧Type → ⟦ t3 ⟧Type)
--   (df : Cht (t1 ⇒ t3))
--   (g : ⟦ t2 ⟧Type → ⟦ t3 ⟧Type)
--   (dg : Cht (t2 ⇒ t3))
--   where
--   private
--     Γ = sum t1 t2 •
--       (t2 ⇒ Δt t2 ⇒ Δt t3) •
--       (t2 ⇒ t3) •
--       (t1 ⇒ Δt t1 ⇒ Δt t3) •
--       (t1 ⇒ t3) •
--       sum (sum (Δt t1) (Δt t2)) (sum t1 t2) •
--       sum t1 t2 • ∅
--   module _ where
--     private
--       Γ′ = t2 • (t2 ⇒ Δt t2 ⇒ Δt t3) • (t2 ⇒ t3) • Γ
--       Γ′′ = t2 • Γ′
--     changeMatchSem-lem1 :
--       ∀ a1 b2 →
--         ⟦ match ⟧ΔConst (inj₁ a1) (inj₂ (inj₂ b2)) f df g dg
--       ≡
--         g b2 ⊕ dg b2 (nil b2) ⊝ f a1
--     changeMatchSem-lem1 a1 b2 rewrite ominusτ-equiv-ext t2 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl
--   module _ where
--     private
--       Γ′ = t1 • (t1 ⇒ Δt t1 ⇒ Δt t3) • (t1 ⇒ t3) • Γ
--       Γ′′ = t1 • Γ′
--     changeMatchSem-lem2 :
--       ∀ b1 a2 →
--         ⟦ match ⟧ΔConst (inj₂ b1) (inj₂ (inj₁ a2)) f df g dg
--       ≡
--         f a2 ⊕ df a2 (nil a2) ⊝ g b1
--     changeMatchSem-lem2 b1 a2 rewrite ominusτ-equiv-ext t1 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl

validDeriveConst : ∀ {τ} (c : Const τ) → valid ⟦ c ⟧Const (⟦_⟧ΔConst c)
correctDeriveConst : ∀ {τ} (c : Const τ) → ⟦ c ⟧Const ≡ ⟦ c ⟧Const ⊕ (⟦_⟧ΔConst c)
correctDeriveConst plus = ext (λ m → ext (lemma m))
  where
    lemma : ∀ m n → m + n ≡ m + n + (m + - m + (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m + n) = refl

correctDeriveConst minus = ext (λ m → ext (λ n → lemma m n))
  where
    lemma : ∀ m n → m - n ≡ m - n + (m + - m - (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m - n) = refl
correctDeriveConst cons = ext (λ v1 → ext (λ v2 → sym (update-nil (v1 , v2))))
correctDeriveConst fst = ext (λ vp → sym (update-nil (proj₁ vp)))
correctDeriveConst snd = ext (λ vp → sym (update-nil (proj₂ vp)))
-- correctDeriveConst linj = ext (λ va → sym (cong inj₁ (update-nil va)))
-- correctDeriveConst rinj = ext (λ vb → sym (cong inj₂ (update-nil vb)))
-- correctDeriveConst (match {t1} {t2} {t3}) = ext³ lemma
--   where
--     lemma : ∀ s f g →
--       ⟦ match {t1} {t2} {t3} ⟧Const s f g ≡
--       (⟦ match ⟧Const ⊕ ⟦ match ⟧ΔConst) s f g
--     lemma (inj₁ x) f g rewrite update-nil x | update-nil (f x) = refl
--     lemma (inj₂ y) f g rewrite update-nil y | update-nil (g y) = refl

validDeriveConst {τ = t1 ⇒ t2 ⇒ pair .t1 .t2} cons = binary-valid (λ a da ada b db bdb → (ada , bdb)) dcons-eq
  where
    open BinaryValid ⟦ cons {t1} {t2} ⟧Const (⟦ cons ⟧ΔConst)
    dcons-eq : binary-valid-eq-hp
    dcons-eq a da ada b db bdb rewrite update-nil (a ⊕ da) | update-nil (b ⊕ db) = refl
validDeriveConst fst (a , b) (da , db) (ada , bdb) = ada , update-nil (a ⊕ da)
validDeriveConst snd (a , b) (da , db) (ada , bdb) = bdb , update-nil (b ⊕ db)

validDeriveConst plus = binary-valid (λ a da ada b db bdb → tt) dplus-eq
  where
    open BinaryValid ⟦ plus ⟧Const (⟦ plus ⟧ΔConst)
    dplus-eq : binary-valid-eq-hp
    dplus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da + (b + db)) = mn·pq=mp·nq {a} {da} {b} {db}
validDeriveConst minus = binary-valid (λ a da ada b db bdb → tt) dminus-eq
  where
    open BinaryValid ⟦ minus ⟧Const (⟦ minus ⟧ΔConst)
    dminus-eq : binary-valid-eq-hp
    dminus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da - (b + db)) | sym (-m·-n=-mn {b} {db}) = mn·pq=mp·nq {a} {da} { - b} { - db}
-- validDeriveConst linj a da ada = sv₁ a da ada , cong inj₁ (update-nil (a ⊕ da))
-- validDeriveConst rinj b db bdb = sv₂ b db bdb , cong inj₂ (update-nil (b ⊕ db))
-- validDeriveConst (match {t1} {t2} {t3}) =
--   ternary-valid dmatch-valid dmatch-eq
--   where
--     open TernaryValid {{chAlgt (sum t1 t2)}} {{chAlgt (t1 ⇒ t3)}} {{chAlgt (t2 ⇒ t3)}} {{chAlgt t3}} ⟦ match ⟧Const (⟦ match ⟧ΔConst)

--     dmatch-valid : ternary-valid-preserve-hp
--     dmatch-valid .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg = proj₁ (fdf a da ada)
--     dmatch-valid .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg = proj₁ (gdg b db bdb)
--     dmatch-valid .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem1 f df g dg a1 b2
--       = ⊝-valid (f a1) (g b2 ⊕ dg b2 (nil b2))
--     dmatch-valid .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem2 f df g dg b1 a2
--       = ⊝-valid (g b1) (f a2 ⊕ df a2 (nil a2))
--     dmatch-eq : ternary-valid-eq-hp
--     dmatch-eq .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg
--       rewrite update-nil (a ⊕ da)
--       | update-nil (f (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))) = proj₂ (fdf a da ada)
--     dmatch-eq .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg
--       rewrite update-nil (b ⊕ db)
--       | update-nil (g (b ⊕ db) ⊕ dg (b ⊕ db) (nil (b ⊕ db))) = proj₂ (gdg b db bdb)
--     dmatch-eq .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem1 f df g dg a1 b2
--       | update-nil b2
--       | update-diff (g b2 ⊕ dg b2 (nil b2)) (f a1)
--       | update-nil (g b2 ⊕ dg b2 (nil b2))
--       = refl
--     dmatch-eq .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem2 f df g dg b1 a2
--       | update-nil a2
--       | update-diff (f a2 ⊕ df a2 (nil a2)) (g b1)
--       | update-nil (f a2 ⊕ df a2 (nil a2))
--       = refl

correctDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = correctDeriveConst c
correctDerive (var x) ρ dρ ρdρ = correctDeriveVar x ρ dρ ρdρ
correctDerive (app s t) ρ dρ ρdρ rewrite sym (fit-sound t ρ dρ ρdρ) =
  let
    open ≡-Reasoning
    a0 = ⟦ t ⟧Term ρ
    da0 = ⟦ derive t ⟧Term dρ
    a0da0 = validDerive t ρ dρ ρdρ
  in
    begin
      ⟦ s ⟧Term (ρ ⊕ dρ) (⟦ t ⟧Term (ρ ⊕ dρ))
    ≡⟨ correctDerive s ρ dρ ρdρ ⟨$⟩ correctDerive t ρ dρ ρdρ ⟩
      (⟦ s ⟧Term ρ ⊕ ⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ ⊕ ⟦ t ⟧ΔTerm ρ dρ)
    ≡⟨ proj₂ (validDerive s ρ dρ ρdρ a0 da0 a0da0)  ⟩
      ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ) ⊕ (⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
    ∎
  where
    open import Theorem.CongApp
correctDerive (abs t) ρ dρ ρdρ = ext $ λ a →
  let
    open ≡-Reasoning
    ρ1 = a • ρ
    dρ1 = nil a • a • dρ
    ρ1dρ1 = nil-valid a , refl , ρdρ
  in
    -- equal-future-expand-derivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm (correctDerive t)
    --   ρ1 dρ1 ρ1dρ1
    --   (a • (ρ ⊕ dρ))
    --   (cong (_• ρ ⊕ dρ) (sym (update-nil a)))
    begin
      ⟦ t ⟧Term (a • ρ ⊕ dρ)
    ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (sym (update-nil a)) ⟩
      ⟦ t ⟧Term (ρ1 ⊕ dρ1)
    ≡⟨ correctDerive t ρ1 dρ1 ρ1dρ1 ⟩
      ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
    ∎

validDerive (app s t) ρ dρ ρdρ =
  let
    f = ⟦ s ⟧Term ρ
    df = ⟦ derive s ⟧Term dρ
    v = ⟦ t ⟧Term ρ
    dv = ⟦ derive t ⟧Term dρ
    vdv = validDerive t ρ dρ ρdρ
    fdf = validDerive s ρ dρ ρdρ
    fvdfv = proj₁ (fdf v dv vdv)
  in subst (λ v′ → valid (f v) (df v′ dv)) (fit-sound t ρ dρ ρdρ) fvdfv
validDerive (abs t) ρ dρ ρdρ =
  λ a da ada →
  let
    ρ1 = a ⊕ da • ρ
    dρ1 = nil (a ⊕ da) • (a ⊕ da) • dρ
    ρ2 = a • ρ
    dρ2 = da • a • dρ
    ρ1dρ1 = nil-valid (a ⊕ da) , refl , ρdρ
    ρ2dρ2 = ada , refl , ρdρ
    rdr = validDerive t ρ2 dρ2 ρ2dρ2
    open ≡-Reasoning
   in
     rdr ,
     equal-future-derivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm (correctDerive t)
       ρ1 dρ1 ρ1dρ1
       ρ2 dρ2 ρ2dρ2
       (cong (λ a′ → (a′ • ρ ⊕ dρ)) (update-nil (a ⊕ da)))
validDerive (var x) ρ dρ ρdρ = validDeriveVar x ρ dρ ρdρ
validDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = validDeriveConst c

module New.Correctness where

open import Function hiding (const)
open import New.Lang
open import New.Changes
open import New.Derive
open import New.LangChanges
open import New.LangOps
open import New.FunctionLemmas
open import New.Unused

⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
  ρ ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ ∅ ∅ tt = refl
⟦Γ≼ΔΓ⟧ (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ ρdρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
  ⟦ t ⟧Term ρ ≡ ⟦ fit t ⟧Term dρ
fit-sound t ρ dρ ρdρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ ρ dρ ρdρ))
  (sym (weaken-sound t _))

-- XXX Should try to simply relate the semantics to the nil change, and prove
-- that validity can be carried over, instead of proving separately validity and
-- correctness; elsewhere this does make things simpler.

validDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) →
  validΓ ρ dρ → valid (⟦ x ⟧Var ρ) (⟦ x ⟧ΔVar ρ dρ)

validDeriveVar this (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = vdv
validDeriveVar (that x) (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = validDeriveVar x ρ dρ ρdρ

correctDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  IsDerivative ⟦ x ⟧Var (⟦ x ⟧ΔVar)
correctDeriveVar this (v • ρ) (dv • v' • dρ) ρdρ = refl
correctDeriveVar (that x) (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = correctDeriveVar x ρ dρ ρdρ

validDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : eCh Γ) → validΓ ρ dρ →
    valid (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
correctDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  IsDerivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm

-- module _ {t1 t2 t3 : Type}
--   (f : ⟦ t1 ⟧Type → ⟦ t3 ⟧Type)
--   (df : Cht (t1 ⇒ t3))
--   (g : ⟦ t2 ⟧Type → ⟦ t3 ⟧Type)
--   (dg : Cht (t2 ⇒ t3))
--   where
--   private
--     Γ = sum t1 t2 •
--       (t2 ⇒ Δt t2 ⇒ Δt t3) •
--       (t2 ⇒ t3) •
--       (t1 ⇒ Δt t1 ⇒ Δt t3) •
--       (t1 ⇒ t3) •
--       sum (sum (Δt t1) (Δt t2)) (sum t1 t2) •
--       sum t1 t2 • ∅
--   module _ where
--     private
--       Γ′ = t2 • (t2 ⇒ Δt t2 ⇒ Δt t3) • (t2 ⇒ t3) • Γ
--       Γ′′ = t2 • Γ′
--     changeMatchSem-lem1 :
--       ∀ a1 b2 →
--         ⟦ match ⟧ΔConst (inj₁ a1) (inj₂ (inj₂ b2)) f df g dg
--       ≡
--         g b2 ⊕ dg b2 (nil b2) ⊝ f a1
--     changeMatchSem-lem1 a1 b2 rewrite ominusτ-equiv-ext t2 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl
--   module _ where
--     private
--       Γ′ = t1 • (t1 ⇒ Δt t1 ⇒ Δt t3) • (t1 ⇒ t3) • Γ
--       Γ′′ = t1 • Γ′
--     changeMatchSem-lem2 :
--       ∀ b1 a2 →
--         ⟦ match ⟧ΔConst (inj₂ b1) (inj₂ (inj₁ a2)) f df g dg
--       ≡
--         f a2 ⊕ df a2 (nil a2) ⊝ g b1
--     changeMatchSem-lem2 b1 a2 rewrite ominusτ-equiv-ext t1 Γ′′ | oplusτ-equiv-ext t3 Γ′ | ominusτ-equiv-ext t3 Γ = refl

validDeriveConst : ∀ {τ} (c : Const τ) → valid ⟦ c ⟧Const (⟦_⟧ΔConst c)
correctDeriveConst : ∀ {τ} (c : Const τ) → ⟦ c ⟧Const ≡ ⟦ c ⟧Const ⊕ (⟦_⟧ΔConst c)
correctDeriveConst plus = ext (λ m → ext (lemma m))
  where
    lemma : ∀ m n → m + n ≡ m + n + (m + - m + (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m + n) = refl

correctDeriveConst minus = ext (λ m → ext (λ n → lemma m n))
  where
    lemma : ∀ m n → m - n ≡ m - n + (m + - m - (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m - n) = refl
correctDeriveConst cons = ext (λ v1 → ext (λ v2 → sym (update-nil (v1 , v2))))
correctDeriveConst fst = ext (λ vp → sym (update-nil (proj₁ vp)))
correctDeriveConst snd = ext (λ vp → sym (update-nil (proj₂ vp)))
-- correctDeriveConst linj = ext (λ va → sym (cong inj₁ (update-nil va)))
-- correctDeriveConst rinj = ext (λ vb → sym (cong inj₂ (update-nil vb)))
-- correctDeriveConst (match {t1} {t2} {t3}) = ext³ lemma
--   where
--     lemma : ∀ s f g →
--       ⟦ match {t1} {t2} {t3} ⟧Const s f g ≡
--       (⟦ match ⟧Const ⊕ ⟦ match ⟧ΔConst) s f g
--     lemma (inj₁ x) f g rewrite update-nil x | update-nil (f x) = refl
--     lemma (inj₂ y) f g rewrite update-nil y | update-nil (g y) = refl

validDeriveConst {τ = t1 ⇒ t2 ⇒ pair .t1 .t2} cons = binary-valid (λ a da ada b db bdb → (ada , bdb)) dcons-eq
  where
    open BinaryValid ⟦ cons {t1} {t2} ⟧Const (⟦ cons ⟧ΔConst)
    dcons-eq : binary-valid-eq-hp
    dcons-eq a da ada b db bdb rewrite update-nil (a ⊕ da) | update-nil (b ⊕ db) = refl
validDeriveConst fst (a , b) (da , db) (ada , bdb) = ada , update-nil (a ⊕ da)
validDeriveConst snd (a , b) (da , db) (ada , bdb) = bdb , update-nil (b ⊕ db)

validDeriveConst plus = binary-valid (λ a da ada b db bdb → tt) dplus-eq
  where
    open BinaryValid ⟦ plus ⟧Const (⟦ plus ⟧ΔConst)
    dplus-eq : binary-valid-eq-hp
    dplus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da + (b + db)) = mn·pq=mp·nq {a} {da} {b} {db}
validDeriveConst minus = binary-valid (λ a da ada b db bdb → tt) dminus-eq
  where
    open BinaryValid ⟦ minus ⟧Const (⟦ minus ⟧ΔConst)
    dminus-eq : binary-valid-eq-hp
    dminus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da - (b + db)) | sym (-m·-n=-mn {b} {db}) = mn·pq=mp·nq {a} {da} { - b} { - db}
-- validDeriveConst linj a da ada = sv₁ a da ada , cong inj₁ (update-nil (a ⊕ da))
-- validDeriveConst rinj b db bdb = sv₂ b db bdb , cong inj₂ (update-nil (b ⊕ db))
-- validDeriveConst (match {t1} {t2} {t3}) =
--   ternary-valid dmatch-valid dmatch-eq
--   where
--     open TernaryValid {{chAlgt (sum t1 t2)}} {{chAlgt (t1 ⇒ t3)}} {{chAlgt (t2 ⇒ t3)}} {{chAlgt t3}} ⟦ match ⟧Const (⟦ match ⟧ΔConst)

--     dmatch-valid : ternary-valid-preserve-hp
--     dmatch-valid .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg = proj₁ (fdf a da ada)
--     dmatch-valid .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg = proj₁ (gdg b db bdb)
--     dmatch-valid .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem1 f df g dg a1 b2
--       = ⊝-valid (f a1) (g b2 ⊕ dg b2 (nil b2))
--     dmatch-valid .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem2 f df g dg b1 a2
--       = ⊝-valid (g b1) (f a2 ⊕ df a2 (nil a2))
--     dmatch-eq : ternary-valid-eq-hp
--     dmatch-eq .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg
--       rewrite update-nil (a ⊕ da)
--       | update-nil (f (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))) = proj₂ (fdf a da ada)
--     dmatch-eq .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg
--       rewrite update-nil (b ⊕ db)
--       | update-nil (g (b ⊕ db) ⊕ dg (b ⊕ db) (nil (b ⊕ db))) = proj₂ (gdg b db bdb)
--     dmatch-eq .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem1 f df g dg a1 b2
--       | update-nil b2
--       | update-diff (g b2 ⊕ dg b2 (nil b2)) (f a1)
--       | update-nil (g b2 ⊕ dg b2 (nil b2))
--       = refl
--     dmatch-eq .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
--       rewrite changeMatchSem-lem2 f df g dg b1 a2
--       | update-nil a2
--       | update-diff (f a2 ⊕ df a2 (nil a2)) (g b1)
--       | update-nil (f a2 ⊕ df a2 (nil a2))
--       = refl

correctDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = correctDeriveConst c
correctDerive (var x) ρ dρ ρdρ = correctDeriveVar x ρ dρ ρdρ
correctDerive (app s t) ρ dρ ρdρ rewrite sym (fit-sound t ρ dρ ρdρ) =
  let
    open ≡-Reasoning
    a0 = ⟦ t ⟧Term ρ
    da0 = ⟦ derive t ⟧Term dρ
    a0da0 = validDerive t ρ dρ ρdρ
  in
    begin
      ⟦ s ⟧Term (ρ ⊕ dρ) (⟦ t ⟧Term (ρ ⊕ dρ))
    ≡⟨ correctDerive s ρ dρ ρdρ ⟨$⟩ correctDerive t ρ dρ ρdρ ⟩
      (⟦ s ⟧Term ρ ⊕ ⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ ⊕ ⟦ t ⟧ΔTerm ρ dρ)
    ≡⟨ proj₂ (validDerive s ρ dρ ρdρ a0 da0 a0da0)  ⟩
      ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ) ⊕ (⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
    ∎
  where
    open import Theorem.CongApp
correctDerive (abs t) ρ dρ ρdρ = ext $ λ a →
  let
    open ≡-Reasoning
    ρ1 = a • ρ
    dρ1 = nil a • a • dρ
    ρ1dρ1 = nil-valid a , refl , ρdρ
  in
    -- equal-future-expand-derivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm (correctDerive t)
    --   ρ1 dρ1 ρ1dρ1
    --   (a • (ρ ⊕ dρ))
    --   (cong (_• ρ ⊕ dρ) (sym (update-nil a)))
    begin
      ⟦ t ⟧Term (a • ρ ⊕ dρ)
    ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (sym (update-nil a)) ⟩
      ⟦ t ⟧Term (ρ1 ⊕ dρ1)
    ≡⟨ correctDerive t ρ1 dρ1 ρ1dρ1 ⟩
      ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
    ∎

validDerive (app s t) ρ dρ ρdρ =
  let
    f = ⟦ s ⟧Term ρ
    df = ⟦ derive s ⟧Term dρ
    v = ⟦ t ⟧Term ρ
    dv = ⟦ derive t ⟧Term dρ
    vdv = validDerive t ρ dρ ρdρ
    fdf = validDerive s ρ dρ ρdρ
    fvdfv = proj₁ (fdf v dv vdv)
  in subst (λ v′ → valid (f v) (df v′ dv)) (fit-sound t ρ dρ ρdρ) fvdfv
validDerive (abs t) ρ dρ ρdρ =
  λ a da ada →
  let
    ρ1 = a ⊕ da • ρ
    dρ1 = nil (a ⊕ da) • (a ⊕ da) • dρ
    ρ2 = a • ρ
    dρ2 = da • a • dρ
    ρ1dρ1 = nil-valid (a ⊕ da) , refl , ρdρ
    ρ2dρ2 = ada , refl , ρdρ
    rdr = validDerive t ρ2 dρ2 ρ2dρ2
    open ≡-Reasoning
   in
     rdr ,
     equal-future-derivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm (correctDerive t)
       ρ1 dρ1 ρ1dρ1
       ρ2 dρ2 ρ2dρ2
       (cong (λ a′ → (a′ • ρ ⊕ dρ)) (update-nil (a ⊕ da)))
validDerive (var x) ρ dρ ρdρ = validDeriveVar x ρ dρ ρdρ
validDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = validDeriveConst c


ZK.JSChecker.Proof: shows that the 2 definitions for the verifier of PoK-CP-EG-rnd are equivalent

{-# OPTIONS --without-K #-}
open import ZK.JSChecker using (verify-PoK-CP-EG-rnd; PoK-CP-EG-rnd; module PoK-CP-EG-rnd)
open import FFI.JS.BigI using (BigI)
open import Data.Product using (_,_)
open import Crypto.JS.BigI.FiniteField
open import Crypto.JS.BigI.CyclicGroup
open import Relation.Binary.PropositionalEquality.Base using (_≡_; refl)
import ZK.GroupHom.ElGamal.JS

module ZK.JSChecker.Proof (p q : BigI) (pok : PoK-CP-EG-rnd ℤ[ q ] ℤ[ p ]★) where

open module ^-h = ^-hom p {q} using (_^_)
open module pok = PoK-CP-EG-rnd pok

pf : ZK.GroupHom.ElGamal.JS.known-enc-rnd.verify-transcript p q g y (g ^ m) (α , β) (A , B) (ℤq▹BigI q c) s
   ≡ verify-PoK-CP-EG-rnd p q pok
pf = refl

error: pathspec 'ZK/JSChecker/Proof.agda' did not match any file(s) known to git


ECC/ec-linkable-ring-sig.agda

ECC/ec-linkable-ring-sig.agda

module ec-linkable-ring-sig where

open import Data.Nat  using (ℕ;   zero; suc)
open import Data.Fin  using (Fin; zero; suc; fromℕ)
open import Data.Vec  using (Vec; tabulate; lookup)
open import Data.Bool using (Bool; true; false; if_then_else_)

_‼_ : ∀ {a} {A : Set a} {n} → Vec A n → Fin n → A
v ‼ i = lookup i v

infix 5 _+_ _-_
infix 6 _·_ _*_
postulate
    Point    : Set
    Msg      : Set
    FieldN   : Set
    FieldP   : Set

    _·_ : FieldN → Point → Point
    _+_ : Point → Point → Point
    _*_ : FieldN → FieldN → FieldN
    _-_ : FieldN → FieldN → FieldN
    _==_ : FieldN → FieldN → Bool
    G   : Point
    N-1 : ℕ
    map-to-point : FieldP → Point

N : ℕ
N = suc N-1

PrvKey   : Set
PrvKey   = FieldN
PubKey   : Set
PubKey   = Point
[PubKey] : Set
[PubKey] = Vec PubKey N
[FieldN] : Set
[FieldN] = Vec FieldN N
Index    : Set
Index    = Fin N

max : Index
max = fromℕ N-1

record Sig : Set where
  constructor sig
  field
    c* : FieldN
    s* : [FieldN]
    Y* : Point

module Core-sign (H* : Point)
                 (Y  : Index → PubKey)
                 (Y* : Point)
                 (H₁ : Point → Point → FieldN)
                 (u  : FieldN)
                 (s  : [FieldN])
                 (xπ : FieldN)
                 (π  : Index)
                 where

    c : Index → FieldN
    c i = {!!}
      where
        sᵢ = s ‼ i
        c-suc-π = H₁ (u · G) (u · H*)
        c-suc-i = H₁ (sᵢ · G + c i · Y i) (sᵢ · H* + c i · Y*)

    sπ  = u - xπ * c π

    s* : Index → FieldN
    s* i = {!if i ≟ π then sπ else s ‼ i!}

    core-sign : Sig
    core-sign = record
      { c* = c zero
      ; s* = tabulate s*
      ; Y* = Y* }

module _
  (H₁      : [PubKey] → Point → Msg → Point → Point → FieldN)
  (H₂      : [PubKey] → FieldP)
  (pubKeys : [PubKey])
  (m       : Msg)
  where

    private
        Y : Index → Point
        Y i = pubKeys ‼ i

        H* = map-to-point (H₂ pubKeys)

    sign : Index → PrvKey → [FieldN] → Sig
    sign π xπ s{-random-} = sg
      where
        Y*  = xπ · H*
        u   = s ‼ π
        H₁C = H₁ pubKeys Y* m
        sg  = Core-sign.core-sign H* Y Y* H₁C u s xπ π

    verify : Sig → Bool
    verify (sig c* s* Y*) = res
      where
        H₁C = H₁ pubKeys Y* m
        module M i where
            Yᵢ   = Y i
            sᵢ   = s* ‼ i
            cᵢ   = {!!}
            Zᵢ   = sᵢ · G  + cᵢ · Yᵢ
            Tᵢ   = sᵢ · H* + cᵢ · Y*
            cᵢ+1 = H₁C Zᵢ Tᵢ
        res = c* == H₁C (M.Zᵢ max) (M.Tᵢ max)

{-
sign-using-ecdsa pubKeys m π xπ s =
  h = ?
  r = ?
  Rx , s = ecdsa.sign h r xπ
-}

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

error: pathspec 'ECC/ec-linkable-ring-sig.agda' did not match any file(s) known to git


Added gcd-comm draft.

Added gcd-comm draft.

Ignore-this: ebe434527351634ba618f9a6abd88da4

darcs-hash:20120124153045-3bd4e-156751b5a8eec9d4b0e2bcf8796b69cc1991ed96.gz

------------------------------------------------------------------------------
-- The gcd is commutative
------------------------------------------------------------------------------

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

module Draft.FOTC.Program.GCD.Total.CommutativeI where

open import Common.Function

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationProperties
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Program.GCD.Total.EquationsI
open import FOTC.Program.GCD.Total.GCD
open import FOTC.Relation.Binary.EqReasoning

------------------------------------------------------------------------------
-- Informal proof:
-- 1. gcd 0 n = n        -- gcd def
--            = gcd n 0  -- gcd def

-- 2. gcd n 0 = n        -- gcd def
--            = gcd 0 n  -- gcd def

-- 3.1. Case: S m > S n
-- gcd (S m) (S n) = gcd (S m - S n) (S n)  -- gcd def
--                 = gcd (S n) (S m - S n)  -- IH
--                 = gcd (S n) (S m)        -- gcd def

-- 3.2. Case: S m ≮ S n
-- gcd (S m) (S n) = gcd (S m) (S n - S m)  -- gcd def
--                 = gcd (S n - S m) (S m)  -- IH
--                 = gcd (S n) (S m)        -- gcd def

------------------------------------------------------------------------------
-- Commutativity property.
Comm : D → D → Set
Comm d₁ d₂ = gcd d₁ d₂ ≡ gcd d₂ d₁
{-# ATP definition Comm #-}

x>y→y≯x : ∀ {m n} → N m → N n → GT m n → NGT n m
x>y→y≯x zN          Nn          0>n   = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→y≯x Nm          zN          _     = 0≯x Nm
x>y→y≯x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS m n) (x>y→y≯x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

postulate
  x≯Sy→Sy>x : ∀ {m n} → N m → N n → NGT m (succ₁ n) → GT (succ₁ n) m
-- x≯Sy→Sy>x {n = n} zN      Nn _ = <-0S n
-- x≯Sy→Sy>x {n = n} (sN {m} Nm) Nn h = {!!}

------------------------------------------------------------------------------
-- gcd 0 0 is commutative.
gcd-00-comm : Comm zero zero
gcd-00-comm = refl

------------------------------------------------------------------------------
-- gcd (succ₁ n) 0 is commutative.
gcd-S0-comm : ∀ n → Comm (succ₁ n) zero
gcd-S0-comm n = trans (gcd-S0 n) (sym (gcd-0S n))

------------------------------------------------------------------------------
-- gcd (succ₁ m) (succ₁ n) when succ₁ m > succ₁ n is commutative.
gcd-S>S-comm : ∀ {m n} → N m → N n →
               Comm (succ₁ m ∸ succ₁ n) (succ₁ n) →
               GT (succ₁ m) (succ₁ n) →
               Comm (succ₁ m) (succ₁ n)
gcd-S>S-comm {m} {n} Nm Nn ih Sm>Sn =
  begin
    gcd (succ₁ m) (succ₁ n)
      ≡⟨ gcd-S>S m n Sm>Sn ⟩
    gcd (succ₁ m ∸ succ₁ n) (succ₁ n)
      ≡⟨ ih ⟩
    gcd (succ₁ n) (succ₁ m ∸ succ₁ n)
      ≡⟨ sym (gcd-S≯S n m (x>y→y≯x (sN Nm) (sN Nn) Sm>Sn)) ⟩
    gcd (succ₁ n) (succ₁ m)
  ∎

------------------------------------------------------------------------------
-- gcd (succ₁ m) (succ₁ n) when succ₁ m ≯ succ₁ n is commutative.
gcd-S≯S-comm : ∀ {m n} → N m → N n →
               Comm (succ₁ m) (succ₁ n ∸ succ₁ m) →
               NGT (succ₁ m) (succ₁ n) →
               Comm (succ₁ m) (succ₁ n)
gcd-S≯S-comm {m} {n} Nm Nn ih Sm≯Sn =
  begin
    gcd (succ₁ m) (succ₁ n)
      ≡⟨ gcd-S≯S m n Sm≯Sn ⟩
    gcd (succ₁ m) (succ₁ n ∸ succ₁ m)
      ≡⟨ ih ⟩
    gcd (succ₁ n ∸ succ₁ m) (succ₁ m)
      ≡⟨ sym (gcd-S>S n m (x≯Sy→Sy>x (sN Nm) Nn Sm≯Sn)) ⟩
    gcd (succ₁ n) (succ₁ m)
  ∎

------------------------------------------------------------------------------
-- gcd m n when m > n is commutative.
gcd-x>y-comm :
  ∀ {m n} → N m → N n →
  (∀ {o p} → N o → N p → LT₂ o p m n → Comm o p) →
  GT m n →
  Comm m n
gcd-x>y-comm zN          Nn          _    0>n   = ⊥-elim $ 0>x→⊥ Nn 0>n
gcd-x>y-comm (sN {n} _)  zN          _    _     = gcd-S0-comm n
gcd-x>y-comm (sN {m} Nm) (sN {n} Nn) accH Sm>Sn = gcd-S>S-comm Nm Nn ih Sm>Sn
  where
  -- Inductive hypothesis.
  ih : Comm (succ₁ m ∸ succ₁ n) (succ₁ n)
  ih = accH {succ₁ m ∸ succ₁ n}
            {succ₁ n}
            (∸-N (sN Nm) (sN Nn))
            (sN Nn)
            ([Sx∸Sy,Sy]<[Sx,Sy] Nm Nn)

------------------------------------------------------------------------------
-- gcd m n when m ≯ n is commutative.
gcd-x≯y-comm :
  ∀ {m n} → N m → N n →
  (∀ {o p} → N o → N p → LT₂ o p m n → Comm o p) →
  NGT m n →
  Comm m n
gcd-x≯y-comm zN          zN          _    _     = gcd-00-comm
gcd-x≯y-comm zN          (sN {n} _)  _    _     = sym (gcd-S0-comm n)
gcd-x≯y-comm (sN {m} Nm) zN          _    Sm≯0  = ⊥-elim $ S≯0→⊥ Sm≯0
gcd-x≯y-comm (sN {m} Nm) (sN {n} Nn) accH Sm≯Sn = gcd-S≯S-comm Nm Nn ih Sm≯Sn
  where
  -- Inductive hypothesis.
  ih : Comm (succ₁ m) (succ₁ n ∸ succ₁ m)
  ih = accH {succ₁ m}
            {succ₁ n ∸ succ₁ m}
            (sN Nm)
            (∸-N (sN Nn) (sN Nm))
            ([Sx,Sy∸Sx]<[Sx,Sy] Nm Nn)

------------------------------------------------------------------------------
-- gcd is commutative.
gcd-comm : ∀ {m n} → N m → N n → Comm m n
gcd-comm = wfInd-LT₂ P istep
  where
  P : D → D → Set
  P i j = Comm i j

  istep : ∀ {i j} → N i → N j → (∀ {k l} → N k → N l → LT₂ k l i j → P k l) →
          P i j
  istep Ni Nj accH =
    [ gcd-x>y-comm Ni Nj accH
    , gcd-x≯y-comm Ni Nj accH
    ] (x>y∨x≯y Ni Nj)

error: pathspec 'Draft/FOTC/Program/GCD/Total/CommutativeI.agda' did not match any file(s) known to git


Added note on structurally smaller.

Added note on structurally smaller.

error: RPC failed; HTTP 403 curl 22 The requested URL returned error: 403
fatal: the remote end hung up unexpectedly


Start ILC proof with functional big-step semantics

There's old cruft to remove here.

module Thesis.BigStep where

open import Thesis.Syntax hiding (suc)
open import Thesis.Lang hiding (⟦_⟧Context; ⟦_⟧Var; suc)

open import Relation.Binary.PropositionalEquality

-- open import Base.Syntax.Context Type public
-- open import Base.Syntax.Vars Type public

-- data Const : (τ : Type) → Set where
--   lit : ℤ → Const int
--   -- succ : Const (int ⇒ int)

-- data Term (Γ : Context) :
--   (τ : Type) → Set where
--   -- constants aka. primitives
--   const : ∀ {τ} →
--     (c : Const τ) →
--     Term Γ τ
--   var : ∀ {τ} →
--     (x : Var Γ τ) →
--     Term Γ τ
--   app : ∀ {σ τ}
--     (s : Term Γ (σ ⇒ τ)) →
--     (t : Term Γ σ) →
--     Term Γ τ
--   -- we use de Bruijn indices, so we don't need binding occurrences.
--   abs : ∀ {σ τ}
--     (t : Term (σ • Γ) τ) →
--     Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public
open import Data.Nat.Base using (ℕ; zero; suc)

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℤ) → Val int
  -- prim : ∀ {σ τ} → (f : Val σ → Val τ) → Val (σ ⇒ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⇒ τ ⟧Type) → Val (σ ⇒ τ)
  pairV : ∀ {σ τ} → Val σ → Val τ → Val (pair σ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⟧Type → Val τ) → Val (σ ⇒ τ)

-- TODO: add defunctionalized interpretations for primitives. Yes, annoying but mechanical.

-- Doesn't work
-- data Val2 : ℕ → Type → Set where
--   prim : ∀ {σ τ n} → (f : Val2 n σ → Val2 n τ) → Val2 (ℕ.suc n) (σ ⇒ τ)

-- Standard relational big-step semantics.
data _⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) : ∀ {τ} → Term Γ τ → Val τ → Set where
  abs : ∀ {τ₁ τ₂} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ closure t ρ
  app : ∀ {Γ′ τ₁ τ₂ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ closure t′ ρ′ →
    ρ ⊢ t₂ ↓ v₂ →
    (v₂ • ρ′) ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {τ} (x : Var Γ τ) →
    ρ ⊢ var x ↓ (⟦ x ⟧Var ρ)
  lit : ∀ n →
    ρ ⊢ const (lit n) ↓ intV n
  plus : ∀ {t1 t2 v1 v2} →
    ρ ⊢ t1 ↓ (intV v1) →
    ρ ⊢ t2 ↓ (intV v2) →
    ρ ⊢ app (app (const plus) t1) t2 ↓ intV (v1 + v2)
  minus : ∀ {t1 t2 v1 v2} →
    ρ ⊢ t1 ↓ (intV v1) →
    ρ ⊢ t2 ↓ (intV v2) →
    ρ ⊢ app (app (const minus) t1) t2 ↓ intV (v1 - v2)
  -- cond-true : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₂ : Val τ} →
  --   ρ ⊢ t₁ ↓ true →
  --   ρ ⊢ t₂ ↓ v₂ →
  --   ρ ⊢ cond t₁ t₂ t₃ ↓ v₂
  -- cond-false : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₃ : Val τ} →
  --   ρ ⊢ t₁ ↓ false →
  --   ρ ⊢ t₃ ↓ v₃ →
  --   ρ ⊢ cond t₁ t₂ t₃ ↓ v₃

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ intV n ⟧Val = n
-- ⟦ prim f ⟧Val = λ v → ⟦ f v ⟧Val
⟦ pairV a b ⟧Val = (⟦ a ⟧Val , ⟦ b ⟧Val)
-- ⟦ true ⟧Val = true
-- ⟦ false ⟧Val = false

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val
↓-sound abs = refl
↓-sound (app ↓₁ ↓₂ ↓′) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ | ↓-sound ↓′ = refl
↓-sound (var x) = ↦-sound _ x
↓-sound (lit n) = refl
↓-sound (plus ↓₁ ↓₂) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ = refl
↓-sound (minus ↓₁ ↓₂) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ = refl

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)
evalConst c n = {!!}

-- evalConst plus n = Done (prim (λ a → prim (λ b → intV (a + b))))
-- evalConst minus n = Done (prim (λ a → prim (λ b → intV (a - b))))
-- evalConst cons n = Done (prim (λ a → prim (λ b → {!pairV !})))
-- evalConst fst n = {!!}
-- evalConst snd n = {!!}
-- evalConst linj n = {!!}
-- evalConst rinj n = {!!}
-- evalConst match n = {!!}
-- evalConst zero = intV (+ 0)
-- evalConst succ = {!!}

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n
-- apply (prim f) a n = Done (f ⟦ a ⟧Val)

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut
-- eval t0 ρ (suc n) with t0
-- ... | const c = evalConst c n
-- ... | var x = Done (⟦ x ⟧Var ρ)
-- ... | abs t = Done (closure t ρ)
-- ... | app s t with eval s ρ n | eval t ρ n
-- ... | Done f | Done a = apply f a n
-- ... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool!
eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
  eval t ρ n ≡ Done v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
  ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
  apply f a n ≡ Done v →
  ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

eval-sound ρ v zero t ()
eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
  let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}

-- Next, we can try defining change structures and validity.

dapply : ∀ {σ τ} → Val (Δt (σ ⇒ τ)) → Val σ → Val (Δt σ) → Res (Δt τ)
dapply df a1 da zero = TimeOut
dapply df a1 da (suc zero) = TimeOut
dapply df a1 da (suc (suc n)) with apply df a1 n
... | Done dfa = apply dfa da (suc n)
... | TimeOut = TimeOut

-- apply (closure (abs (derive t)) dρ) a1 (suc (suc n))
-- eval (derive (abs t)) dρ (suc n) ≡
-- dapply-sound-0
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) n

dapply' : ∀ {σ τ} → ErrVal (Δt (σ ⇒ τ)) → ErrVal σ → ErrVal (Δt σ) → Res (Δt τ)
dapply' (Done df) (Done v) (Done dv) n = dapply df v dv n
dapply' _ _ _ _ = TimeOut

-- Which step-indexes should we use in dapply's specification and
-- implementation? That's highly non-obvious. To come up with them, I had to
-- step through the evaluation of eval (app (app ds t) dt), and verify that I
-- never invoke eval or apply on the same inputs at different step-indexes.
--
-- However, I expect I wouldn't be able to get a working proof if I got the
-- indexes wrong.
dapply-sound : ∀ {Γ σ τ} n ρ (ds : Term Γ (Δt (σ ⇒ τ))) t dt → eval (app (app ds t) dt) ρ (suc (suc n)) ≡ dapply' (eval ds ρ n) (eval t ρ n) (eval dt ρ (suc n)) (suc (suc n))
dapply-sound zero ρ ds t dt = refl
dapply-sound (suc n) ρ ds t dt with eval ds ρ (suc n) | eval t ρ (suc n) | eval dt ρ (suc (suc n))
dapply-sound (suc n) ρ ds t dt | Done df | Done v | Done dv with apply df v (suc n)
... | Done dfv = refl
... | TimeOut  = refl
dapply-sound (suc n) ρ ds t dt | Done df | Done v | TimeOut with apply df v (suc n)
... | Done dfv = refl
... | TimeOut = refl
dapply-sound (suc n) ρ ds t dt | Done df | TimeOut | dv = refl
dapply-sound (suc n) ρ ds t dt | TimeOut | v | dv = refl

open import Data.Empty
open import Data.Unit

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

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
deriveConst = {!!}

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

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

-- open import Thesis.Derive
Chτ : Type → Set
Chτ τ = Val (Δt τ)

deval : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → Res (Δt τ)
deval t ρ dρ = eval (derive t) dρ

dapply-equiv : ∀ {Γ σ τ} n
  (t : Term (σ • Γ) τ)
  (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 : Val σ) →
  dapply (closure (abs (derive t)) dρ) a1 da (suc (suc (suc n))) ≡
  eval (derive t) (da • a1 • dρ) (suc (suc n))
dapply-equiv n t dρ ρ1 da a1 = refl

-- Failed variants, the step-indexes are wrong:
-- dapply-equiv-2 : ∀ {Γ σ τ} n
--   (t : Term (σ • Γ) τ)
--   (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
--   (da : Val (Δt σ)) (a1 : Val σ) →
--   dapply (closure (abs (derive t)) dρ) a1 da (suc (suc n)) ≡
--   eval (derive t) (da • a1 • dρ) (suc n)
-- dapply-equiv-2 zero t dρ ρ1 da a1 = {!!}
-- dapply-equiv-2 (suc n) t dρ ρ1 da a1 = refl
-- -- dapply-equiv-2 zero t dρ ρ1 da a1 = refl
-- -- dapply-equiv-2 (suc zero) (const c) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc zero) (var x) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc zero) (app t t₁) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc zero) (abs t) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc (suc n)) t dρ ρ1 da a1 = refl

-- Worse:
-- dapply-equiv-0 : ∀ {Γ σ τ} n
--   (t : Term (σ • Γ) τ)
--   (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
--   (da : Val (Δt σ)) (a1 : Val σ) →
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) (suc n)
-- dapply-equiv-0 zero t dρ ρ1 da a1 = {!!}
-- dapply-equiv-0 (suc zero) t dρ ρ1 da a1 = {!!}
-- dapply-equiv-0 (suc (suc n)) t dρ ρ1 da a1 = {!!}

-- Target statement:

_[_]τ_from_to_ : (n : ℕ) → ∀ τ → Val (Δt τ) → Val τ → Val τ → Set
_[_]τ'_from_to_ : (n : ℕ) → ∀ τ → ErrVal (Δt τ) → ErrVal τ → ErrVal τ → Set
n [ τ ]τ' Done dv from Done v1 to Done v2 = n [ τ ]τ dv from v1 to v2
n [ τ ]τ' TimeOut from Done v1 to Done v2 = ⊥
n [ τ ]τ' dv from _ to _ = ⊤

_[_]τ'_fromToTimeOut : ∀ n τ edv → n [ τ ]τ' edv from TimeOut to TimeOut ≡ ⊤
n [ τ ]τ' Done v fromToTimeOut = refl
n [ τ ]τ' TimeOut fromToTimeOut = refl
-- n [ τ ]τ' dv from Done v1 to TimeOut = ⊤
-- n [ τ ]τ' dv from TimeOut to Done v2 = ⊤
-- n [ τ ]τ' dv from TimeOut to TimeOut = ⊤

-- In the static-caching paper, the specification we use is similar to this one:
-- n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
--    Σ[ dv ∈ Val (Δt τ) ]
--        dapply df a1 da n ≡ Done dv
--      × n [ τ ]τ dv from v1 to v2
-- I defined _[_]τ'_from_to_ to be able to write an equivalent (hopefully) specification more quickly.

zero [ τ ]τ dv from v1 to v2 = ⊤
-- suc n [ σ ⇒ τ ]τ df from f1 to f2 =
--   ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    n [ τ ]τ' dapply df a1 da n from apply f1 a1 n to apply f2 a2 n

suc n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
   n [ σ ]τ da from a1 to a2 →
   ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
   Σ[ dv ∈ Val (Δt τ) ]
       dapply df a1 da (suc (suc n)) ≡ Done dv
     × n [ τ ]τ dv from v1 to v2

suc n [ int ]τ intV dn from intV n1 to intV n2 = n1 + dn ≡ n2
suc n [ pair σ τ ]τ pairV da db from pairV a1 b1 to pairV a2 b2 =
  suc n [ σ ]τ da from a1 to a2 × suc n [ τ ]τ db from b1 to b2
suc n [ sum σ τ ]τ () from v1 to v2

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

fromtoDeriveVar : ∀ {Γ} τ n → (x : Var Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ (⟦ deriveVar x ⟧Var dρ) from ⟦ x ⟧Var ρ1 to ⟦ x ⟧Var ρ2
fromtoDeriveVar τ n this (dv • .(v1 • _)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = dvv
fromtoDeriveVar τ n (that x) (dv • (.v1 • dρ)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = fromtoDeriveVar τ n x dρ ρ1 ρ2 dρρ

fromtoDerive : ∀ {Γ} τ n → (t : Term Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ' (deval t ρ1 dρ n) from eval t ρ1 n to eval t ρ2 n
fromtoDerive τ zero t dρ ρ1 ρ2 dρρ rewrite zero [ τ ]τ' (deval t ρ1 dρ (suc zero)) fromToTimeOut = tt
fromtoDerive τ (suc n) (const c) dρ ρ1 ρ2 dρρ = {!!}
fromtoDerive τ (suc n) (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar τ (suc n) x dρ ρ1 ρ2 dρρ
fromtoDerive τ (suc n) (app s t) dρ ρ1 ρ2 dρρ = {!!}
-- fromtoDerive (σ ⇒ τ) (suc n) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   rewrite dapply-equiv n t dρ ρ1 da a1 =
--   fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ)

fromtoDerive (σ ⇒ τ) (suc zero) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 () eqv2
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 = {!fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) ?!}

-- fromtoDerive (σ ⇒ τ) (suc (suc zero)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa = {!!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   with eval (abs (derive t)) (a1 • dρ) n | inspect (eval (abs (derive t)) (a1 • dρ)) n
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | Done v | [ eq ] = {!fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) _!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | TimeOut | _ = {!!}
-- --   fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• ?)
-- -- fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}
--   -- fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}

error: pathspec 'Thesis/BigStep.agda' did not match any file(s) known to git


Add incomplete note on co-inductive natural numbers.

------------------------------------------------------------------------------
-- Definition of FOTC Conat using Agda's co-inductive combinators
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Conat.ConatSL where

open import FOTC.Base
open import Coinduction

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

data Conat : D → Set where
  cozero : Conat zero
  cosucc : ∀ {n} → (∞ (Conat n)) → Conat (succ₁ n)

Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')
Conat-unf cozero = inj₁ refl
Conat-unf (cosucc {n} Cn) = inj₂ (n , ♭ Cn , refl)

Conat-pre-fixed : ∀ {n} →
                  (n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')) →
                  Conat n
Conat-pre-fixed (inj₁ h) = subst Conat (sym h) cozero
Conat-pre-fixed (inj₂ (n , Cn , h)) = subst Conat (sym h) (cosucc (♯ Cn))

Conat-coind : ∀ (A : D → Set) {n} →
              (A n → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n')) →
              A n → Conat n
Conat-coind A h An = {!!}

error: pathspec 'notes/FOT/FOTC/Data/Conat/ConatSL.agda' did not match any file(s) known to git


[ draft ] ABP's lemma1 without helper function.

------------------------------------------------------------------------------
-- ABP lemma 1
------------------------------------------------------------------------------

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

-- From Dybjer and Sander's paper: The first lemma states that given a
-- start state S of the ABP, we will arrive at a state S', where the
-- message has been received by the receiver, but where the
-- acknowledgement has not yet been received by the sender.

module FOT.FOTC.Program.ABP.Lemma1WithoutHelperATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP using ( x≢not-x )
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

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

as^ : ∀ b i' is' ds → D
as^ b i' is' ds = await b i' is' ds
{-# ATP definition as^ #-}

bs^ : D → D → D → D → D → D
bs^ b i' is' ds os₁^ = corrupt os₁^ · (as^ b i' is' ds)
{-# ATP definition bs^ #-}

cs^ : D → D → D → D → D → D
cs^ b i' is' ds os₁^ = ack b · (bs^ b i' is' ds os₁^)
{-# ATP definition cs^ #-}

ds^ : D → D → D → D → D → D → D
ds^ b i' is' ds os₁^ os₂^ = corrupt os₂^ · cs^ b i' is' ds os₁^
{-# ATP definition ds^ #-}

os₁^ : D → D → D
os₁^ os₁' ft₁^ = ft₁^ ++ os₁'
{-# ATP definition os₁^ #-}

os₂^ : D → D
os₂^ os₂ = tail₁ os₂
{-# ATP definition os₂^ #-}

-- Helper function for the ABP lemma 1
-- module Helper where
--   -- 30 November 2013. If we don't have the following definitions
--   -- outside the where clause, the ATPs cannot prove the theorems.

--   helper : ∀ b i' is' os₁ os₂ as bs cs ds js →
--            Bit b →
--            Fair os₂ →
--            S b (i' ∷ is') os₁ os₂ as bs cs ds js →
--            ∀ ft₁ os₁' → F*T ft₁ → Fair os₁' → os₁ ≡ ft₁ ++ os₁' →
--            ∃[ os₁' ] ∃[ os₂' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
--              Fair os₁'
--              ∧ Fair os₂'
--              ∧ S' b i' is' os₁' os₂' as' bs' cs' ds' js'
--              ∧ js ≡ i' ∷ js'
--   helper b i' is' os₁ os₂ as bs cs ds js
--          Bb Fos₂ s .(T ∷ []) os₁' f*tnil Fos₁' os₁-eq = prf
--     where
--     postulate
--       prf : ∃[ os₁' ] ∃[ os₂' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
--               Fair os₁'
--               ∧ Fair os₂'
--               ∧ (as' ≡ await b i' is' ds'
--                  ∧ bs' ≡ corrupt os₁' · as'
--                  ∧ cs' ≡ ack (not b) · bs'
--                  ∧ ds' ≡ corrupt os₂' · (b ∷ cs')
--                  ∧ js' ≡ out (not b) · bs')
--               ∧ js ≡ i' ∷ js'
--     {-# ATP prove prf #-}

--   -- TODO (25 January 2014): Why Agda cannot refine using the helper
--   -- function? Agda bug?
--   helper b i' is' os₁ os₂ as bs cs ds js Bb Fos₂ s
--          .(F ∷ ft₁^) os₁' (f*tcons {ft₁^} FTft₁^) Fos₁' os₁-eq =
--          helper b i' is'
--                 (ft₁^ ++ os₁')
--                 (tail₁ os₂)
--                 (await b i' is' ds)
--                 (corrupt (ft₁^ ++ os₁') · await b i' is' ds)
--                 (ack b · (corrupt (ft₁^ ++ os₁') · await b i' is' ds))
--                 (corrupt (tail₁ os₂) ·
--                    (ack b · (corrupt (ft₁^ ++ os₁') · await b i' is' ds)))
--                 js
--                 Bb (tail-Fair Fos₂) ihS ft₁^ os₁' FTft₁^ Fos₁' refl
--     where
--     postulate os₁-eq-helper : os₁ ≡ F ∷ os₁^ os₁' ft₁^
--     {-# ATP prove os₁-eq-helper #-}

--     postulate as-eq : as ≡ < i' , b > ∷ (as^ b i' is' ds)
--     {-# ATP prove as-eq #-}

--     postulate bs-eq : bs ≡ error ∷ (bs^ b i' is' ds (os₁^ os₁' ft₁^))
--     {-# ATP prove bs-eq os₁-eq-helper as-eq #-}

--     postulate cs-eq : cs ≡ not b ∷ cs^ b i' is' ds (os₁^ os₁' ft₁^)
--     {-# ATP prove cs-eq bs-eq #-}

--     postulate
--       ds-eq-helper₁ :
--         os₂ ≡ T ∷ tail₁ os₂ →
--         ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--     {-# ATP prove ds-eq-helper₁ cs-eq #-}

--     postulate
--       ds-eq-helper₂ : os₂ ≡ F ∷ tail₁ os₂ →
--                       ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--     {-# ATP prove ds-eq-helper₂ cs-eq #-}

--     ds-eq : ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--             ∨ ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--     ds-eq = case (λ h → inj₁ (ds-eq-helper₁ h))
--                  (λ h → inj₂ (ds-eq-helper₂ h))
--                  (head-tail-Fair Fos₂)

--     postulate
--       as^-eq-helper₁ :
--         ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
--         as^ b i' is' ds ≡
--           send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--     {-# ATP prove as^-eq-helper₁ x≢not-x #-}

--     postulate
--       as^-eq-helper₂ :
--         ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
--         as^ b i' is' ds ≡
--           send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--     {-# ATP prove as^-eq-helper₂ #-}

--     as^-eq : as^ b i' is' ds ≡
--              send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
--     as^-eq = case as^-eq-helper₁ as^-eq-helper₂ ds-eq

--     postulate js-eq : js ≡ out b · bs^ b i' is' ds (os₁^ os₁' ft₁^)
--     {-# ATP prove js-eq bs-eq #-}

--     ihS : S b
--             (i' ∷ is')
--             (os₁^ os₁' ft₁^)
--             (os₂^ os₂)
--             (as^ b i' is' ds)
--             (bs^ b i' is' ds (os₁^ os₁' ft₁^))
--             (cs^ b i' is' ds (os₁^ os₁' ft₁^))
--             (ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂))
--             js
--     ihS = as^-eq , refl , refl , refl , js-eq

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈ Fair
-- and hence by unfolding Fair, we conclude that there are ft₁ :  F*T
-- and os₁' : Fair, such that os₁ = ft₁ ++ os₁'.
--
-- We proceed by induction on ft₁ : F*T using helper.

-- open Helper
lemma₁ : ∀ b i' is' os₁ os₂ as bs cs ds js →
         Bit b →
         Fair os₁ →
         Fair os₂ →
         S b (i' ∷ is') os₁ os₂ as bs cs ds js →
         ∃[ os₁' ] ∃[ os₂' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
           Fair os₁'
           ∧ Fair os₂'
           ∧ S' b i' is' os₁' os₂' as' bs' cs' ds' js'
           ∧ js ≡ i' ∷ js'
lemma₁ b i' is' os₁ os₂ as bs cs ds js Bb Fos₁ Fos₂ s with Fair-out Fos₁
... | .(true ∷ []) , os₁' , f*tnil , os₁≡ft₁++os₁' , Fos₁' = prf
  where
  postulate
    prf : ∃[ os₁' ] ∃[ os₂' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
            Fair os₁'
            ∧ Fair os₂'
            ∧ (as' ≡ await b i' is' ds'
              ∧ bs' ≡ corrupt os₁' · as'
              ∧ cs' ≡ ack (not b) · bs'
              ∧ ds' ≡ corrupt os₂' · (b ∷ cs')
              ∧ js' ≡ out (not b) · bs')
            ∧ js ≡ i' ∷ js'
  {-# ATP prove prf #-}

... | .(F ∷ ft₁^) , os₁' , f*tcons {ft₁^} FTft₁ , os₁≡ft₁++os₁' , Fos₁' =
  lemma₁ b i' is'
         (ft₁^ ++ os₁')
         (tail₁ os₂)
         (await b i' is' ds)
         (corrupt (ft₁^ ++ os₁') · await b i' is' ds)
         (ack b · (corrupt (ft₁^ ++ os₁') · await b i' is' ds))
         (corrupt (tail₁ os₂) ·
           (ack b · (corrupt (ft₁^ ++ os₁') · await b i' is' ds)))
         js Bb ft₁^++-os₁'-Fair ((tail-Fair Fos₂)) ihS
     where
     ft₁^++-os₁'-Fair : Fair (ft₁^ ++ os₁')
     ft₁^++-os₁'-Fair = Fair-in (ft₁^ , os₁' , FTft₁ , refl , Fos₁')

     postulate os₁-eq-helper : os₁ ≡ F ∷ os₁^ os₁' ft₁^
     {-# ATP prove os₁-eq-helper #-}

     postulate as-eq : as ≡ < i' , b > ∷ (as^ b i' is' ds)
     {-# ATP prove as-eq #-}

     postulate bs-eq : bs ≡ error ∷ (bs^ b i' is' ds (os₁^ os₁' ft₁^))
     {-# ATP prove bs-eq os₁-eq-helper as-eq #-}

     postulate cs-eq : cs ≡ not b ∷ cs^ b i' is' ds (os₁^ os₁' ft₁^)
     {-# ATP prove cs-eq bs-eq #-}

     postulate
       ds-eq-helper₁ :
         os₂ ≡ T ∷ tail₁ os₂ →
         ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove ds-eq-helper₁ cs-eq #-}

     postulate
       ds-eq-helper₂ : os₂ ≡ F ∷ tail₁ os₂ →
                       ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove ds-eq-helper₂ cs-eq #-}

     ds-eq : ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
             ∨ ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     ds-eq = case (λ h → inj₁ (ds-eq-helper₁ h))
                  (λ h → inj₂ (ds-eq-helper₂ h))
                  (head-tail-Fair Fos₂)

     postulate
       as^-eq-helper₁ :
         ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
         as^ b i' is' ds ≡
           send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove as^-eq-helper₁ x≢not-x #-}

     postulate
       as^-eq-helper₂ :
         ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
         as^ b i' is' ds ≡
           send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove as^-eq-helper₂ #-}

     as^-eq : as^ b i' is' ds ≡
              send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     as^-eq = case as^-eq-helper₁ as^-eq-helper₂ ds-eq

     postulate js-eq : js ≡ out b · bs^ b i' is' ds (os₁^ os₁' ft₁^)
     {-# ATP prove js-eq bs-eq #-}

     ihS : S b
             (i' ∷ is')
             (os₁^ os₁' ft₁^)
             (os₂^ os₂)
             (as^ b i' is' ds)
             (bs^ b i' is' ds (os₁^ os₁' ft₁^))
             (cs^ b i' is' ds (os₁^ os₁' ft₁^))
             (ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂))
             js
     ihS = as^-eq , refl , refl , refl , js-eq

error: pathspec 'notes/FOT/FOTC/Program/ABP/Lemma1WithoutHelperATP.agda' did not match any file(s) known to git