mirror of
https://github.com/maciej-bendkowski/generic-boltzmann-brain.git
synced 2024-10-26 21:34:45 +03:00
Revert the idea of specifiable types
This commit is contained in:
Maciej Bendkowski
parent
f9507a181b
commit
0a8d042eb3
@ -1,50 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module BinTree where
|
||||
|
||||
import Control.DeepSeq (NFData)
|
||||
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
|
||||
import Data.Boltzmann.Sampler.TH (mkSampler)
|
||||
import Data.Boltzmann.Specifiable (
|
||||
Specifiable,
|
||||
)
|
||||
import Data.Boltzmann.Specification (
|
||||
SystemSpec,
|
||||
specification,
|
||||
withSystem,
|
||||
withWeights,
|
||||
(==>),
|
||||
)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
data BinTree
|
||||
= Leaf
|
||||
| Node BinTree BinTree
|
||||
deriving (Show, Generic, Specifiable)
|
||||
|
||||
binTreeSysSpec :: SystemSpec
|
||||
binTreeSysSpec =
|
||||
(undefined :: BinTree, 1_000)
|
||||
`withSystem` [ specification
|
||||
(undefined :: BinTree)
|
||||
( withWeights
|
||||
['Leaf ==> 0]
|
||||
)
|
||||
]
|
||||
|
||||
mediumBinTreeSysSpec :: SystemSpec
|
||||
mediumBinTreeSysSpec =
|
||||
(undefined :: BinTree, 10_000)
|
||||
`withSystem` [ specification
|
||||
(undefined :: BinTree)
|
||||
( withWeights
|
||||
['Leaf ==> 0]
|
||||
)
|
||||
]
|
||||
|
||||
$(mkSampler ''BinTree)
|
||||
|
||||
instance NFData BinTree
|
||||
@ -1,18 +0,0 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
|
||||
import BinTree (BinTree)
|
||||
import BinTreeSampler (mediumRandomBinTreeListIO, randomBinTreeListIO)
|
||||
import Criterion.Main (bench, defaultMain, nfIO)
|
||||
|
||||
sampler :: Int -> IO [BinTree]
|
||||
sampler = randomBinTreeListIO 800 1200
|
||||
|
||||
mediumSampler :: Int -> IO [BinTree]
|
||||
mediumSampler = mediumRandomBinTreeListIO 8_000 12_000
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
defaultMain
|
||||
[ bench "100 binary trees" $ nfIO (sampler 100)
|
||||
, bench "100 large binary trees" $ nfIO (mediumSampler 100)
|
||||
]
|
||||
@ -1,19 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module BinTreeSampler (randomBinTreeListIO, mediumRandomBinTreeListIO) where
|
||||
|
||||
import BinTree (BinTree, binTreeSysSpec, mediumBinTreeSysSpec)
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Boltzmann.Oracle (mkSpecSampler)
|
||||
import Data.Boltzmann.Sampler (rejectionSampler)
|
||||
import Data.BuffonMachine (runIO)
|
||||
|
||||
randomBinTreeListIO :: Int -> Int -> Int -> IO [BinTree]
|
||||
randomBinTreeListIO lb ub n =
|
||||
runIO $
|
||||
replicateM n (rejectionSampler $(mkSpecSampler binTreeSysSpec) lb ub)
|
||||
|
||||
mediumRandomBinTreeListIO :: Int -> Int -> Int -> IO [BinTree]
|
||||
mediumRandomBinTreeListIO lb ub n =
|
||||
runIO $
|
||||
replicateM n (rejectionSampler $(mkSpecSampler mediumBinTreeSysSpec) lb ub)
|
||||
@ -38,7 +38,7 @@ library
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
src
|
||||
ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, containers >=0.6.4
|
||||
@ -61,7 +61,7 @@ executable binTreeProfile
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
profile/BinTree
|
||||
ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
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:
|
||||
base >=4.7 && <5
|
||||
, containers >=0.6.4
|
||||
@ -81,22 +81,11 @@ test-suite generic-boltzmann-brain-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Data.Samplers.BinTree
|
||||
Data.Samplers.Lambda
|
||||
Data.Samplers.Tree
|
||||
Data.Types.BinTree
|
||||
Data.Types.Custom
|
||||
Data.Types.Lambda
|
||||
Data.Types.Tree
|
||||
Test.Unit.BuffonMachine
|
||||
Test.Unit.Sampler
|
||||
Test.Unit.Specifiable
|
||||
Test.Unit.Specification
|
||||
Test.Unit.Utils
|
||||
Test.Unit.Samplable
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
ghc-options: -O2 -Wall -Wcompat -Wmissing-export-lists -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures
|
||||
build-depends:
|
||||
QuickCheck >=2.14.2
|
||||
, base >=4.7 && <5
|
||||
@ -115,30 +104,3 @@ test-suite generic-boltzmann-brain-test
|
||||
, transformers >=0.5.6
|
||||
, vector >=0.12.3.1
|
||||
default-language: Haskell2010
|
||||
|
||||
benchmark binTree
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: BinTreeBenchmark.hs
|
||||
other-modules:
|
||||
BinTree
|
||||
BinTreeSampler
|
||||
Paths_generic_boltzmann_brain
|
||||
hs-source-dirs:
|
||||
benchmark/BinTree
|
||||
ghc-options: -O2 -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wno-name-shadowing -fwarn-missing-signatures -ddump-splices
|
||||
build-depends:
|
||||
base >=4.7 && <5
|
||||
, containers >=0.6.4
|
||||
, criterion >=1.5.12.0
|
||||
, deepseq >=1.4.5.0
|
||||
, generic-boltzmann-brain
|
||||
, mtl >=2.2.2
|
||||
, paganini-hs >=0.3.0.0
|
||||
, random >=1.2.0
|
||||
, 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
|
||||
|
||||
8
hie.yaml
8
hie.yaml
@ -1,10 +1,2 @@
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: "generic-boltzmann-brain:lib"
|
||||
|
||||
- path: "./benchmark"
|
||||
component: "generic-boltzmann-brain:exe:generic-boltzmann-brain-benchmark"
|
||||
|
||||
- path: "./test"
|
||||
component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"
|
||||
|
||||
24
package.yaml
24
package.yaml
@ -37,12 +37,12 @@ library:
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Wmissing-export-lists
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wno-name-shadowing
|
||||
- -fwarn-missing-signatures
|
||||
- -ddump-splices
|
||||
|
||||
executables:
|
||||
binTreeProfile:
|
||||
@ -52,6 +52,7 @@ executables:
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Wmissing-export-lists
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
@ -61,25 +62,6 @@ executables:
|
||||
dependencies:
|
||||
- generic-boltzmann-brain
|
||||
|
||||
benchmarks:
|
||||
binTree:
|
||||
main: BinTreeBenchmark.hs
|
||||
source-dirs: benchmark/BinTree
|
||||
ghc-options:
|
||||
- -O2
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wredundant-constraints
|
||||
- -Wno-name-shadowing
|
||||
- -fwarn-missing-signatures
|
||||
- -ddump-splices
|
||||
dependencies:
|
||||
- generic-boltzmann-brain
|
||||
- criterion >= 1.5.12.0
|
||||
- deepseq >= 1.4.5.0
|
||||
|
||||
tests:
|
||||
generic-boltzmann-brain-test:
|
||||
main: Spec.hs
|
||||
@ -88,12 +70,12 @@ tests:
|
||||
- -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
|
||||
- tasty >= 1.4.2
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Data.Samplers.BinTree (randomBinTreeIO) where
|
||||
|
||||
import Data.Boltzmann.Oracle (mkSpecSampler)
|
||||
import Data.Boltzmann.Sampler (rejectionSamplerIO)
|
||||
import Data.Types.BinTree (BinTree, binTreeSysSpec)
|
||||
|
||||
randomBinTreeIO :: Int -> Int -> IO BinTree
|
||||
randomBinTreeIO = rejectionSamplerIO $(mkSpecSampler binTreeSysSpec)
|
||||
@ -1,13 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Data.Samplers.Lambda (randomLambdaIO, randomLambdaListIO) where
|
||||
|
||||
import Data.Boltzmann.Oracle (mkSpecSampler)
|
||||
import Data.Boltzmann.Sampler (rejectionSamplerIO)
|
||||
import Data.Types.Lambda (Lambda, lambdaListSysSpec, lambdaSysSpec)
|
||||
|
||||
randomLambdaIO :: Int -> Int -> IO Lambda
|
||||
randomLambdaIO = rejectionSamplerIO $(mkSpecSampler lambdaSysSpec)
|
||||
|
||||
randomLambdaListIO :: Int -> Int -> IO [Lambda]
|
||||
randomLambdaListIO = rejectionSamplerIO $(mkSpecSampler lambdaListSysSpec)
|
||||
@ -1,10 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Data.Samplers.Tree (randomTreeIO) where
|
||||
|
||||
import Data.Boltzmann.Oracle (mkSpecSampler)
|
||||
import Data.Boltzmann.Sampler (rejectionSamplerIO)
|
||||
import Data.Types.Tree (Tree, treeSysSpec)
|
||||
|
||||
randomTreeIO :: Int -> Int -> IO Tree
|
||||
randomTreeIO = rejectionSamplerIO $(mkSpecSampler treeSysSpec)
|
||||
@ -1,53 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Data.Types.BinTree where
|
||||
|
||||
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
|
||||
import Data.Boltzmann.Sampler.TH (mkSampler)
|
||||
import Data.Boltzmann.Specifiable (
|
||||
Cons (..),
|
||||
Specifiable,
|
||||
SpecifiableType (..),
|
||||
TypeDef,
|
||||
)
|
||||
import Data.Boltzmann.Specification (
|
||||
SystemSpec,
|
||||
specification,
|
||||
withSystem,
|
||||
withWeights,
|
||||
(==>),
|
||||
)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.Unit.Utils (Size (..))
|
||||
|
||||
data BinTree
|
||||
= Leaf
|
||||
| Node BinTree BinTree
|
||||
deriving (Show, Generic, Specifiable)
|
||||
|
||||
instance Size BinTree where
|
||||
size Leaf = 0
|
||||
size (Node ln rn) = 1 + size ln + size rn
|
||||
|
||||
binTree :: SpecifiableType
|
||||
binTree = SpecifiableType (undefined :: BinTree)
|
||||
|
||||
expectedTypeDef :: TypeDef
|
||||
expectedTypeDef =
|
||||
[ Cons {name = "Data.Types.BinTree.Leaf", args = []}
|
||||
, Cons {name = "Data.Types.BinTree.Node", args = [binTree, binTree]}
|
||||
]
|
||||
|
||||
binTreeSysSpec :: SystemSpec
|
||||
binTreeSysSpec =
|
||||
(undefined :: BinTree, 4000)
|
||||
`withSystem` [ specification
|
||||
(undefined :: BinTree)
|
||||
( withWeights
|
||||
['Leaf ==> 0]
|
||||
)
|
||||
]
|
||||
|
||||
$(mkSampler ''BinTree)
|
||||
@ -1,62 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
module Data.Types.Custom where
|
||||
|
||||
import Data.Boltzmann.Specifiable (
|
||||
Specifiable,
|
||||
SpecifiableType (..),
|
||||
)
|
||||
import Data.Boltzmann.Specification (
|
||||
SystemSpec,
|
||||
specification,
|
||||
withFrequencies,
|
||||
withSystem,
|
||||
withWeights,
|
||||
(==>),
|
||||
)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.Unit.Utils (Size (..))
|
||||
|
||||
data Custom
|
||||
= ConsA Custom
|
||||
| ConsB [Custom']
|
||||
deriving (Show, Generic, Specifiable)
|
||||
|
||||
newtype Custom'
|
||||
= ConsC Custom
|
||||
deriving (Show, Generic, Specifiable)
|
||||
|
||||
instance Size Custom where
|
||||
size (ConsA x) = 1 + size x
|
||||
size (ConsB x) = 1 + size x
|
||||
|
||||
instance Size Custom' where
|
||||
size (ConsC x) = 1 + size x
|
||||
|
||||
custom :: SpecifiableType
|
||||
custom = SpecifiableType (undefined :: Custom)
|
||||
|
||||
custom' :: SpecifiableType
|
||||
custom' = SpecifiableType (undefined :: Custom')
|
||||
|
||||
customList' :: SpecifiableType
|
||||
customList' = SpecifiableType (undefined :: [Custom'])
|
||||
|
||||
customSysSpec :: SystemSpec
|
||||
customSysSpec =
|
||||
(undefined :: Custom, 10000)
|
||||
`withSystem` [ specification
|
||||
(undefined :: Custom)
|
||||
( withWeights
|
||||
[ 'ConsA ==> 2
|
||||
, 'ConsB ==> 3
|
||||
, 'ConsC ==> 4
|
||||
]
|
||||
. withFrequencies
|
||||
[ 'ConsA ==> 800
|
||||
, 'ConsB ==> 900
|
||||
]
|
||||
)
|
||||
]
|
||||
@ -1,87 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Data.Types.Lambda where
|
||||
|
||||
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
|
||||
import Data.Boltzmann.Sampler.TH (mkSampler)
|
||||
import Data.Boltzmann.Specifiable (
|
||||
Cons (..),
|
||||
Specifiable,
|
||||
SpecifiableType (..),
|
||||
TypeDef,
|
||||
)
|
||||
import Data.Boltzmann.Specification (
|
||||
SystemSpec,
|
||||
specification,
|
||||
withFrequencies,
|
||||
withSystem,
|
||||
withWeights,
|
||||
(==>),
|
||||
)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.Unit.Utils (Size (..))
|
||||
|
||||
data DeBruijn = S DeBruijn | Z
|
||||
deriving (Generic, Show, Specifiable)
|
||||
|
||||
instance Size DeBruijn where
|
||||
size (S n) = 1 + size n
|
||||
size Z = 1
|
||||
|
||||
data Lambda
|
||||
= Abs Lambda
|
||||
| App Lambda Lambda
|
||||
| Index DeBruijn
|
||||
deriving (Generic, Show, Specifiable)
|
||||
|
||||
instance Size Lambda where
|
||||
size (Abs t) = 1 + size t
|
||||
size (App lt rt) = 1 + size lt + size rt
|
||||
size (Index n) = size n
|
||||
|
||||
deBruijn :: SpecifiableType
|
||||
deBruijn = SpecifiableType (undefined :: DeBruijn)
|
||||
|
||||
lambda :: SpecifiableType
|
||||
lambda = SpecifiableType (undefined :: Lambda)
|
||||
|
||||
expectedDeBruijnTypeDef :: TypeDef
|
||||
expectedDeBruijnTypeDef =
|
||||
[ Cons {name = "Data.Types.Lambda.S", args = [deBruijn]}
|
||||
, Cons {name = "Data.Types.Lambda.Z", args = []}
|
||||
]
|
||||
|
||||
expectedLambdaTypeDef :: TypeDef
|
||||
expectedLambdaTypeDef =
|
||||
[ Cons {name = "Data.Types.Lambda.Abs", args = [lambda]}
|
||||
, Cons {name = "Data.Types.Lambda.App", args = [lambda, lambda]}
|
||||
, Cons {name = "Data.Types.Lambda.Index", args = [deBruijn]}
|
||||
]
|
||||
|
||||
lambdaSysSpec :: SystemSpec
|
||||
lambdaSysSpec =
|
||||
(undefined :: Lambda, 1000)
|
||||
`withSystem` [ specification
|
||||
(undefined :: Lambda)
|
||||
( withWeights
|
||||
['Index ==> 0]
|
||||
. withFrequencies
|
||||
['Abs ==> 330]
|
||||
)
|
||||
]
|
||||
|
||||
lambdaListSysSpec :: SystemSpec
|
||||
lambdaListSysSpec =
|
||||
(undefined :: [Lambda], 1000)
|
||||
`withSystem` [ specification
|
||||
(undefined :: [Lambda])
|
||||
( withWeights
|
||||
['Index ==> 0]
|
||||
)
|
||||
]
|
||||
|
||||
$(mkSampler ''DeBruijn)
|
||||
$(mkSampler ''Lambda)
|
||||
@ -1,44 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Data.Types.Tree where
|
||||
|
||||
import Data.Boltzmann.Sampler (BoltzmannSampler (..))
|
||||
import Data.Boltzmann.Sampler.TH (mkSampler)
|
||||
import Data.Boltzmann.Specifiable (
|
||||
Cons (..),
|
||||
Specifiable,
|
||||
SpecifiableType (..),
|
||||
TypeDef,
|
||||
)
|
||||
import Data.Boltzmann.Specification (
|
||||
SystemSpec,
|
||||
defaultTypeSpec,
|
||||
withSystem,
|
||||
)
|
||||
import GHC.Generics (Generic)
|
||||
import Test.Unit.Utils (Size (..))
|
||||
|
||||
newtype Tree = Node [Tree]
|
||||
deriving (Show, Generic, Specifiable)
|
||||
|
||||
treeList :: SpecifiableType
|
||||
treeList = SpecifiableType (undefined :: [Tree])
|
||||
|
||||
tree :: SpecifiableType
|
||||
tree = SpecifiableType (undefined :: Tree)
|
||||
|
||||
expectedTypeDef :: TypeDef
|
||||
expectedTypeDef =
|
||||
[Cons {name = "Data.Types.Tree.Node", args = [treeList]}]
|
||||
|
||||
instance Size Tree where
|
||||
size (Node xs) = 1 + size xs
|
||||
|
||||
treeSysSpec :: SystemSpec
|
||||
treeSysSpec =
|
||||
(undefined :: Tree, 1000)
|
||||
`withSystem` [defaultTypeSpec (undefined :: Tree)]
|
||||
|
||||
$(mkSampler ''Tree)
|
||||
11
test/Spec.hs
11
test/Spec.hs
@ -1,8 +1,5 @@
|
||||
import Test.Tasty (TestTree, defaultMain, testGroup)
|
||||
import qualified Test.Unit.BuffonMachine as BuffonMachine
|
||||
import qualified Test.Unit.Sampler as Sampler
|
||||
import qualified Test.Unit.Specifiable as Specifiable
|
||||
import qualified Test.Unit.Specification as Specification
|
||||
import qualified Test.Unit.Samplable as Samplable
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain tests
|
||||
@ -12,8 +9,4 @@ tests = testGroup "Unit tests" unitTests
|
||||
|
||||
unitTests :: [TestTree]
|
||||
unitTests =
|
||||
[ Specifiable.unitTests
|
||||
, Specification.unitTests
|
||||
, BuffonMachine.unitTests
|
||||
, Sampler.unitTests
|
||||
]
|
||||
[Samplable.unitTests]
|
||||
|
||||
@ -1,9 +1,10 @@
|
||||
module Test.Unit.BuffonMachine (unitTests) where
|
||||
module Test.Unit.Samplable (unitTests) where
|
||||
|
||||
import Control.Monad (replicateM)
|
||||
import Data.BuffonMachine (choice, runIO)
|
||||
import Data.Boltzmann.Samplable (Distribution (..), choice)
|
||||
import Data.BuffonMachine (runIO)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Vector (Vector, fromList)
|
||||
import Data.Vector (fromList)
|
||||
import Test.Tasty (
|
||||
TestTree,
|
||||
testGroup,
|
||||
@ -44,21 +45,21 @@ choiceTests =
|
||||
]
|
||||
|
||||
-- [1/2, 1/2]
|
||||
distributionA :: Vector Int
|
||||
distributionA = fromList [2, 3, -2, -1]
|
||||
distributionA :: Distribution a
|
||||
distributionA = Distribution $ fromList [2, 3, -2, -1]
|
||||
|
||||
-- [1/3, 1/3, 1/3]
|
||||
distributionB :: Vector Int
|
||||
distributionB = fromList [2, 138, 4, 137, 6, 133, 8, 132, 10, 128, 12, 127, 14, 123, 16, 122, 18, 118, 20, 117, 22, 113, 24, 112, 26, 108, 28, 107, 30, 103, 32, 102, 34, 98, 36, 97, 38, 93, 40, 92, 42, 88, 44, 87, 46, 83, 48, 82, 50, 78, 52, 77, 54, 73, 56, 72, 58, 68, 60, 67, 62, 66, 64, 65, -2, -1, -3, -3, 70, 71, -2, -1, -3, 75, 76, -2, -1, -3, 80, 81, -2, -1, -3, 85, 86, -2, -1, -3, 90, 91, -2, -1, -3, 95, 96, -2, -1, -3, 100, 101, -2, -1, -3, 105, 106, -2, -1, -3, 110, 111, -2, -1, -3, 115, 116, -2, -1, -3, 120, 121, -2, -1, -3, 125, 126, -2, -1, -3, 130, 131, -2, -1, -3, 135, 136, -2, -1, -3, 140, 141, -2, -1]
|
||||
distributionB :: Distribution a
|
||||
distributionB = Distribution $ fromList [2, 138, 4, 137, 6, 133, 8, 132, 10, 128, 12, 127, 14, 123, 16, 122, 18, 118, 20, 117, 22, 113, 24, 112, 26, 108, 28, 107, 30, 103, 32, 102, 34, 98, 36, 97, 38, 93, 40, 92, 42, 88, 44, 87, 46, 83, 48, 82, 50, 78, 52, 77, 54, 73, 56, 72, 58, 68, 60, 67, 62, 66, 64, 65, -2, -1, -3, -3, 70, 71, -2, -1, -3, 75, 76, -2, -1, -3, 80, 81, -2, -1, -3, 85, 86, -2, -1, -3, 90, 91, -2, -1, -3, 95, 96, -2, -1, -3, 100, 101, -2, -1, -3, 105, 106, -2, -1, -3, 110, 111, -2, -1, -3, 115, 116, -2, -1, -3, 120, 121, -2, -1, -3, 125, 126, -2, -1, -3, 130, 131, -2, -1, -3, 135, 136, -2, -1, -3, 140, 141, -2, -1]
|
||||
|
||||
-- [1/7, 4/7, 2/7]
|
||||
distributionC :: Vector Int
|
||||
distributionC = fromList [2, 96, 4, 95, 6, 94, 8, 93, 10, 92, 12, 91, 14, 90, 16, 89, 18, 88, 20, 87, 22, 86, 24, 85, 26, 84, 28, 83, 30, 82, 32, 81, 34, 80, 36, 79, 38, 78, 40, 77, 42, 76, 44, 75, 46, 74, 48, 73, 50, 72, 52, 71, 54, 70, 56, 69, 58, 68, 60, 67, 62, 66, 64, 65, -3, -1, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2]
|
||||
distributionC :: Distribution a
|
||||
distributionC = Distribution $ fromList [2, 96, 4, 95, 6, 94, 8, 93, 10, 92, 12, 91, 14, 90, 16, 89, 18, 88, 20, 87, 22, 86, 24, 85, 26, 84, 28, 83, 30, 82, 32, 81, 34, 80, 36, 79, 38, 78, 40, 77, 42, 76, 44, 75, 46, 74, 48, 73, 50, 72, 52, 71, 54, 70, 56, 69, 58, 68, 60, 67, 62, 66, 64, 65, -3, -1, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2, -1, -3, -2]
|
||||
|
||||
distributionD :: Vector Int
|
||||
distributionD = fromList []
|
||||
distributionD :: Distribution a
|
||||
distributionD = Distribution $ fromList []
|
||||
|
||||
choiceTest :: Vector Int -> Int -> IO [(Int, Double)]
|
||||
choiceTest :: Distribution a -> Int -> IO [(Int, Double)]
|
||||
choiceTest dist n = runIO $ do
|
||||
sam <- replicateM n (choice dist)
|
||||
let groups = frequency sam
|
||||
@ -1,52 +0,0 @@
|
||||
module Test.Unit.Sampler (unitTests) where
|
||||
|
||||
import Data.Boltzmann.Sampler ()
|
||||
import Data.Samplers.BinTree
|
||||
import Data.Samplers.Lambda
|
||||
import Data.Samplers.Tree
|
||||
import Test.QuickCheck.Monadic
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.QuickCheck
|
||||
import Test.Unit.Utils (size)
|
||||
|
||||
unitTests :: TestTree
|
||||
unitTests =
|
||||
testGroup
|
||||
"Sampler"
|
||||
sampleSizeTests
|
||||
|
||||
sampleSizeTests :: [TestTree]
|
||||
sampleSizeTests =
|
||||
[ testProperty "Lambda sampler respects size constraints for sizes around the mean of 1,000" lambdaSamplerSizeProp
|
||||
, testProperty "BinTree sampler respects size constraints for sizes around the mean of 1,000" binTreeSamplerSizeProp
|
||||
, testProperty "Tree sampler respects size constraints for sizes around the mean of 1,000" treeSamplerSizeProp
|
||||
, testProperty "Lambda list sampler respects size constraints for sizes around the mean of 1,000" lambdaListSamplerSizeProp
|
||||
]
|
||||
|
||||
lambdaSamplerSizeProp :: Positive Int -> Property
|
||||
lambdaSamplerSizeProp (Positive x) = monadicIO $ do
|
||||
let (lb, ub) = (800 + x, 1200 + x)
|
||||
term <- run $ randomLambdaIO lb ub
|
||||
let n = size term
|
||||
assert $ lb <= n && n <= ub
|
||||
|
||||
lambdaListSamplerSizeProp :: Positive Int -> Property
|
||||
lambdaListSamplerSizeProp (Positive x) = monadicIO $ do
|
||||
let (lb, ub) = (800 + x, 1200 + x)
|
||||
terms <- run $ randomLambdaListIO lb ub
|
||||
let n = size terms
|
||||
assert $ lb <= n && n <= ub
|
||||
|
||||
binTreeSamplerSizeProp :: Positive Int -> Property
|
||||
binTreeSamplerSizeProp (Positive x) = monadicIO $ do
|
||||
let (lb, ub) = (800 + x, 1200 + x)
|
||||
tree <- run $ randomBinTreeIO lb ub
|
||||
let n = size tree
|
||||
assert $ lb <= n && n <= ub
|
||||
|
||||
treeSamplerSizeProp :: Positive Int -> Property
|
||||
treeSamplerSizeProp (Positive x) = monadicIO $ do
|
||||
let (lb, ub) = (800 + x, 1200 + x)
|
||||
tree <- run $ randomTreeIO lb ub
|
||||
let n = size tree
|
||||
assert $ lb <= n && n <= ub
|
||||
@ -1,49 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
module Test.Unit.Specifiable (unitTests) where
|
||||
|
||||
import Data.Boltzmann.Specifiable (typeName, typedef)
|
||||
import Data.Types.BinTree (BinTree)
|
||||
import qualified Data.Types.BinTree as BinTree
|
||||
import Data.Types.Lambda (DeBruijn, Lambda)
|
||||
import qualified Data.Types.Lambda as Lambda
|
||||
import Data.Types.Tree (Tree)
|
||||
import qualified Data.Types.Tree as Tree
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit (testCase, (@=?))
|
||||
|
||||
unitTests :: TestTree
|
||||
unitTests =
|
||||
testGroup
|
||||
"Specifiable unit tests"
|
||||
[typeDefinitionTests, typeNameTests]
|
||||
|
||||
typeDefinitionTests :: TestTree
|
||||
typeDefinitionTests =
|
||||
testGroup
|
||||
"Type definition unit tests"
|
||||
[ testCase "BinTree has a correct type definition" $
|
||||
BinTree.expectedTypeDef @=? typedef (undefined :: BinTree)
|
||||
, testCase "Tree has a correct type definition" $
|
||||
Tree.expectedTypeDef @=? typedef (undefined :: Tree)
|
||||
, testCase "DeBruijn has a correct type definition" $
|
||||
Lambda.expectedDeBruijnTypeDef @=? typedef (undefined :: DeBruijn)
|
||||
, testCase "Lambda has a correct type definition" $
|
||||
Lambda.expectedLambdaTypeDef @=? typedef (undefined :: Lambda)
|
||||
]
|
||||
|
||||
typeNameTests :: TestTree
|
||||
typeNameTests =
|
||||
testGroup
|
||||
"Type name unit tests"
|
||||
[ testCase "BinTree's type name is correct" $
|
||||
show ''BinTree @=? typeName (undefined :: BinTree)
|
||||
, testCase "Tree's type name is correct" $
|
||||
show ''Tree @=? typeName (undefined :: Tree)
|
||||
, testCase "Lambda's type name is correct" $
|
||||
show ''Lambda @=? typeName (undefined :: Lambda)
|
||||
, testCase "[DeBruijn]'s type name is correct" $
|
||||
"[Data.Types.Lambda.DeBruijn]" @=? typeName (undefined :: [DeBruijn])
|
||||
, testCase "[[DeBruijn]]'s type name is correct" $
|
||||
"[[Data.Types.Lambda.DeBruijn]]" @=? typeName (undefined :: [[DeBruijn]])
|
||||
]
|
||||
@ -1,136 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
|
||||
module Test.Unit.Specification (
|
||||
unitTests,
|
||||
) where
|
||||
|
||||
import qualified Data.Boltzmann.Specification as Specification
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Types.BinTree (BinTree)
|
||||
import qualified Data.Types.BinTree as BinTree
|
||||
import qualified Data.Types.Custom as Custom
|
||||
import Data.Types.Lambda (Lambda)
|
||||
import qualified Data.Types.Lambda as Lambda
|
||||
import qualified Data.Types.Tree as Tree
|
||||
import Test.Tasty (
|
||||
TestTree,
|
||||
testGroup,
|
||||
)
|
||||
import Test.Tasty.HUnit (
|
||||
testCase,
|
||||
(@=?),
|
||||
)
|
||||
|
||||
unitTests :: TestTree
|
||||
unitTests =
|
||||
testGroup
|
||||
"Specification unit tests"
|
||||
[typeSpecTests, collectTypesTests, constructorFrequenciesTests, getWeightTests, getFrequencyTests]
|
||||
|
||||
collectTypesTests :: TestTree
|
||||
collectTypesTests =
|
||||
testGroup
|
||||
"Type collection unit tests"
|
||||
[ testCase "BinTree's types are collected correctly" $
|
||||
Set.singleton BinTree.binTree
|
||||
@=? Specification.collectTypes BinTree.binTreeSysSpec
|
||||
, testCase "Lambda's types are collected correctly" $
|
||||
Set.fromList [Lambda.lambda, Lambda.deBruijn]
|
||||
@=? Specification.collectTypes Lambda.lambdaSysSpec
|
||||
, testCase "Trees's types are collected correctly" $
|
||||
Set.fromList [Tree.tree, Tree.treeList]
|
||||
@=? Specification.collectTypes Tree.treeSysSpec
|
||||
, testCase "Custom's types are collected correctly" $
|
||||
Set.fromList [Custom.custom, Custom.custom', Custom.customList']
|
||||
@=? Specification.collectTypes Custom.customSysSpec
|
||||
]
|
||||
|
||||
constructorFrequenciesTests :: TestTree
|
||||
constructorFrequenciesTests =
|
||||
testGroup
|
||||
"Constructor frequency tests"
|
||||
[ testCase "BinTree's constructor frequencies are collected correctly" $
|
||||
Map.empty @=? Specification.constructorFrequencies BinTree.binTreeSysSpec
|
||||
, testCase "Lambda's constructor frequencies are collected correctly" $
|
||||
Map.fromList [("Data.Types.Lambda.Abs", 330)]
|
||||
@=? Specification.constructorFrequencies Lambda.lambdaSysSpec
|
||||
, testCase "Tree's constructor frequencies are collected correctly" $
|
||||
Map.empty @=? Specification.constructorFrequencies Tree.treeSysSpec
|
||||
, testCase "Custom's constructor frequencies are collected correctly" $
|
||||
Map.fromList [("Data.Types.Custom.ConsA", 800), ("Data.Types.Custom.ConsB", 900)]
|
||||
@=? Specification.constructorFrequencies Custom.customSysSpec
|
||||
]
|
||||
|
||||
getWeightTests :: TestTree
|
||||
getWeightTests =
|
||||
testGroup
|
||||
"Constructor weight unit tests"
|
||||
[ testCase "BinTree's constructor weights are computed correctly" $ do
|
||||
0 @=? BinTree.binTreeSysSpec `Specification.getWeight` show 'BinTree.Leaf
|
||||
1 @=? BinTree.binTreeSysSpec `Specification.getWeight` show 'BinTree.Node
|
||||
, testCase "Lambda's constructor weights are computed correctly" $ do
|
||||
0 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Index
|
||||
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Abs
|
||||
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.App
|
||||
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.S
|
||||
1 @=? Lambda.lambdaSysSpec `Specification.getWeight` show 'Lambda.Z
|
||||
, testCase "Tree's constructor weights are computed correctly" $ do
|
||||
1 @=? Tree.treeSysSpec `Specification.getWeight` show 'Tree.Node
|
||||
0 @=? Tree.treeSysSpec `Specification.getWeight` show '[]
|
||||
0 @=? Tree.treeSysSpec `Specification.getWeight` show '(:)
|
||||
, testCase "Custom's constructor weights are computed correctly" $ do
|
||||
2 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsA
|
||||
3 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsB
|
||||
4 @=? Custom.customSysSpec `Specification.getWeight` show 'Custom.ConsC
|
||||
]
|
||||
|
||||
getFrequencyTests :: TestTree
|
||||
getFrequencyTests =
|
||||
testGroup
|
||||
"Constructor frequencies unit tests"
|
||||
[ testCase "BinTree's constructor frequencies are computed correctly" $ do
|
||||
Nothing @=? BinTree.binTreeSysSpec `Specification.getFrequency` show 'BinTree.Leaf
|
||||
Nothing @=? BinTree.binTreeSysSpec `Specification.getFrequency` show 'BinTree.Node
|
||||
, testCase "Lambda's constructor frequencies are computed correctly" $ do
|
||||
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Index
|
||||
Just 330 @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Abs
|
||||
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.App
|
||||
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.S
|
||||
Nothing @=? Lambda.lambdaSysSpec `Specification.getFrequency` show 'Lambda.Z
|
||||
, testCase "Tree's constructor frequencies are computed correctly" $ do
|
||||
Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show 'Tree.Node
|
||||
Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show '[]
|
||||
Nothing @=? Tree.treeSysSpec `Specification.getFrequency` show '(:)
|
||||
, testCase "Custom's constructor frequencies are computed correctly" $ do
|
||||
Just 800 @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsA
|
||||
Just 900 @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsB
|
||||
Nothing @=? Custom.customSysSpec `Specification.getFrequency` show 'Custom.ConsC
|
||||
]
|
||||
|
||||
typeSpecTests :: TestTree
|
||||
typeSpecTests =
|
||||
testGroup
|
||||
"TypeSpec unit tests"
|
||||
[ testCase "Equal type specs are correctly identified" $ do
|
||||
True @=? a == a
|
||||
False @=? a == b
|
||||
, testCase "Type specs are correctly ordered" $ do
|
||||
True @=? a <= a
|
||||
True @=? b <= a
|
||||
False @=? a <= b
|
||||
]
|
||||
where
|
||||
a =
|
||||
Specification.TypeSpec
|
||||
{ Specification.specifiableType = undefined :: Lambda
|
||||
, Specification.weight = Map.empty
|
||||
, Specification.frequency = Map.empty
|
||||
}
|
||||
|
||||
b =
|
||||
Specification.TypeSpec
|
||||
{ Specification.specifiableType = undefined :: BinTree
|
||||
, Specification.weight = Map.empty
|
||||
, Specification.frequency = Map.empty
|
||||
}
|
||||
@ -1,7 +0,0 @@
|
||||
module Test.Unit.Utils (Size (..)) where
|
||||
|
||||
class Size a where
|
||||
size :: a -> Int
|
||||
|
||||
instance Size a => Size [a] where
|
||||
size = sum . map size
|
||||
Loading…
Reference in New Issue
Block a user