prg.agda

prg.agda

module prg where

open import fun-universe

open import Function
open import Data.Nat.NP hiding (_==_)
open import Data.Bool.NP hiding (_==_)
open import Data.Nat.Properties
open import Data.Bool.Properties
open import Data.Bits
open import Data.Fin using (Fin; zero; suc)
open import Data.Product
open import Data.Empty
open import Data.Vec
open import Relation.Binary.PropositionalEquality.NP

PRGFun : (k n : ℕ) → Set
PRGFun k n = Bits k → Bits n

==-refl : ∀ {n} (xs : Bits n) → (xs == xs) ≡ 1b
==-refl [] = refl
==-refl (true ∷ xs) = ==-refl xs
==-refl (false ∷ xs) = ==-refl xs

_|∨|_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_|∨|_ f g x = f x ∨ g x

_|∧|_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_|∧|_ f g x = f x ∧ g x

module PRG⅁₁ {k n} (PRG : PRGFun k n) where
  -- TODO: give the adv some rand
  Adv : Set
  Adv = Bits n → Bit

  chal : Bit → Bits (n + k) → Bits n
  chal b R = if b then take n R else PRG (drop n R)

  prg⅁ : Adv → Bit → Bits (n + k) → Bit
  prg⅁ adv b R = adv (chal b R)

  -- ``Looks pseudo-random if the message is the output of the PRG some key''
  brute′ : Adv
  brute′ m = search {k} _∨_ ((_==_ m) ∘ PRG)

  -- ``Looks random if the message is not a possible output of the PRG''
  brute : Adv
  brute m = search {k} _∧_ (not ∘ (_==_ m) ∘ PRG)

private
  brute-PRG-K≡0b-aux : ∀ {k n} (PRG : Bits k → Bits n) K
                           → PRG⅁₁.brute PRG (PRG K) ≡ 0b
  brute-PRG-K≡0b-aux {zero}  {n} PRG [] = cong not (==-refl (PRG []))
  brute-PRG-K≡0b-aux {suc k} {n} PRG (true ∷ K)
    rewrite brute-PRG-K≡0b-aux (PRG ∘ 1∷_) K
      = Bool°.+-comm (search _∧_ (not ∘ _==_ (PRG (1∷ K)) ∘ PRG ∘ 0∷_)) 0b
  brute-PRG-K≡0b-aux {suc k} {n} PRG (false ∷ K)
    rewrite brute-PRG-K≡0b-aux (PRG ∘ 0∷_) K = refl

  always : ∀ n → Bits n → Bit
  always _ _ = 1b
  never  : ∀ n → Bits n → Bit
  never _ _ = 0b

  search-·-ε≡ε : ∀ {a} {A : Set a} ε (_·_ : A → A → A)
                   (ε·ε : ε · ε ≡ ε) n → search {n} _·_ (const ε) ≡ ε
  search-·-ε≡ε ε _·_ ε·ε = go
    where
      go : ∀ n → search {n} _·_ (const ε) ≡ ε
      go zero = refl
      go (suc n) rewrite go n = ε·ε

  #never≡0 : ∀ n → #⟨ never n ⟩ ≡ 0
  #never≡0 = search-·-ε≡ε _ _ refl

  #always≡2^_ : ∀ n → #⟨ always n ⟩ ≡ 2^ n
  #always≡2^_ zero = refl
  #always≡2^_ (suc n) = cong₂ _+_ pf pf where pf = #always≡2^ n

  ==-comm : ∀ {n} (xs ys : Bits n) → xs == ys ≡ ys == xs
  ==-comm [] [] = refl
  ==-comm (x ∷ xs) (x₁ ∷ ys) rewrite Xor°.+-comm x x₁ | ==-comm xs ys = refl

  countᵇ : Bit → ℕ
  countᵇ b = if b then 1 else 0

  #⟨==_⟩ : ∀ {n} (xs : Bits n) → #⟨ _==_ xs ⟩ ≡ 1
  #⟨== [] ⟩ = refl
  #⟨==_⟩ {suc n} (true ∷ xs)  rewrite #never≡0 n | #⟨== xs ⟩ = refl
  #⟨==_⟩ {suc n} (false ∷ xs) rewrite #never≡0 n | #⟨== xs ⟩ = refl

  ≗-cong-search : ∀ {n a} {A : Set a} op {f g : Bits n → A} → f ≗ g → search op f ≡ search op g
  ≗-cong-search {zero}  op f≗g = f≗g []
  ≗-cong-search {suc n} op f≗g = cong₂ op (≗-cong-search op (f≗g ∘ 0∷_))
                                          (≗-cong-search op (f≗g ∘ 1∷_))

  ≗-cong-# : ∀ {n} (f g : Bits n → Bit) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
  ≗-cong-# f g f≗g = ≗-cong-search _+_ (cong countᵇ ∘ f≗g)

  #-+ : ∀ {n a b} (f : Bits (suc n) → Bit) → #⟨ f ∘ 0∷_ ⟩ ≡ a → #⟨ f ∘ 1∷_ ⟩ ≡ b → #⟨ f ⟩ ≡ a + b
  #-+ f f0 f1 rewrite f0 | f1 = refl

  take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
  take-∷ n x xs with splitAt n xs
  take-∷ _ _ ._ | _ , _ , refl = refl

  drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
  drop-∷ n x xs with splitAt n xs
  drop-∷ _ _ ._ | _ , _ , refl = refl

  #-take-drop : ∀ m n (f : Bits m → Bit) (g : Bits n → Bit)
                  → #⟨ (f ∘ take m) |∧| (g ∘ drop m) ⟩ ≡ #⟨ f ⟩ * #⟨ g ⟩
  #-take-drop zero n f g with f []
  ... | true rewrite ℕ°.+-comm #⟨ g ⟩ 0 = refl
  ... | false = #never≡0 n
  #-take-drop (suc m) n f g = trans (#-+ {a = #⟨ f ∘ 0∷_ ⟩ * #⟨ g ⟩} ((f ∘ take (suc m)) |∧| (g ∘ drop (suc m)))
                                    (trans (≗-cong-# ((f ∘ take (suc m)) |∧| (g ∘ drop (suc m)) ∘ 0∷_)
                                                  ((f ∘ 0∷_ ∘ take m) |∧| (g ∘ drop m))
                                                  (λ x → cong₂ (λ x y → f x ∧ g y) (take-∷ m 0b x) (drop-∷ m 0b x)))
                                         (#-take-drop m n (f ∘ 0∷_) g))
                                    (trans (≗-cong-# ((f ∘ take (suc m)) |∧| (g ∘ drop (suc m)) ∘ 1∷_)
                                                  ((f ∘ 1∷_ ∘ take m) |∧| (g ∘ drop m))
                                                  (λ x → cong₂ (λ x y → f x ∧ g y) (take-∷ m 1b x) (drop-∷ m 1b x)))
                                         (#-take-drop m n (f ∘ 1∷_) g)))
                             (sym (proj₂ ℕ°.distrib #⟨ g ⟩ #⟨ f ∘ 0∷_ ⟩ #⟨ f ∘ 1∷_ ⟩))

  #-drop-take : ∀ m n (f : Bits n → Bit) (g : Bits m → Bit)
                  → #⟨ (f ∘ drop m) |∧| (g ∘ take m) ⟩ ≡ #⟨ f ⟩ * #⟨ g ⟩
  #-drop-take m n f g =
             #⟨ (f ∘ drop m) |∧| (g ∘ take m) ⟩
           ≡⟨ ≗-cong-# ((f ∘ drop m) |∧| (g ∘ take m)) ((g ∘ take m) |∧| (f ∘ drop m)) (λ x → Bool°.+-comm (f (drop m x)) _) ⟩
             #⟨ (g ∘ take m) |∧| (f ∘ drop m) ⟩
           ≡⟨ #-take-drop m n g f ⟩
             #⟨ g ⟩ * #⟨ f ⟩
           ≡⟨ ℕ°.*-comm #⟨ g ⟩ _ ⟩
             #⟨ f ⟩ * #⟨ g ⟩
           ∎
    where open ≡-Reasoning

  #-take : ∀ m n (f : Bits m → Bit) → #⟨ f ∘ take m {n} ⟩ ≡ 2^ n * #⟨ f ⟩
  #-take m n f = #⟨ f ∘ take m {n} ⟩
               ≡⟨ #-drop-take m n (always n) f ⟩
                 #⟨ always n ⟩ * #⟨ f ⟩
               ≡⟨ cong (flip _*_ #⟨ f ⟩) (#always≡2^ n) ⟩
                 2^ n * #⟨ f ⟩
               ∎
    where open ≡-Reasoning

  #-drop : ∀ m n (f : Bits m → Bit) → #⟨ f ∘ drop n ⟩ ≡ 2^ n * #⟨ f ⟩
  #-drop m n f = #⟨ f ∘ drop n ⟩
               ≡⟨ #-take-drop n m (always n) f ⟩
                 #⟨ always n ⟩ * #⟨ f ⟩
               ≡⟨ cong (flip _*_ #⟨ f ⟩) (#always≡2^ n) ⟩
                 2^ n * #⟨ f ⟩
               ∎
    where open ≡-Reasoning

  #⟨_==⟩ : ∀ {n} (xs : Bits n) → #⟨ flip _==_ xs ⟩ ≡ 1
  #⟨ xs ==⟩ = trans (≗-cong-# (flip _==_ xs) (_==_ xs) (flip ==-comm xs)) #⟨== xs ⟩

  #⇒ : ∀ {n} (f g : Bits n → Bit) → (∀ x → T (f x) → T (g x)) → #⟨ f ⟩ ≤ #⟨ g ⟩
  #⇒ {zero} f g f⇒g with f [] | g [] | f⇒g []
  ... | true  | true  | _ = s≤s z≤n
  ... | true  | false | p = ⊥-elim (p _)
  ... | false | _     | _ = z≤n
  #⇒ {suc n} f g f⇒g = #⇒ (f ∘ 0∷_) (g ∘ 0∷_) (f⇒g ∘ 0∷_)
                  +-mono #⇒ (f ∘ 1∷_) (g ∘ 1∷_) (f⇒g ∘ 1∷_)

  #-∧-∨ᵇ : ∀ x y → countᵇ (x ∧ y) + countᵇ (x ∨ y) ≡ countᵇ x + countᵇ y
  #-∧-∨ᵇ true y rewrite ℕ°.+-comm (countᵇ y) 1 = refl
  #-∧-∨ᵇ false y = refl

  #-∧-∨ : ∀ {n} (f g : Bits n → Bit) → #⟨ f |∧| g ⟩ + #⟨ f |∨| g ⟩ ≡ #⟨ f ⟩ + #⟨ g ⟩
  #-∧-∨ {zero} f g = #-∧-∨ᵇ (f []) (g [])
  #-∧-∨ {suc n} f g =
    trans
      (trans
         (helper #⟨ (f ∘ 0∷_) |∧| (g ∘ 0∷_) ⟩
                 #⟨ (f ∘ 1∷_) |∧| (g ∘ 1∷_) ⟩
                 #⟨ (f ∘ 0∷_) |∨| (g ∘ 0∷_) ⟩
                 #⟨ (f ∘ 1∷_) |∨| (g ∘ 1∷_) ⟩)
         (cong₂ _+_ (#-∧-∨ (f ∘ 0∷_) (g ∘ 0∷_))
                    (#-∧-∨ (f ∘ 1∷_) (g ∘ 1∷_))))
      (helper #⟨ f ∘ 0∷_ ⟩ #⟨ g ∘ 0∷_ ⟩ #⟨ f ∘ 1∷_ ⟩ #⟨ g ∘ 1∷_ ⟩)
      where open SemiringSolver
            helper : ∀ x y z t → x + y + (z + t) ≡ x + z + (y + t)
            helper = solve 4 (λ x y z t → x :+ y :+ (z :+ t) := x :+ z :+ (y :+ t)) refl

  #∨' : ∀ {n} (f g : Bits n → Bit) → #⟨ f |∨| g ⟩ ≤ #⟨ f ⟩ + #⟨ g ⟩
  #∨' {zero} f g with f []
  ... | true  = s≤s z≤n
  ... | false = ℕ≤.refl
  #∨' {suc _} f g = ℕ≤.trans (#∨' (f ∘ 0∷_) (g ∘ 0∷_) +-mono
                               #∨' (f ∘ 1∷_) (g ∘ 1∷_))
                      (ℕ≤.reflexive
                        (helper #⟨ f ∘ 0∷_ ⟩ #⟨ g ∘ 0∷_ ⟩ #⟨ f ∘ 1∷_ ⟩ #⟨ g ∘ 1∷_ ⟩))
      where open SemiringSolver
            helper : ∀ x y z t → x + y + (z + t) ≡ x + z + (y + t)
            helper = solve 4 (λ x y z t → x :+ y :+ (z :+ t) := x :+ z :+ (y :+ t)) refl

  #∨ : ∀ {m n o} {f g : Bits o → Bit} → #⟨ f ⟩ ≤ m → #⟨ g ⟩ ≤ n → #⟨ (λ x → f x ∨ g x) ⟩ ≤ (m + n)
  #∨ {m} {n} {o} {f} {g} pf pg = ℕ≤.trans (#∨' f g) (pf +-mono pg)

  ∧⇒∨ : ∀ x y → T (x ∧ y) → T (x ∨ y)
  ∧⇒∨ true y = _
  ∧⇒∨ false y = λ ()

  #∧ : ∀ {m n o} {f g : Bits o → Bit} → #⟨ f ⟩ ≤ m → #⟨ g ⟩ ≤ n → #⟨ f |∧| g ⟩ ≤ (m + n)
  #∧ {f = f} {g} pf pg = ℕ≤.trans (#⇒ (f |∧| g) (f |∨| g) (λ x → ∧⇒∨ (f x) (g x))) (#∨ {f = f} pf pg)

  lem' : ∀ {n} (f g : Bits n → Bit) → f |∨| g ≗ not ∘ ((not ∘ f) |∧| (not ∘ g))
  lem' f g x with f x
  ... | true = refl
  ... | false = sym (not-involutive _)

  lem : ∀ {n} op (f g : Bits n → Bit) → search op (f |∨| g) ≡ search op (not ∘ ((not ∘ f) |∧| (not ∘ g)))
  lem op f g = ≗-cong-search op {-(f |∨| g) (not ∘ ((not ∘ f) |∧| (not ∘ g)))-} (lem' f g)

  lem'' :
    ∀ {n a b}
      {A : Set a} {B : Set b}
      (_+_ : A → A → A)
      (_*_ : B → B → B)
      (f : A → B)
      (p : Bits n → A)
      (hom : ∀ x y → f (x + y) ≡ f x * f y)
      → f (search _+_ p) ≡ search _*_ (f ∘ p)
  lem'' {zero} _+_ _*_ f p hom = refl
  lem'' {suc n} _+_ _*_ f p hom = trans (hom _ _) (cong₂ _*_ (lem'' {n} _+_ _*_ f (p ∘ 0∷_) hom) (lem'' _+_ _*_ f (p ∘ 1∷_) hom))

  [0↔_] : ∀ {n} → Fin n → Bits n → Bits n
  [0↔_] {zero}  i xs = xs
  [0↔_] {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

  [0↔1] : Bits 2 → Bits 2
  [0↔1] = [0↔ suc zero ]

  [0↔1]-spec : [0↔1] ≗ (λ { (x ∷ y ∷ []) → y ∷ x ∷ [] })
  [0↔1]-spec (x ∷ y ∷ []) = refl

  brute′-bound-aux : ∀ {k n} (PRG : Bits k → Bits n)
                       → let open PRG⅁₁ PRG in
                          #⟨ brute′ ⟩ ≤ 2^ k
  brute′-bound-aux {zero}  PRG = ℕ≤.reflexive #⟨ PRG [] ==⟩
  brute′-bound-aux {suc k} PRG = #∨ {f = λ x → search _∨_ (_==_ x ∘ PRG ∘ 0∷_)}
                                    (brute′-bound-aux (PRG ∘ 0∷_))
                                    (brute′-bound-aux (PRG ∘ 1∷_))

module PRG⅁ {k n} (PRG : PRGFun k n) where
  open PRG⅁₁ PRG public

  brute-PRG-K≡0b : ∀ K → brute (PRG K) ≡ 0b
  brute-PRG-K≡0b = brute-PRG-K≡0b-aux PRG

  prg⅁-brute-0 : prg⅁ brute 0b ≗ (const 0b)
  prg⅁-brute-0 R = brute-PRG-K≡0b (drop n R)

  brute′-bound : #⟨ brute′ ⟩ ≤ 2^ k
  brute′-bound = brute′-bound-aux PRG

  de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
  de-morgan true  _ = refl
  de-morgan false _ = refl

  not∘brute′≗brute : not ∘ brute′ ≗ brute
  not∘brute′≗brute x = lem'' _∨_ _∧_ not (_==_ x ∘ PRG) de-morgan

  brute≗not∘brute′ : brute′ ≗ not ∘ brute
  brute≗not∘brute′ x = trans (sym (not-involutive _)) (cong not (not∘brute′≗brute x))

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


Added draft version of the classical existential elimination.

Ignore-this: 7c94b8879a8bf77b6c0f1ef968364764

darcs-hash:20120216050548-3bd4e-5000cb63aeb450f74e667af510c1917f0b16eb50.gz

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


FMSB: agda model of lambda madnesses

FMSB: agda model of lambda madnesses

module FMSB where

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Lam (X : Nat -> Set)(n : Nat) : Set where
  var : X n -> Lam X n
  app : Lam X n -> Lam X n -> Lam X n
  lam : Lam X (su n) -> Lam X n

_->>_ : {I : Set}(X Y : I -> Set) -> Set
X ->> Y = {i : _} -> X i -> Y i

fmsub : {X Y : Nat -> Set} -> (X ->> Lam Y) -> Lam X ->> Lam Y
fmsub sb (var x)   = sb x
fmsub sb (app f s) = app (fmsub sb f) (fmsub sb s)
fmsub sb (lam b)   = lam (fmsub sb b)

data Fin : Nat -> Set where
  ze : {n : Nat} -> Fin (su n)
  su : {n : Nat} -> Fin n -> Fin (su n)

D : (Nat -> Set) -> Nat -> Set
D F n = F (su n)

weak : {F : Nat -> Set} -> (Fin ->> F) -> (F ->> D F) ->
       {m n : Nat}-> (Fin m -> F n) -> D Fin m -> D F n
weak v w f ze      = v ze
weak v w f (su x)  = w (f x)

_+_ : Nat -> Nat -> Nat
ze    + y = y
su x  + y = su (x + y)

_!+_ : (Nat -> Set) -> Nat -> (Nat -> Set)
F !+ n = \ m -> F (m + n)

weaks : {F : Nat -> Set} -> (Fin ->> F) -> (F ->> D F) ->
        {m n : Nat}-> (Fin m -> F n) -> (Fin !+ m) ->> (F !+ n)
weaks v w f {ze}    = f
weaks v w f {su i}  = weak v w (weaks v w f {i})

jing : {m n : Nat} -> Lam Fin (m + n) -> Lam (Fin !+ n) m
jing (var x) = var x
jing (app f s) = app (jing f) (jing s)
jing (lam t) = lam (jing t)

gnij : {m n : Nat} -> Lam (Fin !+ n) m -> Lam Fin (m + n)
gnij (var x) = var x
gnij (app f s) = app (gnij f) (gnij s)
gnij (lam t) = lam (gnij t)

ren : {m n : Nat} -> (Fin m -> Fin n) -> Lam Fin m -> Lam Fin n
ren f t = gnij (fmsub (\ {i} x -> var (weaks (\ z -> z) su f {i} x)) {ze} (jing t))

sub : {m n : Nat} -> (Fin m -> Lam Fin n) -> Lam Fin m -> Lam Fin n
sub {m}{n} f t = gnij {ze} (fmsub (\ {i} x -> jing {i} (weaks {Lam Fin} var (ren su) f {i} x)) (jing {ze} t))

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


otp-sem-sec.agda

otp-sem-sec.agda

module otp-sem-sec where

open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Vec
open import Data.Product
open import circuit
open import Relation.Binary.PropositionalEquality

-- dup from Game
EXP : ∀ {a b} {A : Set a} {B : Set b} → Bit → (A → B) → (A × A → B)
EXP 0b f (x₀ , x₁) = f x₀
EXP 1b f (x₀ , x₁) = f x₁

Coins = ℕ
Ports = ℕ

module F
  (Size Time : Set)
  (FCp : Coins → Size → Time → Ports → Ports → Set)
  (Cp : Ports → Ports → Set)
  (builder : CircuitBuilder Cp)
  (toC : ∀ {c s t i o} → FCp c s t i o → Cp (c + i) o)
  (runC : ∀ {i o} → Cp i o → Bits i → Bits o)

  (|M| |C| : Ports)

  (Proba : Set)
  -- (Pr[_≡1] : ∀ {c} (EXP : ↺ c Bit) → Proba)
  (Pr[_≡1] : ∀ {c} (EXP : Bits c → Bit) → Proba)
  (negligible-advantage-proba : Proba → Proba → Set)

  where

  record Power : Set where
    constructor mk
    field
      coins : Coins
      size  : Size
      time  : Time
  open Power public

  M = Bits |M|
  C = Bits |C|

  ↺ : Coins → Set → Set
  ↺ c A = Bits c → A

  record SemSecAdv power : Set where
    constructor mk

    open Power power renaming (coins to c; size to s; time to t)
    field
      fcp : FCp c s t |C| (1 + (|M| + |M|))

      {c₀ c₁}   : Coins
      c≡c₀+c₁  : c ≡ c₀ + c₁

    R₀ = Bits c₀
    R₁ = Bits c₁

    open CircuitBuilder builder

    cp : Cp ((c₀ + c₁) + |C|) (1 + (|M| + |M|))
    cp rewrite sym c≡c₀+c₁ = toC fcp

    cp₁ : Cp c₀ (|M| + |M|)
    cp₁ = padR c₁ >>> padR |C| >>> cp >>> tailC

    cp₂ : Cp ((c₀ + c₁) + |C|) 1
    cp₂ = cp >>> headC

    beh : ↺ c₀ ((M × M) × (C → ↺ c₁ Bit))
    beh R₀ = (case splitAt |M| (runC cp₁ R₀) of λ { (x , y , _) → (x , y) })
           , (λ C R₁ → head (runC cp₂ ((R₀ ++ R₁) ++ C)))

  runSemSec : ∀ (E : M → C) {p} (A : SemSecAdv p) (b : Bit) → ↺ (coins p) Bit
  runSemSec E {mk c s t} A b R
      = case SemSecAdv.beh A R₀ of λ
          { (m0m1 , kont) → {- b == -} kont (EXP b E m0m1) R₁ }
    where R₀ = take (SemSecAdv.c₀ A) (subst Bits (SemSecAdv.c≡c₀+c₁ A) R)
          R₁ = drop (SemSecAdv.c₀ A) (subst Bits (SemSecAdv.c≡c₀+c₁ A) R)

  negligible-advantage : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  negligible-advantage EXP = negligible-advantage-proba Pr[ EXP 0b ≡1] Pr[ EXP 1b ≡1]

  SemSec : ∀ (E : M → C) → Power → Set
  SemSec E power = ∀ (A : SemSecAdv power) → negligible-advantage (runSemSec E A)

  |K| = |M|
  K = Bits |K|
  -- OTP : K → M → C
  -- OTP = _⊕_

  -- OTP-SemSec : SemSec (OTP

  Enc = M → C

  Tr = Enc → Enc

  -- In general the power might change
  SemSecTr : Tr → Set
  SemSecTr tr = ∀ {E p} → SemSec E p → SemSec (tr E) p

  neg-pres-sem-sec : SemSecTr (_∘_ vnot)
  neg-pres-sem-sec {E} {p} E-sec A-breaks-E' = pf
     where E' : Enc
           E' = vnot ∘ E
           pf : negligible-advantage (runSemSec E' A-breaks-E')
           pf = {!!}

{-
  ⊕-pres-sem-sec : ∀ mask → SemSecTr (_∘_ (_⊕_ mask))
  ⊕-pres-sem-sec mask {E} {p} E-sec A-breaks-E' = pf
     where E' : Enc
           E' = (_⊕_ mask) ∘ E
           pf : negligible-advantage (runSemSec E' A-breaks-E')
           pf = {!!}
-}

error: pathspec 'otp-sem-sec.agda' did not match any file(s) known to git


experiment with simulator and protocol

experiment with simulator and protocol

-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level
open import Data.Product
open import Data.One

open import Relation.Binary.PropositionalEquality

module Control.Protocol.CoreBind where
open import Control.Strategy renaming (Strategy to Client) public

data Inf : ★ where
  mu nu : Inf

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (A : ★)(B : A → Proto) → Proto
  later : Inf → ∞ Proto → Proto

{-
Tele : Proto → ★
Tele end = 𝟙
Tele (Π' A B) = Σ A λ x → Tele (B x)
Tele (Σ' A B) = Σ A λ x → Tele (B x)
Tele (later i P) = ?

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
Π' A B >>≡ Q = Π' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
Σ' A B >>≡ Q = Σ' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
later i P >>≡ Q = ?

++Tele : ∀ (P : Proto)(Q : Tele P → Proto) → (x : Tele P) → Tele (Q x) → Tele (P >>≡ Q)
++Tele end Q x y = y
++Tele (Π' M C) Q (m , x) y = m , ++Tele (C m) (λ x₁ → Q (m , x₁)) x y
++Tele (Σ' M C) Q (m , x) y = m , ++Tele (C m) _ x y
++Tele (later i P) Q x y = ?

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : ★_ b}{f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g) where
  right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ P
  right-unit end = refl
  right-unit (Π' M C) = let p = funExt (λ x → right-unit (C x)) in cong (Π' M) p
  right-unit (Σ' M C) = cong (Σ' M) (funExt (λ x → right-unit (C x)))
  right-unit (later i P) = ?

  assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P Q x y))) ≡ ((P >>≡ Q) >>≡ R)
  assoc end Q R = refl
  assoc (Π' M C₁) Q R = cong (Π' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (Σ' M C₁) Q R = cong (Σ' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (later i P) Q R = ?

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q
-}
_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

dualInf : Inf → Inf
dualInf mu = nu
dualInf nu = mu

dual : Proto → Proto
dual end = end
dual (Π' A B) = Σ' A (λ x → dual (B x))
dual (Σ' A B) = Π' A (λ x → dual (B x))
dual (later i P) = later (dualInf i) (♯ (dual (♭ P)))

{-
module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele P ≡ Tele (dual P)
  dual-Tele end = refl
  dual-Tele (Π' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (Σ' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (later i P) = ?
-}{-
module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
module _ where
  El : (P : Proto) → (Tele P → ★) → ★
  El end X = X _
  El (Π' A B) X = Π A λ x → El (B x) (λ y → X (x , y))
  El (Σ' A B) X = Σ A λ x → El (B x) (λ y → X (x , y))
  El (later i P) = ?

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto)(Q : Tele P → Proto)(X : Tele (P >>≡ Q) → ★) → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P Q x y)))
  bind-spec end Q X = refl
  bind-spec (Π' A B) Q X = cong (Π A) (funExt (λ x → bind-spec (B x) (λ xs → Q (x , xs)) (λ y → X (x , y))))
  bind-spec (Σ' A B) Q X = cong (Σ A) (funExt (λ x → bind-spec (B x) _ _))
  bind-spec (later i p) Q X = ?

module _ {A B} where
  com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (later i P) x y = ?

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
  com-cont end p q = (_ , p)  , (_ , q)
  com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (later i P) p q = ?
-}
{-
data Process (A : ★): Proto → ★₁ where
  send : ∀ {M P} (m : M) → Process A (P m) → Process A (Σ' M P)
  recv : ∀ {M P} → ((m : M) → Process A (P m)) → Process A (Π' M P)
  end  : A → Process A end
  -}
elInf : Inf → ★₁ → ★₁
elInf mu x = x
elInf nu x = ∞ x

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  send : ∀ {M P} (m : M) → this (P m) → ProcessF this (Σ' M P)
  recv : ∀ {M P} → ((m : M) → this (P m)) → ProcessF this (Π' M P)
  latr : ∀ {P} i → elInf i (this (♭ P)) → ProcessF this (later i P)

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

data Sim : Proto → Proto → ★₁ where
  left  : ∀ {P Q} → ProcessF (flip Sim Q) P → Sim P Q
  right : ∀ {P Q} → ProcessF (Sim P) Q → Sim P Q
  end   : Sim end end

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' A B) = right (recv (λ m → left (send m (sim-id (B m)))))
sim-id (Σ' A B) = left (recv (λ m → right (send m (sim-id (B m)))))
sim-id (later mu P) = right (latr mu (left (latr nu (♯ sim-id (♭ P)))))
sim-id (later nu P) = left (latr mu (right (latr nu (♯ (sim-id (♭ P))))))

sim-comp : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
sim-comp (left (send m x)) QR = left (send m (sim-comp x QR))
sim-comp (left (recv x)) QR = left (recv (λ m → sim-comp (x m) QR))
sim-comp (left (latr mu x)) QR = left (latr mu (sim-comp x QR))
sim-comp (left (latr nu x)) QR = left (latr nu (♯ sim-comp (♭ x) QR))
sim-comp (right (send m x)) (left (recv x₁)) = sim-comp x (x₁ m)
sim-comp (right (recv x)) (left (send m x₁)) = sim-comp (x m) x₁
sim-comp (right (latr mu x)) (left (latr .nu x₁)) = sim-comp x (♭ x₁)
sim-comp (right (latr nu x)) (left (latr .mu x₁)) = sim-comp (♭ x) x₁
sim-comp PQ (right (send m x)) = right (send m (sim-comp PQ x))
sim-comp PQ (right (recv x)) = right (recv (λ m → sim-comp PQ (x m)))
sim-comp PQ (right (latr mu x)) = right (latr mu (sim-comp PQ x))
sim-comp PQ (right (latr nu x)) = right (latr nu (♯ sim-comp PQ (♭ x)))
sim-comp end QR = QR
{-
sim-comp end QR = QR
sim-comp (right (send m x)) (left (recv x₁)) = sim-comp x (x₁ m)
sim-comp (right (recv x)) (left (send m x₁)) = sim-comp (x m) x₁
sim-comp (left (send m x)) QR = left (send m (sim-comp x QR))
sim-comp (left (recv x)) QR = left (recv (λ m → sim-comp (x m) QR))
sim-comp PQ (right (send m₁ x₁)) = right (send m₁ (sim-comp PQ x₁))
sim-comp PQ (right (recv x₁)) = right (recv (λ m₁ → sim-comp PQ (x₁ m₁)))

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = sim-comp

sim-sym : ∀ {P Q} → Sim P Q → Sim Q P
sim-sym (left (send m x)) = right (send m (sim-sym x))
sim-sym (left (recv x)) = right (recv (λ m → sim-sym (x m)))
sim-sym (right (send m x)) = left (send m (sim-sym x))
sim-sym (right (recv x)) = left (recv (λ m → sim-sym (x m)))
sim-sym end = end

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (left ())
sim-unit (right (send m x)) = do (send m (sim-unit x))
sim-unit (right (recv x)) = do (recv (λ m → sim-unit (x m)))
sim-unit end = end 0₁

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (sim-sym PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)
{-

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = {!!}
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}

error: pathspec 'Control/Protocol/CoreBind.agda' did not match any file(s) known to git


Initial commit: agda ILC with nats

Initial commit: agda ILC with nats

Old-commit-hash: 25b473eeff3f5286dafba706c0d7c64b886d29b3

-- TODO: Include proof of
-- "not all correctly-typed values are valid changes"

module A where

open import Data.Product
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤)

open import Relation.Binary.PropositionalEquality

open import Level using
  (zero ; Level ; suc)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)

postulate extensionality : Extensionality zero zero

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

infixr 5 _⇒_

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

infixr 9 _•_

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

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

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

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

  -- Change to nats = replacement Church pairs
  -- 3 -> 5 ::= λf. f 3 5

infix 8 _≼_

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

≼-reflexivity : Reflexive _≼_
≼-reflexivity {∅} = ∅≼∅
≼-reflexivity {τ • x} = keep τ • ≼-reflexivity

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

≼-transitive : Transitive _≼_
≼-transitive ∅≼∅ rel1 = rel1
≼-transitive (keep τ • rel0) (keep .τ • rel1) =
  keep τ • ≼-transitive rel0 rel1
≼-transitive (keep τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (keep τ • rel0) rel1
≼-transitive (drop τ • rel0) (keep .τ • rel1) =
  drop τ • ≼-transitive rel0 rel1
≼-transitive (drop τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (drop τ • rel0) rel1

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

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

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

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

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x

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

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

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

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = cong₂ (λ x y → x y)

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = ≡-app (weaken-sound t₁ ρ) (weaken-sound t₂ ρ)
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

-- Changes to ℕ are replacement Church pairs. The only arguments
-- of conern are `fst` and `snd`, so the Church pairs don't have
-- to be polymorphic.

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

-- It is clear that ⟦⊝⟧ exists on the semantic level:
-- there exists an Agda value to describe the change between any
-- two Agda values denoted by terms. If we have (not dependently-
-- typed) arrays, no term denotes the change between two arrays
-- of different lengths. Thus no full abstraction.

⟦derive⟧ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

infixl 6 _⟦⊕⟧_
infixl 6 _⟦⊝⟧_

⟦fst⟧ : ℕ → ℕ → ℕ
⟦snd⟧ : ℕ → ℕ → ℕ

⟦derive⟧ {τ₁ ⇒ τ₂} f = λ v dv → f (v ⟦⊕⟧ dv) ⟦⊝⟧ f v
⟦derive⟧ {nats} n = λ f → f n n

_⟦⊝⟧_ {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → f₁ (v ⟦⊕⟧ dv) ⟦⊝⟧ f₂ v
_⟦⊝⟧_ {nats} m n = λ f → f n m
-- m ⟦⊝⟧ n ::= replace n by m

_⟦⊕⟧_ {τ₁ ⇒ τ₂} f df = λ v → f v ⟦⊕⟧ df v (⟦derive⟧ v)
_⟦⊕⟧_ {nats} n dn = dn ⟦snd⟧

⟦fst⟧ m n = m
⟦snd⟧ m n = n

-- Strong validity!
data ⟦ValidΔ⟧ : {τ : Type} → (v : ⟦ τ ⟧) → (dv : ⟦ Δ-Type τ ⟧) → Set where
  -- Following Pierce's case names `T-Var`, `T-Abs`, `T-App`
  -- with Agda's capitalization convention
  -- generalized to the semantic (value) domain
  v-nat : (n : ℕ) → (dn : (ℕ → ℕ → ℕ) → ℕ) →
          n ≡ dn ⟦fst⟧ →
          ⟦ValidΔ⟧ n dn

  v-fun : {τ₁ τ₂ : Type} →
          (f : ⟦ τ₁ ⇒ τ₂ ⟧) → (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) →
          -- A strong antecedent: f and df map invalid changes to
          -- valid changes! So long as invalid changes exist,
          -- this is NOT satisfied by
          --
          --      f = ⟦ λ x. x ⟧     = identity
          --     df = ⟦ λ x dx. dx ⟧ = ⟦snd⟧,
          --
          -- negating any hope of ⟦ValidΔ⟧ ⟦ t ⟧ ⟦ derive t ⟧.
          (∀ {s ds} → {-ValidΔ s ds →-} ⟦ValidΔ⟧ (f s) (df s ds)) →
          (∀ {s ds} → (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ (f s ⟦⊕⟧ df s ds)) →
          ⟦ValidΔ⟧ f df

absurdity-of-0=1 : 0 ≡ 1 → (∀ {A : Set} → A)
absurdity-of-0=1 ()

it-is-absurd-that : ⟦ValidΔ⟧ {nats} 0 (λ f → f 1 1) → (∀ {A : Set} → A)
it-is-absurd-that (v-nat .0 .(λ f → f 1 1) 0=1) = absurdity-of-0=1 0=1

-- If (λ x dx → dx) is a ⟦ValidΔ⟧ to (λ x → x),
-- then impossible is nothing.
no-way : ⟦ValidΔ⟧ {nats ⇒ nats} (λ x → x) (λ x dx → dx) →
         (∀ {A : Set} → A)
no-way (v-fun .(λ x → x) .(λ x dx → dx) validity correctness) =
  it-is-absurd-that (validity {0} {λ f → f 1 1})

-- Cool lemmas

f⟦⊝⟧f=⟦deriv⟧f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊝⟧ f ≡ ⟦derive⟧ f
f⟦⊝⟧f=⟦deriv⟧f {nats} f = refl
f⟦⊝⟧f=⟦deriv⟧f {τ₁ ⇒ τ₂} f = refl

f⊕[g⊝f]=g : ∀ {τ : Type} (f g : ⟦ τ ⟧) → f ⟦⊕⟧ (g ⟦⊝⟧ f) ≡ g

f⊕Δf=f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊕⟧ (⟦derive⟧ f) ≡ f

f⊕[g⊝f]=g {nats} m n = refl
f⊕[g⊝f]=g {τ₁ ⇒ τ₂} f g = extensionality (λ x →
    begin
      (f ⟦⊕⟧ (g ⟦⊝⟧ f)) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (g (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong₂ _⟦⊕⟧_
            {x = f x} {y = f x} refl
            (cong₂ _⟦⊝⟧_ (cong g (f⊕Δf=f x)) refl) ⟩
      f x ⟦⊕⟧ (g x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (g x) ⟩
      g x
    ∎
  ) where open ≡-Reasoning

f⊕Δf=f {nats} n = refl
f⊕Δf=f {τ₁ ⇒ τ₂} f = extensionality (λ x →
    begin
      (f ⟦⊕⟧ ⟦derive⟧ f) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (f (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong (λ hole → f x ⟦⊕⟧ (f hole ⟦⊝⟧ f x)) (f⊕Δf=f x) ⟩
      f x ⟦⊕⟧ (f x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (f x) ⟩
      f x
    ∎
  ) where open ≡-Reasoning

valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {nats} n dn = n ≡ dn ⟦fst⟧
valid-Δ {τ₁ ⇒ τ₂} f df =
  ∀ (s : ⟦ τ₁ ⟧) (ds : ⟦ Δ-Type τ₁ ⟧) (R[s,ds] : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×              -- (valid-Δ:1)
    (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ f s ⟦⊕⟧ df s ds -- (valid-Δ:2)

R[f,g⊝f] : ∀ {τ} (f g : ⟦ τ ⟧) → valid-Δ {τ} f (g ⟦⊝⟧ f)
R[f,g⊝f] {nats} m n = refl
R[f,g⊝f] {τ₁ ⇒ τ₂} f g = λ x dx R[x,dx] →
  R[f,g⊝f] {τ₂} (f x) (g (x ⟦⊕⟧ dx)) -- (valid-Δ:1)
  , -- tuple constructor
  (begin
    (f ⟦⊕⟧ (g ⟦⊝⟧ f)) (x ⟦⊕⟧ dx)
  ≡⟨ refl ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧
      (g ((x ⟦⊕⟧ dx) ⟦⊕⟧ ⟦derive⟧ (x ⟦⊕⟧ dx)) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ cong (λ hole → f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g hole ⟦⊝⟧ f (x ⟦⊕⟧ dx)))
          (f⊕Δf=f (x ⟦⊕⟧ dx)) ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g (x ⟦⊕⟧ dx) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ f⊕[g⊝f]=g (f (x ⟦⊕⟧ dx)) (g (x ⟦⊕⟧ dx)) ⟩
    g (x ⟦⊕⟧ dx)
  ≡⟨ sym (f⊕[g⊝f]=g (f x) (g (x ⟦⊕⟧ dx))) ⟩
      f x ⟦⊕⟧ (g ⟦⊝⟧ f) x dx
  ∎)
  where open ≡-Reasoning

R[f,Δf] : ∀ {τ} (f : ⟦ τ ⟧) → valid-Δ {τ} f (⟦derive⟧ f)
R[f,Δf] f rewrite sym (f⟦⊝⟧f=⟦deriv⟧f f) = R[f,g⊝f] f f

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ -- push τ, then push Δτ.

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • (keep τ • Γ≼ΔΓ)

-- Data type to hold proofs that environments are valid
data Valid-Δenv : {Γ : Context} (ρ : ⟦ Γ ⟧) (Δρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is its own valid Δ-environment.
  ρ=∅ : Valid-Δenv {∅} ∅ ∅
  -- Induction case: the change introduced therein should be valid,
  -- and the smaller Δ-environment should be valid as well.
  ρ=v•ρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
            {Γ₀ : Context} {ρ₀ : ⟦ Γ₀ ⟧} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
            valid-Δ v dv → Valid-Δenv ρ₀ dρ₀ →
            Valid-Δenv {τ • Γ₀} (v • ρ₀) (dv • v • dρ₀)

-- Data type to hold proofs that a Δ-env is consistent with self
data Consistent-Δenv : {Γ : Context} (dρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is consistent with itself
  dρ=∅ : Consistent-Δenv {∅} ∅
  -- Induction case: the change introduced at top level
  -- should be valid.
  dρ=dv•v•dρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
                 {Γ₀ : Context} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
                 valid-Δ v dv → Consistent-Δenv dρ₀ →
                 Consistent-Δenv {τ • Γ₀} (dv • v • dρ₀)

-- If a Δ-environment is valid for some other environment,
-- then it is also consistent with itself.

valid-Δenv-is-consistent :
   ∀ {Γ : Context} {ρ : ⟦ Γ ⟧} {dρ : ⟦ Δ-Context Γ ⟧} →
    Valid-Δenv ρ dρ → Consistent-Δenv dρ

valid-Δenv-is-consistent ρ=∅ = dρ=∅
valid-Δenv-is-consistent (ρ=v•ρ₀ valid[v,dv] valid[ρ₀,dρ₀]) =
  dρ=dv•v•dρ₀ valid[v,dv] (valid-Δenv-is-consistent valid[ρ₀,dρ₀])

-- finally, update and ignore

update : ∀ {Γ} → (dρ : ⟦ Δ-Context Γ ⟧) → {_ : Consistent-Δenv dρ} → ⟦ Γ ⟧
update {∅} ∅ {dρ=∅} = ∅
update {τ • Γ} (dv • v • dρ) {dρ=dv•v•dρ₀ valid[v,dv] consistent[dρ₀]} =
  (v ⟦⊕⟧ dv) • update dρ {consistent[dρ₀]}

-- Ignorance is bliss (don't have to pass consistency proofs around :D)

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore = ⟦ Γ≼ΔΓ ⟧ -- Using a proof to describe computation

-- Naming scheme follows weakenVar/weaken

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

derive : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

-- derive(n) = λf. f n n
derive (nat n) = abs (app (app (var this) (nat n)) (nat n))

-- derive(x) = dx
derive (var x) = var (deriveVar x)

-- derive(λx. t) = λx. λdx. derive(t)
derive (abs t) = abs (abs (derive t))

-- derive(f s) = derive(f) s derive(s)
derive (app f s) = app (app (derive f) (weaken Γ≼ΔΓ s)) (derive s)

-- Extensional equivalence for changes
data as-Δ_is_ext-equiv-to_ :
  ∀ (τ : Type) → (df : ⟦ Δ-Type τ ⟧) → (dg : ⟦ Δ-Type τ ⟧) → Set where
  ext-Δ : ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
          (∀ (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg →
             (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)) →
          as-Δ τ is df ext-equiv-to dg

infix 3 as-Δ_is_ext-equiv-to_

-- Extractor for extensional-equivalence-as-changes:
-- Given a value of the data type holding the proof,
-- returns the proof in applicable form.
--
-- Question: Would it not have been better if such
-- proof-holding types were defined as a function in
-- the first place, say in the manner of `valid-Δ`?
--
extract-Δequiv :
  ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
    as-Δ τ is df ext-equiv-to dg →
    (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg → (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)

extract-Δequiv (ext-Δ proof-method) = proof-method

-- Distribution lemmas of validity over ⟦⊝⟧ and ⟦⊕⟧

application-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v) ≡ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
application-over-⊕-and-⊝ f g df v =
  begin
    f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v
  ≡⟨ cong₂ _⟦⊝⟧_
       (cong₂ _⟦⊕⟧_
         (cong f ((sym (f⊕Δf=f v))))
         (cong₂ df
           (sym (f⊕Δf=f v))
           (cong ⟦derive⟧ (sym (f⊕Δf=f v)))))
       refl ⟩
    f (v ⟦⊕⟧ ⟦derive⟧ v)
    ⟦⊕⟧ df (v ⟦⊕⟧ ⟦derive⟧ v) (⟦derive⟧ (v ⟦⊕⟧ ⟦derive⟧ v))
    ⟦⊝⟧ f v
  ≡⟨ refl ⟩
   (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
  ∎ where open ≡-Reasoning

validity-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    valid-Δ g (f ⟦⊕⟧ df ⟦⊝⟧ f) →
    valid-Δ (g v) (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
validity-over-⊕-and-⊝ f g df v R[g,f⊕df]
  rewrite application-over-⊕-and-⊝ f g df v =
    proj₁ (R[g,f⊕df] v (⟦derive⟧ v) (R[f,Δf] v))

-- diff-apply
df=f⊕df⊝f :
  ∀ {τ} (f : ⟦ τ ⟧) (df : ⟦ Δ-Type τ ⟧) →
    valid-Δ f df → as-Δ τ is df ext-equiv-to f ⟦⊕⟧ df ⟦⊝⟧ f

-- Case nat: this REFL is more obvious to Agda than to a human.
df=f⊕df⊝f {nats} n dn valid-f-df =
  ext-Δ (λ m valid-m-dn valid-rhs → refl)

df=f⊕df⊝f {τ₁ ⇒ τ₂} f df R[f,df] = ext-Δ (
  λ g R[g,df] R[g,f⊕df⊝f] →
    extensionality (λ v →
      begin
        g v ⟦⊕⟧ df v (⟦derive⟧ v)
      ≡⟨ extract-Δequiv
           (df=f⊕df⊝f
             (f v) (df v (⟦derive⟧ v))
             (proj₁ (R[f,df] v (⟦derive⟧ v) (R[f,Δf] v))))
           (g v)
           (proj₁ (R[g,df] v (⟦derive⟧ v) (R[f,Δf] v)))
           (validity-over-⊕-and-⊝ f g df v R[g,f⊕df⊝f]) ⟩
        g v ⟦⊕⟧ (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
      ≡⟨ cong₂ _⟦⊕⟧_
           {x = g v} {y = g v} refl
           (application-over-⊕-and-⊝ f g df v) ⟩
        g v ⟦⊕⟧ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
      ∎
    )
  )
  where open ≡-Reasoning

correctness-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  as-Δ τ is
  ⟦ deriveVar x ⟧ ρ
  ext-equiv-to
  ⟦ x ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ x ⟧ (ignore ρ)

correctness-of-deriveVar {τ • Γ₀} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  this = df=f⊕df⊝f {τ} v dv R[v,dv]
  --Putting `df=f⊕df⊝f v dv ?` on RHS triggers Agda bug.
  --TODO: Report it as Agda tells us to.

correctness-of-deriveVar {τ₀ • Γ₀} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ₀} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  (that x) = correctness-of-deriveVar ρ x

correctness-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  as-Δ τ is
  ⟦ derive t ⟧ ρ
  ext-equiv-to
  ⟦ t ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ t ⟧ (ignore ρ)

-- Mutually recursive lemma: derivatives are valid
validity-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  valid-Δ (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

validity-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  valid-Δ (⟦ x ⟧ (ignore ρ)) (⟦ deriveVar x ⟧ ρ)

validity-of-deriveVar {τ • Γ} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  this = R[v,dv]

validity-of-deriveVar {τ₀ • Γ} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  (that x) = validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ {consistency} (var x) =
  validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ (nat n) = refl

validity-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs t) = λ v dv R[v,dv] →
    validity-of-derive (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency} t
    , -- tuple constructor
      (begin
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          ⟦ derive t ⟧ (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
      ≡⟨ {!!} ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ)
        ⟦⊕⟧ {!!}
        ⟦⊕⟧ ⟦ derive t ⟧ (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)

      ≡⟨ {!!} ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧≼ ρ) ⟦⊕⟧ ⟦ derive t ⟧ (dv • v • ρ)
      ∎)
  where open ≡-Reasoning

validity-of-derive ρ (app t t₁) = {!!}

correctness-of-derive ρ (var x) = correctness-of-deriveVar ρ x

correctness-of-derive ρ (nat n) = ext-Δ (λ _ _ _ → refl)

correctness-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs {.τ₁} {.τ₂} t) =
  ext-Δ {τ₁ ⇒ τ₂}
    (λ f R[f,Δt] R[f,t′⊝t] →
      extensionality {⟦ τ₁ ⟧} {λ _ → ⟦ τ₂ ⟧} (λ x →
        begin
          f x ⟦⊕⟧ ⟦ derive t ⟧ (⟦derive⟧ x • x • ρ)
        ≡⟨ extract-Δequiv
            (correctness-of-derive {τ₁ • Γ} {τ₂}
               (⟦derive⟧ x • x • ρ)
               {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency}
               t)
            (f x)
            (proj₁ (R[f,Δt] x (⟦derive⟧ x) (R[f,Δf] x)))
            (proj₁ (R[f,t′⊝t] x (⟦derive⟧ x) (R[f,Δf] x))) ⟩
          f x
          ⟦⊕⟧
          (⟦ t ⟧ (update (⟦derive⟧ x • x • ρ)
                {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency})
          ⟦⊝⟧ ⟦ t ⟧ (x • ⟦ Γ≼ΔΓ ⟧ ρ))
        ∎
  )) where open ≡-Reasoning

correctness-of-derive ρ (app {τ₁} {τ₂} {Γ} t₁ t₂) =
  ext-Δ {τ₂}
  (λ f R[f,Δt] R[f,t′⊝t] →
    begin
      f ⟦⊕⟧ ⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ)
    ≡⟨ {!!} ⟩
      f ⟦⊕⟧
        (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ))
         ⟦⊝⟧
         ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ)))
    ∎
  ) where open ≡-Reasoning

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


{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd) using (_×_; _,_)
open import Data.Zero using (𝟘)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.One using (𝟙)
open import Data.LR
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; ap)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol

module Control.Protocol.Additive where

module send/recv-𝟘 (P : 𝟘 → Proto){{_ : FunExt}}{{_ : UA}} where
    P⊤ : Proto
    P⊤ = recvE 𝟘 P

    P0 : Proto
    P0 = sendE 𝟘 P

    P0-empty : ⟦ P0 ⟧ ≡ 𝟘
    P0-empty = ua (equiv fst (λ()) (λ()) (λ { (() , _) }))

    P⊤-uniq : ⟦ P⊤ ⟧ ≡ 𝟙
    P⊤-uniq = Π𝟘-uniq _

open send/recv-𝟘 (λ _ → end) public

_⊕_ : (l r : Proto) → Proto
l ⊕ r = send [L: l R: r ]

_&_ : (l r : Proto) → Proto
l & r = recv [L: l R: r ]

module _ {{_ : FunExt}} {P Q} where
    dual-⊕ : dual (P ⊕ Q) ≡ dual P & dual Q
    dual-⊕ = recv=′ [L: refl R: refl ]

    dual-& : dual (P & Q) ≡ dual P ⊕ dual Q
    dual-& = send=′ [L: refl R: refl ]

module _ {{_ : FunExt}}{{_ : UA}} P Q where
    &-comm : P & Q ≡ Q & P
    &-comm = recv≃ LR!-equiv [L: refl R: refl ]

    ⊕-comm : P ⊕ Q ≡ Q ⊕ P
    ⊕-comm = send≃ LR!-equiv [L: refl R: refl ]

    -- additive mix (left-biased)
    amixL : ⟦ P & Q ⟧ → ⟦ P ⊕ Q ⟧
    amixL pq = (`L , pq `L)

    amixR : ⟦ P & Q ⟧ → ⟦ P ⊕ Q ⟧
    amixR pq = (`R , pq `R)

module _ {P Q R S}(f : ⟦ P ⟧ → ⟦ Q ⟧)(g : ⟦ R ⟧ → ⟦ S ⟧) where
    ⊕-map : ⟦ P ⊕ R ⟧ → ⟦ Q ⊕ S ⟧
    ⊕-map (`L , pr) = `L , f pr
    ⊕-map (`R , pr) = `R , g pr

    &-map : ⟦ P & R ⟧ → ⟦ Q & S ⟧
    &-map p `L = f (p `L)
    &-map p `R = g (p `R)

module _ {P Q} where
    ⊕→⊎ : ⟦ P ⊕ Q ⟧ → ⟦ P ⟧ ⊎ ⟦ Q ⟧
    ⊕→⊎ (`L , p) = inl p
    ⊕→⊎ (`R , q) = inr q

    ⊎→⊕ : ⟦ P ⟧ ⊎ ⟦ Q ⟧ → ⟦ P ⊕ Q ⟧
    ⊎→⊕ = [inl: _,_ `L ,inr: _,_ `R ]

    ⊕≃⊎ : ⟦ P ⊕ Q ⟧ ≃ (⟦ P ⟧ ⊎ ⟦ Q ⟧)
    ⊕≃⊎ = equiv ⊕→⊎ ⊎→⊕ [inl: (λ _ → refl) ,inr: (λ _ → refl) ] ⊎→⊕→⊎
      where
        ⊎→⊕→⊎ : ∀ x → ⊎→⊕ (⊕→⊎ x) ≡ x
        ⊎→⊕→⊎ (`L , _) = refl
        ⊎→⊕→⊎ (`R , _) = refl

    ⊕≡⊎ : {{_ : UA}} → ⟦ P ⊕ Q ⟧ ≡ (⟦ P ⟧ ⊎ ⟦ Q ⟧)
    ⊕≡⊎ = ua ⊕≃⊎

    &→× : ⟦ P & Q ⟧ → ⟦ P ⟧ × ⟦ Q ⟧
    &→× p = p `L , p `R

    ×→& : ⟦ P ⟧ × ⟦ Q ⟧ → ⟦ P & Q ⟧
    ×→& (p , q) `L = p
    ×→& (p , q) `R = q

    &→×→& : ∀ x → &→× (×→& x) ≡ x
    &→×→& (p , q) = refl

    module _ {{_ : FunExt}} where
        ×→&→× : ∀ x → ×→& (&→× x) ≡ x
        ×→&→× p = λ= λ { `L → refl ; `R → refl }

        &≃× : ⟦ P & Q ⟧ ≃ (⟦ P ⟧ × ⟦ Q ⟧)
        &≃× = &→× , record { linv = ×→& ; is-linv = ×→&→× ; rinv = ×→& ; is-rinv = &→×→& }

        &≡× : {{_ : UA}} → ⟦ P & Q ⟧ ≡ (⟦ P ⟧ × ⟦ Q ⟧)
        &≡× = ua &≃×

module _ P {{_ : FunExt}}{{_ : UA}} where
    P⊤-& : ⟦ P⊤ & P ⟧ ≡ ⟦ P ⟧
    P⊤-& = &≡× ∙ ap (flip _×_ ⟦ P ⟧) P⊤-uniq ∙ Σ𝟙-snd

    P0-⊕ : ⟦ P0 ⊕ P ⟧ ≡ ⟦ P ⟧
    P0-⊕ = ⊕≡⊎ ∙ ap (flip _⊎_ ⟦ P ⟧) Σ𝟘-fst ∙ ⊎-comm ∙ ! ⊎𝟘-inl

module _ P Q R {{_ : FunExt}}{{_ : UA}} where
    &-assoc : ⟦ P & (Q & R) ⟧ ≡ ⟦ (P & Q) & R ⟧
    &-assoc = &≡× ∙ (ap (_×_ ⟦ P ⟧) &≡× ∙ ×-assoc ∙ ap (flip _×_ ⟦ R ⟧) (! &≡×)) ∙ ! &≡×

    ⊕-assoc : ⟦ P ⊕ (Q ⊕ R) ⟧ ≡ ⟦ (P ⊕ Q) ⊕ R ⟧
    ⊕-assoc = ⊕≡⊎ ∙ (ap (_⊎_ ⟦ P ⟧) ⊕≡⊎ ∙ ⊎-assoc ∙ ap (flip _⊎_ ⟦ R ⟧) (! ⊕≡⊎)) ∙ ! ⊕≡⊎

error: pathspec 'Control/Protocol/Additive.agda' did not match any file(s) known to git


clean

clean

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/nfjinjing/chu2.git/'


Testing a Collatz equation.

Testing a Collatz equation.

Ignore-this: 948c916df99a2e916db18694313cee79

darcs-hash:20110519193855-3bd4e-77ed59433535c117a35a8a9aed5a2339cb0fb479.gz

------------------------------------------------------------------------------
-- Equations for the Collatz function
------------------------------------------------------------------------------

module Draft.FOTC.Program.Collatz.EquationsATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers

open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat

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

postulate
  collatz-even    : ∀ {n} → GT n one → Even n →
                    collatz n ≡ collatz (n / two)
-- The ATPs cannot prove this equation.
{-# ATP prove collatz-even #-}

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


ElGamal: Homomorphic encryption and re-encryption

open import Function
open import Type using (★)
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Cipher.ElGamal.Homomorphic
  (ℤq  : ★)
  (G   : ★)
  (g   : G)
  (_⊞_ : ℤq → ℤq → ℤq)
  (_^_ : G → ℤq → G)
  (_♦_ : G → G → G)
  (_/_ : G → G → G)
  where

open import Cipher.ElGamal.Generic G ℤq G g _^_ _♦_ _/_

Combine : CipherText → CipherText → CipherText
Combine (a , b) (c , d) = (a ♦ c , b ♦ d)

Reenc : PubKey → CipherText → (rₑ : ℤq) → CipherText
Reenc pk (gʸ , ζ) rₑ = (g ^ rₑ) ♦ gʸ , (pk ^ rₑ) ♦ ζ

module HomomorphicCorrectness
    (/-♦    : ∀ {x y} → (x ♦ y) / x ≡ y)
    (comm-^ : ∀ {α x y} → (α ^ x)^ y ≡ (α ^ y)^ x)
    (interchange-♦ : ∀ {a b c d} → (a ♦ b) ♦ (c ♦ d) ≡ ((a ♦ c) ♦ (b ♦ d)))
    (^-⊞ : ∀ {α x y} → (α ^ x) ♦ (α ^ y) ≡ α ^ (x ⊞ y))
    where

  open FunctionalCorrectness /-♦ comm-^

  homomorphic-correctness : ∀ sk m₀ m₁ r₀ r₁ →
    let pk = PubKeyGen sk in
    Dec sk (Combine (Enc pk m₀ r₀) (Enc pk m₁ r₁)) ≡ m₀ ♦ m₁
  homomorphic-correctness rₖ m₀ m₁ r₀ r₁ =
    (ap (flip _/_ D) p ∙ ap (_/_ N ∘ flip _^_ rₖ) ^-⊞) ∙ functional-correctness rₖ (r₀ ⊞ r₁) (m₀ ♦ m₁)
    where D = ((g ^ r₀) ♦ (g ^ r₁))^ rₖ
          N = ((g ^ rₖ) ^ (r₀ ⊞ r₁)) ♦ (m₀ ♦ m₁)
          p = interchange-♦ ∙ ap (flip _♦_ (m₀ ♦ m₁)) ^-⊞

module ReencCorrectness
    (/-♦    : ∀ {x y} → (x ♦ y) / x ≡ y)
    (comm-^ : ∀ {α x y} → (α ^ x)^ y ≡ (α ^ y)^ x)
    (interchange-♦ : ∀ {a b c d} → (a ♦ b) ♦ (c ♦ d) ≡ ((a ♦ c) ♦ (b ♦ d)))
    (^-⊞ : ∀ {α x y} → (α ^ x) ♦ (α ^ y) ≡ α ^ (x ⊞ y))
    (g⁰ : G)
    (g⁰-idl : ∀ x → g⁰ ♦ x ≡ x)
    (g⁰-idr : ∀ x → x ♦ g⁰ ≡ x)
    where
  open HomomorphicCorrectness /-♦ comm-^ interchange-♦ ^-⊞

  Reenc-Combine-g⁰ : ∀ pk c r → Reenc pk c r ≡ Combine (Enc pk g⁰ r) c
  Reenc-Combine-g⁰ pk c r = cong₂ _,_ refl (ap (flip _♦_ (proj₂ c)) (! (g⁰-idr _)))

  Reenc-correct : ∀ sk m r₀ r₁ →
                  let pk = PubKeyGen sk in
                  Dec sk (Reenc pk (Enc pk m r₁) r₀) ≡ m
  Reenc-correct rₖ m r₀ r₁ = ap (λ z → (z ♦ (((g ^ rₖ) ^ r₁) ♦ m)) / D)
                                (! (g⁰-idr _))
                           ∙ homomorphic-correctness rₖ g⁰ m r₀ r₁
                           ∙ g⁰-idl _
    where D = ((g ^ r₀) ♦ (g ^ r₁))^ rₖ

error: pathspec 'Cipher/ElGamal/Homomorphic.agda' did not match any file(s) known to git


Add Nearring+1

Add Nearring+1

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

module Algebra.Nearring where

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

  open ≡-Reasoning

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

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

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

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

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

  module +-Grp = Group +-grp

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

  module *-Mon = Monoid *-mon

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

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


Monad.agda

Monad.agda

open import Function
open import Relation.Binary.PropositionalEquality

open import Explore.Type

module Explore.Monad ℓ where

M = Explore ℓ

module _ {A : Set} where
    return : A → M A
    return x _∙_ f = f x

    return-ind : ∀ x → ExploreInd₀ (return x)
    return-ind x P _P∙_ Pf = Pf x

module _ {A B : Set} where

    infixl 1 _>>=_ _>>=-ind_
    _>>=_ : M A → (A → M B) → M B
    (expᴬ >>= expᴮ) _∙_ f = expᴬ _∙_ λ x → expᴮ x _∙_ f

    _>>=-ind_ : ∀ {expᴬ : M A} → ExploreInd₀ expᴬ →
                 {expᴮ : A → M B} → (∀ x → ExploreInd₀ (expᴮ x))
               → ExploreInd₀ (expᴬ >>= expᴮ)
    _>>=-ind_ {expᴬ} Pᴬ {expᴮ} Pᴮ P _P∙_ Pf
      = Pᴬ (λ e → P (e >>= expᴮ)) _P∙_ λ x → Pᴮ x P _P∙_ Pf

    map : (A → B) → M A → M B
    map f e = e >>= return ∘ f

    map-ind : (f : A → B) {expᴬ : M A} → ExploreInd₀ expᴬ → ExploreInd₀ (map f expᴬ)
    map-ind f Pᴬ = Pᴬ >>=-ind return-ind ∘ f

    private
        {- This law is for free: map f e = e >>= return ∘ f -}
        map' : (A → B) → M A → M B
        map' f exp _∙_ g = exp _∙_ (g ∘ f)

        map'≡map : map' ≡ map
        map'≡map = refl

-- universe issues...
-- join : M (M A) → M A

module _ {A B C : Set} (m : M A) (f : A → M B) (g : B → M C) where
    infix 0 _≡e_
    _≡e_ = λ {A} → _≡_ {A = M A}

    left-identity : f ≡ (λ x → return x >>= f)
    left-identity = refl

    right-identity : m ≡e m >>= return
    right-identity = refl

    associativity : m >>= (λ x → f x >>= g) ≡e (m >>= f) >>= g
    associativity = refl

error: pathspec 'lib/Explore/Monad.agda' did not match any file(s) known to git


Proved a non-admissible property from the HALO paper.

------------------------------------------------------------------------------
-- Testing a non-admissible property from the HALO paper
------------------------------------------------------------------------------

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

-- References:
--
-- • Vytiniotis, D., Peyton Jones, S., Rosén, D. and Claessen,
--   K. (2013). HALO: Haskell to Logic thorugh Denotational
--   Semantics. In: Proceedings of the 40th annual ACM SIGPLAN-SIGACT
--   symposium on Principles of programming languages (POPL’13),
--   pp. 431–442.

module FOT.FOTC.UnguardedCorecursion.HALO where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Nat
open import FOTC.Data.Stream.Equality.PropertiesI
open import FOTC.Relation.Binary.Bisimilarity
open import FOTC.Relation.Binary.Bisimilarity.PropertiesI

------------------------------------------------------------------------------
-- The HALO paper states the property
--
-- ∀ x . f x ≠ ones
--
-- cannot be proved because it is a non-admissible predicate.

postulate
  ones    : D
  ones-eq : ones ≡ succ₁ zero ∷ ones

postulate
  f     : D → D
  f-eq₁ : ∀ n → f (succ₁ n) ≡ succ₁ zero ∷ f n
  f-eq₂ : f zero ≡ zero ∷ []

-- A proof using the bisimilarity relation relation.
thm : ∀ {n} → N n → ¬ (f n ≈ ones)
thm nzero h with ≈-unf h
... | x' , xs' , ys' , prf₁ , prf₂ , prf₃ = 0≢S (trans (sym x'≡0) x'≡1)
  where
  x'≡0 : x' ≡ zero
  x'≡0 = ∧-proj₁ (∷-injective (trans (sym prf₁) f-eq₂))

  x'≡1 : x' ≡ succ₁ zero
  x'≡1 = ∧-proj₁ (∷-injective (trans (sym prf₂) ones-eq))

thm (nsucc {n} Nn) h with ≈-unf h
... | x' , xs' , ys' , prf₁ , prf₂ , prf₃ = thm Nn (∷-injective≈ helper)
  where
  xs'≡fn : xs' ≡ f n
  xs'≡fn = ∧-proj₂ (∷-injective (trans (sym prf₁) (f-eq₁ n)))

  ys'≡ones : ys' ≡ ones
  ys'≡ones = ∧-proj₂ (∷-injective (trans (sym prf₂) ones-eq))

  helper : x' ∷ f n ≈ x' ∷ ones
  helper = ≈-pre-fixed ( x'
                       , xs'
                       , ys'
                       , ∷-rightCong (sym xs'≡fn)
                       , ∷-rightCong (sym ys'≡ones)
                       , prf₃
                       )

-- A proof using the propositional equality.
thm' : ∀ {n} → N n → f n ≢ ones
thm' nzero h = 0≢S (∧-proj₁ (∷-injective helper))
  where
  helper : zero ∷ [] ≡ succ₁ zero ∷ ones
  helper = trans₂ (sym f-eq₂) h ones-eq

thm' (nsucc {n} Nn) h = thm' Nn (∧-proj₂ (∷-injective helper))
  where
  helper : succ₁ zero ∷ f n ≡ succ₁ zero ∷ ones
  helper = trans₂ (sym (f-eq₁ n)) h ones-eq

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


Try a different method

Try a different method

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


Add FFI.JS.BigI

Add FFI.JS.BigI

open import FFI.JS hiding (toString)

module FFI.JS.BigI where

abstract
  BigI : Set
  BigI = JSValue

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

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

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

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

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

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


Algebra.NP: "flip"ping structures

Algebra.NP: "flip"ping structures

module Algebra.NP where

open import Algebra public
open import Algebra.Structures
open import Algebra.FunctionProperties
open import Function
open import Data.Product
open import Relation.Binary

module Flip where
    module Structures {c} {C : Set c} {ℓ} (_≈_ : C → C → Set ℓ) (_∙_ : Op₂ C) where
        flipIsSemigroup : IsSemigroup _≈_ _∙_ → IsSemigroup _≈_ (flip _∙_)
        flipIsSemigroup isSg = record { isEquivalence = isEquivalence
                                      ; assoc = λ x y z → sym (assoc z y x)
                                      ; ∙-cong = λ p q → sym (∙-cong (sym q) (sym p)) }
            where open IsSemigroup isSg

        flipIsMonoid : ∀ {ε} → IsMonoid _≈_ _∙_ ε → IsMonoid _≈_ (flip _∙_) ε
        flipIsMonoid isMon = record { isSemigroup = flipIsSemigroup isSemigroup
                                    ; identity    = swap identity }
            where open IsMonoid isMon

        flipIsCommutativeMonoid : ∀ {ε} → IsCommutativeMonoid _≈_ _∙_ ε
                                        → IsCommutativeMonoid _≈_ (flip _∙_) ε
        flipIsCommutativeMonoid isCMon
          = record { isSemigroup = flipIsSemigroup isSemigroup
                   ; identityˡ = proj₂ identity; comm = flip comm }
            where open IsCommutativeMonoid isCMon

        flipIsGroup : ∀ {ε} {_⁻¹} → IsGroup _≈_ _∙_ ε _⁻¹ → IsGroup _≈_ (flip _∙_) ε _⁻¹
        flipIsGroup isGr = record { isMonoid = flipIsMonoid isMonoid
                                  ; inverse = swap inverse
                                  ; ⁻¹-cong = ⁻¹-cong }
            where open IsGroup isGr

        flipIsAbelianGroup : ∀ {ε} {_⁻¹} → IsAbelianGroup _≈_ _∙_ ε _⁻¹
                                         → IsAbelianGroup _≈_ (flip _∙_) ε _⁻¹
        flipIsAbelianGroup isAGr = record { isGroup = flipIsGroup isGroup
                                          ; comm    = flip comm }
            where open IsAbelianGroup isAGr

    flipSemigroup : ∀ {c ℓ} → Semigroup c ℓ → Semigroup c ℓ
    flipSemigroup sg = record { isSemigroup = flipIsSemigroup isSemigroup }
      where open Semigroup sg
            open Structures _≈_ _∙_

    flipMonoid : ∀ {c ℓ} → Monoid c ℓ → Monoid c ℓ
    flipMonoid m = record { isMonoid = flipIsMonoid isMonoid }
      where open Monoid m
            open Structures _≈_ _∙_

    flipCommutativeMonoid : ∀ {c ℓ} → CommutativeMonoid c ℓ → CommutativeMonoid c ℓ
    flipCommutativeMonoid cm
      = record { isCommutativeMonoid = flipIsCommutativeMonoid isCommutativeMonoid }
      where open CommutativeMonoid cm
            open Structures _≈_ _∙_

    flipGroup : ∀ {c ℓ} → Group c ℓ → Group c ℓ
    flipGroup gr = record { isGroup = flipIsGroup isGroup }
      where open Group gr
            open Structures _≈_ _∙_

    flipAbelianGroup : ∀ {c ℓ} → AbelianGroup c ℓ → AbelianGroup c ℓ
    flipAbelianGroup agr = record { isAbelianGroup = flipIsAbelianGroup isAbelianGroup }
      where open AbelianGroup agr
            open Structures _≈_ _∙_

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


Added an issue related with the eta-expansion of definitions.

Ignore-this: 9c9a69a8db6a0e8fb1efc562fa205c73

darcs-hash:20110726163740-3bd4e-d1f2d2388fef48710a9388f0aa1d157f3b113bf7.gz

-- Issue: At the moment, we don't eta-expand the equations in the ATP
-- definitions.

module Test.Issues.Eta where

postulate
  D       : Set
  binaryP : D → D → Set

data ∃ (P : D → Set) : Set where
  _,_ : (witness : D) → P witness → ∃ P

-- Because Agda eta-reduces the equations, the internal representation
-- of P corresponds to the function
--
-- P xs = ∃ (binary xs)
--
-- Due to it, we cannot proof the conjecture bar.

P : D → Set
P xs = ∃ λ ys → binaryP xs ys
{-# ATP definition P #-}

postulate
  foo : ∀ {xs} → (∃ λ ys → binaryP xs ys) → (∃ λ ys → binaryP xs ys)
{-# ATP prove foo #-}

postulate
  barP : ∀ {xs} → P xs → (∃ λ ys → binaryP xs ys)
{-# ATP prove bar #-}

error: pathspec 'Test/Issues/Eta.agda' did not match any file(s) known to git


module Control.Protocol.Parametricity where

open import Type
open import Relation.Binary.Logical

data Proto : ★₁ where
  end  : Proto
  send : {M : ★}(P : M → Proto) → Proto
  recv : {M : ★}(P : M → Proto) → Proto

data ⟦Proto⟧ : ⟦★₁⟧ Proto Proto where
  ⟦end⟧  : ⟦Proto⟧ end end
  ⟦send⟧ : (∀⟨ Mᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ (Mᵣ ⟦→⟧ ⟦Proto⟧) ⟦→⟧ ⟦Proto⟧) send send
  ⟦recv⟧ : (∀⟨ Mᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ (Mᵣ ⟦→⟧ ⟦Proto⟧) ⟦→⟧ ⟦Proto⟧) recv recv

error: pathspec 'Control/Protocol/Parametricity.agda' did not match any file(s) known to git


Text.Parser.Heap: sweet but slow :(

Text.Parser.Heap: sweet but slow :(

{-# OPTIONS --without-K #-}
-- Inspired from https://www.fpcomplete.com/user/edwardk/heap-of-successes
--               https://gist.github.com/ekmett/578eaf3e5a37f7315e6c
--
-- Too slow so far: see an example in github.com/crypto-agda/crypto-agda Solver.Linear.Parser
open import Type using (Type; Type_)
open import Data.Maybe.NP using (_→?_; map?)
open import Data.Nat.NP using (ℕ; zero; suc; _<=_; _∸_; _+_) renaming (_==_ to _==ℕ_)
open import Data.One using (𝟙)
open import Data.Char.NP renaming (_==_ to _==ᶜ_)
open import Data.List.NP as L using (List; []; _∷_; null; filter)
open import Data.Vec using (Vec; []; _∷_)
open import Data.BoundedVec using (BoundedVec) renaming ([] to []ᵇᵛ; _∷_ to _∷ᵇᵛ_)
open import Data.Product.NP renaming (map to ×-map)
open import Data.Bool using (Bool; if_then_else_; false)
open import Data.String using (String) renaming (toList to S▹L; fromList to L▹S)
open import Function.NP
open import Level.NP

module Text.Parser.Heap where

-- Loosely typed assoc list with sorted keys
Heap : Type → Type
Heap A = List (ℕ × A)

module Heap {A : Type} where
  gather : Heap A → Heap (List A)
  gather [] = []
  gather ((i₀ , a₀) ∷ as₀) = go i₀ (a₀ ∷ []) as₀ where
    go : ℕ → _ → List _ → _
    go i acc [] = (i , acc) ∷ []
    go i acc ((j , a) ∷ as)
      = if i ==ℕ j then go i (a ∷ acc) as
                   else (i , acc) ∷ go j (a ∷ []) as

  -- fair interleaving, because, well, why not?
  merge : Heap A → Heap A → Heap A
  merge [] as = as
  merge as [] = as
  merge (a ∷ as) (b ∷ bs) =
    if fst a <= fst b then a ∷ merge (b ∷ bs) as
                      else b ∷ merge bs (a ∷ as)

  sing : ℕ → A → Heap A
  sing n a = (n , a) ∷ []

  map : ∀ {B} → (ℕ → ℕ) → (A → B) → Heap A → Heap B
  map f g = L.map (×-map f g)

  reset : Heap A → Heap A
  reset = L.map (first (const 0))

Parser : (I O : Type) → Type
Parser I O = I → Heap O

ParserL : (I O : Type) → Type
ParserL I O = Parser (List I) O

ParserLC = ParserL Char

module _ {I O : Type} where
  pure : O → Parser I O
  pure o i = Heap.sing 0 o

  empty : Parser I O
  empty _ = []

  infixr 3 _⟨|⟩_
  _⟨|⟩_ : (f g : Parser I O) → Parser I O
  (f ⟨|⟩ g) i = Heap.merge (f i) (g i)

  choices : List (Parser I O) → Parser I O
  choices = L.foldr _⟨|⟩_ empty

-- Parser is a Profunctor
dimap : ∀{I I' O O'}(f : I' → I)(g : O → O') → Parser I O → Parser I' O'
dimap f g p s = L.map (second g) (p (f s))

-- The remaning input is dropped, you may want to first
-- combine your parser `p' with `eof': `p <* eof'
runParser : ∀ {A} → ParserLC A → List Char →? A
runParser p = map? snd ∘ L.listToMaybe ∘ p

runParserˢ : ∀ {A} → ParserLC A → String →? A
runParserˢ p = runParser p ∘ S▹L

lookSat : ∀ {I} → (I → Bool) → Parser I 𝟙
lookSat p i = if p i then (0 , _) ∷ [] else []

notFollowedBy : ∀ {I O} → Parser I O → Parser I 𝟙
notFollowedBy m = lookSat (null ∘ m)

lookAhead : ∀ {I O} → Parser I O → Parser I O
lookAhead p = Heap.reset ∘ p

module _ {I : Type} where
  private
    M = ParserL I

  sat : (I → Bool) → M I
  sat pred (x ∷ xs) = if pred x then (1 , x) ∷ [] else []
  sat _    []       = []

  eof : M 𝟙
  eof = lookSat null

  infixr 0 _>>=_
  _>>=_ : ∀ {A B} → ParserL I A → (A → ParserL I B) → ParserL I B
  (ma >>= amb) s₀ = go 0 s₀ (ma s₀) [] where
    go : _ → _ → List _ → _ → _
    go i s ((j , a) ∷ fss) acc =
      let s' = L.drop (j ∸ i) s in
      go j s' fss (Heap.merge acc (L.map (first (_+_ j)) (amb a s')))
    go _ _ [] acc = acc

  infixl 0 _=<<_
  _=<<_ : ∀ {A B} → (A → ParserL I B) → ParserL I A → ParserL I B
  _=<<_ f pa = pa >>= f

  infixl 4 _⊛_ _*>_ _<*_
  _⊛_ : ∀ {A B} → ParserL I (A → B) → ParserL I A → ParserL I B
  (mf ⊛ ma) s₀ = go 0 s₀ (Heap.gather (mf s₀)) [] where
    go : _ → _ → List _ → _ → _
    go i s ((j , fs) ∷ fss) acc with L.drop (j ∸ i) s
    ... | s' =
      go j s' fss (Heap.merge acc (L.concatMap (λ { (k , a) → L.map (λ f -> (j + k , f a)) fs }) (ma s')))
    go _ _ [] acc = acc

  map : ∀ {A B} → (A → B) → ParserL I A → ParserL I B
  map f pa s₀ = Heap.map id f (pa s₀)

  {-
  map-spec : ∀ {A B}{f : A → B}{pa : ParserL I A} →
             map f pa ≡ pure f ⊛ pa
  map-spec rewrite ... concatMap-map = refl
  -}

  ⟪_·_⟫ : ∀ {A B} → (A → B) → M A → M B
  ⟪ f · x ⟫ = map f x

  ⟪_·_·_⟫ : ∀ {A B C} →
              (A → B → C) → M A → M B → M C
  ⟪ f · x · y ⟫ = map f x ⊛ y

  ⟪_·_·_·_⟫ : ∀ {A B C D} → (A → B → C → D)
              → M A → M B → M C → M D
  ⟪ f · x · y · z ⟫ = map f x ⊛ y ⊛ z

  _*>_ : ∀ {A B} → M A → M B → M B
  p₁ *> p₂ = ⟪ const id · p₁ · p₂ ⟫

  _<*_ : ∀ {A B} → M A → M B → M A
  p₁ <* p₂ = ⟪ const · p₁ · p₂ ⟫

  mapM : ∀ {a} {A : Type_ a} {B} → (A → M B) → List A → M (List B)
  mapM f []       = pure []
  mapM f (x ∷ xs) = ⟪ _∷_ · f x · mapM f xs ⟫

  mapMvoid : ∀ {a} {A : Type_ a} {B} → (A → M B) → List A → M 𝟙
  mapMvoid f []       = pure _
  mapMvoid f (x ∷ xs) = f x *> mapMvoid f xs

  module _ {A : Type} where
    join : ParserL I (ParserL I A) → ParserL I A
    join = _=<<_ id

    vec : ∀ n → M A → M (Vec A n)
    vec zero    p = pure []
    vec (suc n) p = ⟪ _∷_ · p · vec n p ⟫

    -- These are producing bounded vectors mainly for termination
    -- reasons.
    manyBV : ∀ n → M A → M (BoundedVec A n)
    someBV : ∀ n → M A → M (BoundedVec A (suc n))

    manyBV 0       _ = empty
    manyBV (suc n) p = someBV n p ⟨|⟩ pure []ᵇᵛ

    someBV n p = ⟪ _∷ᵇᵛ_ · p · manyBV n p ⟫

    many : ∀ n → M A → M (List A)
    some : ∀ n → M A → M (List A)

    many 0       _ = empty
    many (suc n) p = some n p ⟨|⟩ pure []

    some n p = ⟪ _∷_ · p · many n p ⟫

manySat : (Char → Bool) → ParserLC (List Char)
manySat p []       = (0 , []) ∷ []
manySat p (x ∷ xs) = if p x then Heap.map suc (_∷_ x) (manySat p xs) else (0 , []) ∷ []

manySatˢ : (Char → Bool) → ParserLC String
manySatˢ = map L▹S ∘ manySat

someSat : (Char → Bool) → ParserLC (List Char)
someSat p = pure _∷_ ⊛ sat p ⊛ manySat p

someSatˢ : (Char → Bool) → ParserLC String
someSatˢ = map L▹S ∘ someSat

char : Char → ParserLC 𝟙
char c = sat (_==ᶜ_ c) *> pure _

string : String → ParserLC 𝟙
string = mapMvoid char ∘ S▹L

oneOf : List Char → ParserLC Char
oneOf cs = sat (λ c → c `elem` cs)

oneOfˢ : String → ParserLC Char
oneOfˢ = oneOf ∘ S▹L

noneOf : List Char → ParserLC Char
noneOf cs = sat (λ c → c `notElem` cs)

noneOfˢ : String → ParserLC Char
noneOfˢ = noneOf ∘ S▹L

someOneOf : List Char → ParserLC (List Char)
someOneOf cs = someSat (λ c → c `elem` cs)

someOneOfˢ : String → ParserLC String
someOneOfˢ = map L▹S ∘ someOneOf ∘ S▹L

someNoneOf : List Char → ParserLC (List Char)
someNoneOf cs = someSat (λ c → c `notElem` cs)

someNoneOfˢ : String → ParserLC String
someNoneOfˢ = map L▹S ∘ someNoneOf ∘ S▹L

manyOneOf : List Char → ParserLC (List Char)
manyOneOf cs = manySat (λ c → c `elem` cs)

manyOneOfˢ : String → ParserLC String
manyOneOfˢ = map L▹S ∘ manyOneOf ∘ S▹L

manyNoneOf : List Char → ParserLC (List Char)
manyNoneOf cs = manySat (λ c → c `notElem` cs)

manyNoneOfˢ : String → ParserLC String
manyNoneOfˢ = map L▹S ∘ manyNoneOf ∘ S▹L

lookSatHead : (Char → Bool) → ParserLC 𝟙
lookSatHead pᶜ = lookSat p
    where p : List Char → Bool
          p (x ∷ xs) = pᶜ x
          p []       = false

lookHeadNoneOf : List Char → ParserLC 𝟙
lookHeadNoneOf cs = lookSatHead (λ c → c `notElem` cs)

lookHeadNoneOfˢ : String → ParserLC 𝟙
lookHeadNoneOfˢ = lookHeadNoneOf ∘ S▹L

lookHeadSomeOf : List Char → ParserLC 𝟙
lookHeadSomeOf cs = lookSatHead (λ c → c `elem` cs)

lookHeadSomeOfˢ : String → ParserLC 𝟙
lookHeadSomeOfˢ = lookHeadSomeOf ∘ S▹L

module _ {A} where
    between : ∀ {_V} (begin end : ParserLC _V) → Endo (ParserLC A)
    between begin end p = begin *> p <* end

    betweenᶜ : (begin end : Char) → Endo (ParserLC A)
    betweenᶜ begin end = between (char begin) (char end)

    betweenˢ : (begin end : String) → Endo (ParserLC A)
    betweenˢ begin end = between (string begin) (string end)

    parens   = betweenᶜ '(' ')'
    braces   = betweenᶜ '{' '}'
    brackets = betweenᶜ '[' ']'
    angles   = betweenᶜ '<' '>'
    oxford   = betweenᶜ '⟦' '⟧'

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

error: pathspec 'lib/Text/Parser/Heap.agda' did not match any file(s) known to git


Comments in WhyDependentTypesMatter

Comments in WhyDependentTypesMatter

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/jstolarek/sandbox.git/'


Added MinBC.agda example.

Added MinBC.agda example.

------------------------------------------------------------------------------
-- Example of a partial function using the Bove-Capretta method
------------------------------------------------------------------------------

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

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. vol 2152 LNCS. 2001.

module FOT.FOTC.Program.Min.MinBC where

open import Data.Nat
open import Relation.Binary.PropositionalEquality

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

data minAcc : (ℕ → ℕ) → Set where
  minacc0 : (f : ℕ → ℕ) → f 0 ≡ 0 → minAcc f
  minacc1 : (f : ℕ → ℕ) → f 0 ≢ 0 → minAcc (λ n → f (suc n)) → minAcc f

min : (f : ℕ → ℕ) → minAcc f → ℕ
min f (minacc0 .f q)   = 0
min f (minacc1 .f q h) = suc (min (λ n → f (suc n)) h)

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


Implement change structure for sum types

module Base.Change.Sums where

open import Relation.Binary.PropositionalEquality
open import Level

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    open FunctionChanges using (apply; correct)

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

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

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

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

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

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

error: pathspec 'Base/Change/Sums.agda' did not match any file(s) known to git


circuit.agda

circuit.agda

module circuit where

open import Function
open import Data.Nat.NP hiding (_≟_; compare)
open import Data.Bits
open import Data.Bool hiding (_≟_)
open import Data.Product hiding (swap; map)
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc; inject+; raise; #_)
open import Data.List using (List; []; _∷_)
open import Data.Vec using (Vec; []; _∷_; foldr; _[_]≔_; lookup; _++_; splitAt; tabulate; allFin) renaming (map to vmap)
open import Relation.Nullary.Decidable hiding (map)
open import Relation.Binary.PropositionalEquality

CircuitType : Set₁
CircuitType = (i o : ℕ) → Set

module Rewire where
  RewireFun : CircuitType
  RewireFun i o = Fin o → Fin i

  RewireTbl : CircuitType
  RewireTbl i o = Vec (Fin i) o

  rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (flip lookup v ∘ f)

  rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = vmap (flip lookup v) tbl

  runRewireFun : ∀ {i o} → RewireFun i o → Bits i → Bits o
  runRewireFun = rewire

  runRewireTbl : ∀ {i o} → RewireTbl i o → Bits i → Bits o
  runRewireTbl = rewireTbl

open Rewire using (RewireTbl; RewireFun)

record RewiringBuilder (C : CircuitType) : Set where
  constructor mk

  infixr 1 _>>>_
  infixr 3 _***_

  field
    rewire : ∀ {i o} → RewireFun i o → C i o

    _>>>_  : ∀ {i m o} → C i m → C m o → C i o

    _***_  : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)

  rewireWithTbl : ∀ {i o} → RewireTbl i o → C i o
  rewireWithTbl = rewire ∘ flip lookup

  idC : ∀ {i} → C i i
  idC = rewire id

  sink : ∀ i → C i 0
  sink _ = rewire (λ())

  dup : ∀ o → C 1 o
  dup _ = rewire (const zero)

  dup₂ : C 1 2
  dup₂ = dup 2

  vcat : ∀ {i o n} → Vec (C i o) n → C (n * i) (n * o)
  vcat []       = idC
  vcat (x ∷ xs) = x *** vcat xs

  coerce : ∀ {i₀ i₁ o₀ o₁} → i₀ ≡ i₁ → o₀ ≡ o₁ → C i₀ o₀ → C i₁ o₁
  coerce refl refl = id

  dupⁿ : ∀ {n} k → C n (k * n)
  dupⁿ {n} k = coerce (proj₂ ℕ°.*-identity n) (ℕ°.*-comm n k) (vcat {n = n} (replicate (dup _)))

  ext-before : ∀ {k i o} → C i o → C (k + i) (k + o)
  ext-before {k} c = idC {k} *** c

  ext-after : ∀ {k i o} → C i o → C (i + k) (o + k)
  ext-after c = c *** idC

  dropC : ∀ {k i o} → C i o → C (k + i) o
  dropC {k} c = sink k *** c

  dropC' : ∀ {k i} → C (k + i) i
  dropC' {k} = dropC {k} idC

  swap : ∀ {i} (x y : Fin i) → C i i
  -- swap x y = arr (λ xs → (xs [ x ]≔ (lookup y xs)) [ y ]≔ (lookup x xs))
  swap x y = rewire (Fin.swap x y)

  rev : ∀ {i} → C i i
  rev = rewire Fin.reverse

  swap₂ : C 2 2
  swap₂ = rev
  -- swap₂ = swap (# 0) (# 1)

  Perm : ℕ → Set
  Perm n = List (Fin n × Fin n)

  perm : ∀ {i} → Perm i → C i i
  perm [] = idC
  perm ((x , y) ∷ π) = swap x y >>> perm π

record CircuitBuilder (C : CircuitType) : Set where
  constructor mk
  field
    isRewiringBuilder : RewiringBuilder C
    arr : ∀ {i o} → (Bits i → Bits o) → C i o

  open RewiringBuilder isRewiringBuilder public

  bit : Bit → C 0 1
  bit b = arr (const (b ∷ []))

  0ʷ : C 0 1
  0ʷ = bit 0b

  1ʷ : C 0 1
  1ʷ = bit 1b

  unOp : (Bit → Bit) → C 1 1
  unOp op = arr (λ { (x ∷ []) → (op x) ∷ [] })

  notC : C 1 1
  notC = unOp not

  binOp : (Bit → Bit → Bit) → C 2 1
  binOp op = arr (λ { (x ∷ y ∷ []) → (op x y) ∷ [] })

  xorC : C 2 1
  xorC = binOp _xor_

  eqC : C 2 1
  eqC = binOp _==ᵇ_

  orC : C 2 1
  orC = binOp _∨_

  andC : C 2 1
  andC = binOp _∧_

  norC : C 2 1
  norC = binOp (λ x y → not (x ∨ y))

  nandC : C 2 1
  nandC = binOp (λ x y → not (x ∧ y))

_→ᵇ_ : CircuitType
i →ᵇ o = Bits i → Bits o

_→ᶠ_ : CircuitType
i →ᶠ o = Fin o → Fin i

finFunRewiringBuilder : RewiringBuilder _→ᶠ_
finFunRewiringBuilder = mk id _∘′_ _***_
  where
    C = _→ᶠ_

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
    _***_ {o₀ = o₀} f g x with Fin.cmp o₀ _ x
    _***_      f _ ._ | Fin.bound x = inject+ _ (f x)
    _***_ {i₀} _ g ._ | Fin.free  x = raise i₀ (g x)

tblRewiringBuilder : RewiringBuilder RewireTbl
tblRewiringBuilder = mk tabulate _>>>_ _***_
  where
    open Rewire
    C = RewireTbl

    _>>>_ : ∀ {i m o} → C i m → C m o → C i o
    c₀ >>> c₁ = rewireTbl c₁ c₀
    -- c₀ >>> c₁ = tabulate (flip lookup c₀ ∘ flip lookup c₁)
    -- c₀ >>> c₁ = vmap (flip lookup c₀) c₁

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
    _***_ {i₀} c₀ c₁ = vmap (inject+ _) c₀ ++ vmap (raise i₀) c₁

bitsFunRewiringBuilder : RewiringBuilder _→ᵇ_
bitsFunRewiringBuilder = mk Rewire.rewire _>>>_ _***_
  where
    C = _→ᵇ_

    _>>>_ : ∀ {i m o} → C i m → C m o → C i o
    f >>> g = g ∘ f

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
    (f *** g) xs with splitAt _ xs
    ... | ys , zs , _ = f ys ++ g zs

bitsFunCircuitBuilder : CircuitBuilder _→ᵇ_
bitsFunCircuitBuilder = mk bitsFunRewiringBuilder id

open import bintree
open import flipbased-tree

TreeBits : CircuitType
TreeBits i o = Tree (Bits o) i

module moretree where
  _>>>_ : ∀ {m n a} {A : Set a} → Tree (Bits m) n → Tree A m → Tree A n
  f >>> g = map (flip bintree.lookup g) f

treeBitsRewiringBuilder : RewiringBuilder TreeBits
treeBitsRewiringBuilder = mk rewire moretree._>>>_ _***_
  where
    C = TreeBits

    rewire : ∀ {i o} → RewireFun i o → C i o
    rewire f = fromFun (Rewire.rewire f)

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
    (f *** g) = f >>= λ xs → map (_++_ xs) g

treeBitsCircuitBuilder : CircuitBuilder TreeBits
treeBitsCircuitBuilder = mk treeBitsRewiringBuilder arr
  where
    C = TreeBits

    arr : ∀ {i o} → (Bits i → Bits o) → C i o
    arr = fromFun

RewiringTree : CircuitType
RewiringTree i o = Tree (Fin i) o

module RewiringWith2^Outputs where
    C_⟨2^_⟩ = RewiringTree

    rewire : ∀ {i o} → RewireFun i (2 ^ o) → C i ⟨2^ o ⟩
    rewire f = fromFun (f ∘ toFin)

    lookupFin : ∀ {i o} → C i ⟨2^ o ⟩ → Fin (2 ^ o) → Fin i
    lookupFin c x = bintree.lookup (fromFin x) c

    _>>>_ : ∀ {i m o} → C i ⟨2^ m ⟩ → C (2 ^ m) ⟨2^ o ⟩ → C i ⟨2^ o ⟩
    f >>> g = rewire (lookupFin f ∘ lookupFin g)

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ ⟨2^ o₀ ⟩ → C i₁ ⟨2^ o₁ ⟩ → C (i₀ + i₁) ⟨2^ (o₀ + o₁) ⟩
    f *** g = f >>= λ x → map (Fin._+′_ x) g

module Test where
  open import Data.Bits.Bits4

  tbl : RewireTbl 4 4
  tbl = # 1 ∷ # 0 ∷ # 2 ∷ # 2 ∷ []

  fun : RewireFun 4 4
  fun zero = # 1
  fun (suc zero) = # 0
  fun (suc (suc zero)) = # 2
  fun (suc (suc (suc x))) = # 2

-- swap x y ≈ swap y x
-- reverse ∘ reverse ≈ id

  abs : ∀ {C} → RewiringBuilder C → C 4 4
  abs builder = swap₂ *** dup₂ *** sink 1
    where open RewiringBuilder builder

  tinytree : Tree (Fin 4) 2
  tinytree = fork (fork (leaf (# 1)) (leaf (# 0))) (fork (leaf (# 2)) (leaf (# 2)))

  bigtree : Tree (Bits 4) 4
  bigtree = fork (fork (fork (same 0000b) (same 0011b)) (fork (same 1000b) (same 1011b)))
                 (fork (fork (same 0100b) (same 0111b)) (fork (same 1100b) (same 1111b)))
    where same : ∀ {n} {A : Set} → A → Tree A (suc n)
          same x = fork (leaf x) (leaf x)

  test₁ : tbl ≡ tabulate fun
  test₁ = refl

  test₂ : tbl ≡ abs tblRewiringBuilder
  test₂ = refl

  test₃ : tabulate fun ≡ tabulate (abs finFunRewiringBuilder)
  test₃ = refl

  test₄ : bigtree ≡ abs treeBitsRewiringBuilder
  test₄ = refl

  open RewiringWith2^Outputs
  test₅ : tabulate (lookupFin tinytree) ≡ tbl
  test₅ = refl

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


module Data.Fin.NP where

open import Function
open import Data.Fin public
open import Data.Nat.NP using (ℕ; zero; suc; _<=_; module ℕ°) renaming (_+_ to _+ℕ_)
open import Data.Bool
open import Data.Sum as Sum

_+′_ : ∀ {m n} (x : Fin m) (y : Fin n) → Fin (m +ℕ n)
_+′_ {suc m} {n} zero y rewrite ℕ°.+-comm (suc m) n = inject+ _ y
suc x +′ y = suc (x +′ y)

_==_ : ∀ {n} (x y : Fin n) → Bool
x == y = helper (compare x y) where
  helper : ∀ {n} {i j : Fin n} → Ordering i j → Bool
  helper (equal _) = true
  helper _         = false

swap : ∀ {i} (x y : Fin i) → Fin i → Fin i
swap x y z = if x == z then y else if y == z then x else z

data FinSum m n : Fin (m +ℕ n) → Set where
  bound : (x : Fin m) → FinSum m n (inject+ n x)
  free  : (x : Fin n) → FinSum m n (raise m x)

open import Relation.Binary.PropositionalEquality

cmp : ∀ m n (x : Fin (m +ℕ n)) → FinSum m n x
cmp zero n x = free x
cmp (suc m) n zero = bound zero
cmp (suc m) n (suc x) with cmp m n x
cmp (suc m) n (suc .(inject+ n x)) | bound x = bound (suc x)
cmp (suc m) n (suc .(raise m x))   | free x  = free x

-- reverse x = n ∸ (1 + x)
reverse : ∀ {n} → Fin n → Fin n
reverse zero    = fromℕ _
reverse (suc x) = inject₁ (reverse x)

open import Data.Nat
open import Data.Nat.Properties
open import Data.Fin.Props renaming (reverse to reverse-old)

reverse-fromℕ : ∀ n → reverse (fromℕ n) ≡ zero
reverse-fromℕ zero = refl
reverse-fromℕ (suc n) rewrite reverse-fromℕ n = refl

reverse-inject₁ : ∀ {n} (x : Fin n) → reverse (inject₁ x) ≡ suc (reverse x)
reverse-inject₁ zero = refl
reverse-inject₁ (suc x) rewrite reverse-inject₁ x = refl

reverse-involutive : ∀ {n} (x : Fin n) → reverse (reverse x) ≡ x
reverse-involutive zero = reverse-fromℕ _
reverse-involutive (suc x) rewrite reverse-inject₁ (reverse x) | reverse-involutive x = refl

reverse-lem : ∀ {n} (x : Fin n) → toℕ (reverse x) ≡ n ∸ suc (toℕ x)
reverse-lem zero = to-from _
reverse-lem (suc x) rewrite inject₁-lemma (reverse x) = reverse-lem x

toℕ-ℕ-lem : ∀ {n} (x : Fin (suc n)) → toℕ (n ℕ- x) ≡ n ∸ toℕ x
toℕ-ℕ-lem zero = to-from _
toℕ-ℕ-lem {zero} (suc ())
toℕ-ℕ-lem {suc n} (suc x) = toℕ-ℕ-lem x

reverse-old-lem : ∀ {n} (x : Fin n) → toℕ (reverse-old x) ≡ n ∸ suc (toℕ x)
reverse-old-lem {zero} ()
reverse-old-lem {suc n} x rewrite inject≤-lemma (n ℕ- x) (n∸m≤n (toℕ x) (suc n)) = toℕ-ℕ-lem x

error: pathspec 'lib/Data/Fin/NP.agda' did not match any file(s) known to git


Add Crypto.Sig.Lamport

Add Crypto.Sig.Lamport

{-# 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
-- -}
-- -}
-- -}
-- -}

error: pathspec 'Crypto/Sig/Lamport.agda' did not match any file(s) known to git


Added test.

Added test.

Ignore-this: 4a27bd1d22f7045b1df8c402c24da53d

darcs-hash:20120531151144-3bd4e-4a67b54d15a300e09d0e40094f99c0323e4b60da.gz

------------------------------------------------------------------------------
-- Testing an instance of the class VarNames: Lam term
------------------------------------------------------------------------------

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

module Test.Succeed.FOL.VarNamesLamTerm where

-- We add 3 to the fixities of the standard library.
infixr 8 _∷_
infixr 7 _,_
infix  7 _≡_ _≈_
infixr 5 _∧_

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

postulate
  D      : Set
  _∷_    : D → D → D
  Stream : D → Set
  _≈_    : D → D → Set

data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

syntax ∃ (λ x → e) = ∃[ x ] e

data _≡_ (x : D) : D → Set where
  refl : x ≡ x

postulate
  Stream-gfp₂ : (P : D → Set) →
                -- P is post-fixed point of StreamF.
                (∀ {xs} → P xs → ∃[ x' ] ∃[ xs' ] P xs' ∧ xs ≡ x' ∷ xs') →
                -- Stream is greater than P.
                ∀ {xs} → P xs → Stream xs

postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P helper (xs , xs≈ys)
  where
  P : D → Set
  P zs = ∃[ ws ] ws ≈ zs
  {-# ATP definition P #-}

  postulate
    helper : ∀ {zs} → P zs → ∃[ z' ] ∃[ zs' ] P zs' ∧ zs ≡ z' ∷ zs'
  {-# ATP prove helper #-}

error: pathspec 'Test/Succeed/FOL/VarNamesLamTerm.agda' did not match any file(s) known to git


module Relation.Binary.Logical.Iso where

open import Type using (★_)
open import Level using () renaming (zero to ₀)
open import Data.Product.NP using (_,_)
open import Relation.Binary using (Setoid; module Setoid)
open import Function.Inverse.NP using (_$₁_;_$₂_;id;_∈_) renaming (Inverse to _≅_; module Inverse to ≅; inverses to isomorphism)
open import Function.Equality as FE using (_⟶_; _⇨_; _⟨$⟩_; cong)

module _ {a₁ a₂ aᵣ} {A₁ : Setoid a₁ aᵣ} {A₂ : Setoid a₂ aᵣ} (Aᵣ : A₁ ≅ A₂)
         {b₁ b₂ bᵣ} {B₁ : Setoid b₁ bᵣ} {B₂ : Setoid b₂ bᵣ} (Bᵣ : B₁ ≅ B₂)
         where

    private
        module A₁ˢ = Setoid A₁
        module A₂ˢ = Setoid A₂
        module B₁ˢ = Setoid B₁
        module B₂ˢ = Setoid B₂
        S = A₁ ⟶ B₁
        T = A₂ ⟶ B₂
        to : S → T
        to f = ≅.to Bᵣ FE.∘ f FE.∘ ≅.from Aᵣ
        from : T → S
        from f = ≅.from Bᵣ FE.∘ f FE.∘ ≅.to Aᵣ
        to∘from : ∀ (f : T) x → to (from f) ⟨$⟩ x B₂ˢ.≈ f ⟨$⟩ x
        to∘from f x = B₂ˢ.trans (≅.right-inverse-of Bᵣ (f ⟨$⟩ (Aᵣ $₁ (Aᵣ $₂ x)))) (cong f (≅.right-inverse-of Aᵣ x))
        from∘to : ∀ (f : S) x → from (to f) ⟨$⟩ x B₁ˢ.≈ f ⟨$⟩ x
        from∘to f x = B₁ˢ.trans (≅.left-inverse-of Bᵣ (f ⟨$⟩ (Aᵣ $₂ (Aᵣ $₁ x)))) (cong f (≅.left-inverse-of Aᵣ x))

{-
    infixr 1 _⟪→⟫_

    _⟪→⟫_ : (A₁ ⇨ B₁) ≅ (A₂ ⇨ B₂)
    _⟪→⟫_ = record { to = record { _⟨$⟩_ = to
                                 ; cong = {!!} }
                   ; from = record { _⟨$⟩_ = from
                                   ; cong = {!!} }
                   ; inverse-of = record { left-inverse-of = λ f s → {!from∘to f ? !}
                                         ; right-inverse-of = {!!} } }
-}

open import Relation.Binary.PropositionalEquality as ≡

open import Data.Two using (𝟚; 0'; 1'; not)
open import Data.Bool.Properties

𝟚ˢ : Setoid ₀ ₀
𝟚ˢ = ≡.setoid 𝟚
⟪𝟚⟫ : 𝟚ˢ ≅ 𝟚ˢ
⟪𝟚⟫ = id
⟪0'⟫ : (0' , 0') ∈ ⟪𝟚⟫
⟪0'⟫ = refl
⟪1'⟫ : (1' , 1') ∈ ⟪𝟚⟫
⟪1'⟫ = refl
--⟪not⟫' : (Δ (→-to-⟶ not)) ∈ (⟪𝟚⟫ ⟪→⟫ ⟪𝟚⟫)
--⟪not⟫' refl = refl

-- 'not' is an isomorphism on '𝟚' and so can be used as an “equality” on '𝟚'
⟪not⟫ : 𝟚ˢ ≅ 𝟚ˢ
⟪not⟫ = isomorphism not not not-involutive not-involutive

⟪0'1'⟫ : (0' , 1') ∈ ⟪not⟫
⟪0'1'⟫ = refl
⟪1'0'⟫ : (0' , 1') ∈ ⟪not⟫
⟪1'0'⟫ = refl

--⟪not⟫'' : (Δ (→-to-⟶ not)) ∈ (⟪not⟫ ⟪→⟫ ⟪not⟫)
--⟪not⟫'' refl = not-involutive _

-- since 𝟚ʳ is not reflexive it cannot be an equivalence relation and
-- thus cannot be used to build a setoid.
data 𝟚ʳ : 𝟚 → 𝟚 → ★ ₀ where
  0'1' : 𝟚ʳ 0' 1'
  1'0' : 𝟚ʳ 1' 0'

open import Data.Nat.NP using (ℕ; zero; suc; ℕˢ)
⟪ℕ⟫ : ℕˢ ≅ ℕˢ
⟪ℕ⟫ = id
⟪zero⟫ : (zero , zero) ∈ ⟪ℕ⟫
⟪zero⟫ = refl
--⟪suc⟫ : (→-to-⟶ suc , →-to-⟶ suc) ∈ (⟪ℕ⟫ ⟪→⟫ ⟪ℕ⟫)
--⟪suc⟫ refl = refl

error: pathspec 'lib/Relation/Binary/Logical/Iso.agda' did not match any file(s) known to git