Working on the equivalence of the induction principles of N.

------------------------------------------------------------------------------
-- Induction principles for the total natural numbers
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.Type where

open import FOTC.Base

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

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

-- Induction principle generated by Coq when we define the data type N
-- in Prop.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- The induction principle removing the hypothesis N n from the
-- inductive step.
N-ind₂ : (A : D → Set) →
         A zero →
         (∀ {n} → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₂ A A0 h nzero      = A0
N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

------------------------------------------------------------------------------
-- N-ind₂ from N-ind₁.

N-ind₂' : (A : D → Set) →
          A zero →
          (∀ {n} → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₂' A A0 h = N-ind₁ A A0 (λ _ → h)

------------------------------------------------------------------------------
-- We cannot prove N-ind₁ from N-ind₂.

N→0∨S : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n')
N→0∨S = N-ind₂ A A0 is
  where
  A : D → Set
  A i = i ≡ zero ∨ (∃[ i' ] i ≡ succ₁ i' ∧ N i')

  A0 : A zero
  A0 = inj₁ refl

  is : ∀ {i} → A i → A (succ₁ i)
  is {i} Ai = case prf₁ prf₂ Ai
    where
    prf₁ : i ≡ zero → succ₁ i ≡ zero ∨ (∃[ i' ] succ₁ i ≡ succ₁ i' ∧ N i')
    prf₁ h' = inj₂ (i , refl , (subst N (sym h') nzero))

    prf₂ : ∃[ i' ] i ≡ succ₁ i' ∧ N i' →
           succ₁ i ≡ zero ∨ (∃[ i' ] succ₁ i ≡ succ₁ i' ∧ N i')
    prf₂ (i' , prf , Ni') = inj₂ (i , refl , subst N (sym prf) (nsucc Ni'))

N-ind₁' : (A : D → Set) →
          A zero →
          (∀ {n} → N n → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₁' A A0 h {n} Nn = case prf₁ prf₂ (N→0∨S Nn)
  where
  prf₁ : n ≡ zero → A n
  prf₁ n≡0 = subst A (sym n≡0) A0

  prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → A n
  prf₂ (n' , prf , Nn') = subst A (sym prf) (h Nn' {!!})

------------------------------------------------------------------------------
-- Induction principles for the total natural numbers
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.Type where

open import FOTC.Base

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

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

-- Induction principle generated by Coq when we define the data type N
-- in Prop.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- The induction principle removing the hypothesis N n from the
-- inductive step.
N-ind₂ : (A : D → Set) →
         A zero →
         (∀ {n} → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₂ A A0 h nzero      = A0
N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

-- N-ind₂ from N-ind₁.
N-ind₂' : (A : D → Set) →
          A zero →
          (∀ {n} → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₂' A A0 h = N-ind₁ A A0 (λ _ → h)

-- We cannot prove N-ind₁ from N-ind₂.
N-ind₁' : (A : D → Set) →
          A zero →
          (∀ {n} → N n → A n → A (succ₁ n)) →
          ∀ {n} → N n → A n
N-ind₁' A A0 h = N-ind₂ A A0 {!!}


Added TODO about a regression.

Added TODO about a regression.

Ignore-this: f00d93af876ed7be1aa3d2f9ea68964b

darcs-hash:20120303194504-3bd4e-ab63034841ffbf499f5b1ebf18b7519923fb5590.gz

------------------------------------------------------------------------------
-- FOL theorems
------------------------------------------------------------------------------

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

-- This module contains some examples showing the use of the ATPs for
-- proving FOL theorems.

module FOL.TheoremsATP where

open import FOL.Base

------------------------------------------------------------------------------
-- We postulate some formulae and propositional functions.
postulate
  A     : Set
  A¹ B¹ : D → Set
  A²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
{-
      φ(x)
  -----------  ∀-intro
    ∀x.φ(x)

    ∀x.φ(x)
  -----------  ∀-elim
     φ(t)

      φ(t)
  -----------  ∃-intro
    ∃x.φ(x)

   ∃x.φ(x)   φ(x) → ψ
 ----------------------  ∃-elim
           ψ
-}

postulate
  -- TODO: 2012-03-02. Fix? the universal introduction
  ∀-intro : (∀ x → A¹ x) → ∀ x → A¹ x
  ∀-elim  : (∀ x → A¹ x) → (t : D) → A¹ t
  -- It is necessary to assume a non-empty domain. See
  -- FOL.NonEmptyDomain.TheoremsI/ATP.∃I.
  --
  -- TODO: 2012-02-28. Fix the existential introduction rule.
  -- ∃-intro : ((t : D) → A¹ t) → ∃ A¹
  ∃-elim'  : ∃ A¹ → ((x : D) → A¹ x → A) → A
-- {-# ATP prove ∀-intro #-}
{-# ATP prove ∀-elim #-}
-- {-# ATP prove ∃-intro #-}
{-# ATP prove ∃-elim' #-}

-- Generalization of De Morgan's laws.
postulate
  gDM₁ : ¬ (∀ x → A¹ x) ↔ (∃[ x ] ¬ (A¹ x))
  gDM₂ : ¬ (∃ A¹)       ↔ (∀ x → ¬ (A¹ x))
  gDM₃ : (∀ x → A¹ x)   ↔ ¬ (∃[ x ] ¬ (A¹ x))
  gDM₄ : ∃ A¹           ↔ ¬ (∀ x → ¬ (A¹ x))
{-# ATP prove gDM₁ #-}
{-# ATP prove gDM₂ #-}
{-# ATP prove gDM₃ #-}
{-# ATP prove gDM₄ #-}

-- The order of quantifiers of the same sort is irrelevant.
postulate
  ∀-ord : (∀ x y → A² x y) ↔ (∀ y x → A² x y)
  ∃-ord : (∃[ x ] ∃[ y ] A² x y) ↔ (∃[ y ] ∃[ x ] A² x y)
{-# ATP prove ∀-ord #-}
{-# ATP prove ∃-ord #-}

-- Quantification over a variable that does not occur can be erased or
-- added.
postulate
  -- TODO: 2012-02-03. The ATPs are not proving the theorem.
  -- ∀-erase-add : ((x : D) → A) ↔ A
  ∃-erase-add : (∃[ x ] A ∧ A¹ x) ↔ A ∧ (∃[ x ] A¹ x)
-- {-# ATP prove ∀-erase-add #-}
{-# ATP prove ∃-erase-add #-}

-- Distributes laws for the quantifiers.
postulate
  ∀-dist : ∀ x → A¹ x ∧ B¹ x ↔ ((∀ x → A¹ x) ∧ (∀ x → B¹ x))
  ∃-dist : (∃[ x ] A¹ x ∨ B¹ x) ↔ (∃ A¹ ∨ ∃ B¹)
{-# ATP prove ∀-dist #-}
{-# ATP prove ∃-dist #-}

-- Interchange of quantifiers.
-- The related theorem ∀x∃y.Axy → ∃y∀x.Axy is not (classically) valid.
postulate ∃∀ : ∃[ x ] (∀ y → A² x y) → ∀ y → ∃[ x ] A² x y
{-# ATP prove ∃∀ #-}

-- ∃ in terms of ∀ and ¬.
postulate
  ∃→¬∀¬ : ∃[ x ] A¹ x → ¬ (∀ {x} → ¬ A¹ x)
  ∃¬→¬∀ : ∃[ x ] ¬ A¹ x → ¬ (∀ {x} → A¹ x)
{-# ATP prove ∃→¬∀¬ #-}
{-# ATP prove ∃¬→¬∀ #-}

-- ∀ in terms of ∃ and ¬.
postulate
  ∀→¬∃¬ : (∀ {x} → A¹ x) → ¬ (∃[ x ] ¬ A¹ x)
  ∀¬→¬∃ : (∀ {x} → ¬ A¹ x) → ¬ (∃[ x ] A¹ x)
{-# ATP prove ∀→¬∃¬ #-}
{-# ATP prove ∀¬→¬∃ #-}

------------------------------------------------------------------------------
-- FOL theorems
------------------------------------------------------------------------------

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

-- This module contains some examples showing the use of the ATPs for
-- proving FOL theorems.

module FOL.TheoremsATP where

open import FOL.Base

------------------------------------------------------------------------------
-- We postulate some formulae and propositional functions.
postulate
  A     : Set
  A¹ B¹ : D → Set
  A²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
{-
      φ(x)
  -----------  ∀-intro
    ∀x.φ(x)

    ∀x.φ(x)
  -----------  ∀-elim
     φ(t)

      φ(t)
  -----------  ∃-intro
    ∃x.φ(x)

   ∃x.φ(x)   φ(x) → ψ
 ----------------------  ∃-elim
           ψ
-}

postulate
  -- TODO: 2012-03-02. Fix? the universal introduction
  ∀-intro : (∀ x → A¹ x) → ∀ x → A¹ x
  ∀-elim  : (∀ x → A¹ x) → (t : D) → A¹ t
  -- It is necessary to assume a non-empty domain. See
  -- FOL.NonEmptyDomain.TheoremsI/ATP.∃I.
  --
  -- TODO: 2012-02-28. Fix the existential introduction rule.
  -- ∃-intro : ((t : D) → A¹ t) → ∃ A¹
  ∃-elim'  : ∃ A¹ → ((x : D) → A¹ x → A) → A
-- {-# ATP prove ∀-intro #-}
{-# ATP prove ∀-elim #-}
-- {-# ATP prove ∃-intro #-}
{-# ATP prove ∃-elim' #-}

-- Generalization of De Morgan's laws.
postulate
  gDM₁ : ¬ (∀ x → A¹ x) ↔ (∃[ x ] ¬ (A¹ x))
  gDM₂ : ¬ (∃ A¹)       ↔ (∀ x → ¬ (A¹ x))
  gDM₃ : (∀ x → A¹ x)   ↔ ¬ (∃[ x ] ¬ (A¹ x))
  gDM₄ : ∃ A¹           ↔ ¬ (∀ x → ¬ (A¹ x))
{-# ATP prove gDM₁ #-}
{-# ATP prove gDM₂ #-}
{-# ATP prove gDM₃ #-}
{-# ATP prove gDM₄ #-}

-- The order of quantifiers of the same sort is irrelevant.
postulate
  ∀-ord : (∀ x y → A² x y) ↔ (∀ y x → A² x y)
  ∃-ord : (∃[ x ] ∃[ y ] A² x y) ↔ (∃[ y ] ∃[ x ] A² x y)
{-# ATP prove ∀-ord #-}
{-# ATP prove ∃-ord #-}

-- Quantification over a variable that does not occur can be erased or
-- added.
postulate
  ∀-erase-add : ((_ : D) → A) ↔ A
  ∃-erase-add : (∃[ x ] A ∧ A¹ x) ↔ A ∧ (∃[ x ] A¹ x)
{-# ATP prove ∀-erase-add #-}
{-# ATP prove ∃-erase-add #-}

-- Distributes laws for the quantifiers.
postulate
  ∀-dist : ∀ x → A¹ x ∧ B¹ x ↔ ((∀ x → A¹ x) ∧ (∀ x → B¹ x))
  ∃-dist : (∃[ x ] A¹ x ∨ B¹ x) ↔ (∃ A¹ ∨ ∃ B¹)
{-# ATP prove ∀-dist #-}
{-# ATP prove ∃-dist #-}

-- Interchange of quantifiers.
-- The related theorem ∀x∃y.Axy → ∃y∀x.Axy is not (classically) valid.
postulate ∃∀ : ∃[ x ] (∀ y → A² x y) → ∀ y → ∃[ x ] A² x y
{-# ATP prove ∃∀ #-}

-- ∃ in terms of ∀ and ¬.
postulate
  ∃→¬∀¬ : ∃[ x ] A¹ x → ¬ (∀ {x} → ¬ A¹ x)
  ∃¬→¬∀ : ∃[ x ] ¬ A¹ x → ¬ (∀ {x} → A¹ x)
{-# ATP prove ∃→¬∀¬ #-}
{-# ATP prove ∃¬→¬∀ #-}

-- ∀ in terms of ∃ and ¬.
postulate
  ∀→¬∃¬ : (∀ {x} → A¹ x) → ¬ (∃[ x ] ¬ A¹ x)
  ∀¬→¬∃ : (∀ {x} → ¬ A¹ x) → ¬ (∃[ x ] A¹ x)
{-# ATP prove ∀→¬∃¬ #-}
{-# ATP prove ∀¬→¬∃ #-}


agda: *old* failed experiment with other change definition

This was lying around on my old laptop.

Old-commit-hash: f8ce36e22c6a0d4d2a65bddf007e16ac35ad881f

module PureChanges where

open import Data.Empty
open import Data.Nat
open import Data.Product
open import Data.Bool hiding (_≟_)
open import Data.List
open import Algebra

open import Function

open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; module ≡-Reasoning)
open import Relation.Nullary
open import Relation.Nullary.Decidable
--import Relation.Binary.HeterogeneousEquality as H

open import DecidableEq ℕ _≟_

Base : Set
Base = ℕ

Change₁ : Set
Change₁ = ℕ × ℕ

Change : Set
Change = List Change₁

apply₁ : Change₁ → Base → Base
apply₁ (proj₁ , proj₂) v = if ⌊ proj₁ ≟ v ⌋ then proj₂ else v

apply : Change → Base → Base
apply = flip (foldr apply₁)

diff : Base → Base → Change
diff new old = [ old , new ]

compose : Change → Change → Change
compose = _++_

open import Data.List.Properties
compose-IsFold : ∀ {xs ys} → compose xs ys ≡ foldr _∷_ ys xs
compose-IsFold {xs} {ys} = ++IsFold xs ys

_⊕_ = apply
_⊝_ = diff
_⊚_ = compose

infixl 6 _⊕_ _⊝_ _⊚_ -- as with + - in GHC.Num

≡-cong₂ = cong₂

≡-diff : ∀ {v₁ v₂ v₃ v₄} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → diff v₁ v₃ ≡ diff v₂ v₄
≡-diff = ≡-cong₂ diff

≡-apply : ∀ {dv₁ dv₂} {v₁ v₂} →
  dv₁ ≡ dv₂ → v₁ ≡ v₂ → apply dv₁ v₁ ≡ apply dv₂ v₂
≡-apply = ≡-cong₂ apply

apply-diff : ∀ {v₁ v₂} → apply (diff v₂ v₁) v₁ ≡ v₂
apply-diff {v₁} {v₂} =
  begin
    apply (diff v₂ v₁) v₁
  ≡⟨⟩
    (if ⌊ v₁ ≟ v₁ ⌋ then v₂ else v₁)
  ≡⟨ cong (λ x → if x then v₂ else v₁) (v≟v-true v₁) ⟩
    (if true then v₂ else v₁)
  ≡⟨⟩
    v₂
  ∎
  where
    open ≡-Reasoning

diff-apply : ∀ ds s → ds ⊕ s ⊝ s ≡ ds
diff-apply [] s = {!!}
diff-apply ((proj₁ , proj₂) ∷ ds) s rewrite diff-apply ds s = {!refl!}

apply-compose : ∀ v dv₁ dv₂ →
  (dv₁ ⊚ dv₂) ⊕ v ≡ dv₁ ⊕ (dv₂ ⊕ v)
apply-compose v [] dv₂ = refl
apply-compose v (x ∷ dv₁) dv₂ rewrite apply-compose v dv₁ dv₂ = refl

compose-assoc : ∀ dv₁ dv₂ dv₃ → (dv₁ ⊚ dv₂) ⊚ dv₃ ≡ dv₁ ⊚ (dv₂ ⊚ dv₃)
compose-assoc = let open Monoid (monoid Change₁) in assoc

-- compose-assoc (old₁ , new₁) (old₂ , new₂) (old₃ , new₃) with new₁ ≟ old₂ | new₂ ≟ old₃
-- compose-assoc (old₁ , new₁) (.new₁ , new₂) (.new₂ , new₃) | yes refl | yes refl = let
--     open ≡-Reasoning in
--   begin
--     (if ⌊ new₂ ≟ new₂ ⌋ then old₁ , new₃ else old₁ , new₂)
--   ≡⟨ cong (λ b → if b then old₁ , new₃ else old₁ , new₂) (v≟v-true new₂) ⟩
--     old₁ , new₃
--   ≡⟨ sym (cong (λ b → if b then old₁ , new₃ else old₁ , new₁) (v≟v-true new₁)) ⟩
--     (if ⌊ new₁ ≟ new₁ ⌋ then old₁ , new₃ else old₁ , new₁)
--   ∎
-- compose-assoc (old₁ , new₁) (.new₁ , new₂) (old₃ , new₃) | yes refl | no ¬p = {!!}
-- compose-assoc (old₁ , new₁) (old₂ , new₂) (old₃ , new₃) | no ¬p | yes p = {!!}
-- compose-assoc (old₁ , new₁) (old₂ , new₂) (old₃ , new₃) | no ¬p | no ¬p₁ = let
--     open ≡-Reasoning in
--   begin
--     (if ⌊ new₁ ≟ old₃ ⌋ then old₁ , new₃ else old₁ , new₁)
--   ≡⟨ cong (λ b → if b then old₁ , new₃ else old₁ , new₁) (≢→≟false {new₁} {old₃} {!
--   {- This hole cannot be filled - one can easily construct a counterexample. -}
-- !}) ⟩
--     old₁ , new₁
--   ≡⟨ sym (cong (λ b → if b then old₁ , new₂ else old₁ , new₁) (≢→≟false ¬p)) ⟩
--     (if ⌊ new₁ ≟ old₂ ⌋ then old₁ , new₂ else old₁ , new₁)
--   ∎

module PureChanges where

open import Data.Empty
open import Data.Nat
open import Data.Product
open import Data.Bool hiding (_≟_)

open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Relation.Nullary.Decidable
--import Relation.Binary.HeterogeneousEquality as H

open import DecidableEq ℕ _≟_

Base : Set
Base = ℕ

Change : Set
Change = ℕ × ℕ

apply : Change → Base → Base
apply (proj₁ , proj₂) v = if ⌊ proj₁ ≟ v ⌋ then proj₂ else v

diff : Base → Base → Change
diff new old = old , new

compose : Change → Change → Change
compose (proj₁₁ , proj₂₁) (proj₁₂ , proj₂₂) = if ⌊ proj₂₁ ≟ proj₁₂ ⌋ then proj₁₁ , proj₂₂ else proj₁₁ , proj₂₁

_⊕_ = apply
_⊝_ = diff
_⊚_ = compose

infixl 6 _⊕_ _⊝_ _⊚_ -- as with + - in GHC.Num

≡-cong₂ = cong₂

≡-diff : ∀ {v₁ v₂ v₃ v₄} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → diff v₁ v₃ ≡ diff v₂ v₄
≡-diff = ≡-cong₂ diff

≡-apply : ∀ {dv₁ dv₂} {v₁ v₂} →
  dv₁ ≡ dv₂ → v₁ ≡ v₂ → apply dv₁ v₁ ≡ apply dv₂ v₂
≡-apply = ≡-cong₂ apply

apply-diff : ∀ {v₁ v₂} → apply (diff v₂ v₁) v₁ ≡ v₂
apply-diff {v₁} {v₂} =
  begin
    apply (diff v₂ v₁) v₁
  ≡⟨⟩
    (if ⌊ v₁ ≟ v₁ ⌋ then v₂ else v₁)
  ≡⟨ cong (λ x → if x then v₂ else v₁) (v≟v-true v₁) ⟩
    (if true then v₂ else v₁)
  ≡⟨⟩
    v₂
  ∎
  where
    open ≡-Reasoning

compose-assoc : ∀ dv₁ dv₂ dv₃ → (dv₁ ⊚ dv₂) ⊚ dv₃ ≡ dv₁ ⊚ (dv₂ ⊚ dv₃)
compose-assoc (old₁ , new₁) (old₂ , new₂) (old₃ , new₃) with new₁ ≟ old₂ | new₂ ≟ old₃
compose-assoc (old₁ , new₁) (.new₁ , new₂) (.new₂ , new₃) | yes refl | yes refl = let
    open ≡-Reasoning in
  begin
    (if ⌊ new₂ ≟ new₂ ⌋ then old₁ , new₃ else old₁ , new₂)
  ≡⟨ cong (λ b → if b then old₁ , new₃ else old₁ , new₂) (v≟v-true new₂) ⟩
    old₁ , new₃
  ≡⟨ sym (cong (λ b → if b then old₁ , new₃ else old₁ , new₁) (v≟v-true new₁)) ⟩
    (if ⌊ new₁ ≟ new₁ ⌋ then old₁ , new₃ else old₁ , new₁)
  ∎
compose-assoc (old₁ , new₁) (.new₁ , new₂) (old₃ , new₃) | yes refl | no ¬p = {!!}
compose-assoc (old₁ , new₁) (old₂ , new₂) (old₃ , new₃) | no ¬p | yes p = {!!}
compose-assoc (old₁ , new₁) (old₂ , new₂) (old₃ , new₃) | no ¬p | no ¬p₁ = let
    open ≡-Reasoning in
  begin
    (if ⌊ new₁ ≟ old₃ ⌋ then old₁ , new₃ else old₁ , new₁)
  ≡⟨ cong (λ b → if b then old₁ , new₃ else old₁ , new₁) (≢→≟false {new₁} {old₃} {!
  {- This hole cannot be filled - one can easily construct a counterexample. -}
!}) ⟩
    old₁ , new₁
  ≡⟨ sym (cong (λ b → if b then old₁ , new₂ else old₁ , new₁) (≢→≟false ¬p)) ⟩
    (if ⌊ new₁ ≟ old₂ ⌋ then old₁ , new₂ else old₁ , new₁)
  ∎


changed the proof of \top from true to obvious

module Logic where

-- The true proposition.
data ⊤ : Set where
  obvious : ⊤ -- The proof of truth.

-- The false proposition.
data ⊥ : Set where
  -- There is nothing here so one can never prove false.

-- The AND of two statments.
data _∧_ (A B : Set)  : Set where
  -- The only way to construct a proof of A ∧ B is by pairing a a
  -- proof of A with a proof of and B.
  ⟨_,_⟩ : (a : A)  -- Proof of A
        → (b : B)  -- Proof of B
        → A ∧ B    -- Proof of A ∧ B

-- The OR of two statements.
data _∨_ (A B : Set) : Set where
  -- There are two ways of constructing a proof of A ∨ B.
  inl : (a : A) →  A ∨ B   -- From a proof of A by left introduction
  inr : (b : B) →  A ∨ B   -- From a proof of B by right introduction

-- The not of statement A
¬_ : (A : Set) → Set
¬ A = A → ⊥  -- Given a proof of A one should be able to get a proof
             -- of ⊥.

-- The statement A ↔ B are equivalent.
_↔_ : (A B : Set) → Set
A ↔ B = (A → B) -- If
           ∧    -- and
        (B → A) -- only if

infixr 1 _∧_
infixr 1 _∨_
infixr 0 _↔_
infix  2 ¬_

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

-- Double negation
doubleNegation : ∀ {A : Set} → A → ¬ (¬ A)
doubleNegation a negNegA = negNegA a

{-

doubleNegation' : ∀ {A : Set} → ¬ ( ¬ (¬ A)) → ¬ A

-}

deMorgan1 : ∀ (A B : Set) → ¬ (A ∨ B) → ¬ A ∧ ¬ B
deMorgan1 A B notAorB = ⟨ notAorB ∘ inl , notAorB ∘ inr ⟩

deMorgan2 : ∀ (A B : Set) → ¬ A ∧ ¬ B → ¬ (A ∨ B)
deMorgan2 A B ⟨ notA , notB ⟩ (inl a) = notA a
deMorgan2 A B ⟨ notA , notB ⟩ (inr b) = notB b

deMorgan : ∀ (A B : Set) → ¬ (A ∨ B) ↔ ¬ A ∧ ¬ B
deMorgan A B = ⟨ deMorgan1 A B , deMorgan2 A B ⟩

module Logic where

-- The true proposition.
data ⊤ : Set where
  true : ⊤ -- The proof of truth.

-- The false proposition.
data ⊥ : Set where
  -- There is nothing here so one can never prove false.

-- The AND of two statments.
data _∧_ (A B : Set)  : Set where
  -- The only way to construct a proof of A ∧ B is by pairing a a
  -- proof of A with a proof of and B.
  ⟨_,_⟩ : (a : A)  -- Proof of A
        → (b : B)  -- Proof of B
        → A ∧ B    -- Proof of A ∧ B

-- The OR of two statements.
data _∨_ (A B : Set) : Set where
  -- There are two ways of constructing a proof of A ∨ B.
  inl : (a : A) →  A ∨ B   -- From a proof of A by left introduction
  inr : (b : B) →  A ∨ B   -- From a proof of B by right introduction

-- The not of statement A
¬_ : (A : Set) → Set
¬ A = A → ⊥  -- Given a proof of A one should be able to get a proof
             -- of ⊥.

-- The statement A ↔ B are equivalent.
_↔_ : (A B : Set) → Set
A ↔ B = (A → B) -- If
           ∧    -- and
        (B → A) -- only if

infixr 1 _∧_
infixr 1 _∨_
infixr 0 _↔_
infix  2 ¬_

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

-- Double negation
doubleNegation : ∀ {A : Set} → A → ¬ (¬ A)
doubleNegation a negNegA = negNegA a

{-

doubleNegation' : ∀ {A : Set} → ¬ ( ¬ (¬ A)) → ¬ A

-}

deMorgan1 : ∀ (A B : Set) → ¬ (A ∨ B) → ¬ A ∧ ¬ B
deMorgan1 A B notAorB = ⟨ notAorB ∘ inl , notAorB ∘ inr ⟩

deMorgan2 : ∀ (A B : Set) → ¬ A ∧ ¬ B → ¬ (A ∨ B)
deMorgan2 A B ⟨ notA , notB ⟩ (inl a) = notA a
deMorgan2 A B ⟨ notA , notB ⟩ (inr b) = notB b

deMorgan : ∀ (A B : Set) → ¬ (A ∨ B) ↔ ¬ A ∧ ¬ B
deMorgan A B = ⟨ deMorgan1 A B , deMorgan2 A B ⟩


Simplify and complete stability on variables

Old-commit-hash: 67bac93b9f4260305c74a19d6593a0ad14481f72

{-
Communicate to derivatives that changes to certain arguments
are always nil (i. e., certain arguments are stable).
-}

module ExplicitNil where

open import NatBag

open import Data.Bool
open import Data.Product hiding (map)
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤ ; tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)

-- Debug tool
absurd! : ∀ {A B : Set} → B → A → A → B
absurd! b _ _ = b

data Args : (τ : Type) → Set where
  ∅-nat : Args nats
  ∅-bag : Args bags
  abide : ∀ {τ₁ τ₂} → (args : Args τ₂) → Args (τ₁ ⇒ τ₂)
  alter : ∀ {τ₁ τ₂} → (args : Args τ₂) → Args (τ₁ ⇒ τ₂)

-- Totally like subcontext relation _≼_ : (Γ₁ Γ₂ : Context) → Set
data Vars : Context → Set where
  ∅ : Vars ∅
  abide : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ) -- is in the set
  alter : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ) -- is out of the set

stableVar : ∀ {τ Γ} → Var Γ τ → Vars Γ → Bool
stableVar this (abide _) = true
stableVar this (alter _) = false
stableVar (that x) (abide vars) = stableVar x vars
stableVar (that x) (alter vars) = stableVar x vars

-- A term is stable if all its free variables are unchanging
-- Alternative definition:
--
--     stable t vars = isNil t (derive t)
--
stable : ∀ {τ Γ} → Term Γ τ → Vars Γ → Bool
stable (nat n) vars = true
stable (bag b) vars = true
stable (var x) vars = stableVar x vars
stable (abs t) vars = stable t (abide vars)
stable (app f x) vars = stable f vars ∧ stable x vars
stable (add m n) vars = stable m vars ∧ stable n vars
stable (map f b) vars = stable f vars ∧ stable b vars
stable (diff b d) vars = stable b vars ∧ stable d vars
stable (union b d) vars = stable b vars ∧ stable d vars

{-
-- Reformulating stableness as a decidable relation
-- Not sure if it is necessary or not.
data StableVar : ∀ {τ Γ} → Var Γ τ → Vars Γ → Set where
  abide-this : ∀ {τ Γ} → {vars : Vars Γ} → StableVar this (abide {τ} vars)
  abide-that : ∀ {τ Γ τ′} → {x : Var Γ τ} → {vars : Vars Γ} →
    StableVar x vars → StableVar (that {τ} {τ′} x) (abide vars)
  alter-that : ∀ {τ Γ τ′} → {x : Var Γ τ} → {vars : Vars Γ} →
    StableVar x vars → StableVar (that {τ} {τ′} x) (alter vars)

data Stable : ∀ {τ Γ} → Term Γ τ → Vars Γ → Set where
  stable-nat : ∀ {Γ n vars} → Stable {nats} {Γ} (nat n) vars
  stable-bag : ∀ {Γ b vars} → Stable {bags} {Γ} (bag b) vars
  stable-var : ∀ {τ Γ x vars} →
               StableVar {τ} {Γ} x vars → Stable (var x) vars
  stable-abs : ∀ {τ₁ τ₂ Γ vars} {t : Term (τ₁ • Γ) τ₂} →
               Stable t (abide vars) → Stable (abs t) vars
  -- TODO app add map diff union
-}

expect-volatility : {τ : Type} → Args τ
expect-volatility {τ₁ ⇒ τ₂} = alter expect-volatility
expect-volatility {nats} = ∅-nat
expect-volatility {bags} = ∅-bag

-- Type of `derive'`
derive' : ∀ {τ Γ} → Args τ → Vars Γ →
                    Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

derive' {τ₁ ⇒ τ₂} (abide args) vars (abs t) =
  abs (abs (derive' args (abide vars) t))

derive' (alter args) vars (abs t) =
  abs (abs (derive' args (alter vars) t))

-- Assume, for safety, that all arguments that `t` will
-- eventually receive in `s` or receive curried out of `s`
-- are volatile.
derive' args vars (app s t) =
  if stable t vars
  then app (app (derive' (abide args) vars s) (weaken Γ≼ΔΓ t))
                (derive' expect-volatility vars t)
  else app (app (derive' (alter args) vars s) (weaken Γ≼ΔΓ t))
                (derive' expect-volatility vars t)

derive' args vars (map f b) =
  if stable f vars
  then map (weaken Γ≼ΔΓ f) (derive' args vars b)
  else map (weaken Γ≼ΔΓ f ⊕ derive' (abide ∅-nat) vars f)
           (weaken Γ≼ΔΓ b ⊕ derive' args vars b)
       ⊝ weaken Γ≼ΔΓ (map f b)

derive' args vars (diff b d) =
  diff (derive' args vars b) (derive' args vars d)

derive' args vars (union b d) =
  union (derive' args vars b) (derive' args vars d)

-- derive(x + y) = replace (x + y) by (dx snd + dy snd)
--               = λ f. f (x + y) (dx snd + dy snd)
derive' args vars (add m n) =
  abs (app (app (var this)
    (add (weaken (drop _ • Γ≼ΔΓ) m) (weaken (drop _ • Γ≼ΔΓ) n)))
    (add (app (weaken (drop _ • Γ≼Γ) (derive' args vars m)) snd)
         (app (weaken (drop _ • Γ≼Γ) (derive' args vars n)) snd)))

derive' args vars constant-or-variable = derive constant-or-variable

-- A description of variables is honest w.r.t. a Δ-environment
-- if every variable described as stable receives the nil change.
data Honest : ∀ {Γ} → Vars Γ → ⟦ Δ-Context Γ ⟧ → Set where
  clearly : Honest ∅ ∅
  alter : ∀ {Γ τ v dv} → {vars : Vars Γ} → {ρ : ⟦ Δ-Context Γ ⟧} →
          Honest {Γ} vars ρ →
          Honest {τ • Γ} (alter vars) (dv • v • ρ)
  abide : ∀ {Γ τ v dv} → {vars : Vars Γ} → {ρ : ⟦ Δ-Context Γ ⟧} →
          v ⟦⊕⟧ dv ≡ v →
          Honest {Γ} vars ρ →
          Honest {τ • Γ} (abide vars) (dv • v • ρ)

-- Two Δ-values are close enough w.r.t. a set of arguments if they
-- behave the same when fully applied (cf. extensionality) given
-- that each argument declared stable receives the nil change.
close-enough : ∀ {τ : Type} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → Args τ → Set
close-enough {nats} df dg args = df ≡ dg -- extensionally
close-enough {bags} df dg args = df ≡ dg -- literally
close-enough {τ₁ ⇒ τ₂} df dg (alter args) =
  ∀ {x dx} → close-enough (df x dx) (dg x dx) args
close-enough {τ₁ ⇒ τ₂} df dg (abide args) =
  ∀ {x dx} → x ⟦⊕⟧ dx ≡ x → close-enough (df x dx) (dg x dx) args

syntax close-enough df dg args = df ≈ dg WRT args

volatility⇒identity :
  ∀ {τ} {df dg : ⟦ Δ-Type τ ⟧} →
    df ≈ dg WRT (expect-volatility {τ}) → df ≡ dg

volatility⇒identity {nats} df≈dg = df≈dg
volatility⇒identity {bags} df≈dg = df≈dg
volatility⇒identity {τ₁ ⇒ τ₂} {df} {dg} df≈dg =
  extensionality (λ x → extensionality (λ dx →
    volatility⇒identity {τ₂} (df≈dg {x} {dx})))

df≈df : ∀ {τ} {df : ⟦ Δ-Type τ ⟧} {args : Args τ} → df ≈ df WRT args
df≈df {nats} = refl
df≈df {bags} = refl
df≈df {τ₁ ⇒ τ₂} {df} {abide args} =
  λ {x} {dx} _ → df≈df {τ₂} {df x dx} {args}
df≈df {τ₁ ⇒ τ₂} {df} {alter args} =
  λ {x} {dx}   → df≈df {τ₂} {df x dx} {args}

too-close : ∀ {τ Γ} {args : Args τ} →
  {df dg : Term (Δ-Context Γ) (Δ-Type τ)} {ρ : ⟦ Δ-Context Γ ⟧} →
  df ≡ dg → ⟦ df ⟧ ρ ≈ ⟦ dg ⟧ ρ WRT args

too-close {τ}{_} {args} {df} {dg} {ρ} df=dg
  rewrite df=dg = df≈df {τ} {⟦ dg ⟧ ρ} {args}

-- A variable does not change if its value is unchanging.
stabilityVar : ∀ {τ Γ} → (x : Var Γ τ) (vars : Vars Γ) →
  stableVar x vars ≡ true →
  ∀ {ρ : ⟦ Δ-Context Γ ⟧} → Honest vars ρ →
    ⟦ weakenVar Γ≼ΔΓ x ⟧ ρ ⟦⊕⟧ ⟦ deriveVar x ⟧ ρ ≡ ⟦ weakenVar Γ≼ΔΓ x ⟧ ρ

stabilityVar this (alter vars) () (alter honesty)
stabilityVar this (abide vars) refl (abide proof honesty) = proof

stabilityVar {τ} {τ′ • Γ } (that x) (abide vars) truth (abide _ honesty)
  = stabilityVar x vars truth honesty

stabilityVar {τ} {τ′ • Γ } (that x) (alter vars) truth (alter honesty)
  = stabilityVar x vars truth honesty

-- A term does not change if its free variables are unchanging.
stability : ∀ {τ Γ} → (t : Term Γ τ) (vars : Vars Γ) →
  stable t vars ≡ true →
  ∀ {ρ : ⟦ Δ-Context Γ ⟧} → Honest vars ρ →
    ⟦ weaken Γ≼ΔΓ t ⟧ ρ ⟦⊕⟧ ⟦ derive t ⟧ ρ ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ

stability (nat n) vars truth {ρ} _ = refl

stability (bag b) vars truth {ρ} _ = b++∅=b

stability (var x) vars truth {ρ} honesty =
  stabilityVar x vars truth honesty

stability (abs t) vars truth {ρ} honesty = {!!}
stability (app t t₁) vars truth {ρ} honesty = {!!}
stability (add t t₁) vars truth {ρ} honesty = {!!}
stability (map t t₁) vars truth {ρ} honesty = {!!}
stability (diff t t₁) vars truth {ρ} honesty = {!!}
stability (union t t₁) vars truth {ρ} honesty = {!!}

honestyVar : {τ : Type} → {Γ : Context} →
  (args : Args τ) → (vars : Vars Γ) →
  (x : Var Γ τ) → derive (var x) ≡ derive' args vars (var x)
honestyVar ∅-nat vars x = refl
honestyVar ∅-bag vars x = refl
honestyVar (abide args) vars x = refl
honestyVar (alter args) vars x = refl

-- If both the environment and the future arguments are honest
-- about nil changes, then the optimized derivation delivers
-- the same result as the original derivation.
honesty-is-the-best-policy : ∀ {τ Γ} (t : Term Γ τ) →
  (args : Args τ) → (vars : Vars Γ) →
  (ρ : ⟦ Δ-Context Γ ⟧) → Honest vars ρ →
  ⟦ derive t ⟧ ρ ≈ ⟦ derive' args vars t ⟧ ρ WRT args

honesty-is-the-best-policy (app f s) args vars ρ honesty
  with stable s vars | inspect (stable s) vars
... | true  | [ truth ] = {!!}
--  absurd! {!!} (stability s vars truth {ρ}) {!!}

... | false | [ falsehood ] = {!!}

honesty-is-the-best-policy {nats} {Γ} (nat n) args vars ρ honesty =
  begin
    ⟦ derive (nat n) ⟧ ρ
  ≡⟨ cong (λ hole → ⟦ hole ⟧ ρ) (lemma Γ args vars) ⟩
    ⟦ derive' args vars (nat n) ⟧ ρ
  ∎ where
    open ≡-Reasoning
    lemma : (Γ : Context) (args : Args nats) (vars : Vars Γ) →
      derive (nat n) ≡ derive' {nats} {Γ} args vars (nat n)
    lemma ∅ ∅-nat ∅ = refl
    lemma (τ • Γ) ∅-nat (abide vars) = refl
    lemma (τ • Γ) ∅-nat (alter vars) = refl

honesty-is-the-best-policy {bags} {Γ} (bag b) args vars ρ honesty =
  begin
    ⟦ derive (bag b) ⟧ ρ
  ≡⟨ cong (λ hole → ⟦ hole ⟧ ρ) (lemma Γ args vars) ⟩
    ⟦ derive' args vars (bag b) ⟧ ρ
  ∎ where
    open ≡-Reasoning
    lemma : (Γ : Context) (args : Args bags) (vars : Vars Γ) →
      derive (bag b) ≡ derive' {bags} {Γ} args vars (bag b)
    lemma ∅ ∅-bag ∅ = refl
    lemma (τ • Γ) ∅-bag (abide vars) = refl
    lemma (τ • Γ) ∅-bag (alter vars) = refl

honesty-is-the-best-policy {τ} {Γ} (var x) args vars ρ honesty =
  too-close {τ} {Γ} (honestyVar args vars x)

honesty-is-the-best-policy (abs t) (abide args) vars ρ honesty =
  λ {x} {dx} x⊕dx=x → honesty-is-the-best-policy
    t args (abide vars) (dx • x • ρ) (abide x⊕dx=x honesty)

honesty-is-the-best-policy (abs t) (alter args) vars ρ honesty =
  λ {x} {dx} → honesty-is-the-best-policy
    t args (alter vars) (dx • x • ρ) (alter honesty)

honesty-is-the-best-policy (add m n) args vars ρ honesty = {!!}
honesty-is-the-best-policy (map f b) args vars ρ honesty = {!!}
honesty-is-the-best-policy (diff b d) args vars ρ honesty = {!!}
honesty-is-the-best-policy (union b d) args vars ρ honesty = {!!}

{-
Communicate to derivatives that changes to certain arguments
are always nil (i. e., certain arguments are stable).
-}

module ExplicitNil where

open import NatBag

open import Data.Bool
open import Data.Product hiding (map)
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤ ; tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)

-- Debug tool
absurd! : ∀ {A B : Set} → B → A → A → B
absurd! b _ _ = b

data Args : (τ : Type) → Set where
  ∅-nat : Args nats
  ∅-bag : Args bags
  abide : ∀ {τ₁ τ₂} → (args : Args τ₂) → Args (τ₁ ⇒ τ₂)
  alter : ∀ {τ₁ τ₂} → (args : Args τ₂) → Args (τ₁ ⇒ τ₂)

-- Totally like subcontext relation _≼_ : (Γ₁ Γ₂ : Context) → Set
data Vars : Context → Set where
  ∅ : Vars ∅
  abide : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ) -- is in the set
  alter : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ) -- is out of the set

stableVar : ∀ {τ Γ} → Var Γ τ → Vars Γ → Bool
stableVar this (abide _) = true
stableVar this (alter _) = false
stableVar (that x) (abide vars) = stableVar x vars
stableVar (that x) (alter vars) = stableVar x vars

-- A term is stable if all its free variables are unchanging
-- Alternative definition:
--
--     stable t vars = isNil t (derive t)
--
stable : ∀ {τ Γ} → Term Γ τ → Vars Γ → Bool
stable (nat n) vars = true
stable (bag b) vars = true
stable (var x) vars = stableVar x vars
stable (abs t) vars = stable t (abide vars)
stable (app f x) vars = stable f vars ∧ stable x vars
stable (add m n) vars = stable m vars ∧ stable n vars
stable (map f b) vars = stable f vars ∧ stable b vars
stable (diff b d) vars = stable b vars ∧ stable d vars
stable (union b d) vars = stable b vars ∧ stable d vars

{-
-- Reformulating stableness as a decidable relation
-- Not sure if it is necessary or not.
data StableVar : ∀ {τ Γ} → Var Γ τ → Vars Γ → Set where
  abide-this : ∀ {τ Γ} → {vars : Vars Γ} → StableVar this (abide {τ} vars)
  abide-that : ∀ {τ Γ τ′} → {x : Var Γ τ} → {vars : Vars Γ} →
    StableVar x vars → StableVar (that {τ} {τ′} x) (abide vars)
  alter-that : ∀ {τ Γ τ′} → {x : Var Γ τ} → {vars : Vars Γ} →
    StableVar x vars → StableVar (that {τ} {τ′} x) (alter vars)

data Stable : ∀ {τ Γ} → Term Γ τ → Vars Γ → Set where
  stable-nat : ∀ {Γ n vars} → Stable {nats} {Γ} (nat n) vars
  stable-bag : ∀ {Γ b vars} → Stable {bags} {Γ} (bag b) vars
  stable-var : ∀ {τ Γ x vars} →
               StableVar {τ} {Γ} x vars → Stable (var x) vars
  stable-abs : ∀ {τ₁ τ₂ Γ vars} {t : Term (τ₁ • Γ) τ₂} →
               Stable t (abide vars) → Stable (abs t) vars
  -- TODO app add map diff union
-}

expect-volatility : {τ : Type} → Args τ
expect-volatility {τ₁ ⇒ τ₂} = alter expect-volatility
expect-volatility {nats} = ∅-nat
expect-volatility {bags} = ∅-bag

-- Type of `derive'`
derive' : ∀ {τ Γ} → Args τ → Vars Γ →
                    Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

derive' {τ₁ ⇒ τ₂} (abide args) vars (abs t) =
  abs (abs (derive' args (abide vars) t))

derive' (alter args) vars (abs t) =
  abs (abs (derive' args (alter vars) t))

-- Assume, for safety, that all arguments that `t` will
-- eventually receive in `s` or receive curried out of `s`
-- are volatile.
derive' args vars (app s t) =
  if stable t vars
  then app (app (derive' (abide args) vars s) (weaken Γ≼ΔΓ t))
                (derive' expect-volatility vars t)
  else app (app (derive' (alter args) vars s) (weaken Γ≼ΔΓ t))
                (derive' expect-volatility vars t)

derive' args vars (map f b) =
  if stable f vars
  then map (weaken Γ≼ΔΓ f) (derive' args vars b)
  else map (weaken Γ≼ΔΓ f ⊕ derive' (abide ∅-nat) vars f)
           (weaken Γ≼ΔΓ b ⊕ derive' args vars b)
       ⊝ weaken Γ≼ΔΓ (map f b)

derive' args vars (diff b d) =
  diff (derive' args vars b) (derive' args vars d)

derive' args vars (union b d) =
  union (derive' args vars b) (derive' args vars d)

-- derive(x + y) = replace (x + y) by (dx snd + dy snd)
--               = λ f. f (x + y) (dx snd + dy snd)
derive' args vars (add m n) =
  abs (app (app (var this)
    (add (weaken (drop _ • Γ≼ΔΓ) m) (weaken (drop _ • Γ≼ΔΓ) n)))
    (add (app (weaken (drop _ • Γ≼Γ) (derive' args vars m)) snd)
         (app (weaken (drop _ • Γ≼Γ) (derive' args vars n)) snd)))

derive' args vars constant-or-variable = derive constant-or-variable

-- A description of variables is honest w.r.t. a Δ-environment
-- if every variable described as stable receives the nil change.
data Honest : ∀ {Γ} → Vars Γ → ⟦ Δ-Context Γ ⟧ → Set where
  clearly : Honest ∅ ∅
  alter : ∀ {Γ τ v dv} → {vars : Vars Γ} → {ρ : ⟦ Δ-Context Γ ⟧} →
          Honest {Γ} vars ρ →
          Honest {τ • Γ} (alter vars) (dv • v • ρ)
  abide : ∀ {Γ τ v dv} → {vars : Vars Γ} → {ρ : ⟦ Δ-Context Γ ⟧} →
          v ⟦⊕⟧ dv ≡ v →
          Honest {Γ} vars ρ →
          Honest {τ • Γ} (abide vars) (dv • v • ρ)

-- Two Δ-values are close enough w.r.t. a set of arguments if they
-- behave the same when fully applied (cf. extensionality) given
-- that each argument declared stable receives the nil change.
close-enough : ∀ {τ : Type} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → Args τ → Set
close-enough {nats} df dg args = df ≡ dg -- extensionally
close-enough {bags} df dg args = df ≡ dg -- literally
close-enough {τ₁ ⇒ τ₂} df dg (alter args) =
  ∀ {x dx} → close-enough (df x dx) (dg x dx) args
close-enough {τ₁ ⇒ τ₂} df dg (abide args) =
  ∀ {x dx} → x ⟦⊕⟧ dx ≡ x → close-enough (df x dx) (dg x dx) args

syntax close-enough df dg args = df ≈ dg WRT args

volatility⇒identity :
  ∀ {τ} {df dg : ⟦ Δ-Type τ ⟧} →
    df ≈ dg WRT (expect-volatility {τ}) → df ≡ dg

volatility⇒identity {nats} df≈dg = df≈dg
volatility⇒identity {bags} df≈dg = df≈dg
volatility⇒identity {τ₁ ⇒ τ₂} {df} {dg} df≈dg =
  extensionality (λ x → extensionality (λ dx →
    volatility⇒identity {τ₂} (df≈dg {x} {dx})))

df≈df : ∀ {τ} {df : ⟦ Δ-Type τ ⟧} {args : Args τ} → df ≈ df WRT args
df≈df {nats} = refl
df≈df {bags} = refl
df≈df {τ₁ ⇒ τ₂} {df} {abide args} =
  λ {x} {dx} _ → df≈df {τ₂} {df x dx} {args}
df≈df {τ₁ ⇒ τ₂} {df} {alter args} =
  λ {x} {dx}   → df≈df {τ₂} {df x dx} {args}

too-close : ∀ {τ Γ} {args : Args τ} →
  {df dg : Term (Δ-Context Γ) (Δ-Type τ)} {ρ : ⟦ Δ-Context Γ ⟧} →
  df ≡ dg → ⟦ df ⟧ ρ ≈ ⟦ dg ⟧ ρ WRT args

too-close {τ}{_} {args} {df} {dg} {ρ} df=dg
  rewrite df=dg = df≈df {τ} {⟦ dg ⟧ ρ} {args}

-- A variable does not change if its value is unchanging.
stabilityVar : ∀ {τ Γ} → (x : Var Γ τ) (vars : Vars Γ) →
  stableVar x vars ≡ true →
  ∀ {ρ : ⟦ Δ-Context Γ ⟧} → Honest vars ρ →
    ⟦ weakenVar Γ≼ΔΓ x ⟧ ρ ⟦⊕⟧ ⟦ deriveVar x ⟧ ρ ≡ ⟦ weakenVar Γ≼ΔΓ x ⟧ ρ

stabilityVar this (alter vars) () (alter honesty)
stabilityVar this (abide vars) refl (abide proof honesty) = proof

stabilityVar {τ} {τ′ • Γ } (that x) (abide vars) truth (abide _ honesty) =
  stabilityVar x vars (trans eq2 truth) honesty
  where
    eq2 : stableVar x vars ≡ stableVar (that {τ} {τ′} {Γ} x) (abide vars)
    eq2 = refl

stabilityVar (that x) (alter vars) truth honesty = {!ditto!}

-- A term does not change if its free variables are unchanging.
stability : ∀ {τ Γ} → (t : Term Γ τ) (vars : Vars Γ) →
  stable t vars ≡ true →
  ∀ {ρ : ⟦ Δ-Context Γ ⟧} → Honest vars ρ →
    ⟦ weaken Γ≼ΔΓ t ⟧ ρ ⟦⊕⟧ ⟦ derive t ⟧ ρ ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ

stability (nat n) vars truth {ρ} _ = refl

stability (bag b) vars truth {ρ} _ = b++∅=b

stability (var x) vars truth {ρ} honesty =
  {!!}
  where
    eq1  : stableVar x vars ≡ stable (var x) vars
    eq1  = refl
    tVar : stableVar x vars ≡ true
    tVar = trans eq1 truth

stability (abs t) vars truth {ρ} honesty = {!!}
stability (app t t₁) vars truth {ρ} honesty = {!!}
stability (add t t₁) vars truth {ρ} honesty = {!!}
stability (map t t₁) vars truth {ρ} honesty = {!!}
stability (diff t t₁) vars truth {ρ} honesty = {!!}
stability (union t t₁) vars truth {ρ} honesty = {!!}

honestyVar : {τ : Type} → {Γ : Context} →
  (args : Args τ) → (vars : Vars Γ) →
  (x : Var Γ τ) → derive (var x) ≡ derive' args vars (var x)
honestyVar ∅-nat vars x = refl
honestyVar ∅-bag vars x = refl
honestyVar (abide args) vars x = refl
honestyVar (alter args) vars x = refl

-- If both the environment and the future arguments are honest
-- about nil changes, then the optimized derivation delivers
-- the same result as the original derivation.
honesty-is-the-best-policy : ∀ {τ Γ} (t : Term Γ τ) →
  (args : Args τ) → (vars : Vars Γ) →
  (ρ : ⟦ Δ-Context Γ ⟧) → Honest vars ρ →
  ⟦ derive t ⟧ ρ ≈ ⟦ derive' args vars t ⟧ ρ WRT args

honesty-is-the-best-policy (app f s) args vars ρ honesty
  with stable s vars | inspect (stable s) vars
... | true  | [ truth ] = {!!}
--  absurd! {!!} (stability s vars truth {ρ}) {!!}

... | false | [ falsehood ] = {!!}

honesty-is-the-best-policy {nats} {Γ} (nat n) args vars ρ honesty =
  begin
    ⟦ derive (nat n) ⟧ ρ
  ≡⟨ cong (λ hole → ⟦ hole ⟧ ρ) (lemma Γ args vars) ⟩
    ⟦ derive' args vars (nat n) ⟧ ρ
  ∎ where
    open ≡-Reasoning
    lemma : (Γ : Context) (args : Args nats) (vars : Vars Γ) →
      derive (nat n) ≡ derive' {nats} {Γ} args vars (nat n)
    lemma ∅ ∅-nat ∅ = refl
    lemma (τ • Γ) ∅-nat (abide vars) = refl
    lemma (τ • Γ) ∅-nat (alter vars) = refl

honesty-is-the-best-policy {bags} {Γ} (bag b) args vars ρ honesty =
  begin
    ⟦ derive (bag b) ⟧ ρ
  ≡⟨ cong (λ hole → ⟦ hole ⟧ ρ) (lemma Γ args vars) ⟩
    ⟦ derive' args vars (bag b) ⟧ ρ
  ∎ where
    open ≡-Reasoning
    lemma : (Γ : Context) (args : Args bags) (vars : Vars Γ) →
      derive (bag b) ≡ derive' {bags} {Γ} args vars (bag b)
    lemma ∅ ∅-bag ∅ = refl
    lemma (τ • Γ) ∅-bag (abide vars) = refl
    lemma (τ • Γ) ∅-bag (alter vars) = refl

honesty-is-the-best-policy {τ} {Γ} (var x) args vars ρ honesty =
  too-close {τ} {Γ} (honestyVar args vars x)

honesty-is-the-best-policy (abs t) (abide args) vars ρ honesty =
  λ {x} {dx} x⊕dx=x → honesty-is-the-best-policy
    t args (abide vars) (dx • x • ρ) (abide x⊕dx=x honesty)

honesty-is-the-best-policy (abs t) (alter args) vars ρ honesty =
  λ {x} {dx} → honesty-is-the-best-policy
    t args (alter vars) (dx • x • ρ) (alter honesty)

honesty-is-the-best-policy (add m n) args vars ρ honesty = {!!}
honesty-is-the-best-policy (map f b) args vars ρ honesty = {!!}
honesty-is-the-best-policy (diff b d) args vars ρ honesty = {!!}
honesty-is-the-best-policy (union b d) args vars ρ honesty = {!!}


Remove inappropriate exec. permission

Remove inappropriate exec. permission

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change contexts
--
-- This module specifies how a context of values is merged
-- together with the corresponding context of changes.
--
-- In the PLDI paper, instead of merging the contexts together, we just
-- concatenate them. For example, in the "typing rule" for Derive
-- in Sec. 3.2 of the paper, we write in the conclusion of the rule:
-- "Γ, ΔΓ ⊢ Derive(t) : Δτ". Simple concatenation is possible because
-- the paper uses named variables and assumes that no user variables
-- start with "d". In this formalization, we use de Bruijn indices, so
-- it is easier to alternate values and their changes in the context.
------------------------------------------------------------------------

module Base.Change.Context
    {Type : Set}
    (ΔType : Type → Type) where

open import Base.Syntax.Context Type

-- Transform a context of values into a context of values and
-- changes.
ΔContext : Context → Context
ΔContext ∅ = ∅
ΔContext (τ • Γ) = ΔType τ • τ • ΔContext Γ

-- like ΔContext, but ΔType τ and τ are swapped
ΔContext′ : Context → Context
ΔContext′ ∅ = ∅
ΔContext′ (τ • Γ) = τ • ΔType τ • ΔContext′ Γ

-- This sub-context relationship explains how to go back from
-- ΔContext Γ to Γ: You have to drop every other binding.
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔContext Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop ΔType τ • keep τ • Γ≼ΔΓ


change is consistent with other things and seems ok

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈[_]    : (Nat × subst) → dhexp
      ⦇_⦈[_]   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × tctx × htyp)
  u ::[ Γ ] τ = u , Γ , τ

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts?
  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ2 τ1 Δ2} →
                Δ1 ## Δ2 →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d τ' Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) → -- todo: i added this
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EASubsume : ∀{e u e' Γ τ' d Δ τ} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ e' ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈[ u , id Γ ] :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 τ ~ τ' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈[ u , id Γ ] :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) →
          (x , d) ∈ σ →
          Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                Δ , Γ ⊢ σ :s: Γ' →
                (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇⦈[ u , σ ] :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇ d ⦈[ u , σ ] :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈[ u , σ ] indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈[ u , σ ] ↦  ⦇ d' ⦈[ u , σ ]
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈[_]    : (Nat × subst) → dhexp
      ⦇_⦈[_]   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × tctx × htyp)
  u ::[ Γ ] τ = u , Γ , τ

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts?
  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ2 τ1 Δ2} →
                Δ1 ## Δ2 →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d τ' Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) → -- todo: i added this
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EASubsume : ∀{e u e' Γ τ' d Δ τ} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ e' ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈[ u , id Γ ] :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 τ ~ τ' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈[ u , id Γ ] :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) →
          (x , d) ∈ σ →
          Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ -- todo: made a change here
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                Δ , Γ ⊢ σ :s: Γ' →
                (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇⦈[ u , σ ] :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇ d ⦈[ u , σ ] :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈[ u , σ ] indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈[ u , σ ] ↦  ⦇ d' ⦈[ u , σ ]
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)


layout

layout

module composition-sem-sec-reduction where

open import Data.Nat.NP using (ℕ)
open import Data.Bits using (vnot; vnot∘vnot≗id)
open import Data.Product using (_,_)
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≗_)

open import flipbased-implem using (run↺; map↺)
open import program-distance using (module PrgDist; PrgDist)
open import flat-funs
open import flat-funs-implem
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|₁ using (M₀; M₁; C₀; C₁; Tr)
  open FunOps

  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₁ A₂ A₃) =
    mk A₀
      (A₁ ⁏ first < pre-E × pre-E >)
      (first post-E ⁏ A₂)
       A₃

module CompSec (prgDist : PrgDist) (ep₀ : EncParams) (|M|₁ |C|₁ : ℕ) where
  open PrgDist prgDist
  open FunSemSec prgDist
  open FunOps
  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⁻¹)

-- As a concrete example this module post-compose a negation of all the
-- bits.
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 FunOps
  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

-- Here we apply a concrete prgDist but still with an abstract precision
-- bound.
module ConcretePrgDist (k : ℕ) where
  open program-distance.Implem k
  module Guess-prgDist     = bit-guessing-game prgDist
  module FunSemSec-prgDist = FunSemSec prgDist
  module CompSec-prgDist   = CompSec prgDist


Support type arguments for infix ≈.

Support type arguments for infix ≈.

Old-commit-hash: e96c855b72f3792e2bc0279596338ed2c82c4c8b

module Denotation.Implementation.Popl14 where

-- Notions of programs being implementations of specifications
-- for Calculus Popl14

open import Denotation.Specification.Canon-Popl14 public
open import Popl14.Syntax.Type
open import Popl14.Syntax.Term
open import Popl14.Change.Derive

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Postulate.Extensionality
open import Popl14.Denotation.WeakenSound

infix 4 implements
syntax implements τ u v = u ≈₍ τ ₎ v
implements : ∀ (τ : Type) → ΔVal τ → ⟦ ΔType τ ⟧ → Set

u ≈₍ int ₎ v = u ≡ v
u ≈₍ bag ₎ v = u ≡ v
u ≈₍ σ ⇒ τ ₎ v =
  (w : ⟦ σ ⟧) (Δw : ΔVal σ) (Δw′ : ⟦ ΔType σ ⟧)
  (R[w,Δw] : valid {σ} w Δw) (Δw≈Δw′ : implements σ Δw Δw′) →
  implements τ (u w Δw R[w,Δw]) (v w Δw′)

infix 4 _≈_
_≈_ : ∀ {τ} → ΔVal τ → ⟦ ΔType τ ⟧ → Set
_≈_ {τ} = implements τ

module Disambiguation (τ : Type) where
  _✚_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚_ = _⟦⊕⟧_ {τ}
  _−_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚_ _−_
  _≃_ : ΔVal τ → ⟦ ΔType τ ⟧ → Set
  _≃_ = _≈_ {τ}
  infix 4 _≃_

module FunctionDisambiguation (σ : Type) (τ : Type) where
  open Disambiguation (σ ⇒ τ) public
  _✚₁_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚₁_ = _⟦⊕⟧_ {τ}
  _−₁_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−₁_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚₁_ _−₁_
  _≃₁_ : ΔVal τ → ⟦ ΔType τ ⟧ → Set
  _≃₁_ = _≈_ {τ}
  infix 4 _≃₁_
  _✚₀_ : ⟦ σ ⟧ → ⟦ ΔType σ ⟧ → ⟦ σ ⟧
  _✚₀_ = _⟦⊕⟧_ {σ}
  _−₀_ : ⟦ σ ⟧ → ⟦ σ ⟧ → ⟦ ΔType σ ⟧
  _−₀_ = _⟦⊝⟧_ {σ}
  infixl 6 _✚₀_ _−₀_
  _≃₀_ : ΔVal σ → ⟦ ΔType σ ⟧ → Set
  _≃₀_ = _≈_ {σ}
  infix 4 _≃₀_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ ΔContext Γ ⟧ → Set
compatible {∅} ∅ ∅ = ⊤
compatible {τ • Γ} (cons v Δv _ ρ) (Δv′ • v′ • ρ′) =
  Triple (v ≡ v′) (λ _ → Δv ≈ Δv′) (λ _ _ → compatible ρ ρ′)

-- If a program implements a specification, then certain things
-- proven about the specification carry over to the programs.
carry-over : ∀ {τ}
  {v : ⟦ τ ⟧} {Δv : ΔVal τ} {Δv′ : ⟦ ΔType τ ⟧}
 (R[v,Δv] : valid v Δv) (Δv≈Δv′ : Δv ≈ Δv′) →
 let open Disambiguation τ in
   v ⊞ Δv ≡ v ✚ Δv′

u⊟v≈u⊝v : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
  let open Disambiguation τ in
    u ⊟ v ≃ u − v
u⊟v≈u⊝v {int} = refl
u⊟v≈u⊝v {bag} = refl
u⊟v≈u⊝v {σ ⇒ τ} {g} {f} = result where
  open FunctionDisambiguation σ τ
  result : (w : ⟦ σ ⟧) (Δw : ΔVal σ) (Δw′ : ⟦ ΔType σ ⟧) →
    valid w Δw → Δw ≈ Δw′ →
    g (w ⊞ Δw) ⊟ f w ≃₁ g (w ✚₀ Δw′) −₁ f w
  result w Δw Δw′ R[w,Δw] Δw≈Δw′
    rewrite carry-over {σ} {w} R[w,Δw] Δw≈Δw′ =
    u⊟v≈u⊝v {τ} {g (w ✚₀ Δw′)} {f w}
carry-over {int} {v} tt Δv≈Δv′ = cong (_+_  v) Δv≈Δv′
carry-over {bag} {v} tt Δv≈Δv′ = cong (_++_ v) Δv≈Δv′
carry-over {σ ⇒ τ} {f} {Δf} {Δf′} R[f,Δf] Δf≈Δf′ =
  ext (λ v →
  let
    open FunctionDisambiguation σ τ
    V = R[v,u-v] {σ} {v} {v}
    S = u⊟v≈u⊝v {σ} {v} {v}
  in
    carry-over {τ} {f v}
      {Δf v (v ⊟ v) V} {Δf′ v (v −₀ v)}
      (proj₁ (R[f,Δf] v (v ⊟ v) V))
      (Δf≈Δf′ v (v ⊟ v) (v −₀ v) V S))

-- A property relating `ignore` and the subcontext relation Γ≼ΔΓ
⟦Γ≼ΔΓ⟧ : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′
⟦Γ≼ΔΓ⟧ {∅} {∅} {∅} _ = refl
⟦Γ≼ΔΓ⟧ {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′}
  (cons v≡v′ _ C) = cong₂ _•_ v≡v′ (⟦Γ≼ΔΓ⟧ C)

-- A specialization of the soundness of weakening
⟦fit⟧ : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ fit t ⟧ ρ′
⟦fit⟧ t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (⟦Γ≼ΔΓ⟧ C)) (sym (weaken-sound t ρ′))

module Denotation.Implementation.Popl14 where

-- Notions of programs being implementations of specifications
-- for Calculus Popl14

open import Denotation.Specification.Canon-Popl14 public
open import Popl14.Syntax.Type
open import Popl14.Syntax.Term
open import Popl14.Change.Derive

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Postulate.Extensionality
open import Popl14.Denotation.WeakenSound

-- Better name for v ≈ ⟦ t ⟧:
-- t implements v.
infix 4 _≈_
_≈_ : ∀ {τ} → ΔVal τ → ⟦ ΔType τ ⟧ → Set
_≈_ {int} u v = u ≡ v
_≈_ {bag} u v = u ≡ v
_≈_ {σ ⇒ τ} u v =
  (w : ⟦ σ ⟧) (Δw : ΔVal σ) (Δw′ : ⟦ ΔType σ ⟧)
  (R[w,Δw] : valid w Δw) (Δw≈Δw′ : Δw ≈ Δw′) →
  u w Δw R[w,Δw] ≈ v w Δw′

module Disambiguation (τ : Type) where
  _✚_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚_ = _⟦⊕⟧_ {τ}
  _−_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚_ _−_
  _≃_ : ΔVal τ → ⟦ ΔType τ ⟧ → Set
  _≃_ = _≈_ {τ}
  infix 4 _≃_

module FunctionDisambiguation (σ : Type) (τ : Type) where
  open Disambiguation (σ ⇒ τ) public
  _✚₁_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚₁_ = _⟦⊕⟧_ {τ}
  _−₁_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−₁_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚₁_ _−₁_
  _≃₁_ : ΔVal τ → ⟦ ΔType τ ⟧ → Set
  _≃₁_ = _≈_ {τ}
  infix 4 _≃₁_
  _✚₀_ : ⟦ σ ⟧ → ⟦ ΔType σ ⟧ → ⟦ σ ⟧
  _✚₀_ = _⟦⊕⟧_ {σ}
  _−₀_ : ⟦ σ ⟧ → ⟦ σ ⟧ → ⟦ ΔType σ ⟧
  _−₀_ = _⟦⊝⟧_ {σ}
  infixl 6 _✚₀_ _−₀_
  _≃₀_ : ΔVal σ → ⟦ ΔType σ ⟧ → Set
  _≃₀_ = _≈_ {σ}
  infix 4 _≃₀_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ ΔContext Γ ⟧ → Set
compatible {∅} ∅ ∅ = ⊤
compatible {τ • Γ} (cons v Δv _ ρ) (Δv′ • v′ • ρ′) =
  Triple (v ≡ v′) (λ _ → Δv ≈ Δv′) (λ _ _ → compatible ρ ρ′)

-- If a program implements a specification, then certain things
-- proven about the specification carry over to the programs.
carry-over : ∀ {τ}
  {v : ⟦ τ ⟧} {Δv : ΔVal τ} {Δv′ : ⟦ ΔType τ ⟧}
 (R[v,Δv] : valid v Δv) (Δv≈Δv′ : Δv ≈ Δv′) →
 let open Disambiguation τ in
   v ⊞ Δv ≡ v ✚ Δv′

u⊟v≈u⊝v : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
  let open Disambiguation τ in
    u ⊟ v ≃ u − v
u⊟v≈u⊝v {int} = refl
u⊟v≈u⊝v {bag} = refl
u⊟v≈u⊝v {σ ⇒ τ} {g} {f} = result where
  open FunctionDisambiguation σ τ
  result : (w : ⟦ σ ⟧) (Δw : ΔVal σ) (Δw′ : ⟦ ΔType σ ⟧) →
    valid w Δw → Δw ≈ Δw′ →
    g (w ⊞ Δw) ⊟ f w ≃₁ g (w ✚₀ Δw′) −₁ f w
  result w Δw Δw′ R[w,Δw] Δw≈Δw′
    rewrite carry-over {σ} {w} R[w,Δw] Δw≈Δw′ =
    u⊟v≈u⊝v {τ} {g (w ✚₀ Δw′)} {f w}
carry-over {int} {v} tt Δv≈Δv′ = cong (_+_  v) Δv≈Δv′
carry-over {bag} {v} tt Δv≈Δv′ = cong (_++_ v) Δv≈Δv′
carry-over {σ ⇒ τ} {f} {Δf} {Δf′} R[f,Δf] Δf≈Δf′ =
  ext (λ v →
  let
    open FunctionDisambiguation σ τ
    V = R[v,u-v] {σ} {v} {v}
    S = u⊟v≈u⊝v {σ} {v} {v}
  in
    carry-over {τ} {f v}
      {Δf v (v ⊟ v) V} {Δf′ v (v −₀ v)}
      (proj₁ (R[f,Δf] v (v ⊟ v) V))
      (Δf≈Δf′ v (v ⊟ v) (v −₀ v) V S))

-- A property relating `ignore` and the subcontext relation Γ≼ΔΓ
⟦Γ≼ΔΓ⟧ : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′
⟦Γ≼ΔΓ⟧ {∅} {∅} {∅} _ = refl
⟦Γ≼ΔΓ⟧ {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′}
  (cons v≡v′ _ C) = cong₂ _•_ v≡v′ (⟦Γ≼ΔΓ⟧ C)

-- A specialization of the soundness of weakening
⟦fit⟧ : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ fit t ⟧ ρ′
⟦fit⟧ t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (⟦Γ≼ΔΓ⟧ C)) (sym (weaken-sound t ρ′))


Use subst instead of rewrite.

Use subst instead of rewrite.

For unknown reasons, this seems to play better with type inference.

Old-commit-hash: 55d911c0be0ad7f2ae6e77af9d5250bf4e4932b2

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity
import Parametric.Change.Specification as Specification
import Parametric.Change.Type as ChangeType
import Parametric.Change.Term as ChangeTerm
import Parametric.Change.Value as ChangeValue
import Parametric.Change.Evaluation as ChangeEvaluation
import Parametric.Change.Derive as Derive
import Parametric.Change.Implementation as Implementation

module Parametric.Change.Correctness
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (diff-base : ChangeTerm.DiffStructure Const ΔBase)
    (apply-base : ChangeTerm.ApplyStructure Const ΔBase)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
    (meaning-⊕-base : ChangeEvaluation.ApplyStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base ⟦apply-base⟧ ⟦diff-base⟧)
    (meaning-⊝-base : ChangeEvaluation.DiffStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base ⟦apply-base⟧ ⟦diff-base⟧)
    (validity-structure : Validity.Structure ⟦_⟧Base)
    (specification-structure : Specification.Structure
      Const ⟦_⟧Base ⟦_⟧Const validity-structure)
    (derive-const : Derive.Structure Const ΔBase)
    (implementation-structure : Implementation.Structure
      Const ⟦_⟧Base ⟦_⟧Const ΔBase
      validity-structure specification-structure
      ⟦apply-base⟧ ⟦diff-base⟧ derive-const)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base validity-structure
open Specification.Structure
  Const ⟦_⟧Base ⟦_⟧Const validity-structure specification-structure
open ChangeType.Structure Base ΔBase
open ChangeTerm.Structure Const ΔBase diff-base apply-base
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧
open ChangeEvaluation.Structure
  ⟦_⟧Base ⟦_⟧Const ΔBase
  apply-base diff-base
  ⟦apply-base⟧ ⟦diff-base⟧
  meaning-⊕-base meaning-⊝-base
open Derive.Structure Const ΔBase derive-const
open Implementation.Structure
  Const ⟦_⟧Base ⟦_⟧Const ΔBase validity-structure specification-structure
  ⟦apply-base⟧ ⟦diff-base⟧ derive-const implementation-structure

-- The denotational properties of the `derive` transformation.
-- In particular, the main theorem about it producing the correct
-- incremental behavior.

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality

Structure : Set
Structure = ∀ {Σ Γ τ} (c : Const Σ τ) (ts : Terms Γ Σ)
  (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
  (ts-correct : implements-env Σ (⟦ ts ⟧ΔTerms ρ dρ) (⟦ derive-terms ts ⟧Terms (alternate ρ ρ′))) →
  ⟦ c ⟧ΔConst (⟦ ts ⟧Terms ρ) (⟦ ts ⟧ΔTerms ρ dρ) ≈₍ τ ₎ ⟦ derive-const c (fit-terms ts) (derive-terms ts) ⟧ (alternate ρ ρ′)

module Structure (derive-const-correct : Structure) where
  deriveVar-correct : ∀ {τ Γ} (x : Var Γ τ)
    (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    ⟦ x ⟧ΔVar ρ dρ ≈₍ τ ₎ ⟦ deriveVar x ⟧ (alternate ρ ρ′)
  deriveVar-correct this (v • ρ) (dv • dρ) (dv′ • dρ′) (dv≈dv′ • dρ≈dρ′) = dv≈dv′
  deriveVar-correct (that x) (v • ρ) (dv • dρ) (dv′ • dρ′) (dv≈dv′ • dρ≈dρ′) = deriveVar-correct x ρ dρ dρ′ dρ≈dρ′

  -- That `derive t` implements ⟦ t ⟧Δ
  derive-correct : ∀ {τ Γ} (t : Term Γ τ)
    (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    ⟦ t ⟧Δ ρ dρ ≈₍ τ ₎ ⟦ derive t ⟧ (alternate ρ ρ′)

  derive-terms-correct : ∀ {Σ Γ} (ts : Terms Γ Σ)
    (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    implements-env Σ (⟦ ts ⟧ΔTerms ρ dρ) (⟦ derive-terms ts ⟧Terms (alternate ρ ρ′))

  derive-terms-correct ∅ ρ dρ ρ′ dρ≈ρ′ = ∅
  derive-terms-correct (t • ts) ρ dρ ρ′ dρ≈ρ′ =
    derive-correct t ρ dρ ρ′ dρ≈ρ′ • derive-terms-correct ts ρ dρ ρ′ dρ≈ρ′

  derive-correct (const c ts) ρ dρ ρ′ dρ≈ρ′ =
    derive-const-correct c ts ρ dρ ρ′ dρ≈ρ′
      (derive-terms-correct ts ρ dρ ρ′ dρ≈ρ′)
  derive-correct (var x) ρ dρ ρ′ dρ≈ρ′ =
    deriveVar-correct x ρ dρ ρ′ dρ≈ρ′
  derive-correct (app {σ} {τ} s t) ρ dρ ρ′ dρ≈ρ′
   = subst (λ ⟦t⟧ → ⟦ app s t ⟧Δ ρ dρ ≈₍ τ ₎ (⟦ derive s ⟧Term (alternate ρ ρ′)) ⟦t⟧ (⟦ derive t ⟧Term (alternate ρ ρ′))) (⟦fit⟧ t ρ ρ′)
       (derive-correct {σ ⇒ τ} s ρ dρ ρ′ dρ≈ρ′
          (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ) (⟦ derive t ⟧ (alternate ρ ρ′)) (derive-correct {σ} t ρ dρ ρ′ dρ≈ρ′))

  derive-correct (abs {σ} {τ} t) ρ dρ ρ′ dρ≈ρ′ =
    λ w dw w′ dw≈w′ →
      derive-correct t (w • ρ) (dw • dρ) (w′ • ρ′) (dw≈w′ • dρ≈ρ′)

  main-theorem : ∀ {σ τ}
    {f : Term ∅ (σ ⇒ τ)} {x : Term ∅ σ} {y : Term ∅ σ}
    → ⟦ app f y ⟧
    ≡ ⟦ app f x ⊕₍ τ ₎ app (app (derive f) x) (y ⊝ x) ⟧

  main-theorem {σ} {τ} {f} {x} {y} =
    let
      h  = ⟦ f ⟧ ∅
      Δh = ⟦ f ⟧Δ ∅ ∅
      Δh′ = ⟦ derive f ⟧ ∅
      v  = ⟦ x ⟧ ∅
      u  = ⟦ y ⟧ ∅
      Δoutput-term = app (app (derive f) x) (y ⊝ x)
    in
      ext {A = ⟦ ∅ ⟧Context} (λ { ∅ →
      begin
        h u
      ≡⟨ cong h (sym (v+[u-v]=u {σ})) ⟩
        h (v ⊞₍ σ ₎ (u ⊟₍ σ ₎ v))
      ≡⟨ corollary-closed {σ} {τ} f v (u ⊟₍ σ ₎ v) ⟩
        h v ⊞₍ τ ₎ call-change {σ} {τ} Δh v (u ⊟₍ σ ₎ v)
      ≡⟨ carry-over {τ}
         (call-change {σ} {τ} Δh v (u ⊟₍ σ ₎ v))
         (derive-correct f
           ∅ ∅ ∅ ∅ v (u ⊟₍ σ ₎ v) (u ⟦⊝₍ σ ₎⟧ v) (u⊟v≈u⊝v {σ} {u} {v})) ⟩
         h v ⟦⊕₍ τ ₎⟧ Δh′ v (u ⟦⊝₍ σ ₎⟧ v)
      ≡⟨ trans
         (cong (λ hole → h v ⟦⊕₍ τ ₎⟧ Δh′ v hole) (meaning-⊝ {σ} {s = y} {x}))
         (meaning-⊕ {t = app f x} {Δt = Δoutput-term}) ⟩
         ⟦ app f x ⊕₍ τ ₎ app (app (derive f) x) (y ⊝ x) ⟧ ∅
      ∎}) where open ≡-Reasoning

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity
import Parametric.Change.Specification as Specification
import Parametric.Change.Type as ChangeType
import Parametric.Change.Term as ChangeTerm
import Parametric.Change.Value as ChangeValue
import Parametric.Change.Evaluation as ChangeEvaluation
import Parametric.Change.Derive as Derive
import Parametric.Change.Implementation as Implementation

module Parametric.Change.Correctness
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (diff-base : ChangeTerm.DiffStructure Const ΔBase)
    (apply-base : ChangeTerm.ApplyStructure Const ΔBase)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
    (meaning-⊕-base : ChangeEvaluation.ApplyStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base ⟦apply-base⟧ ⟦diff-base⟧)
    (meaning-⊝-base : ChangeEvaluation.DiffStructure
      ⟦_⟧Base ⟦_⟧Const ΔBase apply-base diff-base ⟦apply-base⟧ ⟦diff-base⟧)
    (validity-structure : Validity.Structure ⟦_⟧Base)
    (specification-structure : Specification.Structure
      Const ⟦_⟧Base ⟦_⟧Const validity-structure)
    (derive-const : Derive.Structure Const ΔBase)
    (implementation-structure : Implementation.Structure
      Const ⟦_⟧Base ⟦_⟧Const ΔBase
      validity-structure specification-structure
      ⟦apply-base⟧ ⟦diff-base⟧ derive-const)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base validity-structure
open Specification.Structure
  Const ⟦_⟧Base ⟦_⟧Const validity-structure specification-structure
open ChangeType.Structure Base ΔBase
open ChangeTerm.Structure Const ΔBase diff-base apply-base
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧
open ChangeEvaluation.Structure
  ⟦_⟧Base ⟦_⟧Const ΔBase
  apply-base diff-base
  ⟦apply-base⟧ ⟦diff-base⟧
  meaning-⊕-base meaning-⊝-base
open Derive.Structure Const ΔBase derive-const
open Implementation.Structure
  Const ⟦_⟧Base ⟦_⟧Const ΔBase validity-structure specification-structure
  ⟦apply-base⟧ ⟦diff-base⟧ derive-const implementation-structure

-- The denotational properties of the `derive` transformation.
-- In particular, the main theorem about it producing the correct
-- incremental behavior.

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality

Structure : Set
Structure = ∀ {Σ Γ τ} (c : Const Σ τ) (ts : Terms Γ Σ)
  (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
  (ts-correct : implements-env Σ (⟦ ts ⟧ΔTerms ρ dρ) (⟦ derive-terms ts ⟧Terms (alternate ρ ρ′))) →
  ⟦ c ⟧ΔConst (⟦ ts ⟧Terms ρ) (⟦ ts ⟧ΔTerms ρ dρ) ≈₍ τ ₎ ⟦ derive-const c (fit-terms ts) (derive-terms ts) ⟧ (alternate ρ ρ′)

module Structure (derive-const-correct : Structure) where
  deriveVar-correct : ∀ {τ Γ} (x : Var Γ τ)
    (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    ⟦ x ⟧ΔVar ρ dρ ≈₍ τ ₎ ⟦ deriveVar x ⟧ (alternate ρ ρ′)
  deriveVar-correct this (v • ρ) (dv • dρ) (dv′ • dρ′) (dv≈dv′ • dρ≈dρ′) = dv≈dv′
  deriveVar-correct (that x) (v • ρ) (dv • dρ) (dv′ • dρ′) (dv≈dv′ • dρ≈dρ′) = deriveVar-correct x ρ dρ dρ′ dρ≈dρ′

  -- That `derive t` implements ⟦ t ⟧Δ
  derive-correct : ∀ {τ Γ} (t : Term Γ τ)
    (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    ⟦ t ⟧Δ ρ dρ ≈₍ τ ₎ ⟦ derive t ⟧ (alternate ρ ρ′)

  derive-terms-correct : ∀ {Σ Γ} (ts : Terms Γ Σ)
    (ρ : ⟦ Γ ⟧) (dρ : ΔEnv Γ ρ) (ρ′ : ⟦ mapContext ΔType Γ ⟧) (dρ≈ρ′ : implements-env Γ dρ ρ′) →
    implements-env Σ (⟦ ts ⟧ΔTerms ρ dρ) (⟦ derive-terms ts ⟧Terms (alternate ρ ρ′))

  derive-terms-correct ∅ ρ dρ ρ′ dρ≈ρ′ = ∅
  derive-terms-correct (t • ts) ρ dρ ρ′ dρ≈ρ′ =
    derive-correct t ρ dρ ρ′ dρ≈ρ′ • derive-terms-correct ts ρ dρ ρ′ dρ≈ρ′

  derive-correct (const c ts) ρ dρ ρ′ dρ≈ρ′ =
    derive-const-correct c ts ρ dρ ρ′ dρ≈ρ′
      (derive-terms-correct ts ρ dρ ρ′ dρ≈ρ′)
  derive-correct (var x) ρ dρ ρ′ dρ≈ρ′ =
    deriveVar-correct x ρ dρ ρ′ dρ≈ρ′
  derive-correct (app s t) ρ dρ ρ′ dρ≈ρ′
    rewrite sym (⟦fit⟧ t ρ ρ′) =
      derive-correct s ρ dρ ρ′ dρ≈ρ′
      (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ) (⟦ derive t ⟧ (alternate ρ ρ′)) (derive-correct t ρ dρ ρ′ dρ≈ρ′)

  derive-correct (abs {σ} {τ} t) ρ dρ ρ′ dρ≈ρ′ =
    λ w dw w′ dw≈w′ →
      derive-correct t (w • ρ) (dw • dρ) (w′ • ρ′) (dw≈w′ • dρ≈ρ′)

  main-theorem : ∀ {σ τ}
    {f : Term ∅ (σ ⇒ τ)} {x : Term ∅ σ} {y : Term ∅ σ}
    → ⟦ app f y ⟧
    ≡ ⟦ app f x ⊕₍ τ ₎ app (app (derive f) x) (y ⊝ x) ⟧

  main-theorem {σ} {τ} {f} {x} {y} =
    let
      h  = ⟦ f ⟧ ∅
      Δh = ⟦ f ⟧Δ ∅ ∅
      Δh′ = ⟦ derive f ⟧ ∅
      v  = ⟦ x ⟧ ∅
      u  = ⟦ y ⟧ ∅
      Δoutput-term = app (app (derive f) x) (y ⊝ x)
    in
      ext {A = ⟦ ∅ ⟧Context} (λ { ∅ →
      begin
        h u
      ≡⟨ cong h (sym (v+[u-v]=u {σ})) ⟩
        h (v ⊞₍ σ ₎ (u ⊟₍ σ ₎ v))
      ≡⟨ corollary-closed {σ} {τ} f v (u ⊟₍ σ ₎ v) ⟩
        h v ⊞₍ τ ₎ call-change {σ} {τ} Δh v (u ⊟₍ σ ₎ v)
      ≡⟨ carry-over {τ}
         (call-change {σ} {τ} Δh v (u ⊟₍ σ ₎ v))
         (derive-correct f
           ∅ ∅ ∅ ∅ v (u ⊟₍ σ ₎ v) (u ⟦⊝₍ σ ₎⟧ v) (u⊟v≈u⊝v {σ} {u} {v})) ⟩
         h v ⟦⊕₍ τ ₎⟧ Δh′ v (u ⟦⊝₍ σ ₎⟧ v)
      ≡⟨ trans
         (cong (λ hole → h v ⟦⊕₍ τ ₎⟧ Δh′ v hole) (meaning-⊝ {σ} {s = y} {x}))
         (meaning-⊕ {t = app f x} {Δt = Δoutput-term}) ⟩
         ⟦ app f x ⊕₍ τ ₎ app (app (derive f) x) (y ⊝ x) ⟧ ∅
      ∎}) where open ≡-Reasoning


simplified otp-lem by factor it a little

module otp-lem where

open import Level
open import Algebra.FunctionProperties
open import Data.Product

open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP
open import Search.Type
open import Search.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)(f : A → B)(searchA : Search zero A)(f-homo : GroupHomomorphism GA GB f)([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
              (sui : ∀ k → StableUnder searchA (flip (Group._∙_ GA) k))(search-ext : SearchExt searchA) where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the search (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the search function respects extensionality
  -}

  {-
   I had some problems with using the standard library definiton of Groups
   so I rolled my own, therefor I need some boring proofs first

  -}

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎
  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

  -}

  -- this proof isn't actually any hard..
  thm : ∀ {X}(op : X → X → X)(O : B → X) m₀ m₁ → searchA op (λ x → O (f x * m₀)) ≡ searchA op (λ x → O (f x * m₁))
  thm op O m₀ m₁ = searchA op (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) op (λ x → O (f x * m₀)) ⟩
                   searchA op (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ search-ext op (λ x → cong O (lemma1 x)) ⟩
                   searchA op (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) op (λ x → O (f x)) ⟩
                   searchA op (λ x → O (f (x + [f] m₁)))
                 ≡⟨ search-ext op (λ x → cong O (lemma2 x)) ⟩
                   searchA op (λ x → O (f x * m₁))
                 ∎
    where
      open ≡-Reasoning

      lemma1 : ∀ x → f (x + - [f] m₀) * m₀ ≡ f x
      lemma1 x rewrite f-homo x (- [f] m₀)
                     | f-pres-inv ([f] m₀)
                     | f-sur m₀
                     | Group.assoc GB (f x) (1/ m₀) m₀
                     | proj₁ (Group.inverse GB) m₀
                     | proj₂ (Group.identity GB) (f x) = refl

      lemma2 : ∀ x → f (x + [f] m₁) ≡ f x * m₁
      lemma2 x rewrite f-homo x ([f] m₁)
                     | f-sur m₁ = refl

module otp-lem where

open import Level
open import Algebra.FunctionProperties
open import Data.Product

open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP
open import Search.Type
open import Search.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)(f : A → B)(searchA : Search zero A)(f-homo : GroupHomomorphism GA GB f)([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
              (sui : ∀ k → StableUnder searchA (flip (Group._∙_ GA) k))(search-ext : SearchExt searchA) where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the search (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the search function respects extensionality
  -}

  {-
   I had some problems with using the standard library definiton of Groups
   so I rolled my own, therefor I need some boring proofs first

  -}

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎
  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

    Should be possible to simplify a little, or atleast name some parts betweeen calls of sui..
  -}

  -- this proof isn't actually any hard..
  thm : ∀ {X}(op : X → X → X)(O : B → X) m₀ m₁ → searchA op (λ x → O (f x * m₀)) ≡ searchA op (λ x → O (f x * m₁))
  thm op O m₀ m₁ = searchA op (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) op (λ x → O (f x * m₀)) ⟩
                   searchA op (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ search-ext op (λ x → cong (λ p → O (p * m₀)) (f-homo x (- [f] m₀))) ⟩
                   searchA op (λ x → O ((f x * f(- [f] m₀))  * m₀))
                 ≡⟨ cong (λ p → searchA op (λ x → O ((f x * p) * m₀))) (f-pres-inv ([f] m₀)) ⟩
                   searchA op (λ x → O ((f x * 1/ f([f] m₀))  * m₀))
                 ≡⟨ search-ext op (λ x → cong O (Group.assoc GB (f x) (1/ f ([f] m₀)) m₀)) ⟩
                   searchA op (λ x → O (f x * (1/ f([f] m₀)  * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * (1/ p * m₀)))) (f-sur m₀) ⟩
                   searchA op (λ x → O (f x * (1/ m₀ * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (proj₁ (Group.inverse GB) m₀) ⟩
                   searchA op (λ x → O (f x * 1g))
                 ≡⟨ search-ext op (λ x → cong O (proj₂ (Group.identity GB) (f x))) ⟩
                   searchA op (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) op (λ x → O (f x)) ⟩
                   searchA op (λ x → O (f (x + [f] m₁)))
                 ≡⟨ search-ext op (λ x → cong O (f-homo x ([f] m₁))) ⟩
                   searchA op (λ x → O (f x * f ([f] m₁)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (f-sur m₁) ⟩
                   searchA op (λ x → O (f x * m₁))
                 ∎
    where
      open ≡-Reasoning