A first step towards a field solver

A first step towards a field solver

import Algebra.Field as Field renaming (Field-Ops to RawField ; module Field-Ops to RawField)
import Algebra.RingSolver as RS

open import Relation.Binary.PropositionalEquality.NP

open import Level
open import Data.Nat as Nat using (ℕ ; suc ; zero)
open import Data.Fin
open import Data.One
open import Data.Product

open import Function

module Algebra.Field.Solver
  {f}{F : Set f}
  (𝔽 : Field.RawField F) where

module 𝔽 = Field.RawField 𝔽

data R-Op : Set where
  [+] [*] [-] : R-Op

data F-Op : Set where
  [+] [*] [-] [/] : F-Op

F-Op-eval : F-Op → F → F → F
F-Op-eval [+] x y = x 𝔽.+ y
F-Op-eval [*] x y = x 𝔽.* y
F-Op-eval [-] x y = x 𝔽.− y
F-Op-eval [/] x y = x 𝔽./ y

R-include : R-Op → F-Op
R-include [+] = [+]
R-include [*] = [*]
R-include [-] = [-]

R-Op-eval : R-Op → F → F → F
R-Op-eval op = F-Op-eval (R-include op)

data Tm (Op : Set)(m : ℕ) : Set f where
  op : (o : Op) (t₁ t₂ : Tm Op m) → Tm Op m
  con : F → Tm Op m
  var : Fin m → Tm Op m

infixl 6 _:+_ _:-_
infixl 7 _:*_ _:/_
pattern _:+_ x y = op [+] x y
pattern _:*_ x y = op [*] x y
pattern _:-_ x y = op [-] x y
pattern _:/_ x y = op [/] x y

module _ {m}{Op : Set}(evalOp : Op → F → F → F)(ρ : Fin m → F) where
  eval : Tm Op m → F
  eval (op o tm tm₁) = evalOp o (eval tm) (eval tm₁)
  eval (con x) = x
  eval (var x) = ρ x

infix 2 _/_:[_,_]
record Div {m} ρ (tm : Tm F-Op m) : Set f where
  constructor _/_:[_,_]
  field
    N : Tm R-Op m
    D : Tm R-Op m
    .nonZero-D : eval R-Op-eval ρ D ≢ 𝔽.0ᶠ
    .is-Correct : eval F-Op-eval ρ tm ≡ eval R-Op-eval ρ N 𝔽./ eval R-Op-eval ρ D

module _ (FS : Field.Field-Struct 𝔽) where
  open Field.Field-Struct {{...}}

  {-
  toRingOp : ∀ {m} → F-Op → Div {m} → Div {m} → Div {m}
  toRingOp [+] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* D' :+ N' :* D  / D :* D'
                                                :[ (λ ρ → noZeroDivisor (P ρ) (P' ρ) ) ]
  toRingOp [*] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* N' / D :* D' :[ (λ ρ → noZeroDivisor (P ρ) (P' ρ)) ]
  toRingOp [-] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* D' :- N' :* D / D :* D'
                                                :[ (λ ρ → noZeroDivisor (P ρ) (P' ρ)) ]
  toRingOp [/] (N / D :[ P ]) (N' / D' :[ P' ]) = N :* D' / N' :* D :[ {!!} ]
  -}

  module _ {m} (ρ : Fin m → F) where
    Assumptions : Tm F-Op m → Set f
    Assumptions (op [+] tm tm₁) = Assumptions tm × Assumptions tm₁
    Assumptions (op [*] tm tm₁) = Assumptions tm × Assumptions tm₁
    Assumptions (op [-] tm tm₁) = Assumptions tm × Assumptions tm₁
    Assumptions (op [/] tm tm₁) = Assumptions tm × Assumptions tm₁ × eval F-Op-eval ρ tm₁ ≢ 0ᶠ
    Assumptions (con x) = Lift 𝟙
    Assumptions (var x) = Lift 𝟙

    toRing : ∀ (tm : Tm F-Op m) → Assumptions tm → Div {m} ρ tm
    toRing (op [+] tm tm₁) (atm , atm₁) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = N :* D₁ :+ N₁ :* D / D :* D₁
                                               :[ noZeroDivisor nD nD₁ , += isC isC₁ ∙ +-quotient nD nD₁ ]
    toRing (op [*] tm tm₁) (atm , atm₁) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = N :* N₁ / D :* D₁
                                               :[ noZeroDivisor nD nD₁ , *= isC isC₁ ∙ *-quotient nD nD₁ ]
    toRing (op [-] tm tm₁) (atm , atm₁) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = N :* D₁ :- N₁ :* D / D :* D₁
                                               :[ noZeroDivisor nD nD₁ , −= isC isC₁ ∙ −-quotient nD nD₁ ]
    toRing (op [/] tm tm₁) (atm , atm₁ , tm₁/=0) with toRing tm atm | toRing tm₁ atm₁
    ... | N / D :[ nD , isC ] | N₁ / D₁ :[ nD₁ , isC₁ ] = (N :* D₁) / (D :* N₁)
                                               :[ noZeroDivisor nD nN₁ , /= isC isC₁ ∙ /-quotient nN₁ nD nD₁ ]
      where .nN₁ : eval R-Op-eval ρ N₁ ≢ 0ᶠ
            nN₁ p = tm₁/=0 (isC₁ ∙ *= p refl ∙ 0*-zero)
    toRing (con x) _ = con x / con 𝔽.1ᶠ :[ 0≢1 ∘ !_ , ! (*= refl 1⁻¹≡1 ∙ *1-identity) ]
    toRing (var x) _ = var x / con 𝔽.1ᶠ :[ 0≢1 ∘ !_ , ! (*= refl 1⁻¹≡1 ∙ *1-identity) ]

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

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


added agda model of list-style datatypes

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

module LLev where

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO ze  #-}
{-# BUILTIN LEVELSUC  su   #-}

max : Level -> Level -> Level
max  ze     m     = m
max (su n)  ze    = su n
max (su n) (su m) = su (max n m)

{-# BUILTIN LEVELMAX max #-}

record Up {l : Level} (A : Set l) : Set (su l) where
  constructor up
  field down : A
open Up

record Sg {l : Level}(S : Set l)(T : S -> Set l) : Set l where
  constructor _,_
  field
    fst : S
    snd : T fst
open Sg
_*_ : {l : Level} -> Set l -> Set l -> Set l
S * T = Sg S \ _ -> T
infixr 4 _*_ _,_

data Zero : Set where

record One {l : Level} : Set l where
  constructor <>

data Desc {l : Level}(I : Set l) : Set (su l) where
  var : (i : I) -> Desc I
  con : (A : Set l) -> Desc I
  sg pi : (S : Set l)(T : S -> Desc I) -> Desc I
  _**_ : (S T : Desc I) -> Desc I
infixr 4 _**_

[!_!] : {l : Level}{I : Set l} -> Desc I -> (I -> Set l) -> Set l
[! var i !] X = X i
[! con A !] X = A
[! sg S T !] X = Sg S \ s -> [! T s !] X
[! pi S T !] X = (s : S) -> [! T s !] X
[! S ** T !] X = [! S !] X * [! T !] X

{-
data Mu {l : Level}(I : Set l)(F : I -> Desc I)(i : I) : Set l where
  <_> : [! F i !] (Mu I F) -> Mu I F i
-}

All : {l : Level}{I : Set l}
      (D : Desc I)(X : I -> Set l) -> [! D !] X -> Desc (Sg I X)
All (var i) X x = var (i , x)
All (con A) X d = con One
All (sg S T) X (s , t) = All (T s) X t
All (pi S T) X f = pi S \ s -> All (T s) X (f s)
All (S ** T) X (s , t) = All S X s ** All T X t

all : {l : Level}{I : Set l}
      (D : Desc I)(X : I -> Set l)(P : Sg I X -> Set l) ->
      ((ix : Sg I X) -> P ix) ->
      (d : [! D !] X) -> [! All D X d !] P
all (var i) X P p x = p (i , x)
all (con A) X P p d = _
all (sg S T) X P p (s , t) = all (T s) X P p t
all (pi S T) X P p f = \ s -> all (T s) X P p (f s)
all (S ** T) X P p (s , t) = all S X P p s , all T X P p t

{-
induction :  {l : Level}{I : Set l}{F : I -> Desc I}
             (P : Sg I (Mu I F) -> Set l) ->
             ((i : I)(d : [! F i !] (Mu I F)) ->
               [! All (F i) (Mu I F) d !] P -> P (i , < d >)) ->
             (ix : Sg I (Mu I F)) -> P ix
induction {F = F} P p (i , < d >) = p i d (all (F i) (Mu _ F) P (induction P p) d)
-}

{-
mutual
  induction :  {l : Level}{I : Set l}{F : I -> Desc I}
               (P : Sg I (Mu I F) -> Set l) ->
               ((i : I)(d : [! F i !] (Mu I F)) ->
                 [! All (F i) (Mu I F) d !] P -> P (i , < d >)) ->
               {i : I}(x : Mu I F i) -> P (i , x)
  induction {F = F} P p {i} < d > = p i d (allInduction F P p (F i) d)
  allInduction : {l : Level}{I : Set l}(F : I -> Desc I)
                 (P : Sg I (Mu I F) -> Set l) ->
                 ((i : I)(d : [! F i !] (Mu I F)) ->
                    [! All (F i) (Mu I F) d !] P -> P (i , < d >)) ->
                 (D : Desc I) ->
                 (d : [! D !] (Mu I F)) -> [! All D (Mu I F) d !] P
  allInduction F P p (var i) d = induction P p d
  allInduction F P p (con A) d = _
  allInduction F P p (sg S T) (s , t) = allInduction F P p (T s) t
  allInduction F P p (pi S T) f = \ s -> allInduction F P p (T s) (f s)
  allInduction F P p (S ** T) (s , t) = allInduction F P p S s , allInduction F P p T t
-}

data List {l : Level}(X : Set l) : Set l where
  [] : List X
  _::_ : X -> List X -> List X
infixr 3 _::_

map : {k l : Level}{X : Set k}{Y : Set l} -> (X -> Y) -> List X -> List Y
map f [] = []
map f (x :: xs) = f x :: map f xs

data UId {l : Level} : Set l where
  ze : UId
  su : UId {l} -> UId

data # {l : Level} : List {l} UId -> Set l where
  ze : forall {x xs} -> # (x :: xs)
  su : forall {x xs} -> # xs -> # (x :: xs)

Constrs : {l : Level} -> Set l -> Set (su l)
Constrs I = List (Up UId * Desc I)

Constr : {l : Level}{I : Set l} -> Constrs I -> Set l
Constr uDs = # (map (\ uD -> down (fst uD)) uDs)

ConD : {l : Level}{I : Set l}(uDs : Constrs I) -> Constr uDs -> Desc I
ConD [] ()
ConD (uD :: _)  ze     = snd uD
ConD (_ :: uDs) (su c) = ConD uDs c

data Data {l : Level}{I : Set l}(F : I -> Constrs I)(i : I) : Set l where
  _/_ : (u : Constr (F i))(d : [! ConD (F i) u !] (Data F)) -> Data F i

{-
DataD : {l : Level}{I : Set l} -> Constrs I -> Desc I
DataD uDs = sg (Constr uDs) (ConD uDs)

Data : {l : Level}{I : Set l}(F : I -> Constrs I)(i : I) -> Set l
Data F = Mu _ \ i -> DataD (F i)
-}

MethodD : {l : Level}{I : Set l}(X : I -> Set l)
          (uDs : Constrs I)
          (P : Sg I X -> Set l)
          (i : I) -> ((u : Constr uDs)(d : [! ConD uDs u !] X) -> X i) -> Set l
MethodD X [] P i c = One
MethodD X ((u , D) :: uDs) P i c
  = ((d : [! D !] X) -> [! All D X d !] P -> P (i , c ze d))
  * MethodD X uDs P i (\ u d -> c (su u) d)

mutual
  induction : {l : Level}{I : Set l}{F : I -> Constrs I}{i : I}(x : Data F i)
              (P : Sg I (Data F) -> Set l)
              (ps : (i : I) -> MethodD (Data F) (F i) P i _/_)
              -> P (i , x)
  induction {F = F}{i = i}(u / d) P ps = indMethod P ps (F i) _/_ (ps i) u d
  indMethod : {l : Level}{I : Set l}{F : I -> Constrs I}{i : I}
              (P : Sg I (Data F) -> Set l)
              (ps : (i : I) -> MethodD (Data F) (F i) P i _/_)
              (uDs : Constrs I)
              (c : (u : Constr uDs) -> [! ConD uDs u !] (Data F) -> Data F i)
              (ms : MethodD (Data F) uDs P i c)
              (u : Constr uDs)
              (d : [! ConD uDs u !] (Data F))
              -> P (i , c u d)
  indMethod P ps [] c ms () d
  indMethod P ps ((u , D) :: _) c (p , ms) ze d = p d (indHyps P ps D d)
  indMethod P ps ((_ , _) :: uDs) c (m , ms) (su u) d
    = indMethod P ps uDs _ ms u d
  indHyps : {l : Level}{I : Set l}{F : I -> Constrs I}
            (P : Sg I (Data F) -> Set l)
            (ps : (i : I) -> MethodD (Data F) (F i) P i _/_)
            (D : Desc I)
            (d : [! D !] (Data F))
            -> [! All D (Data F) d !] P
  indHyps P ps (var i) x = induction x P ps
  indHyps P ps (con A) a = _
  indHyps P ps (sg S T) (s , t) = indHyps P ps (T s) t
  indHyps P ps (pi S T) f = \ s -> indHyps P ps (T s) (f s)
  indHyps P ps (S ** T) (s , t) = indHyps P ps S s , indHyps P ps T t

zi : {l : Level} -> UId {l}
zi = ze

si : {l : Level} -> UId {l}
si = su ze

data UQ {l : Level}(x : UId {l}) : UId {l} -> Set l where
  yes : UQ x x
  no  : {y : UId {l}} -> UQ x y

uq : {l : Level}(x y : UId {l}) -> UQ x y
uq ze ze = yes
uq ze (su y) = no
uq (su x) ze = no
uq (su x) (su y) with uq x y
uq (su x) (su .x) | yes = yes
uq (su x) (su y)  | no  = no

UIn : {l : Level}(x : UId {l}) -> List (UId {l}) -> Set
UIn x [] = Zero
UIn x (y :: ys) with uq x y
UIn x (.x :: _) | yes = One
UIn x (_ :: ys) | no = UIn x ys

uin : {l : Level}(x : UId {l})(ys : List (UId {l})) -> UIn x ys -> # ys
uin x [] ()
uin x (y :: ys) p with uq x y
uin x (.x :: _) _ | yes = ze
uin x (_ :: ys) p | no  = su (uin x ys p)

_!_ : {l : Level}{I : Set l}{F : I -> Constrs I}{i : I} ->
      let us = map (\ uD -> down (fst uD)) (F i) in
      (u : UId {l}){p : UIn u us} ->
      [! ConD (F i) (uin u us p) !] (Data F) ->
      Data F i
_!_ {l}{I}{F}{i} u {p} d = uin u (map (\ uD -> down (fst uD)) (F i)) p / d

infixr 3 _!_

NAT : {l : Level} -> One {l} -> Constrs {l} One
NAT _ = up zi , con One
     :: up si , var _ ** con One
     :: []

ZE : {l : Level} -> Data {l} NAT <>
ZE = zi ! <>

SU : {l : Level} -> Data {l} NAT <> -> Data {l} NAT <>
SU n = si ! n , <>

vari : {l : Level} -> UId {l}
vari = ze
coni : {l : Level} -> UId {l}
coni = su ze
sgi : {l : Level} -> UId {l}
sgi = su (su ze)
pii : {l : Level} -> UId {l}
pii = su (su (su ze))
asti : {l : Level} -> UId {l}
asti = su (su (su (su ze)))

DESC : {l : Level}(I : Set l) -> One {su l} -> Constrs {su l} One
DESC I _ = up vari , con (Up I) ** con One
        :: up coni , con (Set _) ** con One
        :: up sgi , (sg (Set _) \ S -> (pi (Up S) \ _ -> var _) ** con One)
        :: up pii , (sg (Set _) \ S -> (pi (Up S) \ _ -> var _) ** con One)
        :: up asti , var _ ** var _ ** con One
        :: []

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


clean up

clean up

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


Added a example of combined proof instantiating the induction principle.

------------------------------------------------------------------------------
-- Commutativity of addition
------------------------------------------------------------------------------

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

module FOT.PA.Axiomatic.Standard.AddComm where

open import Common.FOL.Relation.Binary.EqReasoning

open import PA.Axiomatic.Standard.Base

------------------------------------------------------------------------------
-- Auxiliary functions

succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succCong = cong succ

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

+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity = PA-ind A A0 is
  where
  A : M → Set
  A i = i + zero ≡ i

  A0 : A zero
  A0 = +-leftIdentity zero

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + zero   ≡⟨ PA₄ i zero ⟩
            succ (i + zero) ≡⟨ succCong ih ⟩
            succ i          ∎

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

  A0 : A zero
  A0 = zero + succ n   ≡⟨ +-leftIdentity (succ n) ⟩
       succ n          ≡⟨ succCong (sym (+-leftIdentity n)) ⟩
       succ (zero + n) ∎

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + succ n     ≡⟨ PA₄ i (succ n) ⟩
            succ (i + succ n)   ≡⟨ succCong ih ⟩
            succ (succ (i + n)) ≡⟨ succCong (sym (PA₄ i n)) ⟩
            succ (succ i + n)   ∎

------------------------------------------------------------------------------
-- Interactive proof

+-comm₁ : ∀ m n → m + n ≡ n + m
+-comm₁ m n = PA-ind A A0 is m
  where
  A : M → Set
  A i = i + n ≡ n + i

  A0 : A zero
  A0 = zero + n ≡⟨ +-leftIdentity n ⟩
       n        ≡⟨ sym (+-rightIdentity n) ⟩
       n + zero ∎

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + n   ≡⟨ PA₄ i n ⟩
            succ (i + n) ≡⟨ succCong ih ⟩
            succ (n + i) ≡⟨ sym (x+Sy≡S[x+y] n i) ⟩
            n + succ i   ∎

------------------------------------------------------------------------------
-- Combined proof

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

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

  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is x+Sy≡S[x+y] #-}

------------------------------------------------------------------------------
-- Interactive proof instantiating the induction principle

+-comm-ind : ∀ n →
             (zero + n ≡ n + zero) →
             (∀ m → m + n ≡ n + m → succ m + n ≡ n + succ m) →
             ∀ m → m + n ≡ n + m
+-comm-ind n = PA-ind (λ i → i + n ≡ n + i)

+-comm₃ : ∀ m n → m + n ≡ n + m
+-comm₃ m n = +-comm-ind n base is m
  where
  base : zero + n ≡ n + zero
  base = zero + n ≡⟨ +-leftIdentity n ⟩
         n        ≡⟨ sym (+-rightIdentity n) ⟩
         n + zero ∎

  is : ∀ i → i + n ≡ n + i → succ i + n ≡ n + succ i
  is i ih = succ i + n   ≡⟨ PA₄ i n ⟩
            succ (i + n) ≡⟨ succCong ih ⟩
            succ (n + i) ≡⟨ sym (x+Sy≡S[x+y] n i) ⟩
            n + succ i   ∎

------------------------------------------------------------------------------
-- Combined proof instantiating the induction principle

-- TODO. 25 October 2012. Why is it not necessary the hypothesis
-- +-rightIdentity ?
postulate +-comm₄ : ∀ m n → m + n ≡ n + m
{-# ATP prove +-comm₄ +-comm-ind x+Sy≡S[x+y] #-}

error: pathspec 'notes/FOT/PA/Axiomatic/Standard/AddComm.agda' did not match any file(s) known to git


normal tuple syntax

normal tuple syntax


how internal flipping the coin affects the count

module dist-props where

open import Data.Bool
open import Data.Nat.NP
open import Data.Product

open import Function

open import Search.Type
open import Search.Sum

open import Search.Searchable.Sum
open import Search.Searchable.Product

open import Relation.Binary.PropositionalEquality.NP

module GameFlipping (R : Set)(sum : Sum R)(sum-ind : SumInd sum)(X Y : R → Bool) where

  R' = Bool × R
  sum' : Sum R'
  sum' = searchBit _+_ ×-sum sum

  open FromSum sum' renaming (count to count')
  open FromSumInd sum-ind

  _==ᴮ_ : Bool → Bool → Bool
  true  ==ᴮ y = y
  false ==ᴮ y = not y

  G : R' → Bool
  G (b , r) = b ==ᴮ (if b then X r else Y r)

  1/2 : R' → Bool
  1/2 = proj₁

  lemma : ∀ X → sum (const 1) ≡ count (not ∘ X) + count X
  lemma X = sum-ind P (λ {a}{b} → part1 {a}{b}) part2
    where
      # = FromSum.count

      P = λ s → s (const 1) ≡ # s (not ∘ X) + # s X

      part1 : ∀ {s₀ s₁} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f)
      part1 {s₀} {s₁} Ps₀ Ps₁ rewrite Ps₀ | Ps₁ = +-interchange (# s₀ (not ∘ X)) (# s₀ X) (# s₁ (not ∘ X)) (# s₁ X)

      part2 : ∀ x → P (λ f → f x)
      part2 x with X x
      part2 x | true  = refl
      part2 x | false = refl

  thm : dist (count' G) (count' 1/2) ≡ dist (count X) (count Y)
  thm = dist (count' G) (count' 1/2)
      ≡⟨ refl ⟩
        dist (count (not ∘ Y) + count X) (sum (const 0) + sum (const 1))
      ≡⟨ cong (λ p → dist (count (not ∘ Y) + count X) (p + sum (const 1))) sum-zero ⟩
        dist (count (not ∘ Y) + count X) (sum (const 1))
      ≡⟨ cong (dist (count (not ∘ Y) + count X)) (lemma Y) ⟩
        dist (count (not ∘ Y) + count X) (count (not ∘ Y) + count Y)
      ≡⟨ dist-x+ (count (not ∘ Y)) (count X) (count Y) ⟩
        dist (count X) (count Y)
      ∎
    where
      open ≡-Reasoning

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


Add Control.Strategy.Utils

Add Control.Strategy.Utils

{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.Product
open import Control.Strategy renaming (map to mapS)

module Control.Strategy.Utils where

record Proto : ★₁ where
  constructor P[_,_]
  field
    Q : ★
    R : Q → ★

Client : Proto → ★ → ★
Client P[ Q , R ] A = Strategy Q R A

{-
data Bisim {P P' A A'} (RA : A → A' → ★) : Client P A → Client P' A' → ★ where
  ask-nop : ∀ {q? cont clt} r
            → Bisim RA (cont r) clt
            → Bisim RA (ask q? cont) clt
  ask-ask : ∀ q₀ q₁ cont₀ cont₁ r₀ r₁
            → ({!!} → Bisim RA (cont₀ r₀) (cont₁ r₁))
            → Bisim RA (ask q₀ cont₀) (ask q₁ cont₁)
-}
module Unused where
  mapS' : ∀ {A B Q Q' R} (f : A → B) (g : Q → Q') → Strategy Q (R ∘ g) A → Strategy Q' R B
  mapS' f g (ask q cont) = ask (g q) (λ r → mapS' f g (cont r))
  mapS' f g (done x)     = done (f x)

[_,_]=<<_ : ∀ {A B Q Q' R} (f : A → Strategy Q' R B) (g : Q → Q') → Strategy Q (R ∘ g) A → Strategy Q' R B
[ f , g ]=<< ask q? cont = ask (g q?) (λ r → [ f , g ]=<< cont r)
[ f , g ]=<< done x      = f x

module Rec {A B Q : ★} {R : Q → ★} {M : ★ → ★}
           (runAsk : ∀ {A} → (q : Q) → (R q → M A) → M A)
           (runDone : A → M B) where
  runMM : Strategy Q R A → M B
  runMM (ask q? cont) = runAsk q? (λ r → runMM (cont r))
  runMM (done x)      = runDone x

module MM {A B Q : ★} {R : Q → ★} {M : ★ → ★}
         (_>>=M_ : ∀ {A B : ★} → M A → (A → M B) → M B)
         (runAsk : (q : Q) → M (R q))
         (runDone : A → M B) where
  runMM : Strategy Q R A → M B
  runMM (ask q? cont) = runAsk q? >>=M (λ r → runMM (cont r))
  runMM (done x)      = runDone x

module _ {A B Q Q' : ★} {R : Q → ★} {R'}
         (f : (q : Q) → Strategy Q' R' (R q))
         (g : A → Strategy Q' R' B) where
  [_,_]=<<'_ : Strategy Q R A → Strategy Q' R' B
  [_,_]=<<'_ (ask q? cont) = f q? >>= λ r → [_,_]=<<'_ (cont r)
  [_,_]=<<'_ (done x)      = g x

record ServerResp (P : Proto) (q : Proto.Q P) (A : ★₀) : ★₀ where
  coinductive
  open Proto P
  field
      srv-resp : R q
      srv-cont : ∀ q → ServerResp P q A
open ServerResp

Server : Proto → ★₀ → ★₀
Server P A = ∀ q → ServerResp P q A

OracleServer : Proto → ★₀
OracleServer P[ Q , R ] = (q : Q) → R q

module _ {P : Proto} {A : ★} where
  open Proto P
  com : Server P A → Client P A → A
  com srv (ask q κc) = com (srv-cont r) (κc (srv-resp r)) where r = srv q
  com srv (done x)   = x

module _ {P P' : Proto} {A A' : ★} where
  module P = Proto P
  module P' = Proto P'
  record MITM : ★ where
    coinductive
    field
      hack-query : (q' : P'.Q) → Client P (P'.R q' × MITM)
      hack-result : A' → Client P A
  open MITM

  module WithOutBind where
      hacked-com-client : Server P A → MITM → Client P' A' → A
      hacked-com-mitm : ∀ {q'} → Server P A → Client P (P'.R q' × MITM) → (P'.R q' → Client P' A') → A
      hacked-com-srv-resp : ∀ {q q'} → ServerResp P q A → (P.R q → Client P (P'.R q' × MITM)) → (P'.R q' → Client P' A') → A

      hacked-com-srv-resp r mitm clt = hacked-com-mitm (srv-cont r) (mitm (srv-resp r)) clt

      hacked-com-mitm srv (ask q? mitm) clt = hacked-com-srv-resp (srv q?) mitm clt
      hacked-com-mitm srv (done (r' , mitm)) clt = hacked-com-client srv mitm (clt r')

      hacked-com-client srv mitm (ask q' κc) = hacked-com-mitm srv (hack-query mitm q') κc
      hacked-com-client srv mitm (done x) = com srv (hack-result mitm x)

  mitm-to-client-trans : MITM → Client P' A' → Client P A
  mitm-to-client-trans mitm (ask q? cont) = hack-query mitm q? >>= λ { (r' , mitm') → mitm-to-client-trans mitm' (cont r') }
  mitm-to-client-trans mitm (done x)      = hack-result mitm x

  hacked-com : Server P A → MITM → Client P' A' → A
  hacked-com srv mitm clt = com srv (mitm-to-client-trans mitm clt)

module _ (P : Proto) (A : ★) where
  open Proto P
  open MITM
  honest : MITM {P} {P} {A} {A}
  hack-query  honest q = ask q λ r → done (r , honest)
  hack-result honest a = done a

module _ (P : Proto) (A : ★) (Oracle : OracleServer P) where
  oracle-server : Server P A
  srv-resp (oracle-server q) = Oracle q
  srv-cont (oracle-server q) = oracle-server

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

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


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

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

module RevisedHutton where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data Bool : Set where
  true : Bool
  false : Bool

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

exprFreeSensitiveMenu : SensitiveMenu Type
exprFreeSensitiveMenu = ( choiceFreeMenu ,  choiceFreeDessert )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

testSubst2 : IMu closeTerm nat
testSubst2 = substExpr testContext
                        discharge
                        test2

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

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

testSubst3 : IMu closeTerm nat
testSubst3 = substExpr testContext
                       discharge
                       test3

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

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

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

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


Added draft on +-assoc using Mendelson's axioms.

Ignore-this: 9e025a50e62c86b02912e79316a6ae25

darcs-hash:20120222142143-3bd4e-43509a674b220dd8d4cf127220b2081b5f4a4abe.gz

-- Tested with FOT on 22 February 2012.

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

module Draft.PA.Axiomatic.Mendelson.AssocAdditionATP where

open import PA.Axiomatic.Mendelson.Base

postulate +-leftCong : ∀ {m n o} → m ≐ n → m + o ≐ n + o

+-asocc : ∀ m n o → m + n + o ≐ m + (n + o)
+-asocc m n o = S₉ P P0 is m
  where
  P : M → Set
  P i = i + n + o ≐ i + (n + o)
  {-# ATP definition P #-}

  postulate P0 : P zero
  -- {-# ATP prove P0 +-leftCong #-}

  -- (2012-02-22) E 1.4. CPU time limit exceeded, terminating (180 sec).
  -- (2012-02-22) Metis 2.3 (release 20110926). SZS status Unknown (180 sec).
  -- (2012-02-22) Vampire 0.6 (revision 903). Time limit reached! (180 sec).
  postulate is : ∀ i → P i → P (succ i)
  {-# ATP prove is +-leftCong #-}

error: pathspec 'Draft/PA/Axiomatic/Mendelson/AssocAdditionATP.agda' did not match any file(s) known to 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


add Data.Product.Param.Binary

add Data.Product.Param.Binary

{-# OPTIONS --without-K #-}
open import Level
open import Data.Product
  renaming (proj₁ to fst; proj₂ to snd)

open import Function.Param.Binary

module Data.Product.Param.Binary where

record ⟦Σ⟧ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
           {A₁ : Set a₁} {A₂ : Set a₂}
           {B₁ : A₁ → Set b₁}
           {B₂ : A₂ → Set b₂}
           (Aᵣ : A₁ → A₂ → Set aᵣ)
           (Bᵣ : {x₁ : A₁} {x₂ : A₂} (xᵣ : Aᵣ x₁ x₂)
                → B₁ x₁ → B₂ x₂ → Set bᵣ)
           (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) : Set (aᵣ ⊔ bᵣ) where
  constructor _⟦,⟧_
  field
    ⟦fst⟧ : Aᵣ (fst p₁) (fst p₂)
    ⟦snd⟧ : Bᵣ ⟦fst⟧ (snd p₁) (snd p₂)
open ⟦Σ⟧ public
infixr 4 _⟦,⟧_

syntax ⟦Σ⟧ Aᵣ (λ xᵣ → e) = [ xᵣ ∶ Aᵣ ]⟦×⟧[ e ]

⟦∃⟧ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
        {A₁ : Set a₁} {A₂ : Set a₂}
        {Aᵣ : A₁ → A₂ → Set aᵣ}
        {B₁ : A₁ → Set b₁}
        {B₂ : A₂ → Set b₂}
        (Bᵣ : ⟦Pred⟧ bᵣ Aᵣ B₁ B₂)
        (p₁ : Σ A₁ B₁) (p₂ : Σ A₂ B₂) → Set _
⟦∃⟧ = ⟦Σ⟧ _

syntax ⟦∃⟧ (λ xᵣ → e) = ⟦∃⟧[ xᵣ ] e

_⟦×⟧_ : ∀ {a₁ a₂ b₂ b₁ aᵣ bᵣ}
          {A₁ : Set a₁} {A₂ : Set a₂}
          {B₁ : Set b₁} {B₂ : Set b₂}
          (Aᵣ : A₁ → A₂ → Set aᵣ)
          (Bᵣ : B₁ → B₂ → Set bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → Set (aᵣ ⊔ bᵣ)
_⟦×⟧_ Aᵣ Bᵣ = ⟦Σ⟧ Aᵣ (λ _ → Bᵣ)

{-
_⟦×⟧_ : ∀ {a₁ a₂ aᵣ} {A₁ : Set a₁} {A₂ : Set a₂} (Aᵣ : A₁ → A₂ → Set aᵣ)
          {b₁ b₂ bᵣ} {B₁ : Set b₁} {B₂ : Set b₂} (Bᵣ : B₁ → B₂ → Set bᵣ)
          (p₁ : A₁ × B₁) (p₂ : A₂ × B₂) → Set _
_⟦×⟧_ Aᵣ Bᵣ = λ p₁ p₂ → Aᵣ (fst p₁) (fst p₂) ×
                        Bᵣ (snd p₁) (snd p₂)
-}

{- One can give these two types to ⟦_,_⟧:

⟦_,_⟧' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : Set a₁} {A₂ : Set a₂}
       {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
       {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {x₁ x₂ y₁ y₂}
       (xᵣ : Aᵣ x₁ x₂)
       (yᵣ : Bᵣ xᵣ y₁ y₂)
     → ⟦Σ⟧ Aᵣ Bᵣ (x₁ , y₁) (x₂ , y₂)
⟦_,_⟧' = ⟦_,_⟧

⟦_,_⟧'' : ∀ {a₁ a₂ b₁ b₂ aᵣ bᵣ}
       {A₁ : Set a₁} {A₂ : Set a₂}
       {B₁ : A₁ → Set b₁} {B₂ : A₂ → Set b₂}
       {Aᵣ : ⟦Set⟧ aᵣ A₁ A₂}
       {Bᵣ : ⟦Pred⟧ Aᵣ bᵣ B₁ B₂}
       {p₁ p₂}
       (⟦fst⟧ : Aᵣ (fst p₁) (fst p₂))
       (⟦snd⟧ : Bᵣ ⟦fst⟧ (snd p₁) (snd p₂))
     → ⟦Σ⟧ Aᵣ Bᵣ p₁ p₂
⟦_,_⟧'' = ⟦_,_⟧
-}

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


open import Level.NP
open import Data.Product.NP

open import Control.Protocol

module Control.Protocol.Lift a {ℓ} where
    liftᴾ : Proto_ ℓ → Proto_ (a ⊔ ℓ)
    liftᴾ end        = end
    liftᴾ (com io P) = com io λ m → liftᴾ (P (lower {ℓ = a} m))

    lift-proc : (P : Proto_ ℓ) → ⟦ P ⟧ → ⟦ liftᴾ P ⟧
    lift-proc end      end     = end
    lift-proc (send P) (m , p) = lift m , lift-proc (P m) p
    lift-proc (recv P) p       = λ { (lift m) → lift-proc (P m) (p m) }

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


lower for function name

lower for function name


Reflection.Scoped.Translation: from unscoped to scoped terms

module Reflection.Scoped.Translation where
{-
open import Level
open import Data.List
open import Reflection
open import Relation.Binary.PropositionalEquality
postulate
  f : (a : Level) → Set a
test : type (quote f) ≡ el unknown (pi (arg (arg-info visible relevant) (el (lit 0) (def (quote Level) []))) (el unknown (sort (set (var 0 [])))))
test = refl
-}

open import Level
open import Data.Zero
open import Data.One
open import Data.Sum
open import Data.Product
open import Data.Nat
open import Data.List
open import Reflection.NP as R
open import Reflection.Scoped as S

module RS where
    Vår : Set → Set
    Vår A = ℕ → S.Args A → S.Term A

    record Env (A : Set) : Set where
      field
        vår  : Vår A
    open Env public

    ε : ∀ {A} → Env A
    ε = record { vår = λ _ _ → unknown }

    vår↑ : ∀ {A} → Vår A → Scope 𝟙 Vår A
    vår↑ f zero    as = var (inj₂ 0₁) as
    vår↑ f (suc n) as = S.app (Map.term inj₁ (f n [])) as

    ↑ : ∀ {A} → Env A → Scope 𝟙 Env A
    ↑ Γ = record { vår = vår↑ (vår Γ) }

    term : ∀ {A} → Env A → R.Term → S.Term A
    tÿpe : ∀ {A} → Env A → R.Type → S.Type A
    args : ∀ {A} → Env A → R.Args → S.Args A
    sørt : ∀ {A} → Env A → R.Sort → S.Sort A

    term Γ (var x as) = vår Γ 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 Γ (pat-lam cs as) = unknown -- TODO
    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

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

module SR where
    Vår : Set → Set
    Vår A = A → R.Args → R.Term

    record Env (A : Set) : Set where
      field
        vår  : Vår A
    open Env public

    ε : Env 𝟘
    ε = record { vår = λ () }

    vår↑ : ∀ {A} → Vår A → Scope 𝟙 Vår A
    vår↑ f (inj₁ x) as = R.app (liftTerm (f x [])) as
    vår↑ f (inj₂ y) as = var 0 as

    ↑ : ∀ {A} → Env A → Scope 𝟙 Env A
    ↑ Γ = record { vår = vår↑ (vår Γ) }

    term : ∀ {A} → Env A → S.Term A → R.Term
    tÿpe : ∀ {A} → Env A → S.Type A → R.Type
    args : ∀ {A} → Env A → S.Args A → R.Args
    sørt : ∀ {A} → Env A → S.Sort A → R.Sort

    term Γ (var x as) = vår Γ 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

module Test where
  open import Relation.Binary.PropositionalEquality
  open import Function

  COMP : Set _
  COMP = {A : Set} {B : A → Set} {C : {x : A} → B x → Set} →
         (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
         ((x : A) → C (g x))

         {-
  _∘_ : COMP
  _∘_ = λ f g x → f (g x)
  -}

  comp : {A : Set} {B : A → Set} {C : {x : A} → B x → Set} →
         (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
         ((x : A) → C (g x))
  comp = λ f g x → f (g x)

         {-
  _∘′_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
             (B → C) → (A → B) → (A → C)
  _∘′_ = λ f g x → f (g x)
  -}
  {-
  ∘′-def = get-term-def (definition (quote _∘′_))
  test : S.Term 𝟘
  test = RS.term RS.ε ∘′-def
  test' : SR.term SR.ε test ≡ ∘′-def
  test' = refl
  -}

  check-term : R.Term → Set
  check-term t = SR.term SR.ε (RS.term RS.ε t) ≡ t

  strip-univ-poly : R.Term → R.Term
  strip-univ-poly (pi (arg i (el s (def (quote Level) []))) (el _ t)) = strip-univ-poly t
  strip-univ-poly t = t

  check : Name → Set
  check n = check-term (Get-term.from-name n)
          × check-term (R.unEl (type n))

  test-∘′ : check (quote _∘_)
  test-∘′ = refl , refl

  test-∘ : check (quote _∘′_)
  test-∘ = refl , refl

  test-comp : check (quote comp)
  test-comp = refl , refl

  test-COMP : check (quote COMP)
  test-COMP = refl , refl

  test-flip : check (quote flip)
  test-flip = refl , refl

  test-[] : check (quote _-[_]-_)
  test-[] = refl , refl
-- -}
-- -}
-- -}
-- -}

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


Added draft about the bisimilarity relation.

Ignore-this: 6fad54c52f5b705de073c3fcb7b1dff6

darcs-hash:20101027171125-3bd4e-cbfedf7a085dcba6213e863b086a47f85a7aca44.gz

module BisimilarityPostFixedPoint where

-- open import LTC.Minimal
-- open import LTC.MinimalER

infixr 5 _∷_
infix 4 _≈_
infixr 4 _,_
infix  3 _≡_
infixr 2 _∧_

------------------------------------------------------------------------------
-- LTC stuff

-- The universal domain.
postulate D : Set

  -- LTC lists.
postulate
  _∷_  : D → D → D

-- The existential quantifier type on D.
data ∃D (P : D → Set) : Set where
  _,_ : (d : D) (Pd : P d) → ∃D P

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

-- Identity properties

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

subst : (P : D → Set){x y : D} → x ≡ y → P x → P y
subst P refl px = px

-- The conjunction data type.
data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

------------------------------------------------------------------------------
BISI : (D → D → Set) → D → D → Set
BISI R xs ys =
  ∃D (λ x' →
  ∃D (λ y' →
  ∃D (λ xs' →
  ∃D (λ ys' →
     x' ≡ y' ∧ R xs' ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ y' ∷ ys'))))

-- From Peter email:

-- For the case of bisimilarity ≈ we have

-- (i) a post-fixed point of BISI, is the following first order axiom

-- forall xs,ys,x,y. x = y & xs ≈ ys -> x :: xs ≈ y :: ys

postulate
  -- The bisimilarity relation.
  _≈_ : D → D → Set

  -- The bisimilarity relation is a post-fixed point of BISI.
  -≈-gfp₁ : {x y xs ys : D} → x ≡ y ∧ xs ≈ ys → x ∷ xs ≈ y ∷ ys

foo : (xs ys : D) → xs ≈ ys → BISI _≈_ xs ys
foo xs ys xs≈ys = {!!}

bar : (xs ys : D) → BISI _≈_ xs ys → xs ≈ ys
bar xs ys (x' , y' , xs' , ys' , x'≡y' , xs'≈ys' , xs≡x'∷xs' , ys≡y'∷ys)
  = subst (λ t₁ → t₁ ≈ ys)
          (sym xs≡x'∷xs')
          (subst (λ t₂ → x' ∷ xs' ≈ t₂)
                 (sym ys≡y'∷ys)
                 (-≈-gfp₁ (x'≡y' , xs'≈ys')))

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


Added stream example (draft).

Added stream example (draft).

Ignore-this: 9047faf72f7e39b3894cb3750ff52ca

darcs-hash:20110803160607-3bd4e-01e8331e2b03a9cbfd89520090f414b362d2c596.gz

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


Agda model for Desc.

Agda model for Desc.

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

module Desc where

import Data.Product
import Data.Unit
import Data.Empty

open import Data.Product
open import Data.Unit
open import Data.Empty

-- Bringing in an hand-made Prop universe

data PROP : Set where
  All : (S : Set) -> (S -> PROP) -> PROP
  And : PROP -> PROP -> PROP
  Trivial : PROP
  Absurd : PROP

Prf : PROP -> Set
Prf Absurd = ⊥
Prf Trivial = ⊤
Prf (All S P) = (x : S) -> Prf (P x)
Prf (And A B) = Σ (Prf A)  (\ _ -> Prf B)

-- Then, we build Desc in Set
-- it's all Set in Set here

-- Desc code:
data Desc : Set where
  Done : Desc
  Arg : (X : Set) -> (X -> Desc) -> Desc
  Ind : (X : Set) -> Desc -> Desc

descOp : Desc -> Set -> Set
descOp Done _ = ⊤
descOp (Arg A f) D = Σ A (\ a -> descOp (f a) D)
descOp (Ind H x) D =  Σ (H -> D) (\ _ -> descOp x D)

-- Followed by Mu:

data Mu (X : Desc) : Set where
  Con : descOp X (Mu X) -> Mu X

-- All of this is fully-furnished with:
--   * boxOp
--   * mapBoxOp
--   * elimOp

boxOp : (d : Desc) -> (D : Set) -> (bp : D -> PROP) -> (v : descOp d D) -> Set
boxOp Done _ _ _ =  ⊤
boxOp (Arg A f) d p v =  boxOp (f (proj₁ v)) d p (proj₂ v)
boxOp (Ind H x) d p v =  Prf ( All H (\y -> p (proj₁ v y)))
                      × boxOp x d p (proj₂ v)

mapBoxOp : (d : Desc) -> (D : Set) -> (bp : D -> PROP) ->
           (Prf (All D (\y -> bp y))) -> (v : descOp d D) ->
           (boxOp d D bp v)
mapBoxOp Done _ _ _ _ =  tt
mapBoxOp (Arg a f) d bp p v =  mapBoxOp (f (proj₁ v)) d bp p (proj₂ v)
mapBoxOp (Ind H x) d bp p v =  (\ y -> p (proj₁ v y)) ,  mapBoxOp x d bp p (proj₂ v)

-- On the Ind case, the Pig code is saying something along those lines:
-- mapBoxOp (Ind H x) d bp p v =  (\ y -> p (proj₁ v y)) ,  mapBoxOp x d bp p (p?! (proj₂ v))

elimOp : (d : Desc) -> (bp : Mu d -> PROP) ->
         (Prf (All (descOp d (Mu d)) (\ x -> (All (boxOp d (Mu d) bp x) (\ _ -> bp (Con x)))))) ->
         (v : Mu d) -> Prf (bp v)
elimOp d bp p (Con v) =  p v (mapBoxOp d (Mu d) bp (\x -> elimOp d bp p x) v)

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


Examples of tactics needing to match against function calls.

{-
This file demonstrates a technique that simulates the ability to
pattern match against function calls rather than just variables
or constructors.

This technique is necessary to write certain kinds of tactics
as generic functions.
-}

module TacticsMatchingFunctionCalls where
open import Data.Bool hiding ( _≟_ )
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Product hiding ( map )
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function

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

{-
Zero is the right identity of addition on the natural numbers.
-}

plusrident : (n : ℕ) → n ≡ n + 0
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

{-
Arith is a universe of codes representing the natural numbers
along with a limited set of functions over them. We would like to write
tactics that pattern match against types indexed by applications of
these functions.
-}

data Arith : Set where
  `zero : Arith
  `suc : (a : Arith) → Arith
  _`+_ _`*_ : (a₁ a₂ : Arith) → Arith

eval : Arith → ℕ
eval `zero = zero
eval (`suc a) = suc (eval a)
eval (a₁ `+ a₂) = eval a₁ + eval a₂
eval (a₁ `* a₂) = eval a₁ * eval a₂

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

{-
Φ (standing for *function*-indexed types)
represents an indexed type, but we *can* pattern
match on function calls in its index position.

A - The type of codes, including constructors and functions.
  i.e. Arith
A′ - The model underlying the codes.
  i.e. ℕ
el - The evaluation function from code values to model values.
  i.e. eval
B - The genuine indexed datatype that Φ represents.
  i.e. Fin
a - The index value as a code, which may be a function call and hence supports
    pattern matching.
  i.e. (a `+ `zero)
-}

data Φ (A A′ : Set) (el : A → A′) (B : A′ → Set) (a : A) : Set where
  φ : (b : B (el a)) → Φ A A′ el B a

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

{-
Alternatively, we can specialize Φ to our Arith universe. This may be
a good use of our ability to cheaply define new datatypes via Desc.
-}

data ΦArith (B : ℕ → Set) (a : Arith) : Set where
  φ : (b : B (eval a)) → ΦArith B a

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

{-
A small universe of dependent types that is sufficient for the
examples given below.
-}

data Type : Set
⟦_⟧ : Type → Set

data Type where
  `Bool `ℕ `Arith : Type
  `Fin : (n : ℕ) → Type
  `Φ : (A A′ : Type)
    (el : ⟦ A ⟧ → ⟦ A′ ⟧)
    (B : ⟦ A′ ⟧ → Type)
    (a : ⟦ A ⟧)
    → Type
  `ΦArith : (B : ℕ → Type) (a : Arith) → Type
  `Π `Σ : (A : Type) (B : ⟦ A ⟧ → Type) → Type
  `Id : (A : Type) (x y : ⟦ A ⟧) → Type

⟦ `Bool ⟧ = Bool
⟦ `ℕ ⟧ = ℕ
⟦ `Arith ⟧ = Arith
⟦ `Fin n ⟧ = Fin n
⟦ `Φ A A′ el B a ⟧ = Φ ⟦ A ⟧ ⟦ A′ ⟧ el (λ a → ⟦ B a ⟧) a
⟦ `ΦArith B a ⟧ = ΦArith (λ x → ⟦ B x ⟧) a
⟦ `Π A B ⟧ = (a : ⟦ A ⟧) → ⟦ B a ⟧
⟦ `Σ A B ⟧ = Σ ⟦ A ⟧ (λ a → ⟦ B a ⟧)
⟦ `Id A x y ⟧ = x ≡ y

_`→_ : (A B : Type) → Type
A `→ B = `Π A (const B)

_`×_ : (A B : Type) → Type
A `× B = `Σ A (const B)

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

{-
Tactics are represented as generic functions taking a Dynamic value (of
any type), and returning a Dynamic value (at a possibly different type).
The convention is to behave like the identity function if the tactic
doesn't match the current value or fails.

In practice, the context will be a List of Dynamic values, and a tactic
will map a Context to a Context. For simplicity, the tactics I give below
only map a Dynamic to a Dynamic.
-}

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

{-
Here is an example of a tactic that only needs to pattern match on a
variable or constructor, but not a function. We don't encounter
any problems when writing this kind of a tactic.

The tactic below changes a `Fin n` value into a `Fin (n + 0)` value.
-}

add-plus0-Fin : Tactic
add-plus0-Fin (`Fin n , i) = `Fin (n + 0) , subst Fin (plusrident n) i
add-plus0-Fin x = x

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

{-
In contrast, it is not straightforward to write tactics that need
to pattern match on function calls.
For example, below is ideally what we want to write to change
a value of `Fin (n + 0)` to a value of `Fin n`.
-}

-- rm-plus0-Fin : Tactic
-- rm-plus0-Fin (`Fin (n + 0) , i) = `Fin n , subst Fin (sym (plusrident n)) i
-- rm-plus0-Fin x = x

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

{-
Instead of matching directly on `Fin, we can match on a `Φ that
represents `Fin. This allows us to match on the the `+ function call
in the index position.

Because we cannot match against the function `el` (we would like to match
it against `eval`), we add to our return type that proves the
extentional equality between `el` and `eval`.

Also note that the tactic below can be used for any type indexed by
ℕ, not just Fin.
-}

rm-plus0 : Tactic
rm-plus0 (`Φ `Arith `ℕ el B (a `+ `zero) , φ b) =
  `Π `Arith (λ x → `Id `ℕ (el x) (eval x))
  `→
  `Φ `Arith `ℕ el B a
  ,
  λ f → φ
  (subst (λ x → ⟦ B x ⟧)
         (sym (f a))
         (subst (λ x → ⟦ B x ⟧)
                (sym (plusrident (eval a)))
                (subst (λ x → ⟦ B x ⟧)
                       (f (a `+ `zero))
                       b)))
rm-plus0 x = x

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

{-
Now it is possible to apply the generic tactic to a specific
value and have the desired behavior occur. Notice that the generated
extentional equality premise is trivially provable because
eval is always equal to eval.
-}

eg-rm-plus0 : (a : Arith)
  → ⟦ `Φ `Arith `ℕ eval `Fin (a `+ `zero) ⟧
  → ⟦ `Φ `Arith `ℕ eval `Fin a ⟧
eg-rm-plus0 a (φ i) = proj₂
  (rm-plus0 (`Φ `Arith `ℕ eval `Fin (a `+ `zero) , φ i))
  (λ _ → refl)

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

{-
Here is the same tactic but using the specialized ΦArith type.
-}

rm-plus0-Arith : Tactic
rm-plus0-Arith (`ΦArith B (a `+ `zero) , φ b) =
  `ΦArith B a
  ,
  φ (subst (λ x → ⟦ B x ⟧) (sym (plusrident (eval a))) b)
rm-plus0-Arith x = x

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

{-
And the same example usage, this time without needing to prove a premise.
-}

eg-rm-plus0-Arith : (a : Arith)
  → ⟦ `ΦArith `Fin (a `+ `zero) ⟧
  → ⟦ `ΦArith `Fin a ⟧
eg-rm-plus0-Arith a (φ i) = proj₂
  (rm-plus0-Arith (`ΦArith `Fin (a `+ `zero) , φ i))

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

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


Basic logic in agda

Basic logic in agda

module Logic where

-- The true proposition.
data ⊤ : Set where
  true : ⊤ -- The proof of truth.

-- The false proposition.
data ⊥ : Set where
  -- There is nothing here so one can never prove false.

-- The AND of two statments.
data _∧_ (A B : Set)  : Set where
  -- The only way to construct a proof of A ∧ B is by pairing a a
  -- proof of A with a proof of and B.
  ⟨_,_⟩ : (a : A)  -- Proof of A
        → (b : B)  -- Proof of B
        → A ∧ B    -- Proof of A ∧ B

-- The OR of two statements.
data _∨_ (A B : Set) : Set where
  -- There are two ways of constructing a proof of A ∨ B.
  inl : (a : A) →  A ∨ B   -- From a proof of A by left introduction
  inr : (b : B) →  A ∨ B   -- From a proof of B by right introduction

-- The not of statement A
¬_ : (A : Set) → Set
¬ A = A → ⊥  -- Given a proof of A one should be able to get a proof
             -- of ⊥.

-- The statement A ↔ B are equivalent.
_↔_ : (A B : Set) → Set
A ↔ B = (A → B) -- If
           ∧    -- and
        (B → A) -- only if

infixr 1 _∧_
infixr 1 _∨_
infixr 0 _↔_
infix  2 ¬_

-- Function composition
_∘_   : {A B C : Set} → (B → C) → (A → B) → A → C
(f ∘ g) x = f (g x)

-- Double negation
doubleNegation : ∀ {A : Set} → A → ¬ (¬ A)
doubleNegation a negNegA = negNegA a

{-

doubleNegation' : ∀ {A : Set} → ¬ ( ¬ (¬ A)) → ¬ A

-}

deMorgan1 : ∀ (A B : Set) → ¬ (A ∨ B) → ¬ A ∧ ¬ B
deMorgan1 A B notAorB = ⟨ notAorB ∘ inl , notAorB ∘ inr ⟩

deMorgan2 : ∀ (A B : Set) → ¬ A ∧ ¬ B → ¬ (A ∨ B)
deMorgan2 A B ⟨ notA , notB ⟩ (inl a) = notA a
deMorgan2 A B ⟨ notA , notB ⟩ (inr b) = notB b

deMorgan : ∀ (A B : Set) → ¬ (A ∨ B) ↔ ¬ A ∧ ¬ B
deMorgan A B = ⟨ deMorgan1 A B , deMorgan2 A B ⟩

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


add middleware type

add middleware type


Added note on the universal quantifier.

Added note on the universal quantifier.

Ignore-this: 228858b33ec27bac0a3f1ae83ea96982

darcs-hash:20120508160306-3bd4e-ac9c9e9ef9bbaea37ab26205c32451f4ec7301b8.gz

-- Tested with FOT on 08 May 2012.

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

module Universal where

postulate D : Set

-- The universal quantifier type on D.
data Forall (A : D → Set) : Set where
  Forall-intro : ((t : D) → A t) → Forall A

Forall-elim : {A : D → Set} → Forall A → (t : D) → A t
Forall-elim (Forall-intro h) t = h t

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


SOme work on Norell's and Chappman's Agda tutorial

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 wfInd-RMC.

Added wfInd-RMC.

Ignore-this: 3c178ec1427644c6853cfd6a2ca9d952

darcs-hash:20110210053633-3bd4e-82684e8337c912506aab5666fa21a0a385c3a76b.gz

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


prefect-bintree.agda

prefect-bintree.agda

module prefect-bintree where

open import Function
open import Data.Nat
open import Data.Bool
open import Data.Bits

data Tree {a} (A : Set a) : ℕ → Set a where
  leaf : (x : A) → Tree A zero
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Tree A n
fromFun {zero} f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : Set a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

lookup : ∀ {n a} {A : Set a} → Bits n → Tree A n → A
lookup = flip toFun

lookup' : ∀ {m n a} {A : Set a} → Bits m → Tree A (m + n) → Tree A n
lookup' [] t = t
lookup' (b ∷ bs) (fork t t₁) = lookup' bs (if b then t₁ else t)

{-
update' : ∀ {m n a} {A : Set a} → Bits m → Tree A n → Tree A (m + n) → Tree A (m + n)
update' = ?
-}

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

open import Relation.Binary
open import Data.Star

data Swp {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  swp₁ : ∀ {n} {left right : Tree A n} →
         Swp (fork left right) (fork right left)
  swp₂ : ∀ {n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         Swp (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))

Swp★ : ∀ {a} {A : Set a} {n} (left right : Tree A n) → Set a
Swp★ = Star Swp

Swp-sym : ∀ {n a} {A : Set a} → Symmetric (Swp {A = A} {n})
Swp-sym swp₁ = swp₁
Swp-sym swp₂ = swp₂

data Rot {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  leaf : ∀ x → Rot (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : Set a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork left right} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : Set a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : Set a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)

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


Sketch fundamental theorem with big-step semantics

OK, honestly that was much easier than with functional big-step semantics.
Though probably a clever strategy would simplify those functional proofs.

Beware I haven't proven any lemmas about the semantics (other than a decider
based on the evaluator).

Also missing: lots of inequalities about step-indexes differences. Proving them
in Agda is a pain. But they all look true.

{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.BigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)
open import Thesis.FunBigStepSILR2

-- Standard relational big-step semantics.
data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : ∀ {τ} → Term Γ τ → ℕ → Val τ → Set where
  abs : ∀ {τ₁ τ₂} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓[ 0 ] closure t ρ
  app : ∀ n1 n2 n3 {Γ′ τ₁ τ₂ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓[ n1 ] closure t′ ρ′ →
    ρ ⊢ t₂ ↓[ n2 ] v₂ →
    (v₂ • ρ′) ⊢ t′ ↓[ n3 ] v′ →
    ρ ⊢ app t₁ t₂ ↓[ suc n1 + n2 + n3 ] v′
  var : ∀ {τ} (x : Var Γ τ) →
    ρ ⊢ var x ↓[ 0 ] (⟦ x ⟧Var ρ)
  lit : ∀ n →
    ρ ⊢ const (lit n) ↓[ 0 ] intV n

-- Silly lemmas for eval-dec-sound
module _ where
  Done-inj : ∀ {τ} m n {v1 v2 : Val τ} → Done v1 m ≡ Done v2 n → m ≡ n
  Done-inj _ _ refl = refl

  lem1 : ∀ n d → d ≢ suc (n + d)
  lem1 n d eq rewrite +-comm n d = m≢1+m+n d eq

  subd : ∀ n d → n + d ≡ d → n ≡ 0
  subd zero d eq = refl
  subd (suc n) d eq = ⊥-elim (lem1 n d (sym eq))

  comp∸ : ∀ a b → b ≤ a → suc a ∸ b ≡ suc (a ∸ b)
  comp∸ a zero le = refl
  comp∸ zero (suc b) ()
  comp∸ (suc a) (suc b) (s≤s le) = comp∸ a b le

  rearr∸ : ∀ a b c → c ≤ b → a + (b ∸ c) ≡ (a + b) ∸ c
  rearr∸ a b zero c≤b = refl
  rearr∸ a zero (suc c) ()
  rearr∸ a (suc b) (suc c) (s≤s c≤b) rewrite +-suc a b = rearr∸ a b c c≤b

  cancel∸ : ∀ a b → b ≤ a → a ∸ b + b ≡ a
  cancel∸ a zero b≤a = +-right-identity a
  cancel∸ zero (suc b) ()
  cancel∸ (suc a) (suc b) (s≤s b≤a) rewrite +-suc (a ∸ b) b = cong suc (cancel∸ a b b≤a)

  lemR : ∀ {τ} n m {v1 v2 : Val τ} → Done v1 m ≡ Done v2 n → m ≡ n
  lemR n .n refl = refl

  lem2 : ∀ n n3 r → n3 ≤ n → n + n3 ≡ suc r → ∃ λ s → (n ≡ suc s)
  lem2 zero .0 r z≤n ()
  lem2 (suc n) n3 .(n + n3) le refl = n , refl

{-# TERMINATING #-}
eval-dec-sound : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v m n → eval t ρ m ≡ Done v n → ρ ⊢ t ↓[ m ∸ n ] v
eval-dec-sound (const (lit x)) ρ (intV v) m n eq with lemR n m eq
eval-dec-sound (const (lit x)) ρ (intV .x) m .m refl | refl rewrite n∸n≡0 m = lit x
eval-dec-sound (var x) ρ v m n eq with lemR n m eq
eval-dec-sound (var x) ρ .(⟦ x ⟧Var ρ) m .m refl | refl rewrite n∸n≡0 m  = var x
eval-dec-sound (abs t) ρ v m n eq with lemR n m eq
eval-dec-sound (abs t) ρ .(closure t ρ) m .m refl | refl rewrite n∸n≡0 m  = abs
eval-dec-sound (app s t) ρ v zero n ()
eval-dec-sound (app s t) ρ v (suc r) n eq with eval s ρ r | inspect (eval s ρ) r
eval-dec-sound (app s t) ρ v (suc r) n eq | (Done sv n1) | [ seq ] with eval t ρ n1 | inspect (eval t ρ) n1
eval-dec-sound (app s t) ρ v (suc r) n eq | (Done (closure st sρ) n1) | [ seq ] | (Done tv n2) | [ teq ] with eval st (tv • sρ) n2 | inspect (eval st (tv • sρ)) n2
eval-dec-sound (app s t) ρ .v (suc r) .n3 refl | (Done sv@(closure st sρ) n1) | [ seq ] | (Done tv n2) | [ teq ] | (Done v n3) | [ veq ] = body
  where
    n1≤r : n1 ≤ r
    n1≤r = eval-dec s ρ sv r n1 seq
    n2≤n1 : n2 ≤ n1
    n2≤n1 = eval-dec t ρ tv n1 n2 teq
    n3≤n2 : n3 ≤ n2
    n3≤n2 = eval-dec st (tv • sρ) v n2 n3 veq
    eval1 = eval-dec-sound s ρ sv r n1 seq
    eval2 = eval-dec-sound t ρ tv n1 n2 teq
    eval3 = eval-dec-sound st (tv • sρ) v n2 n3 veq
    l1 : suc r ∸ n3 ≡ suc (r ∸ n3)
    l1 = comp∸ r n3 (≤-trans n3≤n2 (≤-trans n2≤n1 n1≤r))
    l2 : suc r ∸ n3 ≡ suc (((r ∸ n1) + (n1 ∸ n2)) + (n2 ∸ n3))
    l2
      rewrite rearr∸ (r ∸ n1) n1 n2 n2≤n1 | cancel∸ r n1 n1≤r
      | rearr∸ (r ∸ n2) n2 n3 n3≤n2 | cancel∸ r n2 (≤-trans n2≤n1 n1≤r) = l1
    foo : ρ ⊢ app s t ↓[ suc (r ∸ n1 + (n1 ∸ n2) + (n2 ∸ n3)) ] v
    foo = app (r ∸ n1) (n1 ∸ n2) (n2 ∸ n3) {t₁ = s} {t₂ = t} {t′ = st} eval1 eval2 eval3
    body : ρ ⊢ app s t ↓[ suc r ∸ n3 ] v
    body rewrite l2 = foo
eval-dec-sound (app s t) ρ v (suc r) n () | (Done (closure st sρ) n1) | [ seq ] | (Done tv n2) | [ teq ] | Error | [ veq ]
eval-dec-sound (app s t) ρ v (suc r) n () | (Done (closure st sρ) n1) | [ seq ] | (Done tv n2) | [ teq ] | TimeOut | [ veq ]
eval-dec-sound (app s t) ρ v (suc r) n () | (Done sv n1) | [ seq ] | Error | [ teq ]
eval-dec-sound (app s t) ρ v (suc r) n () | (Done sv n1) | [ seq ] | TimeOut | [ teq ]
eval-dec-sound (app s t) ρ v (suc r) n () | Error | [ seq ]
eval-dec-sound (app s t) ρ v (suc r) n () | TimeOut | [ seq ]
-- ↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
--   ((Den.⟦ x ⟧Var) (⟦ ρ ⟧Context)) ≡ (⟦ (⟦ x ⟧Var) ρ ⟧Val)
-- ↦-sound (px • ρ) this = refl
-- ↦-sound (px • ρ) (that x) = ↦-sound ρ x

-- ↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
--   ρ ⊢ t ↓ v →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val
-- ↓-sound abs = refl
-- ↓-sound (app ↓₁ ↓₂ ↓′) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ | ↓-sound ↓′ = refl
-- ↓-sound (var x) = ↦-sound _ x
-- ↓-sound (lit n) = refl

import Data.Integer as I
open I using (ℤ)
mutual
  rrelT : ∀ {τ Γ} (t1 : Term Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  -- To compare this definition, note that the original k is suc n here.
  rrelT {τ} t1 t2 ρ1 ρ2 n =
    (v1 : Val τ) →
    -- Originally we have 0 ≤ j < k, so j < suc n, so k - j = suc n - j.
    -- It follows that 0 < k - j ≤ k, hence suc n - j ≤ suc n, or n - j ≤ n.
    -- Here, instead of binding j we bind n-j = n - j, require n - j ≤ n, and
    -- use suc n-j instead of k - j.
    ∀ j (j<n : j < n) →
    -- The next assumption is important. This still says that evaluation consumes j steps.
    -- Since j ≤ n, it is OK to start evaluation with n steps.
    -- Starting with (suc n) and getting suc n-j is equivalent, per eval-mono
    -- and eval-strengthen. But in practice this version is easier to use.
    (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t1 ↓[ j ] v1) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] ρ2 ⊢ t2 ↓[ n2 ] v2 × rrelV τ v1 v2 (n ∸ j)

  rrelV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
  rrelV nat (intV v1) (intV v2) n = Σ[ dv ∈ ℤ ] dv I.+ (I.+ v1) ≡ (I.+ v2)
  rrelV (σ ⇒ τ) (closure {Γ1} t1 ρ1) (closure {Γ2} t2 ρ2) n =
    Σ (Γ1 ≡ Γ2) λ { refl →
      ∀ (k : ℕ) (k<n : k < n) v1 v2 →
      (vv : rrelV σ v1 v2 k) →
      rrelT t1 t2 (v1 • ρ1) (v2 • ρ2) k
    }

rrelρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
rrelρ ∅ ∅ ∅ n = ⊤
rrelρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = rrelV τ v1 v2 n × rrelρ Γ ρ1 ρ2 n

⟦_⟧RelVar : ∀ {Γ τ n} (x : Var Γ τ) {ρ1 ρ2 : ⟦ Γ ⟧Context} →
  rrelρ Γ ρ1 ρ2 n →
  rrelV τ (⟦ x ⟧Var ρ1) (⟦ x ⟧Var ρ2) n
⟦ this ⟧RelVar {v1 • ρ1} {v2 • ρ2} (vv , ρρ) = vv
⟦ that x ⟧RelVar {v1 • ρ1} {v2 • ρ2} (vv , ρρ) = ⟦ x ⟧RelVar ρρ

rrelV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → rrelV τ v1 v2 n → rrelV τ v1 v2 m
rrelV-mono m n m≤n nat (intV v1) (intV v2) vv = vv
rrelV-mono m n m≤n (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (refl , ff) = refl , λ k k≤m → ff k (≤-trans k≤m m≤n)

rrelρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → rrelρ Γ ρ1 ρ2 n → rrelρ Γ ρ1 ρ2 m
rrelρ-mono m n m≤n ∅ ∅ ∅ tt = tt
rrelρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = rrelV-mono m n m≤n _ v1 v2 vv , rrelρ-mono m n m≤n Γ ρ1 ρ2 ρρ

rfundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : rrelρ Γ ρ1 ρ2 n) → rrelT (var x) (var x) ρ1 ρ2 n
rfundamentalV x n ρ1 ρ2 ρρ .(⟦ x ⟧Var ρ1) .0 j<n (var .x) = ⟦ x ⟧Var ρ2 , 0 , (var x) , ⟦ x ⟧RelVar ρρ

rfundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : rrelρ Γ ρ1 ρ2 n) → rrelT t t ρ1 ρ2 n
rfundamental (var x) n ρ1 ρ2 ρρ = rfundamentalV x n ρ1 ρ2 ρρ
rfundamental (const (lit x)) n ρ1 ρ2 ρρ .(intV x) .0 j<n (lit .x) = intV x , 0 , lit x , I.+ 0 , refl
rfundamental (abs t) n ρ1 ρ2 ρρ .(closure t ρ1) .0 j<n abs = closure t ρ2 , 0 , abs , refl , (λ k k<n v1 v2 vv v3 j j<k ρ1⊢t1↓[j]v1 → rfundamental t k (v1 • ρ1) (v2 • ρ2) (vv , rrelρ-mono k n (lt1 k<n) _ _ _ ρρ) v3 j j<k ρ1⊢t1↓[j]v1 )
rfundamental (app s t) n ρ1 ρ2 ρρ v1 .(suc (n1 + n2 + n3)) j<n (app n1 n2 n3 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3) = body
  where
    n1<n : n1 < n
    n1<n = {!!}
    n2<n : n2 < n
    n2<n = {!!}
    n-n1-n2<n-n1 : n ∸ n1 ∸ n2 < n ∸ n1
    n-n1-n2<n-n1 = {!!}
    n-n1-n2≤n-n2 : n ∸ n1 ∸ n2 ≤ n ∸ n2
    n-n1-n2≤n-n2 = {!!}
    n3<n-n1-n2 : n3 < n ∸ n1 ∸ n2
    n3<n-n1-n2 = {!!}
    n-[1+n1+n2+n3]≤n-n1-n2-n3 : n ∸ suc (n1 + n2 + n3) ≤ n ∸ n1 ∸ n2 ∸ n3
    n-[1+n1+n2+n3]≤n-n1-n2-n3 = {!!}
    body : Σ[ v2 ∈ Val _ ] Σ[ tn ∈ ℕ ] ρ2 ⊢ app s t ↓[ tn ] v2 × rrelV _ v1 v2 (n ∸ suc (n1 + n2 + n3))
    body with rfundamental s n ρ1 ρ2 ρρ _ n1 n1<n ρ1⊢t1↓[j]v1 | rfundamental t n ρ1 ρ2 ρρ _ n2 n2<n ρ1⊢t1↓[j]v2
    ... | sv2@(closure st2 sρ2) , sn2 , ρ2⊢s↓ , refl , sv1v2 | tv2 , tn2 , ρ2⊢t↓ , tv1v2 with sv1v2 (n ∸ n1 ∸ n2) n-n1-n2<n-n1 _ tv2 (rrelV-mono (n ∸ n1 ∸ n2) (n ∸ n2) n-n1-n2≤n-n2 _ _ tv2 tv1v2 ) v1 n3 n3<n-n1-n2 ρ1⊢t1↓[j]v3
    ... | v2 , stn , ρ2⊢st2↓ , vv = v2 , suc (sn2 + tn2 + stn) , app _ _ _ ρ2⊢s↓ ρ2⊢t↓  ρ2⊢st2↓ , rrelV-mono (n ∸ suc (n1 + n2 + n3)) (n ∸ n1 ∸ n2 ∸ n3) n-[1+n1+n2+n3]≤n-n1-n2-n3 _ v1 v2 vv

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


Terminal-0-Groupoid

fatal: unable to access 'https://github.com/zeitraffer/agda-cats.git/': The requested URL returned error: 403


Add Crypto.Sig.LamportOneBit

Add Crypto.Sig.LamportOneBit

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

module Crypto.Sig.LamportOneBit
          (#secret : ℕ)
          (#digest : ℕ)
          (hash    : Bits #secret → Bits #digest)
          where

#signkey   = 2* #secret
#verifkey  = 2* #digest
#signature = #secret

Digest     = Bits #digest
Secret     = Bits #secret
SignKey    = Bits #signkey
Signature  = Bits #signature
VerifKey   = Bits #verifkey

module signkey (sk : SignKey) where
  skL = take #secret sk
  skH = drop #secret sk
  vkL = hash skL
  vkH = hash skH

-- Derive the public key by hashing each secret
verif-key : SignKey → VerifKey
verif-key = map2* #secret #digest hash

module verifkey (vk : VerifKey) where
  vkL = take #digest vk
  vkH = drop #digest vk

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

-- Sign a single bit message
sign : SignKey → Bit → Signature
sign sk b = take2* _ b sk

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

verify-correct-sig : ∀ sk b → verify (verif-key sk) b (sign sk b) ≡ 1b
verify-correct-sig sk 0b = ==-reflexive (take-++ #digest (hash (take #secret sk)) _)
verify-correct-sig sk 1b = ==-reflexive (drop-++ #digest (hash (take #secret sk)) _)

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

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

  -- If one considers the hash function injective, then, so is verif-key
  verif-key-inj : ∀ {sk1 sk2} → verif-key sk1 ≡ verif-key sk2 → sk1 ≡ sk2
  verif-key-inj {sk1} {sk2} e
    = take-drop= #secret sk1 sk2
        (hash-inj (++-inj₁ e))
        (hash-inj (++-inj₂ sk1.vkL sk2.vkL e))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2

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

  -- If one considers the hash function injective then there is
  -- only one signing key which can sign correctly all (0 and 1)
  -- the messages
  signkey-uniqness :
        ∀ sk1 sk2 →
          (∀ b → verify (verif-key sk1) b (sign sk2 b) ≡ 1b) →
          sk1 ≡ sk2
  signkey-uniqness sk1 sk2 e
    = take-drop= #secret sk1 sk2 (lemmaL (e 0b)) (lemmaH (e 1b))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2
      lemmaL : verify (verif-key sk1) 0b (sign sk2 0b) ≡ 1b →
              sk1.skL ≡ sk2.skL
      lemmaL e0
        rewrite take-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e0)
              = refl

      lemmaH : verify (verif-key sk1) 1b (sign sk2 1b) ≡ 1b →
               sk1.skH ≡ sk2.skH
      lemmaH e1
        rewrite drop-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e1)
              = refl

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

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

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

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

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

-- -}

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


Add Control.Strategy

Add Control.Strategy

module Control.Strategy where

open import Function
open import Type using (★)
open import Category.Monad
open import Relation.Binary.PropositionalEquality.NP

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

infix 2 _≈_
data _≈_ {Q R A} : (s₀ s₁ : Strategy Q R A) → ★ where
  ask-ask : ∀ {k₀ k₁} → (q? : Q) (cont : ∀ r → k₀ r ≈ k₁ r) → ask q? k₀ ≈ ask q? k₁
  done-done : ∀ x → done x ≈ done x

≈-refl : ∀ {Q R A} {s : Strategy Q R A} → s ≈ s
≈-refl {s = ask q? cont} = ask-ask q? (λ r → ≈-refl)
≈-refl {s = done x}      = done-done x

module _ {Q R : ★} where
  private
    M : ★ → ★
    M = Strategy Q R

  _=<<_ : ∀ {A B} → (A → M B) → M A → M B
  f =<< ask q? cont = ask q? (λ r → f =<< cont r)
  f =<< done x      = f x

  return : ∀ {A} → A → M A
  return = done

  map : ∀ {A B} → (A → B) → M A → M B
  map f s = (done ∘ f) =<< s

  join : ∀ {A} → M (M A) → M A
  join s = id =<< s

  _>>=_ : ∀ {A B} → M A → (A → M B) → M B
  _>>=_ = flip _=<<_

  rawMonad : RawMonad M
  rawMonad = record { return = return; _>>=_ = _>>=_ }

  return-=<< : ∀ {A} (m : M A) → return =<< m ≈ m
  return-=<< (ask q? cont) = ask-ask q? (λ r → return-=<< (cont r))
  return-=<< (done x)      = done-done x

  return->>= : ∀ {A B} (x : A) (f : A → M B) → return x >>= f ≡ f x
  return->>= _ _ = refl

  >>=-assoc : ∀ {A B C} (mx : M A) (my : A → M B) (f : B → M C) → (mx >>= λ x → (my x >>= f)) ≈ (mx >>= my) >>= f
  >>=-assoc (ask q? cont) my f = ask-ask q? (λ r → >>=-assoc (cont r) my f)
  >>=-assoc (done x)      my f = ≈-refl

  map-id : ∀ {A} (s : M A) → map id s ≈ s
  map-id = return-=<<

  map-∘ : ∀ {A B C} (f : A → B) (g : B → C) s → map (g ∘ f) s ≈ (map g ∘ map f) s
  map-∘ f g s = >>=-assoc s (done ∘ f) (done ∘ g)

  module EffectfulRun
           (E : ★ → ★)
           (_>>=E_  : ∀ {A B} → E A → (A → E B) → E B)
           (returnE : ∀ {A} → A → E A)
           (Oracle  : Q → E R) where
    runE : ∀ {A} → M A → E A
    runE (ask q? cont) = Oracle q? >>=E (λ r → runE (cont r))
    runE (done x)      = returnE x

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

    module _ {A B : ★} (f : A → M B) where
        run->>= : (s : M A) → run (s >>= f) ≡ run (f (run s))
        run->>= (ask q? cont) = run->>= (cont (Oracle q?))
        run->>= (done x)      = refl

    module _ {A B : ★} (f : A → B) where
        run-map : (s : M A) → run (map f s) ≡ f (run s)
        run-map = run->>= (return ∘ f)

    module _ {A B : ★} where
        run-≈ : {s₀ s₁ : M A} → s₀ ≈ s₁ → run s₀ ≡ run s₁
        run-≈ (ask-ask q? cont) = run-≈ (cont (Oracle q?))
        run-≈ (done-done x)     = refl

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


open import Type
open import Function.NP
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd) using (Σ;_,_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Control.Protocol

module Control.Protocol.Relation where

ℛ⟦_⟧ : ∀{ℓ}(P : Proto_ ℓ) (p q : ⟦ P ⟧) → ★_ ℓ
ℛ⟦ end    ⟧ p q = End
ℛ⟦ recv P ⟧ p q = ∀ m → ℛ⟦ P m ⟧ (p m) (q m)
ℛ⟦ send P ⟧ p q = Σ (fst p ≡ fst q) λ e → ℛ⟦ P (fst q) ⟧ (subst (⟦_⟧ ∘ P) e (snd p)) (snd q)

ℛ⟦_⟧-refl : ∀ {ℓ}(P : Proto_ ℓ) → Reflexive ℛ⟦ P ⟧
ℛ⟦ end    ⟧-refl     = end
ℛ⟦ recv P ⟧-refl     = λ m → ℛ⟦ P m ⟧-refl
ℛ⟦ send P ⟧-refl {x} = refl , ℛ⟦ P (fst x) ⟧-refl

ℛ⟦_⟧-sym : ∀ {ℓ}(P : Proto_ ℓ) → Symmetric ℛ⟦ P ⟧
ℛ⟦ end    ⟧-sym p          = end
ℛ⟦ recv P ⟧-sym p          = λ m → ℛ⟦ P m ⟧-sym (p m)
ℛ⟦ send P ⟧-sym (refl , q) = refl , ℛ⟦ P _ ⟧-sym q    -- TODO HoTT

ℛ⟦_⟧-trans : ∀ {ℓ}(P : Proto_ ℓ) → Transitive ℛ⟦ P ⟧
ℛ⟦ end    ⟧-trans p          q          = end
ℛ⟦ recv P ⟧-trans p          q          = λ m → ℛ⟦ P m ⟧-trans (p m) (q m)
ℛ⟦ send P ⟧-trans (refl , p) (refl , q) = refl , ℛ⟦ P _ ⟧-trans p q    -- TODO HoTT

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


Added draft about the conversion from/to naturals numbers to/from co-naturals numbers.

Ignore-this: 7217f8ea2eb263ea7e03f8dcfbfbb4cc

darcs-hash:20120321171751-3bd4e-cf577bf55571a38494dd3c7a5e31fed9bd446c94.gz

------------------------------------------------------------------------------
-- Testing the conversion from/to natural numbers to/from co-natural numbers
------------------------------------------------------------------------------

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

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

module Draft.FOTC.Data.Conat.PropertiesSL where

open import Coinduction
open import Data.Conat renaming ( suc to csuc )
open import Data.Nat

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

ℕ→Coℕ : ℕ → Coℕ
ℕ→Coℕ zero    = zero
ℕ→Coℕ (suc n) = csuc (♯ (ℕ→Coℕ n))

Coℕ→ℕ : Coℕ → ℕ
Coℕ→ℕ zero     = zero
Coℕ→ℕ (csuc n) = suc (Coℕ→ℕ (♭ n))

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