For those interested: a "polynomial types" DSL in Agda.

-- A DSL example in the language Agda: "polynomial types"
module TypeDSL where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Data.Nat

data E : Set1 where
  Add   : E -> E -> E
  Mul   : E -> E -> E
  Zero  : E
  One   : E

eval : E -> Set
eval (Add x y)  = (eval x) ⊎ (eval y)
eval (Mul x y)  = (eval x) × (eval y)
eval Zero       = ⊥
eval One        = ⊤

two   = Add One One
three = Add One two

test1 : eval One
test1 = tt

false : eval two
false = inj₁ tt
true : eval two
true = inj₂ tt

test3 : eval three
test3 = inj₁ tt

card : E -> ℕ
card (Add x y)  = card x + card y
card (Mul x y)  = card x * card y
card Zero       = 0
card One        = 1

open import Data.Vec as V

variable
    m n : ℕ
    A B : Set

enumAdd : Vec A m -> Vec B n -> Vec (A ⊎ B) (m + n)
enumAdd xs ys = V.map inj₁ xs ++ V.map inj₂ ys

-- cartesianProduct
enumMul : Vec A m → Vec B n → Vec (A × B) (m * n)
enumMul xs ys = concat (V.map  (\a -> V.map  ((a ,_)) ys)  xs)

enumerate : (t : E) -> Vec (eval t) (card t)
enumerate (Add x y)  =  enumAdd  (enumerate x) (enumerate y)
enumerate (Mul x y)  =  enumMul  (enumerate x) (enumerate y)
enumerate Zero       =  []
enumerate One        =  [ tt ]

test : Vec (eval three) 3
test = enumerate three
-- inj₁ tt ∷ inj₂ (inj₁ tt) ∷ inj₂ (inj₂ tt) ∷ []

-- Exercise: add a constructor for function types to the syntax E

error: pathspec 'L/01/TypeDSL.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 (∃;Σ;_×_;_,_;first;second)
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
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; subst; ap; coe; coe!)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol
open import Control.Protocol.Additive
open import Control.Protocol.Sequence

module Control.Protocol.Multiplicative where

_⅋_ : Proto → Proto → Proto
end    ⅋ Q      = Q
recv P ⅋ Q      = recv λ m → P m ⅋ Q
P      ⅋ end    = P
P      ⅋ recv Q = recv λ m → P ⅋ Q m
send P ⅋ send Q = send [inl: (λ m → P m ⅋ send Q)
                       ,inr: (λ n → send P ⅋ Q n) ]

_⊗_ : Proto → Proto → Proto
end    ⊗ Q      = Q
send P ⊗ Q      = send λ m → P m ⊗ Q
P      ⊗ end    = P
P      ⊗ send Q = send λ m → P ⊗ Q m
recv P ⊗ recv Q = recv [inl: (λ m → P m ⊗ recv Q)
                       ,inr: (λ n → recv P ⊗ Q n) ]

module _ {{_ : FunExt}}{{_ : UA}} where
  -- absorption
  ⊤-⅋ : ∀ P → ⟦ P⊤ ⅋ P ⟧
  ⊤-⅋ P = λ()

_⊸_ : (P Q : Proto) → Proto
P ⊸ Q = dual P ⅋ Q

_o-o_ : (P Q : Proto) → Proto
P o-o Q = (P ⊸ Q) ⊗ (Q ⊸ P)

module _ {{_ : FunExt}} where
  ⊗-endR : ∀ P → P ⊗ end ≡ P
  ⊗-endR end      = refl
  ⊗-endR (recv _) = refl
  ⊗-endR (send P) = send=′ λ m → ⊗-endR (P m)

  ⅋-endR : ∀ P → P ⅋ end ≡ P
  ⅋-endR end      = refl
  ⅋-endR (send _) = refl
  ⅋-endR (recv P) = recv=′ λ m → ⅋-endR (P m)

module _ {{_ : FunExt}}{{_ : UA}} where
  ⊗-sendR : ∀ P{M}(Q : M → Proto) → ⟦ P ⊗ send Q ⟧ ≡ (Σ M λ m → ⟦ P ⊗ Q m ⟧)
  ⊗-sendR end      Q = refl
  ⊗-sendR (recv P) Q = refl
  ⊗-sendR (send P) Q = (Σ=′ _ λ m → ⊗-sendR (P m) Q) ∙ ΣΣ-comm

  ⊗-comm : ∀ P Q → ⟦ P ⊗ Q ⟧ ≡ ⟦ Q ⊗ P ⟧
  ⊗-comm end      Q        = ! ap ⟦_⟧ (⊗-endR Q)
  ⊗-comm (send P) Q        = (Σ=′ _ λ m → ⊗-comm (P m) Q) ∙ ! ⊗-sendR Q P
  ⊗-comm (recv P) end      = refl
  ⊗-comm (recv P) (send Q) = Σ=′ _ λ m → ⊗-comm (recv P) (Q m)
  ⊗-comm (recv P) (recv Q) = Π≃ ⊎-comm-equiv [inl: (λ m → ⊗-comm (P m) (recv Q))
                                              ,inr: (λ m → ⊗-comm (recv P) (Q m)) ]

  ⊗-assoc : ∀ P Q R → P ⊗ (Q ⊗ R) ≡ (P ⊗ Q) ⊗ R
  ⊗-assoc end      Q        R        = refl
  ⊗-assoc (send P) Q        R        = send=′ λ m → ⊗-assoc (P m) Q R
  ⊗-assoc (recv P) end      R        = refl
  ⊗-assoc (recv P) (send Q) R        = send=′ λ m → ⊗-assoc (recv P) (Q m) R
  ⊗-assoc (recv P) (recv Q) end      = refl
  ⊗-assoc (recv P) (recv Q) (send R) = send=′ λ m → ⊗-assoc (recv P) (recv Q) (R m)
  ⊗-assoc (recv P) (recv Q) (recv R) = recv≃ ⊎-assoc-equiv
                                            λ { (inl m)       → ⊗-assoc (P m) (recv Q) (recv R)
                                              ; (inr (inl m)) → ⊗-assoc (recv P) (Q m) (recv R)
                                              ; (inr (inr m)) → ⊗-assoc (recv P) (recv Q) (R m) }

  ⅋-recvR : ∀ P{M}(Q : M → Proto) → ⟦ P ⅋ recv Q ⟧ ≡ (Π M λ m → ⟦ P ⅋ Q m ⟧)
  ⅋-recvR end      Q = refl
  ⅋-recvR (send P) Q = refl
  ⅋-recvR (recv P) Q = (Π=′ _ λ m → ⅋-recvR (P m) Q) ∙ ΠΠ-comm

  ⅋-comm : ∀ P Q → ⟦ P ⅋ Q ⟧ ≡ ⟦ Q ⅋ P ⟧
  ⅋-comm end      Q        = ! ap ⟦_⟧ (⅋-endR Q)
  ⅋-comm (recv P) Q        = (Π=′ _ λ m → ⅋-comm (P m) Q) ∙ ! ⅋-recvR Q P
  ⅋-comm (send P) end      = refl
  ⅋-comm (send P) (recv Q) = Π=′ _ λ m → ⅋-comm (send P) (Q m)
  ⅋-comm (send P) (send Q) = Σ≃ ⊎-comm-equiv [inl: (λ m → ⅋-comm (P m) (send Q))
                                              ,inr: (λ m → ⅋-comm (send P) (Q m)) ]

  ⅋-assoc : ∀ P Q R → P ⅋ (Q ⅋ R) ≡ (P ⅋ Q) ⅋ R
  ⅋-assoc end      Q        R        = refl
  ⅋-assoc (recv P) Q        R        = recv=′ λ m → ⅋-assoc (P m) Q R
  ⅋-assoc (send P) end      R        = refl
  ⅋-assoc (send P) (recv Q) R        = recv=′ λ m → ⅋-assoc (send P) (Q m) R
  ⅋-assoc (send P) (send Q) end      = refl
  ⅋-assoc (send P) (send Q) (recv R) = recv=′ λ m → ⅋-assoc (send P) (send Q) (R m)
  ⅋-assoc (send P) (send Q) (send R) = send≃ ⊎-assoc-equiv
                                            λ { (inl m)       → ⅋-assoc (P m) (send Q) (send R)
                                              ; (inr (inl m)) → ⅋-assoc (send P) (Q m) (send R)
                                              ; (inr (inr m)) → ⅋-assoc (send P) (send Q) (R m) }

module _ {P Q R}{{_ : FunExt}} where
  dist-⊗-⊕′ : (Q ⊕ R) ⊗ P ≡ (Q ⊗ P) ⊕ (R ⊗ P)
  dist-⊗-⊕′ = send=′ [L: refl R: refl ]

  dist-⅋-&′ : (Q & R) ⅋ P ≡ (Q ⅋ P) & (R ⅋ P)
  dist-⅋-&′ = recv=′ [L: refl R: refl ]

  module _ {{_ : UA}} where
      dist-⊗-⊕ : ⟦ P ⊗ (Q ⊕ R) ⟧ ≡ ⟦ (P ⊗ Q) ⊕ (P ⊗ R) ⟧
      dist-⊗-⊕ = ⊗-comm P (Q ⊕ R)
                ∙ ap ⟦_⟧ dist-⊗-⊕′
                ∙ ⊕≡⊎
                ∙ ⊎= (⊗-comm Q P) (⊗-comm R P)
                ∙ ! ⊕≡⊎

      dist-⅋-& : ⟦ P ⅋ (Q & R) ⟧ ≡ ⟦ (P ⅋ Q) & (P ⅋ R) ⟧
      dist-⅋-& = ⅋-comm P (Q & R)
                ∙ ap ⟦_⟧ dist-⅋-&′
                ∙ &≡×
                ∙ ×= (⅋-comm Q P) (⅋-comm R P)
                ∙ ! &≡×

  -- sends can be pulled out of tensor
  source->>=-⊗ : ∀ P Q R → (source-of P >>= Q) ⊗ R ≡ source-of P >>= λ log → (Q log ⊗ R)
  source->>=-⊗ end       Q R = refl
  source->>=-⊗ (com _ P) Q R = send=′ λ m → source->>=-⊗ (P m) (Q ∘ _,_ m) R

  -- consequence[Q = const end]: ∀ P R → source-of P ⊗ R ≡ source-of P >> R

  -- recvs can be pulled out of par
  sink->>=-⅋ : ∀ P Q R → (sink-of P >>= Q) ⅋ R ≡ sink-of P >>= λ log → (Q log ⅋ R)
  sink->>=-⅋ end       Q R = refl
  sink->>=-⅋ (com _ P) Q R = recv=′ λ m → sink->>=-⅋ (P m) (Q ∘ _,_ m) R

  -- source-⅋ : source-of P ⅋ source-of Q ≡

  -- consequence[Q = const end]: ∀ P R → sink-of P ⅋ R ≡ sink-of P >> R

Log-⅋-× : ∀ {P Q} → Log (P ⅋ Q) → Log P × Log Q
Log-⅋-× {end}   {Q}      q           = end , q
Log-⅋-× {recv P}{Q}      (m , p)     = first  (_,_ m) $ Log-⅋-× {P m} {Q} p
Log-⅋-× {send P}{end}    (m , p)     = (m , p) , end
Log-⅋-× {send P}{recv Q} (m , p)     = second (_,_ m) $ Log-⅋-× {send P} {Q m} p
Log-⅋-× {send P}{send Q} (inl m , p) = first  (_,_ m) $ Log-⅋-× {P m} {send Q} p
Log-⅋-× {send P}{send Q} (inr m , p) = second (_,_ m) $ Log-⅋-× {send P} {Q m} p

module _ {{_ : FunExt}} where
  ⊗⅋-dual : ∀ P Q → dual (P ⅋ Q) ≡ dual P ⊗ dual Q
  ⊗⅋-dual end Q = refl
  ⊗⅋-dual (recv P) Q = com=′ _ λ m → ⊗⅋-dual (P m) _
  ⊗⅋-dual (send P) end = refl
  ⊗⅋-dual (send P) (recv Q) = com=′ _ λ n → ⊗⅋-dual (send P) (Q n)
  ⊗⅋-dual (send P) (send Q) = com=′ _
    [inl: (λ m → ⊗⅋-dual (P m) (send Q))
    ,inr: (λ n → ⊗⅋-dual (send P) (Q n)) ]

module _ {{_ : FunExt}}{{_ : UA}} where

  ⅋-sendR : ∀ {M}P{Q : M → Proto}(m : M) → ⟦ P ⅋ Q m ⟧ → ⟦ P ⅋ send Q ⟧
  ⅋-sendR end      m p = m , p
  ⅋-sendR (send P) m p = inr m , p
  ⅋-sendR (recv P) m p = λ x → ⅋-sendR (P x) m (p x)

  ⅋-sendL : ∀ {M}{P : M → Proto} Q (m : M) → ⟦ P m ⅋ Q ⟧ → ⟦ send P ⅋ Q ⟧
  ⅋-sendL {M} {P} Q m pq = coe (⅋-comm Q (send P)) (⅋-sendR Q m (coe (⅋-comm (P m) Q) pq))

  ⅋-id : ∀ P → ⟦ dual P ⅋ P ⟧
  ⅋-id end      = end
  ⅋-id (recv P) = λ x → ⅋-sendL (P x) x (⅋-id (P x))
  ⅋-id (send P) = λ x → ⅋-sendR (dual (P x)) x (⅋-id (P x))

  -- left-biased “strategy”
  par : ∀ P Q → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P ⅋ Q ⟧
  par (recv P) Q p       q = λ m → par (P m) Q (p m) q
  par (send P) Q (m , p) q = ⅋-sendL Q m (par (P m) Q p q)
  par end      Q end     q = q

⅋-apply : ∀ P Q → ⟦ P ⅋ Q ⟧ → ⟦ dual P ⟧ → ⟦ Q ⟧
⅋-apply end      Q        s           p       = s
⅋-apply (recv P) Q        s           (m , p) = ⅋-apply (P m) Q (s m) p
⅋-apply (send P) end      s           p       = _
⅋-apply (send P) (recv Q) s           p n     = ⅋-apply (send P) (Q n) (s n) p
⅋-apply (send P) (send Q) (inl m , s) p       = ⅋-apply (P m) (send Q) s (p m)
⅋-apply (send P) (send Q) (inr m , s) p       = m , ⅋-apply (send P) (Q m) s p

module _ {{_ : FunExt}}{{_ : UA}} where
⊗-pair : ∀ {P Q} → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P ⊗ Q ⟧
⊗-pair {end}    {Q}      p q       = q
⊗-pair {send P} {Q}      (m , p) q = m , ⊗-pair {P m} p q
⊗-pair {recv P} {end}    p end     = p
⊗-pair {recv P} {send Q} p (m , q) = m , ⊗-pair {recv P} {Q m} p q
⊗-pair {recv P} {recv Q} p q       = [inl: (λ m → ⊗-pair {P m}    {recv Q} (p m) q)
                                      ,inr: (λ n → ⊗-pair {recv P} {Q n}    p     (q n)) ]

⊗-fst : ∀ P Q → ⟦ P ⊗ Q ⟧ → ⟦ P ⟧
⊗-fst end      Q        pq       = _
⊗-fst (send P) Q        (m , pq) = m , ⊗-fst (P m) Q pq
⊗-fst (recv P) end      pq       = pq
⊗-fst (recv P) (send Q) (_ , pq) = ⊗-fst (recv P) (Q _) pq
⊗-fst (recv P) (recv Q) pq       = λ m → ⊗-fst (P m) (recv Q) (pq (inl m))

⊗-snd : ∀ P Q → ⟦ P ⊗ Q ⟧ → ⟦ Q ⟧
⊗-snd end      Q        pq       = pq
⊗-snd (send P) Q        (_ , pq) = ⊗-snd (P _) Q pq
⊗-snd (recv P) end      pq       = end
⊗-snd (recv P) (send Q) (m , pq) = m , ⊗-snd (recv P) (Q m) pq
⊗-snd (recv P) (recv Q) pq       = λ m → ⊗-snd (recv P) (Q m) (pq (inr m))

module _ {{_ : FunExt}} where
    ⊗-pair-fst : ∀ P Q (p : ⟦ P ⟧)(q : ⟦ Q ⟧) → ⊗-fst P Q (⊗-pair {P} {Q} p q) ≡ p
    ⊗-pair-fst end      Q        p q       = refl
    ⊗-pair-fst (send P) Q        (m , p) q = pair= refl (⊗-pair-fst (P m) Q p q)
    ⊗-pair-fst (recv P) end      p q       = refl
    ⊗-pair-fst (recv P) (send Q) p (m , q) = ⊗-pair-fst (recv P) (Q m) p q
    ⊗-pair-fst (recv P) (recv Q) p q       = λ= λ m → ⊗-pair-fst (P m) (recv Q) (p m) q

    ⊗-pair-snd : ∀ P Q (p : ⟦ P ⟧)(q : ⟦ Q ⟧) → ⊗-snd P Q (⊗-pair {P} {Q} p q) ≡ q
    ⊗-pair-snd end      Q        p q       = refl
    ⊗-pair-snd (send P) Q        (m , p) q = ⊗-pair-snd (P m) Q p q
    ⊗-pair-snd (recv P) end      p q       = refl
    ⊗-pair-snd (recv P) (send Q) p (m , q) = pair= refl (⊗-pair-snd (recv P) (Q m) p q)
    ⊗-pair-snd (recv P) (recv Q) p q       = λ= λ m → ⊗-pair-snd (recv P) (Q m) p (q m)

module _ P Q where
  ⊗→× : ⟦ P ⊗ Q ⟧ → ⟦ P ⟧ × ⟦ Q ⟧
  ⊗→× pq = ⊗-fst P Q pq , ⊗-snd P Q pq

  ×→⊗ : ⟦ P ⟧ × ⟦ Q ⟧ → ⟦ P ⊗ Q ⟧
  ×→⊗ (p , q) = ⊗-pair {P} {Q} p q

  module _ {{_ : FunExt}} where
    ×→⊗→× : ×→⊗ RightInverseOf ⊗→×
    ×→⊗→× = λ { (x , y) → pair×= (⊗-pair-fst P Q x y) (⊗-pair-snd P Q x y) }

    ⊗→×-has-rinv : Rinv ⊗→×
    ⊗→×-has-rinv = record { rinv = ×→⊗ ; is-rinv = ×→⊗→× }

{- WRONG
⊗→×→⊗ : (×→⊗ P Q) LeftInverseOf (⊗→× P Q)
⊗≃×   : ⟦ P ⊗ Q ⟧ ≃ ⟦ P ⟧ × ⟦ Q ⟧
⟦⊗⟧≡× : P ⟦⊗⟧ Q ≡ (⟦ P ⟧ × ⟦ Q ⟧)
-}

module _ {{_ : FunExt}}{{_ : UA}} where
    switchL' : ∀ P Q R (pq : ⟦ P ⅋ Q ⟧) (r : ⟦ R ⟧) → ⟦ P ⅋ (Q ⊗ R) ⟧
    switchL' end      Q        R        q            r       = ⊗-pair {Q} {R} q r
    switchL' (send P) end      R        p            r       = par (send P) R p r
    switchL' (send P) (send Q) R        (inl m , pq) r       = inl m , switchL' (P m) (send Q) R pq r
    switchL' (send P) (send Q) R        (inr m , pq) r       = inr m , switchL' (send P) (Q m) R pq r
    switchL' (send P) (recv Q) end      pq           r       = pq
    switchL' (send P) (recv Q) (send R) pq           (m , r) = inr m , switchL' (send P) (recv Q) (R m) pq r
    switchL' (send P) (recv Q) (recv R) pq           r       = [inl: (λ m → switchL' (send P) (Q m) (recv R) (pq m) r)
                                                                ,inr: (λ m → switchL' (send P) (recv Q) (R m) pq (r m)) ]
    switchL' (recv P) Q        R        pq           r       = λ m → switchL' (P m) Q R (pq m) r

    switchL : ∀ P Q R → ⟦ (P ⅋ Q) ⊗ R ⟧ → ⟦ P ⅋ (Q ⊗ R) ⟧
    switchL P Q R pqr = switchL' P Q R (⊗-fst (P ⅋ Q) R pqr) (⊗-snd (P ⅋ Q) R pqr)

    ⊸-apply : ∀ {P Q} → ⟦ dual P ⅋ Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
    ⊸-apply {P} {Q} pq p = ⅋-apply (dual P) Q pq (subst ⟦_⟧ (! (dual-involutive P)) p)

    o-o-apply : ∀ P Q → ⟦ P o-o Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
    o-o-apply P Q Po-oQ p = ⊸-apply {P} {Q} (⊗-fst (P ⊸ Q) (Q ⊸ P) Po-oQ) p

    o-o-comm : ∀ P Q → ⟦ P o-o Q ⟧ ≡ ⟦ Q o-o P ⟧
    o-o-comm P Q = ⊗-comm (dual P ⅋ Q) (dual Q ⅋ P)

    -- multiplicative mix (left-biased)
    mmix : ∀ P Q → ⟦ P ⊗ Q ⟧ → ⟦ P ⅋ Q ⟧
    mmix P Q pq = par P Q (⊗-fst P Q pq) (⊗-snd P Q pq)
-- -}
-- -}
-- -}

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


Add exercises for Brutal Metaintroduction to Agda

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 thesis' example.

Added thesis' example.

fatal: unable to access 'https://github.com/asr/fotc.git/': The requested URL returned error: 403


Add Crypto.Sig.Lamport.OneBit.Abstract

Add Crypto.Sig.Lamport.OneBit.Abstract

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq using (Eq?; _==_; ≡⇒==; ==⇒≡)
open import Data.Product.NP using (_×_; _,_; fst; snd; map)
open import Data.Bit using (Bit; 0b; 1b; proj′; ✓→≡; ≡→✓)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

module Crypto.Sig.Lamport.OneBit.Abstract
          (Secret : Type)
          (Digest : Type)
          (hash   : Secret → Digest)
          (eq?    : Eq? Digest)
          where

SignKey    = Secret × Secret
Signature  = Secret
VerifKey   = Digest × Digest

module signkey (sk : SignKey) where
  skL = fst sk
  skH = snd sk
  vkL = hash skL
  vkH = hash skH

-- Derive the public key by hashing each secret
verif-key : SignKey → VerifKey
verif-key sk = vkL , vkH
  where open signkey sk

module verifkey (vk : VerifKey) where
  vkL = fst vk
  vkH = snd vk

-- Key generation
key-gen : SignKey → VerifKey × SignKey
key-gen sk = vk , sk
  module key-gen where
    vk = verif-key sk

-- Sign a single bit message
sign : SignKey → Bit → Signature
sign = proj′

-- Verify the signature of a single bit message
verify : VerifKey → Bit → Signature → Bit
verify vk b sig = proj′ vk b == hash sig

verify-correct-sig : ∀ sk b → verify (verif-key sk) b (sign sk b) ≡ 1b
verify-correct-sig sk 0b = ✓→≡ (≡⇒== (hash (fst sk) ∎))
verify-correct-sig sk 1b = ✓→≡ (≡⇒== (hash (snd sk) ∎))

import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits

module Assuming-injectivity (hash-inj : Injective hash) where

  -- If one considers the hash function injective, then, so is verif-key
  verif-key-inj : ∀ {sk1 sk2} → verif-key sk1 ≡ verif-key sk2 → sk1 ≡ sk2
  verif-key-inj {sk1} {sk2} e
    = ap₂ _,_ (hash-inj (ap fst e)) (hash-inj (ap snd e))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2

  -- Therefor under this assumption, different secret keys means different public keys
  verif-key-corrolary : ∀ {sk1 sk2} → sk1 ≢ sk2 → verif-key sk1 ≢ verif-key sk2
  verif-key-corrolary {sk1} {sk2} sk≢ vk= = sk≢ (verif-key-inj vk=)

  -- If one considers the hash function injective then there is
  -- only one signing key which can sign correctly all (0 and 1)
  -- the messages
  signkey-uniqness :
        ∀ sk1 sk2 →
          (∀ b → verify (verif-key sk1) b (sign sk2 b) ≡ 1b) →
          sk1 ≡ sk2
  signkey-uniqness sk1 sk2 e
    = ap₂ _,_ (hash-inj (==⇒≡ (≡→✓ (e 0b))))
              (hash-inj (==⇒≡ (≡→✓ (e 1b))))

module Assuming-invertibility
         (unhash : Digest → Secret)
         (unhash-hash : ∀ x → unhash (hash x) ≡ x)
         (hash-unhash : ∀ x → hash (unhash x) ≡ x)
         where

  -- EXERCISES
  {-
  recover-signkey : VerifKey → SignKey
  recover-signkey = {!!}

  recover-signkey-correct : ∀ sk → recover-signkey (verif-key sk) ≡ sk
  recover-signkey-correct = {!!}

  forgesig : VerifKey → Bit → Signature
  forgesig = {!!}

  forgesig-correct : ∀ vk b → verify vk b (forgesig vk b) ≡ 1b
  forgesig-correct = {!!}
  -}

-- -}

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


Readd UNDEFINED

Readd UNDEFINED

This was deleted in 5bde6429aaee189aecc700b69ff698946d226090: undefined
is not appropriate for a complete development, but it is for a
work-in-progress (like the current one).

-- Allow holes in modules to import, by introducing a single general postulate.

module UNDEFINED where

open import Data.Unit.Core using (Hidden)
open import Data.Unit.Core public using (reveal)

postulate
  -- If this postulate would produce a T, it could be used as instance argument, triggering many ambiguities.
  -- This postulate is named in capitals because it introduces an inconsistency.
  -- Hence, this must be used through `reveal UNDEFINED`.
  UNDEFINED : ∀ {ℓ} → {T : Set ℓ} → Hidden T

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


Desc@ICFP: draft of a cleaner Hutton's aftershave

 {-# OPTIONS --type-in-type #-}

module RevisedHutton where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
data Unit  : Set where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

subst : forall {x y} -> x == y -> x -> y
subst refl x = x

cong : {A B : Set}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {A B C : Set}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

postulate
  reflFun : {A B : Set}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

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

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

data Vec (A : Set) : Nat -> Set where
   vnil : Vec A ze
   vcons : {n : Nat} -> A -> Vec A n -> Vec A (su n)

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

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

  mutual
    indI : (i : I)(x : IMu R i) -> P (i , x)
    indI i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type
  pair : Type -> Type -> Type

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

-- Fix menu:
exprFreeFixMenu : FixMenu Type
exprFreeFixMenu = ( consE nilE ,
                    \ty -> (prod (var bool) (prod (var ty) (var ty)), -- if b then t1 else t2
                           Void))

-- Index-dependent menu:
choiceFreeMenu : Type -> EnumU
choiceFreeMenu nat = consE nilE
choiceFreeMenu bool = consE nilE
choiceFreeMenu (pair x y) = nilE

choiceFreeDessert : (ty : Type) -> spi (choiceFreeMenu ty) (\ _ -> IDesc Type)
choiceFreeDessert nat = (prod (var nat) (var nat) , Void)     -- plus x y
choiceFreeDessert bool = (prod (var nat) (var nat) , Void )   -- le x y
choiceFreeDessert (pair x y) = Void

exprFreeSensitiveMenu : SensitiveMenu Type
exprFreeSensitiveMenu = ( choiceFreeMenu ,  choiceFreeDessert )

-- Tagged description of expressions
exprFree : TagIDesc Type
exprFree = exprFreeFixMenu , exprFreeSensitiveMenu

-- Free monadic expressions
exprFreeC : (Type -> Set) -> TagIDesc Type
exprFreeC X = exprFree ** X

--********************************
-- Closed terms
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool
Val (pair x y) = (Val x) * (Val y)

closeTerm : Type -> IDesc Type
closeTerm = toIDesc Type (exprFree ** Val)

--********************************
-- Closed term evaluation
--********************************

eval : {ty : Type} -> IMu closeTerm ty -> Val ty
eval {ty} term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)
              evalOneStep (pair x y) (ESu (ESu ()) , _)

--********************************
-- [Open terms]
--********************************

-- Context and context lookup
Context : Nat -> Set
Context n = Vec (Sigma Type (\ty -> IMu closeTerm ty)) n

typeAt : {n : Nat}(c : Context n) -> Fin n -> Type
typeAt {ze} c ()
typeAt {su _} (vcons x _) fze = fst x
typeAt {su _} (vcons _ xs) (fsu y) = typeAt xs y

lookup : {n : Nat}(c : Context n)(i : Fin n) -> IMu closeTerm (typeAt c i)
lookup {ze} c ()
lookup {su _} (vcons x _) fze = snd x
lookup {su _} (vcons _ xs) (fsu y) = lookup xs y

-- A variable is an index into the context *and* a proof that the
-- context contains the expected stuff
Var : {n : Nat} -> Context n -> Type -> Set
Var {n} c ty = Sigma (Fin n) (\i -> typeAt c i == ty)

-- Open term: holes are either values or variables in a context
openTerm : {n : Nat} -> Context n -> Type -> IDesc Type
openTerm c = toIDesc Type (exprFree ** (\ty -> Val ty + Var c ty))

--********************************
-- Evaluation of open terms
--********************************

-- |discharge| is the local substitution expected by |substI|. It is
-- just sugar around context lookup, taking care of transmitting the
-- proof
discharge : {n : Nat}
            {context : Context n}
            (ty : Type) ->
            (Val ty + Var context ty) ->
            IMu closeTerm ty
discharge ty (l value) = con (EZe , value)
discharge {n} {c} ty (r variable) =
    subst (cong (IMu closeTerm) (snd variable))
          (lookup c (fst variable))

-- |substExpr| is the specialized |substI| to expressions. We get it
-- generically from the free monad construction.
substExpr : {n : Nat}
            {ty : Type}
            (context : Context n)
            (sigma : (ty : Type) ->
                     (Val ty + Var context ty) ->
                     IMu closeTerm ty) ->
            IMu (openTerm context) ty ->
            IMu closeTerm ty
substExpr {n} {ty} c sig term =
    substI (\ty -> Val ty + Var c ty) Val exprFree sig ty term

-- By first doing substitution to close the term, we can use
-- evaluation of closed terms, obtaining evaluation of open terms
-- under a valid context.
evalOpen : {n : Nat}{ty : Type}
           (context : Context n) ->
           IMu (openTerm context) ty ->
           Val ty
evalOpen context tm = eval (substExpr context discharge tm)

--********************************
-- Tests
--********************************

-- V 0 :-> true, V 1 :-> 2, V 2 :-> ( false , 1 )
testContext : Context _
testContext =  vcons (bool , con (EZe , true ))
              (vcons (nat , con (EZe , su (su ze)) )
              (vcons (pair bool nat , con (EZe , ( false , su ze )))
               vnil))

-- V 1
test1 : IMu (openTerm testContext) nat
test1 = con (EZe , r ( fsu fze , refl ) )

testSubst1 : IMu closeTerm nat
testSubst1 = substExpr testContext
                       discharge
                       test1
-- = 2
testEval1 : Val nat
testEval1 = evalOpen testContext test1

-- add 1 (V 1)
test2 : IMu (openTerm testContext) nat
test2 = con (ESu (ESu EZe) , (con (EZe , l (su ze)) , con ( EZe , r (fsu fze , refl) )) )

testSubst2 : IMu closeTerm nat
testSubst2 = substExpr testContext
                        discharge
                        test2

-- = 3
testEval2 : Val nat
testEval2 = evalOpen testContext test2

-- if (V 0) then (V 1) else 0
test3 : IMu (openTerm testContext) nat
test3 = con (ESu EZe , (con (EZe , r (fze , refl)) ,
                       (con (EZe , r (fsu fze , refl)) ,
                        con (EZe , l ze))))

testSubst3 : IMu closeTerm nat
testSubst3 = substExpr testContext
                       discharge
                       test3

-- = 2
testEval3 : Val nat
testEval3 = evalOpen testContext test3

-- V 2
test4 : IMu (openTerm testContext) (pair bool nat)
test4 = con (EZe , r ( fsu (fsu fze) , refl ) )

testSubst4 : IMu closeTerm (pair bool nat)
testSubst4 = substExpr testContext
                       discharge
                       test4
-- = (false , 1)
testEval4 : Val (pair bool nat)
testEval4 = evalOpen testContext test4

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


Add FunUniverse/Nand/Function.agda

Add FunUniverse/Nand/Function.agda

open import Data.Product

module FunUniverse.Nand.Function where

module FromNand {A} (nand : A × A → A) where

    open import FunUniverse.Agda
    open import FunUniverse.Nand (Abstract𝟚.funRewiring A)

    open FromNand nand public

open import Data.Two

module Nand𝟚 = FromNand (uncurry nand)

open import Data.Tree.Binary

module NandTree {A} = FromNand {BinTree A} (uncurry fork)

error: pathspec 'FunUniverse/Nand/Function.agda' did not match any file(s) known to git


Added note on Agda parameters.

Added note on Agda parameters.

module Parameters where

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

-- Error: The type of the constructor does not fit in the sort of the
-- datatype, since Set₁ is not less or equal than Set when checking
-- the constructor [] in the declaration of List₁
--
-- data List₁ : Set → Set where
--   []  : {A : Set} → List₁ A
--   _∷_ : {A : Set} → A → List₁ A → List₁ A

data List₁ : Set → Set₁ where
  []  : {A : Set} → List₁ A
  _∷_ : {A : Set} → A → List₁ A → List₁ A

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


Add SemiRing

Add SemiRing

module SemiRingRecord where

import Algebra.FunctionProperties
  using (LeftIdentity; RightIdentity)
import Function using (_on_)
import Relation.Binary.EqReasoning as EqReasoning
import Relation.Binary.On using (isEquivalence)
import Algebra.Structures using (module IsCommutativeMonoid; IsCommutativeMonoid)
open import Relation.Binary
  using (module IsEquivalence; IsEquivalence; _Preserves₂_⟶_⟶_ ; Setoid)
open import Data.Product renaming (_,_ to _,,_) -- just to avoid clash with other commas

open import Preliminaries

open import SemiNearRingRecord

record SemiRing : Set₁ where
  field
    snr : SemiNearRing

  open SemiNearRing snr

  field
    1s : s

  open Algebra.FunctionProperties _≃s_ using (LeftIdentity; RightIdentity)

  field
    ∙-identityl : LeftIdentity 1s _∙s_
    ∙-identityr : RightIdentity 1s _∙s_

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


Testing an alternative definition of subtraction.

------------------------------------------------------------------------------
-- Testing an alternative definition of subtraction
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.SubtractionSL where

open import Data.Nat hiding ( _∸_ )
open import Relation.Binary.PropositionalEquality

-- First definition (from the standard library).
_∸₁_ : ℕ → ℕ → ℕ
m     ∸₁ zero  = m
zero  ∸₁ suc n = zero
suc m ∸₁ suc n = m ∸₁ n

-- Second definition.
_∸₂_ : ℕ → ℕ → ℕ
m     ∸₂ zero  = m
zero  ∸₂ n     = zero
suc m ∸₂ suc n = m ∸₂ n

-- Both definitions are equivalents.
thm : ∀ m n → m ∸₁ n ≡ m ∸₂ n
thm m       zero    = refl
thm zero    (suc n) = refl
thm (suc m) (suc n) = thm m n

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


Testing the use of numeric literals.

Testing the use of numeric literals.

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


added red-black tree

added red-black tree

module RedBlack where

open import Data.Nat

-- | The colour of a node.
data Color : Set where
  red   : Color
  black : Color

-- | The red black tree
data Tree  (A : Set) : ℕ       -- black height
                     → Color   -- color of the root
                     → Set
     where

  -- Empty node is always black
  empty :  Tree A 0 black

  -- Both the children of the red node are black.
  red   :  {d : ℕ}
        → Tree A d black  -- left child
        → A               -- element on the node
        → Tree A d black  -- right child
        → Tree A d red    -- The black height does not change

  -- The children can be of either color
  black : {d : ℕ} {cL cR : Color}
        → Tree A d       cL    -- left child
        → A                    -- element
        → Tree A d       cR    -- right child
        → Tree A (d + 1) black -- black height goes up by one.

-- Converts a tree with red root to a black tree. The type encodes the
-- fact that the height of the tree goes up by 1.
blacken : {A : Set} {d : ℕ}
        → Tree A d       red
        → Tree A (d + 1) black
blacken (red lt x rt) = black lt x rt

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


Rolled back a test.

Rolled back a test.

Ignore-this: 6f7b957c439302714d52ae0596db654c

darcs-hash:20110318123636-3bd4e-deb0e738289da6f28d61ad88ca1531eb846a9c49.gz

module Test.Succeed.Conjectures.LogicalConstants where

infix  5 ¬_
infixr 4 _∧_
infixr 3 _∨_
infixr 2 _⇒_
infixr 1 _↔_

------------------------------------------------------------------------------
-- Propositional logic

-- The logical connectives

-- The logical connectives are hard-coded in our implementation,
-- i.e. the following symbols must be used.
postulate
  ⊥ ⊤     : Set -- N.B. the name of the tautology symbol is "\top", not T.
  ¬_      : Set → Set -- N.B. the right hole.
  _∧_ _∨_ : Set → Set → Set
  _⇒_ _↔_ : Set → Set → Set

-- We postulate some propositional variables (which are translated as
-- 0-ary predicates).
postulate
  P Q R : Set

-- The introduction and elimination rules for the propositional
-- connectives are theorems.
postulate
  →I  : (P → Q) → P ⇒ Q
  →E  : (P ⇒ Q) → P → Q
  ∧I  : P → Q → P ∧ Q
  ∧E₁ : P ∧ Q → P
  ∧E₂ : P ∧ Q → Q
  ∨I₁ : P → P ∨ Q
  ∨I₂ : Q → P ∨ Q
  ∨E  : (P ⇒ R) → (Q ⇒ R) → P ∨ Q → R
  ⊥E  : ⊥ → P
  ¬E : (¬ P → ⊥ ) → P
{-# ATP prove →I #-}
{-# ATP prove →E #-}
{-# ATP prove ∧I #-}
{-# ATP prove ∧E₁ #-}
{-# ATP prove ∧E₂ #-}
{-# ATP prove ∨I₁ #-}
{-# ATP prove ∨I₂ #-}
{-# ATP prove ∨E #-}
{-# ATP prove ⊥E #-}
{-# ATP prove ¬E #-}

------------------------------------------------------------------------------
-- Predicate logic

-- The universe of discourse.
postulate
  D : Set

-- The quantifiers are hard-coded in our implementation, i.e. the
-- following symbols must be used.
postulate
  ∃ : (P : D → Set) → Set
  ⋀ : (P : D → Set) → Set

-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
postulate
  ∀I : ((x : D) → P¹ x) → ⋀ P¹
  ∀E : ⋀ P¹ → (t : D) → P¹ t
  -- This elimination rule cannot prove in Coq because in Coq we can
  -- have empty domains. We do not have this problem because the ATPs
  -- assume a non-empty domain.
  ∃I : ((t : D) → P¹ t) → ∃ P¹
  -- TODO: ∃E : (x : D) → ∃ P¹ → (P¹ x → Q¹ x) → Q¹ x
{-# ATP prove ∀I #-}
{-# ATP prove ∀E #-}
{-# ATP prove ∃I #-}
-- {-# ATP prove ∃E #-}

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


Added a draft about bisimilarity and streams via postulates

Ignore-this: bbdcec20cf94f65036bec7d31faf95a4

darcs-hash:20101021034205-3bd4e-3ea18ecd84a8600bbedc524ad0de6b3577ad5a0e.gz

------------------------------------------------------------------------------
-- Testing the bisimilar relation with streams via postulates
------------------------------------------------------------------------------

module Draft.Bisimilarity.Stream.Postulates where

open import LTC.Minimal
open import LTC.MinimalER using ( subst )

import Lib.Relation.Binary.EqReasoning
open module Postulates-ER =
  Lib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

open import LTC.Minimal.Properties using ( ∷-injective ; ≡-stream )

open import LTC.Data.Stream.Bisimulation hiding ( -≈-≡ )

------------------------------------------------------------------------
-- The LTC stream type.

postulate
  Stream   : D → Set
  consS    : (x : D){xs : D} → Stream xs → Stream (x ∷ xs)
  invConsS : (x : D){xs : D} → Stream (x ∷ xs) → Stream xs

------------------------------------------------------------------------
-- The bisimilar and the equality relation.
-≈-≡ : {xs ys : D} → Stream xs → Stream ys → xs ≈ ys → xs ≡ ys
-≈-≡ {xs} {ys} Sxs Sys xs≈ys =
  begin
    xs       ≡⟨ xs≡x'∷xs' ⟩
    x' ∷ xs' ≡⟨ ≡-stream x'≡y' (-≈-≡ Sxs' Sys' xs'≈ys') ⟩
    y' ∷ ys' ≡⟨ sym ys≡y'∷ys' ⟩
    ys
  ∎

  where
    aux : BIS _≈_ xs ys
    aux = ≈-GFP-eq₁ xs≈ys

    x' : D
    x' = ∃D-proj₁ aux

    y' : D
    y' = ∃D-proj₁ (∃D-proj₂ aux)

    xs' : D
    xs' = ∃D-proj₁ (∃D-proj₂ (∃D-proj₂ aux))

    ys' : D
    ys' = ∃D-proj₁ (∃D-proj₂ (∃D-proj₂ (∃D-proj₂ aux)))

    x'≡y' : x' ≡ y'
    x'≡y' = ∧-proj₁ (∃D-proj₂
                    (∃D-proj₂
                    (∃D-proj₂
                    (∃D-proj₂ aux))))

    xs'≈ys' : xs' ≈ ys'
    xs'≈ys' = ∧-proj₁ (∧-proj₂ (∃D-proj₂
                               (∃D-proj₂
                               (∃D-proj₂
                               (∃D-proj₂ aux)))))

    xs≡x'∷xs' : xs ≡ x' ∷ xs'
    xs≡x'∷xs' =
      ∧-proj₁ (∧-proj₂ (∧-proj₂ (∃D-proj₂
                                (∃D-proj₂
                                (∃D-proj₂
                                (∃D-proj₂ aux))))))

    ys≡y'∷ys' : ys ≡ y' ∷ ys'
    ys≡y'∷ys' =
      ∧-proj₂ (∧-proj₂ (∧-proj₂ (∃D-proj₂
                                (∃D-proj₂
                                (∃D-proj₂
                                (∃D-proj₂ aux))))))

    Sxs' : Stream xs'
    Sxs' = invConsS x' (subst (λ t → Stream t) xs≡x'∷xs' Sxs)

    Sys' : Stream ys'
    Sys' = invConsS y' (subst (λ t → Stream t) ys≡y'∷ys' Sys)

error: pathspec 'Draft/Bisimilarity/Stream/Postulates.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/'


natural numbers added⎈

natural numbers added⎈

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

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


Added thesis' example.

Added thesis' example.

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

module CombinedProofs.CommAddGlobalHints where

open import PA.Axiomatic.Standard.Base

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity = PA₃

+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity = PA-ind A A0 is
  where
  A : M → Set
  A i = i + zero ≡ i
  {-# ATP definition A #-}

  A0 : A zero
  A0 = +-leftIdentity zero

  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is #-}

x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)
x+Sy≡S[x+y] m n = PA-ind A A0 is m
  where
  A : M → Set
  A i = i + succ n ≡ succ (i + n)
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 #-}

  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is #-}

-- Global hints
{-# ATP hint x+Sy≡S[x+y] +-rightIdentity #-}

+-comm : ∀ m n → m + n ≡ n + m
+-comm m n = PA-ind A A0 is m
  where
  A : M → Set
  A i = i + n ≡ n + i
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 #-}

  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is #-}

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


isos-examples.agda

isos-examples.agda

module isos-examples where

open import Function
import Function.Inverse as FI
open FI using (_↔_)
open import Type hiding (★)
open import Data.Product
open import Data.Bool
open import Data.Bits
open import Relation.Binary

_≈₂_ : ∀ {a} {A : ★ a} (f g : A → Bit) → ★ _
_≈₂_ {A = A} f g = Σ A (T ∘ f) ↔ Σ A (T ∘ g)

module _ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} where
  _≈_ : (f : A → C) (g : B → C) → ★ _
  f ≈ g = ∀ (O : C → ★ c) →
            (B × Σ A (O ∘ f)) ↔ (A × Σ B (O ∘ g))

module _ {a c} {A : ★ a} {C : ★ c} where
  ≈-refl : Reflexive {A = A → C} _≈_
  ≈-refl _ = FI.id

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


pisearch.agda

pisearch.agda

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


Unfinished VectorSpace module

Unfinished VectorSpace module

{-# OPTIONS --without-K #-}

open import Level.NP
open import Function.Extensionality
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Group
open import Algebra.Group.Homomorphism
open import Algebra.Field
open import Relation.Binary.PropositionalEquality.NP

module Algebra.VectorSpace {{_ : FunExt}} where

record VectorSpace {ℓf}{F : Set ℓf}(𝔽 : Field F)
                   {ℓv}(V : Set ℓv) : Set (ℓf ⊔ ℓv) where

  module 𝔽 = Field {ℓf} {F} 𝔽

  field

    V-grp : Group V

    _·_   : F → V → V

{-
    _·_ : (F × V) → V
    _·_ : F → (V → V)
    _·_ : F → Endo V
-}

    ·-+ : MonoidHomomorphism 𝔽.+-mon (Pointwise′.mon V (Group.mon V-grp)) _·_
    ·-* : MonoidHomomorphism 𝔽.*-mon (∘-mon V) _·_

  open 𝔽
  open Additive-Group V-grp using () renaming (_+_ to _⊕_)

  module Alternative
    (·-+ : ∀ v → GroupHomomorphism 𝔽.+-grp V-grp (λ a → a · v))
    where
    ·-+' : ∀ {v a b} → (a + b) · v ≡ a · v ⊕ b · v
    ·-+' = GroupHomomorphism.hom (·-+ _)

  ·-+' : ∀ {v a b} → (a + b) · v ≡ a · v ⊕ b · v
  ·-+' {v} = ap (λ f → f v) (MonoidHomomorphism.+-hom-* ·-+)

  ·-*' : ∀ {v a b} → (a * b) · v ≡ a · (b · v)
  ·-*' {v} = ap (λ f → f v) (MonoidHomomorphism.+-hom-* ·-*)
  {-
  _·_(a * b) ≡ _·_(a) ∘ _·_(b)
  ∀ v → _·_(a * b) v ≡ (_·_(a) ∘ _·_(b)) v
  ∀ v → (a * b) · v ≡ a · (b · v)
  -}

  ·-1 : ∀ {v} → 1# · v ≡ v
  ·-1 {v} = ap (λ f → f v) (MonoidHomomorphism.0-hom-1 ·-*)
  {-
  _·_ 1# ≡ id
  ∀ v → _·_ 1# v ≡ id v
  ∀ v → 1# · v ≡ v
  -}

  ·-⊕ : ∀ {v w a} → a · (v ⊕ w) ≡ a · v ⊕ a · w
  ·-⊕ {v} {w} {a} = {!!}
  {-
  _·_(a + b) ≡ _·_(a) ∘ _·_(b)
  ∀ v → _·_(a + b) v ≡ (_·_(a) ∘ _·_(b)) v
  ∀ v → (a + b) · v ≡ a · (b · v)
  -}

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


languages/test.agda

languages/test.agda

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/sharkspeed/dororis.git/'


Added Agsy test on distributive laws.

Added Agsy test on distributive laws.

Ignore-this: 764a5b06812ad55cc3c070f1357ab83a

darcs-hash:20101213173849-3bd4e-0478a0141552920f27964e67c8cb72fd2013df15.gz

------------------------------------------------------------------------------
-- Asgy test on distributive laws on a binary operation
------------------------------------------------------------------------------

module DistributiveLaws where

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

-- We add 3 to the fixities of the standard library.
infixl 10 _∙_

------------------------------------------------------------------------------
-- Distributive laws axioms

postulate
  D   : Set        -- The universe
  _∙_ : D → D → D  -- The binary operation.

  leftDistributive  : ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
  rightDistributive : ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z)

-- Properties

Stanovsky1 : ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
                        (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
                        x ∙ z ∙ (y ∙ u)
Stanovsky1 u x y z = {!-t 20 -m!}  -- Agsy fails

Stanovsky : ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
                        (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
                        x ∙ z ∙ (y ∙ u)
Stanovsky u x y z =
-- The numbering of the justifications correspond to the numbers of
-- the proof using only equational reasoning (see
-- DistributiveLaws.Interactive.Properties).
  begin
    xy∙zu ∙ (xy∙zu ∙ xz∙yu)                                         ≡⟨ j₁ ⟩

    xy∙zu ∙ (xz ∙ xu∙yu ∙ (y∙zu ∙ xz∙yu))                           ≡⟨ j₅ ⟩

    xy∙zu ∙ (xz ∙ xyu ∙ (yxz ∙ yu))                                 ≡⟨ j₉ ⟩

    xz ∙ xyu ∙ (yz ∙ xyu) ∙ (xz ∙ xyu ∙ (y∙xu ∙ z∙yu))              ≡⟨ j₁₄ ⟩

    xz ∙ xyu ∙ (y∙xu ∙ (y∙yu ∙ z∙yu) ∙ (z ∙ xu∙yu ∙ (y∙xu ∙ z∙yu))) ≡⟨ j₂₀ ⟩

    xz ∙ xyu ∙ (y ∙ xu∙zu ∙ (z ∙ xu∙yu ∙ (y∙xu ∙ z∙yu)))            ≡⟨ j₂₃ ⟩

    (xz ∙ xyu) ∙ (y ∙ xu∙zu ∙ (z∙xu ∙ y∙xu ∙ z∙yu))                 ≡⟨ j₂₅ ⟩

    xz ∙ xyu ∙ (y∙zy ∙ xzu)                                         ≡⟨ j₃₀ ⟩

    xz∙yu
  ∎
  where
    -- Two variables abbreviations

    xz = x ∙ z
    yu = y ∙ u
    yz = y ∙ z

    -- Three variables abbreviations

    xyu = x ∙ y ∙ u
    xyz = x ∙ y ∙ z
    xzu = x ∙ z ∙ u
    yxz = y ∙ x ∙ z

    y∙xu = y ∙ (x ∙ u)
    y∙yu = y ∙ (y ∙ u)
    y∙zu = y ∙ (z ∙ u)
    y∙zy = y ∙ (z ∙ y)

    z∙xu = z ∙ (x ∙ u)
    z∙yu = z ∙ (y ∙ u)

    -- Four variables abbreviations

    xu∙yu = x ∙ u ∙ (y ∙ u)
    xu∙zu = x ∙ u ∙ (z ∙ u)

    xy∙zu = x ∙ y ∙ (z ∙ u)

    xz∙yu = x ∙ z ∙ (y ∙ u)

    -- Steps justifications

    j₁ : xy∙zu ∙ (xy∙zu ∙ xz∙yu) ≡
         xy∙zu ∙ (xz ∙ xu∙yu ∙ (y∙zu ∙ xz∙yu))
    j₁ = {!-t 20 -m !}  -- Agsy fails

    j₅ : xy∙zu ∙ (xz ∙ xu∙yu ∙ (y∙zu ∙ xz∙yu)) ≡
         xy∙zu ∙ (xz ∙ xyu ∙ (yxz ∙ yu))
    j₅ = {!-t 20 -m !}  -- Agsy fails

    j₉ : xy∙zu ∙ (xz ∙ xyu ∙ (yxz ∙ yu)) ≡
         xz ∙ xyu ∙ (yz ∙ xyu) ∙ (xz ∙ xyu ∙ (y∙xu ∙ z∙yu))
    j₉ = {!-t 20 -m!}  -- Agsy fails

    j₁₄ : xz ∙ xyu ∙ (yz ∙ xyu) ∙ (xz ∙ xyu ∙ (y∙xu ∙ z∙yu)) ≡
          xz ∙ xyu ∙ (y∙xu ∙ (y∙yu ∙ z∙yu) ∙ (z ∙ xu∙yu ∙ (y∙xu ∙ z∙yu)))
    j₁₄ = {!-t 20 -m!}  -- Agsy fails

    j₂₀ : xz ∙ xyu ∙ (y∙xu ∙ (y∙yu ∙ z∙yu) ∙ (z ∙ xu∙yu ∙ (y∙xu ∙ z∙yu))) ≡
          xz ∙ xyu ∙ (y ∙ xu∙zu ∙ (z ∙ xu∙yu ∙ (y∙xu ∙ z∙yu)))
    j₂₀ = {!-t 20 -m!}  -- Agsy fails

    j₂₃ : xz ∙ xyu ∙ (y ∙ xu∙zu ∙ (z ∙ xu∙yu ∙ (y∙xu ∙ z∙yu))) ≡
          (xz ∙ xyu) ∙ (y ∙ xu∙zu ∙ (z∙xu ∙ y∙xu ∙ z∙yu))
    j₂₃ = {!-t 20 -m!}  -- Agsy fails

    j₂₅ : (xz ∙ xyu) ∙ (y ∙ xu∙zu ∙ (z∙xu ∙ y∙xu ∙ z∙yu)) ≡
          xz ∙ xyu ∙ (y∙zy ∙ xzu)

    j₂₅ = {!-t 20 -m!}  -- Agsy fails

    j₃₀ : xz ∙ xyu ∙ (y∙zy ∙ xzu) ≡
          xz∙yu
    j₃₀ = {!-t 20 -m!}  -- Agsy fails

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


Added incomple draft.

Added incomple draft.

Ignore-this: 914ebd400ea224ce249e5dd8bc1e7e63

darcs-hash:20120319121849-3bd4e-e2a2f7cab1269de8886051af48d637d604382a2c.gz

------------------------------------------------------------------------------
-- Reasoning about a function without a termination proof
------------------------------------------------------------------------------

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

-- Tested with the development version of the standard library on
-- 19 March 2012.

module Draft.FOTC.Program.Collatz.CollatzSL where

open import Data.Bool
open import Data.Empty
open import Data.Nat renaming ( suc to succ )
open import Data.Product
open import Data.Sum
open import Relation.Binary.PropositionalEquality hiding ( [_] )
open import Relation.Nullary

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

_^_ : ℕ → ℕ → ℕ
n ^ zero   = 1
m ^ succ n = m * (m ^ n)

isEven : ℕ → Bool
isEven 0 = true
isEven 1 = false
isEven (succ (succ n)) = isEven n

{-# NO_TERMINATION_CHECK #-}
collatz : ℕ → ℕ
collatz zero       = 1
collatz (succ zero) = 1
collatz n with isEven n
... | true = collatz ⌊ n /2⌋
... | false = collatz (3 * n + 1)

xy≡0→x≡0∨y≡0 : (m n : ℕ) → m * n ≡ zero → m ≡ zero ⊎ n ≡ zero
xy≡0→x≡0∨y≡0 zero n h = inj₁ refl
xy≡0→x≡0∨y≡0 (succ m) zero h = inj₂ refl
xy≡0→x≡0∨y≡0 (succ m) (succ n) ()

+∸2 : ∀ {n} → ¬ (n ≡ zero) → ¬ (n ≡ 1) → n ≡ succ (succ (n ∸ 2))
+∸2 {zero} 0≢0 _ = ⊥-elim (0≢0 refl)
+∸2 {succ zero} _ 1≢1 = ⊥-elim (1≢1 refl)
+∸2 {succ (succ n)} _ _ = refl

2^x≢0 : (n : ℕ) → ¬ (2 ^ n ≡ zero)
2^x≢0 zero ()
2^x≢0 (succ n) h = [ (λ ())
                   , (λ 2^n≡0 → ⊥-elim (2^x≢0 n 2^n≡0))
                   ]′ (xy≡0→x≡0∨y≡0 2 (2 ^ n) h)

2^[x+1]/2≡2^x : ∀ n → ⌊ 2 ^ succ n /2⌋ ≡ 2 ^ n
2^[x+1]/2≡2^x zero = refl
2^[x+1]/2≡2^x (succ zero) = refl
2^[x+1]/2≡2^x (succ (succ n)) = {!!}

collatz-2^x : ∀ n → Σ ℕ (λ k → n ≡ 2 ^ k) → collatz n ≡ 1
collatz-2^x zero h = refl
collatz-2^x (succ n) (zero , proj₂)   = subst (λ t → collatz t ≡ 1) (sym proj₂) refl
collatz-2^x (succ n) (succ k , proj₂) = subst (λ t → collatz t ≡ 1) (sym proj₂) {!!}

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


Playing around with powersets.

Playing around with powersets.

module powerset where

open import level
open import list
open import bool
open import product
open import empty
open import unit
open import sum
open import eq
open import functions renaming (id to id-set) public

-- Extensionality will be used when proving equivalences of morphisms.
postulate ext-set : ∀{l1 l2 : level} → extensionality {l1} {l2}
-- These are isomorphisms, but Agda has no way to prove these as
-- equivalences.  They are consistent to adopt as equivalences by
-- univalence:
postulate ⊎-unit-r : ∀{X : Set} → (X ⊎ ⊥) ≡ X
postulate ⊎-unit-l : ∀{X : Set} → (⊥ ⊎ X) ≡ X
postulate ∧-unit : ∀{ℓ}{A : Set ℓ} → A ≡ ((⊤ {ℓ}) ∧ A)
postulate ∧-sym : ∀{ℓ}{A B : Set ℓ} → (A ∧ B) ≡ (B ∧ A)
postulate ∧-unit-r : ∀{ℓ}{A : Set ℓ} → A ≡ (A ∧ (⊤ {ℓ}))
postulate ∧-assoc : ∀{ℓ}{A B C : Set ℓ} →  (A ∧ (B ∧ C)) ≡ ((A ∧ B) ∧ C)

ℙ : Set → Set₁
ℙ X = X → Set

ℙₐ : {X Y : Set} → (X → Y) → ℙ Y → ℙ X
ℙₐ f s x = s (f x)

_∪_ : {X : Set} → ℙ X → ℙ X → ℙ X
(s₁ ∪ s₂) x = (s₁ x) ⊎ (s₂ x)

_∩_ : {X : Set} → ℙ X → ℙ X → ℙ X
(s₁ ∩ s₂) x = (s₁ x) × (s₂ x)

¬_ : {X : Set} → ℙ X → ℙ X
(¬ s₁) x = (s₁ x) → ⊥

∅ : {X : Set} → ℙ X
∅ _ = ⊥

carrier : {X : Set} → ℙ X
carrier _ = ⊤

∪-unit₁ : ∀{X : Set}{s : ℙ X} → s ∪ ∅ ≡ s
∪-unit₁ {X}{s} = ext-set aux
 where
  aux : {a : X} → (s a ⊎ ⊥) ≡ s a
  aux {x} = ⊎-unit-r {s x}

∪-unit₂ : ∀{X : Set}{s : ℙ X} → ∅ ∪ s ≡ s
∪-unit₂ {X}{s} = ext-set aux
 where
   aux : {a : X} → (⊥ ⊎ s a) ≡ s a
   aux {x} = ⊎-unit-l

∩-unit₁ : ∀{X : Set}{s : ℙ X} → s ∩ carrier ≡ s
∩-unit₁ {X}{s} = ext-set aux
 where
   aux : {a : X} → Σ (s a) (λ x → ⊤) ≡ s a
   aux {x} = sym (∧-unit-r {_}{s x})

∩-unit₂ : ∀{X : Set}{s : ℙ X} → carrier ∩ s ≡ s
∩-unit₂ {X}{s} = ext-set aux
 where
   aux : {a : X} → Σ ⊤ (λ x → s a) ≡ s a
   aux {x} = sym (∧-unit {_}{s x})

i₁ : {X Y : Set} → ℙ X → ℙ (X × Y)
i₁ = ℙₐ fst

i₂ : {X Y : Set} → ℙ Y → ℙ (X × Y)
i₂ = ℙₐ snd

cp-ar : {X Y Z : Set} → (Z → X) → (Z → Y) → ℙ (X × Y) → ℙ Z
cp-ar f g = ℙₐ (trans-× f g)

cp-diag₁ : {X Y Z : Set}{f : Z → X}{g : Z → Y} → cp-ar f g ∘ i₁ ≡ ℙₐ f
cp-diag₁ {X}{Y}{Z}{f}{g} = refl

cp-diag₂ : {X Y Z : Set}{f : Z → X}{g : Z → Y} → cp-ar f g ∘ i₂ ≡ ℙₐ g
cp-diag₂ {X}{Y}{Z}{f}{g} = refl

co-curry : {A B C : Set} → ((A × B) → C) → ℙ (B → C) → ℙ A
co-curry {A}{B}{C} f = ℙₐ {A}{B → C} (curry f)

co-uncurry : {A B C : Set} → (A → B → C) → ℙ C → ℙ (A × B)
co-uncurry {A}{B}{C} f = ℙₐ {A × B} {C} (uncurry f)

liftℙ : {A B : Set} → (A → ℙ B) → ℙ A → ℙ B
liftℙ {A} f s b = ∀(a : A) → (s a) × (f a b)

error: pathspec 'power-set-algebra/powerset.agda' did not match any file(s) known to git


Comments

Comments

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 test.

Added test.

Ignore-this: 8285ded7fae8d2e4f0a41678130fd2b

darcs-hash:20120531154627-3bd4e-4b2d7d451f2079aca2ed50457b493d389f18f81d.gz

------------------------------------------------------------------------------
-- Testing the function FOL.Translation.Terms.termToFOLTerm : Con term
------------------------------------------------------------------------------

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

module Test.Succeed.FOL.TermToFOLTerm.ConTerm where

-- We add 3 to the fixities of the standard library.
infixl 9 _+_
infix  7 _≡_

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

data M : Set where
  zero :     M
  succ : M → M

data _≡_ (m : M) : M → Set where
  refl : m ≡ m

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

_+_ : M → M → M
zero   + n = n
succ m + n = succ (m + n)

+-Sx : ∀ m n → succ m + n ≡ succ (m + n)
+-Sx m n = refl
{-# ATP hint +-Sx #-}

postulate
  +-rightIdentity : ∀ n → n + zero ≡ n
  x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero     n = sym (+-rightIdentity n)
+-comm (succ m) n = prf (+-comm m n)
  where
  postulate prf : m + n ≡ n + m →  -- IH.
                  succ m + n ≡ n + succ m
  {-# ATP prove prf x+Sy≡S[x+y] #-}

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


Add Control.Process.Type

Add Control.Process.Type

{-
  On the one hand this module has nothing to do with JS, on the other
  hand our JS binding relies on this particular type definition.
-}
module Control.Process.Type where

open import Data.String.Base using (String)

data Proc (C {-channels-} : Set₀) (M {-messages-} : Set₀) : Set₀ where
  end   : Proc C M
  send  : (d : C) (m : M) (p : Proc C M) → Proc C M
  recv  : (d : C) (p : M → Proc C M) → Proc C M
  spawn : (p : C → Proc C M)
          (q : C → Proc C M) → Proc C M
  error : (err : String) → Proc C M

error: pathspec 'lib/Control/Process/Type.agda' did not match any file(s) known to git


clean import

clean import


clean

clean


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


thrms about ~ and \~

thrms about ~ and \~

open import Nat
open import Prelude

module core where
  -- types
  data τ̇ : Set where
    num   : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇
    _⊕_   : τ̇ → τ̇ → τ̇
    _⊗_   : τ̇ → τ̇ → τ̇

  -- expressions, prefixed with a · to distinguish name clashes with agda
  -- built-ins
  data ė : Set where
    _·:_   : ė → τ̇ → ė
    X      : Nat → ė
    ·λ     : Nat → ė → ė
    N      : Nat → ė
    _·+_   : ė → ė → ė
    ⦇⦈[_]  : Nat → ė
    ⦇_⦈[_] : ė → Nat → ė
    _∘_    : ė → ė → ė
    inl    : ė → ė
    inr    : ė → ė
    case   : ė → Nat → ė → Nat → ė → ė
    [_,_]  : ė → ė → ė
    fst    : ė → ė
    snd    : ė → ė

  data subst : Set where -- todo

  data ë : Set where
    X        : Nat → ë
    ·λ       : Nat → ë → ë
    N        : Nat → ë
    _·+_     : ë → ë → ë
    ⦇⦈[_,_]  : Nat → subst → ë
    ⦇_⦈[_,_] : ë → Nat → subst → ë
    _∘_      : ë → ë → ë
    inl      : ë → ë
    inr      : ë → ë
    case     : ë → Nat → ë → Nat → ë → ë
    [_,_]    : ë → ë → ë
    fst      : ë → ë
    snd      : ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               (t1 ==> t2) ~ (t1' ==> t2')
    TCSum : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               (t1 ⊕ t2) ~ (t1' ⊕ t2')
    TCPro : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               (t1 ⊗ t2) ~ (t1' ⊗ t2')

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICNumArr1 : {t1 t2 : τ̇} → num ~̸ (t1 ==> t2)
    ICNumArr2 : {t1 t2 : τ̇} → (t1 ==> t2) ~̸ num
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               (t1 ==> t2) ~̸ (t3 ==> t4)
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               (t1 ==> t2) ~̸ (t3 ==> t4)

    ICNumSum1 : {t1 t2 : τ̇} → num ~̸ (t1 ⊕ t2)
    ICNumSum2 : {t1 t2 : τ̇} → (t1 ⊕ t2) ~̸ num
    ICSum1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               (t1 ⊕ t2) ~̸ (t3 ⊕ t4)
    ICSum2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               (t1 ⊕ t2) ~̸ (t3 ⊕ t4)
    ICSumArr1 : {t1 t2 t3 t4 : τ̇} → (t1 ⊕ t2) ~̸ (t3 ==> t4)
    ICSumArr2 : {t1 t2 t3 t4 : τ̇} → (t1 ==> t2) ~̸ (t3 ⊕ t4)

    ICNumPro1 : {t1 t2 : τ̇} → num ~̸ (t1 ⊗ t2)
    ICNumPro2 : {t1 t2 : τ̇} → (t1 ⊗ t2) ~̸ num
    ICPro1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               (t1 ⊗ t2) ~̸ (t3 ⊗ t4)
    ICPro2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               (t1 ⊗ t2) ~̸ (t3 ⊗ t4)
    ICProArr1 : {t1 t2 t3 t4 : τ̇} → (t1 ⊗ t2) ~̸ (t3 ==> t4)
    ICProArr2 : {t1 t2 t3 t4 : τ̇} → (t1 ==> t2) ~̸ (t3 ⊗ t4)

    ICProSum1 : {t1 t2 t3 t4 : τ̇} → (t1 ⊗ t2) ~̸ (t3 ⊕ t4)
    ICProSum2 : {t1 t2 t3 t4 : τ̇} → (t1 ⊕ t2) ~̸ (t3 ⊗ t4)

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr (⦇⦈ ==> ⦇⦈)
    MAArr  : {t1 t2 : τ̇} → (t1 ==> t2) ▸arr (t1 ==> t2)

  data _▸sum_ : τ̇ → τ̇ → Set where
    MSHole  : ⦇⦈ ▸sum (⦇⦈ ⊕ ⦇⦈)
    MSPlus  : {t1 t2 : τ̇} → (t1 ⊕ t2) ▸sum (t1 ⊕ t2)

  data _▸pro_ : τ̇ → τ̇ → Set where
    MPHole  : ⦇⦈ ▸pro (⦇⦈ ⊗ ⦇⦈)
    MPPlus  : {t1 t2 : τ̇} → (t1 ⊗ t2) ▸pro (t1 ⊗ t2)

  -- matching produces unique answers for arrows, sums, and products
  ▸arr-unicity : ∀{ t t2 t3 } →
                 t ▸arr t2 →
                 t ▸arr t3 →
                 t2 == t3
  ▸arr-unicity MAHole MAHole = refl
  ▸arr-unicity MAArr MAArr = refl

  ▸sum-unicity : ∀{ t t2 t3 } →
                 t ▸sum t2 →
                 t ▸sum t3 →
                 t2 == t3
  ▸sum-unicity MSHole MSHole = refl
  ▸sum-unicity MSPlus MSPlus = refl

  ▸pro-unicity : ∀{ t t2 t3 } →
                 t ▸pro t2 →
                 t ▸pro t3 →
                 t2 == t3
  ▸pro-unicity MPHole MPHole = refl
  ▸pro-unicity MPPlus MPPlus = refl

  -- if an arrow matches, then it's consistent with the least restrictive
  -- function type
  matchconsist : ∀{t t'} →
                 t ▸arr t' →
                 t ~ (⦇⦈ ==> ⦇⦈)
  matchconsist MAHole = TCHole2
  matchconsist MAArr = TCArr TCHole1 TCHole1

  matchnotnum : ∀{t1 t2} → num ▸arr (t1 ==> t2) → ⊥
  matchnotnum ()

  ---- contexts and some operations on them

  -- variables are named with naturals in ė. therefore we represent
  -- contexts as functions from names for variables (nats) to possible
  -- bindings.
  ·ctx : Set
  ·ctx = Nat → Maybe τ̇

  -- convenient shorthand for the (unique up to fun. ext.) empty context
  ∅ : ·ctx
  ∅ _ = None

  -- add a new binding to the context, clobbering anything that might have
  -- been there before.
  _,,_ : ·ctx → (Nat × τ̇) → ·ctx
  (Γ ,, (x , t)) y with natEQ x y
  (Γ ,, (x , t)) .x | Inl refl = Some t
  (Γ ,, (x , t)) y  | Inr neq  = Γ y

  -- membership, or presence, in a context
  _∈_ : (p : Nat × τ̇) → (Γ : ·ctx) → Set
  (x , t) ∈ Γ = (Γ x) == Some t

  -- apartness for contexts, so that we can follow barendregt's convention
  _#_ : (n : Nat) → (Γ : ·ctx) → Set
  x # Γ = (Γ x) == None

  -- without: remove a variable from a context
  _/_ : ·ctx → Nat → ·ctx
  (Γ / x) y with natEQ x y
  (Γ / x) .x | Inl refl = None
  (Γ / x) y  | Inr neq  = Γ y

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : ·ctx) → (e : ė) → (t : τ̇) → Set where
      SAsc    : {Γ : ·ctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : ·ctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : ·ctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr (t2 ==> t') →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SNum    :  {Γ : ·ctx} {n : Nat} →
                 Γ ⊢ N n => num
      SPlus   : {Γ : ·ctx} {e1 e2 : ė}  →
                 Γ ⊢ e1 <= num →
                 Γ ⊢ e2 <= num →
                 Γ ⊢ (e1 ·+ e2) => num
      SEHole  : {Γ : ·ctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : ·ctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈

    --todo: add rules for products

    -- analysis
    data _⊢_<=_ : (Γ : ·ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : ·ctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : ·ctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr (t1 ==> t2) →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t
      AInl : {Γ : ·ctx} {e : ė} {t+ t1 t2 : τ̇} →
                 t+ ▸sum (t1 ⊕ t2) →
                 Γ ⊢ e <= t1 →
                 Γ ⊢ inl e <= t+
      AInr : {Γ : ·ctx} {e : ė} {t+ t1 t2 : τ̇} →
                 t+ ▸sum (t1 ⊕ t2) →
                 Γ ⊢ e <= t2 →
                 Γ ⊢ inr e <= t+
      ACase : {Γ : ·ctx} {e e1 e2 : ė} {t t+ t1 t2 : τ̇} {x y : Nat} →
                 x # Γ →
                 y # Γ →
                 t+ ▸sum (t1 ⊕ t2) →
                 Γ ⊢ e => t+ →
                 (Γ ,, (x , t1)) ⊢ e1 <= t →
                 (Γ ,, (y , t2)) ⊢ e2 <= t →
                 Γ ⊢ case e x e1 y e2 <= t

  ----- some theorems about the rules and judgement presented so far.

  -- a variable is apart from any context from which it is removed
  aar : (Γ : ·ctx) (x : Nat) → x # (Γ / x)
  aar Γ x with natEQ x x
  aar Γ x | Inl refl = refl
  aar Γ x | Inr x≠x  = abort (x≠x refl)

  -- contexts give at most one binding for each variable
  ctxunicity : {Γ : ·ctx} {n : Nat} {t t' : τ̇} →
               (n , t) ∈ Γ →
               (n , t') ∈ Γ →
               t == t'
  ctxunicity {n = n} p q with natEQ n n
  ctxunicity p q | Inl refl = someinj (! p · q)
  ctxunicity _ _ | Inr x≠x = abort (x≠x refl)

  -- type consistency is symmetric
  ~sym : {t1 t2 : τ̇} → t1 ~ t2 → t2 ~ t1
  ~sym TCRefl = TCRefl
  ~sym TCHole1 = TCHole2
  ~sym TCHole2 = TCHole1
  ~sym (TCArr p1 p2) = TCArr (~sym p1) (~sym p2)
  ~sym (TCSum p1 p2) = TCSum (~sym p1) (~sym p2)
  ~sym (TCPro p1 p2) = TCPro (~sym p1) (~sym p2)

  -- type consistency isn't transitive
  not-trans : ((t1 t2 t3 : τ̇) → t1 ~ t2 → t2 ~ t3 → t1 ~ t3) → ⊥
  not-trans t with t (num ==> num) ⦇⦈ num TCHole1 TCHole2
  ... | ()

  --  every pair of types is either consistent or not consistent
  ~dec : (t1 t2 : τ̇) → ((t1 ~ t2) + (t1 ~̸ t2))
    -- this takes care of all hole cases, so we don't consider them below
  ~dec _ ⦇⦈ = Inl TCHole1
  ~dec ⦇⦈ _ = Inl TCHole2
    -- num cases
  ~dec num num = Inl TCRefl
  ~dec num (t2 ==> t3) = Inr ICNumArr1
    -- arrow cases
  ~dec (t1 ==> t2) num = Inr ICNumArr2
  ~dec (t1 ==> t2) (t3 ==> t4) with ~dec t1 t3 | ~dec t2 t4
  ... | Inl x | Inl y = Inl (TCArr x y)
  ... | Inl _ | Inr y = Inr (ICArr2 y)
  ... | Inr x | _     = Inr (ICArr1 x)
    -- plus cases
  ~dec (t1 ⊕ t2) num = Inr ICNumSum2
  ~dec (t1 ⊕ t2) (t3 ==> t4) = Inr ICSumArr1
  ~dec (t1 ⊕ t2) (t3 ⊕ t4) with ~dec t1 t3 | ~dec t2 t4
  ... | Inl x | Inl y = Inl (TCSum x y)
  ... | _     | Inr x = Inr (ICSum2 x)
  ... | Inr x | Inl _ = Inr (ICSum1 x)
  ~dec num (y ⊕ y₁) = Inr ICNumSum1
  ~dec (x ==> x₁) (y ⊕ y₁) = Inr ICSumArr2
  ~dec num (t2 ⊗ t3) = Inr ICNumPro1
  ~dec (t1 ==> t2) (t3 ⊗ t4) = Inr ICProArr2
  ~dec (t1 ⊕ t2) (t3 ⊗ t4) = Inr ICProSum2
  ~dec (t1 ⊗ t2) num = Inr ICNumPro2
  ~dec (t1 ⊗ t2) (t3 ==> t4) = Inr ICProArr1
  ~dec (t1 ⊗ t2) (t3 ⊕ t4) = Inr ICProSum1
  ~dec (t1 ⊗ t2) (t3 ⊗ t4) with ~dec t1 t3 | ~dec t2 t4
  ... | Inl x | Inl y = Inl (TCPro x y)
  ... | _     | Inr x = Inr (ICPro2 x)
  ... | Inr x | Inl _ = Inr (ICPro1 x)

  -- no pair of types is both consistent and not consistent
  ~apart : {t1 t2 : τ̇} → (t1 ~̸ t2) → (t1 ~ t2) → ⊥
  ~apart ICNumArr1 ()
  ~apart ICNumArr2 ()
  ~apart (ICArr1 x) TCRefl = ~apart x TCRefl
  ~apart (ICArr1 x) (TCArr y y₁) = ~apart x y
  ~apart (ICArr2 x) TCRefl = ~apart x TCRefl
  ~apart (ICArr2 x) (TCArr y y₁) = ~apart x y₁
  ~apart ICNumSum1 ()
  ~apart ICNumSum2 ()
  ~apart (ICSum1 x) TCRefl = ~apart x TCRefl
  ~apart (ICSum1 x) (TCSum y y₁) = ~apart x y
  ~apart (ICSum2 x) TCRefl = ~apart x TCRefl
  ~apart (ICSum2 x) (TCSum y y₁) = ~apart x y₁
  ~apart ICSumArr1 ()
  ~apart ICSumArr2 ()
  ~apart ICNumPro1 ()
  ~apart ICNumPro2 ()
  ~apart (ICPro1 x) TCRefl = ~apart x TCRefl
  ~apart (ICPro1 x) (TCPro y y₁) = ~apart x y
  ~apart (ICPro2 x) TCRefl = ~apart x TCRefl
  ~apart (ICPro2 x) (TCPro y y₁) = ~apart x y₁
  ~apart ICProArr1 ()
  ~apart ICProArr2 ()
  ~apart ICProSum1 ()
  ~apart ICProSum2 ()

  -- synthesis only produces equal types. note that there is no need for an
  -- analagous theorem for analytic positions because we think of
  -- the type as an input
  synthunicity : {Γ : ·ctx} {e : ė} {t t' : τ̇} →
                  (Γ ⊢ e => t)
                → (Γ ⊢ e => t')
                → t == t'
  synthunicity (SAsc _) (SAsc _) = refl
  synthunicity {Γ = G} (SVar in1) (SVar in2) = ctxunicity {Γ = G} in1 in2
  synthunicity (SAp D1 MAHole b) (SAp D2 MAHole y) = refl
  synthunicity (SAp D1 MAHole b) (SAp D2 MAArr y) with synthunicity D1 D2
  ... | ()
  synthunicity (SAp D1 MAArr b) (SAp D2 MAHole y) with synthunicity D1 D2
  ... | ()
  synthunicity (SAp D1 MAArr b) (SAp D2 MAArr y) with synthunicity D1 D2
  ... | refl = refl
  synthunicity SNum SNum = refl
  synthunicity (SPlus _ _ ) (SPlus _ _ ) = refl
  synthunicity SEHole SEHole = refl
  synthunicity (SNEHole _) (SNEHole _) = refl

  ----- the zippered form of the forms above and the rules for actions on them

  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete num         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2
  tcomplete (t1 ⊕ t2)   = tcomplete t1 × tcomplete t2
  tcomplete (t1 ⊗ t2)   = tcomplete t1 × tcomplete t2

  -- similarly to the complete types, the complete expressions
  ecomplete : ė → Set
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete (N x)      = ⊤
  ecomplete (e1 ·+ e2) = ecomplete e1 × ecomplete e2
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (inl e)    = ecomplete e
  ecomplete (inr e)    = ecomplete e
  ecomplete (case e x e1 y e2)  = ecomplete e × ecomplete e1 × ecomplete e2
  ecomplete [ e1 , e2 ] = ecomplete e1 × ecomplete e2
  ecomplete (fst e) = ecomplete e
  ecomplete (snd e) = ecomplete e

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


Type.Eq: classify types with an equality test

{-# OPTIONS --without-K #-}
module Type.Eq where

open import Data.Two
              renaming (_==_ to _==𝟚_)
open import Relation.Binary.PropositionalEquality
              renaming (cong to ap; cong₂ to ap₂)
open import Data.Product
              renaming (proj₁ to fst; proj₂ to snd)

record Eq? {a} (A : Set a) : Set a where
  field
    _==_ : A → A → 𝟚
    ≡⇒== : ∀ {x y} → x ≡ y → ✓ (x == y)
    ==⇒≡ : ∀ {x y} → ✓ (x == y) → x ≡ y

open Eq? {{...}} public

𝟚-Eq? : Eq? 𝟚
𝟚-Eq? = record { _==_ = _==𝟚_
               ; ≡⇒== = λ { {0₂} .{0₂} refl → _
                          ; {1₂} .{1₂} refl → _
                          }
               ; ==⇒≡ = λ { {0₂} {0₂} _ → refl
                          ; {1₂} {1₂} _ → refl
                          ; {0₂} {1₂} ()
                          ; {1₂} {0₂} ()
                          }
               }

module _ {a b}{A : Set a}{B : Set b}
         {{A-eq? : Eq? A}}
         {{B-eq? : Eq? B}} where
  instance
    ×-Eq? : Eq? (A × B)
    ×-Eq? = record
      { _==_ = λ x y → fst x == fst y ∧ snd x == snd y
      ; ≡⇒== = λ e → ✓∧ (≡⇒== (ap fst e)) (≡⇒== (ap snd e))
      ; ==⇒≡ = λ e → let p = ✓∧× e in
                      ap₂ _,_ (==⇒≡ (fst p))
                              (==⇒≡ (snd p))
      }

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


universe.agda

universe.agda

module universe where

import Level as L
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (_×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

width-U : Universe ℕ
width-U = mk 0 1 _+_ _*_

card-U : Universe ℕ
card-U = mk 1 2 _*_ _^_

⊤-U : Universe ⊤
⊤-U = mk _ _ _ _

×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T

data U : Set where
  ⊤′ Bit′ : U
  _×′_    : U → U → U
  _^′_    : U → ℕ → U

syn-U : Universe U
syn-U = mk ⊤′ Bit′ _×′_ _^′_

fold-U : ∀ {t} {T : Set t} → Universe T → U → T
fold-U {_} {T} uni = go
  where open Universe uni
        go : U → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T

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


Added note on possible type classes.

Added note on possible type classes.

------------------------------------------------------------------------------
-- Note on type classes
------------------------------------------------------------------------------

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

module FOT.FOTC.TypeClasses.Test where

open import FOTC.Base
open import FOTC.Data.List.Type
open import FOTC.Data.Nat.Type

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

-- 14 December 2012. Type classes for FOTC means type classes for the
-- inductive predicates because them represent the Haskell types. In this
-- case, we are not working in first-order logic.

data _≈_ {A : Set₁}(x : A) : A → Set₁ where
  refl : x ≈ x

foo : ∀ {m n} → m ≡ n → N m ≈ N n
foo refl = refl

bar : ∀ {xs ys} → xs ≡ ys → List xs ≈ List ys
bar refl = refl

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


md5.agda

module md5 where

open import Type
open import Data.Fin using (Fin)
open import Data.Bits using (Bits)
open import Data.Nat

infix 0 _⌥_
infixr 1 _⁏_
infix 0 _`→_
_`×_ = _+_
`Bit = 1
`Bits : ℕ → ℕ
`Bits n = n
postulate
  -- ℕ : Set
  _⊞_ : ∀ {q} → Fin q → Fin q → Fin q
  _⌥_ : ℕ → ℕ → ★

_`→_ = _⌥_
postulate
  rewire : ∀ {i o} → (Fin o → Fin i) → i ⌥ o
    -- cost: 0 time, o space
  _∘_    : ∀ {m n o} → (n ⌥ o) → (m ⌥ n) → (m ⌥ o)
  _⁏_    : ∀ {m n o} → (m ⌥ n) → (n ⌥ o) → (m ⌥ o)
  dup : ∀ {n} → n ⌥ (n + n)
    -- cost: sum time and space
  <_×_>  : ∀ {m n o p} → (m ⌥ o) → (n ⌥ p) → (m + n) ⌥ (o + p)
    -- cost: max time and sum space
  cond   : ∀ {n} → (1 + (n + n)) ⌥ n
    -- cost: 1 time, 1 space
  bits   : ∀ {n _⊤} → Bits n → _⊤ ⌥ n
    -- cost: 0 time, n space
  --xor    : ∀ {n} → Bits n → n ⌥ n
    -- cost: 1 time, n space
  id        : ∀ {A} → A `→ A
  fst       : ∀ {A B} → A `× B `→ A
  snd       : ∀ {A B} → A `× B `→ B
  swap      : ∀ {A B} → (A `× B) `→ (B `× A)
  assoc     : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  {-
  tt        : ∀ {_⊤} → _⊤ `→ `⊤
  <[]>      : ∀ {_⊤ A} → _⊤ `→ `Vec A 0
  <∷>       : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
  uncons    : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)
  <tt,id>   : ∀ {A} → A `→ `⊤ `× A
  snd<tt,>  : ∀ {A} → `⊤ `× A `→ A
  tt→[]     : ∀ {A} → `⊤ `→ `Vec A 0
  []→tt     : ∀ {A} → `Vec A 0 `→ `⊤
  rewireTbl : ∀ {i o} → RewireTbl i o   → `Bits i `→ `Bits o
  -}
  first     : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  second    : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  <_,_>     : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  bijFork   : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ `Bit `× B
  fork      : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  <0b> <1b> : ∀ {_⊤} → _⊤ `→ `Bit
  xor : ∀ {n} → (n + n) ⌥ n
  and : ∀ {n} → (n + n) ⌥ n
  or  : ∀ {n} → (n + n) ⌥ n
  add : ∀ {A} → (A + A) `→ A
  neg : ∀ {n} → n ⌥ n

record Proj A B : Set where
  field
    get : A `→ B
    on  : (A `× B) `→ B → A `→ A
open Proj

module Ops
  (F G : ℕ → ★)
  (lift₁ : ∀ {A B} → A `→ B → F A → G B)
  (lift₂ : ∀ {A B C} → (A `× B) `→ C → F A → F B → G C) where

    infixl 6 _`+_ _⊕_
    _`+_ : ∀ {A} → F A → F A → G A
    _`+_ = lift₂ add

    _⊕_ : ∀ {A} → F A → F A → G A
    _⊕_ = lift₂ xor

    _∧_ : ∀ {A} → F A → F A → G A
    _∧_ = lift₂ and

    _∨_ : ∀ {A} → F A → F A → G A
    _∨_ = lift₂ or

    ¬_ : ∀ {A} → F A → G A
    ¬_ = lift₁ neg

rol : ∀ {n} → Fin n → n `→ n
rol x = rewire (_⊞_ x)

_+=_ : ∀ {A B} → Proj A B → A `→ B → A `→ A
p += c = on p (first c ⁏ add)

module SOps
  (F : ℕ → ★)
  (lift₁ : ∀ {A B} → A `→ B → F A → F B)
  (lift₂ : ∀ {A B C} → (A `× B) `→ C → F A → F B → F C)
  where

    open Ops F F lift₁ lift₂ public

    Op3 : ℕ → ★
    Op3 A = F A → F A → F A → F A

    R : ∀ {A B : ℕ} {I : ★} → (I → A `→ B) → Op3 B → (a b c d : Proj A B) (i : I) (k : Bits B) (s : Fin B) → _
    R {A} {B} w f a b c d i k s =
      a += ({!f (get b) (get c) (get d) {- `+ w i `+ bits k -}!}) ⁏ on a (snd {A} ⁏ rol s) ⁏ a += get b

    module f1,2,3,4 (A : ℕ) where

        f1 : Op3 A
        f2 : Op3 A
        f3 : Op3 A
        f4 : Op3 A

        f1 x y z = z ⊕ (x ∧ (y ⊕ z))
        f2 x y z = f1 z x y -- y ⊕ (z ∧ (x ⊕ y))
        f3 x y z = x ⊕ y ⊕ z
        f4 x y z = y ⊕ (x ∨ ¬ z)

    {-
lift₁ : ∀ {A B C} → B `→ C → Proj A B → A `→ C
lift₁ op p = get p ⁏ op

lift₂ : ∀ {A B C D} → (B `× C) `→ D → Proj A B → Proj A C → A `→ D
lift₂ op p₀ p₁ = dup ⁏ < get p₀ × get p₁ > ⁏ op

module Ops' {A} = Ops (Proj A) (_`→_ A) lift₁ lift₂
open Ops'
-}

lift₁ : ∀ {A B C} → B `→ C → A `→ B → A `→ C
lift₁ op p = p ⁏ op

lift₂ : ∀ {A B C D} → (B `× C) `→ D → A `→ B → A `→ C → A `→ D
lift₂ op p₀ p₁ = dup ⁏ < p₀ × p₁ > ⁏ op

module SOps' {A} = SOps (_`→_ A) lift₁ lift₂
-- open SOps'

{-
x : ∀ {A B} → (A `× B) `→ A
x = fst
y : ∀ {A B C} → (A `× B `× C) `→ B
y = snd ⁏ fst
z : ∀ {A B C D} → (A `× B `× C `× D) `→ C
z = snd ⁏ snd ⁏ fst
-}

{-
partofmd5 =
  R f1 a b c d 0 0xd76aa478 7  ⁏
  R f1 d a b c 1 0xe8c7b756 12 ⁏
  R f1 c d a b 2 0x242070db 17 ⁏
  R f1 b c d a 3 0xc1bdceee 22
  -- -}
  -- -}
  -- -}
  -- -}
  -- -}

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


Added draft: Conversion functions i, j, and p.

Ignore-this: bd94fe9db721fc35f983fdb1f4eab4c9

darcs-hash:20110205045233-3bd4e-ce1165f0c88f3408a8ac80324d2f766c2f79f04c.gz

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


{-# OPTIONS --without-K #-}

open import Function.NP
import Function.Extensionality as FE
open FE using (FunExt)
open import Relation.Binary.PropositionalEquality.NP

-- All of this should be derived from FE together with the iso
-- between explicit Π and implicit Π
module Function.Extensionality.Implicit {a b}{A : Set a}{B : A → Set b} where

private
  T    = {x : A} → B x
  _≡'_ = _≡_ {A = T}

infix 4 _∼_

_∼_   : (f₀ f₁ : {x : A} → B x) → Set _
f₀ ∼ f₁ = (x : A) → f₀ {x} ≡ f₁ {x}

module _ {f₀ f₁ : T} where
  happly : f₀ ≡' f₁ → f₀ ∼ f₁
  happly p x = ap (λ f₀ → f₀ {x}) p

  module _ {{fe : FunExt}} where
    postulate
      λ= : (f= : f₀ ∼ f₁) → f₀ ≡' f₁

      happly-λ= : (f= : f₀ ∼ f₁) → happly (λ= f=) ≡ f=

      λ=-happly : (α : f₀ ≡' f₁) → λ= (happly α) ≡ α

      -- This should be derivable if I had a proper proof of λ=
      tr-λ= : ∀ {p x}(P : B x → Set p)(f= : f₀ ∼ f₁)
              → tr (λ f₀ → P (f₀ {x})) (λ= f=) ≡ tr P (f= x)

!-α-λ= : ∀ {f₀ f₁ : T}{{fe : FunExt}}
           (α : f₀ ≡' f₁) → ! α ≡ λ= (!_ ∘ happly α)
!-α-λ= refl = ! λ=-happly refl

module _ {f₀ f₁ : T}{{fe : FunExt}} where
  !-λ= : (f= : f₀ ∼ f₁) → ! (λ= f=) ≡ λ= (!_ ∘ f=)
  !-λ= f= = !-α-λ= (λ= f=) ∙ ap λ= (FE.λ= (λ x → ap !_ (FE.happly (happly-λ= f=) x)))

  λ=ⁱ : (f= : ∀ {x} → f₀ {x} ≡ f₁ {x}) → f₀ ≡' f₁
  λ=ⁱ f= = λ= λ x → f= {x}
-- -}
-- -}
-- -}
-- -}
-- -}

error: pathspec 'lib/Function/Extensionality/Implicit.agda' did not match any file(s) known to git


Preliminary work on datalog termination

Preliminary work on datalog termination

module Datalog where
open import Data.Nat as ℕ
open import Data.List
open import Data.Integer as ℤ
open import Relation.Binary.PropositionalEquality
open import Data.List.Any

module Term where
  data tt : Set where
    τ-int : tt

  open Membership (setoid tt)

  ctx = List tt

  data Lit : tt → Set where
    int : ℤ → Lit τ-int

  data Expr {τ : tt} {{ Γ : ctx }} {{ Δ : ctx }} : Set where
    lit   : (Lit τ) → Expr {τ}
    e-var : (τ ∈ Γ) → Expr {τ}
    a-var : (τ ∈ Δ) → Expr {τ}

module Program where

  at = List Term.tt

  open Membership (setoid at)

  ctx = List at

  data PartialAtom {Γ : Term.ctx} {Δ : Term.ctx} {Ρ : ctx} (ρ : at) : Set where
    predicate : (ρ ∈ Ρ) → PartialAtom ρ
    apply : ∀ {τ : Term.tt} → PartialAtom {Γ} {Δ} {Ρ} (τ ∷ ρ) → Term.Expr {τ} ⦃ Γ ⦄ ⦃ Δ ⦄ → PartialAtom {Γ} {Δ} {Ρ} ρ

  data Atom {Γ : Term.ctx} {Δ : Term.ctx} ⦃ Ρ : ctx ⦄ : Set where
    close : PartialAtom {Γ} {Δ} {Ρ} [] → Atom

  data Rule {Ρ : ctx} : Set where
    -- Here, we should also be checking that the rhs uses Γ to make it a relevant ctx
    -- when used in the universal position
    -- I don't think I need that property for proofs yet, so it can wait
    rule : {Γ : Term.ctx} → Atom {Γ} {[]} → List (Atom {[]} {Γ}) → Rule

  Program : {Ρ : ctx} → Set
  Program {Ρ} = List (Rule {Ρ})

  data Derivable {Ρ} : Program {Ρ} → Atom {[]} {[]} → Set where

{-
  Proof sketch:
  0.) match as an assumed-correct-primitive
  1.) Proof of upper bound : prog, ∀ r ∈ prog. ∀ db. ∀ s ∈ match db r.body. subst s r.head ∈ upper
  2.) semantics : p : Program → db → ∀ a ∈ db. Derivable Ρ prog a → upper → (∀ r ∈ p. ∀ vdb. ∀ s ∈ match vdb r.body. let h = subst s r.head in (h ∈ upper) || (h ∈ db))
      a.) Go through prog, trying to generate the proof of termination
      b.) If on any rule you fail, take the failing fact:
          i.) Move the fact from upper to db
          ii.) Add derivability proof for the fact you just derived (look up the matched facts derivation and build up)
          iii.) Fix up the completeness term by demonstrating that if all that happened moved from upper to db, the property is just as true
  3.) Proof of correctness is:
      db, ∀ a ∈ db. Derivable {Ρ} prog a, ∀ r ∈ prog. ∀ s ∈ match db r.body. subst s r.head ∈ db
      e.g. database, proof that database is sound, proof that database is complete
-}

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


-- Inspired from the haskell 'lens' package
module Lens.Getter where

open import Type
open import Lens.Type
open import Function

data Accessor (R : ★) (A : ★) : ★ where
  mkAccessor : R → Accessor R A

private
  coerceAccessor : ∀ {R A B} → Accessor R A → Accessor R B
  coerceAccessor (mkAccessor x) = mkAccessor x
  runAccessor : ∀ {R A} → Accessor R A → R
  runAccessor (mkAccessor x) = x

Getting : (R S T A B : ★) → ★
Getting R = LensLike (Accessor R)
  -- Getting R S T A B ≡ (A → Accessor R B) → S → Accessor R T

-- unlike Control.Lens.Getter we have no Gettable type-class
Getter : (S A : ★) → ★₁
Getter S A = ∀ {R} → Getting R S S A A

infixl 8 _^·_ _^&_
infixl 1 _&_
infixr 0 _^$_

_^·_ : ∀ {S T A B} → S → Getting A S T A B → A
s ^· ℓ = runAccessor (ℓ mkAccessor s)

_^$_ : ∀ {S T A B} → Getting A S T A B → S → A
_^$_ = flip _^·_

to : ∀ {S A} → (S → A) → Getter S A
to f g = coerceAccessor ∘ g ∘ f

_&_ : ∀ {A B : ★} → A → (A → B) → B
a & f = f a

_^&_ : ∀ {A B : ★} → A → (A → B) → B
a ^& f = f a

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


qualified import and clean up

qualified import and clean up

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/'


A simpler type for terms, mainly for debugging, includes a printer

open import Reflection.NP hiding (app)
open import Function
open import Data.Nat
open import Data.Nat.Show renaming (show to showNat)
open import Data.List hiding (_++_)
open import Data.String
open import Data.Float
open import Data.Char

module Reflection.Simple where

data Var A : Set where
  var : (x : A) → Var A
  con : (c : Name) → Var A
  def : (f : Name) → Var A

data Tm A : Set where
  app     : (v : Var A) (args : List (Tm A)) → Tm A
  lam     : (s : A) (t : Tm A) → Tm A
  pi      : (s : A) (t₁ : Tm A) (t₂ : Tm A) → Tm A
  sort    : ℕ → Tm A
  lit     : (l : Literal) → Tm A
  unknown : Tm A

Tms : Set → Set
Tms A = List (Tm A)

module Level where
    Env : Set
    Env = ℕ
    vår : Env → Var ℕ → Var ℕ
    vår depth (var ix) = var (depth ∸ suc ix)
    vår depth (con c)  = con c
    vår depth (def d)  = def d
    term  : Env → Tm ℕ → Tm ℕ
    terms : Env → Tms ℕ → Tms ℕ
    term Γ (app x args) = app (vår Γ x) (terms Γ args)
    term Γ (lam _ t) = lam Γ (term (suc Γ) t)
    term Γ (pi _ t t₁) = pi Γ (term Γ t) (term (suc Γ) t₁)
    term Γ (sort l) = sort l
    term Γ (lit l) = lit l
    term Γ unknown = unknown
    terms Γ [] = []
    terms Γ (x ∷ ts) = term Γ x ∷ terms Γ ts

module Simplify where
    term : Term → Tm ℕ
    tÿpe : Type → Tm ℕ
    årgs : Args → List (Tm ℕ)
    term (var x args) = app (var x) (årgs args)
    term (con c args) = app (con c) (årgs args)
    term (def f args) = app (def f) (årgs args)
    term (lam v t) = lam 42 (term t)
    term (pat-lam cs args) = unknown
    term (pi (arg _ t₁) t₂) = pi 42 (tÿpe t₁) (tÿpe t₂)
    term (sort (lit l)) = sort l
    term (sort _) = unknown
    term (lit l) = lit l
    term unknown = unknown
    tÿpe (el s t) = term t
    årgs [] = []
    årgs (arg i x ∷ as) = term x ∷ årgs as

simple : Term → Tm ℕ
simple = Level.term 0 ∘ Simplify.term

open import Text.Printer
module Printer where
    open PrEnv

    topᴸ = mk 2
    appᴸ = mk 1
    atmᴸ = mk 0

    prTm : PrEnv → Pr (Tm ℕ)
    prV   : Pr ℕ
    prVar : Pr (Var ℕ)
    prTms : Pr (Tms ℕ)

    prV x = ` "x" ∘ `(showNat x)

    prVar (var x) = prV x
    prVar (con c) = `(showName c)
    prVar (def f) = `(showName f)

    prTm ℓ (lam b t)  = paren topᴸ ℓ (` "λ" ∘ prV b ∘ ` ". " ∘ prTm topᴸ t)
    prTm ℓ (app v []) = prVar v
    prTm ℓ (app v as) = paren appᴸ ℓ (prVar v ∘ prTms as)
    prTm ℓ (pi s t u) = paren topᴸ ℓ (` "(" ∘ prV s ∘ ` " : " ∘ prTm topᴸ t ∘ ` ") → " ∘ prTm topᴸ u)
    prTm ℓ (sort l)   = ` "Set" ∘ ` showNat l
    prTm ℓ (lit l)    = `(showLiteral l)
    prTm ℓ unknown    = ` "unknown"

    prTms [] = id
    prTms (a ∷ as) = ` " " ∘ prTm atmᴸ a ∘ prTms as

showTerm : Term → String
showTerm t = prTm topᴸ (simple t) "" where open Printer

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


Dependently typed versions of curryⁿ and $ⁿ and one property

module Data.Vec.N-ary.NP where

open import Function
open import Data.Nat
open import Data.Vec
open import Data.Vec.N-ary public renaming (curryⁿ to curryⁿ′; _$ⁿ_ to _$ⁿ′_)
open import Relation.Binary.PropositionalEquality

curryⁿ : ∀ {n a b} {A : Set a} {B : N-ary n A (Set b)} →
         ((xs : Vec A n) → B $ⁿ′ xs) → ∀ⁿ n B
curryⁿ {zero}  f = f []
curryⁿ {suc n} f = λ x → curryⁿ (f ∘ _∷_ x)

_$ⁿ_ : ∀ {n a b} {A : Set a} {B : N-ary n A (Set b)} → ∀ⁿ n B → ((xs : Vec A n) → B $ⁿ′ xs)
f $ⁿ []       = f
f $ⁿ (x ∷ xs) = f x $ⁿ xs

curry-$ⁿ : ∀ {n a b} {A : Set a} {B : N-ary n A (Set b)} (f : (xs : Vec A n) → B $ⁿ′ xs) (xs : Vec A n)
           → curryⁿ f $ⁿ xs ≡ f xs
curry-$ⁿ f []       = refl
curry-$ⁿ f (x ∷ xs) = curry-$ⁿ (f ∘ _∷_ x) xs

curry-$ⁿ′ : ∀ {n a b} {A : Set a} {B : Set b} (f : Vec A n → B) (xs : Vec A n)
           → curryⁿ′ f $ⁿ′ xs ≡ f xs
curry-$ⁿ′ f []       = refl
curry-$ⁿ′ f (x ∷ xs) = curry-$ⁿ′ (f ∘ _∷_ x) xs

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


Working in the length of streams.

Working in the length of streams.

module FOT.FOTC.Data.Stream.Length where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open FOTC.Base.BList
open import FOTC.Base.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream

module Version₁ where
  {-# NO_TERMINATION_CHECK #-}
  Stream-length : ∀ {xs} → Stream xs → length xs ≡ ∞
  Stream-length {xs} Sxs with (Stream-unf Sxs)
  ... | x' , xs' , Sxs' , h =
    length xs
      ≡⟨ cong length h ⟩
    length (x' ∷ xs')
      ≡⟨ lg-xs≡∞→lg-x∷xs≡∞ x' xs' (Stream-length Sxs') ⟩
    ∞ ∎

-- module Version₂ where
--   Stream-length : ∀ {xs} → Stream xs → length xs ≈N ∞
--   Stream-length xs = ≈N-coind {!!} {!!} {!!}

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


ZK.GroupHom.JSChal: basic setup, many postulates left

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq
open import Relation.Binary

open import ZK.GroupHom.NumChal
open import FFI.JS.BigI
open import Algebra.Group
open import Algebra.Group.Homomorphism
open import Data.Bool.Base renaming (T to ✓)
open import Relation.Binary.PropositionalEquality

module ZK.GroupHom.JSChal
  (G+ G* : Type)
  (𝔾+ : Group G+)
  (𝔾* : Group G*)
  {{eq?-G* : Eq? G*}}
  (φ : G+ → G*)
  (φ-hom : GroupHomomorphism 𝔾+ 𝔾* φ)
  (Y : G*)

  (q : BigI)
  where

infixl 6 _+ⁿ_ _∸ⁿ_
infixl 7 _*ⁿ_

module 𝔾+ = Group 𝔾+
open module 𝔾* = Multiplicative-Group 𝔾*

postulate
  BigIPrime : BigI → Type

0ⁿ   = 0I
1ⁿ   = 1I
_+ⁿ_ = add
_∸ⁿ_ = subtract
_*ⁿ_ = multiply

_<BigI_ : (x y : BigI) → Type
x <BigI y = ✓ (x <I y)

_div-q _mod-q inv-mod-q : BigI → BigI
x div-q     = divide x q
x mod-q     = mod x q
inv-mod-q x = modInv x q

postulate
  _⊗ⁿ_ : G+ → BigI → G+
--_⊗ⁿ_ = {!!}
  _^ⁿ_ : G* → BigI → G*
--_^ⁿ_ = {!!}

-- TODO
postulate
  -- should be turned into a dynamic test!
  q-prime : BigIPrime q

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

-- We can hope to reduce these two more basic facts
postulate
  1^ⁿ : ∀ x → 𝔾*.1# ^ⁿ x ≡ 𝔾*.1#
  φ-hom-iterated : ∀ {x c} → φ (x ⊗ⁿ c) ≡ φ x ^ⁿ c

postulate
  compare : Trichotomous _≡_ _<BigI_
  <-∸≢0 : ∀ x y → y <BigI x → x ∸ⁿ y ≢ 0ⁿ
  div-mod-q-propⁿ : ∀ d → d ≡ d mod-q +ⁿ (d div-q) *ⁿ q
  inv-mod-q-prop : ∀ x → x ≢ 0ⁿ → (inv-mod-q x *ⁿ x)mod-q ≡ 1ⁿ

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

JSPackage : Package
JSPackage = record
              { Num = BigI
              ; Prime = BigIPrime
              ; _<_ = _<BigI_
              ; 0ⁿ = 0ⁿ
              ; 1ⁿ = 1ⁿ
              ; _+ⁿ_ = _+ⁿ_
              ; _∸ⁿ_ = _∸ⁿ_
              ; _*ⁿ_ = _*ⁿ_
              ; compare = compare
              ; <-∸≢0 = <-∸≢0
              ; G+ = G+
              ; G* = G*
              ; 𝔾+ = 𝔾+
              ; 𝔾* = 𝔾*
              ; _⊗ⁿ_ = _⊗ⁿ_
              ; _^ⁿ_ = _^ⁿ_
              ; 1^ⁿ = 1^ⁿ
              ; φ = φ
              ; φ-hom = φ-hom
              ; φ-hom-iterated = φ-hom-iterated
              ; q = q
              ; q-prime = q-prime
              ; _div-q = _div-q
              ; _mod-q = _mod-q
              ; div-mod-q-propⁿ = div-mod-q-propⁿ
              ; inv-mod-q = inv-mod-q
              ; inv-mod-q-prop = inv-mod-q-prop
              ; Y = Y
              ; G*-order = G*-order
              ; ^ⁿ1ⁿ+ⁿ = ^ⁿ1ⁿ+ⁿ
              ; ^ⁿ-* = ^ⁿ-*
              ; ^ⁿ-∸ⁿ = ^ⁿ-∸ⁿ
              }

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


Add FiniteField/FinImplem.agda (unfinished)

-- Implements ℤq with Data.Fin
open import Type
open import Data.Nat
open import Data.Fin.NP as Fin
open import Relation.Binary.PropositionalEquality

open import Explore.Type
open import Explore.Explorable

open Fin.Modulo renaming (sucmod to [suc]; sucmod-inj to [suc]-inj)

module FiniteField.FinImplem (q-1 : ℕ) ([0]' [1]' : Fin (suc q-1)) where
  -- open Sum
  q : ℕ
  q = suc q-1

  ℤq : ★
  ℤq = Fin q

  μℤq : Explorable ℤq
  μℤq = {!μFinSuc q-1!}

  sumℤq : Sum ℤq
  sumℤq = sum μℤq

  [0] : ℤq
  [0] = [0]'

  [1] : ℤq
  [1] = [1]'

  [suc]-stable : SumStableUnder (sum μℤq) [suc]
  [suc]-stable = {!μFinSUI [suc] [suc]-inj!}

  _ℕ⊞_ : ℕ → ℤq → ℤq
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = m ℕ⊞ ([suc] n)

  ℕ⊞-inj : ∀ n {x y} → n ℕ⊞ x ≡ n ℕ⊞ y → x ≡ y
  ℕ⊞-inj zero    eq = eq
  ℕ⊞-inj (suc n) eq = [suc]-inj (ℕ⊞-inj n eq)

  ℕ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_ℕ⊞_ m)
  ℕ⊞-stable m = {!μFinSUI (_ℕ⊞_ m) (ℕ⊞-inj m)!}

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin▹ℕ m ℕ⊞ n

  ⊞-inj : ∀ m {x y} → m ⊞ x ≡ m ⊞ y → x ≡ y
  ⊞-inj m = ℕ⊞-inj (Fin▹ℕ m)

  ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_⊞_ m)
  ⊞-stable m = {!μFinSUI (_⊞_ m) (⊞-inj m)!}

  _ℕ⊠_ : ℕ → ℤq → ℤq
  zero  ℕ⊠ n = [0]
  suc m ℕ⊠ n = n ⊞ (m ℕ⊠ n)

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin▹ℕ m ℕ⊠ n

  _[^]ℕ_ : ℤq → ℕ → ℤq
  m [^]ℕ zero  = [1]
  m [^]ℕ suc n = m ⊠ (m [^]ℕ n)

  _[^]_ : ℤq → ℤq → ℤq
  m [^] n = m [^]ℕ (Fin▹ℕ n)

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


FunUniverse/Loop.agda

FunUniverse/Loop.agda

open import Type
open import FunUniverse.Core

module FunUniverse.Loop where

module LoopType {t} {T : ★_ t} (funU : FunUniverse T) where
  open FunUniverse funU
  Exit? = `𝟚

  record Loop A I B O : ★_ t where
    constructor loop[_⁏_⁏_]
    field
      {S} : T

    Init = A `→ S
    Body = I `× S `→ Exit? `× O `× S
    Exit = S `→ B

    field
      init : Init
      body : Body
      exit : Exit

module Foldl {t} {T : ★_ t} {funU : FunUniverse T}
             (funOps : FunOps funU)
             {I O}
             (z : let open FunUniverse funU in
                  `𝟙 `→ O)
             (f : let open FunUniverse funU in
                  I `× O `→ O) where
    open LoopType funU
    open FunUniverse funU
    open FunOps funOps hiding (foldl)
    foldl : Loop `𝟙 I `𝟙 O
    foldl = loop[ z ⁏ (f ⁏ <tt⁏ <0₂> , dup >) ⁏ tt ]

open import FunUniverse.Agda
open import Data.Product
open import Data.One
open import Data.Two
open import Data.List
open LoopType agdaFunU
open FunOps agdaFunOps hiding (init)

module RunList {A I B O} (loop : Loop A I B O) where

  open Loop loop

  runList₀ : List I × S → List O × S
  runList₁ : List I × Exit? × O × S → List O × S

  runList₁ (is , 0₂ , o , s) = first (_∷_ o) (runList₀ (is , s))
  runList₁ (is , 1₂ , o , s) = (o ∷ [] , s)

  runList₀ ([]     , s) = ([] , s)
  runList₀ (i ∷ is , s) = runList₁ (is , body (i , s))

  runList : List I × A → List O × B
  runList = second init ⁏ runList₀ ⁏ second exit

-- -}

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