From c647de735f400f67949c14eecd8daecb9dd974e6 Mon Sep 17 00:00:00 2001 From: Maciej Bendkowski Date: Sun, 27 Mar 2022 21:01:33 +0200 Subject: [PATCH] Sampler size tests. --- generic-boltzmann-brain.cabal | 90 ++------------------------ hie.yaml | 28 +-------- internal/Data/Boltzmann/Sampler.hs | 53 ++++++++++++---- internal/Data/Boltzmann/System/TH.hs | 53 ++++++++++++---- package.yaml | 81 +----------------------- profile/BinTree/BinTree.hs | 37 ----------- profile/BinTree/BinTreeProfile.hs | 4 -- profile/Lambda/Lambda.hs | 60 ------------------ profile/Lambda/LambdaProfile.hs | 4 -- profile/Tree/Tree.hs | 28 --------- profile/Tree/TreeProfile.hs | 4 -- src/Data/Boltzmann.hs | 10 ++- test/Spec.hs | 5 +- test/Test/Samplers/BinTree.hs | 44 +++++++++++++ test/Test/Samplers/Lambda.hs | 94 ++++++++++++++++++++++++++++ test/Test/Samplers/Tree.hs | 29 +++++++++ test/Test/Unit/Sampler.hs | 30 +++++++++ 17 files changed, 297 insertions(+), 357 deletions(-) delete mode 100644 profile/BinTree/BinTree.hs delete mode 100644 profile/BinTree/BinTreeProfile.hs delete mode 100644 profile/Lambda/Lambda.hs delete mode 100644 profile/Lambda/LambdaProfile.hs delete mode 100644 profile/Tree/Tree.hs delete mode 100644 profile/Tree/TreeProfile.hs create mode 100644 test/Test/Samplers/BinTree.hs create mode 100644 test/Test/Samplers/Lambda.hs create mode 100644 test/Test/Samplers/Tree.hs create mode 100644 test/Test/Unit/Sampler.hs diff --git a/generic-boltzmann-brain.cabal b/generic-boltzmann-brain.cabal index 3875cd0..330fa54 100644 --- a/generic-boltzmann-brain.cabal +++ b/generic-boltzmann-brain.cabal @@ -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 diff --git a/hie.yaml b/hie.yaml index fbccf13..f69bbf3 100644 --- a/hie.yaml +++ b/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" diff --git a/internal/Data/Boltzmann/Sampler.hs b/internal/Data/Boltzmann/Sampler.hs index 1c9d6cf..a9b629e 100644 --- a/internal/Data/Boltzmann/Sampler.hs +++ b/internal/Data/Boltzmann/Sampler.hs @@ -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 diff --git a/internal/Data/Boltzmann/System/TH.hs b/internal/Data/Boltzmann/System/TH.hs index 26e2036..3c465ff 100644 --- a/internal/Data/Boltzmann/System/TH.hs +++ b/internal/Data/Boltzmann/System/TH.hs @@ -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 diff --git a/package.yaml b/package.yaml index d0286bf..f1ed251 100644 --- a/package.yaml +++ b/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 diff --git a/profile/BinTree/BinTree.hs b/profile/BinTree/BinTree.hs deleted file mode 100644 index 9598f0a..0000000 --- a/profile/BinTree/BinTree.hs +++ /dev/null @@ -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) diff --git a/profile/BinTree/BinTreeProfile.hs b/profile/BinTree/BinTreeProfile.hs deleted file mode 100644 index f02a1d9..0000000 --- a/profile/BinTree/BinTreeProfile.hs +++ /dev/null @@ -1,4 +0,0 @@ -import BinTree (randomBinTreeListIO) - -main :: IO () -main = randomBinTreeListIO 100 >>= print diff --git a/profile/Lambda/Lambda.hs b/profile/Lambda/Lambda.hs deleted file mode 100644 index a3f5620..0000000 --- a/profile/Lambda/Lambda.hs +++ /dev/null @@ -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) diff --git a/profile/Lambda/LambdaProfile.hs b/profile/Lambda/LambdaProfile.hs deleted file mode 100644 index 3066068..0000000 --- a/profile/Lambda/LambdaProfile.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Lambda (randomLambdaListIO) - -main :: IO () -main = randomLambdaListIO 100 >>= print diff --git a/profile/Tree/Tree.hs b/profile/Tree/Tree.hs deleted file mode 100644 index 887551a..0000000 --- a/profile/Tree/Tree.hs +++ /dev/null @@ -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 diff --git a/profile/Tree/TreeProfile.hs b/profile/Tree/TreeProfile.hs deleted file mode 100644 index 8e6df4b..0000000 --- a/profile/Tree/TreeProfile.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Tree (randomTreeListIO) - -main :: IO () -main = randomTreeListIO 100 >>= print diff --git a/src/Data/Boltzmann.hs b/src/Data/Boltzmann.hs index adb6c59..822d415 100644 --- a/src/Data/Boltzmann.hs +++ b/src/Data/Boltzmann.hs @@ -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, ) diff --git a/test/Spec.hs b/test/Spec.hs index 5d08919..fb339d7 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Test/Samplers/BinTree.hs b/test/Test/Samplers/BinTree.hs new file mode 100644 index 0000000..2ed8186 --- /dev/null +++ b/test/Test/Samplers/BinTree.hs @@ -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 [] diff --git a/test/Test/Samplers/Lambda.hs b/test/Test/Samplers/Lambda.hs new file mode 100644 index 0000000..c45e0ef --- /dev/null +++ b/test/Test/Samplers/Lambda.hs @@ -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 [] diff --git a/test/Test/Samplers/Tree.hs b/test/Test/Samplers/Tree.hs new file mode 100644 index 0000000..2365f56 --- /dev/null +++ b/test/Test/Samplers/Tree.hs @@ -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 [] diff --git a/test/Test/Unit/Sampler.hs b/test/Test/Unit/Sampler.hs new file mode 100644 index 0000000..7b99e3e --- /dev/null +++ b/test/Test/Unit/Sampler.hs @@ -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 + ]