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
|
, vector >=0.12.3.1
|
||||||
default-language: Haskell2010
|
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
|
test-suite generic-boltzmann-brain-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Test.Samplers.BinTree
|
||||||
|
Test.Samplers.Lambda
|
||||||
|
Test.Samplers.Tree
|
||||||
Test.Unit.BuffonMachine
|
Test.Unit.BuffonMachine
|
||||||
|
Test.Unit.Sampler
|
||||||
Paths_generic_boltzmann_brain
|
Paths_generic_boltzmann_brain
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
test
|
||||||
default-extensions:
|
default-extensions:
|
||||||
NumericUnderscores LambdaCase BangPatterns DerivingVia FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables Rank2Types
|
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:
|
build-depends:
|
||||||
QuickCheck >=2.14.2
|
QuickCheck >=2.14.2
|
||||||
, base >=4.7 && <5
|
, base >=4.7 && <5
|
||||||
|
28
hie.yaml
28
hie.yaml
@ -3,32 +3,8 @@ cradle:
|
|||||||
- path: "./src"
|
- path: "./src"
|
||||||
component: "generic-boltzmann-brain:lib"
|
component: "generic-boltzmann-brain:lib"
|
||||||
|
|
||||||
- path: "./profile/BinTree/BinTreeProfile.hs"
|
- path: "./internal"
|
||||||
component: "generic-boltzmann-brain:exe:binTreeProfile"
|
component: "generic-boltzmann-brain:lib:generic-boltzmann-brain-internal"
|
||||||
|
|
||||||
- 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: "./test"
|
- path: "./test"
|
||||||
component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"
|
component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"
|
||||||
|
@ -10,15 +10,19 @@ module Data.Boltzmann.Sampler (
|
|||||||
BoltzmannSampler (..),
|
BoltzmannSampler (..),
|
||||||
|
|
||||||
-- * Rejection samplers
|
-- * Rejection samplers
|
||||||
|
LowerBound (..),
|
||||||
|
UpperBound (..),
|
||||||
rejectionSampler,
|
rejectionSampler,
|
||||||
toleranceRejectionSampler,
|
toleranceRejectionSampler,
|
||||||
|
|
||||||
-- * Other utilities
|
-- * Other utilities
|
||||||
hoistBoltzmannSampler,
|
hoistRejectionSampler,
|
||||||
|
hoistToleranceRejectionSampler,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
|
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
|
||||||
import Data.Boltzmann.BuffonMachine (BuffonMachine, eval)
|
import Data.Boltzmann.BuffonMachine (BuffonMachine, eval)
|
||||||
|
import Data.Coerce (coerce)
|
||||||
import System.Random (RandomGen)
|
import System.Random (RandomGen)
|
||||||
import Test.QuickCheck (Gen)
|
import Test.QuickCheck (Gen)
|
||||||
import Test.QuickCheck.Gen (Gen (MkGen))
|
import Test.QuickCheck.Gen (Gen (MkGen))
|
||||||
@ -31,16 +35,27 @@ class BoltzmannSampler a where
|
|||||||
-- the given upper bound parameter, @Nothing@ is returned instead.
|
-- the given upper bound parameter, @Nothing@ is returned instead.
|
||||||
sample :: RandomGen g => Int -> MaybeT (BuffonMachine g) (a, Int)
|
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@
|
-- Rejection sampler for type @a@. Given lower and upper bound @lb@ and @ub@
|
||||||
-- generates a random objects of size on between @lb@ and @ub@.
|
-- generates a random objects of size on between @lb@ and @ub@.
|
||||||
rejectionSampler ::
|
rejectionSampler ::
|
||||||
(RandomGen g, BoltzmannSampler a) => Int -> Int -> BuffonMachine g a
|
(RandomGen g, BoltzmannSampler a) =>
|
||||||
|
LowerBound ->
|
||||||
|
UpperBound ->
|
||||||
|
BuffonMachine g a
|
||||||
rejectionSampler lb ub = do
|
rejectionSampler lb ub = do
|
||||||
runMaybeT (sample ub)
|
runMaybeT (sample $ coerce ub)
|
||||||
>>= ( \case
|
>>= ( \case
|
||||||
Just (obj, s) ->
|
Just (obj, s) ->
|
||||||
if lb <= s && s <= ub
|
if coerce lb <= s && s <= coerce ub
|
||||||
then pure obj
|
then pure obj
|
||||||
else rejectionSampler lb ub
|
else rejectionSampler lb ub
|
||||||
Nothing -> 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
|
-- 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
|
-- determine the admissible size window @[(1-eps) n, (1+eps) n]@ centered
|
||||||
-- sampler centered around the target mean size @N@.
|
-- around the given size @n@.
|
||||||
toleranceRejectionSampler ::
|
toleranceRejectionSampler ::
|
||||||
(RandomGen g, BoltzmannSampler a) => Int -> Double -> BuffonMachine g a
|
(RandomGen g, BoltzmannSampler a) => Int -> Double -> BuffonMachine g a
|
||||||
toleranceRejectionSampler n eps = rejectionSampler lb ub
|
toleranceRejectionSampler n eps = rejectionSampler lb ub
|
||||||
where
|
where
|
||||||
lb = floor $ (1 - eps) * fromIntegral n
|
lb = MkLowerBound $ floor $ (1 - eps) * fromIntegral n
|
||||||
ub = ceiling $ (1 + eps) * fromIntegral n
|
ub = MkUpperBound $ ceiling $ (1 + eps) * fromIntegral n
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Hoists a given Boltzmann sampler for @a@ into
|
-- Using the given tolerance, hoists a tolerance rejection sampler
|
||||||
-- a Quickcheck generator @Gen a@.
|
-- for @a@ to a Quickcheck generator @Gen a@.
|
||||||
hoistBoltzmannSampler :: BoltzmannSampler a => Gen a
|
hoistRejectionSampler ::
|
||||||
hoistBoltzmannSampler = MkGen $ \(QCGen g) n ->
|
BoltzmannSampler a =>
|
||||||
let machine = rejectionSampler 0 n
|
(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
|
in eval machine g
|
||||||
|
@ -46,7 +46,7 @@ import Data.Boltzmann.System (
|
|||||||
import Data.Coerce (coerce)
|
import Data.Coerce (coerce)
|
||||||
import Data.Default (def)
|
import Data.Default (def)
|
||||||
import Data.Functor ((<&>))
|
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 (
|
import Language.Haskell.TH.Datatype (
|
||||||
ConstructorInfo (constructorFields, constructorName),
|
ConstructorInfo (constructorFields, constructorName),
|
||||||
DatatypeInfo (datatypeCons),
|
DatatypeInfo (datatypeCons),
|
||||||
@ -114,6 +114,34 @@ mkCoerce tv = do
|
|||||||
Plain tn -> ConT $ coerce tn
|
Plain tn -> ConT $ coerce tn
|
||||||
List tn -> AppT ListT (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 :: String -> Q Pat
|
||||||
mkPat = pure . VarP . mkName
|
mkPat = pure . VarP . mkName
|
||||||
|
|
||||||
@ -125,12 +153,12 @@ mkCon = pure . ConE . coerce
|
|||||||
|
|
||||||
mkCaseConstr :: TypeVariant -> SamplerGen Exp
|
mkCaseConstr :: TypeVariant -> SamplerGen Exp
|
||||||
mkCaseConstr = \case
|
mkCaseConstr = \case
|
||||||
Plain tn -> do
|
tv@(Plain tn) -> do
|
||||||
typInfo <- lift $ reifyDatatype (coerce tn)
|
typInfo <- lift $ reifyDatatype (coerce tn)
|
||||||
let constrInfo = datatypeCons typInfo
|
let constrInfo = datatypeCons typInfo
|
||||||
constrGroup = zip constrInfo [0 :: Integer ..]
|
constrGroup = zip constrInfo [0 :: Integer ..]
|
||||||
|
|
||||||
caseMatches <- mapM (mkCaseMatch tn) constrGroup
|
caseMatches <- mapM (mkCaseMatch tv) constrGroup
|
||||||
pure $ LamCaseE caseMatches
|
pure $ LamCaseE caseMatches
|
||||||
tv -> do
|
tv -> do
|
||||||
coerceExp <- mkCoerce tv
|
coerceExp <- mkCoerce tv
|
||||||
@ -144,10 +172,10 @@ mkCaseConstr = \case
|
|||||||
pure ($(pure coerceExp) (x : xs), w + ws)
|
pure ($(pure coerceExp) (x : xs), w + ws)
|
||||||
|]
|
|]
|
||||||
|
|
||||||
mkCaseMatch :: TypeName -> (ConstructorInfo, Integer) -> SamplerGen Match
|
mkCaseMatch :: TypeVariant -> (ConstructorInfo, Integer) -> SamplerGen Match
|
||||||
mkCaseMatch typ (constr, idx) = do
|
mkCaseMatch tv (constr, idx) = do
|
||||||
let n' = LitP $ IntegerL idx
|
let n' = LitP $ IntegerL idx
|
||||||
conExpr <- mkConExpr typ constr
|
conExpr <- mkConExpr tv constr
|
||||||
pure $ Match n' (NormalB conExpr) []
|
pure $ Match n' (NormalB conExpr) []
|
||||||
|
|
||||||
data ArgExp = ArgExp
|
data ArgExp = ArgExp
|
||||||
@ -209,24 +237,23 @@ mkArgExpr constr = do
|
|||||||
name <- lift $ newName s
|
name <- lift $ newName s
|
||||||
pure (VarP name, VarE name)
|
pure (VarP name, VarE name)
|
||||||
|
|
||||||
mkConExpr :: TypeName -> ConstructorInfo -> SamplerGen Exp
|
mkConExpr :: TypeVariant -> ConstructorInfo -> SamplerGen Exp
|
||||||
mkConExpr typ constr = do
|
mkConExpr tv constr = do
|
||||||
ArgExp {..} <- mkArgExpr constr
|
ArgExp {..} <- mkArgExpr constr
|
||||||
let constrName = MkConstructorName (constructorName constr)
|
let constrName = MkConstructorName (constructorName constr)
|
||||||
constrWeight <- getWeight $ coerce constrName
|
constrWeight <- getWeight $ coerce constrName
|
||||||
|
|
||||||
constrExp <- lift $ mkCon 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)|]
|
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])
|
pure $ DoE Nothing (stmts <> [NoBindS pureExp])
|
||||||
|
|
||||||
mkGuard :: SamplerGen Exp
|
mkGuard :: SamplerGen Exp
|
||||||
mkGuard = lift [|guard ($(mkVar "ub") > 0)|]
|
mkGuard = lift [|guard ($(mkVar "ub") >= 0)|]
|
||||||
|
|
||||||
mkChoice :: TypeVariant -> SamplerGen Exp
|
mkChoice :: TypeVariant -> SamplerGen Exp
|
||||||
mkChoice typ = do
|
mkChoice typ = do
|
||||||
|
81
package.yaml
81
package.yaml
@ -83,86 +83,6 @@ internal-libraries:
|
|||||||
ScopedTypeVariables
|
ScopedTypeVariables
|
||||||
Rank2Types
|
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:
|
tests:
|
||||||
generic-boltzmann-brain-test:
|
generic-boltzmann-brain-test:
|
||||||
main: Spec.hs
|
main: Spec.hs
|
||||||
@ -177,6 +97,7 @@ tests:
|
|||||||
- -Wredundant-constraints
|
- -Wredundant-constraints
|
||||||
- -Wno-name-shadowing
|
- -Wno-name-shadowing
|
||||||
- -fwarn-missing-signatures
|
- -fwarn-missing-signatures
|
||||||
|
- -ddump-splices
|
||||||
dependencies:
|
dependencies:
|
||||||
- generic-boltzmann-brain-internal
|
- generic-boltzmann-brain-internal
|
||||||
- generic-boltzmann-brain
|
- 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
|
-- * Boltzmann samplers
|
||||||
BoltzmannSampler (..),
|
BoltzmannSampler (..),
|
||||||
|
LowerBound (..),
|
||||||
|
UpperBound (..),
|
||||||
rejectionSampler,
|
rejectionSampler,
|
||||||
toleranceRejectionSampler,
|
toleranceRejectionSampler,
|
||||||
mkBoltzmannSampler,
|
mkBoltzmannSampler,
|
||||||
mkDefBoltzmannSampler,
|
mkDefBoltzmannSampler,
|
||||||
hoistBoltzmannSampler,
|
hoistRejectionSampler,
|
||||||
|
hoistToleranceRejectionSampler,
|
||||||
|
|
||||||
-- * Buffon machines
|
-- * Buffon machines
|
||||||
BuffonMachine,
|
BuffonMachine,
|
||||||
@ -34,7 +37,10 @@ import Data.Boltzmann.System.TH (
|
|||||||
|
|
||||||
import Data.Boltzmann.Sampler (
|
import Data.Boltzmann.Sampler (
|
||||||
BoltzmannSampler (..),
|
BoltzmannSampler (..),
|
||||||
hoistBoltzmannSampler,
|
LowerBound (..),
|
||||||
|
UpperBound (..),
|
||||||
|
hoistRejectionSampler,
|
||||||
|
hoistToleranceRejectionSampler,
|
||||||
rejectionSampler,
|
rejectionSampler,
|
||||||
toleranceRejectionSampler,
|
toleranceRejectionSampler,
|
||||||
)
|
)
|
||||||
|
@ -1,5 +1,6 @@
|
|||||||
import Test.Tasty (TestTree, defaultMain, testGroup)
|
import Test.Tasty (TestTree, defaultMain, testGroup)
|
||||||
import qualified Test.Unit.BuffonMachine as BuffonMachine
|
import qualified Test.Unit.BuffonMachine as BuffonMachine
|
||||||
|
import qualified Test.Unit.Sampler as Sampler
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain tests
|
main = defaultMain tests
|
||||||
@ -9,4 +10,6 @@ tests = testGroup "Unit tests" unitTests
|
|||||||
|
|
||||||
unitTests :: [TestTree]
|
unitTests :: [TestTree]
|
||||||
unitTests =
|
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