module Data.Lambda.Random
(
closedLambda
, closedLambdaIO
, filterClosed
, filterClosedIO
, plainLambda
, plainLambdaIO
, filterPlain
, filterPlainIO
) where
import Prelude hiding (abs)
import Control.Monad
import Control.Monad.Random
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Lambda
import Data.Lambda.Model
import qualified Data.Lambda.Random.System as S
import qualified Data.Lambda.Random.PlainSystem as P
randomP :: (Random a, Num a, RandomGen g) => MaybeT (Rand g) a
randomP = lift $ getRandomR (0,1)
pass :: S.System a -> S.System a
pass [e] = [e]
pass (_:es) = es
pass _ = error "Can't pass an empty system!"
randomClosedLambda :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> S.Sampler a b
-> b
-> MaybeT (Rand g) (Lambda, b)
randomClosedLambda spec = randomClosedLambda' m sys
where (m,sys) = (S.model spec, S.system spec)
randomClosedLambda' :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> Model b -> [S.Expr a] -> b -> MaybeT (Rand g) (Lambda, b)
randomClosedLambda' m sys @ (e:_) ub = do
guard (ub > 0)
p <- randomP
if p < S.abs e then do
let w = absW m
(x,s) <- randomClosedLambda' m (pass sys) (ub w)
return (Abs x, s + w)
else if p < S.app e then do
let w = appW m
(x,s) <- randomClosedLambda' m sys (ub w)
(x',s') <- randomClosedLambda' m sys (ub w s)
return (App x x', s + s' + w)
else do
(x,s) <- randomIndex m ub p (S.idx e)
return (Var x, s)
randomClosedLambda' _ _ _ = error "I wasn't expecting the Spanish Inquisition."
randomIndex :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> Model b
-> b
-> a
-> [a]
-> MaybeT (Rand g) (Index, b)
randomIndex m ub = randomIndex' m (ub w) Z w
where w = zeroW m
randomIndex' :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> Model b -> b -> Index -> b -> a -> [a] -> MaybeT (Rand g) (Index, b)
randomIndex' m ub idx w p ps = do
guard (ub > 0)
case ps of
(p':ps') ->
if p < p' then return (idx, w)
else do
let w' = succW m
randomIndex' m (ub w') (S idx) (w + w') p ps'
_ -> return (idx, w)
randomLambda :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> P.PlainSampler a b -> b -> MaybeT (Rand g) (Lambda, b)
randomLambda spec = randomLambda' m sys
where (m,sys) = (P.model spec, P.system spec)
randomLambda' :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> Model b -> P.PlainSystem a -> b -> MaybeT (Rand g) (Lambda, b)
randomLambda' m sys ub = do
guard (ub > 0)
p <- randomP
if p < P.abs sys then do
let w = absW m
(x,s) <- randomLambda' m sys (ub w)
return (Abs x, s + w)
else if p < P.app sys then do
let w = appW m
(x,s) <- randomLambda' m sys (ub w)
(x',s') <- randomLambda' m sys (ub w s)
return (App x x', s + s' + w)
else do
(x,s) <- randomPlainIndex m ub (P.zero sys)
return (Var x, s)
randomPlainIndex :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> Model b -> b -> a -> MaybeT (Rand g) (Index, b)
randomPlainIndex m ub zeroP = do
guard (ub > 0)
p <- randomP
if p < zeroP then return (Z, zeroW m)
else do
let w = succW m
(idx, s) <- randomPlainIndex m (ub w) zeroP
return (S idx, s + w)
closedLambda :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> S.Sampler a b
-> b
-> b
-> Rand g Lambda
closedLambda spec lb ub = do
sample <- runMaybeT $ randomClosedLambda spec ub
case sample of
Nothing -> closedLambda spec lb ub
Just (t, w) -> if lb <= w then return t
else closedLambda spec lb ub
closedLambdaIO :: (Random a, Num a, Ord a, Integral b)
=> S.Sampler a b
-> b
-> b
-> IO Lambda
closedLambdaIO spec lb ub = evalRandIO rand
where rand = closedLambda spec lb ub
plainLambda :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> P.PlainSampler a b
-> b
-> b
-> Rand g Lambda
plainLambda spec lb ub = do
sample <- runMaybeT $ randomLambda spec ub
case sample of
Nothing -> plainLambda spec lb ub
Just (t, w) -> if lb <= w then return t
else plainLambda spec lb ub
plainLambdaIO :: (Random a, Num a, Ord a, Integral b)
=> P.PlainSampler a b
-> b
-> b
-> IO Lambda
plainLambdaIO spec lb ub = evalRandIO rand
where rand = plainLambda spec lb ub
filterClosed :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> (Lambda -> Bool)
-> S.Sampler a b
-> b
-> b
-> Rand g Lambda
filterClosed p spec lb ub = do
t <- closedLambda spec lb ub
if p t then return t
else filterClosed p spec lb ub
filterClosedIO :: (Random a, Num a, Ord a, Integral b)
=> (Lambda -> Bool)
-> S.Sampler a b
-> b
-> b
-> IO Lambda
filterClosedIO p spec lb ub = evalRandIO rand
where rand = filterClosed p spec lb ub
filterPlain :: (Random a, Num a, Ord a, Integral b, RandomGen g)
=> (Lambda -> Bool)
-> P.PlainSampler a b
-> b
-> b
-> Rand g Lambda
filterPlain p spec lb ub = do
t <- plainLambda spec lb ub
if p t then return t
else filterPlain p spec lb ub
filterPlainIO :: (Random a, Num a, Ord a, Integral b)
=> (Lambda -> Bool)
-> P.PlainSampler a b
-> b
-> b
-> IO Lambda
filterPlainIO p spec lb ub = evalRandIO rand
where rand = filterPlain p spec lb ub