Browse Source

Do distributions properly.

tags/0.1.0.0
Thomas Kerber 1 year ago
parent
commit
e3f945d5ed
Signed by: Thomas Kerber <tk@drwx.org> GPG Key ID: 8489B911F9ED617B
6 changed files with 114 additions and 65 deletions
  1. +45
    -10
      src/Yggdrasil/Distribution.hs
  2. +35
    -42
      src/Yggdrasil/ExecutionModel.hs
  3. +3
    -2
      src/Yggdrasil/Functionalities.hs
  4. +26
    -8
      tests/ExecTests.hs
  5. +3
    -1
      tests/Spec.hs
  6. +2
    -2
      yggdrasil.cabal

+ 45
- 10
src/Yggdrasil/Distribution.hs View File

@@ -1,17 +1,18 @@
{-# LANGUAGE MultiParamTypeClasses,
ExistentialQuantification,
Rank2Types,
ScopedTypeVariables,
TupleSections #-}

module Yggdrasil.Distribution (Distribution, sample) where
module Yggdrasil.Distribution (Distribution, Sampler, sample, coin, uniform) where

import Control.Monad
import System.Random
import Crypto.Random
import Data.Bits
import Data.Maybe
import qualified Data.ByteArray as B

newtype Distribution b = Distribution (forall g. RandomGen g => g -> (b, g))

sample :: RandomGen g => g -> Distribution b -> (b, g)
sample g (Distribution f) = f g
newtype Distribution b = Distribution (forall s. Sampler s => s -> (b, s))

instance Functor Distribution where
fmap f x = pure f <*> x
@@ -19,7 +20,41 @@ instance Applicative Distribution where
pure x = Distribution (x,)
(<*>) = ap
instance Monad Distribution where
a >>= b = Distribution (\g ->
let (a', g') = sample g a in
let (b', g'') = sample g' (b a')
in (b', g''))
a >>= b = Distribution (\s -> let
(a', s') = sample s a
(b', s'') = sample s' (b a')
in (b', s''))

class Sampler s where
sampleCoin :: s -> (Bool, s)

instance Sampler SystemDRG where
sampleCoin s = (if b .&. 1 == 1 then True else False, s')
where
(ba :: B.Bytes, s') = randomBytesGenerate 1 s
(b, _) = fromJust $ B.uncons ba

sample :: Sampler s => s -> Distribution b -> (b, s)
sample s (Distribution f) = f s

coin :: Distribution Bool
coin = Distribution sampleCoin

uniform :: [a] -> Distribution a
uniform xs = do
let l = length xs
let lg = ilog2 l
n <- samplen lg
if n > l then uniform xs else return (xs !! n)
where
ilog2 :: Int -> Int
ilog2 1 = 0
ilog2 n | n > 1 = ilog2 (n `div` 2) + 1
ilog2 _ = error "attempted non-postive logarithm"
samplen :: Int -> Distribution Int
samplen 0 = return 0
samplen lg | lg > 0 = do
n' <- samplen (lg-1)
c <- coin
return $ (n' * 2) + if c then 1 else 0
samplen _ = error "attempted to sample negative logarithm"

+ 35
- 42
src/Yggdrasil/ExecutionModel.hs View File

@@ -3,17 +3,17 @@
FlexibleContexts,
ConstraintKinds,
ScopedTypeVariables,
TypeOperators,
TupleSections #-}

module Yggdrasil.ExecutionModel (
Operation, TypOperation, TypFunctionality, Ref, WeakRef, Action,
Functionality(..), external, weaken, abort, strengthenSelf, self, doSample,
Operation, WeakRef, Action,
Functionality(..), type (->>), external, weaken, abort, strengthenSelf, self, doSample,
send, create, run
) where

import Control.Monad
import Data.Dynamic
import System.Random
import Yggdrasil.Distribution

newtype World = World [Dynamic]
@@ -22,20 +22,10 @@ newtype World = World [Dynamic]
-- state 's'.
type Operation s a b = (s, WeakRef, a) -> Action (s, b)

type TypOperation s a b = (Typeable s, Typeable a, Typeable b)

type TypFunctionality s b = (Typeable s, Typeable b)

data Functionality s b = Functionality s (Action b)

data Ref s a b = Ref
{ index :: Int
, func :: Operation s a b
}
data a ->> b where
Ref :: Typeable s => Int -> Operation s a b -> (a ->> b)

-- | A weakened reference, that allows comparing entities for equality, but
-- nothing else.
@@ -47,11 +37,11 @@ external :: WeakRef
external = WeakRef (-1)

-- | Weakens a functionality reference.
weaken :: Ref s a b -> WeakRef
weaken = WeakRef . index
weaken :: (a ->> b) -> WeakRef
weaken (Ref idx _) = WeakRef idx

strengthen :: TypOperation s a b =>
World -> WeakRef -> Operation s a b -> Maybe (Ref s a b)
strengthen :: Typeable s =>
World -> WeakRef -> Operation s a b -> Maybe (a ->> b)
strengthen (World []) _ _ = Nothing
strengthen (World (x:_)) (WeakRef 0) (f :: Operation s a b) = do
_ :: s <- fromDynamic x
@@ -77,11 +67,11 @@ safeWriteIdx (x:xs) i x' = (:) x <$> safeWriteIdx xs (i-1) x'

data Action b where
Abort :: Action b
StrengthenSelf :: TypOperation s a b => Operation s a b -> Action (Ref s a b)
StrengthenSelf :: Typeable s => Operation s a b -> Action (a ->> b)
Self :: Action WeakRef
Sample :: Distribution b -> Action b
Send :: TypOperation s a b => Ref s a b -> a -> Action b
Create :: TypFunctionality s b => Functionality s b -> Action b
Send :: (a ->> b) -> a -> Action b
Create :: Typeable s => Functionality s b -> Action b
Compose :: Action c -> (c -> Action b) -> Action b

-- Export visible constructors as functions.
@@ -91,7 +81,7 @@ abort = Abort
-- | Attempts to add a new operation on ourselves.
-- This action will fail (effectively aborting) if our state is not of type
-- 's'.
strengthenSelf :: TypOperation s a b => Operation s a b -> Action (Ref s a b)
strengthenSelf :: Typeable s => Operation s a b -> Action (a ->> b)
strengthenSelf = StrengthenSelf
-- | Obtain a weak reference on ourselves.
self :: Action WeakRef
@@ -101,11 +91,11 @@ doSample :: Distribution b -> Action b
doSample = Sample
-- | Send a message to a receipient we know the reference of.
-- Unless the receipient aborts, he must eventually respond.
send :: TypOperation s a b => Ref s a b -> a -> Action b
send :: a ->> b -> a -> Action b
send = Send
-- | Creates a new autonomous party, with a given initial state, and a given
-- program.
create :: TypFunctionality s b => Functionality s b -> Action b
create :: Typeable s => Functionality s b -> Action b
create = Create

instance Functor Action where
@@ -117,35 +107,26 @@ instance Monad Action where
a >>= b = Compose a b

-- | Execute a top-level action in the Yggdrasil execution model.
run :: RandomGen g => g -> Action b -> Maybe (b, g)
run g a = (\(_, b, g') -> (b, g')) <$> run' g (World []) external a
run :: Sampler s => s -> Action b -> Maybe (b, s)
run s a = (\(_, b, s') -> (b, s')) <$> run' s (World []) external a

run' :: RandomGen g =>
g -> World -> WeakRef -> Action b -> Maybe (World, b, g)
run' :: Sampler s =>
s -> World -> WeakRef -> Action b -> Maybe (World, b, s)
run' _ _ _ Abort = Nothing
run' g wld slf (StrengthenSelf f) =
(wld, , g) <$> strengthen wld slf f
run' g wld slf Self = Just (wld, slf, g)
run' g wld _ (Sample d) = let (y, g') = sample g d in Just (wld, y, g')
run' g (World xs) from (Send to m) = do
dyns <- safeIdx xs (index to)
s <- fromDynamic dyns
let action = func to (s, from, m)
(World xs', (s', y), g') <- run' g (World xs) (weaken to) action
xs'' <- safeWriteIdx xs' (index to) (toDyn s')
return (World xs'', y, g')
run' s wld slf (StrengthenSelf f) =
(wld, , s) <$> strengthen wld slf f
run' s wld slf Self = return (wld, slf, s)
run' s wld _ (Sample d) = let (y, s') = sample s d in Just (wld, y, s')
run' s (World xs) from (Send to@(Ref idx func) m) = do
dyns <- safeIdx xs idx
st <- fromDynamic dyns
let action = func (st, from, m)
(World xs', (st', y), s') <- run' s (World xs) (weaken to) action
xs'' <- safeWriteIdx xs' idx (toDyn st')
return (World xs'', y, s')
-- Note: This could cause a re-entrancy style bug!
run' g wld _ (Create (Functionality s a)) =
let (wld', from') = new wld s in run' g wld' from' a
run' g wld from (Compose a f) = do
(wld', b, g') <- run' g wld from a
run' g' wld' from (f b)

run' s wld _ (Create (Functionality st a)) =
let (wld', from') = new wld st in run' s wld' from' a
run' s wld from (Compose a f) = do
(wld', b, s') <- run' s wld from a
run' s' wld' from (f b)

+ 3
- 2
src/Yggdrasil/Functionalities.hs View File

@@ -1,3 +1,4 @@
{-# LANGUAGE TypeOperators #-}

module Yggdrasil.Functionalities (
commonRandomString, randomOracle
@@ -12,7 +13,7 @@ crsOp :: Distribution b -> Operation (CRSState b) () b
crsOp _ (Just x, _, ()) = return (Just x, x)
crsOp d (Nothing, _, ()) = (\x -> (Just x, x)) <$> doSample d
commonRandomString :: Typeable b =>
Distribution b -> Functionality (CRSState b) (Ref (CRSState b) () b)
Distribution b -> Functionality (CRSState b) (() ->> b)
commonRandomString d = Functionality Nothing (strengthenSelf (crsOp d))

type ROState a b = [(a, b)]
@@ -27,5 +28,5 @@ roOp d (xs, _, x') = case roLookup xs x' of
y <- doSample d
return ((x', y):xs, y)
randomOracle :: (Eq a, Typeable a, Typeable b) =>
Distribution b -> Functionality (ROState a b) (Ref (ROState a b) a b)
Distribution b -> Functionality (ROState a b) (a ->> b)
randomOracle d = Functionality [] (strengthenSelf (roOp d))

+ 26
- 8
tests/ExecTests.hs View File

@@ -2,15 +2,33 @@

module ExecTests (spec) where

import System.Random
import Crypto.Random
import Data.Maybe
import Test.Hspec
import Test.Hspec.QuickCheck
import Yggdrasil.ExecutionModel
import Yggdrasil.Distribution

spec :: Spec
spec =
describe "action" $ do
prop "obeys return" $ \i (x::String) ->
fst (run (mkStdGen i) (return x)) == Just x
prop "is exteral" $ \i ->
fst (run (mkStdGen i) self) == Just external
inSampleRange :: Int -> Bool
inSampleRange x = x > 4700 && x < 5300

sampleTest :: Action Int
sampleTest = sampleTest' 10000
where
sampleTest' :: Int -> Action Int
sampleTest' 0 = return 0
sampleTest' n = do
x <- sampleTest' (n-1)
b <- doSample (uniform [0, 1])
return $ x + b

spec :: IO Spec
spec = do
rnd <- getSystemDRG
return $ describe "action" $ do
prop "obeys return" $ \(x::String) -> do
(fmap fst (run rnd (return x))) == Just x
it "is exteral" $
(fmap fst (run rnd self) == Just external) `shouldBe` True
it "samples evenly" $
inSampleRange (fst $ fromJust (run rnd sampleTest)) `shouldBe` True

+ 3
- 1
tests/Spec.hs View File

@@ -3,4 +3,6 @@ import Test.Hspec
import qualified ExecTests

main :: IO ()
main = hspec ExecTests.spec
main = do
execTests <- ExecTests.spec
hspec execTests

+ 2
- 2
yggdrasil.cabal View File

@@ -20,7 +20,7 @@ library
exposed-modules: Yggdrasil.Distribution, Yggdrasil.ExecutionModel, Yggdrasil.Functionalities
-- other-modules:
other-extensions: ExistentialQuantification, MultiParamTypeClasses, AllowAmbiguousTypes, TypeFamilies, GADTs, FlexibleContexts, ScopedTypeVariables
build-depends: random, base >=4.11 && <4.12
build-depends: base, cryptonite, memory
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall -Werror
@@ -33,4 +33,4 @@ test-suite spec
ghc-options: -Wall -Werror
main-is: Spec.hs
other-modules: ExecTests
build-depends: random, base, hspec, QuickCheck, yggdrasil
build-depends: cryptonite, base, hspec, QuickCheck, yggdrasil

Loading…
Cancel
Save