adding a stub theorem for what complete progress probably looks like.

@cyrus- i'm not quite sure what complete preservation looks like. the
statement of preservation is actually pretty standard, so i don't know what
the adjustment would be. maybe that you just don't add any casts or
something? there are no casts in hexps so a complete term won't have any;
if we believe that casts are a thing that results from holes being
indeterminate, we shouldn't add any. that's probably a theorem we should be
proving but i'm not sure it's preservation.

open import Nat
open import Prelude
open import List
open import core
open import contexts

module complete-progress where

  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  -- nb: don't need (Δ , ∅ ⊢ d :: τ) because of typed-expansion
  complete-progress : {Δ : hctx} {d : dhexp} {τ : htyp} {e : hexp}→
                       ecomplete e →
                       ∅ ⊢ e ⇒ τ ~> d ⊣ Δ →
                       ok d Δ
  complete-progress = {!!}

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


Crypto/Schemes.agda

Crypto/Schemes.agda

module Crypto.Schemes where

open import Type
open import Data.Product
open import Relation.Binary.PropositionalEquality

record PublicKeyEncryption : ★₁ where
  constructor mk
  field
    PubKey SecKey Message CipherText Rₖ Rₑ : ★
    KeyGen : Rₖ → PubKey × SecKey
    Enc : PubKey → Message → Rₑ → CipherText
    Dec : SecKey → CipherText → Message

  FunctionallyCorrect : ★
  FunctionallyCorrect =
    ∀ rₖ rₑ m → let (pk , sk) = KeyGen rₖ in
                 Dec sk (Enc pk m rₑ) ≡ m

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


clean spec

clean spec

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


Newest Desc model.

Newest Desc model.

In the style of https://github.com/larrytheliquid/generic-elim.
This version has a specialized Mu that supports levitation.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
open import Function
module Spire.Examples.PropLev where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Branches : (E : Enum) (P : Tag E → Set) → Set
Branches [] P = ⊤
Branches (l ∷ E) P = P here × Branches E (λ t → P (there t))

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches [] P X = X
CurriedBranches (l ∷ E) P X = P here → CurriedBranches E (λ t → P (there t)) X

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

data Desc (I : Set) : Set₁ where
  End : (i : I) → Desc I
  Rec : (i : I) (D : Desc I) → Desc I
  Arg : (A : Set) (B : A → Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : {I : Set} (D : Desc I) → ISet I → ISet I
El (End j) X i = j ≡ i
El (Rec j D) X i = X j × El D X i
El (Arg A B) X i = Σ A (λ a → El (B a) X i)

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El D X i) → Set
Hyps (End j) X P i q = ⊤
Hyps (Rec j D) X P i (x , xs) = P j x × Hyps D X P i xs
Hyps (Arg A B) X P i (a , b) = Hyps (B a) X P i b

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

BranchesD : (I : Set) (E : Enum) → Set
BranchesD I E = Branches E (λ _ → Desc I)

caseD : {I : Set} {E : Enum} (cs : BranchesD I E) (t : Tag E) → Desc I
caseD = case (λ _ → Desc _)

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

UncurriedEl : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedEl D X = ∀{i} → El D X i → X i

CurriedEl : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedEl (End i) X = X i
CurriedEl (Rec i D) X = (x : X i) → CurriedEl D X
CurriedEl (Arg A B) X = (a : A) → CurriedEl (B a) X

CurriedEl' : {I : Set} (D : Desc I) (X : ISet I) (i : I) → Set
CurriedEl' (End j) X i = j ≡ i → X i
CurriedEl' (Rec j D) X i = (x : X j) → CurriedEl' D X i
CurriedEl' (Arg A B) X i = (a : A) → CurriedEl' (B a) X i

curryEl : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedEl D X → CurriedEl D X
curryEl (End i) X cn = cn refl
curryEl (Rec i D) X cn = λ x → curryEl D X (λ xs → cn (x , xs))
curryEl (Arg A B) X cn = λ a → curryEl (B a) X (λ xs → cn (a , xs))

uncurryEl : {I : Set} (D : Desc I) (X : ISet I)
  → CurriedEl D X → UncurriedEl D X
uncurryEl (End i) X cn refl = cn
uncurryEl (Rec i D) X cn (x , xs) = uncurryEl D X (cn x) xs
uncurryEl (Arg A B) X cn (a , xs) = uncurryEl (B a) X (cn a) xs

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : El D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → Set
CurriedHyps (End i) X P cn =
  P i (cn refl)
CurriedHyps (Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps D X P (λ xs → cn (x , xs))
CurriedHyps (Arg A B) X P cn =
  (a : A) → CurriedHyps (B a) X P (λ xs → cn (a , xs))

CurriedHyps' : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (i : I)
  (cn : El D X i → X i)
  → Set
CurriedHyps' (End j) X P i cn = (q : j ≡ i) → P i (cn q)
CurriedHyps' (Rec j D) X P i cn =
  (x : X j) → P j x → CurriedHyps' D X P i (λ xs → cn (x , xs))
CurriedHyps' (Arg A B) X P i cn =
  (a : A) → CurriedHyps' (B a) X P i (λ xs → cn (a , xs))

curryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → UncurriedHyps D X P cn
  → CurriedHyps D X P cn
curryHyps (End i) X P cn pf =
  pf i refl tt
curryHyps (Rec i D) X P cn pf =
  λ x ih → curryHyps D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps (Arg A B) X P cn pf =
  λ a → curryHyps (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps (End .i) X P cn pf i refl tt =
  pf
uncurryHyps (Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps (Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs

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

data μ {I : Set} (E : Enum) (C : Tag E → Desc I) : ISet I where
  init : (t : Tag E) → UncurriedEl (C t) (μ E C)

inj : {I : Set} (E : Enum) (C : Tag E → Desc I) (t : Tag E) → CurriedEl (C t) (μ E C)
inj E C t = curryEl (C t) (μ E C) (init t)

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

ind :
  {I : Set}
  (E : Enum)
  (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) (μ E C) P (init t))
  (i : I)
  (x : μ E C i)
  → P i x

hyps :
  {I : Set}
  (E : Enum)
  (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) (μ E C) P (init t))
  (D : Desc I)
  (i : I)
  (xs : El D (μ E C) i)
  → Hyps D (μ E C) P i xs

ind E C P α i (init t xs) = α t i xs (hyps E C P α (Arg (Tag E) C) i (t , xs))

hyps E C P α (End j) i q = tt
hyps E C P α (Rec j A) i (x , xs) = ind E C P α j x , hyps E C P α A i xs
hyps E C P α (Arg A B) i (a , b) = hyps E C P α (B a) i b

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

indCurried : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (f : (t : Tag E) → CurriedHyps (C t) (μ E C) P (init t))
  (i : I)
  (x : μ E C i)
  → P i x
indCurried E C P f i x = ind E C P (λ t → uncurryHyps (C t) (μ E C) P (init t) (f t)) i x

Summer : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (X  : ISet I) (cn : (t : Tag E) → UncurriedEl (C t) X)
  (P : (i : I) → X i → Set)
  → Tag E → Set
Summer E C X cn P t = CurriedHyps (C t) X P (cn t)

SumCurriedHyps : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  → Tag E → Set
SumCurriedHyps E C P t = Summer E C (μ E C) init P t

elimUncurried : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  → Branches E (SumCurriedHyps E C P)
  → (i : I) (x : μ E C i) → P i x
elimUncurried E C P cs i x =
  indCurried E C P
    (case (SumCurriedHyps E C P) cs)
    i x

elim : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  → CurriedBranches E
      (SumCurriedHyps E C P)
      ((i : I) (x : μ E C i) → P i x)
elim E C P = curryBranches (elimUncurried E C P)

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

Soundness : Set₁
Soundness = {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (cs : Branches E (SumCurriedHyps E C P))
  (i : I) (x : μ E C i)
  → ∃ λ α
  → elimUncurried E C P cs i x ≡ ind E C P α i x

sound : Soundness
sound E C P cs i xs =
  let D = Arg (Tag E) C in
  (λ t → uncurryHyps (C t) (μ E C) P (init t) (case (SumCurriedHyps E C P) cs t)) , refl

Completeness : Set₁
Completeness = {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) (μ E C) P (init t))
  (i : I) (x : μ E C i)
  → ∃ λ cs
  → ind E C P α i x ≡ elimUncurried E C P cs i x

uncurryHypsIdent : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  (α : UncurriedHyps D X P cn)
  (i : I) (xs : El D X i) (ihs : Hyps D X P i xs)
  → α i xs ihs ≡ uncurryHyps D X P cn (curryHyps D X P cn α) i xs ihs
uncurryHypsIdent (End .i) X P cn α i refl tt = refl
uncurryHypsIdent (Rec j D) X P cn α i (x , xs) (p , ps) =
  uncurryHypsIdent D X P (λ xs → cn (x , xs)) (λ k ys rs → α k (x , ys) (p , rs)) i xs ps
uncurryHypsIdent (Arg A B) X P cn α i (a , xs) ps =
  uncurryHypsIdent (B a) X P (λ xs → cn (a , xs)) (λ j ys → α j (a , ys)) i xs ps

postulate
  ext4 : {A : Set} {B : A → Set} {C : (a : A) → B a → Set}
    {D : (a : A) (b : B a) → C a b → Set}
    {Z : (a : A) (b : B a) (c : C a b) → D a b c → Set}
    (f g : (a : A) (b : B a) (c : C a b) (d : D a b c) → Z a b c d)
    → ((a : A) (b : B a) (c : C a b) (d : D a b c) → f a b c d ≡ g a b c d)
    → f ≡ g

toBranches : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (X  : ISet I) (cn : (t : Tag E) → UncurriedEl (C t) X)
  (P : (i : I) → X i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) X P (cn t))
  → Branches E (Summer E C X cn P)
toBranches [] C X cn P α = tt
toBranches (l ∷ E) C X cn P α =
    curryHyps (C here) X P (λ xs → cn here xs) (λ i xs → α here i xs)
  , toBranches E (λ t → C (there t)) X
     (λ t → cn (there t))
     P (λ t i xs ih → α (there t) i xs ih)

ToBranches : {I : Set} {E : Enum} (C : Tag E → Desc I)
  (X  : ISet I) (cn : (t : Tag E) → UncurriedEl (C t) X)
  (P : (i : I) → X i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) X P (cn t))
  (t : Tag E)
  → let β = toBranches E C X cn P α in
  case (Summer E C X cn P) β t ≡ curryHyps (C t) X P (cn t) (α t)
ToBranches C X cn P α here = refl
ToBranches C X cn P α (there t)
  with ToBranches (λ t → C (there t)) X
    (λ t xs → cn (there t) xs)
    P (λ t i xs ih → α (there t) i xs ih) t
... | ih rewrite ih = refl

completeα : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) (μ E C) P (init t))
  (t : Tag E) (i : I) (xs : El (C t) (μ E C) i) (ihs : Hyps (C t) (μ E C) P i xs)
  → let β = toBranches E C (μ E C) init P α in
  α t i xs ihs ≡ uncurryHyps (C t) (μ E C) P (init t) (case (SumCurriedHyps E C P) β t) i xs ihs
completeα E C P α t i xs ihs
  with ToBranches C (μ E C) init P α t
... | q rewrite q = uncurryHypsIdent (C t) (μ E C) P (init t) (α t) i xs ihs

complete' : {I : Set} (E : Enum) (C : Tag E → Desc I)
  (P : (i : I) → μ E C i → Set)
  (α : (t : Tag E) → UncurriedHyps (C t) (μ E C) P (init t))
  (i : I) (x : μ E C i)
  → let β = toBranches E C (μ E C) init P α in
  ind E C P α i x ≡ elimUncurried E C P β i x
complete' E C P α i (init t xs) = cong
  (λ f → ind E C P f i (init t xs))
  (ext4 α
    (λ t → uncurryHyps (C t) (μ E C) P (init t) (case (SumCurriedHyps E C P) β t))
    (completeα E C P α)
  )
  where β = toBranches E C (μ E C) init P α

complete : Completeness
complete E C P α i x =
  let D = Arg (Tag E) C in
    toBranches E C (μ E C) init P α
  , complete' E C P α i x

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

ℕE : Enum
ℕE = "zero" ∷ "suc" ∷ []

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

ℕC : ℕT → Desc ⊤
ℕC = caseD $
    End tt
  , Rec tt (End tt)
  , tt

ℕD : Desc ⊤
ℕD = Arg ℕT ℕC

ℕ : ⊤ → Set
ℕ = μ ℕE ℕC

zero : ℕ tt
zero = init zeroT refl

suc : ℕ tt → ℕ tt
suc n = init sucT (n , refl)

VecC : (A : Set) → VecT → Desc (ℕ tt)
VecC A = caseD $
    End zero
  , Arg (ℕ tt) (λ n → Arg A λ _ → Rec n (End (suc n)))
  , tt

nilD : (A : Set) → Desc (ℕ tt)
nilD A = End zero

consD : (A : Set) → Desc (ℕ tt)
consD A = Arg (ℕ tt) (λ n → Arg A (λ _ → Rec n (End (suc n))))

VecD : (A : Set) → Desc (ℕ tt)
VecD A = Arg VecT (VecC A)

Vec : (A : Set) → ℕ tt → Set
Vec A = μ VecE (VecC A)

NilEl : (A : Set) (n : ℕ tt) → Set
NilEl A n = El (nilD A) (Vec A) n

ConsEl : (A : Set) → ℕ tt → Set
ConsEl A n = El (consD A) (Vec A) n

VecEl : (A : Set) → ℕ tt → Set
VecEl A n = El (VecD A) (Vec A) n

NilHyps : (A : Set) (P : (n : ℕ tt) → Vec A n → Set) (n : ℕ tt) (xs : NilEl A n) → Set
NilHyps A P n xs = Hyps (nilD A) (Vec A) P n xs

ConsHyps : (A : Set) (P : (n : ℕ tt) → Vec A n → Set) (n : ℕ tt) (xs : ConsEl A n) → Set
ConsHyps A P n xs = Hyps (consD A) (Vec A) P n xs

VecHyps : (A : Set) (P : (n : ℕ tt) → Vec A n → Set) (n : ℕ tt) (xs : VecEl A n) → Set
VecHyps A P n xs = Hyps (VecD A) (Vec A) P n xs

ConsUncurriedHyps : (A : Set)
  (P : (n : ℕ tt) → Vec A n → Set)
  (cn : UncurriedEl (consD A) (Vec A)) → Set
ConsUncurriedHyps A P cn = UncurriedHyps (consD A) (Vec A) P cn

nil : (A : Set) → Vec A zero
nil A = init nilT refl

cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A n x xs = init consT (n , x , xs , refl)

nil2 : (A : Set) → Vec A zero
nil2 A = inj VecE (VecC A) nilT

cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons2 A = inj VecE (VecC A) consT

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

module Induction where

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ℕE ℕC _
    (case (λ t → UncurriedHyps (ℕC t) ℕ _ (init t))
      ( (λ u q ih n → n)
      , (λ u m,q ih,tt n → suc (proj₁ ih,tt n))
      , tt
      )
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ℕE ℕC _
    (case (λ t → UncurriedHyps (ℕC t) ℕ _ (init t))
      ( (λ u q ih n → zero)
      , (λ u m,q ih,tt n → add n (proj₁ ih,tt n))
      , tt
      )
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind VecE (VecC A) _
    (case (λ t → UncurriedHyps (VecC A t) (Vec A) _ (init t))
      ( (λ m q ih n ys → subst (λ m → Vec A (add m n)) q ys)
      , (λ m m',x,xs,q ih,tt n ys →
          let m' = proj₁ m',x,xs,q
              x = proj₁ (proj₂ m',x,xs,q)
              q = proj₂ (proj₂ (proj₂ m',x,xs,q))
              ih = proj₁ ih,tt
          in
          subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
        )
      , tt
      )
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind VecE (VecC (Vec A m)) _
    (case (λ t → UncurriedHyps (VecC (Vec A m) t) (Vec (Vec A m)) _ (init t))
      ( (λ n q ih → subst (λ n → Vec A (mult n m)) q (nil A))
      , (λ n n',x,xs,q ih,tt →
          let n' = proj₁ n',x,xs,q
              xs = proj₁ (proj₂ n',x,xs,q)
              q = proj₂ (proj₂ (proj₂ n',x,xs,q))
              ih = proj₁ ih,tt
          in subst  (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
        )
      , tt
      )
    )

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

module GenericElim where

  add : ℕ tt → ℕ tt → ℕ tt
  add = elim ℕE ℕC _
    (λ n → n)
    (λ m ih n → suc (ih n))
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = elim ℕE ℕC _
    (λ n → zero)
    (λ m ih n → add n (ih n))
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = elim VecE (VecC A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ n ys → ys)
    (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = elim VecE (VecC (Vec A m)) (λ n xss → Vec A (mult n m))
    (nil A)
    (λ n xs xss ih → append A m xs (mult n m) ih)

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

error: pathspec 'formalization/agda/Spire/Examples/PropLev.agda' did not match any file(s) known to git


Added unproven theorem.

Added unproven theorem.

------------------------------------------------------------------------------
-- ABP mayor premise
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.MayorPremiseATP where

open import FOTC.Base
open import FOTC.Data.Bool
open import FOTC.Data.Stream
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Terms

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

postulate
  mayorPremise : ∀ {b fs₀ fs₁ is} → Bit b → Fair fs₀ → Fair fs₁ → Stream is →
                 B is (transfer b fs₀ fs₁ is)
-- {-# ATP prove mayorPremise #-}

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


Added existential quantifier using postulates.

Ignore-this: 44b355c6d698e97868bb8a4040303fbf

darcs-hash:20111122164841-3bd4e-384e766b50a58a95260af860c8ad63006d6c06a0.gz

module Existential where

postulate
  D       : Set
  ∃       : (P : D → Set) → Set
  _,_     : {P : D → Set}(d : D) → P d → ∃ P
  ∃-proj₁ : {P : D → Set} → ∃ P → D
  ∃-proj₂ : {P : D → Set}(p : ∃ P) → P (∃-proj₁ p)

error: pathspec 'notes/thesis/logical-framework/Existential.agda' did not match any file(s) known to git


module Data.Nat.Positive where

open import Type
open import Data.Nat renaming (_*_ to _*ℕ_; _+_ to _+ℕ_)

data ℕ⁺ : ★ where
  suc : ℕ → ℕ⁺

one : ℕ⁺
one = suc zero

_+_ : ℕ⁺ → ℕ⁺ → ℕ⁺
suc x + suc y = suc (suc (x +ℕ y))

_*_ : ℕ⁺ → ℕ⁺ → ℕ⁺
suc x * suc y = suc (x +ℕ y +ℕ x *ℕ y)

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


Added recursive equation for addition.

Added recursive equation for addition.

------------------------------------------------------------------------------
-- Definition of addition using a recursive equation
------------------------------------------------------------------------------

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

-- Tested with agda2atp on 17 August 2012.

module FOT.FOTC.Data.Nat.AddRecursiveEquation where

open import FOTC.Base

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

postulate
  _+_  : D → D → D
  +-eq : ∀ m n → m + n ≡ if (iszero₁ m) then n else succ₁ (pred₁ m + n)
{-# ATP axiom +-eq #-}

postulate
  +-0x : ∀ n →   zero    + n ≡ n
  +-Sx : ∀ m n → succ₁ m + n ≡ succ₁ (m + n)
{-# ATP prove +-0x #-}
{-# ATP prove +-Sx #-}

-- $ agda2atp -i. -i ~/fotc/fot/ FOT/FOTC/Data/Nat/AddRecursiveEquation.agda
-- Proving the conjecture in /tmp/FOT/FOTC/Data/Nat/AddRecursiveEquation/23-43-Sx.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/FOT/FOTC/Data/Nat/AddRecursiveEquation/23-43-Sx.tptp
-- Proving the conjecture in /tmp/FOT/FOTC/Data/Nat/AddRecursiveEquation/22-43-0x.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/FOT/FOTC/Data/Nat/AddRecursiveEquation/22-43-0x.tptp

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


flipbased.agda

flipbased.agda

module flipbased where

open import Algebra
import Level as L
open L using () renaming (_⊔_ to _L⊔_)
open import Function using (id; _∘_; const; _$_)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Product using (proj₁; proj₂; _,_; swap; _×_)
open import Data.Bits hiding (replicateM)
open import Data.Vec using (Vec; []; _∷_; take; drop)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡

record M {a} n (A : Set a) : Set a where
  constructor mk
  field
    run : Bits n → A

flip′ : M 1 Bit
flip′ = mk (λ { (b ∷ []) → b })

return′ : ∀ {a} {A : Set a} → A → M 0 A
return′ x = mk (λ _ → x)

pure′ : ∀ {a} {A : Set a} → A → M 0 A
pure′ = return′

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → M m A → M n A
comap f (mk g) = mk (g ∘ f)

weaken : ∀ {m n a} {A : Set a} → M n A → M (m + n) A
weaken {m} = comap (drop m)

weaken′ : ∀ {m n a} {A : Set a} → M n A → M (n + m) A
weaken′ = comap (take _)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → n ≤ m → M n A → M m A
weaken≤ p = comap (take≤ p)

flip : ∀ {n} → M (1 + n) Bit
flip = weaken′ flip′

return : ∀ {n a} {A : Set a} → A → M n A
return = weaken′ ∘ return′

pure : ∀ {n a} {A : Set a} → A → M n A
pure = return

_>>=_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → (A → M n₂ B) → M (n₁ + n₂) B
_>>=_ {n₁} x f = mk (λ bs → M.run (f (M.run x (take _ bs))) (drop n₁ bs))

_>>=′_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → (A → M n₂ B) → M (n₂ + n₁) B
_>>=′_ {n₁} {n₂} rewrite ℕ°.+-comm n₂ n₁ = _>>=_

_>>_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → M n₂ B → M (n₁ + n₂) B
_>>_ {n₁} x y = x >>= const y

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → M n A → M n B
map f x = mk (f ∘ M.run x)
-- map f x ≗ x >>=′ (return {0} ∘ f)

join : ∀ {n₁ n₂ a} {A : Set a} →
       M n₁ (M n₂ A) → M (n₁ + n₂) A
join x = x >>= id

infixl 4 _⊛_
_⊛_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ (A → B) → M n₂ A → M (n₁ + n₂) B
_⊛_ {n₁} mf mx = mf >>= λ f → map (_$_ f) mx

replicateM : ∀ {a} {A : Set a} {n m} → M m A → M (n * m) (Vec A n)
replicateM {n = zero}  _ = pure []
replicateM {n = suc n} {m} x rewrite ℕ°.+-comm (n * m) m = pure {0} _∷_ ⊛ x ⊛ replicateM x

flips : ∀ {n} → M n (Bits n)
-- specialized version for now
flips {zero} = pure []
flips {suc n} = map _∷_ flip′ ⊛ flips {n}

_⟨_⟩_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
        M m A → (A → B → C) → M n B → M (m + n) C
x ⟨ f ⟩ y = map f x ⊛ y

private --move to Data.Nat.NP
  module ⊔° = CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne

record ProgEquiv a ℓ : Set (L.suc ℓ L⊔ L.suc a) where
  infix 2 _≈_
  field
    _≈_ : ∀ {n} {A : Set a} → Rel (M n A) ℓ

  _≋_ : ∀ {n₁ n₂} {A : Set a} → M n₁ A → M n₂ A → Set ℓ
  _≋_ {n₁} {n₂} p₁ p₂ = _≈_ {n = n₁ ⊔ n₂} (weaken≤ (m≤m⊔n _ _) p₁) (weaken≤ (m≤n⊔m _ n₁) p₂)
    where m≤n⊔m : ∀ m n → m ≤ n ⊔ m
          m≤n⊔m m n rewrite ⊔°.+-comm n m = m≤m⊔n m n

record PRG (prgEq : ProgEquiv L.zero L.zero) k n : Set where
  open ProgEquiv prgEq
  field
    prg : Bits k → Bits n
    sec : map prg flips ≋ flips

init : ∀ {k a} {A : Set a} → (Bits k → A) → M k A
init f = map f flips

module Examples (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq
  ex₁ = ∀ {x} → flip′ ⟨ _xor_ ⟩ pure′ x ≈ pure x

  ex₂ = p ≈ map swap p where p = flip′ ⟨ _,_ ⟩ flip′

  ex₃ = ∀ {n} {xs : Bits n} → map (_⊕_ xs) flips ≈ flips

  ex₄ = ∀ {k n} (prg : PRG progEq k n) xs → map (_⊕_ xs ∘ PRG.prg prg) flips ≋ flips

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


Add FFI.JS

Add FFI.JS

module FFI.JS where

open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

data JSType : Set where
  array object number string bool null : JSType

infixr 5 _++_

postulate
    Number      : Set
    readNumber  : String  → Number
    zero        : Number
    one         : Number
    _+_         : Number  → Number  → Number

    _++_        : String → String → String
    reverse     : String → String
    sort        : String → String
    take-half   : String → String
    drop-half   : String → String
    String▹List : String → List Char
    List▹String : List Char → String
    Number▹String : Number → String

    JSValue        : Set
    _+JS_          : JSValue → JSValue → JSValue
    _≤JS_          : JSValue → JSValue → Bool
    _===_          : JSValue → JSValue → Bool
    JSON-stringify : JSValue → String
    JSON-parse     : String → JSValue
    toString       : JSValue → String
    fromString     : String → JSValue
    fromChar       : Char   → JSValue
    fromNumber     : Number → JSValue
    objectFromList : {A : Set} → List A → (A → String) → (A → JSValue) → JSValue
    fromJSArray    : {A : Set} → JSValue → (Number → JSValue → A) → List A
    fromJSArrayString : JSValue → List String
    castNumber     : JSValue → Number
    castString     : JSValue → String
    nullJS         : JSValue
    trueJS         : JSValue
    falseJS        : JSValue
    readJSType     : String → JSType
    showJSType     : JSType → String
    typeof         : JSValue → JSType
    _·[_]          : JSValue → JSValue → JSValue

    onString : {A : Set} (f : String → A) → JSValue → A

    trace : {A B : Set} → String → A → (A → B) → B

{-# COMPILED_JS zero      0 #-}
{-# COMPILED_JS one       1 #-}
{-# COMPILED_JS readNumber Number #-}
{-# COMPILED_JS _+_       function(x) { return function(y) { return x + y; }; }  #-}
{-# COMPILED_JS _++_      function(x) { return function(y) { return x + y; }; }  #-}
{-# COMPILED_JS _+JS_     function(x) { return function(y) { return x + y; }; }  #-}
{-# COMPILED_JS reverse   function(x) { return x.split("").reverse().join(""); } #-}
{-# COMPILED_JS sort      function(x) { return x.split("").sort().join(""); }    #-}
{-# COMPILED_JS take-half function(x) { return x.substring(0,x.length/2); }      #-}
{-# COMPILED_JS drop-half function(x) { return x.substring(x.length/2); }        #-}
{-# COMPILED_JS List▹String function(x) { return (require("libagda").fromList(x, function(y) { return y; })).join(""); } #-}
{-# COMPILED_JS String▹List function(x) { return require("libagda").fromJSArrayString(x.split("")); } #-}
{-# COMPILED_JS fromJSArray       function (ty) { return require("libagda").fromJSArray; } #-}
{-# COMPILED_JS fromJSArrayString require("libagda").fromJSArrayString #-}
{-# COMPILED_JS _≤JS_     function(x) { return function(y) { return x <=  y; }; } #-}
{-# COMPILED_JS _===_     function(x) { return function(y) { return x === y; }; } #-}
{-# COMPILED_JS JSON-stringify JSON.stringify #-}
{-# COMPILED_JS JSON-parse JSON.parse #-}
{-# COMPILED_JS toString   function(x) { return x.toString(); } #-}
{-# COMPILED_JS fromString function(x) { return x; } #-}
{-# COMPILED_JS fromChar   function(x) { return x; } #-}
{-# COMPILED_JS fromNumber function(x) { return x; } #-}
{-# COMPILED_JS Number▹String String #-}
{-# COMPILED_JS castNumber Number #-}
{-# COMPILED_JS castString String #-}
{-# COMPILED_JS nullJS     null #-}
{-# COMPILED_JS trueJS     true #-}
{-# COMPILED_JS falseJS    false #-}
{-# COMPILED_JS typeof     function(x) { return typeof(x); } #-}
{-# COMPILED_JS _·[_]      require("libagda").readProp #-}
{-# COMPILED_JS onString   function(t) { return require("libagda").onString; } #-}
{-# COMPILED_JS trace      require("libagda").trace #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number  → Value
  bool   : Bool → Value
  null   : Value

postulate
    fromValue : Value → JSValue

{-# COMPILED_JS fromValue require("libagda").fromValue #-}

data ValueView : Set₀ where
  array  : List JSValue → ValueView
  object : List (String × JSValue) → ValueView
  string : String → ValueView
  number : Number  → ValueView
  bool   : Bool → ValueView
  null   : ValueView

{-
postulate
    fromJSValue : JSValue → ValueView
-}

fromBool : Bool → JSValue
fromBool true  = trueJS
fromBool false = falseJS

Object = List (String × JSValue)

fromObject : Object → JSValue
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

abstract
  URI = String
  showURI : URI → String
  showURI x = x
  readURI : String → URI
  readURI x = x

JSProc = Proc URI JSValue

data JSCmd : Set where
  server : (ip port  : String)
           (proc     : URI → JSProc)
           (callback : URI → JSCmd) → JSCmd
  client : JSProc → JSCmd → JSCmd

  end          : JSCmd
  assert       : Bool → JSCmd → JSCmd
  console_log  : String → JSCmd → JSCmd
  process_argv : (List String → JSCmd) → JSCmd

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


Added missing file.

Added missing file.

-- Tested with the development version of Agda on 17 October 2012.

-- Testing how the pragmas are saved in the agda interface files (using
-- the program dump-agdai) when they are used from the command-line:

-- $ agda --no-termination-check OptionPragmaCommandLine.agda

-- 17 October 2012. Because the PragmaOption --no-termination-check
-- was used from the command-line it is *not* saved in the interface
-- file.

-- iPragmaOptions = []

module OptionPragmaCommandLine where

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


Reflection.Scoped.Param: binary parametricity on scoped terms

open import Relation.Binary.Logical
open import Data.Nat.Logical
open import Function
open import Opaque
open import Data.Zero
open import Data.One
open import Data.Nat
open import Data.List
open import Data.Sum.NP
import Reflection.NP as R
open R using (Name; Arg; arg; Arg-info; arg-info; Literal; Visibility; visible; hidden; Relevance; relevant; irrelevant; Pattern; argᵛʳ; argʰʳ; absTerm; Abs; module Abs; _,_)
open import Reflection.Scoped as S
open import Reflection.Scoped.Translation as T

module Reflection.Scoped.Param where

data VarKind : Set where
  K₀ K₁ Kᵣ : VarKind

record Env (A B : Set) : Set where
  field
    pVar : VarKind → A → B
    pCon : Name → Name
    pDef : Name → Name
open Env

ε : ∀ {B} → Env 𝟘 B
ε = record { pVar = λ _ ()
           ; pCon = const (opaque "ε.pCon" (quote ε))
           ; pDef = const (opaque "ε.pDef" (quote ε)) }

defDefEnv : Name → Name
defDefEnv (quote ℕ) = quote ⟦ℕ⟧
defDefEnv n         = opaque "defDefEnv" n

defConEnv : Name → Name
defConEnv (quote ℕ.zero) = quote ⟦ℕ⟧.zero
defConEnv (quote ℕ.suc)  = quote ⟦ℕ⟧.suc
defConEnv n              = opaque "defConEnv" n

defEnv : ∀ {B} → Env 𝟘 B
defEnv = record { pVar = λ _ ()
                ; pCon = defConEnv
                ; pDef = defDefEnv }

_⊎𝟙^_ : Set → ℕ → Set
A ⊎𝟙^ 0       = A
A ⊎𝟙^ (suc n) = (A ⊎𝟙^ n) ⊎ 𝟙

inl^ : ∀ n {A} → A → A ⊎𝟙^ n
inl^ 0 x = x
inl^ (suc n) x = inl (inl^ n x)

# : ∀ n {A} → A ⊎𝟙^ (suc n)
# 0       = inr 0₁
# (suc n) = inl (# n)

on-pVar : ∀ {A B C D} → (VarKind → (A → B) → (C → D)) → Env A B → Env C D
on-pVar f Γ = record
  { pVar = λ k → f k (pVar Γ k)
  ; pCon = pCon Γ
  ; pDef = pDef Γ }

_+1 : ∀ {A B} → Env A B → Env A (B ⊎ 𝟙)
_+1 = on-pVar λ k f → inl ∘ f

_+2 : ∀ {A B} → Env A B → Env A (B ⊎𝟙^ 2)
Γ +2 = Γ +1 +1

_+3 : ∀ {A B} → Env A B → Env A (B ⊎𝟙^ 3)
Γ +3 = Γ +2 +1

_↑1 : ∀ {A B} → Env A B → Env (A ⊎ 𝟙) (B ⊎ 𝟙)
_↑1 = on-pVar λ k → Map.↑

_\3 : ∀ {A B} → Env A B → Env (A ⊎ 𝟙) (B ⊎𝟙^ 3)
_\3 = on-pVar λ { K₀ f → inl^ 2 ∘ Map.↑ f
                ; K₁ f → inl ∘ Map.↑ (inl ∘ f)
                ; Kᵣ f → Map.↑ (inl^ 2 ∘ f) }

pW : ∀ {A B}(Γ : Env A B)
       (f : (Δ : Env A (B ⊎𝟙^ 2))(a₀ a₁ : Term (B ⊎𝟙^ 2)) → Term (B ⊎𝟙^ 2))
     → Term B
pW Γ f = lam visible (lam visible (f (Γ +2) (var (# 1) []) (var (# 0) [])))

pTerm  : ∀ {A B}(Γ : Env A B)(t : Term A)  → Term B
pArgs  : ∀ {A B}(Γ : Env A B)(a : Args A)  → Args B
pLit   : ∀ {A B}(Γ : Env A B)(l : Literal) → Term B
pType∈ : ∀ {A B}(Γ : Env A B)(t : Type A)(a₀ a₁ : Term B) → Type B
pTerm∈ : ∀ {A B}(Γ : Env A B)(t : Term A)(a₀ a₁ : Term B) → Term B
pSort∈ : ∀ {A B}(Γ : Env A B)(s : Sort A)(a₀ a₁ : Term B) → Term B
pPi∈   : ∀ {A B}(Γ : Env A B)(t : Arg (Type A))(u : Scope 𝟙 Type A)(a₀ a₁ : Term B) → Term B

pTerm Γ (lam _ t) = lam hidden (lam hidden (lam visible (pTerm (Γ \3) t)))
pTerm Γ (var v args) = var (pVar Γ Kᵣ v) (pArgs Γ args)
pTerm Γ (con c args) = con (pCon Γ c) (pArgs Γ args)
pTerm Γ (def d args) = def (pDef Γ d) (pArgs Γ args)
pTerm Γ (lit l) = pLit Γ l
-- pTerm Γ (pat-lam cs args) = unknown -- TODO
pTerm Γ unknown = unknown

pTerm Γ (sort s) = pW Γ λ Δ → pSort∈ Δ s
pTerm Γ (pi s t) = pW Γ λ Δ → pPi∈ Δ s t

-- pTerm Γ t as' = opaque "impossible: a type cannot be applied to arguments" unknown

pPi∈ Γ (arg (arg-info _ r) s) t a₀ a₁ =
  pi (arg (arg-info hidden r) (Map.tÿpe (pVar Γ K₀) s)) $
  `Π (arg (arg-info hidden r) (Map.tÿpe (pVar (Γ +1) K₁) s)) $
  `Π (arg (arg-info visible relevant)
          (pType∈ (Γ +2) s (var (# 1) []) (var (# 0) [])))
  (pType∈ (Γ \3) t
    (app (Map.term (inl^ 3) a₀) (argᵛʳ (var (# 2) []) ∷ []))
    (app (Map.term (inl^ 3) a₁) (argᵛʳ (var (# 1) []) ∷ [])))

pTerm∈ Γ (sort s) = pSort∈ Γ s
pTerm∈ Γ (pi s t) = pPi∈ Γ s t
pTerm∈ Γ t a₀ a₁ = app (pTerm Γ t) (argᵛʳ a₀ ∷ argᵛʳ a₁ ∷ [])

pLit  Γ l  = unknown -- TODO
pArgs Γ [] = []
pArgs Γ (arg (arg-info _ r) t ∷ as)
  = arg (arg-info hidden  r) (opaque "t0" (Map.term (pVar Γ K₀)) t)
  ∷ arg (arg-info hidden  r) (opaque "t1" (Map.term (pVar Γ K₁)) t)
  ∷ arg (arg-info visible relevant) (pTerm Γ t)
  ∷ pArgs Γ as
pSort∈ Γ (lit n) a₀ a₁ = piᵛʳ (el (lit n) a₀)
                            (`Πᵛʳ (el (lit n) (Map.term inl a₁)) ``★₀)
pSort∈ Γ (set t) _ _ = unknown -- TODO
pSort∈ Γ unknown _ _ = unknown

pType∈ Γ (el (lit n) t) a₀ a₁ = el (lit n) (pTerm∈ Γ t a₀ a₁)
pType∈ Γ (el s t)       _ _  = el unknown unknown

{-
pClause : ∀ {A B} → Env A B → Clause A → Clause B
pClause Γ c = ?
-}

open import Relation.Binary.PropositionalEquality
module Test' where

    param : R.Term → R.Term
    param t = T.SR.term T.SR.ε (pTerm defEnv (T.RS.term T.RS.ε t))
    --  test-lift : lift
    pℕ→ℕ = param (quoteTerm (ℕ → ℕ))
    ⟦ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
    test-pℕ→ℕ : unquote pℕ→ℕ ≡ ⟦ℕ→ℕ⟧
    test-pℕ→ℕ = refl
    pℕ→ℕ→ℕ = param (quoteTerm (ℕ → ℕ → ℕ))
    ⟦ℕ→ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
    test-pℕ→ℕ→ℕ : pℕ→ℕ→ℕ ≡ quoteTerm ⟦ℕ→ℕ→ℕ⟧
    test-pℕ→ℕ→ℕ = refl
    ZERO : Set₁
    ZERO = (A : Set₀) → A
    ⟦ZERO⟧ : ZERO → ZERO → Set₁
    ⟦ZERO⟧ f₀ f₁ =
        {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
        → Aᵣ (f₀ A₀) (f₁ A₁)
    pZERO = param (quoteTerm ZERO)
    q⟦ZERO⟧ = quoteTerm ⟦ZERO⟧
    test-pZERO : pZERO ≡ q⟦ZERO⟧
    test-pZERO = refl
    ID : Set₁
    ID = (A : Set₀) → A → A
    ⟦ID⟧ : ID → ID → Set₁
    ⟦ID⟧ f₀ f₁ =
        {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
        {x₀ : A₀} {x₁ : A₁} (x : Aᵣ x₀ x₁)
        → Aᵣ (f₀ A₀ x₀) (f₁ A₁ x₁)
    pID = param (quoteTerm ID)
    q⟦ID⟧ = quoteTerm ⟦ID⟧
    test-ID-abs : absTerm q⟦ID⟧ ≡ absTerm pID
    test-ID-abs = refl
    test-param : q⟦ID⟧ ≡ pID
    test-param = refl

    test-opaque : opaque "a" "" ≡ opaque "a" ""
    test-opaque = refl
-- -}
-- -}
-- -}
-- -}
-- -}

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


composition-sem-sec-reduction.agda

composition-sem-sec-reduction.agda

module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable
open import flat-funs
open import program-distance
open import one-time-semantic-security
import bit-guessing-game

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

  vnot∘vnot : ∀ {n} → vnot {n} ∘ vnot ≗ id
  vnot∘vnot [] = refl
  vnot∘vnot (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot xs)

open BitsExtra

module CompRed {t} {T : Set t}
               {♭Funs : FlatFuns T}
               (♭ops : FlatFunsOps ♭Funs)
               (ep ep' : EncParams) where
    open FlatFunsOps ♭ops
    open AbsSemSec ♭Funs

    open EncParams ep using (|M|; |C|)
    open EncParams ep' using () renaming (|M| to |M|'; |C| to |C|')

    M = `Bits |M|
    C = `Bits |C|
    M' = `Bits |M|'
    C' = `Bits |C|'

    comp-red : (pre-E : M' `→ M)
               (post-E : C `→ C') → SemSecReduction ep' ep _
    comp-red pre-E post-E (mk A₀ A₁) = mk (A₀ >>> (pre-E *** pre-E) *** idO) (post-E *** idO >>> A₁)

module Comp (ep : EncParams) (|M|' |C|' : ℕ) where
  open EncParams ep

  ep' : EncParams
  ep' = EncParams.mk |M|' |C|' |R|e

  open EncParams ep' using () renaming (Enc to Enc'; M to M'; C to C')

  Tr = Enc → Enc'

  open FlatFunsOps fun♭Ops

  comp : (pre-E : M' → M) (post-E : C → C') → Tr
  comp pre-E post-E E = pre-E >>> E >>> {-weaken≤ |R|e≤|R|e' ∘-} map↺ post-E

module CompSec (prgDist : PrgDist) (ep : EncParams) (|M|' |C|' : ℕ) where
  open PrgDist prgDist
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist
  open AbsSemSec fun♭Funs

  open EncParams ep

  ep' : EncParams
  ep' = EncParams.mk |M|' |C|' |R|e

  open EncParams ep' using () renaming (Enc to Enc'; M to M'; C to C')

  module CompSec' (pre-E : M' → M) (post-E : C → C') where
    open SemSecReductions ep ep'
    open CompRed fun♭Ops ep ep' hiding (M; C)
    open Comp ep |M|' |C|'

    comp-pres-sem-sec : SemSecTr id (comp pre-E post-E)
    comp-pres-sem-sec = comp-red pre-E post-E , λ E A → id

  open SemSecReductions ep ep'
  open CompRed fun♭Ops ep ep' hiding (M; C)
  open CompSec' public
  module Comp' {x y z} = Comp x y z
  open Comp' hiding (Tr)
  comp-pres-sem-sec⁻¹ : ∀ pre-E pre-E⁻¹
                          (pre-E-right-inv : pre-E ∘ pre-E⁻¹ ≗ id)
                          post-E post-E⁻¹
                          (post-E-left-inv : post-E⁻¹ ∘ post-E ≗ id)
                        → SemSecTr⁻¹ id (comp pre-E post-E)
  comp-pres-sem-sec⁻¹ pre-E pre-E⁻¹ pre-E-inv post-E post-E⁻¹ post-E-inv =
    SemSecTr→SemSecTr⁻¹
      (comp pre-E⁻¹ post-E⁻¹)
      (comp pre-E post-E)
      (λ E m R → trans (post-E-inv _) (cong (λ x → run↺ (E x) R) (pre-E-inv _)))
      (comp-pres-sem-sec pre-E⁻¹ post-E⁻¹)

module PostNegSec (prgDist : PrgDist) ep where
  open EncParams ep
  open Comp ep |M| |C| hiding (Tr)
  open CompSec prgDist ep |M| |C|
  open FunSemSec prgDist
  open SemSecReductions ep ep

  post-neg : Tr
  post-neg = comp id vnot

  post-neg-pres-sem-sec : SemSecTr id post-neg
  post-neg-pres-sem-sec = comp-pres-sem-sec id vnot

  post-neg-pres-sem-sec⁻¹ : SemSecTr⁻¹ id post-neg
  post-neg-pres-sem-sec⁻¹ = comp-pres-sem-sec⁻¹ id id (λ _ → refl) vnot vnot vnot∘vnot

module Concrete k where
  open program-distance.Implem k
  module Guess' = bit-guessing-game prgDist
  module FunSemSec' = FunSemSec prgDist
  module CompSec' = CompSec prgDist

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


reverse each line by agda.

reverse each line by agda.

-- agda -c -isrc -i/usr/share/agda-stdlib/ src/Main.agda
module Main where

open import IO
open import Function
open import Coinduction
open import Data.String using (String; toList; fromList)
open import Example

-- main = interact $ unline . reverse . lines
main = run (♯ getContents >>= ♯_ ∘ eachline ( fromList ∘ rev ∘ toList) ) where

  open import Data.Maybe
  open import Data.Product
  open import Data.List using ([]; _∷_; [_])
  open import Data.Colist using (Colist; []; _∷_)
  open import Data.String using (Costring; _++_)
  open import Data.Unit using (⊤; tt)
  open import Category.Monad.Partiality

  takeLine : Costring → Maybe (String × ∞ Costring) ⊥
  takeLine [] = now nothing -- EOF
  takeLine xs = go "" xs where
    go : String → Costring → Maybe (String × ∞ Costring) ⊥
    go acc [] = now (just (acc , ♯ []))
    go acc (x ∷ xs) with fromList [ x ]
    go acc (_ ∷ xs) | "\n" = now (just (acc , xs))
    go acc (_ ∷ xs) | last = later (♯ go (acc ++ last) (♭ xs))

  eachline : (String → String) → Costring → IO ⊤
  eachline f = go ∘ takeLine where
    go : Maybe (String × ∞ Costring) ⊥ → IO ⊤
    go (now nothing) = return tt
    go (now (just (line , xs))) = ♯ putStrLn (f line) >> ♯ go (takeLine (♭ xs))
    go (later x) = ♯ return tt >> ♯ go (♭ x)

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


Search/Derived.agda

Search/Derived.agda

module Search.Derived where

open import Function
open import Data.Nat.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Data.Nat.Properties
open import Search.Type
open import Search.Searchable

sum-lin⇒sum-zero : ∀ {A} → {sum : Sum A} → SumLin sum → SumZero sum
sum-lin⇒sum-zero sum-lin = sum-lin (λ _ → 0) 0

sum-mono⇒sum-ext : ∀ {A} → {sum : Sum A} → SumMono sum → SumExt sum
sum-mono⇒sum-ext sum-mono f≗g = ℕ≤.antisym (sum-mono (ℕ≤.reflexive ∘ f≗g)) (sum-mono (ℕ≤.reflexive ∘ ≡.sym ∘ f≗g))

sum-ext+sum-hom⇒sum-mono : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
sum-ext+sum-hom⇒sum-mono {sum = sum} sum-ext sum-hom {f} {g} f≤°g =
    sum f                         ≤⟨ m≤m+n _ _ ⟩
    sum f + sum (λ x → g x ∸ f x) ≡⟨ ≡.sym (sum-hom _ _) ⟩
    sum (λ x → f x + (g x ∸ f x)) ≡⟨ sum-ext (m+n∸m≡n ∘ f≤°g) ⟩
    sum g ∎ where open ≤-Reasoning

search-swap' : ∀ {A B} cm (μA : Searchable A) (μB : Searchable B) f →
               let open CMon cm
                   sᴬ = search μA _∙_
                   sᴮ = search μB _∙_ in
               sᴬ (sᴮ ∘ f) ≈ sᴮ (sᴬ ∘ flip f)
search-swap' cm μA μB f = search-swap μA sg f (search-hom μB cm)
  where open CMon cm

sum-swap : ∀ {A B} (μA : Searchable A) (μB : Searchable B) f →
           sum μA (sum μB ∘ f) ≡ sum μB (sum μA ∘ flip f)
sum-swap = search-swap' ℕ°.+-commutativeMonoid

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


agda-libjs.agda

agda-libjs.agda

module agda-libjs where
import Control.Process.Type
import FFI.JS
import FFI.JS.BigI
import FFI.JS.Console
import FFI.JS.FS
import FFI.JS.Proc
import FFI.JS.Process
import FFI.JS.Properties
import FFI.JS.SHA1
import FFI.JS.Type

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


hash.agda

hash.agda

module hash where

open import Data.Bits
open import Data.Fin as Fin hiding (_<_; fromℕ) renaming (_+_ to _+f_)
open import Data.Fin.Props
open import Data.Vec hiding (last)
open import Data.Nat.NP
open import Data.Product
open import Data.Bool
open import Relation.Binary.PropositionalEquality.NP
open import Function

record PaddingScheme n (M : Set) : Set where
  constructor mk
  field
    padlen : M → ℕ
    pad : (m : M) → Vec (Bits n) (padlen m)

module Merkle-Damgård₁
  {T : Set}             -- Tag space
  {n}                   -- Block length
  (h : T → Bits n → T) -- Compression function
  where

  H₁ : ∀ {ℓ} → T → Vec (Bits n) ℓ → T
  H₁ tag []       = tag
  H₁ tag (x ∷ xs) = H₁ (h tag x) xs

module Merkle-Damgård₂
  {T : Set}             -- Tag space
  {n}                   -- Block length
  (h : T → Bits n → T) -- Compression function

  (IV : T)              -- Initialization vector

  {M : Set}
  (paddingSch : PaddingScheme n M)
  where

  open Merkle-Damgård₁ h
  open PaddingScheme paddingSch

  H₂ : M → T
  H₂ m = H₁ IV (pad m)

{-
lengthPadding₁ : ∀ {ℓ n} → PaddingScheme n (Bits ℓ)
lengthPadding₁ = mk padlen pad where
  padlen : ∀ {ℓ} → Bits ℓ → ℕ
  padlen xs = {!!}

  pad : ∀ {ℓ n} → (m : Bits ℓ) → Vec (Bits n) (padlen m)
  pad [] = {!!}
  pad (b ∷ bs) = {!!}
-}

-- Fin (2 ^ n) → Bits n

lengthPadding₀ : ∀ {n s} → ℕ → Bits (1 + n + s)
lengthPadding₀ {n} {s} x = 1b ∷ 0… {n} ++ fromℕ {s} x

infixl 6 _ℕ-ℕ'_

-- adapted from Data.Fin, looks better this way:
_ℕ-ℕ'_ : (n : ℕ) → Fin n → ℕ
zero  ℕ-ℕ' ()
suc n ℕ-ℕ' zero   = suc n
suc n ℕ-ℕ' suc i  = n ℕ-ℕ' i

n-m+m≡n : ∀ n (m : Fin n) → (n ℕ-ℕ' m) + Fin.toℕ m ≡ n
n-m+m≡n zero ()
n-m+m≡n (suc n) zero rewrite ℕ°.+-comm n 0 = refl
n-m+m≡n (suc n) (suc m)
   = (suc n ℕ-ℕ' suc m) + Fin.toℕ (suc m) ≡⟨ ℕ°.+-comm (n ℕ-ℕ' m) (Fin.toℕ (suc m)) ⟩
     suc (Fin.toℕ m + (n ℕ-ℕ' m)) ≡⟨ cong suc (ℕ°.+-comm (Fin.toℕ m) (n ℕ-ℕ' m)) ⟩
     suc ((n ℕ-ℕ' m) + Fin.toℕ m) ≡⟨ cong suc (n-m+m≡n n m) ⟩
     suc n ∎ where open ≡-Reasoning

module LengthPadding₁
  {n}
  {s : Fin n}              -- Length of the size part of the padding block
  (sizemsg : Bits (Fin.toℕ s))      -- Usually the size of the message
  {ℓ : Fin n}
  where
  lengthPadding₁ : PaddingScheme n (Bits (Fin.toℕ ℓ))
  lengthPadding₁ = mk padlen pad where
    padlen : ∀ {ℓ} → Bits (Fin.toℕ ℓ) → ℕ
    padlen xs = if suc n <= (Fin.toℕ ℓ + Fin.toℕ s) then 2 else 1

    pad : (m : Bits (Fin.toℕ ℓ)) → Vec (Bits n) (padlen m)
    pad bs with suc n <= (Fin.toℕ ℓ + Fin.toℕ s)
    ... | true = helper (bounded _) bs ∷ block₂ ∷ []
         where
           helper : ∀ {n' n} → n' < n → Bits n' → Bits n
           helper (s≤s p) [] = 1b ∷ 0…
           helper (s≤s p) (b ∷ bs) = b ∷ helper p bs
           block₂ : Bits n
           block₂ = subst Bits (n-m+m≡n n s) (0… {n ℕ-ℕ' s} ++ sizemsg)
    ... | false = helper' ∷ [] where
           helper : ∀ {#0s #m} → Bits #m → Bits (#m + 1 + #0s + Fin.toℕ s)
           helper {p} [] = 1b ∷ 0… {p} ++ sizemsg
           helper (b ∷ bs) = b ∷ helper bs

{-
           pf = Fin.toℕ ℓ + 1 + (n ∸ (Fin.toℕ ℓ + 1 + Fin.toℕ s)) + Fin.toℕ s ≡⟨ ? ⟩
                (n ∸ (Fin.toℕ ℓ + 1 + Fin.toℕ s)) + Fin.toℕ ℓ + 1 + Fin.toℕ s ≡⟨ ? ⟩
                (n ∸ Fin.toℕ (ℓ +f suc s)) + Fin.toℕ ℓ + 1 + Fin.toℕ s ≡⟨ ? ⟩
                (n ∸ Fin.toℕ (ℓ +f suc s)) + Fin.toℕ (ℓ +f suc s) ≡⟨ ? ⟩
                (n ℕ-ℕ' (ℓ +f suc s)) + Fin.toℕ (ℓ +f suc s) ≡⟨ ? ⟩
                n ∎ where open ≡-Reasoning
-}

           postulate helper' : Bits n
           -- helper' = subst Bits pf (helper {n ∸ (Fin.toℕ ℓ + 1 + Fin.toℕ s)} bs)

record WithLast ℓ n : Set where
  constructor mk
  field
    main : Vec (Bits n) ℓ
    {m}  : Fin n
    last : Bits (Fin.toℕ m)

lengthPadding₂ : ∀ {ℓ n} → (∀ m → PaddingScheme n (Bits (Fin.toℕ m))) → PaddingScheme n (WithLast ℓ n)
lengthPadding₂ {ℓ} {n} ps = mk padlen pad where
  padlen : WithLast ℓ n → ℕ
  padlen (mk _ last) = ℓ + PaddingScheme.padlen (ps _) last

  pad : (m : WithLast ℓ n) → Vec (Bits n) (padlen m)
  pad (mk xs last) = xs ++ PaddingScheme.pad (ps _) last

-- lengthPadding₃ : ∀ {ℓ n} → PaddingScheme n (WithLast ℓ n)
-- lengthPadding₃ = lengthPadding₂ (λ _ → LengthPadding₁.lengthPadding₁)

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


flipbased-tree.agda

flipbased-tree.agda

module flipbased-tree where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Vec

import flipbased

data Tree {a} (A : Set a) : ℕ → Set a

↺ : ∀ {a} n (A : Set a) → Set a
↺ = flip Tree

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
data Tree {a} (A : Set a) where
  return↺ : ∀ {c} → A → ↺ c A
  fork    : ∀ {c} → (left right : ↺ c A) → ↺ (suc c) A

runDet : ∀ {a} {A : Set a} → ↺ 0 A → A
runDet (return↺ x) = x

toss : ↺ 1 Bit
toss = fork (return↺ 0b) (return↺ 1b)

map↺ : ∀ {c a b} {A : Set a} {B : Set b} → (A → B) → ↺ c A → ↺ c B
map↺ f (return↺ x) = return↺ (f x)
map↺ f (fork left right) = fork (map↺ f left) (map↺ f right)

weaken≤ : ∀ {m c a} {A : Set a} → m ≤ c → ↺ m A → ↺ c A
weaken≤ p (return↺ x) = return↺ x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

weaken+ : ∀ {m c a} {A : Set a} → ↺ m A → ↺ (c + m) A
weaken+ {m} {c} = weaken≤ (ℕ≤.trans (m≤m+n m c) (ℕ≤.reflexive (ℕ°.+-comm m c)))

join↺ : ∀ {c₁ c₂ a} {A : Set a} → ↺ c₁ (↺ c₂ A) → ↺ (c₁ + c₂) A
join↺ {c} (return↺ x)      = weaken+ {_} {c} x
join↺     (fork left right) = fork (join↺ left) (join↺ right)

open flipbased ↺ toss weaken≤ return↺ map↺ join↺ public

open import Data.Bool
open import Data.Bits
open import Data.Product
open import Relation.Binary.PropositionalEquality

infix 4 _/2+_/2
infix 6 _/2
postulate
  [0,1] : Set
  0/1 : [0,1]
  1/1 : [0,1]
  _/2 : [0,1] → [0,1]
  _/2+_/2 : [0,1] → [0,1] → [0,1]
-- sym _/2+_/2
-- 1 /2+ 1 /2 = 1/1
-- p /2+ p /2 = p
-- p /2+ (1- p) /2 = 1/2

1/2^_ : ℕ → [0,1]
1/2^ zero = 1/1
1/2^ suc n = (1/2^ n)/2

1/2 : [0,1]
1/2 = 1/2^ 1
1/4 : [0,1]
1/4 = 1/2^ 2

postulate
  Pr[_≡_] : ∀ {c a} {A : Set a} → ↺ c A → A → [0,1]

_≈_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈ p₂ = ∀ x → Pr[ p₁ ≡ x ] ≡ Pr[ p₂ ≡ x ]

postulate
  fork-sym : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → fork p₁ p₂ ≈ fork p₂ p₁

  Pr-return-≡ : ∀ {c a} {A : Set a} (x : A) → Pr[ return↺ {c = c} x ≡ x ] ≡ 1/1

  Pr-return-≢ : ∀ {c a} {A : Set a} {x y : A} → x ≢ y → Pr[ return↺ {c = c} x ≡ y ] ≡ 0/1

  Pr-fork : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p q}
            → Pr[ left ≡ x ] ≡ p
            → Pr[ right ≡ x ] ≡ q
            → Pr[ fork left right ≡ x ] ≡ p /2+ q /2

  0/2+p/2≡p/2 : ∀ p → (0/1 /2+ p /2) ≡ p /2

Pr-fork-0 : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p}
            → Pr[ left ≡ x ] ≡ 0/1
            → Pr[ right ≡ x ] ≡ p
            → Pr[ fork left right ≡ x ] ≡ p /2
Pr-fork-0 {p = p} eq₁ eq₂ rewrite sym (0/2+p/2≡p/2 p) = Pr-fork eq₁ eq₂

ex₁ : ∀ x → Pr[ toss ≡ x ] ≡ 1/2
ex₁ 1b = Pr-fork-0 (Pr-return-≢ (λ ())) (Pr-return-≡ 1b)
ex₁ 0b rewrite fork-sym {0} (return↺ 0b) (return↺ 1b) 0b = Pr-fork-0 (Pr-return-≢ (λ ())) (Pr-return-≡ 0b)

postulate
  ex₂ : ∀ x y → Pr[ toss ⟨,⟩ toss ≡ (x , y) ] ≡ 1/2^ 2

  ex₃ : ∀ {n} (x : Bits n) → Pr[ random ≡ x ] ≡ 1/2^ n

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


models/DescFix.agda: generic recursion principle for Desc (not structurally recursive yet)

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

module DescFix where

open import DescTT

aux : (C : Desc)(D : Desc)(P : Mu C -> Set)(x : [| D |] (Mu C)) -> Set
aux C id          P (con y) = P (con y) * aux C C P y
aux C (const K)   P k       = Unit
aux C (prod D D') P (s , t) = aux C D P s * aux C D' P t
aux C (sigma S T) P (s , t) = aux C (T s) P t
aux C (pi S T)    P f       = (s : S) -> aux C (T s) P (f s)

gen : (C : Desc)(D : Desc)(P : Mu C -> Set)
  (rec : (y : [| C |] Mu C) -> aux C C P y -> P (con y))
  (x : [| D |] Mu C) -> aux C D P x
gen C id          P rec (con x) = rec x (gen C C P rec x) , gen C C P rec x
gen C (const K)   P rec k       = Void
gen C (prod D D') P rec (s , t) = gen C D P rec s , gen C D' P rec t
gen C (sigma S T) P rec (s , t) = gen C (T s) P rec t
gen C (pi S T)    P rec f       = \ s -> gen C (T s) P rec (f s)

fix : (D : Desc)(P : Mu D -> Set)
  (rec : (y : [| D |] Mu D) -> aux D D P y -> P (con y))
  (x : Mu D) -> P x
fix D P rec (con x) = rec x (gen D D P rec x)

plus : Nat -> Nat -> Nat
plus (con (Ze , Void)) n = n
plus (con (Suc , m)) n = suc (plus m n)

fib : Nat -> Nat
fib = fix NatD (\ _ -> Nat) help
  where
    help : (m : [| NatD |] Nat) -> aux NatD NatD (\ _ -> Nat) m -> Nat
    help (Ze , x) a = suc ze
    help (Suc , con (Ze , _)) a = suc ze
    help (Suc , con (Suc , con n)) (fib-n , (fib-sn , a)) = plus fib-n fib-sn

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


Added a note about fixed-points.

Added a note about fixed-points.

Ignore-this: 4291537fe55f220577beb75b04f5afd3

darcs-hash:20101004162158-3bd4e-157b42baf139d0cf6b3a57ed82f5e0659a2437a0.gz

{-# OPTIONS --universe-polymorphism #-}

module FixedPoints where

open import Level renaming ( zero to zeroL )

postulate
  D    : Set
  zero : D
  succ : D → D
  _≡_  : Set → Set → Set
  _≣_  : (D → Set) → (D → Set) → Set  -- Equality on predicates.

-- data _≡_ {l : Level}{A : Set l}(x : A) : A → Set l where
--   refl : x ≡ x

-- The pure (i.e. non-inductive) LTC natural numbers.
postulate
  N₁  : D → Set
  zN₁ : N₁ zero
  sN₁ : (n : D) → N₁ n → N₁ (succ n)

-- The LTC natural numbers.
data N₂ : D → Set where
  zN₂ : N₂ zero
  sN₂ : (n : D) → N₂ n → N₂ (succ n)

-- Because N₂ is an inductive data type, we can defined it as the least
-- fixed-point (Fix) of an appropriate functional.
postulate
  Fix  : ((D → Set) → D → Set) → D → Set
  cFix : (f : (D → Set) → D → Set) → Fix f ≣ f (Fix f)

-- A version of FN if D was an inductive type
-- FN : (D → Set) → D → Set
-- FN N zero     = N zero
-- FN N (succ n) = N n → N (succ N)

postulate
  FN     : (D → Set) → D → Set
  zeroFN : (N : D → Set) →        FN N zero     ≡ N zero
  succFN : (N : D → Set)(n : D) → FN N (succ n) ≡ N n → N (succ n)

-- The LTC natural numbers using Fix.
N₃ : D → Set
N₃ = Fix FN

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


Added an old draft.

Added an old draft.

Ignore-this: cb330225429d806e0cc92de5faa8e151

darcs-hash:20110928210550-3bd4e-8d3a9422d2c1cf542cd829e127a667fe09a8463d.gz

------------------------------------------------------------------------------
-- Formalization of Azcel's First Order Theory of Combinators (FOTC) [*]

-- [*] Peter Aczel. The strength of Martin-Löf's intuitionistic type
-- theory with one universe. In S. Miettinen and J. Väänanen, editors,
-- Proc. of the Symposium on Mathematical Logic (Oulu, 1974), Report
-- No. 2, Department of Philosopy, University of Helsinki, Helsinki,
-- pages 1–32, 1977.

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

module Aczel-FOTC where

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

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

-- The universe.
postulate D : Set

-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

postulate
  K S : D
  _·_ : D → D → D

-- Conversion rules
postulate
  Kax : ∀ x y →       K · x · y ≡ x
  Sax : ∀ x y z → S · x · y · z ≡ x · z · (y · z)

error: pathspec 'Draft/old/Aczel-FOTC.agda' did not match any file(s) known to git


Control/Beh.agda

Control/Beh.agda

open import Type
open import Data.One

module Control.Beh where

data Beh (PId E S R I O A : ★) : ★ where
  return : A → Beh PId E S R I O A
  input  : (PId → I → Beh PId E S R I O A) → Beh PId E S R I O A
  output : PId → O → Beh PId E S R I O A → Beh PId E S R I O A
  get    : (S → Beh PId E S R I O A) → Beh PId E S R I O A
  set    : S → Beh PId E S R I O A → Beh PId E S R I O A
  ask    : (E → Beh PId E S R I O A) → Beh PId E S R I O A
  rand   : (R → Beh PId E S R I O A) → Beh PId E S R I O A

module _ {PId E S R I O : ★} where
    end : Beh PId E S R I O 𝟙
    end = return _

module Sim[E=𝟙,R=1] {PId S I O A : ★} where
  E = 𝟙
  R = 𝟙
  Proc = Beh PId E S R I O A
  data _≈_ : (P₀ P₁ : Proc) → ★ where
    input-input :
      ∀ {P₀ P₁ : PId → I → Beh _ _ _ _ _ _ _}
      → (∀ i m → P₀ i m ≈ P₁ i m)
      → input P₀ ≈ input P₁
    output-output :
      ∀ {i m P₀ P₁}
      → P₀ ≈ P₁
      → output i m P₀ ≈ output i m P₁
    return-return :
      ∀ x
      → return x ≈ return x
    nop-ask :
      ∀ {P₀ P₁}
      → P₀ ≈ P₁ _
      → P₀ ≈ ask P₁
    nop-rand :
      ∀ {P₀ P₁}
      → P₀ ≈ P₁ _
      → P₀ ≈ rand P₁
    -- rand rand, ask ask...

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


{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Level.NP
open import Data.Product.NP using (Σ; _×_; _,_) renaming (proj₁ to fst)
open import Data.One using (𝟙)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; ap; coe; coe!)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences
open import Type

module Control.Protocol.InOut where

data InOut : ★ where
  In Out : InOut

dualᴵᴼ : InOut → InOut
dualᴵᴼ In  = Out
dualᴵᴼ Out = In

dualᴵᴼ-involutive : ∀ io → dualᴵᴼ (dualᴵᴼ io) ≡ io
dualᴵᴼ-involutive In = refl
dualᴵᴼ-involutive Out = refl

dualᴵᴼ-equiv : Is-equiv dualᴵᴼ
dualᴵᴼ-equiv = self-inv-is-equiv dualᴵᴼ-involutive

dualᴵᴼ-inj : ∀ {x y} → dualᴵᴼ x ≡ dualᴵᴼ y → x ≡ y
dualᴵᴼ-inj = Is-equiv.injective dualᴵᴼ-equiv

⟦_⟧ᴵᴼ : InOut → ∀{ℓ}(M : ★_ ℓ)(P : M → ★_ ℓ) → ★_ ℓ
⟦_⟧ᴵᴼ In  = Π
⟦_⟧ᴵᴼ Out = Σ

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


Add FFI.JS.SHA1

Add FFI.JS.SHA1

module FFI.JS.SHA1 where

open import Data.String.Base using (String)

postulate SHA1 : String → String
{-# COMPILED_JS SHA1 function (x) { return require("sha1")(x); } #-}

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


ReceiptFreeness.agda

ReceiptFreeness.agda

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

open import Function
open import Type
open import Data.Maybe
open import Data.Fin hiding (_+_)
open import Data.Product renaming (zip to zip-×)
--open import Data.One
open import Data.Two
open import Data.List as L

open import Data.Nat.NP hiding (_==_)

{-
open import Explore.Core
open import Explore.Explorable
open import Explore.Product
open Operators
open import Relation.Binary.PropositionalEquality
-}
--open import Control.Strategy renaming (run to runStrategy)

module Game.ReceiptFreeness
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : ★)
  (CheckedCipherText : ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CheckedCipherText)
  (forget : CheckedCipherText → CipherText)
  (check  : CipherText → Maybe CheckedCipherText)
  (Dec    : let Message = 𝟚 in
            SecKey → CheckedCipherText → Message)

where

data Strategy (Q : ★) (R : Q → ★) (A : ★) : ★ where
  ask  : (q? : Q) (cont : R q? → Strategy Q R A) → Strategy Q R A
  done : A → Strategy Q R A

module _ {Q : ★} {R : Q → ★} (Oracle : (q : Q) → R q) where
  private
    M = Strategy Q R
  run : ∀ {A} → M A → A
  run (ask q? cont) = run (cont (Oracle q?))
  run (done x)      = x

Candidate : ★
Candidate = 𝟚 -- as in the paper: "for simplicity"

alice bob : Candidate
alice = 0₂
bob   = 1₂

-- candidate order
-- also known as LHS or Message
-- represented by who is the first candidate
CO : ★
CO = 𝟚

alice-then-bob bob-then-alice : CO
alice-then-bob = 0₂
bob-then-alice = 1₂

data CO-spec : CO → Candidate → Candidate → ★ where
  01₂ : CO-spec 0₂ 0₂ 1₂
  10₂ : CO-spec 1₂ 1₂ 0₂

alice-then-bob-spec : CO-spec alice-then-bob alice bob
alice-then-bob-spec = 01₂

bob-then-alice-spec : CO-spec bob-then-alice bob alice
bob-then-alice-spec = 10₂

MarkedRHS : ★
MarkedRHS = 𝟚

data MarkedRHS-spec : MarkedRHS → ★ where
  marked-on-first-cell  : MarkedRHS-spec 0₂
  marked-on-second-cell : MarkedRHS-spec 1₂

Receipt : ★
Receipt = SerialNumber × CipherText

CheckedReceipt : ★
CheckedReceipt = SerialNumber × CheckedCipherText

data MarkedRHS? : ★ where
  not-marked : MarkedRHS?
  marked     : MarkedRHS → MarkedRHS?

RHS : ★
RHS = Receipt × MarkedRHS?

CheckedRHS : ★
CheckedRHS = CheckedReceipt × MarkedRHS?

receipt : RHS → Receipt
receipt = proj₁

markedRHS? : RHS → MarkedRHS?
markedRHS? = proj₂

-- Marked when there is a 1
marked? : MarkedRHS? → 𝟚
marked? not-marked = 0₂
marked? (marked x) = 1₂

first-mark : MarkedRHS? → 𝟚
first-mark not-marked = 0₂
first-mark (marked x) = x == 0₂

second-mark : MarkedRHS? → 𝟚
second-mark not-marked = 0₂
second-mark (marked x) = x == 1₂

Ballot : ★
Ballot = CO × RHS

CheckedBallot : ★
CheckedBallot = CO × RHS

Rgb : ★
Rgb = CO × Rₑ

genBallot : Rgb → SerialNumber → PubKey → Ballot
genBallot (rCO , rₑ) sn pk = rCO , ((sn , forget (Enc pk rCO rₑ)) , not-marked)

lhs : Ballot → CO
lhs = proj₁

rhs : Ballot → RHS
rhs = proj₂

BB : ★
BB = List CheckedRHS

Tally : ★
Tally = ℕ × ℕ

data Accept? : ★ where
  accept reject : Accept?

-- In the paper RBB is the returning the Tally and we
-- return the BB, here RTally is returning the Tally
data Q : ★ where
  REB RBB RTally : Q
  RCO            : CheckedRHS → Q
  Vote           : RHS → Q

Resp : Q → ★
Resp REB = Ballot
Resp (RCO x) = CO
Resp (Vote x) = Accept?
Resp RBB = BB
Resp RTally = Tally

Phase : ★ → ★
Phase = Strategy Q Resp

-- A × B   sends A, then behave as B
-- A → B   receives A, then behave as B

RFChallenge : ★ → ★
RFChallenge Next = (𝟚 → Receipt) → Next

Adversary : ★
Adversary = Rₐ → PubKey → Phase -- Phase[I]
                           (RFChallenge
                             (Phase -- Phase[II]
                               𝟚)) -- Adversary guess of whether the vote is for alice

-- TODO adversary validity

tallyMarkedRHS : CO → MarkedRHS → Tally
tallyMarkedRHS co m = 𝟚▹ℕ for-alice , 𝟚▹ℕ (not for-alice)
  where for-alice = co == m

1:alice-0:bob 0:alice-1:bob : Tally
1:alice-0:bob = 1 , 0
0:alice-1:bob = 0 , 1

data TallyMarkedRHS-spec : CO → MarkedRHS → Tally → ★ where
  -- CO is alice-then-bob
  c1 : TallyMarkedRHS-spec alice-then-bob{-0-} 0₂ 1:alice-0:bob
  c2 : TallyMarkedRHS-spec alice-then-bob{-0-} 1₂ 0:alice-1:bob

  -- CO is bob-then-alice
  c3 : TallyMarkedRHS-spec bob-then-alice{-1-} 0₂ 0:alice-1:bob
  c4 : TallyMarkedRHS-spec bob-then-alice{-1-} 1₂ 1:alice-0:bob

tallyMarkedRHS-ok : ∀ co m → TallyMarkedRHS-spec co m (tallyMarkedRHS co m)
tallyMarkedRHS-ok 1₂ 1₂ = c4
tallyMarkedRHS-ok 1₂ 0₂ = c3
tallyMarkedRHS-ok 0₂ 1₂ = c2
tallyMarkedRHS-ok 0₂ 0₂ = c1

tallyCheckedRHS : SecKey → CheckedRHS → Tally
tallyCheckedRHS sk (r , not-marked) = 0 , 0
tallyCheckedRHS sk ((sn , co) , marked x) = tallyMarkedRHS (Dec sk co) x

tally : SecKey → BB → Tally
tally sk bb = L.foldr (zip-× _+_ _+_) (0 , 0) (L.map (tallyCheckedRHS sk) bb)

R : ★
R = Rₖ × Rₐ × (Fin {!!} → Rgb) × {!!}

-- Return
Game : ★
Game = Adversary → R → 𝟚

module _ (sk : SecKey) (pk : PubKey) (rgb : Rgb) (sn : SerialNumber) (bb : BB) where
    Oracle : (q : Q) → Resp q
    Oracle REB = genBallot rgb sn pk
    Oracle RBB = bb
    Oracle RTally = tally sk bb
    Oracle (RCO ((sn , receipt) , m?)) = Dec sk receipt

    -- do we check if the sn is already here?
    Oracle (Vote ((sn , receipt) , m?)) = case check receipt of λ { (just x) → accept ; nothing → reject }

    OracleBB : Q → BB
    OracleBB REB = bb
    OracleBB RBB = bb
    OracleBB RTally = bb
    OracleBB (RCO _) = bb

    -- do we check if the sn is already here?
    OracleBB (Vote ((sn , receipt) , m?)) = case check receipt of λ { (just x) → ((sn , x) , m?) ∷ bb ; nothing → bb }

⅁ : Game
⅁ A (rₖ , rₐ , rgbs , _) =
  -- setup
  case KeyGen rₖ of λ
  { (pk , sk) →
    let bb = [] in
    let Asetup = A rₐ pk in
    let Aphase[I] = run (Oracle sk pk (rgbs {!!}) {!!} {!bb!}) Asetup in
    {!!}
  }
-- -}
-- -}
-- -}
-- -}

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


module Category.Applicative.NP where

open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat
open import Category.Applicative public hiding (module RawApplicative)

module RawApplicative {f} {F : Set f → Set f}
                      (app : RawApplicative F) where
    open Category.Applicative.RawApplicative app public

    replicateM : ∀ {n A} → F A → F (Vec A n)
    replicateM {zero}  _ = pure []
    replicateM {suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

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


[ #22 ] Added example.

[ #22 ] Added example.

module Issue22 where

postulate
  D   : Set
  _≡_ : D → D → Set
  d e : D

foo : ∀ x → x ≡ x
foo x = bar
  where
  postulate
    d≡e : d ≡ e

  postulate
    bar : x ≡ x
  {-# ATP prove bar d≡e #-}

-- $ apia Bug.agda
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/Apia/Utils/AgdaAPI/Interface.hs:307

-- The error occurs because the dead code analysis removes `d≡e` from
-- the the interfase file.

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


+GenChal

+GenChal

{-# OPTIONS --without-K --copatterns #-}
open import Type
open import Function
open import Data.One
open import Data.Two
open import Data.Product

open import Control.Protocol.Core

module Game.GenChal
  -- could be Public Key
  (Public    : ★)

  -- could be:
  --   * CPA:  Query _ = 𝟘
  --   * CCA2: Query _ = Ciphertext
  --   * CCA1: Query = [0: Ciphertext 1: 𝟘 ]
  (Query : 𝟚 → ★)

  -- could be:
  --   * CPA:  Response _ ()
  --   * CCA2: Response _ _ = Message
  --   * CCA1: Response 0₂ _ = Message
  --           Response 1₂ ()
  (Response : {i : 𝟚} → Query i → ★)

  -- could be:
  --   * CPA/CCA2/CCA1: ChallengeInput = Message × Message
  (ChallengeInput : ★)

  -- could be:
  --   * CPA/CCA2/CCA1: Challenge = Ciphertext
  --   * CCA2†: Challenge = Ciphertext × Ciphertext
  (Challenge : ★)

  (ContProto : Proto)
  where

Query₀ = Query 0₂
Query₁ = Query 1₂

Round : (phase# : 𝟚) → Proto → Proto
Round i = Server' (Query i) Response

Round₀ = Round 0₂
Round₁ = Round 1₂

Chal : Proto → Proto
Chal X = ChallengeInput →' (Challenge ×' X)

-- challenger implement this
Main : Proto
Main = Public ×' Round₀ (Chal (Round₁ ContProto))

module Implementation
  -- could be Private Key
  (Private   : ★)

  -- could be 𝟚 for IND games
  (Secret    : ★)

  {X}
  (cont      : El X ContProto)

  {- {OracleRand : {i : 𝟚} (q : Query i) → ★} -}
  (oracle    : Private → {i : 𝟚} (q : Query i) → {-OracleRand q →-} Response q)
  {ChalRand : ★}
  (challenge : Public → Secret → ChallengeInput → ChalRand → Challenge)
  where

    module _ (b : Secret)(pk : Public)(sk : Private)(chal-rand : ChalRand) where

      module _ {i : 𝟚}{A}(ContDone : A) where
        service : Server (Query i) Response A
        srv-ask  service q = oracle sk q {-{!!}-} , service
        srv-done service   = ContDone

      phase₁ : Server Query₁ Response (El X ContProto)
      phase₁ = service cont

      exchange : El X (Chal (Round₁ ContProto))
      exchange m = challenge pk b m chal-rand , phase₁

      phase₀ : Server Query₀ Response (El X (Chal (Round₁ ContProto)))
      phase₀ = service exchange

      main : El X Main
      main = pk , phase₀

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


Deriving N-ary parametricity using the reflection API

open import Function
open import Opaque
open import Type
open import Data.Zero
open import Data.One hiding (_≟_)
open import Data.Two hiding (_≟_)
open import Data.Two.Logical
open import Data.Nat hiding (_≟_)
open import Data.Fin using (Fin; zero; suc; toℕ)
open import Data.Vec using (Vec; []; _∷_; replicate; tabulate; allFin; reverse; _⊛_; toList) renaming (map to vmap)
open import Data.Nat.Logical hiding (_≟_) renaming (zero to ⟦zero⟧; suc to ⟦suc⟧)
open import Data.List hiding (replicate; reverse)
open import Data.Sum.NP
open import Reflection.NP
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open import Relation.Nullary.NP
open import Relation.Binary.PropositionalEquality.NP

module Param where

module Revelator (tyH : Type) where
    tm : Term → ℕ → Args → Term
    tm (pi (arg (arg-info v _) t₁) (el _ t₂)) y as = lam visible (tm t₂ (suc y) (mapVarArgs suc as ++ argʳ v (var 0 []) ∷ []))
    tm (var x args) = var
    tm (def f args) = var
    tm (sort s)     = var
    tm unknown _ _ = unknown
    tm (con c args) _ _ = opaque "revealator/tm/con: impossible" unknown
    tm (lam v ty) _ _ = opaque "revealator/tm/lam: impossible" unknown
    tm (lit l) _ _ = opaque "revealator/tm/lit: impossible" unknown
    tm (pat-lam cs args) _ _ = opaque "revealator/tm/pat-lam: TODO" unknown
    tÿpe : Type
    tÿpe = tyH `→ᵛʳ Reveal-args.tÿpe tyH
    term : Term
    term = lam visible (tm (unEl tyH) 0 [])
    fun : FunctionDef
    fun = fun-def tÿpe (clause (argᵛʳ var ∷ []) (tm (unEl tyH) 0 []) ∷ [])

data VarKind (n : ℕ) : Set where
  Kᵢ : Fin n → VarKind n
  Kᵣ : VarKind n

record Env (n : ℕ)(A B : Set) : Set where
  field
    pVar : VarKind n → A → B
    pCon : Name → Name
    pDef : Name → Name
open Env

Env' = λ n → Env n ℕ ℕ

ε : ∀ n → Env' n
ε n = record { pVar = λ _ _ → opaque "ε.pVar" 0
             ; pCon = const (opaque "ε.pCon" (quote ε))
             ; pDef = const (opaque "ε.pDef" (quote ε)) }

extDefEnv : ((Name → Name) → (Name → Name)) → ∀ {n A B} → Env n A B → Env n A B
extDefEnv ext Γ = record Γ { pDef = ext (pDef Γ) }

ext1DefEnv : (old new : Name) → ∀ {n A B} → Env n A B → Env n A B
ext1DefEnv old new = extDefEnv (λ f x → [yes: (λ _ → new) no: (λ _ → f x) ]′ (x ≟-Name old))

↑pVar : ℕ → (ℕ → ℕ) → (ℕ → ℕ)
↑pVar zero = id
↑pVar (suc n) = ↑pVar n ∘ mapVar↑

on-pVar : ∀ {n A B C D} → (VarKind n → (A → B) → (C → D)) → Env n A B → Env n C D
on-pVar f Γ = record
  { pVar = λ k → f k (pVar Γ k)
  ; pCon = pCon Γ
  ; pDef = pDef Γ }

_+↑ : ∀ {n} → Env' n → Env' n
_+↑ {n} = on-pVar goK
  where
    goK : VarKind n → (ℕ → ℕ) → (ℕ → ℕ)
    goK (Kᵢ x) f = _+_ (n ∸ toℕ x) ∘ ↑pVar 1 (_+_ (toℕ x) ∘ f)
    goK Kᵣ     f = ↑pVar 1 (_+_ n ∘ f)

_+'_ : ∀ {w} → Env' w → ℕ → Env' w
Γ +' n = record { pVar = λ k → _+_ n ∘ pVar Γ k ; pCon = pCon Γ ; pDef = pDef Γ }

_+1 : ∀ {w} → Env' w → Env' w
Γ +1 = Γ +' 1

pattern `⟦zero⟧  = con (quote ⟦ℕ⟧.zero) []
pattern `⟦suc⟧ t = con (quote ⟦ℕ⟧.suc) (argᵛʳ t ∷ [])
pNat : ℕ → Term
pNat zero    = `⟦zero⟧
pNat (suc n) = `⟦suc⟧ (pNat n)

lam^ : ℕ → Visibility → Term → Term
lam^ zero    v x = x
lam^ (suc n) v x = lam v (lam^ n v x)

lam∈ : ∀ {n} → Env' n → (f : Env' n → Vec Term n → Term) → Term
lam∈ {n} Γ f = lam^ n visible (f (Γ +' n) (reverse (tabulate (λ x → var (toℕ x) []))))

app-tabulate : ∀ {n a} {A : Set a} → (Fin n → A) → List A → List A
app-tabulate {zero}  f xs = xs
app-tabulate {suc n} f xs = f zero ∷ app-tabulate (f ∘ suc) xs

p^args : ∀ {n A} → Relevance → (Fin n → A) → A → List (Arg A) → List (Arg A)
p^args r f x args = app-tabulate (λ k → argʰ r (f k)) (argᵛʳ x ∷ args)

p^lam : ℕ → Term → Term
p^lam n t = lam^ n hidden (lam visible t)

{-
pi^ : ℕ → Arg Type → Type → Type
pi^ zero    i t = t
pi^ (suc n) i t = `Π i (pi^ n i t)
-}

allVarsFrom : ∀ n → ℕ → Vec Term n
allVarsFrom zero    k = []
allVarsFrom (suc n) k = var (k + n) [] ∷ allVarsFrom n k

p3pi∈ : ∀ {n} (Γ : Env' n) (r : Relevance)
          (s : Type)
          (t : Env' n → Vec Term n → Type)
          (u : Env' n → Vec Term n → Type) → Term
p3pi∈ {n} Γ r s t u = unEl (go Γ (allFin n))
  where
  go : ∀ {m} → Env' n → Vec (Fin n) m → Type
  go Δ [] =
      `Πᵛʳ (t Δ (allVarsFrom n 0)) (u (Γ +↑) (allVarsFrom n 1))
  go Δ (x ∷ xs) =
      `Π (argʰ r (mapVarType (pVar Δ (Kᵢ x)) s))
         (go (Δ +1) xs)

pSort∈ : ∀ {n} → Sort → Vec Term n → Type
pSort∈ s = go 0
  where
    go : ℕ → ∀ {n} → Vec Term n → Type
    go k []       = el (suc-sort s) (sort s)
    go k (t ∷ ts) = `Πᵛʳ (mapVarType (_+_ k) (el s t)) (go (suc k) ts)

pEnvPats : List (Arg Pattern) → ∀ {n} → Env' n → Env' n
pEnvPat : Pattern → ∀ {n} → Env' n → Env' n

pEnvPat (con _ pats) = pEnvPats pats
pEnvPat dot = id
pEnvPat var = _+↑
pEnvPat (lit _) = id
pEnvPat (proj _) = opaque "pEnvPats/proj" id
pEnvPat absurd = id

pEnvPats [] = id
pEnvPats (arg i p ∷ ps) = pEnvPat p ∘ pEnvPats ps

pPats : ∀ {n} → Env' n → List (Arg Pattern) → List (Arg Pattern)
pPat  : ∀ {n} → Env' n → Arg Pattern → List (Arg Pattern)

pPats Γ [] = []
pPats Γ (pat ∷ ps) = pPat Γ pat ++ pPats Γ ps

nodot = var

pPat {n} Γ (arg (arg-info _ r) (con c pats))
  = p^args {n} r (const nodot) (con (pCon Γ c) (pPats Γ pats)) []
pPat {n} Γ (arg (arg-info _ r) dot)
  = p^args {n} r (const dot) dot []
pPat {n} Γ (arg (arg-info _ r) var)
  = p^args {n} r (const var) var []
pPat {n} Γ (arg i (lit (nat l))) = opaque "pPat/lit/nat" []
pPat {n} Γ (arg (arg-info _ r) (lit l))
  = p^args {n} r go
                 (con (quote refl) []) []
      where
        go : ∀ {n} → Fin n → Pattern
        go zero = lit l
        go (suc _) = nodot
pPat {n} Γ (arg (arg-info _ r) absurd) = p^args {n} r (const var) absurd []
pPat {n} Γ (arg i (proj p)) = opaque "pPat/proj" []

pLit : Literal → Term
pLit (nat n) = pNat n
pLit _       = con (quote refl) []

pTerm  : ∀ {n} → Env' n → Term → Term
pArgs  : ∀ {n} → Env' n → Args → Args
pType∈ : ∀ {n} → Env' n → Type             → Vec Term n → Type
pTerm∈ : ∀ {n} → Env' n → Term             → Vec Term n → Term
pPi∈   : ∀ {n} → Env' n → Arg Type → Type → Vec Term n → Term

pType∈ Γ (el s t) as = el s (pTerm∈ Γ t as)

pTerm {n} Γ (lam _ t) = p^lam n (pTerm (Γ +↑) t)
pTerm Γ (var v args)  = var (pVar Γ Kᵣ v) (pArgs Γ args)
pTerm Γ (con c args)  = con (pCon Γ c) (pArgs Γ args)
pTerm Γ (def d args)  = def (pDef Γ d) (pArgs Γ args)
pTerm Γ (lit l)       = pLit l
pTerm Γ (pat-lam _ _) = opaque "pTerm/pat-lam" unknown
pTerm Γ unknown       = unknown

pTerm Γ (sort s) = lam∈ Γ λ _ as → unEl (pSort∈ s as)
pTerm Γ (pi s t) = lam∈ Γ λ Δ → pPi∈ Δ s t

pPi∈ {n} Γ (arg (arg-info _ r) s) t as =
  p3pi∈ Γ r s (λ Δ → pType∈ Δ s) (λ Δ vs → pType∈ Δ t
    (vmap (λ a v → app (mapVar (_+_ (suc n)) a) (argᵛʳ v ∷ [])) as ⊛ vs))

pTerm∈ Γ (sort s) as = unEl (pSort∈ s as)
pTerm∈ Γ (pi s t) = pPi∈ Γ s t
pTerm∈ Γ t as = app (pTerm Γ t) (toList (vmap argᵛʳ as))

pArgs Γ [] = []
pArgs Γ (arg (arg-info _ r) t ∷ as)
  = p^args r (λ k → mapVar (pVar (Γ +↑) (Kᵢ k)) t) (pTerm Γ t) (pArgs Γ as)

pClause  : ∀ {n} → Env' n → Clause → Clause
pClauses : ∀ {n} → Env' n → Clauses → Clauses

pClause Γ (clause pats body) = clause (pPats Γ pats) (pTerm (pEnvPats pats Γ) body)
pClause Γ (absurd-clause pats) = absurd-clause (pPats Γ pats)

pClauses Γ [] = []
pClauses Γ (c ∷ cs) = pClause Γ c ∷ pClauses Γ cs

pFunDef : ∀ {n} → Env' n → Name → FunctionDef → FunctionDef
pFunDef Γ d (fun-def t cs)
  = fun-def (pType∈ Γ t (replicate (def d []))) (pClauses Γ cs)

postulate
  IMPOSSIBLE : FunctionDef

pFunName : ∀ {n} → Env' n → Name → FunctionDef
pFunName Γ x with definition x
... | function d = pFunDef Γ x d
... | _ = IMPOSSIBLE -- opaque "pFunName" (fun-def {!!} {!!})

pFunNameRec : ∀ {n} → Env' n → (x xₚ : Name) → FunctionDef
pFunNameRec Γ x xₚ = pFunName (ext1DefEnv x xₚ Γ) x

{-
pDefinition : Env' 2 → Name → Definition → Definition
pDefinition Γ n (function x) = function {!pFunDef!}
pDefinition Γ n (data-type x) = {!!}
pDefinition Γ n (record′ x) = {!!}
pDefinition Γ n constructor′ = {!!}
pDefinition Γ n axiom = {!!}
pDefinition Γ n primitive′ = {!!}

pName : Env' 2 → Name → Definition
pName Γ n = pDefinition Γ n (definition n)
-}

open import Data.String using (String)
open import Data.Float  using (Float)

infixr 1 _[₀→₀]_
_[₀→₀]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₀} (Bₚ : B → Set₀)
            (f : A → B) → Set₀
_[₀→₀]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₀→₁]_
_[₀→₁]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₀→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₁]_
_[₁→₁]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₁→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₂]_
_[₁→₂]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₂} (Bₚ : B → Set₂)
            (f : A → B) → Set₂
_[₁→₂]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

[[Set₀]] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
[[Set₀]] = λ A → A [₀→₁] [Set₀]

{-
EqEnv = {!!}
EqRes = {!!}

eqTerm : EqEnv → Term → Term → EqRes
eqTerm Γ (var x args) (var x₁ args₁) = {!!}
eqTerm Γ (def f₀ args₀) (def f₁ args₁) = {!!}
eqTerm Γ (con c₀ args₀) (con c₁ args₁) = {!!}
eqTerm Γ (lam v t) (lam v' t') = {!!}
eqTerm Γ (pi t₁ t₂) (pi u₁ u₂) = {!!}
eqTerm Γ (sort s₀) (sort s₁) = {!!}
eqTerm Γ (lit l₀) (lit l₁) = {!!}
eqTerm Γ unknown unknown = {!!}
eqTerm Γ (def f args) u = {!!}
--eqTerm Γ (pat-lam cs args) u = {!!}
eqTerm _ _ = ?
-}

import Reflection.Simple as Si
open Si using (var;con;def;lam;pi;sort;unknown;simple;showTerm)

p[Set₀] = pFunName (ε 1) (quote [Set₀])
q[[Set₀]] = definition (quote [[Set₀]]) -- quoteTerm [[Set₀]]
test-type-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀] ≡ unquote (unEl (Get-type.from-fun-def p[Set₀]))
test-type-p[Set₀] = refl
test-term-p[Set₀] : quoteTerm [[Set₀]] ≡ Get-term.from-fun-def p[Set₀]
test-term-p[Set₀] = refl
unquoteDecl u-p[Set₀] = p[Set₀]

{-
p-[→]-type = unEl (Get-type.from-fun-def p-[→])
p-[→]' : ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
                {Aₚ : A → Set₀} (A₁ₚ : {x : A} → A₀ₚ x → Set₀)
                {B : Set₀}       (B₀ₚ : B → Set₀)
                {Bₚ : B → Set₀} (B₁ₚ : {x : B} → B₀ₚ x → Set₀)
                {f : A → B}    (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
              → (Aₚ [₀→₀] Bₚ) f →
              {C : Set₀} → (C → Set₀) → {t : {!!}} → (A → B) → Set₀ -- _[₀→₀]_ {A} {-A₀ₚ} {Aₚ-} {-A₁ₚ-} {!!} {B} {!!} {-B₀ₚ} B₁ₚ-} f -- fₚ
p-[→]' = {!unquote (Get-term.from-fun-def p-[→])!}
-}

[String] : [★₀] String
[String] _ = 𝟙

[Float] : [★₀] Float
[Float] _ = 𝟙

⟦String⟧ : ⟦★₀⟧ String String
⟦String⟧ = _≡_

⟦Float⟧ : ⟦★₀⟧ Float Float
⟦Float⟧ = _≡_

data [𝟚] : [Set₀] 𝟚 where
  [0₂] : [𝟚] 0₂
  [1₂] : [𝟚] 1₂

data [ℕ] : [Set₀] ℕ where
  [zero] : [ℕ] zero
  [suc]  : ([ℕ] [→] [ℕ]) suc

[pred] : ([ℕ] [→] [ℕ]) pred
[pred] [zero]     = [zero]
[pred] ([suc] xₚ) = xₚ

revealed-[→] = Reveal-args.nåme (quote _[₀→₀]_)
unquoteDecl revealed-[→]' = un-function revealed-[→]

unquoteDecl revelator-[→] = Revelator.fun (type (quote _[₀→₀]_))

{-
p-[→] = pFunName (ε 1) (quote _[₀→₀]_)
p-[→]-type = unEl (Get-type.from-fun-def p-[→])

p-[→]' : (x0 : Set) → (x1 : (x1 : x0) → Set) → (x2 : (x2 : x0) → Set) → (x3 : (x3 : x0) → (x4 : x1 x3) → (x5 : x2 x3) → Set) → (x4 : Set) → (x5 : (x5 : x4) → Set) → (x6 : (x6 : x4) → Set) → (x7 : (x7 : x4) → (x8 : x5 x7) → (x9 : x6 x7) → Set) → (x8 : (x8 : x0) → x4) → (x9 : (x9 : x0) → (x10 : x1 x9) → x5 (x8 x9)) → (x10 : _[₀→₀]_ {x0} x2 {x4} x6 x8) → Set
{-
p-[→]' : ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
                {Aₚ : A → Set₀} (A₁ₚ : {x : A} → A₀ₚ x → Set₀)
                {B : Set₀}       (B₀ₚ : B → Set₀)
                {Bₚ : B → Set₀} (B₁ₚ : {x : B} → B₀ₚ x → Set₀)
                {f : A → B}    (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
              → (Aₚ [₀→₀] Bₚ) f →
              {C : Set₀} → (C → Set₀) → {t : {!!}} → (A → B) → Set₀ -- _[₀→₀]_ {A} {-A₀ₚ} {Aₚ-} {-A₁ₚ-} {!!} {B} {!!} {-B₀ₚ} B₁ₚ-} f -- fₚ
-}
p-[→]' = {!unquote (Get-term.from-fun-def p-[→])!}

test : {!showTerm p-[→]-type!}
test = {!unquote (Get-term.from-fun-def p-[→])!}
{-
-- unquoteDecl _[[→]]_ = p-[→]

{-
data [[ℕ]] : [[Set₀]] [ℕ] [ℕ] where
  [[zero]] : [[ℕ]] [zero] [zero]
  [[suc]]  : ([[ℕ]] [[→]] [[ℕ]]) [suc] [suc]
-}

defDefEnv1 : Name → Name
defDefEnv1 (quote 𝟚) = quote [𝟚]
defDefEnv1 (quote ℕ) = quote [ℕ]
defDefEnv1 (quote String) = quote [String]
defDefEnv1 (quote Float) = quote [Float]
defDefEnv1 (quote ★₀) = quote [★₀]
defDefEnv1 (quote ★₁) = quote [★₁]
defDefEnv1 n         = opaque "defDefEnv1" n

defConEnv1 : Name → Name
defConEnv1 (quote 0₂) = quote [0₂]
defConEnv1 (quote 1₂) = quote [1₂]
defConEnv1 (quote ℕ.zero) = quote [zero]
defConEnv1 (quote ℕ.suc)  = quote [suc]
defConEnv1 n              = opaque "defConEnv1" n

defDefEnv2 : Name → Name
defDefEnv2 (quote 𝟚) = quote ⟦𝟚⟧
defDefEnv2 (quote ℕ) = quote ⟦ℕ⟧
defDefEnv2 (quote String) = quote ⟦String⟧
defDefEnv2 (quote Float) = quote ⟦Float⟧
defDefEnv2 (quote ★₀) = quote ⟦★₀⟧
defDefEnv2 (quote ★₁) = quote ⟦★₁⟧
defDefEnv2 n         = opaque "defDefEnv" n

defConEnv2 : Name → Name
defConEnv2 (quote 0₂) = quote ⟦0₂⟧
defConEnv2 (quote 1₂) = quote ⟦1₂⟧
defConEnv2 (quote ℕ.zero) = quote ⟦ℕ⟧.zero
defConEnv2 (quote ℕ.suc)  = quote ⟦ℕ⟧.suc
defConEnv2 n              = opaque "defConEnv2" n

defEnv1 : Env' 1
defEnv1 = record { pVar = λ _ _ → opaque "defEnv1.pVar" 0
                 ; pCon = defConEnv1
                 ; pDef = defDefEnv1 }

defEnv2 : Env' 2
defEnv2 = record { pVar = λ _ _ → opaque "defEnv2.pVar" 0
                 ; pCon = defConEnv2
                 ; pDef = defDefEnv2 }

{-
_⟦+⟧_ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) _+_ _+_
zero  ⟦+⟧ n = n
suc m ⟦+⟧ n = suc (m ⟦+⟧ n)
-}

_/2 : ℕ → ℕ
zero        /2 = zero
suc zero    /2 = zero
suc (suc n) /2 = suc (n /2)

_⟦/2⟧ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _/2 _/2
⟦zero⟧         ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ ⟦zero⟧    ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ (⟦suc⟧ n) ⟦/2⟧ = ⟦suc⟧ (n ⟦/2⟧)

_+ℕ_ : ℕ → ℕ → ℕ
zero  +ℕ n = n
suc m +ℕ n = suc (m +ℕ n)

_⟦+ℕ⟧_ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _+ℕ_ _+ℕ_
⟦zero⟧  ⟦+ℕ⟧ n = n
⟦suc⟧ m ⟦+ℕ⟧ n = ⟦suc⟧ (m ⟦+ℕ⟧ n)

⟦⟦Set₀⟧⟧ : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
⟦⟦Set₀⟧⟧ = λ A₀ A₁ → A₀ ⟦₀→₁⟧ A₁ ⟦₀→₁⟧ ⟦Set₀⟧

⟦⟦Set₀⟧⟧' : {x₁ x₂ : Set} (xᵣ : x₁ → x₂ → Set) {x₃ : Set} {x₄ : Set}
            (xᵣ₁ : x₃ → x₄ → Set) →
            (x₁ → x₃ → Set) → (x₂ → x₄ → Set) → Set₁
⟦⟦Set₀⟧⟧' = λ A₀ A₁ f₁ f₂ →
  ∀ {x₁} {x₂} (xᵣ : A₀ x₁ x₂)
    {x₃} {x₄} (xᵣ₁ : A₁ x₃ x₄) →
    f₁ x₁ x₃ → f₂ x₂ x₄ → Set

-- Since quoteTerm normalises
test-⟦⟦Set₀⟧⟧ : quoteTerm ⟦⟦Set₀⟧⟧ ≡ quoteTerm ⟦⟦Set₀⟧⟧'
test-⟦⟦Set₀⟧⟧ = refl

test-⟦⟦Set₀⟧⟧-type : unquote (unEl (type (quote ⟦⟦Set₀⟧⟧))) ≡ unquote (unEl (type (quote ⟦⟦Set₀⟧⟧')))
test-⟦⟦Set₀⟧⟧-type = refl

pSet₀ = pTerm defEnv2 `★₀
ppSet₀ = pTerm defEnv2 pSet₀
p⟦Set₀⟧ = pFunName defEnv2 (quote ⟦Set₀⟧)
test-pSet₀ : pSet₀ ≡ quoteTerm ⟦Set₀⟧
test-pSet₀ = refl
test-ppSet₀ : ppSet₀ ≡ quoteTerm ⟦⟦Set₀⟧⟧
test-ppSet₀ = refl
test-ppSet₀'' : ppSet₀ ≡ Get-term.from-fun-def p⟦Set₀⟧
test-ppSet₀'' = refl

-- unquoteDecl ⟦⟦Set₀⟧⟧'' = p⟦Set₀⟧

data ⟦⟦𝟚⟧⟧ : (⟦⟦Set₀⟧⟧ ⟦𝟚⟧ ⟦𝟚⟧) ⟦𝟚⟧ ⟦𝟚⟧ where
  ⟦⟦0₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧
  ⟦⟦1₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧

_≡clauses_ = λ x y → Get-clauses.from-def x ≡ Get-clauses.from-def y
_≡type_ = λ x y → Get-type.from-def x ≡ Get-type.from-def y

module Test where
  p1ℕ→ℕ = pTerm defEnv1 (quoteTerm (ℕ → ℕ))
  [ℕ→ℕ] = [ℕ] [→] [ℕ]
  test-p1ℕ→ℕ : unquote p1ℕ→ℕ ≡ [ℕ→ℕ]
  test-p1ℕ→ℕ = refl

  p2ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ))
  ⟦ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
  test-p2ℕ→ℕ : unquote p2ℕ→ℕ ≡ ⟦ℕ→ℕ⟧
  test-p2ℕ→ℕ = refl

  pℕ→ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ → ℕ))
  ⟦ℕ→ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
  test-pℕ→ℕ→ℕ : pℕ→ℕ→ℕ ≡ quoteTerm ⟦ℕ→ℕ→ℕ⟧
  test-pℕ→ℕ→ℕ = refl
  ZERO : Set₁
  ZERO = (A : Set₀) → A
  ⟦ZERO⟧ : ZERO → ZERO → Set₁
  ⟦ZERO⟧ f₀ f₁ =
    {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
    → Aᵣ (f₀ A₀) (f₁ A₁)
  pZERO = pTerm (ε 2) (quoteTerm ZERO)
  q⟦ZERO⟧ = quoteTerm ⟦ZERO⟧
  test-pZERO : pZERO ≡ q⟦ZERO⟧
  test-pZERO = refl
  ID : Set₁
  ID = (A : Set₀) → A → A
  ⟦ID⟧ : ID → ID → Set₁
  ⟦ID⟧ f₀ f₁ =
    {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
    {x₀ : A₀} {x₁ : A₁} (x : Aᵣ x₀ x₁)
    → Aᵣ (f₀ A₀ x₀) (f₁ A₁ x₁)
  pID = pTerm (ε 2) (quoteTerm ID)
  q⟦ID⟧ = quoteTerm ⟦ID⟧
  test-param : absTerm q⟦ID⟧ ≡ absTerm pID
  test-param = refl
  test-ID : q⟦ID⟧ ≡ pID
  test-ID = refl

  p-not = pFunName defEnv2 (quote not)
  unquoteDecl P-not = p-not
  test-not : ∀ {x₀ x₁ : 𝟚} (xᵣ : ⟦𝟚⟧ x₀ x₁) → ⟦not⟧ xᵣ ≡ P-not xᵣ
  test-not ⟦0₂⟧ = refl
  test-not ⟦1₂⟧ = refl

  p1-pred = pFunName defEnv1 (quote pred)
  q-[pred] = quoteTerm [pred]
  unquoteDecl [pred]' = p1-pred
  test-p1-pred : ∀ {n} (nₚ : [ℕ] n) → [pred]' nₚ ≡ [pred] nₚ
  test-p1-pred [zero] = refl
  test-p1-pred ([suc] nₚ) = refl

  p2-pred = pFunName defEnv2 (quote pred)
  q-⟦pred⟧ = definition (quote ⟦pred⟧)
  unquoteDecl ⟦pred⟧' = p2-pred
  test-p2-pred : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → ⟦pred⟧' nᵣ ≡ ⟦pred⟧ nᵣ
  test-p2-pred ⟦zero⟧ = refl
  test-p2-pred (⟦suc⟧ nᵣ) = refl

  p/2 = pFunNameRec defEnv2 (quote _/2)
  q⟦/2⟧ = definition (quote _⟦/2⟧)
  unquoteDecl _⟦/2⟧' = p/2 _⟦/2⟧'
  {-
  test-/2 : function (p/2 (quote _⟦/2⟧)) ≡ q⟦/2⟧
  test-/2 = refl
  -}
  test-/2 : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → nᵣ ⟦/2⟧' ≡ nᵣ ⟦/2⟧
  test-/2 ⟦zero⟧ = refl
  test-/2 (⟦suc⟧ ⟦zero⟧) = refl
  test-/2 (⟦suc⟧ (⟦suc⟧ nᵣ)) = ap ⟦suc⟧ (test-/2 nᵣ)

  p+ = pFunNameRec defEnv2 (quote _+ℕ_)
  q⟦+⟧ = definition (quote _⟦+ℕ⟧_)
  unquoteDecl _⟦+⟧'_ = p+ _⟦+⟧'_
  -- test-+ : function (p+ (quote _⟦+ℕ⟧_)) ≡ q⟦+⟧
  -- test-+ = refl
  test-+ : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) {n'₀ n'₁} (n'ᵣ : ⟦ℕ⟧ n'₀ n'₁) → nᵣ ⟦+⟧' n'ᵣ ≡ nᵣ ⟦+ℕ⟧ n'ᵣ
  test-+ ⟦zero⟧    n'ᵣ = refl
  test-+ (⟦suc⟧ nᵣ) n'ᵣ = ap ⟦suc⟧ (test-+ nᵣ n'ᵣ)

  {-
  is-good : String → 𝟚
  is-good "good" = 1₂
  is-good _      = 0₂

  ⟦is-good⟧ : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
  ⟦is-good⟧ {"good"} refl = ⟦1₂⟧
  ⟦is-good⟧ {_}      refl = {!!}

  p-is-good = pFunName defEnv2 (quote is-good)
  unquoteDecl ⟦is-good⟧' = p-is-good
  test-is-good = {!!}
  -}

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

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


Formalize change algebras.

Formalize change algebras.

Old-commit-hash: 19a6f7f8a08464d8f2e98dcc618ac9a06d50da78

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    isChangeAlgebra : IsChangeAlgebra Change update diff

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

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


adding theorems that each branch of the progress are disjoint

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-forms
open import type-assignment-unicity

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- values and indeterminates are disjoint
  vi : ∀{d} → d val → d indet → ⊥
  vi VConst ()
  vi VLam ()

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (d0' , Step (FHFinal x) () (FHFinal x₁))
  is IEHole (d0' , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step (FHFinal x) () FHEHole)
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step (FHFinal x) () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step (FHFinal x) () (FHNEHoleFinal x₁))
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step (FHFinal x) () (FHCastFinal x₁))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (d , Step (FHFinal x₁) () (FHFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () FHEHole)
  is (INEHole x) (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHCastFinal x₂))
  is (INEHole x) (d , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (d' , Step p q r) = {!p r!}

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  es (ECastError x x₁) (d' , Step (FHFinal (FVal ())) x₃ x₄)
  es (ECastError x x₁) (d' , Step (FHFinal (FIndet ())) x₃ x₄)
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₃!}
  es (ECastError x x₁) (d' , Step (FHCastFinal (FVal x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (ECastError x x₁) (d' , Step (FHCastFinal (FIndet x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (EAp1 e) (d , Step (FHFinal (FVal x)) x₁ q) = vs x (d , Step (FHFinal (FVal x)) x₁ q)
  es (EAp1 e) (d , Step (FHFinal (FIndet x)) x₁ q) = is x (d , Step (FHFinal (FIndet x)) x₁ q)
  es (EAp1 e) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = {!!}
  es (EAp1 e) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = {!!}
  es (EAp2 e) s = {!!}
  es (ENEHole e) s = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FVal x)) (ITCast x₁ x₂ x₃) x₄) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FIndet x)) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}

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


Added Agsy test about the totality of addition.

Ignore-this: a8258a4fd6d8c1e7fac155dd2f1e5068

darcs-hash:20110324140030-3bd4e-59b07b9164d8e8fb7afe865220ccc4721d839818.gz

module AddTotality where

open import Relation.Binary.PropositionalEquality

infixl 9  _+_

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

postulate
  D    : Set
  zero : D
  succ : D → D

data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero   + d ≡ d
  +-Sx : ∀ d e → succ d + e ≡ succ (d + e)

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = {!-c -m -t 20!}  -- Agsy fails

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ zN Nn = {!-m!}  -- Agda bug?
                     -- An internal error has occurred. Please report this as a bug.
                     -- Location of the error: src/full/Agda/Auto/Convert.hs:444

+-N₁ (sN Nm) Nn = {!-m!} -- Agda bug?
                         -- An internal error has occurred. Please report this as a bug.
                         -- Location of the error: src/full/Agda/Auto/Convert.hs:444

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


adding prelude from popl work

adding prelude from popl work

module Prelude where
  open import Agda.Primitive using (Level; lzero; lsuc) renaming (_⊔_ to lmax)

  -- empty type
  data ⊥ : Set where

  -- from false, derive whatever
  abort : ∀ {C : Set} → ⊥ → C
  abort ()

  -- unit
  data ⊤ : Set where
    <> : ⊤

  -- sums
  data _+_ (A B : Set) : Set where
    Inl : A → A + B
    Inr : B → A + B

  -- pairs
  infixr 1 _,_
  record Σ {l1 l2 : Level} (A : Set l1) (B : A → Set l2) : Set (lmax l1 l2) where
    constructor _,_
    field
      π1 : A
      π2 : B π1
  open Σ public

  -- Sigma types, or dependent pairs, with nice notation.
  syntax Σ A (\ x -> B) = Σ[ x ∈ A ] B

  _×_ : {l1 : Level} {l2 : Level} → (Set l1) → (Set l2) → Set (lmax l1 l2)
  A × B = Σ A λ _ → B

  infixr 1 _×_

  -- equality
  data _==_ {l : Level} {A : Set l} (M : A) : A → Set l where
    refl : M == M

  infixr 9 _==_

  {-# BUILTIN EQUALITY _==_ #-}
  {-# BUILTIN REFL refl #-}

  -- transitivity of equality
  _·_ : {l : Level} {α : Set l} {x y z : α} → x == y → y == z → x == z
  refl · refl = refl

  -- symmetry of equality
  ! : {l : Level} {α : Set l} {x y : α} → x == y → y == x
  ! refl = refl

  -- ap, in the sense of HoTT, that all functions respect equality in their
  -- arguments. named in a slightly non-standard way to avoid naming
  -- clashes with hazelnut constructors.
  ap1 : {l1 l2 : Level} {α : Set l1} {β : Set l2} {x y : α} (F : α → β)
          → x == y → F x == F y
  ap1 F refl = refl

  -- transport, in the sense of HoTT, that fibrations respect equality
  tr : {l1 l2 : Level} {α : Set l1} {x y : α}
                    (B : α → Set l2)
                    → x == y
                    → B x
                    → B y
  tr B refl x₁ = x₁

  -- options
  data Maybe (A : Set) : Set where
    Some : A → Maybe A
    None : Maybe A

  -- the some constructor is injective. perhaps unsurprisingly.
  someinj : {A : Set} {x y : A} → Some x == Some y → x == y
  someinj refl = refl

  --  some isn't none.
  somenotnone : {A : Set} {x : A} → Some x == None → ⊥
  somenotnone ()

  -- function extensionality, used to reason about contexts as finite
  -- functions.
  postulate
     funext : {A : Set} {B : A → Set} {f g : (x : A) → (B x)} →
              ((x : A) → f x == g x) → f == g

  -- non-equality is commutative
  flip : {A : Set} {x y : A} → (x == y → ⊥) → (y == x → ⊥)
  flip neq eq = neq (! eq)

  -- two types are said to be equivalent, or isomorphic, if there is a pair
  -- of functions between them where both round-trips are stable up to ==
  _≃_ : Set → Set → Set
  _≃_ A B = Σ[ f ∈ (A → B) ] Σ[ g ∈ (B → A) ]
             (((a : A) → g (f a) == a) × (((b : B) → f (g b) == b)))

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


module Data.Vec.NP where

open import Data.Vec public
open import Data.Nat using (ℕ; suc; zero)
open import Data.Fin
open import Data.Fin.Props
open import Data.Bool
open import Function

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
count pred [] = zero
count pred (x ∷ xs) = (if pred x then suc else inject₁) (count pred xs)

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (toℕ (count pred xs))
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite inject₁-lemma (count pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

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


Add Cipher.ElGamal.Group

Add Cipher.ElGamal.Group

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