mirror of
https://github.com/maciej-bendkowski/generic-boltzmann-brain.git
synced 2024-09-11 12:48:09 +03:00
Sampler size tests.
This commit is contained in:
parent
66feb60074
commit
c647de735f
@ -83,101 +83,21 @@ library generic-boltzmann-brain-internal
|
||||
, vector >=0.12.3.1
|
||||
default-language: Haskell2010
|
||||
|
||||
executable binTreeProfile
|
||||
main-is: BinTreeProfile.hs
|
||||
other-modules:
|
||||
BinTree
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
profile/BinTree
|
||||
default-extensions:
|
||||
NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
build-depends:
|
||||
QuickCheck >=2.14.2
|
||||
, base >=4.7 && <5
|
||||
, containers >=0.6.4
|
||||
, data-default >=0.7.1.1
|
||||
, generic-boltzmann-brain
|
||||
, mtl >=2.2.2
|
||||
, paganini-hs >=0.3.0.0
|
||||
, random >=1.2.0
|
||||
, splitmix >=0.1.0.4
|
||||
, template-haskell >=2.17.0.0
|
||||
, th-abstraction >=0.4.3.0
|
||||
, th-lift >=0.8.2
|
||||
, th-lift-instances >=0.1.18
|
||||
, transformers >=0.5.6
|
||||
, vector >=0.12.3.1
|
||||
default-language: Haskell2010
|
||||
|
||||
executable lambdaProfile
|
||||
main-is: LambdaProfile.hs
|
||||
other-modules:
|
||||
Lambda
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
profile/Lambda
|
||||
default-extensions:
|
||||
NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
build-depends:
|
||||
QuickCheck >=2.14.2
|
||||
, base >=4.7 && <5
|
||||
, containers >=0.6.4
|
||||
, data-default >=0.7.1.1
|
||||
, generic-boltzmann-brain
|
||||
, mtl >=2.2.2
|
||||
, paganini-hs >=0.3.0.0
|
||||
, random >=1.2.0
|
||||
, splitmix >=0.1.0.4
|
||||
, template-haskell >=2.17.0.0
|
||||
, th-abstraction >=0.4.3.0
|
||||
, th-lift >=0.8.2
|
||||
, th-lift-instances >=0.1.18
|
||||
, transformers >=0.5.6
|
||||
, vector >=0.12.3.1
|
||||
default-language: Haskell2010
|
||||
|
||||
executable treeProfile
|
||||
main-is: TreeProfile.hs
|
||||
other-modules:
|
||||
Tree
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
profile/Tree
|
||||
default-extensions:
|
||||
NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
build-depends:
|
||||
QuickCheck >=2.14.2
|
||||
, base >=4.7 && <5
|
||||
, containers >=0.6.4
|
||||
, data-default >=0.7.1.1
|
||||
, generic-boltzmann-brain
|
||||
, mtl >=2.2.2
|
||||
, paganini-hs >=0.3.0.0
|
||||
, random >=1.2.0
|
||||
, splitmix >=0.1.0.4
|
||||
, template-haskell >=2.17.0.0
|
||||
, th-abstraction >=0.4.3.0
|
||||
, th-lift >=0.8.2
|
||||
, th-lift-instances >=0.1.18
|
||||
, transformers >=0.5.6
|
||||
, vector >=0.12.3.1
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite generic-boltzmann-brain-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Test.Samplers.BinTree
|
||||
Test.Samplers.Lambda
|
||||
Test.Samplers.Tree
|
||||
Test.Unit.BuffonMachine
|
||||
Test.Unit.Sampler
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions:
|
||||
NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
build-depends:
|
||||
QuickCheck >=2.14.2
|
||||
, base >=4.7 && <5
|
||||
|
28
hie.yaml
28
hie.yaml
@ -3,32 +3,8 @@ cradle:
|
||||
- path: "./src"
|
||||
component: "generic-boltzmann-brain:lib"
|
||||
|
||||
- path: "./profile/BinTree/BinTreeProfile.hs"
|
||||
component: "generic-boltzmann-brain:exe:binTreeProfile"
|
||||
|
||||
- path: "./profile/BinTree/BinTree.hs"
|
||||
component: "generic-boltzmann-brain:exe:binTreeProfile"
|
||||
|
||||
- path: "./profile/BinTree/Paths_generic_boltzmann_brain.hs"
|
||||
component: "generic-boltzmann-brain:exe:binTreeProfile"
|
||||
|
||||
- path: "./profile/Lambda/LambdaProfile.hs"
|
||||
component: "generic-boltzmann-brain:exe:lambdaProfile"
|
||||
|
||||
- path: "./profile/Lambda/Lambda.hs"
|
||||
component: "generic-boltzmann-brain:exe:lambdaProfile"
|
||||
|
||||
- path: "./profile/Lambda/Paths_generic_boltzmann_brain.hs"
|
||||
component: "generic-boltzmann-brain:exe:lambdaProfile"
|
||||
|
||||
- path: "./profile/Tree/TreeProfile.hs"
|
||||
component: "generic-boltzmann-brain:exe:treeProfile"
|
||||
|
||||
- path: "./profile/Tree/Tree.hs"
|
||||
component: "generic-boltzmann-brain:exe:treeProfile"
|
||||
|
||||
- path: "./profile/Tree/Paths_generic_boltzmann_brain.hs"
|
||||
component: "generic-boltzmann-brain:exe:treeProfile"
|
||||
- path: "./internal"
|
||||
component: "generic-boltzmann-brain:lib:generic-boltzmann-brain-internal"
|
||||
|
||||
- path: "./test"
|
||||
component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"
|
||||
|
@ -10,15 +10,19 @@ module Data.Boltzmann.Sampler (
|
||||
BoltzmannSampler (..),
|
||||
|
||||
-- * Rejection samplers
|
||||
LowerBound (..),
|
||||
UpperBound (..),
|
||||
rejectionSampler,
|
||||
toleranceRejectionSampler,
|
||||
|
||||
-- * Other utilities
|
||||
hoistBoltzmannSampler,
|
||||
hoistRejectionSampler,
|
||||
hoistToleranceRejectionSampler,
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
|
||||
import Data.Boltzmann.BuffonMachine (BuffonMachine, eval)
|
||||
import Data.Coerce (coerce)
|
||||
import System.Random (RandomGen)
|
||||
import Test.QuickCheck (Gen)
|
||||
import Test.QuickCheck.Gen (Gen (MkGen))
|
||||
@ -31,16 +35,27 @@ class BoltzmannSampler a where
|
||||
-- the given upper bound parameter, @Nothing@ is returned instead.
|
||||
sample :: RandomGen g => Int -> MaybeT (BuffonMachine g) (a, Int)
|
||||
|
||||
-- | Lower bound for rejection samplers.
|
||||
newtype LowerBound = MkLowerBound Int
|
||||
deriving (Show)
|
||||
|
||||
-- | Upper bound for rejection samplers.
|
||||
newtype UpperBound = MkUpperBound Int
|
||||
deriving (Show)
|
||||
|
||||
-- |
|
||||
-- Rejection sampler for type @a@. Given lower and upper bound @lb@ and @ub@
|
||||
-- generates a random objects of size on between @lb@ and @ub@.
|
||||
rejectionSampler ::
|
||||
(RandomGen g, BoltzmannSampler a) => Int -> Int -> BuffonMachine g a
|
||||
(RandomGen g, BoltzmannSampler a) =>
|
||||
LowerBound ->
|
||||
UpperBound ->
|
||||
BuffonMachine g a
|
||||
rejectionSampler lb ub = do
|
||||
runMaybeT (sample ub)
|
||||
runMaybeT (sample $ coerce ub)
|
||||
>>= ( \case
|
||||
Just (obj, s) ->
|
||||
if lb <= s && s <= ub
|
||||
if coerce lb <= s && s <= coerce ub
|
||||
then pure obj
|
||||
else rejectionSampler lb ub
|
||||
Nothing -> rejectionSampler lb ub
|
||||
@ -48,19 +63,31 @@ rejectionSampler lb ub = do
|
||||
|
||||
-- |
|
||||
-- Rejection sampler for type @a@ which uses a given @eps@ parameter to
|
||||
-- determine the admissible size window @[(1-eps) N, (1+eps) N]@ for a
|
||||
-- sampler centered around the target mean size @N@.
|
||||
-- determine the admissible size window @[(1-eps) n, (1+eps) n]@ centered
|
||||
-- around the given size @n@.
|
||||
toleranceRejectionSampler ::
|
||||
(RandomGen g, BoltzmannSampler a) => Int -> Double -> BuffonMachine g a
|
||||
toleranceRejectionSampler n eps = rejectionSampler lb ub
|
||||
where
|
||||
lb = floor $ (1 - eps) * fromIntegral n
|
||||
ub = ceiling $ (1 + eps) * fromIntegral n
|
||||
lb = MkLowerBound $ floor $ (1 - eps) * fromIntegral n
|
||||
ub = MkUpperBound $ ceiling $ (1 + eps) * fromIntegral n
|
||||
|
||||
-- |
|
||||
-- Hoists a given Boltzmann sampler for @a@ into
|
||||
-- a Quickcheck generator @Gen a@.
|
||||
hoistBoltzmannSampler :: BoltzmannSampler a => Gen a
|
||||
hoistBoltzmannSampler = MkGen $ \(QCGen g) n ->
|
||||
let machine = rejectionSampler 0 n
|
||||
-- Using the given tolerance, hoists a tolerance rejection sampler
|
||||
-- for @a@ to a Quickcheck generator @Gen a@.
|
||||
hoistRejectionSampler ::
|
||||
BoltzmannSampler a =>
|
||||
(Int -> (LowerBound, UpperBound)) ->
|
||||
Gen a
|
||||
hoistRejectionSampler genBounds = MkGen $ \(QCGen g) n ->
|
||||
let (lb, ub) = genBounds n
|
||||
machine = rejectionSampler lb ub
|
||||
in eval machine g
|
||||
|
||||
-- |
|
||||
-- Using the given tolerance, hoists a tolerance rejection sampler
|
||||
-- for @a@ to a Quickcheck generator @Gen a@.
|
||||
hoistToleranceRejectionSampler :: BoltzmannSampler a => Double -> Gen a
|
||||
hoistToleranceRejectionSampler eps = MkGen $ \(QCGen g) n ->
|
||||
let machine = toleranceRejectionSampler n eps
|
||||
in eval machine g
|
||||
|
@ -46,7 +46,7 @@ import Data.Boltzmann.System (
|
||||
import Data.Coerce (coerce)
|
||||
import Data.Default (def)
|
||||
import Data.Functor ((<&>))
|
||||
import Language.Haskell.TH (Exp (LamCaseE), Name, Q, Type (ListT))
|
||||
import Language.Haskell.TH (Exp (LamCaseE), Name, Q, Type (ArrowT, ListT))
|
||||
import Language.Haskell.TH.Datatype (
|
||||
ConstructorInfo (constructorFields, constructorName),
|
||||
DatatypeInfo (datatypeCons),
|
||||
@ -114,6 +114,34 @@ mkCoerce tv = do
|
||||
Plain tn -> ConT $ coerce tn
|
||||
List tn -> AppT ListT (ConT $ coerce tn)
|
||||
|
||||
toTypeVariant :: Type -> SamplerGen TypeVariant
|
||||
toTypeVariant (ConT tn) = pure . Plain $ coerce tn
|
||||
toTypeVariant (AppT ListT (ConT tn)) = pure . List $ coerce tn
|
||||
toTypeVariant typ = fail $ "Unsupported type " ++ show typ
|
||||
|
||||
mkConstrCoerce :: TypeVariant -> ConstructorInfo -> SamplerGen Exp
|
||||
mkConstrCoerce tv info = do
|
||||
typeVariants <- mapM toTypeVariant (constructorFields info)
|
||||
let constrType = foldr arr (convert tv) (map convert typeVariants)
|
||||
|
||||
typSynonym <- findTypeSyn tv
|
||||
synonyms <- mapM findTypeSyn typeVariants
|
||||
let constrSynType = foldr arr typSynonym synonyms
|
||||
|
||||
let fromType = constrType
|
||||
toType = constrSynType
|
||||
|
||||
coerce' <- lift [|coerce|]
|
||||
pure $ AppTypeE (AppTypeE coerce' fromType) toType
|
||||
where
|
||||
convert :: TypeVariant -> Type
|
||||
convert = \case
|
||||
Plain tn -> ConT $ coerce tn
|
||||
List tn -> AppT ListT (ConT $ coerce tn)
|
||||
|
||||
arr :: Type -> Type -> Type
|
||||
arr a = AppT (AppT ArrowT a)
|
||||
|
||||
mkPat :: String -> Q Pat
|
||||
mkPat = pure . VarP . mkName
|
||||
|
||||
@ -125,12 +153,12 @@ mkCon = pure . ConE . coerce
|
||||
|
||||
mkCaseConstr :: TypeVariant -> SamplerGen Exp
|
||||
mkCaseConstr = \case
|
||||
Plain tn -> do
|
||||
tv@(Plain tn) -> do
|
||||
typInfo <- lift $ reifyDatatype (coerce tn)
|
||||
let constrInfo = datatypeCons typInfo
|
||||
constrGroup = zip constrInfo [0 :: Integer ..]
|
||||
|
||||
caseMatches <- mapM (mkCaseMatch tn) constrGroup
|
||||
caseMatches <- mapM (mkCaseMatch tv) constrGroup
|
||||
pure $ LamCaseE caseMatches
|
||||
tv -> do
|
||||
coerceExp <- mkCoerce tv
|
||||
@ -144,10 +172,10 @@ mkCaseConstr = \case
|
||||
pure ($(pure coerceExp) (x : xs), w + ws)
|
||||
|]
|
||||
|
||||
mkCaseMatch :: TypeName -> (ConstructorInfo, Integer) -> SamplerGen Match
|
||||
mkCaseMatch typ (constr, idx) = do
|
||||
mkCaseMatch :: TypeVariant -> (ConstructorInfo, Integer) -> SamplerGen Match
|
||||
mkCaseMatch tv (constr, idx) = do
|
||||
let n' = LitP $ IntegerL idx
|
||||
conExpr <- mkConExpr typ constr
|
||||
conExpr <- mkConExpr tv constr
|
||||
pure $ Match n' (NormalB conExpr) []
|
||||
|
||||
data ArgExp = ArgExp
|
||||
@ -209,24 +237,23 @@ mkArgExpr constr = do
|
||||
name <- lift $ newName s
|
||||
pure (VarP name, VarE name)
|
||||
|
||||
mkConExpr :: TypeName -> ConstructorInfo -> SamplerGen Exp
|
||||
mkConExpr typ constr = do
|
||||
mkConExpr :: TypeVariant -> ConstructorInfo -> SamplerGen Exp
|
||||
mkConExpr tv constr = do
|
||||
ArgExp {..} <- mkArgExpr constr
|
||||
let constrName = MkConstructorName (constructorName constr)
|
||||
constrWeight <- getWeight $ coerce constrName
|
||||
|
||||
constrExp <- lift $ mkCon constrName
|
||||
exp <- lift . pure $ foldl AppE constrExp args
|
||||
coercedConstrExp <- mkConstrCoerce tv constr
|
||||
exp <- lift . pure $ foldl AppE (AppE coercedConstrExp constrExp) args
|
||||
|
||||
coerceExp <- mkCoerce (Plain typ) -- TODO(mbendkowski): FIX
|
||||
object <- lift [|$(pure coerceExp) $(pure exp)|]
|
||||
weightExp <- lift [|$(Lift.lift constrWeight) + $(pure weight)|]
|
||||
|
||||
pureExp <- lift [|pure ($(pure object), $(pure weightExp))|]
|
||||
pureExp <- lift [|pure ($(pure exp), $(pure weightExp))|]
|
||||
pure $ DoE Nothing (stmts <> [NoBindS pureExp])
|
||||
|
||||
mkGuard :: SamplerGen Exp
|
||||
mkGuard = lift [|guard ($(mkVar "ub") > 0)|]
|
||||
mkGuard = lift [|guard ($(mkVar "ub") >= 0)|]
|
||||
|
||||
mkChoice :: TypeVariant -> SamplerGen Exp
|
||||
mkChoice typ = do
|
||||
|
81
package.yaml
81
package.yaml
@ -83,86 +83,6 @@ internal-libraries:
|
||||
ScopedTypeVariables
|
||||
Rank2Types
|
||||
|
||||
executables:
|
||||
binTreeProfile:
|
||||
main: BinTreeProfile.hs
|
||||
source-dirs: profile/BinTree
|
||||
ghc-options:
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Wmissing-export-lists
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wno-name-shadowing
|
||||
- -fwarn-missing-signatures
|
||||
- -ddump-splices
|
||||
dependencies:
|
||||
- generic-boltzmann-brain
|
||||
default-extensions:
|
||||
NumericUnderscores
|
||||
LambdaCase
|
||||
BangPatterns
|
||||
DerivingVia
|
||||
FlexibleInstances
|
||||
UndecidableInstances
|
||||
TypeApplications
|
||||
ScopedTypeVariables
|
||||
Rank2Types
|
||||
treeProfile:
|
||||
main: TreeProfile.hs
|
||||
source-dirs: profile/Tree
|
||||
ghc-options:
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Wmissing-export-lists
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wno-name-shadowing
|
||||
- -fwarn-missing-signatures
|
||||
- -ddump-splices
|
||||
dependencies:
|
||||
- generic-boltzmann-brain
|
||||
default-extensions:
|
||||
NumericUnderscores
|
||||
LambdaCase
|
||||
BangPatterns
|
||||
DerivingVia
|
||||
FlexibleInstances
|
||||
UndecidableInstances
|
||||
TypeApplications
|
||||
ScopedTypeVariables
|
||||
Rank2Types
|
||||
lambdaProfile:
|
||||
main: LambdaProfile.hs
|
||||
source-dirs: profile/Lambda
|
||||
ghc-options:
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Wmissing-export-lists
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wno-name-shadowing
|
||||
- -fwarn-missing-signatures
|
||||
- -ddump-splices
|
||||
dependencies:
|
||||
- generic-boltzmann-brain
|
||||
default-extensions:
|
||||
NumericUnderscores
|
||||
LambdaCase
|
||||
BangPatterns
|
||||
DerivingVia
|
||||
FlexibleInstances
|
||||
UndecidableInstances
|
||||
TypeApplications
|
||||
ScopedTypeVariables
|
||||
Rank2Types
|
||||
|
||||
tests:
|
||||
generic-boltzmann-brain-test:
|
||||
main: Spec.hs
|
||||
@ -177,6 +97,7 @@ tests:
|
||||
- -Wredundant-constraints
|
||||
- -Wno-name-shadowing
|
||||
- -fwarn-missing-signatures
|
||||
- -ddump-splices
|
||||
dependencies:
|
||||
- generic-boltzmann-brain-internal
|
||||
- generic-boltzmann-brain
|
||||
|
@ -1,37 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module BinTree (BinTree (..), randomBinTreeListIO) where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
|
||||
import Data.Boltzmann (
|
||||
BoltzmannSampler (..),
|
||||
Constructable ((<:>)),
|
||||
System (..),
|
||||
evalIO,
|
||||
mkBoltzmannSampler,
|
||||
mkDefWeights,
|
||||
toleranceRejectionSampler,
|
||||
)
|
||||
import Data.Default (Default (def))
|
||||
|
||||
import System.Random.SplitMix (SMGen)
|
||||
|
||||
data BinTree
|
||||
= Leaf
|
||||
| Node BinTree BinTree
|
||||
deriving (Show)
|
||||
|
||||
mkBoltzmannSampler
|
||||
System
|
||||
{ targetType = ''BinTree
|
||||
, meanSize = 1000
|
||||
, frequencies = def
|
||||
, weights =
|
||||
('Leaf, 0)
|
||||
<:> $(mkDefWeights ''BinTree)
|
||||
}
|
||||
|
||||
randomBinTreeListIO :: Int -> IO [BinTree]
|
||||
randomBinTreeListIO n =
|
||||
evalIO $ replicateM n (toleranceRejectionSampler @SMGen 1000 0.2)
|
@ -1,4 +0,0 @@
|
||||
import BinTree (randomBinTreeListIO)
|
||||
|
||||
main :: IO ()
|
||||
main = randomBinTreeListIO 100 >>= print
|
@ -1,60 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Lambda (Lambda (..), randomLambdaListIO) where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
|
||||
import Data.Boltzmann (
|
||||
BoltzmannSampler (..),
|
||||
Constructable ((<:>)),
|
||||
System (..),
|
||||
evalIO,
|
||||
mkBoltzmannSampler,
|
||||
mkDefWeights,
|
||||
toleranceRejectionSampler,
|
||||
)
|
||||
import Data.Default (Default (def))
|
||||
|
||||
import System.Random.SplitMix (SMGen)
|
||||
|
||||
data DeBruijn
|
||||
= Z
|
||||
| S DeBruijn
|
||||
deriving (Show)
|
||||
|
||||
data Lambda
|
||||
= Index DeBruijn
|
||||
| App Lambda Lambda
|
||||
| Abs Lambda
|
||||
deriving (Show)
|
||||
|
||||
mkBoltzmannSampler
|
||||
System
|
||||
{ targetType = ''Lambda
|
||||
, meanSize = 10_000
|
||||
, frequencies = def
|
||||
, weights =
|
||||
('Index, 0)
|
||||
<:> $(mkDefWeights ''Lambda)
|
||||
}
|
||||
|
||||
newtype BinLambda = MkBinLambda Lambda
|
||||
deriving (Show)
|
||||
|
||||
mkBoltzmannSampler
|
||||
System
|
||||
{ targetType = ''BinLambda
|
||||
, meanSize = 10_000
|
||||
, frequencies =
|
||||
('Abs, 4500) <:> def
|
||||
, weights =
|
||||
('Index, 0)
|
||||
<:> ('App, 2)
|
||||
<:> ('Abs, 2)
|
||||
<:> $(mkDefWeights ''Lambda)
|
||||
}
|
||||
|
||||
randomLambdaListIO :: Int -> IO [BinLambda]
|
||||
randomLambdaListIO n =
|
||||
evalIO $
|
||||
replicateM n (toleranceRejectionSampler @SMGen 10_000 0.2)
|
@ -1,4 +0,0 @@
|
||||
import Lambda (randomLambdaListIO)
|
||||
|
||||
main :: IO ()
|
||||
main = randomLambdaListIO 100 >>= print
|
@ -1,28 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Tree (Tree (..), randomTreeListIO) where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
|
||||
import Data.Boltzmann (
|
||||
BoltzmannSampler (..),
|
||||
evalIO,
|
||||
mkDefBoltzmannSampler,
|
||||
toleranceRejectionSampler,
|
||||
)
|
||||
|
||||
import System.Random.SplitMix (SMGen)
|
||||
|
||||
data Tree = T [Tree]
|
||||
deriving (Show)
|
||||
|
||||
mkDefBoltzmannSampler ''Tree 100
|
||||
|
||||
randomTreeListIO :: Int -> IO [Tree]
|
||||
randomTreeListIO n =
|
||||
evalIO $ replicateM n (toleranceRejectionSampler @SMGen 1000 0.2)
|
||||
|
||||
newtype Tree' = MkTree' Tree
|
||||
deriving (Show)
|
||||
|
||||
mkDefBoltzmannSampler ''Tree' 2000
|
@ -1,4 +0,0 @@
|
||||
import Tree (randomTreeListIO)
|
||||
|
||||
main :: IO ()
|
||||
main = randomTreeListIO 100 >>= print
|
@ -8,11 +8,14 @@ module Data.Boltzmann (
|
||||
|
||||
-- * Boltzmann samplers
|
||||
BoltzmannSampler (..),
|
||||
LowerBound (..),
|
||||
UpperBound (..),
|
||||
rejectionSampler,
|
||||
toleranceRejectionSampler,
|
||||
mkBoltzmannSampler,
|
||||
mkDefBoltzmannSampler,
|
||||
hoistBoltzmannSampler,
|
||||
hoistRejectionSampler,
|
||||
hoistToleranceRejectionSampler,
|
||||
|
||||
-- * Buffon machines
|
||||
BuffonMachine,
|
||||
@ -34,7 +37,10 @@ import Data.Boltzmann.System.TH (
|
||||
|
||||
import Data.Boltzmann.Sampler (
|
||||
BoltzmannSampler (..),
|
||||
hoistBoltzmannSampler,
|
||||
LowerBound (..),
|
||||
UpperBound (..),
|
||||
hoistRejectionSampler,
|
||||
hoistToleranceRejectionSampler,
|
||||
rejectionSampler,
|
||||
toleranceRejectionSampler,
|
||||
)
|
||||
|
@ -1,5 +1,6 @@
|
||||
import Test.Tasty (TestTree, defaultMain, testGroup)
|
||||
import qualified Test.Unit.BuffonMachine as BuffonMachine
|
||||
import qualified Test.Unit.Sampler as Sampler
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain tests
|
||||
@ -9,4 +10,6 @@ tests = testGroup "Unit tests" unitTests
|
||||
|
||||
unitTests :: [TestTree]
|
||||
unitTests =
|
||||
[BuffonMachine.unitTests]
|
||||
[ BuffonMachine.unitTests
|
||||
, Sampler.unitTests
|
||||
]
|
||||
|
44
test/Test/Samplers/BinTree.hs
Normal file
44
test/Test/Samplers/BinTree.hs
Normal file
@ -0,0 +1,44 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Test.Samplers.BinTree (BinTree (..), size) where
|
||||
|
||||
import Data.Boltzmann (
|
||||
BoltzmannSampler (..),
|
||||
Constructable (..),
|
||||
LowerBound (MkLowerBound),
|
||||
System (..),
|
||||
UpperBound (MkUpperBound),
|
||||
hoistRejectionSampler,
|
||||
mkBoltzmannSampler,
|
||||
mkDefWeights,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.QuickCheck (Arbitrary (arbitrary, shrink))
|
||||
|
||||
data BinTree
|
||||
= Leaf
|
||||
| Node BinTree BinTree
|
||||
deriving (Generic, Show)
|
||||
|
||||
size :: BinTree -> Int
|
||||
size = \case
|
||||
Leaf -> 0
|
||||
Node lt rt -> 1 + size lt + size rt
|
||||
|
||||
mkBoltzmannSampler
|
||||
System
|
||||
{ targetType = ''BinTree
|
||||
, meanSize = 1000
|
||||
, frequencies = def
|
||||
, weights =
|
||||
('Leaf, 0)
|
||||
<:> $(mkDefWeights ''BinTree)
|
||||
}
|
||||
|
||||
instance Arbitrary BinTree where
|
||||
arbitrary =
|
||||
hoistRejectionSampler $
|
||||
const (MkLowerBound 800, MkUpperBound 1200)
|
||||
shrink = const []
|
94
test/Test/Samplers/Lambda.hs
Normal file
94
test/Test/Samplers/Lambda.hs
Normal file
@ -0,0 +1,94 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Test.Samplers.Lambda (
|
||||
DeBruijn (..),
|
||||
Lambda (..),
|
||||
BinLambda (..),
|
||||
size,
|
||||
sizeBin,
|
||||
) where
|
||||
|
||||
import Data.Boltzmann (
|
||||
BoltzmannSampler (..),
|
||||
Constructable (..),
|
||||
LowerBound (MkLowerBound),
|
||||
System (..),
|
||||
UpperBound (MkUpperBound),
|
||||
hoistRejectionSampler,
|
||||
mkBoltzmannSampler,
|
||||
mkDefWeights,
|
||||
)
|
||||
import Data.Default (def)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.QuickCheck (Arbitrary (arbitrary, shrink))
|
||||
|
||||
data DeBruijn
|
||||
= Z
|
||||
| S DeBruijn
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance Arbitrary DeBruijn where
|
||||
arbitrary = undefined -- not used
|
||||
shrink = const []
|
||||
|
||||
data Lambda
|
||||
= Index DeBruijn
|
||||
| App Lambda Lambda
|
||||
| Abs Lambda
|
||||
deriving (Generic, Show)
|
||||
|
||||
mkBoltzmannSampler
|
||||
System
|
||||
{ targetType = ''Lambda
|
||||
, meanSize = 10_000
|
||||
, frequencies = ('Abs, 4_000) <:> def
|
||||
, weights =
|
||||
('Index, 0)
|
||||
<:> $(mkDefWeights ''Lambda)
|
||||
}
|
||||
|
||||
size' :: DeBruijn -> Int
|
||||
size' = \case
|
||||
Z -> 1
|
||||
S n -> 1 + size' n
|
||||
|
||||
size :: Lambda -> Int
|
||||
size = \case
|
||||
Index n -> size' n
|
||||
App lt rt -> 1 + size lt + size rt
|
||||
Abs t -> 1 + size t
|
||||
|
||||
sizeBin :: BinLambda -> Int
|
||||
sizeBin = \case
|
||||
MkBinLambda (Index n) -> size' n
|
||||
MkBinLambda (App lt rt) ->
|
||||
2 + sizeBin (MkBinLambda lt) + sizeBin (MkBinLambda rt)
|
||||
MkBinLambda (Abs t) -> 2 + sizeBin (MkBinLambda t)
|
||||
|
||||
instance Arbitrary Lambda where
|
||||
arbitrary =
|
||||
hoistRejectionSampler $
|
||||
const (MkLowerBound 8_000, MkUpperBound 12_000)
|
||||
shrink = const []
|
||||
|
||||
newtype BinLambda = MkBinLambda Lambda
|
||||
deriving (Generic, Show)
|
||||
|
||||
mkBoltzmannSampler
|
||||
System
|
||||
{ targetType = ''BinLambda
|
||||
, meanSize = 6_000
|
||||
, frequencies = def
|
||||
, weights =
|
||||
('Index, 0)
|
||||
<:> ('App, 2)
|
||||
<:> ('Abs, 2)
|
||||
<:> $(mkDefWeights ''Lambda)
|
||||
}
|
||||
|
||||
instance Arbitrary BinLambda where
|
||||
arbitrary =
|
||||
hoistRejectionSampler $
|
||||
const (MkLowerBound 5_000, MkUpperBound 6_400)
|
||||
shrink = const []
|
29
test/Test/Samplers/Tree.hs
Normal file
29
test/Test/Samplers/Tree.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Test.Samplers.Tree (Tree (..), size) where
|
||||
|
||||
import Data.Boltzmann (
|
||||
BoltzmannSampler (..),
|
||||
LowerBound (MkLowerBound),
|
||||
UpperBound (MkUpperBound),
|
||||
hoistRejectionSampler,
|
||||
mkDefBoltzmannSampler,
|
||||
)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.QuickCheck (Arbitrary (arbitrary, shrink))
|
||||
|
||||
data Tree = T [Tree]
|
||||
deriving (Generic, Show)
|
||||
|
||||
mkDefBoltzmannSampler ''Tree 2000
|
||||
|
||||
size :: Tree -> Int
|
||||
size = \case
|
||||
T ts -> 1 + sum (map size ts)
|
||||
|
||||
instance Arbitrary Tree where
|
||||
arbitrary =
|
||||
hoistRejectionSampler $
|
||||
const (MkLowerBound 1600, MkUpperBound 2400)
|
||||
shrink = const []
|
30
test/Test/Unit/Sampler.hs
Normal file
30
test/Test/Unit/Sampler.hs
Normal file
@ -0,0 +1,30 @@
|
||||
module Test.Unit.Sampler (unitTests) where
|
||||
|
||||
import qualified Test.Samplers.BinTree as BinTree
|
||||
import qualified Test.Samplers.Lambda as Lambda
|
||||
import qualified Test.Samplers.Tree as Tree
|
||||
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.QuickCheck as QC (testProperty)
|
||||
|
||||
unitTests :: TestTree
|
||||
unitTests =
|
||||
testGroup
|
||||
"Sampler tests"
|
||||
[ QC.testProperty "BinTree sampler respects size constraints" $
|
||||
\binTree ->
|
||||
let s = BinTree.size binTree
|
||||
in 800 <= s && s <= 1200
|
||||
, QC.testProperty "Tree sampler respects size constraints" $
|
||||
\tree ->
|
||||
let s = Tree.size tree
|
||||
in 1600 <= s && s <= 2400
|
||||
, QC.testProperty "Lambda sampler respects size constraints" $
|
||||
\term ->
|
||||
let s = Lambda.size term
|
||||
in 8_000 <= s && s <= 12_000
|
||||
, QC.testProperty "BinLambda sampler respects size constraints" $
|
||||
\term ->
|
||||
let s = Lambda.sizeBin term
|
||||
in 5_000 <= s && s <= 6_400
|
||||
]
|
Loading…
Reference in New Issue
Block a user