Browse Source

Better distributions.

tags/0.1.0.0
Thomas Kerber 1 year ago
parent
commit
92b3b26481
Signed by: Thomas Kerber <t.kerber@ed.ac.uk> GPG Key ID: 8489B911F9ED617B
3 changed files with 77 additions and 41 deletions
  1. +18
    -4
      src/Yggdrasil/Distribution.hs
  2. +41
    -31
      src/Yggdrasil/ExecutionModel.hs
  3. +18
    -6
      src/Yggdrasil/SimpleState.hs

+ 18
- 4
src/Yggdrasil/Distribution.hs View File

@@ -1,8 +1,22 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, Rank2Types #-}

module Yggdrasil.Distribution (Distribution(..)) where
module Yggdrasil.Distribution (Distribution, sample) where

import Control.Monad
import System.Random

class Distribution d b where
sample :: RandomGen g => g -> d -> 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

instance Functor Distribution where
fmap f x = pure f <*> x
instance Applicative Distribution where
pure x = Distribution (\g -> (x, g))
(<*>) = 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''))

+ 41
- 31
src/Yggdrasil/ExecutionModel.hs View File

@@ -1,14 +1,14 @@
{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
AllowAmbiguousTypes, TypeFamilies, GADTs, FlexibleContexts,
ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, GADTs, FlexibleContexts, ConstraintKinds #-}

module Yggdrasil.ExecutionModel (
GlobalState(..), StrongGlobalState(..), Action(..), Funct(..), run
GlobalState(..), StrongGlobalState(..), Action, Funct(..), LegalFunct, run,
abort, sample, send, create
) where

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

-- A weak global state is what functionalities themselves get to see.
-- the weakness lies functionalities not being able to create a new instance of
@@ -18,8 +18,9 @@ class Eq (WeakRef gs) => GlobalState gs where
data Ref gs :: * -> * -> * -> *
data WeakRef gs :: *
weaken :: Ref gs s a b -> WeakRef gs
new :: (Typeable s, Typeable a, Typeable b) => gs -> Funct gs s a b -> (gs, Ref gs s a b)
update :: (Typeable s, Typeable a, Typeable b) => gs -> WeakRef gs -> Ref gs s a b -> a -> Maybe (gs, Action gs b)
new :: LegalFunct gs s a b => gs -> Funct gs s a b -> (gs, Ref gs s a b)
update :: LegalFunct gs s a b =>
gs -> WeakRef gs -> Ref gs s a b -> a -> Maybe (gs, Action gs b)

-- A strong global state is able to create new instances of itself.
class GlobalState gs => StrongGlobalState gs where
@@ -28,35 +29,44 @@ class GlobalState gs => StrongGlobalState gs where

data Funct gs s a b = Funct s ((s, (WeakRef gs, a)) -> (s, Action gs b))

type LegalFunct gs s a b = (GlobalState gs, Typeable s, Typeable a, Typeable b)

data Action gs b where
Return :: b -> Action gs b
Abort :: Action gs b
Sample :: Distribution d b => d -> Action gs b
Send :: (GlobalState gs, Typeable s, Typeable a, Typeable b) => Ref gs s a b -> a -> Action gs b
Create :: (GlobalState gs, Typeable s, Typeable a, Typeable b) => Funct gs s a b -> Action gs (Ref gs s a b)
Sample :: Distribution b -> Action gs b
Send :: LegalFunct gs s a b => Ref gs s a b -> a -> Action gs b
Create :: LegalFunct gs s a b => Funct gs s a b -> Action gs (Ref gs s a b)
Compose :: Action gs c -> (c -> Action gs b) -> Action gs b

run :: RandomGen g => StrongGlobalState gs => g -> Action gs b -> Maybe b
run g = fmap snd . run' g empty external

run' :: RandomGen g => GlobalState gs => g -> gs -> WeakRef gs -> Action gs b -> Maybe (gs, b)
run' _ _ _ Abort = Nothing
run' _ gs _ (Return x) = Just (gs, x)
run' g gs _ (Sample d) = Just (gs, (sample g d))
run' g gs from (Send ref m) = do
(gs', a) <- update gs from ref m
run' g gs' (weaken ref) a
run' g gs _ (Create f) = Just (new gs f)
run' g gs from (Compose a f) = do
(gs', b) <- run' g gs from a
run' g gs' from (f b)
-- Export visible constructors as functions.
abort :: Action gs b
abort = Abort
doSample :: Distribution b -> Action gs b
doSample = Sample
send :: LegalFunct gs s a b => Ref gs s a b -> a -> Action gs b
send = Send
create :: LegalFunct gs s a b => Funct gs s a b -> Action gs (Ref gs s a b)
create = Create

instance Functor (Action gs) where
fmap f a = a >>= (\x -> pure $ f x)
run :: (RandomGen g, StrongGlobalState gs) => g -> Action gs b -> (Maybe b, g)
run g a = let (r, g') = run' g empty external a in (fmap snd r, g')

instance Applicative (Action gs) where
pure = Return
f <*> a = f >>= (\f -> fmap f a)
run' :: (RandomGen g, GlobalState gs) =>
g -> gs -> WeakRef gs -> Action gs b -> (Maybe (gs, b), g)
run' g _ _ Abort = (Nothing, g)
run' g gs _ (Sample d) = let (y, g') = sample g d in (Just (gs, y), g')
run' g gs from (Send ref m) = case update gs from ref m of
Just (gs', a) -> run' g gs' (weaken ref) a
Nothing -> (Nothing, g)
run' g gs _ (Create f) = (Just (new gs f), g)
run' g gs from (Compose a f) = case run' g gs from a of
(Just (gs', b), g') -> run' g' gs' from (f b)
(Nothing, g') -> (Nothing, g')

instance Functor (Action gs) where
fmap f x = pure f <*> x
instance Applicative (Action gs) where
pure = Sample . pure
(<*>) = ap
instance Monad (Action gs) where
a >>= b = Compose a b

+ 18
- 6
src/Yggdrasil/SimpleState.hs View File

@@ -1,4 +1,4 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

module Yggdrasil.SimpleState (SimpleState) where

@@ -8,17 +8,29 @@ import Data.Dynamic
type SSFunct s a b = Funct SimpleState s a b
newtype SimpleState = SimpleState [Dynamic]

get :: (Typeable s, Typeable a, Typeable b) => SimpleState -> Ref SimpleState s a b -> Maybe (Funct SimpleState s a b)
get :: LegalFunct SimpleState s a b =>
SimpleState ->
Ref SimpleState s a b ->
Maybe (Funct SimpleState s a b)
get (SimpleState []) _ = Nothing
get (SimpleState (x:_)) (SSRef 0) = fromDynamic x
get (SimpleState (_:xs)) ref = get (SimpleState xs) (refdec ref)
set :: (Typeable s, Typeable a, Typeable b) => SimpleState -> Ref SimpleState s a b -> Funct SimpleState s a b -> Maybe SimpleState
set :: LegalFunct SimpleState s a b =>
SimpleState ->
Ref SimpleState s a b ->
Funct SimpleState s a b ->
Maybe SimpleState
set (SimpleState []) _ _ = Nothing
set (SimpleState (_:xs)) (SSRef 0) f = Just $ SimpleState $ toDyn f : xs
set (SimpleState (x:xs)) ref f = do
SimpleState (xs') <- set (SimpleState xs) (refdec ref) f
return $ SimpleState (x:xs')
update' :: (Typeable s, Typeable a, Typeable b) => SimpleState -> WeakRef SimpleState -> Ref SimpleState s a b -> a -> Maybe (SimpleState, Action SimpleState b)
SimpleState (xs') <- set (SimpleState xs) (refdec ref) f
return $ SimpleState (x:xs')
update' :: LegalFunct SimpleState s a b =>
SimpleState ->
WeakRef SimpleState ->
Ref SimpleState s a b ->
a ->
Maybe (SimpleState, Action SimpleState b)
update' gs from to msg = get gs to >>= (\(Funct st f) ->
let (st', a) = f (st, (from, msg)) in
set gs to (Funct st' f) >>= (\gs' -> return (gs', a)))

Loading…
Cancel
Save