s/ColistF/ListF.

s/ColistF/ListF.

------------------------------------------------------------------------------
-- Co-lists
------------------------------------------------------------------------------

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

module GFPs.Colist where

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Colist is a greatest fixed-point of a functor

-- The functor.
ListF : (D → Set) → D → Set
ListF A xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')

-- Colist is the greatest fixed-point of ListF.
postulate
  Colist : D → Set

  -- Colist is a post-fixed point of ListF, i.e.
  --
  -- Colist ≤ ListF Colist.
  Colist-out-ho : ∀ {n} → Colist n → ListF Colist n

  -- Colist is the greatest post-fixed point of ListF, i.e.
  --
  -- ∀ A. A ≤ ListF A ⇒ A ≤ Colist.
  Colist-coind-ho :
    (A : D → Set) →
    -- A is post-fixed point of ListF.
    (∀ {xs} → A xs → ListF A xs) →
    -- Colist is greater than A.
    ∀ {xs} → A xs → Colist xs

------------------------------------------------------------------------------
-- First-order versions

Colist-out : ∀ {xs} →
             Colist xs →
             xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')
Colist-out = Colist-out-ho

Colist-coind :
  (A : D → Set) →
  (∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')) →
  ∀ {xs} → A xs → Colist xs
Colist-coind = Colist-coind-ho

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Colist predicate is also a pre-fixed point of the functional ListF,
-- i.e.
--
-- ListF Colist ≤ Colist.
Colist-in-ho : ∀ {xs} → ListF Colist xs → Colist xs
Colist-in-ho h = Colist-coind-ho A h' h
  where
  A : D → Set
  A xs = ListF Colist xs

  h' : ∀ {xs} → A xs → ListF A xs
  h' (inj₁ xs≡0) = inj₁ xs≡0
  h' (inj₂ (x' , xs' , prf , CLxs' )) =
    inj₂ (x' , xs' , prf , Colist-out CLxs')

-- The first-order version.
Colist-in : ∀ {xs} →
            xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs') →
            Colist xs
Colist-in = Colist-in-ho

------------------------------------------------------------------------------
-- A stronger co-induction principle
--
-- From (Paulson, 1997. p. 16).

postulate
  Colist-coind-stronger-ho :
    (A : D → Set) →
    (∀ {xs} → A xs → ListF A xs ∨ Colist xs) →
    ∀ {xs} → A xs → Colist xs

Colist-coind-ho' :
  (A : D → Set) →
  (∀ {xs} → A xs → ListF A xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-ho' A h Axs =
  Colist-coind-stronger-ho A (λ Ays → inj₁ (h Ays)) Axs

-- The first-order version.
Colist-coind-stronger :
  (A : D → Set) →
  (∀ {xs} → A xs →
    (xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'))
    ∨ Colist xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-stronger = Colist-coind-stronger-ho

-- 13 January 2014. As expected, we cannot prove
-- Colist-coind-stronger-ho from Colist-coind-ho.
Colist-coind-stronger-ho' :
  (A : D → Set) →
  (∀ {xs} → A xs → ListF A xs ∨ Colist xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-stronger-ho' A h {xs} Axs = case prf (λ h' → h') (h Axs)
  where
  prf : ListF A xs → Colist xs
  prf h' = Colist-coind-ho A {!!} Axs

------------------------------------------------------------------------------
-- References
--
-- Paulson, L. C. (1997). Mechanizing Coinduction and Corecursion in
-- Higher-order Logic. In: Journal of Logic and Computation 7.2,
-- pp. 175–204.

------------------------------------------------------------------------------
-- Co-lists
------------------------------------------------------------------------------

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

module GFPs.Colist where

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Colist is a greatest fixed-point of a functor

-- The functor.
ColistF : (D → Set) → D → Set
ColistF A xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')

-- Colist is the greatest fixed-point of ColistF.
postulate
  Colist : D → Set

  -- Colist is a post-fixed point of ColistF, i.e.
  --
  -- Colist ≤ ColistF Colist.
  Colist-out-ho : ∀ {n} → Colist n → ColistF Colist n

  -- Colist is the greatest post-fixed point of ColistF, i.e.
  --
  -- ∀ A. A ≤ ColistF A ⇒ A ≤ Colist.
  Colist-coind-ho :
    (A : D → Set) →
    -- A is post-fixed point of ColistF.
    (∀ {xs} → A xs → ColistF A xs) →
    -- Colist is greater than A.
    ∀ {xs} → A xs → Colist xs

------------------------------------------------------------------------------
-- First-order versions

Colist-out : ∀ {xs} →
             Colist xs →
             xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')
Colist-out = Colist-out-ho

Colist-coind :
  (A : D → Set) →
  (∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')) →
  ∀ {xs} → A xs → Colist xs
Colist-coind = Colist-coind-ho

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Colist predicate is also a pre-fixed point of the functional
-- ColistF, i.e.
--
-- ColistF Colist ≤ Colist.
Colist-in-ho : ∀ {xs} → ColistF Colist xs → Colist xs
Colist-in-ho h = Colist-coind-ho A h' h
  where
  A : D → Set
  A xs = ColistF Colist xs

  h' : ∀ {xs} → A xs → ColistF A xs
  h' (inj₁ xs≡0) = inj₁ xs≡0
  h' (inj₂ (x' , xs' , prf , CLxs' )) =
    inj₂ (x' , xs' , prf , Colist-out CLxs')

-- The first-order version.
Colist-in : ∀ {xs} →
            xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs') →
            Colist xs
Colist-in = Colist-in-ho

------------------------------------------------------------------------------
-- A stronger co-induction principle
--
-- From (Paulson, 1997. p. 16).

postulate
  Colist-coind-stronger-ho :
    (A : D → Set) →
    (∀ {xs} → A xs → ColistF A xs ∨ Colist xs) →
    ∀ {xs} → A xs → Colist xs

Colist-coind-ho' :
  (A : D → Set) →
  (∀ {xs} → A xs → ColistF A xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-ho' A h Axs =
  Colist-coind-stronger-ho A (λ Ays → inj₁ (h Ays)) Axs

-- The first-order version.
Colist-coind-stronger :
  (A : D → Set) →
  (∀ {xs} → A xs →
    (xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'))
    ∨ Colist xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-stronger = Colist-coind-stronger-ho

-- 13 January 2014. As expected, we cannot prove
-- Colist-coind-stronger-ho from Colist-coind-ho.
Colist-coind-stronger-ho' :
  (A : D → Set) →
  (∀ {xs} → A xs → ColistF A xs ∨ Colist xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-stronger-ho' A h {xs} Axs = case prf (λ h' → h') (h Axs)
  where
  prf : ColistF A xs → Colist xs
  prf h' = Colist-coind-ho A {!!} Axs

------------------------------------------------------------------------------
-- References
--
-- Paulson, L. C. (1997). Mechanizing Coinduction and Corecursion in
-- Higher-order Logic. In: Journal of Logic and Computation 7.2,
-- pp. 175–204.


Adapt the compression attack to Message × Message interface

-- Compression can be used an an Oracle to defeat encryption.
-- Here we show how compressing before encrypting lead to a
-- NOT semantically secure construction (IND-CPA).
module Attack.Compression where

open import Type using (★)
open import Function
open import Data.Nat.NP
open import Data.Two hiding (_==_)
open import Data.Product
open import Data.Zero
open import Relation.Binary.PropositionalEquality.NP

import Game.IND-CPA

record Sized (A : ★) : ★ where
  field
    size  : A → ℕ

open Sized {{...}}

module _ {A B} {{_ : Sized A}} {{_ : Sized B}} where
    -- Same size
    _==ˢ_ : A → B → 𝟚
    x ==ˢ y = size x == size y

    -- Same size
    _≡ˢ_ : A → B → ★
    x ≡ˢ y = size x ≡ size y

    ≡ˢ→==ˢ : ∀ {x y} → x ≡ˢ y → (x ==ˢ y) ≡ 1₂
    ≡ˢ→==ˢ {x} {y} x≡ˢy rewrite x≡ˢy = ✓→≡ (==.refl {size y})

    ==ˢ→≡ˢ : ∀ {x y} → (x ==ˢ y) ≡ 1₂ → x ≡ˢ y
    ==ˢ→≡ˢ p = ==.sound _ _ (≡→✓ p)

module _ {PubKey Message CipherText Rₑ : ★}
         (Enc  : PubKey → Message → Rₑ → CipherText)
         {{_ : Sized Message}}
         {{_ : Sized CipherText}}
  where
    -- Encryption size is independant of the randomness
    EncSizeRndInd =
      ∀ {pk m r₀ r₁} → Enc pk m r₀ ≡ˢ Enc pk m r₁

    -- Encrypted ciphertexts of the same size, will lead to messages of the same size
    EncLeakSize =
      ∀ {pk m₀ m₁ r₀ r₁} → Enc pk m₀ r₀ ≡ˢ Enc pk m₁ r₁ → m₀ ≡ˢ m₁

module M
  {Message CompressedMessage : ★}
  {{_ : Sized CompressedMessage}}

  (compress : Message → CompressedMessage)

  -- 2 messages which have different size after compression
  (m₀ m₁ : Message)
  (different-compression
     : size (compress m₀) ≢ size (compress m₁))

  (PubKey     : ★)
  (SecKey     : ★)
  (CipherText : ★)
  {{_ : Sized CipherText}}
  (Rₑ Rₖ Rₓ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc₀ : PubKey → CompressedMessage → Rₑ → CipherText)
  (Enc₀SizeRndInd : EncSizeRndInd Enc₀)
  (Enc₀LeakSize : EncLeakSize Enc₀)
  where

  -- Our adversary runs one encryption
  Rₐ = Rₑ

  Enc₁ : PubKey → Message → Rₑ → CipherText
  Enc₁ pk m rₑ = Enc₀ pk (compress m) rₑ

  module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText
                                Rₑ Rₖ Rₐ Rₓ KeyGen Enc₁

  adv : IND-CPA.Adv
  adv = (λ { _  _    → [0: m₀ 1: m₁ ] })
      , (λ { rₑ pk c → c ==ˢ Enc₁ pk m₁ rₑ })

  -- The adversary adv is always winning.
  adv-win : ∀ {r} b → IND-CPA.⅁ b adv r ≡ b
  adv-win 0₂ = ≢1→≡0 (different-compression ∘ Enc₀LeakSize ∘ ==ˢ→≡ˢ)
  adv-win 1₂ = ≡ˢ→==ˢ Enc₀SizeRndInd

-- Compression can be used an an Oracle to defeat encryption.
-- Here we show how compressing before encrypting lead to a
-- NOT semantically secure construction (IND-CPA).
module Attack.Compression where

open import Type using (★)
open import Function
open import Data.Nat.NP
open import Data.Two hiding (_==_)
open import Data.Product
open import Data.Zero
open import Relation.Binary.PropositionalEquality.NP

import Game.IND-CPA

record Sized (A : ★) : ★ where
  field
    size  : A → ℕ

open Sized {{...}}

module _ {A B} {{_ : Sized A}} {{_ : Sized B}} where
    -- Same size
    _==ˢ_ : A → B → 𝟚
    x ==ˢ y = size x == size y

    -- Same size
    _≡ˢ_ : A → B → ★
    x ≡ˢ y = size x ≡ size y

    ≡ˢ→==ˢ : ∀ {x y} → x ≡ˢ y → (x ==ˢ y) ≡ 1₂
    ≡ˢ→==ˢ {x} {y} x≡ˢy rewrite x≡ˢy = ✓→≡ (==.refl {size y})

    ==ˢ→≡ˢ : ∀ {x y} → (x ==ˢ y) ≡ 1₂ → x ≡ˢ y
    ==ˢ→≡ˢ p = ==.sound _ _ (≡→✓ p)

module _ {PubKey Message CipherText Rₑ : ★}
         (Enc  : PubKey → Message → Rₑ → CipherText)
         {{_ : Sized Message}}
         {{_ : Sized CipherText}}
  where
    -- Encryption size is independant of the randomness
    EncSizeRndInd =
      ∀ {pk m r₀ r₁} → Enc pk m r₀ ≡ˢ Enc pk m r₁

    -- Encrypted ciphertexts of the same size, will lead to messages of the same size
    EncLeakSize =
      ∀ {pk m₀ m₁ r₀ r₁} → Enc pk m₀ r₀ ≡ˢ Enc pk m₁ r₁ → m₀ ≡ˢ m₁

module M
  {Message CompressedMessage : ★}
  {{_ : Sized CompressedMessage}}

  (compress : Message → CompressedMessage)

  -- 2 messages which have different size after compression
  (m : 𝟚 → Message)
  (different-compression
     : size (compress (m 0₂)) ≢ size (compress (m 1₂)))

  (PubKey     : ★)
  (SecKey     : ★)
  (CipherText : ★)
  {{_ : Sized CipherText}}
  (Rₑ Rₖ Rₓ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc₀ : PubKey → CompressedMessage → Rₑ → CipherText)
  (Enc₀SizeRndInd : EncSizeRndInd Enc₀)
  (Enc₀LeakSize : EncLeakSize Enc₀)
  where

  -- Our adversary runs one encryption
  Rₐ = Rₑ

  Enc₁ : PubKey → Message → Rₑ → CipherText
  Enc₁ pk m rₑ = Enc₀ pk (compress m) rₑ

  module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText
                                Rₑ Rₖ Rₐ Rₓ KeyGen Enc₁

  adv : IND-CPA.Adv
  adv = (λ { _  _    → m })
      , (λ { rₑ pk c → c ==ˢ Enc₁ pk (m 1₂) rₑ })

  -- The adversary adv is always winning.
  adv-win : ∀ {r} b → IND-CPA.⅁ b adv r ≡ b
  adv-win 0₂ = ≢1→≡0 (different-compression ∘ Enc₀LeakSize ∘ ==ˢ→≡ˢ)
  adv-win 1₂ = ≡ˢ→==ˢ Enc₀SizeRndInd


Lamport: renamings

Lamport: renamings

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

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

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

H = hash-secret

#signkey1   = OTS1.#signkey
#verifkey1  = OTS1.#verifkey
#signature1 = OTS1.#signature
#signkey    = #message * #signkey1
#verifkey   = #message * #verifkey1
#signature  = #message * #signature1

Digest     = Bits #digest
Seed       = Bits #seed
Secret     = Bits #secret
SignKey    = Bits #signkey
Message    = Bits #message
Signature  = Bits #signature
VerifKey   = Bits #verifkey

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

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

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

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

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

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

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

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

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

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

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

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

H = hash-secret

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

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

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

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

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

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

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

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

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

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

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


Fix argument order for fromto→valid

Fix argument order for fromto→valid

Also make some arguments explicit where it's going to be required soon.

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set
[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2

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

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

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

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.
open import Postulate.Extensionality

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ _ _ _ daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da a1 a2 daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set
[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2

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

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

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

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.
open import Postulate.Extensionality

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ _ _ _ daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da a1 a2 daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ v1 v2 dv → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ v1 v2 dv x → tt
fromto→valid {pair σ τ} (a1 , b1) (a2 , b2) (da , db) (daa , dbb) = (fromto→valid  _ _ _ daa) , (fromto→valid _ _ _ dbb)
fromto→valid {σ ⇒ τ} f1 f2 df dff = λ a da ada →
  fromto→valid _ _ _ (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto _ _ ada)

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid _ _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ _ _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)


agda: clarify implementation of diff-term by adding pseudocode

Old-commit-hash: 531f469c648998b9b89cff66da12e2dbc01a3aea

module Syntactic.Changes where

-- TERMS that operate on CHANGES
--
-- This module defines terms that correspond to the basic change
-- operations, as well as some other helper terms.

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Changes

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

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

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
-- Other problem: in fact, Δ t is not the nil change of t, in this context. That's a problem.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs (abs (var this xor-term var (that this)))
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) (diff-term (var this) (var this)))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
-- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = λ df f → app (app apply-pure-term df) f
apply-term {bool} = _xor-term_

diff-term {τ ⇒ τ₁} =
  λ f₁ f₂ →
  -- The following can be written as:
  -- * Using Unicode symbols for change operations:
  -- λ x dx. (f1 (dx ⊝ x)) ⊝ (f2 x)
  -- * In lambda calculus with names:
  --λx.  λdx. diff           (     f₁                   (apply      dx         x))                 (f₂                        x)
  -- * As a deBrujin-encoded term in Agda:
    abs (abs (diff-term {τ₁} (app (weaken ≼-in-body f₁) (apply-term (var this) (var (that this)))) (app (weaken ≼-in-body f₂) (var (that this)))))
  where
    ≼-in-body = drop (Δ-Type τ) • (drop τ • ≼-refl)

diff-term {bool} = _xor-term_

module Syntactic.Changes where

-- TERMS that operate on CHANGES
--
-- This module defines terms that correspond to the basic change
-- operations, as well as some other helper terms.

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Changes

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

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

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
-- Other problem: in fact, Δ t is not the nil change of t, in this context. That's a problem.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs (abs (var this xor-term var (that this)))
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) (diff-term (var this) (var this)))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
-- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = λ df f → app (app apply-pure-term df) f
apply-term {bool} = _xor-term_

diff-term {τ ⇒ τ₁} =
  λ f₁ f₂ →
  --λx.  λdx. diff           (     f₁                   (apply      dx         x))                 (f₂                        x)
    abs (abs (diff-term {τ₁} (app (weaken ≼-in-body f₁) (apply-term (var this) (var (that this)))) (app (weaken ≼-in-body f₂) (var (that this)))))
  where
    ≼-in-body = drop (Δ-Type τ) • (drop τ • ≼-refl)

diff-term {bool} = _xor-term_


Make the Adequacy module universe polymorphic

{-# OPTIONS --without-K #-}
-- The core properties behind exploration functions
module Explore.Properties where

open import Level.NP using (_⊔_; ₀; ₁; ₛ; Lift)
open import Type using (★₀; ★₁; ★_)
open import Function.NP using (id; _∘′_; _∘_; flip; const; Π; Cmp)
open import Algebra using (Semigroup; module Semigroup; Monoid; module Monoid; CommutativeMonoid; module CommutativeMonoid)
import      Algebra.FunctionProperties.NP
import      Algebra.FunctionProperties.Derived as FPD
open import Algebra.FunctionProperties.Core using (Op₂)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Explicits using (Injective)
open import Data.Nat.NP using (_+_; _*_; _≤_; _+°_)
open import Data.Product using (Σ; _×_; _,_; proj₁; proj₂)
open import Data.Sum  using (_⊎_)
open import Data.Zero using (𝟘)
open import Data.One  using (𝟙)
open import Data.Two  using (𝟚; ✓)
open import Data.Fin  using (Fin)
open import Relation.Binary.NP using (module Setoid-Reasoning; _Preserves₂_⟶_⟶_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≗_)

open import Explore.Core

module FP = Algebra.FunctionProperties.NP Π

module SgrpExtra {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★ _
  C = Carrier
  _≈°_ : ∀ {a} {A : ★ a} (f g : A → C) → ★ _
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {a} {A : ★ a} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong
  !_ = sym

module Sgrp {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg public
  open SgrpExtra sg public

module RawMon {c} {C : ★ c} (rawMon : C × Op₂ C) where
  ε    = proj₁ rawMon
  _∙_  = proj₂ rawMon

module Mon {c ℓ} (m : Monoid c ℓ) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public
  RawMon = C × Op₂ C
  rawMon : RawMon
  rawMon = ε , _∙_

module CMon {c ℓ} (cm : CommutativeMonoid c ℓ) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public
  open FP _≈_

  ∙-interchange : Interchange _∙_ _∙_
  ∙-interchange = FPD.FromAssocCommCong.interchange
                    _≈_ isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

module _ {ℓ a} {A : ★ a} where
    ExploreInd : ∀ p → Explore ℓ A → ★ (a ⊔ ₛ (ℓ ⊔ p))
    ExploreInd p exp =
      ∀ (P  : Explore ℓ A → ★ p)
        (Pε : P empty-explore)
        (P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁))
        (Pf : ∀ x → P (point-explore x))
      → P exp

    module _ {p} where
        point-explore-ind : (x : A) → ExploreInd p (point-explore x)
        point-explore-ind x _ _ _ Pf = Pf x

        empty-explore-ind : ExploreInd p empty-explore
        empty-explore-ind _ Pε _ _ = Pε

        merge-explore-ind : ∀ {e₀ e₁ : Explore ℓ A}
                            → ExploreInd p e₀ → ExploreInd p e₁
                            → ExploreInd p (merge-explore e₀ e₁)
        merge-explore-ind Pe₀ Pe₁ P Pε _P∙_ Pf = (Pe₀ P Pε _P∙_ Pf) P∙ (Pe₁ P Pε _P∙_ Pf)

    ExploreInd₀ : Explore ℓ A → ★ _
    ExploreInd₀ = ExploreInd ₀

    ExploreInd₁ : Explore ℓ A → ★ _
    ExploreInd₁ = ExploreInd ₁

    BigOpMonInd : ∀ p {c} (M : Monoid c ℓ) → BigOpMon M A → ★ _
    BigOpMonInd p {c} M exp =
      ∀ (P  : BigOpMon M A → ★ p)
        (Pε : P (const ε))
        (P∙ : ∀ {e₀ e₁ : BigOpMon M A} → P e₀ → P e₁ → P (λ f → e₀ f ∙ e₁ f))
        (Pf : ∀ x → P (λ f → f x))
        (P≈ : ∀ {e e'} → e ≈° e' → P e → P e')
      → P exp
      where open Mon M

    module _ (eᴬ : Explore {a} (ₛ ℓ) A) where
        Πᵉ : (A → ★ ℓ) → ★ ℓ
        Πᵉ = eᴬ (Lift 𝟙) _×_

        Σᵉ : (A → ★ ℓ) → ★ ℓ
        Σᵉ = eᴬ (Lift 𝟘) _⊎_

module _ {ℓ a} {A : ★ a} where
    module _ (eᴬ : Explore (ₛ ℓ) A) where
        Lookup : ★ (ₛ ℓ ⊔ a)
        Lookup = ∀ {P : A → ★ ℓ} → Πᵉ eᴬ P → Π A P

        -- alternative name suggestion: tabulate
        Reify : ★ (a ⊔ ₛ ℓ)
        Reify = ∀ {P : A → ★ ℓ} → Π A P → Πᵉ eᴬ P

        Unfocus : ★ (a ⊔ ₛ ℓ)
        Unfocus = ∀ {P : A → ★ ℓ} → Σᵉ eᴬ P → Σ A P

        -- alternative name suggestion: inject
        Focus : ★ (a ⊔ ₛ ℓ)
        Focus = ∀ {P : A → ★ ℓ} → Σ A P → Σᵉ eᴬ P

    Adequate-Σ : ((A → ★ ℓ) → ★ _) → ★ _
    Adequate-Σ Σᴬ = ∀ F → Σᴬ F ≡ Σ A F

    Adequate-Π : ((A → ★ ℓ) → ★ _) → ★ _
    Adequate-Π Πᴬ = ∀ F → Πᴬ F ≡ Π A F

-- This module could be parameterised by the relation on types, here _≡_
module Universal-Adequacy {ℓu ℓe ℓr ℓa}
                          (U : ★_ ℓu)(El : U → ★_ ℓe)
                          (_≈_ : ★_ ℓe → ★_ (ℓa ⊔ ℓe) → ★_ ℓr){A : ★_ ℓa} where
    Adequate-univ-sum : ((A → U) → U) → ★_ (ℓa ⊔ (ℓr ⊔ ℓu))
    Adequate-univ-sum sumᴬ = ∀ f → El (sumᴬ f) ≈ Σ A (El ∘ f)

    Adequate-univ-product : ((A → U) → U) → ★_ (ℓa ⊔ (ℓr ⊔ ℓu))
    Adequate-univ-product productᴬ = ∀ f → El (productᴬ f) ≈ Π A (El ∘ f)

module Adequacy {ℓa ℓr}(_≈_ : ★₀ → ★_ ℓa → ★_ ℓr){A : ★_ ℓa} where

    -- Universal-Adequacy.Adequate-univ-sum ℕ Fin _≡_
    Adequate-sum : Sum A → ★_(ℓa ⊔ ℓr)
    Adequate-sum sumᴬ = ∀ f → Fin (sumᴬ f) ≈ Σ A (Fin ∘ f)

    -- Universal-Adequacy.Adequate-univ-product ℕ Fin _≡_
    Adequate-product : Product A → ★_(ℓa ⊔ ℓr)
    Adequate-product productᴬ = ∀ f → Fin (productᴬ f) ≈ Π A (Fin ∘ f)

    -- Universal-Adequacy.Adequate-univ-product 𝟚 ✓ _≡_
    Adequate-any : (any : BigOp 𝟚 A) → ★_(ℓa ⊔ ℓr)
    Adequate-any anyᴬ = ∀ f → ✓ (anyᴬ f) ≈ Σ A (✓ ∘ f)

    -- Universal-Adequacy.Adequate-univ-product 𝟚 ✓ _≡_
    Adequate-all : (all : BigOp 𝟚 A) → ★_(ℓa ⊔ ℓr)
    Adequate-all allᴬ = ∀ f → ✓ (allᴬ f) ≈ Π A (✓ ∘ f)

module _ {m a}{M : ★ m}{A : ★ a}([⊕] : BigOp M A) where
    BigOpStableUnder : (p : A → A) → ★ _
    BigOpStableUnder p = ∀ f → [⊕] f ≡ [⊕] (f ∘ p)

    -- Extensionality of a big-operator
    BigOp= : ★ _
    BigOp= = {f g : A → M} → f ≗ g → [⊕] f ≡ [⊕] g

module _ {ℓ a} {A : ★ a} (eᴬ : Explore ℓ A) where
    StableUnder : (A → A) → ★ _
    StableUnder p = ∀ {M}(ε : M) op → BigOpStableUnder (eᴬ ε op) p

    -- Extensionality of an exploration function
    Explore= : ★ _
    Explore= = ∀ {M}(ε : M) op → BigOp= (eᴬ ε op)
    ExploreExt = Explore=

module _ {ℓ a} {A : ★ a} r (eᴬ : Explore ℓ A) where
    ExploreMono : ★ _
    ExploreMono = ∀ {C} (_⊆_ : C → C → ★ r)
                    {z₀ z₁} (z₀⊆z₁ : z₀ ⊆ z₁)
                    {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                    {f g} →
                    (∀ x → f x ⊆ g x) → eᴬ z₀ _∙_ f ⊆ eᴬ z₁ _∙_ g

    ExploreMonExt : ★ _
    ExploreMonExt =
      ∀ (m : Monoid ℓ r) {f g}
      → let open Mon m
            bigop = eᴬ ε _∙_
        in
        f ≈° g → bigop f ≈ bigop g

    Exploreε : ★ _
    Exploreε = ∀ (m : Monoid ℓ r) →
                 let open Mon m in
                 eᴬ ε _∙_ (const ε) ≈ ε

    ExploreLinˡ : ★ _
    ExploreLinˡ =
      ∀ m _◎_ f k →
        let open Mon {ℓ} {r} m
            open FP _≈_ in
        k ◎ ε ≈ ε →
        _◎_ DistributesOverˡ _∙_ →
        eᴬ ε _∙_ (λ x → k ◎ f x) ≈ k ◎ eᴬ ε _∙_ f

    ExploreLinʳ : ★ _
    ExploreLinʳ =
      ∀ m _◎_ f k →
        let open Mon {ℓ} {r} m
            open FP _≈_ in
        ε ◎ k ≈ ε →
        _◎_ DistributesOverʳ _∙_ →
        eᴬ ε _∙_ (λ x → f x ◎ k) ≈ eᴬ ε _∙_ f ◎ k

    ExploreHom : ★ _
    ExploreHom =
      ∀ cm f g →
        let open CMon {ℓ} {r} cm in
        eᴬ ε _∙_ (f ∙° g) ≈ eᴬ ε _∙_ f ∙ eᴬ ε _∙_ g

        {-
    ExploreSwap'' : ∀ {b} → ★ _
    ExploreSwap'' {b}
                = ∀ (monM : Monoid _) (monN : Monoid _) →
                    let module M = Mon {_} {r} monM in
                    let module N = Mon {_} {r} monN in
                  ∀ {h : M.C → N.C}
                    (h-ε : h M.ε ≈ N.ε)
                    (h-∙ : ∀ x y → h (x M.∙ y) ≈ h x N.∙ h y)
                    f
                  → eᴬ ε _∙_ (h ∘ f) ≈ h (eᴬ ε _∙_ f)
-}

-- derived from lift-hom with the source monoid being (a → m)
    ExploreSwap : ∀ {b} → ★ _
    ExploreSwap {b}
                = ∀ {B : ★ b} mon →
                    let open Mon {_} {r} mon in
                  ∀ {opᴮ : (B → C) → C}
                    (opᴮ-ε : opᴮ (const ε) ≈ ε)
                    (hom : ∀ f g → opᴮ (f ∙° g) ≈ opᴮ f ∙ opᴮ g)
                    f
                  → eᴬ ε _∙_ (opᴮ ∘ f) ≈ opᴮ (eᴬ ε _∙_ ∘ flip f)

module _ {a} {A : ★ a} (sumᴬ : Sum A) where
    SumStableUnder : (A → A) → ★ _
    SumStableUnder p = ∀ f → sumᴬ f ≡ sumᴬ (f ∘ p)

    SumStableUnderInjection : ★ _
    SumStableUnderInjection = ∀ p → Injective p → SumStableUnder p

    SumInd : ★(₁ ⊔ a)
    SumInd = ∀ (P  : Sum A → ★₀)
               (P0 : P (λ f → 0))
               (P+ : ∀ {s₀ s₁ : Sum A} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f))
               (Pf : ∀ x → P (λ f → f x))
             → P sumᴬ

    SumExt : ★ _
    SumExt = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

    SumZero : ★ _
    SumZero = sumᴬ (λ _ → 0) ≡ 0

    SumLin : ★ _
    SumLin = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

    SumHom : ★ _
    SumHom = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

    SumMono : ★ _
    SumMono = ∀ {f g} → (∀ x → f x ≤ g x) → sumᴬ f ≤ sumᴬ g

    SumConst : ★ _
    SumConst = ∀ x → sumᴬ (const x) ≡ sumᴬ (const 1) * x

    SumSwap : ★ _
    SumSwap = ∀ {B : ★₀}
                {sumᴮ : Sum B}
                (sumᴮ-0 : sumᴮ (const 0) ≡ 0)
                (hom : ∀ f g → sumᴮ (f +° g) ≡ sumᴮ f + sumᴮ g)
                f
              → sumᴬ (sumᴮ ∘ f) ≡ sumᴮ (sumᴬ ∘ flip f)

module _ {a} {A : ★ a} (countᴬ : Count A) where
    CountStableUnder : (A → A) → ★ _
    CountStableUnder p = ∀ f → countᴬ f ≡ countᴬ (f ∘ p)

    CountExt : ★ _
    CountExt = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

    Unique : Cmp A → ★ _
    Unique cmp = ∀ x → countᴬ (cmp x) ≡ 1
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
-- The core properties behind exploration functions
module Explore.Properties where

open import Level.NP using (_⊔_; ₀; ₁; ₛ; Lift)
open import Type using (★₀; ★₁; ★_)
open import Function.NP using (id; _∘′_; _∘_; flip; const; Π; Cmp)
open import Algebra using (Semigroup; module Semigroup; Monoid; module Monoid; CommutativeMonoid; module CommutativeMonoid)
import      Algebra.FunctionProperties.NP
import      Algebra.FunctionProperties.Derived as FPD
open import Algebra.FunctionProperties.Core using (Op₂)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Explicits using (Injective)
open import Data.Nat.NP using (_+_; _*_; _≤_; _+°_)
open import Data.Product using (Σ; _×_; _,_; proj₁; proj₂)
open import Data.Sum  using (_⊎_)
open import Data.Zero using (𝟘)
open import Data.One  using (𝟙)
open import Data.Two  using (𝟚; ✓)
open import Data.Fin  using (Fin)
open import Relation.Binary.NP using (module Setoid-Reasoning; _Preserves₂_⟶_⟶_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≗_)

open import Explore.Core

module FP = Algebra.FunctionProperties.NP Π

module SgrpExtra {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★ _
  C = Carrier
  _≈°_ : ∀ {a} {A : ★ a} (f g : A → C) → ★ _
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {a} {A : ★ a} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong
  !_ = sym

module Sgrp {c ℓ} (sg : Semigroup c ℓ) where
  open Semigroup sg public
  open SgrpExtra sg public

module RawMon {c} {C : ★ c} (rawMon : C × Op₂ C) where
  ε    = proj₁ rawMon
  _∙_  = proj₂ rawMon

module Mon {c ℓ} (m : Monoid c ℓ) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public
  RawMon = C × Op₂ C
  rawMon : RawMon
  rawMon = ε , _∙_

module CMon {c ℓ} (cm : CommutativeMonoid c ℓ) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public
  open FP _≈_

  ∙-interchange : Interchange _∙_ _∙_
  ∙-interchange = FPD.FromAssocCommCong.interchange
                    _≈_ isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

module _ {ℓ a} {A : ★ a} where
    ExploreInd : ∀ p → Explore ℓ A → ★ (a ⊔ ₛ (ℓ ⊔ p))
    ExploreInd p exp =
      ∀ (P  : Explore ℓ A → ★ p)
        (Pε : P empty-explore)
        (P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁))
        (Pf : ∀ x → P (point-explore x))
      → P exp

    module _ {p} where
        point-explore-ind : (x : A) → ExploreInd p (point-explore x)
        point-explore-ind x _ _ _ Pf = Pf x

        empty-explore-ind : ExploreInd p empty-explore
        empty-explore-ind _ Pε _ _ = Pε

        merge-explore-ind : ∀ {e₀ e₁ : Explore ℓ A}
                            → ExploreInd p e₀ → ExploreInd p e₁
                            → ExploreInd p (merge-explore e₀ e₁)
        merge-explore-ind Pe₀ Pe₁ P Pε _P∙_ Pf = (Pe₀ P Pε _P∙_ Pf) P∙ (Pe₁ P Pε _P∙_ Pf)

    ExploreInd₀ : Explore ℓ A → ★ _
    ExploreInd₀ = ExploreInd ₀

    ExploreInd₁ : Explore ℓ A → ★ _
    ExploreInd₁ = ExploreInd ₁

    BigOpMonInd : ∀ p {c} (M : Monoid c ℓ) → BigOpMon M A → ★ _
    BigOpMonInd p {c} M exp =
      ∀ (P  : BigOpMon M A → ★ p)
        (Pε : P (const ε))
        (P∙ : ∀ {e₀ e₁ : BigOpMon M A} → P e₀ → P e₁ → P (λ f → e₀ f ∙ e₁ f))
        (Pf : ∀ x → P (λ f → f x))
        (P≈ : ∀ {e e'} → e ≈° e' → P e → P e')
      → P exp
      where open Mon M

    module _ (eᴬ : Explore {a} (ₛ ℓ) A) where
        Πᵉ : (A → ★ ℓ) → ★ ℓ
        Πᵉ = eᴬ (Lift 𝟙) _×_

        Σᵉ : (A → ★ ℓ) → ★ ℓ
        Σᵉ = eᴬ (Lift 𝟘) _⊎_

module _ {ℓ a} {A : ★ a} where
    module _ (eᴬ : Explore (ₛ ℓ) A) where
        Lookup : ★ (ₛ ℓ ⊔ a)
        Lookup = ∀ {P : A → ★ ℓ} → Πᵉ eᴬ P → Π A P

        -- alternative name suggestion: tabulate
        Reify : ★ (a ⊔ ₛ ℓ)
        Reify = ∀ {P : A → ★ ℓ} → Π A P → Πᵉ eᴬ P

        Unfocus : ★ (a ⊔ ₛ ℓ)
        Unfocus = ∀ {P : A → ★ ℓ} → Σᵉ eᴬ P → Σ A P

        -- alternative name suggestion: inject
        Focus : ★ (a ⊔ ₛ ℓ)
        Focus = ∀ {P : A → ★ ℓ} → Σ A P → Σᵉ eᴬ P

    Adequate-Σ : ((A → ★ ℓ) → ★ _) → ★ _
    Adequate-Σ Σᴬ = ∀ F → Σᴬ F ≡ Σ A F

    Adequate-Π : ((A → ★ ℓ) → ★ _) → ★ _
    Adequate-Π Πᴬ = ∀ F → Πᴬ F ≡ Π A F

-- This module could be parameterised by the relation on types, here _≡_
module Universal-Adequacy {ℓu ℓe ℓr ℓa}
                          (U : ★_ ℓu)(El : U → ★_ ℓe)
                          (_≈_ : ★_ ℓe → ★_ (ℓa ⊔ ℓe) → ★_ ℓr){A : ★_ ℓa} where
    Adequate-univ-sum : ((A → U) → U) → ★_ (ℓa ⊔ (ℓr ⊔ ℓu))
    Adequate-univ-sum sumᴬ = ∀ f → El (sumᴬ f) ≈ Σ A (El ∘ f)

    Adequate-univ-product : ((A → U) → U) → ★_ (ℓa ⊔ (ℓr ⊔ ℓu))
    Adequate-univ-product productᴬ = ∀ f → El (productᴬ f) ≈ Π A (El ∘ f)

module Adequacy {ℓr}(_≈_ : ★₀ → ★₀ → ★_ ℓr){A : ★₀} where

    -- Universal-Adequacy.Adequate-univ-sum ℕ Fin _≡_
    Adequate-sum : Sum A → ★_ ℓr
    Adequate-sum sumᴬ = ∀ f → Fin (sumᴬ f) ≈ Σ A (Fin ∘ f)

    -- Universal-Adequacy.Adequate-univ-product ℕ Fin _≡_
    Adequate-product : Product A → ★_ ℓr
    Adequate-product productᴬ = ∀ f → Fin (productᴬ f) ≈ Π A (Fin ∘ f)

    -- Universal-Adequacy.Adequate-univ-product 𝟚 ✓ _≡_
    Adequate-any : (any : BigOp 𝟚 A) → ★_ ℓr
    Adequate-any anyᴬ = ∀ f → ✓ (anyᴬ f) ≈ Σ A (✓ ∘ f)

    -- Universal-Adequacy.Adequate-univ-product 𝟚 ✓ _≡_
    Adequate-all : (all : BigOp 𝟚 A) → ★_ ℓr
    Adequate-all allᴬ = ∀ f → ✓ (allᴬ f) ≈ Π A (✓ ∘ f)

module _ {m a}{M : ★ m}{A : ★ a}([⊕] : BigOp M A) where
    BigOpStableUnder : (p : A → A) → ★ _
    BigOpStableUnder p = ∀ f → [⊕] f ≡ [⊕] (f ∘ p)

    -- Extensionality of a big-operator
    BigOp= : ★ _
    BigOp= = {f g : A → M} → f ≗ g → [⊕] f ≡ [⊕] g

module _ {ℓ a} {A : ★ a} (eᴬ : Explore ℓ A) where
    StableUnder : (A → A) → ★ _
    StableUnder p = ∀ {M}(ε : M) op → BigOpStableUnder (eᴬ ε op) p

    -- Extensionality of an exploration function
    Explore= : ★ _
    Explore= = ∀ {M}(ε : M) op → BigOp= (eᴬ ε op)
    ExploreExt = Explore=

module _ {ℓ a} {A : ★ a} r (eᴬ : Explore ℓ A) where
    ExploreMono : ★ _
    ExploreMono = ∀ {C} (_⊆_ : C → C → ★ r)
                    {z₀ z₁} (z₀⊆z₁ : z₀ ⊆ z₁)
                    {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                    {f g} →
                    (∀ x → f x ⊆ g x) → eᴬ z₀ _∙_ f ⊆ eᴬ z₁ _∙_ g

    ExploreMonExt : ★ _
    ExploreMonExt =
      ∀ (m : Monoid ℓ r) {f g}
      → let open Mon m
            bigop = eᴬ ε _∙_
        in
        f ≈° g → bigop f ≈ bigop g

    Exploreε : ★ _
    Exploreε = ∀ (m : Monoid ℓ r) →
                 let open Mon m in
                 eᴬ ε _∙_ (const ε) ≈ ε

    ExploreLinˡ : ★ _
    ExploreLinˡ =
      ∀ m _◎_ f k →
        let open Mon {ℓ} {r} m
            open FP _≈_ in
        k ◎ ε ≈ ε →
        _◎_ DistributesOverˡ _∙_ →
        eᴬ ε _∙_ (λ x → k ◎ f x) ≈ k ◎ eᴬ ε _∙_ f

    ExploreLinʳ : ★ _
    ExploreLinʳ =
      ∀ m _◎_ f k →
        let open Mon {ℓ} {r} m
            open FP _≈_ in
        ε ◎ k ≈ ε →
        _◎_ DistributesOverʳ _∙_ →
        eᴬ ε _∙_ (λ x → f x ◎ k) ≈ eᴬ ε _∙_ f ◎ k

    ExploreHom : ★ _
    ExploreHom =
      ∀ cm f g →
        let open CMon {ℓ} {r} cm in
        eᴬ ε _∙_ (f ∙° g) ≈ eᴬ ε _∙_ f ∙ eᴬ ε _∙_ g

        {-
    ExploreSwap'' : ∀ {b} → ★ _
    ExploreSwap'' {b}
                = ∀ (monM : Monoid _) (monN : Monoid _) →
                    let module M = Mon {_} {r} monM in
                    let module N = Mon {_} {r} monN in
                  ∀ {h : M.C → N.C}
                    (h-ε : h M.ε ≈ N.ε)
                    (h-∙ : ∀ x y → h (x M.∙ y) ≈ h x N.∙ h y)
                    f
                  → eᴬ ε _∙_ (h ∘ f) ≈ h (eᴬ ε _∙_ f)
-}

-- derived from lift-hom with the source monoid being (a → m)
    ExploreSwap : ∀ {b} → ★ _
    ExploreSwap {b}
                = ∀ {B : ★ b} mon →
                    let open Mon {_} {r} mon in
                  ∀ {opᴮ : (B → C) → C}
                    (opᴮ-ε : opᴮ (const ε) ≈ ε)
                    (hom : ∀ f g → opᴮ (f ∙° g) ≈ opᴮ f ∙ opᴮ g)
                    f
                  → eᴬ ε _∙_ (opᴮ ∘ f) ≈ opᴮ (eᴬ ε _∙_ ∘ flip f)

module _ {a} {A : ★ a} (sumᴬ : Sum A) where
    SumStableUnder : (A → A) → ★ _
    SumStableUnder p = ∀ f → sumᴬ f ≡ sumᴬ (f ∘ p)

    SumStableUnderInjection : ★ _
    SumStableUnderInjection = ∀ p → Injective p → SumStableUnder p

    SumInd : ★(₁ ⊔ a)
    SumInd = ∀ (P  : Sum A → ★₀)
               (P0 : P (λ f → 0))
               (P+ : ∀ {s₀ s₁ : Sum A} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f))
               (Pf : ∀ x → P (λ f → f x))
             → P sumᴬ

    SumExt : ★ _
    SumExt = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

    SumZero : ★ _
    SumZero = sumᴬ (λ _ → 0) ≡ 0

    SumLin : ★ _
    SumLin = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

    SumHom : ★ _
    SumHom = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

    SumMono : ★ _
    SumMono = ∀ {f g} → (∀ x → f x ≤ g x) → sumᴬ f ≤ sumᴬ g

    SumConst : ★ _
    SumConst = ∀ x → sumᴬ (const x) ≡ sumᴬ (const 1) * x

    SumSwap : ★ _
    SumSwap = ∀ {B : ★₀}
                {sumᴮ : Sum B}
                (sumᴮ-0 : sumᴮ (const 0) ≡ 0)
                (hom : ∀ f g → sumᴮ (f +° g) ≡ sumᴮ f + sumᴮ g)
                f
              → sumᴬ (sumᴮ ∘ f) ≡ sumᴮ (sumᴬ ∘ flip f)

module _ {a} {A : ★ a} (countᴬ : Count A) where
    CountStableUnder : (A → A) → ★ _
    CountStableUnder p = ∀ f → countᴬ f ≡ countᴬ (f ∘ p)

    CountExt : ★ _
    CountExt = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

    Unique : Cmp A → ★ _
    Unique cmp = ∀ x → countᴬ (cmp x) ≡ 1
-- -}
-- -}
-- -}
-- -}


Desc model: rename iso2 to psi.

Desc model: rename iso2 to psi.


Rename lift-apply to apply-term.

Rename lift-apply to apply-term.

Old-commit-hash: b02f9113ba8fab93ce132d5a8abe88b8d4ce471c

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

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

-- Terms that operate on changes

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

open import Data.Product

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

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

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

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

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

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

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

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

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

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

  diff : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff = app₂ diff-term

  apply : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply = app₂ apply-term

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

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

-- Terms that operate on changes

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

open import Data.Product

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

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

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

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

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

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

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

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

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

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

  diff : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff = app₂ diff-term

  apply : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply = app₂ lift-apply


Boring.

Boring.

Ignore-this: 388f14f883c989b9b05f0318e6a8750

darcs-hash:20100509150614-3bd4e-798fd3f93aeb4bf23f39bbb36ed0147ae3c78f00.gz

------------------------------------------------------------------------------
-- Testing the removal of the quantification
------------------------------------------------------------------------------

module Test.Succeed.OnlyAxioms.EraseQuantification where

postulate
  D    : Set
  _≡_  : D → D → Set
  succ : D → D

module EraseQuantificationOnSet where

  postulate a : D

  -- The translation must erase the quantification on Set (i.e. {A : Set}),
  -- the translation must be 'a = a'.
  postulate foo : {A : Set} → a ≡ a
  {-# ATP axiom foo #-}

module EraseQuantificationOnProofs where

  -- The data constructors sN₁ and sN₂ must have the same translation,
  -- i.e. we must erase the quantification of the variable Nn on N n.
  -- The translation of sN₂ must be '∀ x. n(x) → n(succ(x))

  data N : D → Set where
    -- zN : N zero
    sN₁ : {n : D} →  N n → N (succ n)
    sN₂ : {n : D} → (Nn : N n) → N (succ n)
  {-# ATP hint sN₂ #-}

  -- We need to remove the quantification over proofs inside a where
  -- clause. The translation of P must be '∀ x. ∀ y. p(x, y) ↔ y = x',
  -- i.e. we must erase the quantification on N n.
  foo : (n : D) → N n → Set
  foo n Nn = P n
    where
      P : D → Set
      P m = m ≡ n
      {-# ATP definition P #-}

-- module EraseQuantificationOverFunctionsAndPiTerm

-- -- Possible test

-- data A : Set where
--   a : A

-- foo : {e : D } → (N e → D) → A → e ≡ e
-- foo {e} fn a = prf
--   where
--   postulate prf : e ≡ e
--   {-# ATP prove prf #-}

-- bar : {e : D } → ((d : D) → N d → D) → A → e ≡ e
-- bar {e} fn a = prf
--   where
--   postulate prf : e ≡ e
--   {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Testing the removal of the quantification
------------------------------------------------------------------------------

module Test.Succeed.OnlyAxioms.EraseQuantification where

postulate
  D    : Set
  _≡_  : D → D → Set
  succ : D → D

module EraseQuantificationOnSet where

  postulate a : D

  -- The translation must erase the quantification on Set (i.e. {A : Set}),
  -- the translation must be 'a = a'.
  postulate foo : {A : Set} → a ≡ a
  {-# ATP axiom foo #-}

module EraseQuantificationOverProofs where

  -- The data constructors sN₁ and sN₂ must have the same translation,
  -- i.e. we must erase the quantification of the variable Nn on N n.
  -- The translation of sN₂ must be '∀ x. n(x) → n(succ(x))

  data N : D → Set where
    -- zN : N zero
    sN₁ : {n : D} →  N n → N (succ n)
    sN₂ : {n : D} → (Nn : N n) → N (succ n)
  {-# ATP hint sN₂ #-}

  -- We need to remove the quantification over proofs inside a where
  -- clause. The translation of P must be '∀ x. ∀ y. p(x, y) ↔ y = x',
  -- i.e. we must erase the quantification on N n.
  foo : (n : D) → N n → Set
  foo n Nn = P n
    where
      P : D → Set
      P m = m ≡ n
      {-# ATP definition P #-}

-- module EraseQuantificationOverFunctionsAndPiTerm

-- -- Possible test

-- data A : Set where
--   a : A

-- foo : {e : D } → (N e → D) → A → e ≡ e
-- foo {e} fn a = prf
--   where
--   postulate prf : e ≡ e
--   {-# ATP prove prf #-}

-- bar : {e : D } → ((d : D) → N d → D) → A → e ≡ e
-- bar {e} fn a = prf
--   where
--   postulate prf : e ≡ e
--   {-# ATP prove prf #-}


Added doc: We couldn't prove Conat-coind.

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

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

module FOT.FOTC.Data.Conat.TypeSL where

open import FOTC.Base
open import Coinduction

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

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

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

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

-- TODO (06 January 2014). We couldn't prove Conat-coind.
Conat-coind : (A : D → Set) →
              (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
              ∀ {n} → A n → Conat n
Conat-coind A h {n} An = Conat-in (case prf₁ prf₂ (h An))
  where
  prf₁ : n ≡ zero → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₁ n≡0 = inj₁ n≡0

  prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ A n' →
         n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₂ (n' , prf , An') = inj₂ (n' , prf , {!!})

postulate
  inf    : D
  inf-eq : inf ≡ succ₁ inf
{-# ATP axiom inf-eq #-}

{-# NO_TERMINATION_CHECK #-}
inf-Conat : Conat inf
inf-Conat = subst Conat (sym inf-eq) (cosucc (♯ inf-Conat))

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

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

module FOT.FOTC.Data.Conat.TypeSL where

open import FOTC.Base
open import Coinduction

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

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

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

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

Conat-coind : (A : D → Set) →
              (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
              ∀ {n} → A n → Conat n
Conat-coind A h {n} An = Conat-in (case prf₁ prf₂ (h An))
  where
  prf₁ : n ≡ zero → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₁ n≡0 = inj₁ n≡0

  prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ A n' →
         n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₂ (n' , prf , An') = inj₂ (n' , prf , {!!})

postulate
  inf    : D
  inf-eq : inf ≡ succ₁ inf
{-# ATP axiom inf-eq #-}

{-# NO_TERMINATION_CHECK #-}
inf-Conat : Conat inf
inf-Conat = subst Conat (sym inf-eq) (cosucc (♯ inf-Conat))


README.agda: commit the version generated without YAML

Old-commit-hash: 50638b3bf74b27250b21099c86b61824c9113a06

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * multiple calculi

import Denotation.Change.Popl14
{- Correctness theorem for canonical derivation of Calc. Popl14 -}
import Denotation.Derive.Canon-Popl14
{- Correctness theorem for optimized derivation of Calc. Popl14 -}
import Denotation.Derive.Optimized-Popl14
import Denotation.Environment.Popl14
import Denotation.Environment
import Denotation.Evaluation.Popl14
import Denotation.FreeVars.Popl14
{- The idea of implementing a denotational specification for Calc. Popl14 -}
import Denotation.Implementation.Popl14
import Denotation.Notation
{- Denotation-as-specification for canonical derivation of Calc. Popl14 -}
import Denotation.Specification.Canon-Popl14
import Denotation.Specification.Optimized-Popl14
import Denotation.Value.Popl14
import Postulate.Bag-Popl14
import Postulate.Extensionality
import Property.Uniqueness
import Structure.Bag.Popl14
import Structure.Tuples
import Syntax.Context.Popl14
import Syntax.Context
import Syntax.Derive.Canon-Popl14
import Syntax.Derive.Optimized-Popl14
import Syntax.FreeVars.Popl14
{- Language definition of Calc. Atlas -}
import Syntax.Language.Atlas
import Syntax.Language.Calculus
{- Terms of a calculus described in Plotkin style
  - types are parametric in base types
  - terms are parametric in constants
  This style of language description is employed in:
  G. D. Plotkin. "LCF considered as a programming language."
  Theoretical Computer Science 5(3) pp. 223--255, 1997.
  http://dx.doi.org/10.1016/0304-3975(77)90044-5 -}
import Syntax.Term.Plotkin
import Syntax.Term.Popl14
import Syntax.Type.Plotkin
import Syntax.Type.Popl14
import Syntax.Vars
import Theorem.CongApp
import Theorem.EqualityUnique
import Theorem.Groups-Popl14
import Theorem.IrrelevanceUnique-Popl14
import Theorem.ProductUnique
import Theorem.ValidityUnique-Popl14
import UNDEFINED
import experimental.DecidableEq
import experimental.FoldableBag
import experimental.FoldableBagParametric
import experimental.NormalizationByEvaluation
import experimental.OrdBag
import experimental.Sorting

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * multiple calculi

import Denotation.Change.Popl14
{- Correctness theorem for canonical derivation of Calc. Popl14 -}
import Denotation.Derive.Canon-Popl14
{- Correctness theorem for optimized derivation of Calc. Popl14 -}
import Denotation.Derive.Optimized-Popl14
import Denotation.Environment.Popl14
import Denotation.Environment
import Denotation.Evaluation.Popl14
import Denotation.FreeVars.Popl14
{- The idea of implementing a denotational specification for Calc. Popl14 -}
import Denotation.Implementation.Popl14
import Denotation.Notation
{- Denotation-as-specification for canonical derivation of Calc. Popl14 -}
import Denotation.Specification.Canon-Popl14
import Denotation.Specification.Optimized-Popl14
import Denotation.Value.Popl14
import Postulate.Bag-Popl14
import Postulate.Extensionality
import Property.Uniqueness
import Structure.Bag.Popl14
import Structure.Tuples
import Syntax.Context.Popl14
import Syntax.Context
import Syntax.Derive.Canon-Popl14
import Syntax.Derive.Optimized-Popl14
import Syntax.FreeVars.Popl14
{- Language definition of Calc. Atlas -}
import Syntax.Language.Atlas
import Syntax.Language.Calculus
{- Terms of a calculus described in Plotkin style
- types are parametric in base types
- terms are parametric in constants
This style of language description is employed in:
G. D. Plotkin. "LCF considered as a programming language."
Theoretical Computer Science 5(3) pp. 223--255, 1997.
http://dx.doi.org/10.1016/0304-3975(77)90044-5
 -}
import Syntax.Term.Plotkin
import Syntax.Term.Popl14
import Syntax.Type.Plotkin
import Syntax.Type.Popl14
import Syntax.Vars
import Theorem.CongApp
import Theorem.EqualityUnique
import Theorem.Groups-Popl14
import Theorem.IrrelevanceUnique-Popl14
import Theorem.ProductUnique
import Theorem.ValidityUnique-Popl14
import experimental.DecidableEq
import experimental.FoldableBag
import experimental.FoldableBagParametric
import experimental.NormalizationByEvaluation
import experimental.OrdBag
import experimental.Sorting


Delete copy-n-pasted-by-mistake comment

Delete copy-n-pasted-by-mistake comment

This comes directly from Relation.Binary.PropositionalEquality, and is
totally irrelevant here.

Old-commit-hash: d8c5accf1966a913db36fefe149720366811965c

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

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

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

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

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

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

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

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

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

  ------------------------------------------------------------------------
  -- Convenient syntax for equational reasoning

  import Relation.Binary.EqReasoning as EqR

  module ≙-Reasoning where
    open EqR ≙-setoid public
      renaming (_≈⟨_⟩_ to _≙⟨_⟩_)

  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ dx → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ dx → x ⊞ dx ≡ x → dx ≙ nil x
  ⊞-unit-is-nil dx x⊞dx≡x =
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

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

  -- This results pairs with update-diff.
  diff-update : ∀ {dx} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

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

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

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

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ = df-x-dx≙dg-x-dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- We know that Derivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> Derivative f (apply df).
  -- Now, we try to prove that if Derivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    Derivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    Derivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → Derivative f (apply df) → Derivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning
{-
      lemma : nil f ≙ dg
      -- Goes through
      --lemma = sym (derivative-is-nil dg fdg)
      -- Generates tons of crazy yellow ambiguities of equality type. Apparently, unifying against ≙ does not work so well.
      lemma = ≙-symm {{changeAlgebra}} {f} {dg} {nil f} (derivative-is-nil dg fdg)
-}

  -- We could also use derivative-is-⊞-unit, but the proof above matches better
  -- with the text above.

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

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

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

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

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

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

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

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

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

  ------------------------------------------------------------------------
  -- Convenient syntax for equational reasoning

  import Relation.Binary.EqReasoning as EqR

  -- Relation.Binary.EqReasoning is more convenient to use with _≡_ if
  -- the combinators take the type argument (a) as a hidden argument,
  -- instead of being locked to a fixed type at module instantiation
  -- time.

  module ≙-Reasoning where
    open EqR ≙-setoid public
      renaming (_≈⟨_⟩_ to _≙⟨_⟩_)

  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ dx → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ dx → x ⊞ dx ≡ x → dx ≙ nil x
  ⊞-unit-is-nil dx x⊞dx≡x =
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

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

  -- This results pairs with update-diff.
  diff-update : ∀ {dx} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

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

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

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

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ = df-x-dx≙dg-x-dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- We know that Derivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> Derivative f (apply df).
  -- Now, we try to prove that if Derivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    Derivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    Derivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → Derivative f (apply df) → Derivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning
{-
      lemma : nil f ≙ dg
      -- Goes through
      --lemma = sym (derivative-is-nil dg fdg)
      -- Generates tons of crazy yellow ambiguities of equality type. Apparently, unifying against ≙ does not work so well.
      lemma = ≙-symm {{changeAlgebra}} {f} {dg} {nil f} (derivative-is-nil dg fdg)
-}

  -- We could also use derivative-is-⊞-unit, but the proof above matches better
  -- with the text above.


Level: ℕ→Level

Level: ℕ→Level

{-# OPTIONS --without-K #-}
module Level.NP where

import Level
open import Data.Nat

open Level public renaming (zero to ₀; suc to ₛ)

₁ ₂ ₃ ₄ : Level
₁ = ₛ ₀
₂ = ₛ ₁
₃ = ₛ ₂
₄ = ₛ ₃

ℕ→Level : ℕ → Level
ℕ→Level zero    = ₀
ℕ→Level (suc n) = ₛ (ℕ→Level n)

{-# OPTIONS --without-K #-}
module Level.NP where

import Level

open Level public renaming (zero to ₀; suc to ₛ)

₁ ₂ ₃ ₄ : Level
₁ = ₛ ₀
₂ = ₛ ₁
₃ = ₛ ₂
₄ = ₛ ₃


We only need one point and decidability on objects.

module DCBSets where

open import prelude
open import relations

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (Σ[ n ∈ (⊤ → X) ] (Σ[ α ∈ (U → X → Set) ]( ∀(u : U)(x : X) → Dec (α u x) ))))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , _ , α , _) (V , Y , _ , β , _) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , n₁ , α , _)} {(V , Y , n₂ , β , _)} {(W , Z , n₃ , γ , _)} (f , F  , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , n , α , _)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , _ , α , _)}{(V , Y , _ , β , _)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , _ , α , _}
         {V , Y , _ , β , _}
         {W , Z , _ , γ , _}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , _ , α , _}{V , Y , _ , β , _}{W , Z , _ , γ , _}{S , T , _ , ι , _}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _ , _ , _}{V , Y , _ , _ , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _ , _ , _}{V , Y , _ , _ , _}{f , F , _} = refl , refl

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

⊗d : ∀{U V X Y}{α : U → X → Set}{β  : V → Y → Set}{d₁ : (u : U) (x : X) → Dec (α u x)}{d₂ : (u : V) (x : Y) → Dec (β u x)} → (u : Σ U (λ x → V)) (x : Σ X (λ x₁ → Y)) → Dec ((α ⊗ᵣ β) u x)
⊗d {U}{V}{X}{Y}{α}{β}{d₁}{d₂} (u , v) (x , y) with d₁ u x | d₂ v y
... | yes z | yes z' = yes (z , z')
... | yes z | no z' = no (λ z'' → z' (snd z''))
... | no z | yes z' = no (λ z'' → z (fst z''))
... | no z | no z' = no (λ z'' → z' (snd z''))

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂) = ((U × V) , (X × Y) , trans-× n₁ n₂ , α ⊗ᵣ β , ⊗d {α = α} {β}{d₁}{d₂})

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , _ , α , _)}{(V , Y , _ , β , _)}{(W , Z , _ , γ , _)}{(S , T , _ , δ , _)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {m₁ : ⊤ → U}
    → {n₁ : ⊤ → X}
    → {m₂ : ⊤ → V}
    → {n₂ : ⊤ → Y}
    → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
    → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
    → Hom ((U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂)) (U , X , n₁ , α , d₁)
π₁ {U}{X}{V}{Y}{α}{β}{m₁}{n₁}{m₂}{n₂} = fst , (λ r x → x , n₂ triv) , cond
 where
   cond : {u : Σ U (λ x → V)} {y : X} → (α ⊗ᵣ β) u (y , n₂ triv) → α (fst u) y
   cond {u , v}{x} (p₁ , p₂) = p₁

π₂ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {m₁ : ⊤ → U}
    → {n₁ : ⊤ → X}
    → {m₂ : ⊤ → V}
    → {n₂ : ⊤ → Y}
    → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
    → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
    → Hom ((U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂)) (V , Y , n₂ , β , d₂)
π₂ {U}{X}{V}{Y}{α}{β}{m₁}{n₁}{m₂}{n₂} = snd , (λ r y → n₁ triv , y) , cond
 where
  cond : {u : Σ U (λ x → V)} {y : Y} → (α ⊗ᵣ β) u (n₁ triv , y) → β (snd u) y
  cond {u , v}{y} (p₁ , p₂) = p₂

cart-ar : {U X V Y W Z : Set}
  → {α : U → X → Set}
  → {β : V → Y → Set}
  → {γ : W → Z → Set}
  → {n₁ : ⊤ → X}
  → {n₂ : ⊤ → Y}
  → {n₃ : ⊤ → Z}
  → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
  → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
  → {d₃ : ∀(w : W)(z : Z) → Dec (γ w z)}
  → Hom (W , Z , n₃ , γ , d₃) (U , X , n₁ , α , d₁)
  → Hom (W , Z , n₃ , γ , d₃) (V , Y , n₂ , β , d₂)
  → Hom (W , Z , n₃ , γ , d₃) ((U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂))
cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ}{n₁}{n₂}{n₃}{d₁}{d₂}{d₃} (f , F , p₁) (g , G , p₂) = trans-× f g ,  cart-ar-d , cond
 where
   cart-ar-d : W → Σ X (λ x → Y) → Z
   cart-ar-d w (x , y) with d₂ (g w) y
   ... | yes t = F w x
   ... | no t = G w y

   cond : {u : W} {y : Σ X (λ x → Y)} → γ u (cart-ar-d u y) → (α ⊗ᵣ β) (f u , g u) y
   cond {w}{x , y} p₃ with d₂ (g w) y
   ... | yes t = p₁ p₃ , t
   ... | no t = ⊥-elim (t (p₂ p₃)) , p₂  p₃

module DCBSets where

open import prelude
open import relations

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (Σ[ m ∈ (⊤ → U) ] (Σ[ n ∈ (⊤ → X) ] (Σ[ α ∈ (U → X → Set) ]( ∀(u : U)(x : X) → Dec (α u x) )))))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , _ , _ , α , _) (V , Y , _ , _ , β , _) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , m₁ , n₁ , α , _)} {(V , Y , m₂ , n₂ , β , _)} {(W , Z , m₃ , n₃ , γ , _)} (f , F  , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , m , n , α , _)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , _ , _ , α , _)}{(V , Y , _ , _ , β , _)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , _ , _ , α , _}{V , Y , _ , _ , β , _}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , _ , _ , α , _}{V , Y , _ , _ , β , _}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , _ , _ , α , _}{V , Y , _ , _ , β , _}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , _ , _ , α , _}
         {V , Y , _ , _ , β , _}
         {W , Z , _ , _ , γ , _}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , _ , _ , α , _}{V , Y , _ , _ , β , _}{W , Z , _ , _ , γ , _}{S , T , _ , _ , ι , _}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _ , _ , _ , _}{V , Y , _ , _ , _ , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _ , _ , _ , _}{V , Y , _ , _ , _ , _}{f , F , _} = refl , refl

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

⊗d : ∀{U V X Y}{α : U → X → Set}{β  : V → Y → Set}{d₁ : (u : U) (x : X) → Dec (α u x)}{d₂ : (u : V) (x : Y) → Dec (β u x)} → (u : Σ U (λ x → V)) (x : Σ X (λ x₁ → Y)) → Dec ((α ⊗ᵣ β) u x)
⊗d {U}{V}{X}{Y}{α}{β}{d₁}{d₂} (u , v) (x , y) with d₁ u x | d₂ v y
... | yes z | yes z' = yes (z , z')
... | yes z | no z' = no (λ z'' → z' (snd z''))
... | no z | yes z' = no (λ z'' → z (fst z''))
... | no z | no z' = no (λ z'' → z' (snd z''))

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , m₁ , n₁ , α , d₁) ⊗ₒ (V , Y , m₂ , n₂ , β , d₂) = ((U × V) , (X × Y) , trans-× m₁ m₂  , trans-× n₁ n₂ , α ⊗ᵣ β , ⊗d {α = α} {β}{d₁}{d₂})

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , _ , _ , α , _)}{(V , Y , _ , _ , β , _)}{(W , Z , _ , _ , γ , _)}{(S , T , _ , _ , δ , _)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {m₁ : ⊤ → U}
    → {n₁ : ⊤ → X}
    → {m₂ : ⊤ → V}
    → {n₂ : ⊤ → Y}
    → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
    → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
    → Hom ((U , X , m₁ , n₁ , α , d₁) ⊗ₒ (V , Y , m₂ , n₂ , β , d₂)) (U , X , m₁ , n₁ , α , d₁)
π₁ {U}{X}{V}{Y}{α}{β}{m₁}{n₁}{m₂}{n₂} = fst , (λ r x → x , n₂ triv) , cond
 where
   cond : {u : Σ U (λ x → V)} {y : X} → (α ⊗ᵣ β) u (y , n₂ triv) → α (fst u) y
   cond {u , v}{x} (p₁ , p₂) = p₁

π₂ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {m₁ : ⊤ → U}
    → {n₁ : ⊤ → X}
    → {m₂ : ⊤ → V}
    → {n₂ : ⊤ → Y}
    → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
    → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
    → Hom ((U , X , m₁ , n₁ , α , d₁) ⊗ₒ (V , Y , m₂ , n₂ , β , d₂)) (V , Y , m₂ , n₂ , β , d₂)
π₂ {U}{X}{V}{Y}{α}{β}{m₁}{n₁}{m₂}{n₂} = snd , (λ r y → n₁ triv , y) , cond
 where
  cond : {u : Σ U (λ x → V)} {y : Y} → (α ⊗ᵣ β) u (n₁ triv , y) → β (snd u) y
  cond {u , v}{y} (p₁ , p₂) = p₂

cart-ar : {U X V Y W Z : Set}
  → {α : U → X → Set}
  → {β : V → Y → Set}
  → {γ : W → Z → Set}
  → {m₁ : ⊤ → U}
  → {n₁ : ⊤ → X}
  → {m₂ : ⊤ → V}
  → {n₂ : ⊤ → Y}
  → {m₃ : ⊤ → W}
  → {n₃ : ⊤ → Z}
  → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
  → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
  → {d₃ : ∀(w : W)(z : Z) → Dec (γ w z)}
  → Hom (W , Z , m₃ , n₃ , γ , d₃) (U , X , m₁ , n₁ , α , d₁)
  → Hom (W , Z , m₃ , n₃ , γ , d₃) (V , Y , m₂ , n₂ , β , d₂)
  → Hom (W , Z , m₃ , n₃ , γ , d₃) ((U , X , m₁ , n₁ , α , d₁) ⊗ₒ (V , Y , m₂ , n₂ , β , d₂))
cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ}{m₁}{n₁}{m₂}{n₂}{m₃}{n₃}{d₁}{d₂}{d₃} (f , F , p₁) (g , G , p₂) = trans-× f g ,  cart-ar-d , cond
 where
   cart-ar-d : W → Σ X (λ x → Y) → Z
   cart-ar-d w (x , y) with d₂ (g w) y
   ... | yes t = F w x
   ... | no t = G w y

   cond : {u : W} {y : Σ X (λ x → Y)} → γ u (cart-ar-d u y) → (α ⊗ᵣ β) (f u , g u) y
   cond {w}{x , y} p₃ with d₂ (g w) y
   ... | yes t = p₁ p₃ , t
   ... | no t = ⊥-elim (t (p₂ p₃)) , p₂  p₃