+prefect-bintree-sorting.agda

+prefect-bintree-sorting.agda

module prefect-bintree-sorting where
import Level as L
open import Function.NP
import Data.Nat.NP as Nat
open Nat using (ℕ; zero; suc; 2^_; _+_; _∸_; module ℕ°; module ℕ≤; +-≤-inj; ¬n+≤y<n; sucx≰x; ¬n≤x<n; module ℕcmp) renaming (module <= to ℕ<=; _<=_ to _ℕ<=_)
open import Data.Bool.NP hiding (toℕ)
open import Data.Sum
open import Data.Bits
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product using (_×_; _,_; proj₁; proj₂; ∃; uncurry) renaming (swap to swap-×)
open import Data.Vec.NP using (Vec; _++_; module Alternative-Reverse; shallow-η)
open import Relation.Nullary
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning; [_])
open import Algebra.FunctionProperties
import Relation.Binary.ToNat as ToNat
open import prefect-bintree
open import Data.Nat.Properties
open Nat using (z≤n; s≤s; ≤-pred; 2*_; 2*′_; 2*-spec; 2*′-spec; suc-injective) renaming (_≤_ to _ℕ≤_; _<_ to _ℕ<_)

module MM where
 open Nat using (_≤_; _<_)
 split-≤ : ∀ {x y} → x ≤ y → x ≡ y ⊎ x < y
 split-≤ {zero} {zero} p = inj₁ ≡.refl
 split-≤ {zero} {suc y} p = inj₂ (s≤s z≤n)
 split-≤ {suc x} {zero} ()
 split-≤ {suc x} {suc y} (s≤s p) with split-≤ {x} {y} p
 ... | inj₁ q rewrite q = inj₁ ≡.refl
 ... | inj₂ q = inj₂ (s≤s q)

 <→≤ : ∀ {x y} → x < y → x ≤ y
 <→≤ (s≤s p) = ≤-steps 1 p

 Monotone : ℕ → Endo ℕ → Set
 Monotone ub f = ∀ {x y} → x ≤ y → y < ub → f x ≤ f y

 IsInj : ℕ → Endo ℕ → Set
 IsInj ub f = ∀ {x y} → x < ub → y < ub → f x ≡ f y → x ≡ y

 Bounded : ℕ → Endo ℕ → Set
 Bounded ub f = ∀ x → x < ub → f x < ub

 module M (f : ℕ → ℕ) {ub}
          (f-mono : Monotone ub f)
          (f-inj : IsInj ub f)
          (f-bounded : Bounded ub f) where

  f-mono-< : ∀ {x y} → x < y → y < ub → f x < f y
  f-mono-< {x} {y} p y<ub with split-≤ (f-mono {x} {y} (<→≤ p) y<ub)
  ... | inj₁ q = ⊥-elim (sucx≰x y (≡.subst (λ z → suc z ℕ≤ y) (f-inj {x} {y} (<-trans p y<ub) y<ub q) p))
  ... | inj₂ q = q

  -- f-mono-<′ : ∀ {x} → suc x < ub → f x < f (suc x)

  le : ∀ n → suc n < ub → f (suc n) ≤ n → f n < n
  le n 1+n<ub p = ℕ≤.trans (f-mono-< {n} {suc n} ℕ≤.refl 1+n<ub) p

  bo : ∀ b → b < ub → ¬(f b < b)
  bo zero _ ()
  bo (suc b) b<ub (s≤s p) = bo b (ℕ≤.trans (s≤s (≤-step ℕ≤.refl)) b<ub) (le b b<ub p)

  fp : ∀ b → b < ub → Bounded (suc b) f → f b ≡ b
  fp b b<ub bub with split-≤ (bub b ℕ≤.refl)
  ... | inj₁ p = suc-injective p
  ... | inj₂ p = ⊥-elim (bo b b<ub (≤-pred p))

  ob : ∀ b → b ≤ ub → Bounded b f → ∀ x → x < b → f x ≡ x
  ob zero b≤ub bub _ ()
  ob (suc b) b≤ub bub x pf with split-≤ pf
  ... | inj₁ p rewrite suc-injective p = fp b b≤ub bub
  ... | inj₂ (s≤s p) = ob b (<→≤ b≤ub) ((λ y y<b → ℕ≤.trans (f-mono-< y<b b≤ub) (ℕ≤.reflexive (fp b b≤ub bub)))) x p

  is-id : ∀ x → x < ub → f x ≡ x
  is-id = ob ub ℕ≤.refl f-bounded

open BitsSorting
open OperationSyntax
open PermTreeProof
open EvalTree
open Alternative-Reverse

mkBijT : ∀ {n} → Tree (Bits n) n → Bij
mkBijT = Perm.perm SPP.sort-proof

mkBijT⁻¹ : ∀ {n} → Tree (Bits n) n → Bij
mkBijT⁻¹ f = mkBijT f ⁻¹

mkBij : ∀ {n} → Endo (Bits n) → Bij
mkBij f = mkBijT (fromFun f) ⁻¹

mkBij-p : ∀ {n} (t : Tree (Bits n) n) → t ≡ evalTree (mkBijT t) (sort t)
mkBij-p t = Perm.proof SPP.sort-proof t

IsInj : ∀ {i o} → (Bits i → Bits o) → Set
IsInj f = ∀ {x y} → f x ≡ f y → x ≡ y

idT : ∀ {n} → Tree (Bits n) n
idT = fromFun id

toFun-idT : ∀ {n} → toFun idT ≗ id {A = Bits n}
toFun-idT x = toFun∘fromFun id x

InjT : ∀ {n} → Tree (Bits n) n → Set
InjT = IsInj ∘ toFun

_⁻¹-inverseTree : ∀ {n} f → evalTree (f `⁏ f ⁻¹) ≗ id {A = Tree (Bits n) n}
(f ⁻¹-inverseTree) t = evalTree (f `⁏ f ⁻¹) t
                     ≡⟨ ≡.sym (fromFun∘toFun (evalTree (f `⁏ f ⁻¹) t)) ⟩
                       fromFun (toFun (evalTree (f `⁏ f ⁻¹) t))
                     ≡⟨ fromFun-≗ (evalTree-eval′ (f `⁏ f ⁻¹) t) ⟩
                       fromFun (toFun t ∘ eval (f ⁻¹ ⁻¹ `⁏ f ⁻¹))
                     ≡⟨ fromFun-≗ (λ x → ≡.cong (toFun t) (VecBijKit._⁻¹-inverse′ _ (f ⁻¹) x)) ⟩
                       fromFun (toFun t)
                     ≡⟨ fromFun∘toFun t ⟩
                       t
                     ∎ where open ≡-Reasoning

mkBij-p⁻¹ : ∀ {n} (t : Tree (Bits n) n) → evalTree (mkBijT⁻¹ t) t ≡ sort t
mkBij-p⁻¹ t = ≡.trans (≡.cong (evalTree (mkBijT⁻¹ t)) (mkBij-p t)) (((mkBijT t) ⁻¹-inverseTree) (sort t))

foo : ∀ {n} (t : Tree (Bits n) n) → toFun t ≗ toFun (sort t) ∘ eval (mkBijT⁻¹ t)
foo t xs = toFun t xs
         ≡⟨ ≡.cong (λ t → toFun t xs) (Perm.proof SPP.sort-proof t) ⟩
           toFun (evalTree (mkBijT t) (sort t)) xs
         ≡⟨ evalTree-eval (mkBijT⁻¹ t) (evalTree (mkBijT t) (sort t)) xs ⟩
           toFun (evalTree (mkBijT⁻¹ t) (evalTree (mkBijT t) (sort t))) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ ≡.refl ⟩
           toFun (evalTree (mkBijT t `⁏ mkBijT⁻¹ t) (sort t)) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ ≡.cong (λ u → toFun u (eval (mkBijT⁻¹ t) xs)) (((mkBijT t) ⁻¹-inverseTree) (sort t)) ⟩
           toFun (sort t) (eval (mkBijT⁻¹ t) xs)
         ∎ where open ≡-Reasoning

module SortedMonotonicFunctionsBits {n} where
    open SortedMonotonicFunctions (_≤_ {n}) isPreorder public
open SortedMonotonicFunctionsBits hiding (Sorted)

-- _∘-inj_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {f : B → C} {g : A → B} → IsInj f → IsInj g → IsInj (f ∘ g)
_∘-inj_ : ∀ {a b c} {f : Bits b → Bits c} {g : Bits a → Bits b} → IsInj f → IsInj g → IsInj (f ∘ g)
f-inj ∘-inj g-inj = g-inj ∘ f-inj

_∷-inj : ∀ {n} b → IsInj (_∷_ {n = n} b)
(_ ∷-inj) ≡.refl = ≡.refl

lemvec : ∀ {n} (xs ys : Bits (suc n)) → head xs ≡ head ys → tail xs ≡ tail ys → xs ≡ ys
lemvec (x ∷ xs) (.x ∷ .xs) ≡.refl ≡.refl = ≡.refl

≤→≤ᴮ : ∀ {n} {x y : Bits n} → x ≤ y → x ≤ᴮ y
≤→≤ᴮ {x = []}         {[]}         p = []
≤→≤ᴮ {suc n} {true ∷ xs}  {true ∷ ys}  p = there 1b (≤→≤ᴮ {x = xs} {ys} (ℕ<=.complete {toℕ xs} {toℕ ys} (+-≤-inj (2^ n) (ℕ<=.sound _ _ p))))
≤→≤ᴮ {x = false ∷ xs} {false ∷ ys} p = there 0b (≤→≤ᴮ {x = xs} {ys} p)
≤→≤ᴮ {suc n} {true ∷ xs}  {false ∷ ys} p = ⊥-elim (2ⁿ+≰toℕ ys (ℕ<=.sound (2^ n + toℕ xs) (toℕ ys) p))
≤→≤ᴮ {x = false ∷ xs} {true ∷ ys}  p = 0-1 xs ys

≤ᴮ→≤ : ∀ {n} {x y : Bits n} → x ≤ᴮ y → x ≤ y
≤ᴮ→≤ [] = _
≤ᴮ→≤ {suc n} (there true p) = ℕ<=.complete (ℕ≤.refl {2^ n} +-mono (ℕ<=.sound _ _ (≤ᴮ→≤ p)))
≤ᴮ→≤ (there false p) = ≤ᴮ→≤ p
≤ᴮ→≤ (0-1 p q) = ℕ<=.complete (toℕ≤2ⁿ+ p {toℕ q})

Monotone' : ∀ {i o} → (Bits i → Bits o) → Set _
Monotone' {i} {o} f = ∀ {p q : Bits i} → p ≤ᴮ q → f p ≤ᴮ f q

toEndoℕ : ∀ {n} → Endo (Bits n) → Endo ℕ
toEndoℕ f = toℕ ∘ f ∘ fromℕ

≤-steps′ : ∀ {x} y → x Nat.≤ x + y
≤-steps′ {x} y rewrite ℕ°.+-comm x y = ≤-steps y ℕ≤.refl

<=-steps′ : ∀ {x} y → T (x ℕ<= (x + y))
<=-steps′ {x} y = ℕ<=.complete (≤-steps′ {x} y)

open Nat using (_≰_)
2ⁿ≰toℕ : ∀ {n} (xs : Bits n) → 2^ n ≰ toℕ xs
2ⁿ≰toℕ xs p = ¬n≤x<n _ p (toℕ-bound xs)

Tnot2ⁿ<=toℕ : ∀ {n} (xs : Bits n) → T (not (2^ n ℕ<= (toℕ xs)))
Tnot2ⁿ<=toℕ {n} xs with (2^ n) ℕ<= (toℕ xs) | ≡.inspect (_ℕ<=_ (2^ n)) (toℕ xs)
... | true  | [ p ] = 2ⁿ≰toℕ xs (ℕ<=.sound (2^ n) (toℕ xs) (≡→T p))
... | false |   _   = _

fromℕ∘toℕ : ∀ {n} (x : Bits n) → fromℕ (toℕ x) ≡ x
fromℕ∘toℕ [] = ≡.refl
fromℕ∘toℕ {suc n} (true ∷ xs)
  rewrite T→≡ (<=-steps′ {2^ n} (toℕ xs))
        | ℕ°.+-comm (2^ n) (toℕ xs)
        | m+n∸n≡m (toℕ xs) (2^ n)
        | fromℕ∘toℕ xs
        = ≡.refl
fromℕ∘toℕ (false ∷ xs)
  rewrite Tnot→≡ (Tnot2ⁿ<=toℕ xs)
        | fromℕ∘toℕ xs
        = ≡.refl

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ℕ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

{-
x≤2y′→x∸y≤y : ∀ x y → x ℕ≤ 2*′ y → x ∸ y ℕ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p)) = ℕ≤.trans (sucx∸y≤suc⟨x∸y⟩ x y) (s≤s (x≤2y′→x∸y≤y x y p))
-}

x<2y′→x∸y<y : ∀ x y → x ℕ< 2*′ y → x ∸ y ℕ< y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = ℕ≤.trans (s≤s (sucx∸y≤suc⟨x∸y⟩ x y)) (s≤s (x<2y′→x∸y<y x y p))

x<2y→x∸y<y : ∀ x y → x ℕ< 2* y → x ∸ y ℕ< y
x<2y→x∸y<y x y p rewrite ≡.sym (2*′-spec y) = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y ℕ< x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = ℕ≤.trans (s≤s (≤-step ℕ≤.refl)) a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = ⊥-elim (p (≤-pred c))

not<=→< : ∀ x y → T (not (x ℕ<= y)) → T (suc y ℕ<= x)
not<=→< x y p = ℕ<=.complete (≰→< x y (T'not'¬ p ∘ ℕ<=.complete))

toℕ∘fromℕ : ∀ {n} x → x ℕ< 2^ n → toℕ {n} (fromℕ x) ≡ x
toℕ∘fromℕ {zero} .0 (s≤s z≤n) = ≡.refl
toℕ∘fromℕ {suc n} x x<2ⁿ with 2^ n ℕ<= x | ≡.inspect (_ℕ<=_ (2^ n)) x
... | true  | [ p ] rewrite toℕ∘fromℕ {n} (x ∸ 2^ n) (x<2y→x∸y<y x (2^ n) x<2ⁿ) = m+n∸m≡n {2^ n} {x} (ℕ<=.sound (2^ n) x (≡→T p))
... | false | [ p ] = toℕ∘fromℕ {n} x (ℕ<=.sound (suc x) (2^ n) (not<=→< (2^ n) x (≡→Tnot p)))

fromℕ-inj : ∀ {n} {x y : ℕ} → x ℕ< 2^ n → y ℕ< 2^ n → fromℕ {n} x ≡ fromℕ y → x ≡ y
fromℕ-inj {n} {x} {y} x< y< fx≡fy
  = x
  ≡⟨ ≡.sym (toℕ∘fromℕ {n} x x<) ⟩
    toℕ (fromℕ {n} x)
  ≡⟨ ≡.cong toℕ fx≡fy ⟩
    toℕ (fromℕ {n} y)
  ≡⟨ toℕ∘fromℕ {n} y y< ⟩
    y
  ∎ where open ≡-Reasoning

module ToEndoℕ {n} (f : Endo (Bits n)) where
    fℕ = toEndoℕ f

    fromℕn = fromℕ {n}

    mono : Monotone f → MM.Monotone (2^ n) fℕ
    mono f-mono {x} {y} x≤y y<2ⁿ
       = ℕ<=.sound _ _
          (f-mono
            (≤→≤ᴮ (ℕ<=.complete {toℕ (fromℕn x)} {toℕ (fromℕn y)}
                     (ℕ≤.trans (ℕ≤.reflexive (toℕ∘fromℕ {n} x (ℕ≤.trans (s≤s x≤y) y<2ⁿ)))
                        (ℕ≤.trans x≤y (ℕ≤.reflexive (≡.sym (toℕ∘fromℕ {n} y y<2ⁿ))))))))

    inj : IsInj f → MM.IsInj (2^ n) fℕ
    inj f-inj {x} {y} x< y< = fromℕ-inj x< y< ∘ f-inj ∘ toℕ-inj _ _

    bounded : MM.Bounded (2^ n) fℕ
    bounded x x≤2ⁿ = toℕ-bound (f (fromℕ x))

lem : ∀ {n} (f : Endo (Bits n)) → Monotone f → IsInj f → f ≗ id
lem {n} f f-mono f-inj x = toℕ-inj _ _ (≡.trans (≡.cong (toℕ ∘ f) (≡.sym (fromℕ∘toℕ x))) (MM.M.is-id (toEndoℕ f) {2^ n} (mono f-mono) (inj f-inj) bounded (toℕ x) (toℕ-bound x)))
  where open ToEndoℕ f

IsInj-toFunFromFun : ∀ {n} (f : Endo (Bits n)) → IsInj f → IsInj (toFun (fromFun f))
IsInj-toFunFromFun f f-inj {x} {y} eq
  rewrite toFun∘fromFun f x
        | toFun∘fromFun f y
        = f-inj eq

sort-spec′ : ∀ {n} (t : Tree (Bits n) n) → Sorted (evalTree (mkBijT⁻¹ t) t)
sort-spec′ t rewrite mkBij-p⁻¹ t = sort-spec t

sort-id′′ : ∀ {n} (t : Tree (Bits n) n) → InjT t → Sorted t → toFun t ≗ id
sort-id′′ t Pt st x = lem (toFun t) (DataSorted→Sorted st) Pt x

toFun-eval-inj : ∀ {n} f → IsInj (eval f {n})
toFun-eval-inj f {x} {y} eq = x
                            ≡⟨ ≡.sym ((f ⁻¹-inverse) x) ⟩
                              eval (f ⁻¹) (eval f x)
                            ≡⟨ ≡.cong (eval (f ⁻¹)) eq ⟩
                              eval (f ⁻¹) (eval f y)
                            ≡⟨ (f ⁻¹-inverse) y ⟩
                              y
                            ∎ where open ≡-Reasoning

toFun-evalTree-inj : ∀ {n} f (t : Tree (Bits n) n) → InjT t → InjT (evalTree f t)
toFun-evalTree-inj f t Pt {x} {y} eq
  rewrite evalTree-eval′ f t x
        | evalTree-eval′ f t y = toFun-eval-inj (f ⁻¹) (Pt eq)

sort-id′ : ∀ {n} f (t : Tree (Bits n) n) → InjT t → Sorted (evalTree f t) → toFun (evalTree f t) ≗ id
sort-id′ f t Pt = sort-id′′ (evalTree f t) (λ {x} {y} eq → toFun-evalTree-inj f t Pt eq)

sort-id : ∀ {n} (t : Tree (Bits n) n) → InjT t → toFun (sort t) ≗ id
sort-id t Pt rewrite ≡.sym (mkBij-p⁻¹ t) = sort-id′ (mkBijT⁻¹ t) t Pt (sort-spec′ t)

bar : ∀ {n} (t : Tree (Bits n) n) → InjT t → toFun t ≗ eval (mkBijT⁻¹ t)
bar t Pt xs = toFun t xs
         ≡⟨ foo t xs ⟩
           toFun (sort t) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ sort-id t Pt (eval (mkBijT⁻¹ t) xs) ⟩
           eval (mkBijT⁻¹ t) xs
         ∎ where open ≡-Reasoning

thm : ∀ {n} (f : Endo (Bits n)) (f-inj : IsInj f) →
        eval (mkBij f) ≗ f
thm f f-inj xs = eval (mkBij f) xs
               ≡⟨ ≡.sym (bar (fromFun f) (IsInj-toFunFromFun f f-inj) xs) ⟩
                 toFun (fromFun f) xs
               ≡⟨ toFun∘fromFun f xs ⟩
                 f xs
               ∎ where open ≡-Reasoning

thm# : ∀ {n} (f : Bits n → Bit) (g : Endo (Bits n)) (g-inj : IsInj g) →
       #⟨ f ∘ g ⟩ ≡ #⟨ f ⟩
thm# f g g-inj = #⟨ f ∘ g ⟩
               ≡⟨ #-≗ (f ∘ g) (f ∘ eval (mkBij g)) (λ x → ≡.cong f (≡.sym (thm g g-inj x))) ⟩
                 #⟨ f ∘ eval (mkBij g) ⟩
               ≡⟨ #-bij f (mkBij g) ⟩
                 #⟨ f ⟩
               ∎ where open ≡-Reasoning

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

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


{-# OPTIONS --without-K #-}
module Data.RGB where

open import Type

data RGB : ★ where
  `R `G `B : RGB

[R:_G:_B:_] : ∀ {ℓ}{C : RGB → ★_ ℓ}(r : C `R)(g : C `G)(b : C `B)(rgb : RGB) → C rgb
[R: r G: g B: b ] `R = r
[R: r G: g B: b ] `G = g
[R: r G: g B: b ] `B = b

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


Add ZK.GroupHom.ElGamal.JS, so far only known-enc-rnd

{-# OPTIONS --without-K #-}
open import FFI.JS.BigI
open import Data.Bool.Base using (Bool)
open import SynGrp
open import ZK.GroupHom.Types
import ZK.GroupHom.ElGamal
import ZK.GroupHom.JS

module ZK.GroupHom.ElGamal.JS (p q : BigI)(g : ℤ[ p ]★) where

module EG = ZK.GroupHom.ElGamal `ℤ[ q ]+ `ℤ[ p ]★ _`^_ g

module known-enc-rnd (pk : EG.PubKey)
                     (M  : EG.Message)
                     (ct : EG.CipherText) where
  module ker = EG.Known-enc-rnd pk M ct
  module zkh = `ZK-hom ker.zk-hom
  module zkp = ZK.GroupHom.JS q zkh.`φ zkh.y
  prover-commitment : (r : zkp.Randomness)(w : zkp.Witness) → zkp.Commitment
  prover-commitment r w = zkp.Prover-Interaction.get-A (zkp.prover r w)
  prover-response : (r : zkp.Randomness)(w : zkp.Witness)(c : zkp.Challenge) → zkp.Response
  prover-response r w c = zkp.Prover-Interaction.get-f (zkp.prover r w) c
  verify-transcript : (A : zkp.Commitment)(c : zkp.Challenge)(r : zkp.Response) → Bool
  verify-transcript A c r = zkp.verifier (zkp.Transcript.mk A c r)

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

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


refactoring

refactoring

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/zeitraffer/agda-cats.git/'


Added note about induction principles for N.

Ignore-this: 3f4594794619ba6d27827d2c894512cb

darcs-hash:20111102230806-3bd4e-52b0658622e9fe2c81ce207a5aef1937ef655764.gz

module InductionPrinciples where

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

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

-- The induction principle without the hypothesis N n in the inductive step.
ind₁ : Set₁
ind₁ = (P : D → Set) →
       P zero →
       (∀ {n} → P n → P (succ n)) →
       ∀ {n} → N n → P n

-- The induction principle with the hypothesis N n in the inductive step.
ind₂ : Set₁
ind₂ = (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n

-- We couldn't prove ind₂ from ind₁
1→2 : ind₁ → ind₂
1→2 h P P0 is {n} Nn = {!!}

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


improve FiniteComplete.agda

improve FiniteComplete.agda

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


guessing-game.agda

guessing-game.agda

module guessing-game where

open import Function.NP
open import Data.Nat.NP
open import Data.Product
open import Data.Fin hiding (Ordering; compare; _+_)
open import Data.Bool -- hiding (_≟_)

record Beh (ChalMove AdvMove : Set) : Set where
  constructor mk
  field run : AdvMove → ChalMove × Beh ChalMove AdvMove

module OrderingTags where
  data OrderingTag : Set where
    LT EQ GT : OrderingTag

  tag : ∀ {m n} → Ordering m n → OrderingTag
  tag (less _ _)    = LT
  tag (equal _)     = EQ
  tag (greater _ _) = GT

  cmp : (m n : ℕ) → OrderingTag
  cmp m n = tag (compare m n)

open OrderingTags

data Trace : Set where
  say : (lastguess : ℕ) → Trace
  ask : (guess : ℕ) (ordering : OrderingTag) → Trace → Trace

data Win answer : Trace → Set where
  win  : Win answer (say answer)
  step : ∀ {guess trace} → Win answer trace → Win answer (ask guess (cmp guess answer) trace)

data ChalMove : Set where
  chalStop : ChalMove
  chalStep : OrderingTag → ChalMove

data AdvMove : Set where
  advStop : (guess : ℕ) → AdvMove
  advStep : (guess : ℕ) → AdvMove

advGuess : AdvMove → ℕ
advGuess (advStop guess) = guess
advGuess (advStep guess) = guess

Chal : Set
Chal = Beh ChalMove AdvMove

Adv : Set
Adv = Beh AdvMove ChalMove

chalBeh : (answer : ℕ) → Chal
chalBeh answer = chal where
  chal : Chal
  go : AdvMove → ChalMove × Chal
  go (advStop lastguess) = chalStop , chal
  go (advStep guess) = chalStep (cmp guess answer) , chal
  chal = mk go

middle : (lo hi : ℕ) → ℕ
middle lo hi = lo + ⌊ hi ∸ lo /2⌋

advStop' : ℕ → AdvMove × Adv
advStop' g = advStop g , mk (const (advStop' g))

adv : ∀ (lo g hi : ℕ) → ChalMove → AdvMove × Adv

advStep' : ∀ (lo g hi : ℕ) → AdvMove × Adv
advStep' lo g hi = advStep g , mk (adv lo g hi)

adv lo g hi chalStop = advStop' g
adv lo g hi (chalStep LT) = advStep' g (middle g hi) hi
adv lo g hi (chalStep EQ) = advStop' g
adv lo g hi (chalStep GT) = advStep' lo (middle lo g) g

play : ℕ → Chal → AdvMove × Adv → Trace
play (suc n) (mk chal) (advStep g , mk adv) with chal (advStep g)
... | chalStop , chalNext = say g
... | chalStep o , chalNext = ask g o (play n chalNext (adv (chalStep o)))
play _ _ (advMove , _) = say (advGuess advMove)

play100 : Fin 100 → Trace
play100 a = play 100 (chalBeh (toℕ a)) (advStep' 0 50 100)

ex : Trace
ex = play100 (# 5)

ex-wining : Win 5 ex
ex-wining = step (step (step (step (step (step (step win))))))

--  winner's-win : ∀ answer → Win (toℕ answer) (play100 answer)
-- winner's-win answer = {!!}

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


open import Type
open import Data.Product

module Cipher.ElGamal.Generic
  (Message : ★)
  (ℤq      : ★)
  (G       : ★)
  (g       : G)
  (_^_     : G → ℤq → G)

  -- Required for encryption
  (_∙_     : G → Message → Message)

  -- Required for decryption
  (_/_     : Message → G → Message)
where

PubKey     = G
SecKey     = ℤq
CipherText = G × Message
Rₖ         = ℤq
Rₑ         = ℤq

KeyGen : Rₖ → PubKey × SecKey
KeyGen x = (g ^ x , x)

Enc : PubKey → Message → Rₑ → CipherText
Enc gˣ m y = gʸ , ζ where
  gʸ = g  ^ y
  δ  = gˣ ^ y
  ζ  = δ  ∙ m

Dec : SecKey → CipherText → Message
Dec x (gʸ , ζ) = ζ / (gʸ ^ x)

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


{-# OPTIONS --without-K #-}
module Function.Extensionality where

open import Relation.Binary.PropositionalEquality

postulate
    FunExt : Set
    λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f₀ f₁ : (x : A) → B x}(f= : ∀ x → f₀ x ≡ f₁ x){{fe : FunExt}} → f₀ ≡ f₁

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


hash-param.agda

hash-param.agda

module hash-param where

open import Type using (★_)
open import Function
open import Reflection.Param
open import Data.List.NP as L renaming (dup to dupL)
open import Data.List.Properties.NP
open import Data.Zero
open import Data.Two
open import Data.One
open import Data.Product.NP
open import Data.Sum.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Fin hiding (_+_; pred)
import Data.Vec.NP as V
open V using (Vec; []; _∷_)
open import Algebra.FunctionProperties.Eq
open import Relation.Binary.PropositionalEquality.NP
open import Relation.Binary
open import Relation.Nullary
open import Coinduction

module _ {A : Set} where
    tabulate : ∀ {n} → (Fin n → A) → List A
    tabulate = V.toList ∘ V.tabulate

Injective₂ : {A B C : Set}(f : A → B → C) → Set
Injective₂ f = ∀ {x} → Injective (f x)

module PRNG where
    module PRNG {B D : Set} (H : B → D) {n} (mkB : Fin n → B) where
      prng : List D
      prng = tabulate (H ∘ mkB)

    data DPRNG (B : Set) : Set where
      dH : B → DPRNG B

    dprng : ∀ {B : Set} {n} (mkB : Fin n → B) → List (DPRNG B)
    dprng = PRNG.prng dH

    fprng : ∀ {n} → List (Fin n)
    fprng = PRNG.prng id id

    fprng-allFin : ∀ {n} → fprng {n} ≡ V.toList (V.allFin n)
    fprng-allFin = refl

    module PRNG-Key {Key B D : Set} (H : Key → B → D) {n} (mkB : Fin n → B) where
      prng : Key → List D
      prng k = PRNG.prng (H k) mkB

module HMAC where
  module HMAC-mono
    {B : Set}
    (opad⊕_ ipad⊕_ : B → B)
    (H : List B → B)
    where
    hmac : B → List B → B
    hmac key msg = H (opad⊕ key ∷ H (ipad⊕ key ∷ msg) ∷ [])

  module HMAC
    {Key B D : Set}
    (opad⊕_ ipad⊕_ : Key → B)
    (H : List B → D)
    (E : D → List B) -- E as in "embed"
    where
    hmac : Key → List B → D
    hmac key msg = H (opad⊕ key ∷ E (H (ipad⊕ key ∷ msg)))

  module HMAC-id
    {B : Set}
    where
    hmac-id : B → List B → List B
    hmac-id = HMAC.hmac id id id id
    hmac-id-code : hmac-id ≡ λ key msg → key ∷ key ∷ msg
    hmac-id-code = refl

module Signing
  {VerifKey SignKey : Set}
  (verifkey : SignKey → VerifKey)
  {D Sig Rsign : Set}
  (sign     : Rsign → SignKey → D → Sig)
  (Verify   : VerifKey → D → Sig → Set)
  (correct  : ∀ r sk d → Verify (verifkey sk) d (sign r sk d))

  -- beware
  (extractor : VerifKey → (D → Sig) → D → SignKey)
  (extractor-prop
            : ∀ sk (f : D → Sig) d
               (let vk = verifkey sk)
             → Verify vk d (f d) → extractor vk f d ≡ sk)

  where

  module SigH
    (Msg : Set) (H : Msg → D) (E : D → Msg) where
    signH     : Rsign → SignKey → Msg → Sig
    signH r sk msg = sign r sk (H msg)
    VerifyH   : VerifKey → Msg → Sig → Set
    VerifyH vk msg sig = Verify vk (H msg) sig
    correctH  : ∀ r sk msg → VerifyH (verifkey sk) msg (signH r sk msg)
    correctH r sk msg = correct r sk (H msg)

    extractorH : VerifKey → (Msg → Sig) → Msg → SignKey
    extractorH vk f msg = extractor vk (λ d → f (E d)) (H msg)

    module TrivialH (EH : ∀ m → E (H m) ≡ m) where
        extractorH-prop
                : ∀ sk (f : Msg → Sig) d
                   (let vk = verifkey sk)
                 → VerifyH vk d (f d) → extractorH vk f d ≡ sk
        extractorH-prop sk f d vok = extractor-prop sk (f ∘ E) (H d) (tr (λ z → Verify (verifkey sk) (H d) (f z)) (! EH d) vok)

  module Sig-id where
    open SigH D id id
    open TrivialH (λ _ → refl)

module Signing-data
  (VerifKey SignKey Rsign : Set)
  (verifkey : SignKey → VerifKey)
  where

  module Sig-abs (D : Set) where

    record Sig : Set where
      constructor sign
      field
        rsign   : Rsign
        signkey : SignKey
        d       : D

    Verify : VerifKey → D → Sig → Set
    Verify vk d (sign r sk d') = vk ≡ verifkey sk × d ≡ d'

    correct  : ∀ r sk d → Verify (verifkey sk) d (sign r sk d)
    correct r sk d = refl , refl

    extractor : VerifKey → (D → Sig) → D → SignKey
    extractor vk f d = Sig.signkey (f d)

    module _
      (verifkey-inj : Injective verifkey)
      where
      extractor-prop
                : ∀ sk (f : D → Sig) d
                   (let vk = verifkey sk)
                 → Verify vk d (f d) → extractor vk f d ≡ sk
      extractor-prop sk f d (proj₁ , proj₂) = ! verifkey-inj proj₁

      open Signing verifkey sign Verify correct extractor extractor-prop public

  module SigH-data
    {Msg : Set}
    where

    data D : Set where
      h : Msg → D

    e : D → Msg
    e (h msg) = msg

    open Sig-abs D

    module _
        (verifkey-inj : Injective verifkey)
        where
        open SigH verifkey-inj Msg h e
        open TrivialH (λ m → refl)

module _ {A B C D : Set} (f : A → B) (g : C → D)
         (conflict-pres : Conflict f → Conflict g)
         (_≟_ : Decidable {A = A} _≡_)
         (inj-g : Injective g)
  where
  inj-pres : Injective f
  inj-pres {x} {y} e with x ≟ y
  ... | yes x≡y = x≡y
  ... | no  x≢y = 𝟘-elim (Conflict-¬Injective (conflict-pres (x , y , x≢y , e)) inj-g)

module _ {A B C : Set} (g : B → C) (f : A → B)
         (_≟_ : Decidable {A = B} _≡_) where
  private
    h : A → C
    h = g ∘ f

  conflict-composition : Conflict h → Conflict g ⊎ Conflict f
  conflict-composition (x , y , x≢y , e) with f x ≟ f y
  ... | yes fx≡fy = inr (x , y , x≢y , fx≡fy)
  ... | no  fx≢fy = inl (f x , f y , fx≢fy , e)

  post-inj-pres-conflict : Injective f → Conflict h → Conflict g
  post-inj-pres-conflict f-inj (x , y , x≢y , e) = f x , f y , x≢y ∘ f-inj , e

  -- Therefore all of these constructions preserves conflicts on g:
  --   h(x) = g(k , x)
  --   h(x) = g(k ∷ x)
  --   h(x) = g(k ++ x)
  --   h(x) = g(k ++ x ++ k')
  --   h(x) = g(k ⊕ x)
  --   h(x) = g(x ++ x)
  --   h(x) = g(x , x)

  pre-inj-pres-conflict : Injective g → Conflict h → Conflict f
  pre-inj-pres-conflict g-inj (x , y , x≢y , e) = x , y , x≢y , g-inj e

  -- Therefore all of these constructions preserves conflicts on g:
  --   h(x) = k , g(x)
  --   h(x) = k ∷ g(x)
  --   h(x) = k ++ g(x)
  --   h(x) = k ++ g(x) ++ k'
  --   h(x) = k ⊕ g(x)

-- A construct such as H(H(x)) is a particular case of the conflict-composition
module Self-composition
          {A : Set}
          (h : A → A)
          (_≟_ : Decidable {A = A} _≡_) where
  self-comp-pres-conflict : Conflict (h ∘ h) → Conflict h
  self-comp-pres-conflict c = untag (conflict-composition h h _≟_ c)

module _ {A B : Set} (h : A × A → B) where
  dupP : A → A × A
  dupP x = x , x

  dupP-inj : Injective dupP
  dupP-inj = ap fst

  dupL-inj = dup-inj
  dupV-inj = dup-inj

-- WRONG
{-
module _ {A B C : Set} (f : A → B × C) where
  h = fst ∘ f

  foo : Conflict h → Conflict f
  foo (x , y , i , e) = x , y , i , {!e!}
  -}

record I (B D : Set) : Set where
  field
    h   : List D → D
    i   : B → D
    _⊕_ : D → D → D

data S (B : Set) : Set where
  hˢ   : List (S B) → S B
  iˢ   : B → S B
  _⊕ˢ_ : S B → S B → S B

module TinyEnc {B D : Set} (imp : I B D) where
  open I imp
  enc : (key msg : D) → D
  enc key msg = h (key ∷ []) ⊕ msg
  dec : (key ct : D) → D
  dec = enc

  module _ (⊕-ok : ∀ {x y} → x ⊕ (x ⊕ y) ≡ y) where
    dec-enc : ∀ {key msg} → dec key (enc key msg) ≡ msg
    dec-enc = ⊕-ok

  Msg = D
  CT  = D
  Key = D

  module _ (Rₐ : Set) where
    Adv = Rₐ → Msg ² × (CT → 𝟚)

    run : 𝟚 → Adv → (Rₐ × Key) → 𝟚
    run β adv (ra , key) = let msgs , k = adv ra in k (enc key (msgs β))

    run' : Adv → (Rₐ × Key × 𝟚) → 𝟚
    run' adv (r , key , β) = run β adv (r , key) == β

    -- Pr[ run 0 adv ] ≈ Pr[ run 1 adv ]

-- Sigma protocol
module _ (Commit ChalQuery ChalResp Res : Set) where
  Verifier = Commit →
            (ChalQuery ×
             ChalResp →
            (Res × 𝟙))

  {-

data Adv (Msg CT : Set) : Set where
  query : (msg : Msg) (k : (ct : CT) → Adv Msg CT) → Adv Msg CT
  chal  : (msgs : Msg ²) (k : (ct : CT) → 𝟚) → Adv Msg CT
open import Data.Tree.Binary
-}

data T (A : Set) : Set where
  empty : T A
  fork  : T A → T A → T A
  leaf  : A → T A

H : Set₁
H = {B : Set} (c : B → B → B)(ε : B) → List B → B

H✓ : H → Set₁
H✓ h = ∀ {B : Set} (c : B → B → B) ε
     → Injective₂ c
     → Conflict (h c ε)
     → Conflict (uncurry c)

module _ {A : Set} {x y : A} {xs ys : List A} where
  ≢∷ : x List.∷ xs ≢ y ∷ ys → x ≢ y ⊎ (x ≡ y × xs ≢ ys)
  ≢∷ = {!!}

  {-
c-inj₂ : ∀ {t u v} → c t u ≡ c t v → u ≡ v
c-inj₂ refl = refl
-}

module Fold where
  h : H
  h = foldr

  module _ {B : Set} (c : B → B → B) ε
           (c-inj : ∀ {x y z} → c x y ≡ c x z → y ≡ z) where
    h✓' : ∀ xs ys(is : xs ≢ ys)(es : h c ε xs ≡ h c ε ys)
          → Conflict (uncurry c)

    h✓' [] [] is es = 𝟘-elim (is refl)
    h✓' [] (x ∷ ys) is es = {!!}
    h✓' (x ∷ xs) [] is es = {!!}
    h✓' (x ∷ xs) (y ∷ ys) is es with ≢∷ is
    ... | inl i = (x , h c ε xs) , (y , h c ε ys) , (λ p → i (ap fst p)) , es
    ... | inr (e , is') = h✓' xs ys is' (c-inj (tr (λ z → c z (h c ε xs) ≡ c y (h c ε ys)) e es))

  h✓ : H✓ h
  h✓ c ε c-inj (xs , ys , is , es) = h✓' c ε c-inj xs ys is es

  {-
_⊕_ : H → H → H
(h₀ ⊕ h₁) c xs = c (h₀ c xs) (h₁ c xs)

Hₚ : H → Set₁
Hₚ h = (Bₚ : H → Set)
       (cₚ : ∀ {h₀ h₁ : H} → Bₚ h₀ → Bₚ h₁ → Bₚ (h₀ ⊕ h₁))
     → Bₚ h

module _ (h : H) (hₚ : Hₚ h) {B : Set} (c : B → B → B)(ε : B) where

  P⊕ : ∀ {h₀ h₁ : H} → P h₀ → P h₁ → P (h₀ ⊕ h₁)
  P⊕ h₀ₚ h₁ₚ ([] , [] , is , es) = 𝟘-elim (is refl)
  P⊕ h₀ₚ h₁ₚ ([] , x ∷ ys , is , es) = {!!}
  P⊕ h₀ₚ h₁ₚ (x ∷ xs , [] , is , es) = {!!}
  P⊕ h₀ₚ h₁ₚ (x ∷ xs , y ∷ ys , is , es) with ≢∷ is
  ... | inl i = x , y , i , {!es!}
  ... | inr i = {!!}

  ph : P h
  ph = hₚ P (λ {x}{y} → P⊕ {x} {y})
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

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


[ #27 ] Added example.

[ #27 ] Added example.

[ci skip]

module Issue27 where

infix  4 _≡_
infixl 4 _>_ _<_
infixr 1 _∨_

postulate ℝ : Set

------------------------------------------------------------------------------
-- Logic stuff

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

data _∨_ (A B : Set) : Set where
  inj₁ : A → A ∨ B
  inj₂ : B → A ∨ B

case : ∀ {A B} → {C : Set} → (A → C) → (B → C) → A ∨ B → C
case f g (inj₁ a) = f a
case f g (inj₂ b) = g b

------------------------------------------------------------------------------
-- Real numbers stuff

postulate _>_ : ℝ → ℝ → Set

_<_ : ℝ → ℝ → Set
y < x = x > y
{-# ATP definition _<_ #-}

postulate
  trichotomy : (x y : ℝ) → (x > y) ∨ (x ≡ y) ∨ (x < y)
{-# ATP axiom trichotomy #-}

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

rmin : ℝ → ℝ → ℝ
rmin x y = case (λ _ → y) (λ h → case (λ _ → x) (λ _ → x) h) (trichotomy x y)
{-# ATP definition rmin #-}

postulate foo : ∀ x y → rmin x y ≡ rmin x y
{-# ATP prove foo #-}

{-
Error:
$ apia --check Issue27.agda
apia: tptp4X found an error/warning in the file /tmp/Issue27/44-foo.fof
Please report this as a bug

WARNING: Line 34 Char 159 Token "," : Multiple arity symbol n_62__46_8405600604384089447, arity 0 and now 2
WARNING: Line 34 Char 259 Token ")" : Multiple arity symbol n_60__48_8405600604384089447, arity 0 and now 2
WARNING: Line 34 Char 387 Token "," : Multiple arity symbol n_60__48_8405600604384089447, arity 0 and now 2
WARNING: Line 34 Char 460 Token ")" : Multiple arity symbol case_32_8405600604384089447, arity 5 and now 6
-}

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


dice.agda

dice.agda

open import Type
open import Search.Type
open import Search.Searchable

module dice where

data Dice : ★₀ where
  ⚀ ⚁ ⚂ ⚃ ⚄ ⚅ : Dice

searchDice : ∀ m → Search m Dice
searchDice m _∙_ f = f ⚀ ∙ (f ⚁ ∙ (f ⚂ ∙ (f ⚃ ∙ (f ⚄ ∙ f ⚅))))

searchDice-ind : ∀ {m} p → SearchInd p (searchDice m)
searchDice-ind p P _∙_ f = f ⚀ ∙ (f ⚁ ∙ (f ⚂ ∙ (f ⚃ ∙ (f ⚄ ∙ f ⚅))))

μDice : Searchable Dice
μDice = _ , searchDice-ind _

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


import Data.Nat.NP as ℕ
open ℕ using (ℕ; zero; suc; module ℕ≤)
open import Data.Bool
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum renaming (map to ⊎-map)
open import Function
open import Relation.Binary
open import Algebra.FunctionProperties
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Relation.Binary.ToNat {a} {A : Set a} (f : A → ℕ) (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) where

_<=_ : A → A → Bool
_<=_ = ℕ._<=_ on f

_≤_ : A → A → Set
x ≤ y = T (x <= y)

_⊓_ : A → A → A
x ⊓ y = if x <= y then x else y

_⊔_ : A → A → A
x ⊔ y = if x <= y then y else x

isPreorder : IsPreorder _≡_ _≤_
isPreorder = record { isEquivalence = ≡.isEquivalence
                    ; reflexive = reflexive
                    ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
  where open ℕ.<=
        reflexive : ∀ {i j} → i ≡ j → i ≤ j
        reflexive {i} ≡.refl = complete (ℕ≤.refl {f i})
        trans : Transitive _≤_
        trans {x} {y} {z} p q = complete (ℕ≤.trans (sound (f x) (f y) p) (sound (f y) (f z) q))

isPartialOrder : IsPartialOrder _≡_ _≤_
isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }
  where open ℕ.<= using (sound)
        antisym : Antisymmetric _≡_ _≤_
        antisym {x} {y} p q = f-inj (ℕ≤.antisym (sound (f x) (f y) p) (sound (f y) (f x) q))

isTotalOrder : IsTotalOrder _≡_ _≤_
isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total (f x) (f y)) }
  where open ℕ.<= using (complete)

open IsTotalOrder isTotalOrder

⊔-spec : ∀ {x y} → x ≤ y → x ⊔ y ≡ y
⊔-spec {x} {y} p with x <= y
⊔-spec _    | true = ≡.refl
⊔-spec ()   | false

⊓-spec : ∀ {x y} → x ≤ y → x ⊓ y ≡ x
⊓-spec {x} {y} p with x <= y
⊓-spec _    | true = ≡.refl
⊓-spec ()   | false

⊓-comm : Commutative _≡_ _⊓_
⊓-comm x y with x <= y | y <= x | antisym {x} {y} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊔-comm : Commutative _≡_ _⊔_
⊔-comm x y with x <= y | y <= x | antisym {y} {x} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊓-≤ : ∀ x y → (x ⊓ y) ≤ y
⊓-≤ x y with total x y
⊓-≤ x y | inj₁ p rewrite ⊓-spec p = p
⊓-≤ x y | inj₂ p rewrite ⊓-comm x y | ⊓-spec p = refl

≤-<_,_> : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ⊓ z)
≤-<_,_> {x} {y} {z} x≤y y≤z with total y z
... | inj₁ p rewrite ⊓-spec p = x≤y
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = y≤z

≤-[_,_] : ∀ {x y z} → x ≤ z → y ≤ z → (x ⊔ y) ≤ z
≤-[_,_] {x} {y} {z} x≤z y≤z with total x y
... | inj₁ p rewrite ⊔-spec p = y≤z
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = x≤z

≤-⊓₀ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ y
≤-⊓₀ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = id
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = flip trans p

≤-⊓₁ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ z
≤-⊓₁ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = flip trans p
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = id

≤-⊔₀ : ∀ {x y z} → (x ⊔ y) ≤ z → x ≤ z
≤-⊔₀ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = trans p
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = id

≤-⊔₁ : ∀ {x y z} → (x ⊔ y) ≤ z → y ≤ z
≤-⊔₁ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = id
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = trans p

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


Added possible test case.

Added possible test case.

Ignore-this: 35250bb5e1176e1d4af513edf0ad0b04

darcs-hash:20110924002242-3bd4e-165ef85e8c9d6cdf2cf5c0df56d74c5f544dee31.gz

-- From LTC-PCF.Data.Nat.Inequalities.PropertiesATP

module Draft.Issues.Agda365 where

open import LTC-PCF.Base

open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Inequalities
open import LTC-PCF.Data.Nat.Inequalities.EquationsATP
open import LTC-PCF.Data.Nat.PropertiesATP

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

-- After the Agda patch

-- Thu Sep 15 14:15:05 COT 2011  ulfn@chalmers.se
--  * fixed issue 365: different evaluation behaviour for point-free and pointed style

-- we get the error

-- Translating Draft/Issues/Agda365.agda ...
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/FOL/Translation/Internal/Terms.hs:516
--
-- because we don't translate the Agda internal lambda terms. We fixed
-- the issue using an abstract block to avoid the reduction (see
-- LTC-PCF.Data.Nat.Inequalities). I am keeping this example as an
-- possible test case for the translation of the Agda internal lambda
-- terms.

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y∸x+x≡y Nm Nn m≤n)
  where
  postulate m≤n : LE m n
  {-# ATP prove m≤n <-SS #-}

  postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                  (succ n ∸ succ m) + succ m ≡ succ n
  -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove prf +-comm ∸-N +-Sx ∸-SS <-SS #-}

-- This is an incomplete case which does not matter.
x≤y→y∸x+x≡y {m} {n} Nm Nn m≤n = whatever
  where
  postulate whatever : n ∸ m + m ≡ n

error: pathspec 'Draft/Issues/Agda365.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 (_,_)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.Two hiding (_≟_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; coe)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences

open import Control.Protocol
open import Control.Protocol.Lift
open import Control.Protocol.Multiplicative

module Control.Protocol.Examples where

module MonomorphicSky (P : Proto₀) where
  Cloud : Proto₀
  Cloud = recv λ (t   : ⟦ P  ⟧) →
          recv λ (u   : ⟦ P ⊥⟧) →
          send λ (log : Log P)  →
          end
  cloud : ⟦ Cloud ⟧
  cloud t u = telecom P t u , _

module PolySky where
  Cloud : Proto_ ₁
  Cloud = recv λ (P : Proto₀) →
          liftᴾ ₁ (MonomorphicSky.Cloud P)
  cloud : ⟦ Cloud ⟧
  cloud P = lift-proc ₁ (MonomorphicSky.Cloud P) (MonomorphicSky.cloud P)

module PolySky' where
  Cloud : Proto_ ₁
  Cloud = recv λ (P   : Proto₀) →
          recv λ (t   : Lift ⟦ P  ⟧)  →
          recv λ (u   : Lift ⟦ P ⊥⟧)  →
          send λ (log : Lift (Log P)) →
          end
  cloud : ⟦ Cloud ⟧
  cloud P (lift t) (lift u) = lift (telecom P t u) , _

module Commitment {Secret Guess : ★} {R : ..(_ : Secret) → Guess → ★} where
    Commit : Proto
    Commit = send☐ λ (s : Secret) →
             recv  λ (g : Guess)  →
             send  λ (_ : S⟨ s ⟩) →
             end

    commit : (s : Secret)  → ⟦ Commit ⟧
    commit s = [ s ] , λ g → S[ s ] , _

    decommit : (g : Guess) → ⟦ dual Commit ⟧
    decommit g [ m ] = g , _

-- Prove knowledge of a discrete log
-- Adapted here to have precise types
module Shnorr-protocol
    (G ℤq : ★)
    (g    : G)
    (_^_  : G  → ℤq → G)
    (_·_  : G  → G  → G)
    (_+_  : ℤq → ℤq → ℤq)
    (_*_  : ℤq → ℤq → ℤq)
    (_≟_  : (x y : G) → Dec (x ≡ y))
    where
    module Real where
        Prover : Proto
        Prover = send λ (gʳ : G)  → -- commitment
                 recv λ (c  : ℤq) → -- challenge
                 send λ (s  : ℤq) → -- response
                 end

        Verifier : Proto
        Verifier = dual Prover

        -- He is honest but its type does not say it
        -- The definition for "prover" below is derived from
        -- a well typed version.
        prover' : (x r : ℤq) → ⟦ Prover ⟧
        prover' x r = (g ^ r) , λ c → (r + (c * x)) , _

        verifier : (c : ℤq) → ⟦ Verifier ⟧
        verifier c _ = c , _

        module _ ..(x : ℤq) (y : S⟨ g ^ x ⟩) where
            Honest-Prover : Proto
            Honest-Prover
              = send☐ λ (r  : ℤq)                → -- ideal commitment
                send  λ (gʳ : S⟨ g ^ r ⟩)        → -- real  commitment
                recv  λ (c  : ℤq)                → -- challenge
                send  λ (s  : S⟨ r + (c * x) ⟩)  → -- response
                recv  λ (_  : Dec ((g ^ unS s) ≡ (unS gʳ · (unS y ^ c)))) →
                end

            Honest-Verifier : Proto
            Honest-Verifier = dual Honest-Prover

            honest-verifier' : (c : ℤq) → ⟦ Honest-Verifier ⟧
            honest-verifier' c [ r ] gʳ = c , λ s → _ ≟ _ , _

            sim-honest-prover : ⟦ Honest-Prover ⊸ Prover ⟧
            sim-honest-prover [ r ] S[ gʳ ∥ gʳ= ] = inr gʳ , λ c →
                                                    inl c  , λ { S[ s ∥ s= ] →
                                                    inr s  ,
                                                    _ ≟ _  ,
                                                    end }

            -- The next version is derived from sim-honest-prover
            honest-prover→prover' : ⟦ Honest-Prover ⟧ → ⟦ Prover ⟧
            honest-prover→prover' ([ r ] , gʳ , p) = unS gʳ , λ c → case p c of λ { (s , _) → unS s , _ }

            module _ {{_ : FunExt}}{{_ : UA}} where
                sim-honest-verifier : ⟦ Verifier ⊸ Honest-Verifier ⟧
                sim-honest-verifier = coe (⅋-comm Honest-Verifier _) sim-honest-prover

                honest-prover→prover : ⟦ Honest-Prover ⟧ → ⟦ Prover ⟧
                honest-prover→prover = ⊸-apply {Honest-Prover} sim-honest-prover

                verifier→honest-verifier : ⟦ Verifier ⟧ → ⟦ Honest-Verifier ⟧
                verifier→honest-verifier = ⊸-apply {Verifier} {Honest-Verifier} sim-honest-verifier

                honest-verifier : (c : ℤq) → ⟦ Honest-Verifier ⟧
                honest-verifier c = verifier→honest-verifier (verifier c)

        module _ (x r : ℤq) where
            honest-prover : ⟦ Honest-Prover x S[ g ^ x ] ⟧
            honest-prover = [ r ] , S[ g ^ r ] , λ c → S[ r + (c * x) ] , _
            -- agsy can do it

            module _ {{_ : FunExt}}{{_ : UA}} where
                prover : ⟦ Prover ⟧
                prover = honest-prover→prover x S[ g ^ x ] honest-prover

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


refactor

refactor


Testing ≈→≡.

Testing ≈→≡.

------------------------------------------------------------------------------
-- Properties for the bisimilarity relation
------------------------------------------------------------------------------

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

module FOT.FOTC.Relation.Binary.Bisimilarity.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Relation.Binary.Bisimilarity

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

{-# NO_TERMINATION_CHECK #-}
≈→≡₁ : ∀ {xs ys} → xs ≈ ys → xs ≡ ys
≈→≡₁ {xs} {ys} xs≈ys with (≈-unf xs≈ys)
... | x' , xs' , ys' , h₁ , h₂ , h₃ =
  xs       ≡⟨ h₂ ⟩
  x' ∷ xs' ≡⟨ ∷-rightCong (≈→≡₁ h₁) ⟩
  x' ∷ ys' ≡⟨ sym h₃ ⟩
  ys       ∎

-- Requires K.
{-# NO_TERMINATION_CHECK #-}
≈→≡₂ : ∀ {xs ys} → xs ≈ ys → xs ≡ ys
≈→≡₂ xs≈ys with (≈-unf xs≈ys)
... | x' , xs' , ys' , h , refl , refl = ∷-rightCong (≈→≡₂ h)

error: pathspec 'notes/FOT/FOTC/Relation/Binary/Bisimilarity/PropertiesI.agda' did not match any file(s) known to git


Renaming of FiniteField.JS

Renaming of FiniteField.JS

{-# OPTIONS --without-K #-}
open import Function.NP
open import FFI.JS using (𝟙; Number; Bool; true; false; String; warn-check; check; trace-call; _++_)
open import FFI.JS.BigI
open import Data.List.Base hiding (sum; _++_)
{-
open import Algebra.Raw
open import Algebra.Field
-}

module FFI.JS.BigI.FiniteField (q : BigI) where

abstract
  𝔽 : Set
  𝔽 = BigI

  private
    mod-q : BigI → 𝔽
    mod-q x = mod x q

    check' : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
    -- check' = warn-check
    check' = check

  -- There is two ways to go from BigI to ℤq: check and mod-q
  -- Use check for untrusted input data and mod-q for internal
  -- computation.
  fromBigI : BigI → 𝔽
  fromBigI = -- trace-call "BigI▹ℤq "
    λ x →
      (check' (x <I q)
         (λ _ → "Not below the modulus: q:" ++ toString q ++ " is less than x:" ++ toString x)
         (check' (x ≥I 0I)
            (λ _ → "Should be positive: " ++ toString x ++ " < 0") x))

  check-non-zero : 𝔽 → BigI
  check-non-zero = -- trace-call "check-non-zero "
    λ x → check (x >I 0I) (λ _ → "Should be non zero") x

  repr : 𝔽 → BigI
  repr x = x

  0# 1# : 𝔽
  0# = 0I
  1# = 1I

  1/_ : Op₁ 𝔽
  1/ x = modInv (check-non-zero x) q

  _^_ : Op₂ 𝔽
  x ^ y = modPow (repr x) (repr y) q

_+_ _−_ _*_ _/_ : Op₂ 𝔽

x + y = mod-q (add      (repr x) (repr y))
x − y = mod-q (subtract (repr x) (repr y))
x * y = mod-q (multiply (repr x) (repr y))
x / y = x * 1/ y

0−_ : Op₁ 𝔽
0− x = mod-q (negate (repr x))

_==_ : (x y : 𝔽) → Bool
x == y = equals (repr x) (repr y)

sum prod : List 𝔽 → 𝔽
sum  = foldr _+_ 0#
prod = foldr _*_ 1#

{-
+-mon-ops : Monoid-Ops 𝔽
+-mon-ops = _+_ , 0#

+-grp-ops : Group-Ops 𝔽
+-grp-ops = +-mon-ops , 0−_

*-mon-ops : Monoid-Ops 𝔽
*-mon-ops = _*_ , 1#

*-grp-ops : Group-Ops 𝔽
*-grp-ops = *-mon-ops , 1/_

fld-ops : Field-Ops 𝔽
fld-ops = +-grp-ops , *-grp-ops

postulate
  fld-struct : Field-Struct fld-ops

fld : Field 𝔽
fld = fld-ops , fld-struct
-- -}
-- -}
-- -}
-- -}
-- -}

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


infix priority

infix priority


an equality module for Sets

an equality module for Sets

module Equality where

data _≡_  {A : Set} : (a b : A) → Set where
  definition : {x : A} → x ≡ x

sym : {A : Set} {a b : A} → a ≡ b → b ≡ a
sym definition = definition

trans : {A : Set} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans pAB definition = pAB
-- trans definition pBC = pBC

cong : {A B : Set} {a₀ a₁ : A} → (f : A → B) → a₀ ≡ a₁ → f a₀ ≡ f a₁
cong f definition = definition

begin : {A : Set} (a : A) →  a ≡ a
begin a = definition

_≈_by_ : {A : Set} {a b : A} → a ≡ b → (c : A) → b ≡ c → a ≡ c
aEb ≈ c by bEc = trans aEb bEc

_∎ : {A : Set} (a : A) → A
x ∎ = x

infixl 1 _≈_by_
infixl 1 _≡_

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


{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd) using (Σ;_,_)
open import Data.Zero
open import Data.One using (𝟙)
open import Data.Two hiding (_≟_; nand)
open Data.Two.Indexed
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; subst; ap; coe; coe!)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences
open import Control.Protocol

module Control.Protocol.MultiParty where

module _ (I : ★) where
    data MProto : ★₁ where
      _-[_]→_⁏_ : (A : I) (M : ★) (B : I) (ℂ : ..(m : M) → MProto) → MProto
      _-[_]→★⁏_ : (A : I) (M : ★)         (ℂ :   (m : M) → MProto) → MProto
      end       : MProto

module _ {I : ★} where
    _-[_]→ø⁏_ : ∀ (A : I)(M : ★)(ℂ : ..(m : M) → MProto I) → MProto I
    A -[ M ]→ø⁏ ℂ = A -[ ☐ M ]→★⁏ λ { [ m ] → ℂ m }

    Group = I → 𝟚

    _/_ : (ℂ : MProto I) (φ : Group) → Proto
    (A -[ M ]→ B ⁏ ℂ) / φ = case φ A
                               0: case φ B
                                    0: recv (λ { [ m ] → ℂ m / φ })
                                    1: recv (λ     m   → ℂ m / φ)
                               1: send (λ m → ℂ m / φ)
    (A -[ M ]→★⁏   ℂ) / φ = com (case φ A 0: In 1: Out) λ m → ℂ m / φ
    end               / φ = end

    empty-group : Group
    empty-group _ = 0₂

    full-group : Group
    full-group _ = 1₂

    -- MultiParty Obs(erver)
    MObs : MProto I → Proto
    MObs ℂ = ℂ / empty-group

    -- MultiParty Log
    MLog : MProto I → Proto
    MLog ℂ = ℂ / full-group

    ℂLog-IsSource : ∀ ℂ → IsSource (MLog ℂ)
    ℂLog-IsSource (A -[ M ]→ B ⁏ ℂ) = send' λ m → ℂLog-IsSource (ℂ m)
    ℂLog-IsSource (A -[ M ]→★⁏   ℂ) = send' λ m → ℂLog-IsSource (ℂ m)
    ℂLog-IsSource end               = end

    ℂObserver-IsSink : ∀ ℂ → IsSink (MObs ℂ)
    ℂObserver-IsSink (A -[ M ]→ B ⁏ ℂ) = recv' λ { [ m ] → ℂObserver-IsSink (ℂ m) }
    ℂObserver-IsSink (A -[ M ]→★⁏   ℂ) = recv' λ m → ℂObserver-IsSink (ℂ m)
    ℂObserver-IsSink end = end

    data Nand : (x y : 𝟚) → ★ where
      n01 : Nand 0₂ 1₂
      n10 : Nand 1₂ 0₂
      n00 : Nand 0₂ 0₂

    or : ∀ {x y} → Nand x y → 𝟚
    or n01 = 1₂
    or n10 = 1₂
    or n00 = 0₂

    Nand° : (φ ψ : Group) → ★
    Nand° φ ψ = ∀ i → Nand (φ i) (ψ i)

    or° : ∀ {φ ψ} → Nand° φ ψ → Group
    or° r° = or ∘ r°

    data R : (x y z : 𝟚) → ★ where
      r01 : R 0₂ 1₂ 1₂
      r10 : R 1₂ 0₂ 1₂
      r00 : R 0₂ 0₂ 0₂

    R° : (φ ψ ξ : Group) → ★
    R° φ ψ ξ = ∀ i → R (φ i) (ψ i) (ξ i)

    Nand-R : ∀ {x y z} → R x y z → Σ (Nand x y) (_≡_ z ∘ or)
    Nand-R r01 = n01 , refl
    Nand-R r10 = n10 , refl
    Nand-R r00 = n00 , refl

    Nand-R° : ∀ {x y z}{{_ : FunExt}} → R° x y z → Σ (Nand° x y) (_≡_ z ∘ or°)
    Nand-R° p = fst ∘ Nand-R ∘ p , λ= (λ i → snd (Nand-R (p i)))

    module _ {p q : I → 𝟚}(pq : Nand° p q) where
        group-merge : (ℂ : MProto I) → ⟦ ℂ / p ⟧ → ⟦ ℂ / q ⟧ → ⟦ ℂ / or° pq ⟧
        group-merge (A -[ M ]→ B ⁏ ℂ) ℂp ℂq with p A | q A | pq A | p B | q B | pq B
        group-merge (A -[ M ]→ B ⁏ ℂ) ℂp (m , ℂq) | .0₂ |  1₂ | n01 |  1₂ | .0₂ | n10 = m , group-merge (ℂ m) (ℂp m) ℂq
        group-merge (A -[ M ]→ B ⁏ ℂ) ℂp (m , ℂq) | .0₂ |  1₂ | n01 |  0₂ |  _  | _   = m , group-merge (ℂ m) (ℂp [ m ]) ℂq
        group-merge (A -[ M ]→ B ⁏ ℂ) (m , ℂp) ℂq |  1₂ | .0₂ | n10 | .0₂ |  1₂ | n01 = m , group-merge (ℂ m) ℂp (ℂq m)
        group-merge (A -[ M ]→ B ⁏ ℂ) (m , ℂp) ℂq |  1₂ | .0₂ | n10 |  _  |  0₂ | _   = m , group-merge (ℂ m) ℂp (ℂq [ m ])
        group-merge (A -[ M ]→ B ⁏ ℂ) ℂp ℂq       | .0₂ |  0₂ | n00 | .0₂ |  1₂ | n01 = λ m → group-merge (ℂ m) (ℂp [ m ]) (ℂq m)
        group-merge (A -[ M ]→ B ⁏ ℂ) ℂp ℂq       | .0₂ |  0₂ | n00 |  1₂ | .0₂ | n10 = λ m → group-merge (ℂ m) (ℂp m) (ℂq [ m ])
        group-merge (A -[ M ]→ B ⁏ ℂ) ℂp ℂq       | .0₂ |  0₂ | n00 |  0₂ |  0₂ | n00 = λ { [ m ] → group-merge (ℂ m) (ℂp [ m ]) (ℂq [ m ]) }
        group-merge (A -[ M ]→★⁏   ℂ) ℂp ℂq with p A | q A | pq A
        group-merge (A -[ M ]→★⁏   ℂ) ℂp (m , ℂq) | .0₂ |  1₂ | n01 = m , group-merge (ℂ m) (ℂp m) ℂq
        group-merge (A -[ M ]→★⁏   ℂ) (m , ℂp) ℂq |  1₂ | .0₂ | n10 = m , group-merge (ℂ m) ℂp (ℂq m)
        group-merge (A -[ M ]→★⁏   ℂ) ℂp ℂq       | .0₂ |  0₂ | n00 = λ m → group-merge (ℂ m) (ℂp m) (ℂq m)
        group-merge end ℂp ℂq = _

    module _ {p q r : I → 𝟚}(pqr : R° p q r){{_ : FunExt}} where
        group-merge' : (ℂ : MProto I) → ⟦ ℂ / p ⟧ → ⟦ ℂ / q ⟧ → ⟦ ℂ / r ⟧
        group-merge' ℂ p q with Nand-R° pqr
        ... | z , e = subst (⟦_⟧ ∘ _/_ ℂ) (! e) (group-merge z ℂ p q)

        {-
    module _ {p q r : I → 𝟚} where
        choreo-merge-assoc : (ℂ : MProto I)(Rqr : Nand° q r)(Rpq : Nand° p q)(Rpqr : Nand° p _)(Rpqr' : Nand° _ r) →
                             (ℂp : ⟦ ℂ / p ⟧) (ℂq : ⟦ ℂ / q ⟧) (ℂr : ⟦ ℂ / r ⟧)
                             → group-merge Rpqr ℂ ℂp (group-merge Rqr ℂ ℂq ℂr)
                             ≡ subst (λ x → ⟦ ℂ / nand° x ⟧) {!!}
                               (group-merge Rpqr' ℂ (group-merge Rpq ℂ ℂp ℂq) ℂr)
        choreo-merge-assoc = {!!}
        -}

    R-p-¬p-1 : ∀ (φ : I → 𝟚) i → R (φ i) (not (φ i)) 1₂
    R-p-¬p-1 φ i with φ i
    R-p-¬p-1 φ i | 1₂ = r10
    R-p-¬p-1 φ i | 0₂ = r01

    module _ {{_ : FunExt}} where
        choreo-bi : {φ : I → 𝟚}(ℂ : MProto I) → ⟦ ℂ / φ ⟧ → ⟦ ℂ / (not ∘ φ) ⟧ → ⟦ MLog ℂ ⟧
        choreo-bi {φ} ℂ ℂp ℂ¬p = group-merge' (R-p-¬p-1 φ) ℂ ℂp ℂ¬p

module _ {{_ : FunExt}} where
    choreo2 : (ℂ : MProto 𝟚) → ⟦ ℂ / id ⟧ → ⟦ ℂ / not ⟧ → ⟦ MLog ℂ ⟧
    choreo2 = choreo-bi

module ThreeParty where
  data 𝟛 : ★ where
    0₃ 1₃ 2₃ : 𝟛
  0₃? 1₃? 2₃? : 𝟛 → 𝟚
  0₃? 0₃ = 1₂
  0₃? _  = 0₂
  1₃? 1₃ = 1₂
  1₃? _  = 0₂
  2₃? 2₃ = 1₂
  2₃? _  = 0₂

  R-1-2-¬0 : R° 1₃? 2₃? (not ∘ 0₃?)
  R-1-2-¬0 0₃ = r00
  R-1-2-¬0 1₃ = r10
  R-1-2-¬0 2₃ = r01

  {- While this does not scale -}
  3com : (ℂ : MProto 𝟛) → ⟦ ℂ / 0₃? ⟧ → ⟦ ℂ / 1₃? ⟧ → ⟦ ℂ / 2₃? ⟧ → ⟦ MLog ℂ ⟧
  3com (0₃ -[ M ]→ 0₃ ⁏ ℂ) (m , p0) p1 p2 = m , 3com (ℂ m) p0 (p1 [ m ]) (p2 [ m ])
  3com (0₃ -[ M ]→ 1₃ ⁏ ℂ) (m , p0) p1 p2 = m , 3com (ℂ m) p0 (p1 m) (p2 [ m ])
  3com (0₃ -[ M ]→ 2₃ ⁏ ℂ) (m , p0) p1 p2 = m , 3com (ℂ m) p0 (p1 [ m ]) (p2 m)
  3com (1₃ -[ M ]→ 0₃ ⁏ ℂ) p0 (m , p1) p2 = m , 3com (ℂ m) (p0 m) p1 (p2 [ m ])
  3com (1₃ -[ M ]→ 1₃ ⁏ ℂ) p0 (m , p1) p2 = m , 3com (ℂ m) (p0 [ m ]) p1 (p2 [ m ])
  3com (1₃ -[ M ]→ 2₃ ⁏ ℂ) p0 (m , p1) p2 = m , 3com (ℂ m) (p0 [ m ]) p1 (p2 m)
  3com (2₃ -[ M ]→ 0₃ ⁏ ℂ) p0 p1 (m , p2) = m , 3com (ℂ m) (p0 m) (p1 [ m ]) p2
  3com (2₃ -[ M ]→ 1₃ ⁏ ℂ) p0 p1 (m , p2) = m , 3com (ℂ m) (p0 [ m ]) (p1 m) p2
  3com (2₃ -[ M ]→ 2₃ ⁏ ℂ) p0 p1 (m , p2) = m , 3com (ℂ m) (p0 [ m ]) (p1 [ m ]) p2
  3com (0₃ -[ M ]→★⁏    ℂ) (m , p0) p1 p2 = m , 3com (ℂ m) p0 (p1 m) (p2 m)
  3com (1₃ -[ M ]→★⁏    ℂ) p0 (m , p1) p2 = m , 3com (ℂ m) (p0 m) p1 (p2 m)
  3com (2₃ -[ M ]→★⁏    ℂ) p0 p1 (m , p2) = m , 3com (ℂ m) (p0 m) (p1 m) p2
  3com end p0 p1 p2 = _

  {- This does scale -}
  module _ {{_ : FunExt}} where
    3com' : (ℂ : MProto 𝟛) → ⟦ ℂ / 0₃? ⟧ → ⟦ ℂ / 1₃? ⟧ → ⟦ ℂ / 2₃? ⟧ → ⟦ MLog ℂ ⟧
    3com' ℂ p0 p1 p2 = group-merge' (R-p-¬p-1 0₃?) ℂ p0 (group-merge' R-1-2-¬0 ℂ p1 p2)
-- -}
-- -}
-- -}
-- -}

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


Add FunUniverse/Fin/Op/Abstract.agda

Add FunUniverse/Fin/Op/Abstract.agda

open import Type
open import Function
open import Data.Product using (proj₂)
open import Data.Two renaming (mux to mux₂)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; module ℕ°)
open import Data.Fin.NP as Fin using (Fin; inject+; raise; bound; free; zero; suc)
open import Data.Vec.NP using (Vec; []; _∷_; lookup; tabulate)
open import Data.Vec.Properties using (lookup∘tabulate)
open import Data.Bits using (Bits; _→ᵇ_; RewireTbl{-; 0ⁿ; 1ⁿ-})
open import Relation.Binary.PropositionalEquality

open import FunUniverse.Data
open import FunUniverse.Core
open import FunUniverse.Fin.Op
open import FunUniverse.Rewiring.Linear
open import FunUniverse.Category
open import Language.Simple.Interface

module FunUniverse.Fin.Op.Abstract where

private
  module BF = Rewiring finOpRewiring

module _ {E : ★ → ★} {Op} (lang : Lang Op 𝟚 E) where
    open Lang lang

    {-
    bits : ∀ {o} → Bits o → 0 →ᵉ o
    bits xs = 𝟚▹E ∘ flip Vec.lookup xs
    -}

    efinFunU : FunUniverse ℕ
    efinFunU = Bits-U , _→ᵉ_

    module EFinFunUniverse = FunUniverse efinFunU

    efinCat : Category _→ᵉ_
    efinCat = input , _∘ᵉ_

    private
      open EFinFunUniverse
      module _ {A B C D} (f : A `→ C) (g : B `→ D) where
        <_×_>  : (A `× B) `→ (C `× D)
        <_×_> x with Fin.cmp C D x
        <_×_> ._ | Fin.bound y = inject+ B <$> f y
        <_×_> ._ | Fin.free  y = raise   A <$> g y

    efinLin : LinRewiring efinFunU
    efinLin = mk efinCat (flip <_×_> input)
                         (λ {A} → input ∘ BF.swap {A})
                         (λ {A} → input ∘ BF.assoc {A})
                         input input <_×_> (λ {A} → <_×_> {A} input)
                         input input input input

    efinRewiring : Rewiring efinFunU
    efinRewiring = mk efinLin (λ()) (input ∘ BF.dup) (λ()) (λ f g → < f × g > ∘ᵉ (input ∘ BF.dup))
                      (input ∘ inject+ _) (λ {A} → input ∘ raise A)
                      (λ f → input ∘ BF.rewire f) (λ f → input ∘ BF.rewireTbl f)

    {-
    efinFork : HasFork efinFunU
    efinFork = cond , λ f g → second {1} < f , g > ⁏ cond
      where
        open Rewiring efinRewiring
        cond : ∀ {A} → `Bit `× A `× A `→ A
        cond {A} x = {!mux (return zero) (input (raise 1 (inject+ _ x))) (input (raise 1 (raise A x)))!}

    𝟚▹E = {!!}
    efinOps : FunOps efinFunU
    efinOps = mk efinRewiring efinFork (const (𝟚▹E 0₂)) (const (𝟚▹E 1₂))
    open Cong-*1 _→ᵉ_

    reify : ∀ {i o} → i →ᵇ o → i →ᵉ o
    reify = cong-*1′ ∘ FunOps.fromBitsFun efinOps
    -}

      {-
    eval-reify : eval (reify f)
    eval-reify = ?
    -}

    -- -}

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


Reflection.Scoped: a subset of the reflection API, scoped using nested data types

open import Reflection.NP using (Name; Arg; arg; Arg-info; arg-info; Literal; Visibility; visible; hidden; Relevance; relevant; irrelevant; Pattern; argᵛʳ; argʰʳ)
open import Level.NP
open import Data.List
open import Data.Nat renaming (_⊔_ to _⊔ℕ_)
open import Data.Sum.NP hiding (map)
open import Data.One
open import Data.Maybe.NP
open import Opaque

module Reflection.Scoped where

Scope : Set → (Set → Set) → Set → Set
Scope B F A = F (A ⊎ B)

mutual
  data Term (A : Set) : Set where
    -- Variable applied to arguments.
    var     : (x : A) (args : List (Arg (Term A))) → Term A
    -- Constructor applied to arguments.
    con     : (c : Name) (args : List (Arg (Term A))) → Term A
    -- Identifier applied to arguments.
    def     : (f : Name) (args : List (Arg (Term A))) → Term A
    -- Different kinds of λ-abstraction.
    lam     : (v : Visibility) (t : Scope 𝟙 Term A) → Term A
    -- Pattern matching λ-abstraction
    -- pat-lam : (cs : List (Clause A)) (args : List (Arg (Term A))) → Term A
    -- Pi-type.
    pi      : (t₁ : Arg (Type A)) (t₂ : Scope 𝟙 Type A) → Term A
    -- A sort.
    sort    : Sort A → Term A
    -- A literal.
    lit     : Literal → Term A
    -- Anything else.
    unknown : Term A

  data Type (A : Set) : Set where
    el : (s : Sort A) (t : Term A) → Type A

  data Sort (A : Set) : Set where
    -- A Set of a given (possibly neutral) level.
    set     : (t : Term A) → Sort A
    -- A Set of a given concrete level.
    lit     : (n : ℕ) → Sort A
    -- Anything else.
    unknown : Sort A

    {-
  data Clause (A : Set) : Set where
    clause : (ps : List (Arg Pattern)) → Scope (BoundPats ps) Term A → Clause A
    absurd-clause : List (Arg Pattern) → Clause A
    -}

Args : Set → Set
Args A = List (Arg (Term A))

unEl : ∀ {A} → Type A → Term A
unEl (el _ tm) = tm

getSort : ∀ {A} → Type A → Sort A
getSort (el s _) = s

unArg : ∀ {A} → Arg A → A
unArg (arg _ a) = a

-- sort₀ : Sort
pattern sort₀ = lit 0

-- sort₁ : Sort
pattern sort₁ = lit 1

-- `★_ : ℕ → Term
pattern  `★_ i = sort (lit i)

-- `★₀ : Term
pattern `★₀ = `★_ 0

-- el₀ : Term → Type
pattern el₀ t = el sort₀ t

-- Builds a type variable (of type ★₀)
{-
``var₀ : ℕ → Args → Type
``var₀ n args = el₀ (var n args)
-}

-- ``set : ℕ → ℕ → Type
pattern ``set i j = el (lit (suc j)) (`★_ i)

``★_ : ∀ {A} → ℕ → Type A
``★_ i = el (lit (suc i)) (`★_ i)

-- ``★₀ : Type
pattern ``★₀ = ``set 0 0

decode-Sort : ∀ {A} → Sort A → Maybe ℕ
--decode-Sort `set₀ = just zero
--decode-Sort (`setₛ_ s) = map? suc (decode-Sort (set s))
--decode-Sort (`set_ s) = decode-Sort s
decode-Sort (set _) = nothing
decode-Sort (lit n) = just n
decode-Sort unknown = nothing

pattern _`⊔_ s₁ s₂ = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

{-
_`⊔`_ : ∀ {A} → Sort A → Sort A → Sort A
s₁ `⊔` s₂ with decode-Sort s₁ | decode-Sort s₂
...          | just n₁        | just n₂        = lit (n₁ ⊔ℕ n₂)
...          | _              | _              = s₁ `⊔ s₂
-}

_`⊔`_ : ∀ {A} → Sort A → Scope 𝟙 Sort A → Sort A
s₁ `⊔` s₂ with decode-Sort s₁ | decode-Sort s₂
...          | just n₁        | just n₂        = lit (n₁ ⊔ℕ n₂)
...          | _              | _              = s₁ -- `⊔ s₂

pattern piᵛʳ t u = pi (argᵛʳ t) u
pattern piʰʳ t u = pi (argʰʳ t) u

`Π : ∀ {A} → Arg (Type A) → Scope 𝟙 Type A → Type A
`Π t u = el (getSort (unArg t) `⊔` getSort u) (pi t u)

`Πᵛʳ : ∀ {A} → Type A → Scope 𝟙 Type A → Type A
`Πᵛʳ t u = el (getSort t `⊔` getSort u) (piᵛʳ t u)

`Πʰʳ : ∀ {A} → Type A → Scope 𝟙 Type A → Type A
`Πʰʳ t u = el (getSort t `⊔` getSort u) (piʰʳ t u)

app : ∀ {A} → Term A → Args A → Term A
app (var x args) args₁ = var x (args ++ args₁)
app (con c args) args₁ = con c (args ++ args₁)
app (def f args) args₁ = def f (args ++ args₁)
app (lam v t) args = opaque "app/lam" unknown
-- app (pat-lam cs args) args₁ = opaque "app/pat-lam" unknown
app (pi t₁ t₂) args = opaque "app/pi" unknown
app (sort x) args = opaque "app/sort" unknown
app (lit x) args = opaque "app/lit" unknown
app unknown args = unknown

module Map where
    TermMap : (Set → Set) → Set₁
    TermMap F = ∀ {A B} → (A → B) → F A → F B

    ↑ : ∀ {A B C : Set} → (A → B) → (A ⊎ C) → (B ⊎ C)
    ↑ Γ (inl x) = inl (Γ x)
    ↑ Γ (inr y) = inr y

    term : TermMap Term
    tÿpe : TermMap Type
    args : TermMap Args
    sørt : TermMap Sort

    term Γ (var x as) = var (Γ x) (args Γ as)
    term Γ (con c as) = con c (args Γ as)
    term Γ (def d as) = def d (args Γ as)
    term Γ (lam v t) = lam v (term (↑ Γ) t)
    term Γ (pi (arg i t₁) t₂) = pi (arg i (tÿpe Γ t₁)) (tÿpe (↑ Γ) t₂)
    term Γ (sort x) = sort (sørt Γ x)
    term Γ (lit x) = lit x
    term Γ unknown = unknown

    tÿpe Γ (el s t) = el (sørt Γ s) (term Γ t)

    sørt Γ (set t) = set (term Γ t)
    sørt Γ (lit n) = lit n
    sørt Γ unknown = unknown

    args Γ []             = []
    args Γ (arg i t ∷ as) = arg i (term Γ t) ∷ args Γ as

-- Non-hereditary!
module Subst where
    VarSubst : Set → Set → Set
    VarSubst A B = A → Args B → Term B

    TermSubst : (Set → Set) → Set₁
    TermSubst F = ∀ {A B} → VarSubst A B → F A → F B

    ↑ : ∀ {A B C} → VarSubst A B → VarSubst (A ⊎ C) (B ⊎ C)
    ↑ Γ (inl x) as = app (Map.term inl (Γ x [])) as
    ↑ Γ (inr y) as = var (inr y) as

    term : TermSubst Term
    tÿpe : TermSubst Type
    args : TermSubst Args
    sørt : TermSubst Sort

    term Γ (var x as) = Γ x (args Γ as)
    term Γ (con c as) = con c (args Γ as)
    term Γ (def d as) = def d (args Γ as)
    term Γ (lam v t) = lam v (term (↑ Γ) t)
    term Γ (pi (arg i t₁) t₂) = pi (arg i (tÿpe Γ t₁)) (tÿpe (↑ Γ) t₂)
    term Γ (sort x) = sort (sørt Γ x)
    term Γ (lit x) = lit x
    term Γ unknown = unknown

    tÿpe Γ (el s t) = el (sørt Γ s) (term Γ t)

    sørt Γ (set t) = set (term Γ t)
    sørt Γ (lit n) = lit n
    sørt Γ unknown = unknown

    args Γ []             = []
    args Γ (arg i t ∷ as) = arg i (term Γ t) ∷ args Γ as

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


Added note on Mendelson's axioms.

Added note on Mendelson's axioms.

Ignore-this: c104ea1898a2c73827f738bf188d4439

darcs-hash:20120220191820-3bd4e-fa646ab5d6d1eeab01c2ff4943b5e60843f3c58a.gz

-- Tested with the development version of Agda on 20 February 2012.

module MendelsonAxioms where

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

postulate
  M       : Set
  zero    : M
  succ    : M → M
  _+_ _*_ : M → M → M

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

-- Impossible.
-- S₄ : ∀ {m n} → succ m ≡ succ n → m ≡ n
-- S₄ h = {!!}

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


WIP sketch System L

WIP sketch System L

import Parametric.Syntax.Type as Type

{--
-- Encoding types of polarized System L, as described in "A dissection of L".
--}

module Parametric.Syntax.LType where

-- The treatment of base type seems questionable. We might want instead to
-- distinguish base value types and base computation types. Or not, I'm not
-- sure.

module Structure (Base : Type.Structure) where
  open Type.Structure Base

  mutual
    -- Polarized L.
    --  Values (positive types)
    data VType : Set where
      vB : (ι : Base) → VType

      _⊗_ : (τ₁ : VType) → (τ₂ : VType) → VType
      vUnit : VType

      _⊕_ : (τ₁ : VType) → (τ₂ : VType) → VType
      vZero : VType

      ! : VType → VType
      ↓ : (c : CType) → VType

    data CType : Set where
      cB : (ι : Base) → CType

      _⅋_ : CType → CType → CType
      c⊥ : CType

      _&_ : CType → CType → CType
      c⊤ : CType

      ¿ : CType → CType
      ↑ : VType → CType

  _†v : VType → CType
  _†c : CType → VType

  vB ι †v = cB ι
  (v₁ ⊗ v₂) †v = (v₁ †v) ⅋ (v₂ †v)
  vUnit †v = c⊥
  (v₁ ⊕ v₂) †v = (v₁ †v) & (v₂ †v)
  vZero †v = c⊤
  ! v †v = ¿ (v †v)
  ↓ c †v = ↑ (c †c)

  cB ι †c = vB ι
  (c₁ ⅋ c₂) †c = c₁ †c ⊗ c₂ †c
  c⊥ †c = vUnit
  (c₁ & c₂) †c = (c₁ †c) ⊕ (c₂ †c)
  c⊤ †c = vZero
  ¿ c †c = ! (c †c)
  ↑ v †c = ↓ (v †v)

  open import Relation.Binary.PropositionalEquality

  -- This proof really calls for tactics, doesn't it?
  invV : ∀ {v} → v ≡ v †v †c
  invC : ∀ {c} → c ≡ c †c †v

  invV {vB ι} = refl
  invV {v₁ ⊗ v₂} = cong₂ _⊗_ invV invV
  invV {vUnit} = refl
  invV {v₁ ⊕ v₂} = cong₂ _⊕_ invV invV
  invV {vZero} = refl
  invV { ! v} = cong ! invV
  invV {↓ c} = cong ↓ invC

  invC {cB ι} = refl
  invC {c₁ ⅋ c₂} = cong₂ _⅋_ invC invC
  invC {c⊥} = refl
  invC {c₁ & c₂} = cong₂ _&_ invC invC
  invC {c⊤} = refl
  invC {¿ c} = cong ¿ invC
  invC {↑ x} = cong ↑ invV

  open import Base.Syntax.Context VType public
    using ()
    renaming
      ( ∅ to ∅∅
      ; _•_ to _••_
      ; _⋎_ to _⋎⋎_
      ; mapContext to mapVCtx
      ; Var to VVar
      ; Context to VContext
      ; this to vThis; that to vThat)

  fromVar : ∀ {Γ τ} → (f : Type → VType) → Var Γ τ → VVar (mapVCtx f Γ) (f τ)
  fromVar {x • Γ} f this = vThis
  fromVar {x • Γ} f (that v) = vThat (fromVar f v)

  data VTerm : (Ξ : VContext) → (Γ : VContext) → VType → Set
  data CTerm : (Ξ : VContext) → (Γ : VContext) → CType → Set

  -- Each constructor of the following types encodes a rule from the paper (Fig.
  -- 4); the original names are given in comments at the end of each row.

  data Cmd : (Ξ : VContext) → (Γ : VContext) → Set where
    -- I swapped the operands compared to the cut rule in the paper (Fig. 4),
    -- but this should be purely cosmetic.
    ⟨_∣_⟩ : ∀ {Ξ Γ Δ τ} → (v : CTerm Ξ Δ (τ †v)) → (u : VTerm Ξ Γ τ) → Cmd Ξ (Γ ⋎⋎ Δ) -- cut

  data VTerm where
    lvar : ∀ {Ξ A} → VTerm Ξ (A •• ∅∅) A        -- id
    vvar : ∀ {Ξ A} → VVar Ξ A → VTerm Ξ ∅∅ A   -- id'
    μ⇑_ : ∀ {Ξ Γ N} → Cmd Ξ (N †c •• Γ) → VTerm Ξ Γ (↓ N) -- ↓

    -- Multiplicative fragment
    _,_ : ∀ {Ξ Γ Δ A B} → VTerm Ξ Γ A → VTerm Ξ Δ B → VTerm Ξ (Γ ⋎⋎ Δ) (A ⊗ B) -- ⊗
    ⟨⟩ : ∀ {Ξ} → VTerm Ξ ∅∅ vUnit --1

    -- Additive fragment
    _₁as_ : ∀ {Ξ Γ A} → VTerm Ξ Γ A → ∀ B → VTerm Ξ Γ (A ⊕ B) -- ⊕L
    _₂as_ : ∀ {Ξ Γ B} → VTerm Ξ Γ B → ∀ A → VTerm Ξ Γ (A ⊕ B) -- ⊕R

    -- No rule for vZero

    -- Exponential fragment (in the sense of linear logic)

    ⦃⦄_ : ∀ {Ξ A} → VTerm Ξ ∅∅ A → VTerm Ξ ∅∅ (! A) -- !
    -- : ∀ {Ξ Γ A} →

  -- Compared to the paper, we avoid using † in indexes of the result, and
  -- exploit the fact that † is involutive. See for instance μ
  data CTerm where
    μ : ∀ {Ξ Γ N} → Cmd Ξ (N †c •• Γ) → CTerm Ξ Γ N
    ⇑ : ∀ {Ξ Γ A} → VTerm Ξ Γ A → CTerm Ξ Γ (↑ A) -- ↑

    -- Multiplicative fragment
    μ, : ∀ {Ξ Γ N M} → Cmd Ξ (N †c •• M †c •• Γ) → CTerm Ξ Γ (N ⅋ M) -- ⅋
    μ⟨⟩ : ∀ {Ξ Γ} → Cmd Ξ Γ → CTerm Ξ Γ c⊥ -- ⊥

    -- Additive fragment
    μ₁_μ₂_ : ∀ {Ξ Γ N M} → Cmd Ξ (N †c •• Γ) → Cmd Ξ (M †c •• Γ) → CTerm Ξ Γ (N & M)

    -- Exponential fragment (in the sense of linear logic)
    μ⦃⦄ : ∀ {Ξ Γ N} → Cmd (N †c •• Ξ) Γ → CTerm Ξ Γ (¿ N) -- ?

    -- : ∀ {Ξ Γ τ} →

  cast-invV : ∀ {Ξ Γ N} → VTerm Ξ Γ N → VTerm Ξ Γ ((N †v) †c)
  cast-invV {Ξ} {Γ} t = subst (VTerm Ξ Γ) invV t

  cast-invV2 : ∀ {Ξ Γ N} → VTerm Ξ Γ ((N †v) †c) → VTerm Ξ Γ N
  cast-invV2 {Ξ} {Γ} t = subst (VTerm Ξ Γ) (sym invV) t

  cast-invC : ∀ {Ξ Γ N} → CTerm Ξ Γ N → CTerm Ξ Γ ((N †c) †v)
  cast-invC {Ξ} {Γ} t = subst (CTerm Ξ Γ) invC t

  -- Check that type rules match by doing eta-expansion.
  -- (Is this checking harmony?)
  η-μ : ∀ {Ξ Γ N} → CTerm Ξ Γ N → CTerm Ξ Γ N
  η-μ t = μ ⟨ cast-invC t ∣ lvar ⟩

  maybe-η-μ⇑ : ∀ {Ξ Γ A} → VTerm Ξ Γ A → VTerm Ξ Γ (↓ (↑ A))
  maybe-η-μ⇑ t = μ⇑ ⟨ cast-invC (⇑ t) ∣ lvar ⟩

  -- A "thunk" combinator (from paper)
  ⇓ : ∀ {Ξ Γ N} → CTerm Ξ Γ N → VTerm Ξ Γ (↓ N)
  ⇓ t = μ⇑ ⟨ cast-invC t ∣ lvar ⟩

  -- from paper
  force : ∀ {Ξ Γ N} → VTerm Ξ Γ (↓ N) → CTerm Ξ Γ N
  force t = {! μ ⟨ ⇑ lvar ∣ t ⟩ !}

  -- XXX Here we "just" need to reorder variables in contexts. OMG, I screwed up
  -- (which is bad), or they use implicit exchange (which would be worse).
  η-μ⇑ : ∀ {Ξ Γ N} → VTerm Ξ Γ (↓ N) → VTerm Ξ Γ (↓ N)
  η-μ⇑ t = μ⇑ {! ⟨ ⇑ lvar ∣ t ⟩ !}

  n-μ, : ∀ {Ξ Γ N M} → CTerm Ξ Γ (N ⅋ M) → CTerm Ξ Γ (N ⅋ M)
  n-μ, t = μ, ⟨ cast-invC t ∣ lvar , lvar ⟩ -- The two lvars are in different contexts, so they have different types!

  η-μ⟨⟩ : ∀ {Ξ Γ} → CTerm Ξ Γ c⊥ → CTerm Ξ Γ c⊥
  η-μ⟨⟩ t = μ⟨⟩ ⟨ t ∣ ⟨⟩ ⟩

  η-μ⦃⦄ : ∀ {Ξ Γ N} → CTerm Ξ Γ (¿ N) → CTerm Ξ Γ (¿ N)
  η-μ⦃⦄ t = μ⦃⦄ ⟨  cast-invC {!weaken t!} ∣ ⦃⦄ (vvar vThis) ⟩

  β-expand-μ⟨⟩ : ∀ {Ξ Γ} → Cmd Ξ Γ → Cmd Ξ Γ
  β-expand-μ⟨⟩ c = ⟨ μ⟨⟩ c ∣ ⟨⟩ ⟩

  -- η-rules for sums look different.
  maybe-η-μ₁ : ∀ {Ξ Γ N M} → CTerm Ξ Γ N → CTerm Ξ Γ M → CTerm Ξ Γ (N & M)
  maybe-η-μ₁ t₁ t₂ = μ₁ ⟨ cast-invC t₁ ∣ lvar ⟩ μ₂  ⟨ cast-invC t₂ ∣ lvar ⟩

  η-μ₁ : ∀ {Ξ Γ N M} → CTerm Ξ Γ N → CTerm Ξ Γ M → CTerm Ξ Γ N
  η-μ₁ {M = M} t₁ t₂ =
    μ ⟨
      μ₁ ⟨ cast-invC (cast-invC t₁) ∣ lvar ⟩  μ₂ ⟨ cast-invC (cast-invC t₂) ∣ lvar ⟩
    ∣
      lvar ₁as (M †c)
    ⟩

  η-μ₂ : ∀ {Ξ Γ N M} → CTerm Ξ Γ N → CTerm Ξ Γ M → CTerm Ξ Γ M
  η-μ₂ {N = N} t₁ t₂ =
    μ ⟨
      μ₁ ⟨ cast-invC (cast-invC t₁) ∣ lvar ⟩  μ₂ ⟨ cast-invC (cast-invC t₂) ∣ lvar ⟩
    ∣
      lvar ₂as (N †c)
    ⟩

  -- Some syntactic sugar.
  _⊸_ : VType → CType → CType
  σ ⊸ τ = (σ †v) ⅋ τ

  _⇛_ : VType → CType → CType
  σ ⇛ τ = ! σ ⊸ τ

  -- Not checked again yet. This code comes from CBPV and was refactored for
  -- renamings done to get polarized L, so it might or might not work.

  cbnToCType : Type → CType
  cbnToCType (base ι) = ↑ (vB ι)
  cbnToCType (σ ⇒ τ) = ↓ (cbnToCType σ) ⇛ cbnToCType τ

  cbvToVType : Type → VType
  cbvToVType (base ι) = vB ι
  cbvToVType (σ ⇒ τ) = ↓ (cbvToVType σ ⇛ ↑ (cbvToVType τ))

  cbnToVType : Type → VType
  cbnToVType τ = ↓ (cbnToCType τ)

  cbvToCType : Type → CType
  cbvToCType τ = ↑ (cbvToVType τ)

  fromCBNCtx : Context → VContext
  fromCBNCtx Γ = mapVCtx cbnToVType Γ

  fromCBVCtx : Context → VContext
  fromCBVCtx Γ = mapVCtx cbvToVType Γ

  open import Data.List
  open Data.List using (List) public
  fromCBVToCompList : Context → List CType
  fromCBVToCompList Γ = mapVCtx cbvToCType Γ

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


Added note on unguarded co-recursive functions.

------------------------------------------------------------------------------
-- Alter: An unguarded co-recursive function
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Alter where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream

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

{-# NO_TERMINATION_CHECK #-}
alter : D
alter = true ∷ false ∷ alter

alter-Stream : Stream (alter)
alter-Stream = Stream-coind A h₁ h₂
  where
  A : D → Set
  A xs = xs ≡ xs

  h₁ : A alter → ∃[ x' ] ∃[ xs' ] alter ≡ x' ∷ xs' ∧ A xs'
  h₁ _ = true , (false ∷ alter) , refl , refl

  h₂ : A alter
  h₂ = refl

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


Added note about the existential.

Added note about the existential.

Ignore-this: 3d9fb02a35a02c6d345a892aead4a148

darcs-hash:20120226033342-3bd4e-4b43cf7250b47b730b02a9952914e3605575ce84.gz

-- Tested with the development version of Agda on 25 February 2012.

module Existential where

infixr 7 _,_

postulate
  D   : Set
  P Q : D → Set
  P→Q : ∀ {x} → P x → Q x

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

∃-elim : {P : D → Set}{Q : Set} → ∃ P → (∀ x → P x → Q) → Q
∃-elim (x , p) h = h x p

thm₁ : ∃ P → ∃ Q
thm₁ h = ∃-elim h (λ x Px → x , P→Q Px)

thm₂ : ∃ P → ∃ Q
thm₂ h = ∃-elim h helper
  where
  helper : ∀ x → P x → ∃ Q
  helper x Px = x , P→Q Px

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


moved the typed terms into a separate file

module Typed-Core where
open import Data.List
open import Data.Nat
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.Core

open import Core
open import Core-Lemmas
open import Typing

data Λ : Type -> Set where
  bv : ∀ {A} -> (i : ℕ) -> Λ A
  fv : ∀ {A} -> (x : Atom) -> Λ A
  lam : ∀ {B} -> (A : Type) -> (e : Λ B) -> Λ (A ⟶ B)
  app : ∀ {A B} -> (e₁ : Λ (A ⟶ B)) -> (e₂ : Λ A) -> Λ B
  Y : (t : Type) -> Λ ((t ⟶ t) ⟶ t)

data _~_ : ∀{t} -> Λ t -> PTerm -> Set where
  bv : ∀ {t i} -> (bv {t} i) ~ (bv i)
  fv : ∀ {t x} -> (fv {t} x) ~ (fv x)
  lam : ∀ {t s m m'} -> m ~ m' -> (lam {s} t m) ~ (lam m')
  app : ∀ {t s m n m' n'} -> m ~ m' -> n ~ n' -> (app {t} {s} m n) ~ (app m' n')
  Y : ∀ {t} -> (Y t) ~ (Y t)

Λ[_<<_] : ∀ {t} -> ℕ -> Atom -> Λ t -> Λ t
Λ[ k << x ] (bv i) = bv i
Λ[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
Λ[ k << x ] (lam t m) = lam t (Λ[ (suc k) << x ] m)
Λ[ k << x ] (app t1 t2) = app (Λ[ k << x ] t1) (Λ[ k << x ] t2)
Λ[ k << x ] (Y t) = Y t

⊢->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
⊢->Λ {m = bv i} ()
⊢->Λ {m = fv x} {t} Γ⊢m∶t = fv {t} x
⊢->Λ {m = lam m} (abs {_} {τ₁} {τ₂} L cf) =
  lam τ₁ ( Λ[ 0 << ∃fresh (L ++ FV m) ] (⊢->Λ (cf (∉-cons-l _ _ (∃fresh-spec (L ++ FV m)) ))) )
⊢->Λ {m = app s t} (app Γ⊢s Γ⊢t) = app (⊢->Λ Γ⊢s) (⊢->Λ Γ⊢t)
⊢->Λ {m = Y τ} (Y _) = Y τ

-- ⊢->Λ≡ : ∀ {Γ m n t} -> m ≡ n -> {Γ⊢m : Γ ⊢ m ∶ t} -> {Γ⊢n : Γ ⊢ n ∶ t} -> (⊢->Λ Γ⊢m) ≡ (⊢->Λ Γ⊢m)
-- ⊢->Λ≡ refl = λ {Γ⊢m} {Γ⊢n} → refl

Λ*^-*^~ : ∀ {τ x k} t t' -> _~_ {τ} t t' -> Λ[ k << x ] t ~ ([ k << x ] t')
Λ*^-*^~ _ _ bv = bv
Λ*^-*^~ {x = x} (fv y) _ fv with x ≟ y
Λ*^-*^~ (fv x) .(fv x) fv | yes _ = bv
Λ*^-*^~ (fv y) .(fv y) fv | no _ = fv
Λ*^-*^~ _ _ (lam {m = m} {m'} t~t') = lam (Λ*^-*^~ m m' t~t')
Λ*^-*^~ _ _ (app {m = m} {n} {m'} {n'} t~t' t~t'') = app (Λ*^-*^~ m m' t~t') (Λ*^-*^~ n n' t~t'')
Λ*^-*^~ _ _ Y = Y

⊢->Λ~ : ∀ {Γ t τ} -> (Γ⊢t : Γ ⊢ t ∶ τ) -> (⊢->Λ Γ⊢t) ~ t
⊢->Λ~ {t = bv i} ()
⊢->Λ~ {t = fv x} (var _ _) = fv
⊢->Λ~ {t = lam t} (abs {τ₁ = τ₁} {τ₂} L cf) = lam ih
  where
  x = ∃fresh (L ++ FV t)
  x∉ = ∃fresh-spec (L ++ FV t)
  x∷Γ⊢t^'x = cf (∉-cons-l _ _ x∉)

  sub : ∀ {τ x m} -> x ∉ FV t -> _~_ {τ} m t ≡ m ~ (* x ^ (t ^' x))
  sub {_} {x} x∉ rewrite fv-^-*^-refl x t {0} x∉ = refl

  ih : Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x) ~ t
  ih rewrite sub {_} {x} {Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x)} (∉-cons-r L _ x∉) =
    Λ*^-*^~ (⊢->Λ x∷Γ⊢t^'x) (t ^' x) (⊢->Λ~ (cf (∉-cons-l _ _ x∉)))
⊢->Λ~ {t = app t t₁} (app Γ⊢t Γ⊢t₁) = app (⊢->Λ~ Γ⊢t) (⊢->Λ~ Γ⊢t₁)
⊢->Λ~ {t = Y t₁} (Y x) = Y

Λ[_>>_] : ∀ {τ τ'} -> ℕ -> Λ τ' -> Λ τ -> Λ τ
Λ[_>>_] {τ} {τ'} k u (bv i) with k ≟ i | τ ≟T τ'
Λ[ k >> u ] (bv i) | yes _ | yes refl = u
... | yes _ | no _ = bv i
... | no _ | _ = bv i
Λ[ k >> u ] (fv x) = fv x
Λ[ k >> u ] (lam A t) = lam A (Λ[ (suc k) >> u ] t)
Λ[ k >> u ] (app t1 t2) = app (Λ[ k >> u ] t1) (Λ[ k >> u ] t2)
Λ[ k >> u ] (Y t) = Y t

error: pathspec 'Agda/Typed-Core.agda' did not match any file(s) known to git


Added example for discussion on induction.

------------------------------------------------------------------------------
-- Totality of predecessor function
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.PredTotality where

open import FOTC.Base

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

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

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

-- Proof by pattern matching.
pred-N : ∀ {n} → N n → N (pred₁ n)
pred-N nzero          = subst N (sym pred-0) nzero
pred-N (nsucc {n} Nn) = subst N (sym (pred-S n)) Nn

-- Proof using N-ind₁.
pred-N₁ : ∀ {n} → N n → N (pred₁ n)
pred-N₁ = N-ind₁ A A0 is
  where
  A : D → Set
  A i = N (pred₁ i)

  A0 : A zero
  A0 = subst N (sym pred-0) nzero

  is : ∀ {i} → N i → A i → A (succ₁ i)
  is {i} Ni ih = subst N (sym (pred-S i)) Ni

-- Proof using N-ind₂.
-- pred-N₂ : ∀ {n} → N n → N (pred₁ n)
-- pred-N₂ = N-ind₂ A A0 is
--   where
--   A : D → Set
--   A i = N (pred₁ i)

--   A0 : A zero
--   A0 = subst N (sym pred-0) nzero

--   is : ∀ {i} → A i → A (succ₁ i)
--   is {i} ih = {!!}

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


clean

clean

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


Initial version of Data.Bits

Initial version of Data.Bits

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Bool
open import Data.Fin using (Fin; zero; suc; toℕ; #_; inject₁)
open import Data.Vec hiding (_⊛_) renaming (map to vmap)
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry)
open import Function.NP hiding (_→⟨_⟩_)
open import Relation.Binary.PropositionalEquality
open import Algebra.FunctionProperties
import Data.List as L

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true
{-
data Bit : Set where
  0b 1b : Bit
-}

Bits : ℕ → Set
Bits = Vec Bit

0… : ∀ {n} → Bits n
0… = replicate 0b

-- Warning: 0… {0} ≡ 1… {0}
1… : ∀ {n} → Bits n
1… = replicate 1b

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1…

postulate
  ⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
  ⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
  ⊕-left-identity : ∀ {n} → LeftIdentity _≡_ (replicate 0b) (_⊕_ {n})
  ⊕-right-identity : ∀ {n} → RightIdentity _≡_ (replicate 0b) (_⊕_ {n})
  ⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ replicate 0b

  ⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ replicate 1b
  -- x ⊕ vnot x ≡ x ⊕ (1… ⊕ x) ≡ (x ⊕ x) ⊕ 1… ≡ 0… ⊕ 1… ≡ 1…

msb : ∀ {n} k → Bits (k + n) → Bits k
msb zero    bs       = []
msb (suc k) (b ∷ bs) = b ∷ msb k bs

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =

11ᵇ : Bits 2
11ᵇ = 1b ∷ 1b ∷ []

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

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

open M public

bits⁴ : Vec (Bits 4) 16
bits⁴ = fromList $ replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))
  where open RawMonad L.monad

0000b = bits⁴ ! # 0
0001b = bits⁴ ! # 1
0010b = bits⁴ ! # 2
0011b = bits⁴ ! # 3
0100b = bits⁴ ! # 4
0101b = bits⁴ ! # 5
0110b = bits⁴ ! # 6
0111b = bits⁴ ! # 7
1000b = bits⁴ ! # 8
1001b = bits⁴ ! # 9
1010b = bits⁴ ! # 10
1011b = bits⁴ ! # 11
1100b = bits⁴ ! # 12
1101b = bits⁴ ! # 13
1110b = bits⁴ ! # 14
1111b = bits⁴ ! # 15

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup
{- alternative
η {zero} = λ _ → []
η {suc n} = λ xs → head xs ∷ η (tail xs)
-}

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


program-distance.agda

program-distance.agda

module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count)
open import Data.Nat.NP
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import diff
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
    ]-[-cong : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'

  breaks : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  _≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ↺ c Bit) → Set
  ⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

  ≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
  ≗⅁-trans p q b R = trans (p b R) (q b R)

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ↺ c₀ Bit) (⅁₁ : Bit → ↺ c₁ Bit) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ↺ c Bit}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong (same-games 0b) (same-games 1b)

ext-count : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → count f xs ≡ count g xs
ext-count f≗g [] = refl
ext-count f≗g (x ∷ xs) rewrite ext-count f≗g xs | f≗g x = refl

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
ext-# f≗g = ext-count f≗g (allBits _)

module Implem k where

  --  diff (#1 f) (#1 g) ≥ 2^(-k) * 2^ c
  --  diff (#1 f) (#1 g) ≥ ε * 2^ c
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c
  --    where ε = 2^ -k
  -- {!dist (#1 f / 2^ c) (#1 g / 2^ c) > ε !}
  _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
  _]-[_ {c} f g = diff (Fin.toℕ #⟨ run↺ f ⟩) (Fin.toℕ #⟨ run↺ g ⟩) ≥ 2^(c ∸ k)

  ]-[-cong : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong f≗g f'≗g' f]-[f' rewrite ext-# f≗g | ext-# f'≗g' = f]-[f'

  prgDist : PrgDist
  prgDist = mk _]-[_ ]-[-cong

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


module Data.Nat.Ack where

open import Data.Nat.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

open ack-Props
open InflModule

postulate
  ↑3+ : ∀ a n b → a ↑⟨ 3 + n ⟩ b ≡ fold (_^_ a) (fold 1) n b
  -- mon↑3+'' : ∀ a b → Mon (λ n → fold (_^_ a) (fold 1) n b)

  mon↑3+' : ∀ b → Mon (λ n → fold (_^_ 2) (fold 1) n (3 + b))
-- mon↑3+' b = {!!}

mon↑3+ : ∀ b → Mon (λ n → 2 ↑⟨ 3 + n ⟩ (3 + b))
mon↑3+ b {m} {n} rewrite ↑3+ 2 m (3 + b) | ↑3+ 2 n (3 + b) = mon↑3+' b

open ↑-Props
lem>=3 : ∀ m n → 3 ≤ 2 ↑⟨ 3 + m ⟩ (3 + n)
lem>=3 m n = 3 ≤⟨ s≤s (s≤s (s≤s z≤n)) ⟩
             2 ↑⟨ 3 ⟩ 3 ≡⟨ ↑₃-^ 2 3 ⟩
             2 ^ 3 ≤⟨ lem2^3 n ⟩
             2 ^ (3 + n) ≡⟨ ≡.sym (↑₃-^ 2 (3 + n)) ⟩
             2 ↑⟨ 3 ⟩ (3 + n) ≤⟨ mon↑3+ n z≤n ⟩
             2 ↑⟨ 3 + m ⟩ (3 + n) ∎
  where open ≤-Reasoning

lem>=3'' : ∀ m n → 3 ≤ 2 ↑⟨ suc m ⟩ (3 + n)
lem>=3'' zero n = s≤s (s≤s (s≤s z≤n))
lem>=3'' (suc zero) n rewrite ↑₂-* 2 (3 + n) = s≤s (s≤s (s≤s z≤n))
lem>=3'' (suc (suc m)) n = lem>=3 m n
ack-↑ : ∀ m n → 3 + ack m n ≡ 2 ↑⟨ m ⟩ (3 + n)
ack-↑ zero n = ≡.refl
ack-↑ (suc m) zero = 3 + ack (suc m) 0   ≡⟨ ack-↑ m 1 ⟩
                     2 ↑⟨ m ⟩ 4          ≡⟨ ≡.cong (_↑⟨_⟩_ 2 m) (lem4212 m) ⟩
                     2 ↑⟨ suc m ⟩ 3 ∎
  where open ≡-Reasoning
ack-↑ (suc m) (suc n) = 3 + ack (suc m) (suc n)
                      ≡⟨ ≡.refl ⟩
                        3 + ack m (ack (suc m) n)
                      ≡⟨ ≡.refl ⟩
                        3 + ack m ((3 + ack (suc m) n) ∸ 3)
                      ≡⟨ ≡.cong (λ x → 3 + ack m (x ∸ 3)) (ack-↑ (suc m) n) ⟩
                         3 + ack m (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3)
                      ≡⟨ ack-↑ m (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3) ⟩
                         2 ↑⟨ m ⟩ (3 + (2 ↑⟨ suc m ⟩ (3 + n) ∸ 3))
                      ≡⟨ ≡.cong (λ x → 2 ↑⟨ m ⟩ x) (lem∸ (lem>=3'' m n)) ⟩
                         2 ↑⟨ m ⟩ (2 ↑⟨ suc m ⟩ (3 + n))
                      ≡⟨ ≡.refl ⟩
                        2 ↑⟨ suc m ⟩ (4 + n) ∎
  where open ≡-Reasoning

postulate
  1+a^-infl< : ∀ {a}  → Infl< (_^_ (1 + a))

--  2+a*1+b-infl< : ∀ a → Infl< (λ x → (2 + a) * (1 + x))
-- ∀ a b → b < (2 + a) * b
-- fold-a*-fold1 : ∀ {n a} → Infl< (_↑2+⟨_⟩_ (2 + a) n)
fold-a^-fold1 : ∀ {n a} → Infl< (fold (_^_ (1 + a)) (fold 1) n)
fold-a^-fold1 {n} = fold-infl< 1+a^-infl< fold1+-inflT< {n}

↑3+-mon : ∀ a n → Mon (fold (_^_ (1 + a)) (fold 1) n)
↑3+-mon a n = fold-mon' 1+a^-mon 1+a^-infl< (λ η₁ η₂ → fold-mon η₁ η₂) fold1+-inflT< {n}

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


clean

clean


Added draft for the function mirror-Tree.

Ignore-this: 850e3a11b04c024a7a64ededdb1e6dbc

darcs-hash:20110303140728-3bd4e-4ee6830368cdb96e613044a1d827af3f22f5f16e.gz

------------------------------------------------------------------------------
-- Properties related with the closures of the tree type
------------------------------------------------------------------------------

-- {-# OPTIONS --no-termination-check #-}
{-# OPTIONS --injective-type-constructors #-}

module Draft.Mirror.Tree.ClosuresI where

open import FOTC.Base

open import FOTC.Data.List

open import FOTC.Program.Mirror.Mirror
open import FOTC.Program.Mirror.ListTree.Closures
open import FOTC.Program.Mirror.ListTree.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

node-ListTree : ∀ {d ts} → Tree (node d ts) → ListTree ts
node-ListTree {d} (treeT .d LTts) = LTts

postulate
  reverse-∷' : ∀ x ys → reverse (x ∷ ys) ≡ reverse ys ++ (x ∷ [])

mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
mirror-Tree (treeT d nilLT) =
  subst Tree (sym (mirror-eq d [])) (treeT d helper₂)
    where
      helper₁ : rev (map mirror []) [] ≡ []
      helper₁ =
        begin
          rev (map mirror []) []
          ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
                   (map-[] mirror)
                   refl
          ⟩
          rev [] []
            ≡⟨ rev-[] [] ⟩
          []
        ∎

      helper₂ : ListTree (rev (map mirror []) [])
      helper₂ = subst ListTree (sym helper₁) nilLT

mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
  subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d helper)

  where
     h₁ : Tree (node d (reverse (map mirror ts)))
     h₁ = subst Tree (mirror-eq d ts) (mirror-Tree (treeT d LTts))

     h₂ : ListTree (reverse (map mirror ts))
     h₂ = node-ListTree h₁

     h₃ : ListTree ((reverse (map mirror ts)) ++ (mirror · t ∷ []))
     h₃ = ++-ListTree h₂ (consLT (mirror-Tree Tt) nilLT)

     h₄ : ListTree (reverse (mirror · t ∷ map mirror ts))
     h₄ = subst ListTree ( sym (reverse-∷' (mirror · t) (map mirror ts))) h₃

     helper : ListTree (reverse (map mirror (t ∷ ts)))
     helper = subst ListTree
              (subst (λ x → reverse x ≡ reverse (map mirror (t ∷ ts)))
                     (map-∷ mirror t ts)
                     refl)
              h₄

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


Update Agda tutorial code

Update Agda tutorial code

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


added models

added models

{-# OPTIONS --type-in-type --no-termination-check
 #-}

module Data where

_-_ : {A : Set}{B : A -> Set}{C : (a : A) -> B a -> Set} ->
      ({a : A}(b : B a) -> C a b) -> (f : (a : A) -> B a) ->
      (a : A) -> C a (f a)
f - g = \ x -> f (g x)

id : {X : Set} -> X -> X
id x = x

konst : {S : Set}{T : S -> Set} -> ({x : S} -> T x) -> (x : S) -> T x
konst c x = c

data Zero : Set where
record One : Set where

record Sig (S : Set)(T : S -> Set) : Set where
  field
    fst : S
    snd : T fst

open module Sig' {S : Set}{T : S -> Set} = Sig {S}{T}

_,_ : forall {S T}(s : S) -> T s -> Sig S T
s , t = record {fst = s; snd = t}

infixr 40 _,_

_*_ : Set -> Set -> Set
S * T = Sig S \ _ -> T

sig : forall {S T}{P : Sig S T -> Set} ->
      ((s : S)(t : T s) -> P (s , t)) -> (st : Sig S T) -> P st
sig f st = f (fst st) (snd st)

data Two : Set where
  tt : Two
  ff : Two

cond : {S : Two -> Set} -> S tt -> S ff -> (b : Two) -> S b
cond t f tt = t
cond t f ff = f

_+_ : Set -> Set -> Set
S + T = Sig Two (cond S T)

[_,_] : {S T : Set}{P : S + T -> Set} ->
        ((s : S) -> P (tt , s)) -> ((t : T) -> P (ff , t)) ->
        (x : S + T) -> P x
[ f , g ] = sig (cond f g)

data PROP : Set where
  Absu : PROP
  Triv : PROP
  _/\_ : PROP -> PROP -> PROP
  All : (S : Set) -> (S -> PROP) -> PROP

Prf : PROP -> Set
Prf Absu = Zero
Prf Triv = One
Prf (P /\ Q) = Prf P * Prf Q
Prf (All S P) = (x : S) -> Prf (P x)

data CON (I : Set) : Set where
  ?? : I -> CON I
  PrfC : PROP -> CON I
  _*C_ : CON I -> CON I -> CON I
  PiC : (S : Set) -> (S -> CON I) -> CON I
  SiC : (S : Set) -> (S -> CON I) -> CON I
  MuC : (O : Set) -> (O -> CON (I + O)) -> O -> CON I
  NuC : (O : Set) -> (O -> CON (I + O)) -> O -> CON I

mutual
  [|_|] : {I : Set} -> CON I -> (I -> Set) -> Set
  [| ?? i |]       X = X i
  [| PrfC P |]     X = Prf P
  [| C *C D |]     X = [| C |] X * [| D |] X
  [| PiC S C |]    X = (s : S) -> [| C s |] X
  [| SiC S C |]    X = Sig S \ s -> [| C s |] X
  [| MuC O C o |]  X = Mu C X o
  [| NuC O C o |]  X = Nu C X o

  data Mu {I O : Set}(C : O -> CON (I + O))(X : I -> Set)(o : O) : Set where
    con : [| C o |] [ X , Mu C X ] -> Mu C X o
  codata Nu {I O : Set}(C : O -> CON (I + O))(X : I -> Set)(o : O) : Set where
    con : [| C o |] [ X , Nu C X ] -> Nu C X o

noc :  {I O : Set}{C : O -> CON (I + O)}{X : I -> Set}{o : O} ->
       Nu C X o -> [| C o |] [ X , Nu C X ]
noc (con xs) = xs

mutual
  map : {I : Set}{X Y : I -> Set} -> (C : CON I) -> ((i : I) -> X i -> Y i) ->
        [| C |] X -> [| C |] Y
  map (?? i)       f = f i
  map (PrfC P)     f = id
  map (C *C D)     f = sig \ c d -> map C f c , map D f d
  map (PiC S C)    f = \ c s -> map (C s) f (c s)
  map (SiC S C)    f = sig \ s c -> s , map (C s) f c
  map (MuC O C o)  f = fold C (Mu C _) (\ o xs -> con (map (C o) [ f , konst id ] xs)) o
  map (NuC O C o)  f = unfold C (Nu C _) (\ o ss -> map (C o) [ f , konst id ] (noc ss)) o

  fold :  {I O : Set}(C : O -> CON (I + O)){X : I -> Set}(Y : O -> Set) ->
          ((o : O) -> [| C o |] [ X , Y ] -> Y o) ->
          (o : O) -> Mu C X o -> Y o
  fold C Y f o (con xs) = f o (map (C o) [ konst id , fold C Y f ] xs)

  unfold :  {I O : Set}(C : O -> CON (I + O)){X : I -> Set}(Y : O -> Set) ->
            ((o : O) -> Y o -> [| C o |] [ X , Y ]) ->
            (o : O) -> Y o -> Nu C X o
  unfold C Y f o y = con (map (C o) [ konst id , unfold C Y f ] (f o y))

induction : {I O : Set}(C : O -> CON (I + O)){X : I -> Set}
            (P : (o : O) -> Mu C X o -> Set) ->
            ((o : O)(xyps : [| C o |] [ X , (\ o -> Sig (Mu C X o) (P o)) ]) ->
             P o (con (map (C o) [ konst id , (\ o -> fst) ] xyps))) ->
            (o : O)(y : Mu C X o) -> P o y
induction C P p o (con xys) =
  p o (map (C o) [ konst id , (\ o y -> (y , induction C P p o y)) ] xys)

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


Lamport.Merkle: verifkey is a single hash, sig has half secrets and half hashes

{-# OPTIONS --without-K #-}
open import Function using (id; _∘_; _$_; flip)
open import Data.Nat.NP hiding (_==_)
open import Data.Fin using (Fin; zero; suc)
open import Data.Product.NP renaming (map to ×-map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning
import Crypto.Sig.Lamport

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

module B = Crypto.Sig.Lamport #digest #seed #secret #message hash-secret seed-expansion
module B1 = B.OTS1

open B using (H²)

H = hash-secret

#signkey   = B.#signkey
#verifkey  = #digest
#signature = B.#signature + #message * #digest

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

module signature (sig : Signature) where
  sigB        = take B.#signature sig
  module sigB = B.signature sigB
  sigB1s      = sigB.sig1s
  sigL1s      = map H sigB1s
  sigH        = drop B.#signature sig
  sigH1s      = group #message #digest sigH

verif-key : SignKey → VerifKey
verif-key = hash-verif-key
          ∘ B.verif-key

module signkey (sk : SignKey) where
  open B.signkey sk public renaming (vk to vkF) -- F"ull"
  vk   = verif-key sk

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

co-sign : Bits (2* #secret) → Bit → Digest
co-sign s b = H (B1.sign s (not b))

sign : SignKey → Message → Signature
sign sk m = sig
  module sign where
    open signkey sk public
    sigL   = B.sign sk m
    sigH1s = map co-sign sk1s ⊛ m
    sigB1s = map B1.sign sk1s ⊛ m
    sigL1s = map H sigB1s
    sigH   = concat sigH1s
    sig    = sigL ++ sigH
    module sigL = B.sign sk m
    module sig  = signature sig
    sigH1s-spec : sig.sigH1s ≡ sigH1s
    sigH1s-spec = sig.sigH1s                  ≡⟨ ap (group #message #digest) (drop-++ B.#signature sigL sigH) ⟩
                  group #message #digest sigH ≡⟨ group-concat sigH1s ⟩
                  sigH1s                      ∎
    sigB1s-spec : sig.sigB1s ≡ sigB1s
    sigB1s-spec = sig.sigB1s                  ≡⟨ ap (group #message #secret) (take-++ B.#signature sigL sigH) ⟩
                  group #message #secret sigL ≡⟨ group-concat sigL.sig1s ⟩
                  sigB1s                      ∎
    sigL1s-spec : sig.sigL1s ≡ sigL1s
    sigL1s-spec = ap (map H) sigB1s-spec

twist-, : Bit → Digest → Digest → Digest × Digest
twist-, b sL sH = proj′ (sL , sH) b , proj′ (sH , sL) b

twist-++ : ∀ {n}(b : Bit)(sL sH : Bits n) → Bits (2* n)
twist-++ b sL sH = proj′ (sL , sH) b ++ proj′ (sH , sL) b

twist-++-map2* : ∀ {m n}(f : Bits m → Bits n) b sL sH
               → map2* m n f (twist-++ b sL sH) ≡ twist-++ b (f sL) (f sH)
twist-++-map2* f 0b sL sH rewrite take-++ _ sL sH | drop-++ _ sL sH = refl
twist-++-map2* f 1b sL sH rewrite take-++ _ sH sL | drop-++ _ sH sL = refl

twist-++-not : ∀ {n}(f : Bit → Bits n) b
               → twist-++ b (f b) (f (not b)) ≡ f 0b ++ f 1b
twist-++-not f 0b = refl
twist-++-not f 1b = refl

verify : VerifKey → Message → Signature → Bit
verify vk m sig = root-hash == vk
  module verify where
    open signature sig public
    sig1s     = map twist-++ m ⊛ sigL1s ⊛ sigH1s
    root-hash = hash-verif-key (concat sig1s)

lemma1 : ∀ sk b → twist-++ b (H (B1.sign sk b)) (H (B1.sign sk (not b))) ≡ H² sk
lemma1 sk b =
  twist-++ b (H (B1.sign sk b)) (H (B1.sign sk (not b)))
      ≡⟨ ! twist-++-map2* H b _ _ ⟩
  H² (twist-++ b (B1.sign sk b) (B1.sign sk (not b)))
      ≡⟨ ap H² (twist-++-not (B1.sign sk) b) ⟩
  H² (B1.sign sk 0b ++ B1.sign sk 1b)
      ≡⟨ ap H² (B1.sign-both-reveals-signkey sk) ⟩
  H² sk
      ∎

verify-correct-sig : ∀ sk m → verify (verif-key sk) m (sign sk m) ≡ 1b
verify-correct-sig sk m = ==-reflexive {xs = root-hash} lemma
  where
     vk = verif-key sk
     sig = sign sk m
     module sig = sign sk m
     module sk = signkey sk
     open verify vk m sig

     lemma-pointwise : ∀ (i : Fin #message) →
           (map twist-++ m ⊛ sig.sigL1s ⊛ sig.sigH1s ‼ i) ≡
           (map H² sig.sk1s ‼ i)
     lemma-pointwise i =
       (map twist-++ m ⊛ sig.sigL1s ⊛ sig.sigH1s ‼ i)
           -- Pushes the lookup down the operations map/⊛
           ≡⟨ ‼-⊛= i {map twist-++ m ⊛ sig.sigL1s}
                (‼-⊛= i {map twist-++ m}
                   (‼-map= i twist-++ refl)
                   (‼-map= i H (‼-⊛= i (‼-map i _ _) refl)))
                (‼-⊛= i (‼-map i co-sign sig.sk1s) refl) ⟩
       twist-++ (m ‼ i) (H (B1.sign (sig.sk1s ‼ i) (m ‼ i))) (H (B1.sign (sig.sk1s ‼ i) (not (m ‼ i))))
           ≡⟨ lemma1 (sig.sk1s ‼ i) (m ‼ i) ⟩
       H² (sig.sk1s ‼ i)
           -- Wrap-up the lookup through the map
           ≡⟨ ! ‼-map i H² _ ⟩
       (map H² sig.sk1s ‼ i)
           ∎

     lemma : root-hash ≡ vk
     lemma = ap (hash-verif-key ∘ concat)
                (map twist-++ m ⊛ sigL1s ⊛ sigH1s
                   -- Since the signature to be verified is known to come from
                   -- the sign function, one can symbolically reduce the
                   -- processing of the bit vector layout done on both parts of
                   -- the signature (only take/drop-++, group-concat).
                   ≡⟨ ap₂ _⊛_ (ap₂ _⊛_ refl sig.sigL1s-spec) sig.sigH1s-spec ⟩
                 map twist-++ m ⊛ sig.sigL1s ⊛ sig.sigH1s
                   -- One proves this equality pointwise for all index in the
                   -- message m.
                   ≡⟨ vec= lemma-pointwise ⟩
                 map B1.verif-key sk.sk1s ∎)
-- -}
-- -}
-- -}
-- -}

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