Initial commit

2024-07-15 00:10:30 +03:00 · 2022-01-12 16:47:07 +01:00 · 2022-01-12 16:47:07 +01:00 · 83f4479808
commit 83f4479808
25 changed files with 1453 additions and 0 deletions
--- a/.gitignore
+++ b/.gitignore
@ -0,0 +1,24 @@
+dist
+dist-*
+cabal-dev
+*.o
+*.hi
+*.hie
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+.stack-work/
+cabal.project.local
+cabal.project.local~
+.HTF/
+.ghc.environment.*
+*~
--- a/30
+++ b/30
@ -0,0 +1,30 @@
+Copyright Maciej Bendkowski (c) 2022
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- a/README.md
+++ b/README.md
@ -0,0 +1 @@
+# generic-boltzmann-brain
--- a/Setup.hs
+++ b/Setup.hs
@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
--- a/generic-boltzmann-brain.cabal
+++ b/generic-boltzmann-brain.cabal
@ -0,0 +1,84 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.4.
+--
+-- see: https://github.com/sol/hpack
+
+name:           generic-boltzmann-brain
+version:        0.1.0.0
+description:    Please see the README on GitHub at <https://github.com/maciej-bendkowski/generic-boltzmann-brain#readme>
+homepage:       https://github.com/maciej-bendkowski/generic-boltzmann-brain#readme
+bug-reports:    https://github.com/maciej-bendkowski/generic-boltzmann-brain/issues
+author:         Maciej Bendkowski
+maintainer:     maciej.bendkowski@gmail.com
+copyright:      2022 Maciej Bendkowski
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/maciej-bendkowski/generic-boltzmann-brain
+
+library
+  exposed-modules:
+      Data.Boltzmann.Oracle
+      Data.Boltzmann.Sampler
+      Data.Boltzmann.Sampler.Utils
+      Data.Boltzmann.Specifiable
+      Data.Boltzmann.Specification
+      Data.BuffonMachine
+  other-modules:
+      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
+  build-depends:
+      base >=4.7 && <5
+    , containers >=0.6.4
+    , mtl >=2.2.2
+    , paganini-hs >=0.3.0.0
+    , random >=1.2.0
+    , template-haskell >=2.16.0.0
+    , th-abstraction >=0.4.3.0
+    , 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:
+      Data.Samplers.BinTree
+      Data.Samplers.Lambda
+      Data.Samplers.Tree
+      Data.Types.BinTree
+      Data.Types.Lambda
+      Data.Types.Tree
+      Test.Unit.Sampler
+      Test.Unit.Specifiable
+      Test.Unit.Utils
+      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
+  build-depends:
+      QuickCheck >=2.14.2
+    , base >=4.7 && <5
+    , containers >=0.6.4
+    , generic-boltzmann-brain
+    , mtl >=2.2.2
+    , paganini-hs >=0.3.0.0
+    , random >=1.2.0
+    , tasty >=1.4.2
+    , tasty-hunit >=0.10.0
+    , tasty-quickcheck >=0.10.0
+    , template-haskell >=2.16.0.0
+    , th-abstraction >=0.4.3.0
+    , th-lift-instances >=0.1.18
+    , transformers >=0.5.6
+    , vector >=0.12.3.1
+  default-language: Haskell2010
--- a/hie.yaml
+++ b/hie.yaml
@ -0,0 +1,7 @@
+cradle:
+  stack:
+    - path: "./src"
+      component: "generic-boltzmann-brain:lib"
+
+    - path: "./test"
+      component: "generic-boltzmann-brain:test:generic-boltzmann-brain-test"
--- a/package.yaml
+++ b/package.yaml
@ -0,0 +1,65 @@
+name:                generic-boltzmann-brain
+version:             0.1.0.0
+github:              "maciej-bendkowski/generic-boltzmann-brain"
+license:             BSD3
+author:              "Maciej Bendkowski"
+maintainer:          "maciej.bendkowski@gmail.com"
+copyright:           "2022 Maciej Bendkowski"
+
+extra-source-files:
+- README.md
+
+# Metadata used when publishing your package
+# synopsis:            Short description of your package
+# category:            Web
+
+# To avoid duplicated efforts in documentation and dealing with the
+# complications of embedding Haddock markup inside cabal files, it is
+# common to point users to the README.md file.
+description:         Please see the README on GitHub at <https://github.com/maciej-bendkowski/generic-boltzmann-brain#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- containers >= 0.6.4
+- vector >= 0.12.3.1
+- random >= 1.2.0
+- transformers >= 0.5.6
+- template-haskell >= 2.16.0.0
+- th-abstraction >= 0.4.3.0
+- th-lift-instances >= 0.1.18
+- mtl >= 2.2.2
+- paganini-hs >= 0.3.0.0
+
+library:
+  source-dirs: src
+  ghc-options:
+  - -O2
+  - -Wall
+  - -Wcompat
+  - -Wincomplete-record-updates
+  - -Wincomplete-uni-patterns
+  - -Wredundant-constraints
+  - -Wno-name-shadowing
+  - -fwarn-missing-signatures
+  - -ddump-splices
+
+tests:
+  generic-boltzmann-brain-test:
+    main:                Spec.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
+    dependencies:
+    - generic-boltzmann-brain
+    - tasty >= 1.4.2
+    - tasty-hunit >= 0.10.0
+    - tasty-quickcheck >= 0.10.0
+    - QuickCheck >= 2.14.2
--- a/src/Data/Boltzmann/Oracle.hs
+++ b/src/Data/Boltzmann/Oracle.hs
@ -0,0 +1,201 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Data.Boltzmann.Oracle
+-- Description :
+-- Copyright   : (c) Maciej Bendkowski, 2022
+-- License     : BSD3
+-- Maintainer  : maciej.bendkowski@gmail.com
+-- Stability   : experimental
+module Data.Boltzmann.Oracle
+  ( mkChoiceFun,
+    mkWeightFun,
+  )
+where
+
+import Control.Monad (replicateM)
+import Data.Boltzmann.Specifiable
+  ( Cons (args, name),
+    Specifiable (..),
+    SpecifiableType (..),
+    TypeDef,
+  )
+import Data.Boltzmann.Specification (getWeight)
+import qualified Data.Boltzmann.Specification as S
+import qualified Data.Map as Map
+import Data.Map.Strict (Map)
+import Data.Maybe (fromJust)
+import Data.Paganini
+  ( Expr,
+    FromVariable,
+    Let (Let),
+    PaganiniError,
+    Spec,
+    ddg,
+    debugPaganini,
+    tune,
+    variable,
+    variable',
+    (.=.),
+  )
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Vector
+  ( Vector,
+    fromList,
+  )
+import Instances.TH.Lift ()
+import Language.Haskell.TH
+  ( Exp (LamCaseE),
+    Lit (IntegerL),
+    runIO,
+  )
+import Language.Haskell.TH.Syntax
+  ( Body (NormalB),
+    Exp (LitE),
+    Lit (StringL),
+    Match (Match),
+    Pat (LitP),
+    Q,
+  )
+
+-- nicer sum for non-empty lists.
+sum' :: Num a => [a] -> a
+sum' = foldl1 (+)
+
+type VarDefs = Map String Let
+
+-- Discrete distribution generating tree.
+type SystemDDGs = Map String (Vector Int)
+
+mkVariables :: Set SpecifiableType -> Spec VarDefs
+mkVariables sys = do
+  let n = Set.size sys
+  xs <- replicateM n variable
+  let sys' = Set.toList sys
+      names = map (\(SpecifiableType a) -> typeName a) sys'
+
+  return (Map.fromList $ names `zip` xs)
+
+mkMarkingVariables :: S.SystemSpec -> Spec VarDefs
+mkMarkingVariables sys = do
+  let constrFreq = Map.toList $ S.constructorFrequencies sys
+  xs <-
+    mapM
+      ( \(n, freq) -> do
+          x <- variable' freq
+          return (show n, x)
+      )
+      constrFreq
+
+  return $ Map.fromList xs
+
+-- FIXME: rename
+data Variables = Variables
+  { sizeVar :: forall a. FromVariable a => a,
+    typeVariable :: Map String Let,
+    markingVariable :: Map String Let,
+    systemSpec :: S.SystemSpec
+  }
+
+mkTypeVariables :: Variables -> Set SpecifiableType -> Spec ()
+mkTypeVariables variables types =
+  mapM_ (mkTypeVariable variables) (Set.toList types)
+
+mkTypeVariable :: Variables -> SpecifiableType -> Spec ()
+mkTypeVariable variables (SpecifiableType typ) = do
+  let (Let x) = typeVariable variables Map.! typeName typ
+  x .=. typeExpr variables (typedef typ)
+
+typeExpr :: Variables -> TypeDef -> Expr
+typeExpr variables = sum' . map (consExpr variables)
+
+consExpr :: Variables -> Cons -> Expr
+consExpr variables cons = defaults u * z ^ w * product args'
+  where
+    z = sizeVar variables
+    u = name cons `Map.lookup` markingVariable variables
+    w = systemSpec variables `getWeight` name cons
+    args' = map (argExpr variables) (args cons)
+
+argExpr :: Variables -> SpecifiableType -> Expr
+argExpr variables (SpecifiableType typ) =
+  let Let x = typeVariable variables Map.! typeName typ in x
+
+defaults :: (Num p, FromVariable p) => Maybe Let -> p
+defaults Nothing = 1
+defaults (Just (Let x)) = x
+
+mkDDGs :: Variables -> Spec SystemDDGs
+mkDDGs variables = do
+  let typeList = Map.toList $ typeVariable variables
+  ddgs <-
+    mapM
+      ( \(n, x) -> do
+          ddgTree <- ddg x
+          return (n, fromList $ fromJust ddgTree)
+      )
+      typeList
+
+  return $ Map.fromList ddgs
+
+paganiniSpec :: S.SystemSpec -> Spec SystemDDGs
+paganiniSpec sys@(S.SystemSpec {S.targetType = target, S.meanSize = n}) = do
+  let samplableTypes = S.collectTypes sys
+
+  Let z <- variable' n
+  varDefs <- mkVariables samplableTypes
+  markDefs <- mkMarkingVariables sys
+
+  let variables =
+        Variables
+          { sizeVar = z,
+            typeVariable = varDefs,
+            markingVariable = markDefs,
+            systemSpec = sys
+          }
+
+  mkTypeVariables variables samplableTypes
+
+  let (Let t) = varDefs Map.! typeName target
+  tune t -- tune for target variable.
+  mkDDGs variables
+
+paganiniSpecIO :: S.SystemSpec -> IO (Either PaganiniError SystemDDGs)
+paganiniSpecIO = debugPaganini . paganiniSpec
+
+systemDDGs :: S.SystemSpec -> IO SystemDDGs
+systemDDGs sys = do
+  spec <- paganiniSpecIO sys
+  return $ case spec of
+    Left err -> error (show err)
+    Right x -> x
+
+mkChoiceFun :: S.SystemSpec -> Q Exp
+mkChoiceFun sys = do
+  ddgs <- runIO $ systemDDGs sys
+  matches <- mapM mkChoiceFun' $ Map.toList ddgs
+  return $ LamCaseE matches
+
+mkChoiceFun' :: (String, Vector Int) -> Q Match
+mkChoiceFun' (s, ddg) = do
+  listExpr <- [|ddg|]
+  return $ Match (LitP (StringL s)) (NormalB listExpr) []
+
+mkWeightFun :: S.SystemSpec -> Q Exp
+mkWeightFun sys = do
+  let types = S.collectTypes sys
+      typedefs = map (\(SpecifiableType typ) -> typedef typ) $ Set.toList types
+  conMatches <- mapM (mkWeightFun' sys) typedefs
+  return $ LamCaseE (concat conMatches)
+
+mkWeightFun' :: S.SystemSpec -> TypeDef -> Q [Match]
+mkWeightFun' sys = mapM (mkWeightMatch sys)
+
+mkWeightMatch :: S.SystemSpec -> Cons -> Q Match
+mkWeightMatch sys cons = return $ Match (LitP (StringL s)) (NormalB $ LitE (IntegerL w)) []
+  where
+    s = name cons
+    w = sys `S.getWeight` s
--- a/src/Data/Boltzmann/Sampler.hs
+++ b/src/Data/Boltzmann/Sampler.hs
@ -0,0 +1,61 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- |
+-- Module      : Data.Boltzmann.Sampler
+-- Description :
+-- Copyright   : (c) Maciej Bendkowski, 2022
+-- License     : BSD3
+-- Maintainer  : maciej.bendkowski@gmail.com
+-- Stability   : experimental
+module Data.Boltzmann.Sampler
+  ( RejectionSampler,
+    BoltzmannSampler (..),
+    rejectionSampler,
+    rejectionSamplerIO,
+  )
+where
+
+import Control.Monad (guard)
+import Control.Monad.Trans (MonadTrans (lift))
+import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
+import Data.Boltzmann.Specifiable (Specifiable, listTypeName)
+import Data.BuffonMachine (BuffonMachine, choice, runIO)
+import Data.Vector (Vector)
+import System.Random (RandomGen, StdGen)
+
+type RejectionSampler g a = MaybeT (BuffonMachine g) (a, Int)
+
+class BoltzmannSampler a where
+  sample :: RandomGen g => (String -> Vector Int) -> (String -> Int) -> Int -> RejectionSampler g a
+
+instance (Specifiable a, BoltzmannSampler a) => BoltzmannSampler [a] where
+  sample ddgs weight ub = do
+    guard (ub > 0)
+    lift (choice (ddgs $ listTypeName (undefined :: a)))
+      >>= ( \case
+              0 -> return ([], weight (show '[]))
+              _ -> do
+                let wcons = weight (show '(:))
+                (x, w) <- sample ddgs weight (ub - wcons)
+                (xs, ws) <- sample ddgs weight (ub - wcons - w)
+                return (x : xs, w + ws + wcons)
+          )
+
+rejectionSampler :: RandomGen g => (Int -> RejectionSampler g a) -> Int -> Int -> BuffonMachine g a
+rejectionSampler sam lb ub =
+  do
+    str <- runMaybeT (sam ub)
+    case str of
+      Nothing -> rejectionSampler sam lb ub
+      Just (x, s) ->
+        if lb <= s && s <= ub
+          then return x
+          else rejectionSampler sam lb ub
+
+rejectionSamplerIO :: (Int -> RejectionSampler StdGen a) -> Int -> Int -> IO a
+rejectionSamplerIO sam lb ub = runIO (rejectionSampler sam lb ub)
--- a/src/Data/Boltzmann/Sampler/Utils.hs
+++ b/src/Data/Boltzmann/Sampler/Utils.hs
@ -0,0 +1,173 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- Module      : Data.Boltzmann.Oracle
+-- Description :
+-- Copyright   : (c) Maciej Bendkowski, 2022
+-- License     : BSD3
+-- Maintainer  : maciej.bendkowski@gmail.com
+-- Stability   : experimental
+module Data.Boltzmann.Sampler.Utils (mkSampler) where
+
+import Control.Monad (guard)
+import qualified Control.Monad.Trans as T
+import Data.Boltzmann.Sampler (sample)
+import Data.BuffonMachine (choice)
+import Language.Haskell.TH (Exp (DoE, LamCaseE, TupE), Pat (VarP), Stmt (NoBindS), newName)
+import Language.Haskell.TH.Datatype
+  ( ConstructorInfo (constructorName),
+    DatatypeInfo (..),
+    constructorFields,
+    constructorName,
+    reifyDatatype,
+  )
+import Language.Haskell.TH.Syntax (Body (NormalB), Clause (Clause), Dec (FunD, InstanceD), Exp (AppE, ConE, InfixE, LamE, LitE, VarE), Lit (IntegerL, StringL), Match (Match), Name, Pat (LitP, TupP), Q, Stmt (BindS), Type (AppT, ConT), mkName)
+import Prelude hiding (sum)
+
+application :: Exp -> Exp -> [Exp] -> Exp
+application op = foldl (\a b -> InfixE (Just a) op (Just b))
+
+sum :: Exp -> [Exp] -> Q Exp
+sum expr params = do
+  op <- [|(+)|]
+  return $ application op expr params
+
+minus :: Exp -> [Exp] -> Q Exp
+minus expr params = do
+  op <- [|(-)|]
+  return $ application op expr params
+
+pat :: String -> Pat
+pat = VarP . mkName
+
+var :: String -> Exp
+var = VarE . mkName
+
+lit :: Integer -> Exp
+lit = LitE . IntegerL
+
+fresh :: String -> Q (Pat, Exp)
+fresh s = do
+  x <- newName s
+  return (VarP x, VarE x)
+
+constructor :: Name -> Q Exp
+constructor = return . ConE . mkName . show -- note: we're using fully qualified constructors
+
+weightQuery :: Name -> Q Exp
+weightQuery name =
+  return $ AppE (var "weight") (LitE (StringL (show name)))
+
+genMatchExprs :: [(ConstructorInfo, Integer)] -> Q Exp
+genMatchExprs constrGroup = do
+  matchExprs <- mapM genMatchExpr constrGroup
+  return $ LamCaseE matchExprs
+
+genMatchExpr :: (ConstructorInfo, Integer) -> Q Match
+genMatchExpr (con, n) = do
+  let n' = LitP $ IntegerL n
+  conExpr <- genConExpr con
+  return $ Match n' (NormalB conExpr) []
+
+genConExpr :: ConstructorInfo -> Q Exp
+genConExpr con = do
+  argStmtExpr <- genArgExprs con
+  case stmts argStmtExpr of
+    [] -> [|return ($(constructor (constructorName con)), $(weightQuery (constructorName con)))|]
+    _ -> do
+      w <- weightQuery (constructorName con)
+      constrApp <- genConstrApplication (constructorName con) (objs argStmtExpr)
+      weightSum <- sum w (weights argStmtExpr)
+      return' <- [|return|]
+      return $
+        DoE
+          Nothing
+          ( stmts argStmtExpr
+              ++ [NoBindS $ AppE return' (TupE [Just constrApp, Just weightSum])]
+          )
+
+genConstrApplication :: Name -> [Exp] -> Q Exp
+genConstrApplication s args' = do
+  con <- constructor s
+  return $ foldl AppE con args'
+
+data ArgStmtExpr = ArgStmtExpr
+  { stmts :: [Stmt],
+    objs :: [Exp],
+    weights :: [Exp]
+  }
+
+genArgExprs :: ConstructorInfo -> Q ArgStmtExpr
+genArgExprs con = do
+  w <- weightQuery (constructorName con)
+  ubExpr <- var "ub" `minus` [w]
+  genArgExprs' ubExpr (constructorFields con)
+
+genArgExprs' :: Exp -> [Type] -> Q ArgStmtExpr
+genArgExprs' _ [] = return ArgStmtExpr {stmts = [], objs = [], weights = []}
+genArgExprs' ubExpr (_ : as) = do
+  (xp, x) <- fresh "x"
+  (wp, w) <- fresh "w"
+  argExpr <- [|sample|]
+  ubExpr' <- ubExpr `minus` [w]
+  argStmtExpr <- genArgExprs' ubExpr' as
+  let stmt = BindS (TupP [xp, wp]) (AppE (AppE (AppE argExpr (VarE $ mkName "ddgs")) (VarE $ mkName "weight")) ubExpr)
+  return
+    ArgStmtExpr
+      { stmts = stmt : stmts argStmtExpr,
+        objs = x : objs argStmtExpr,
+        weights = w : weights argStmtExpr
+      }
+
+genChoiceExpr :: Name -> Q Exp
+genChoiceExpr typ = do
+  choice' <- [|choice|]
+  lift' <- [|T.lift|]
+  ddgs' <- [|ddgs $(genName typ)|]
+  return $ foldr AppE ddgs' [lift', choice']
+
+genName :: Name -> Q Exp
+genName name = return (LitE $ StringL (show name))
+
+genGuardExpr :: Q Exp
+genGuardExpr = do
+  compOp <- [|(>)|]
+  let ub = var "ub"
+      compExpr = InfixE (Just ub) compOp (Just $ lit 0)
+  guardExpr <- [|guard|]
+  return $ AppE guardExpr compExpr
+
+gen :: Name -> Q Exp
+gen typ = do
+  guardExpr <- genGuardExpr
+  choiceExpr <- genChoiceExpr typ
+
+  constrGroup <- genConstrGroup typ
+  caseExpr <- genMatchExprs constrGroup
+  bindOp <- [|(>>=)|]
+
+  return $
+    LamE
+      [pat "ddgs", pat "weight", pat "ub"]
+      $ DoE
+        Nothing
+        [ NoBindS guardExpr,
+          NoBindS $ InfixE (Just choiceExpr) bindOp (Just caseExpr)
+        ]
+
+genConstrGroup :: Name -> Q [(ConstructorInfo, Integer)]
+genConstrGroup typ = do
+  typInfo <- reifyDatatype typ
+  let consInfo = datatypeCons typInfo
+  return $ zip consInfo [0 :: Integer ..]
+
+mkSampler :: Name -> Q [Dec]
+mkSampler typ = do
+  samplerBody <- gen typ
+  let clazz = AppT (ConT $ mkName "BoltzmannSampler") (ConT typ)
+      funDec = FunD (mkName "sample") [Clause [] (NormalB samplerBody) []]
+      inst = InstanceD Nothing [] clazz [funDec]
+  return [inst]
--- a/src/Data/Boltzmann/Specifiable.hs
+++ b/src/Data/Boltzmann/Specifiable.hs
@ -0,0 +1,125 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+-- |
+-- Module      : Data.Boltzmann.Specifiable
+-- Description :
+-- Copyright   : (c) Maciej Bendkowski, 2022
+-- License     : BSD3
+-- Maintainer  : maciej.bendkowski@gmail.com
+-- Stability   : experimental
+module Data.Boltzmann.Specifiable
+  ( SpecifiableType (..),
+    TypeDef,
+    Cons (..),
+    Specifiable (..),
+    listTypeName,
+  )
+where
+
+import GHC.Generics
+  ( C1,
+    Constructor (conName),
+    D1,
+    Datatype (datatypeName, moduleName),
+    Generic (Rep, from),
+    K1,
+    R,
+    S1,
+    U1,
+    type (:*:),
+    type (:+:),
+  )
+import Language.Haskell.TH.Syntax (Lift)
+
+-- | Specifiable, algebraic type definitions given
+--   as a list of respective type constructors.
+type TypeDef = [Cons]
+
+data Cons = Cons
+  { name :: String,
+    args :: [SpecifiableType]
+  }
+  deriving (Eq, Show, Lift)
+
+data SpecifiableType
+  = forall a. (Specifiable a) => SpecifiableType a
+
+instance Show SpecifiableType where
+  show (SpecifiableType x) = typeName x
+
+instance Eq SpecifiableType where
+  x == y = show x == show y
+
+instance Ord SpecifiableType where
+  x <= y = show x <= show y
+
+instance Lift SpecifiableType
+
+class GWithTypeName f where
+  gtypeName :: f a -> String
+
+instance (Datatype d) => GWithTypeName (D1 d f) where
+  gtypeName x = moduleName x ++ "." ++ datatypeName x
+
+class Specifiable a where
+  typedef :: a -> TypeDef
+  default typedef :: (Generic a, GSpecifiable (Rep a)) => a -> TypeDef
+  typedef = gtypedef . from
+
+  typeName :: a -> String
+  default typeName :: (Generic a, GWithTypeName (Rep a)) => a -> String
+  typeName = gtypeName . from
+
+bracket :: String -> String
+bracket s = "[" ++ s ++ "]"
+
+listTypeName :: Specifiable a => a -> String
+listTypeName = bracket . typeName
+
+-- handle lists.
+instance {-# OVERLAPS #-} (Generic a, Specifiable a) => Specifiable [a] where
+  typeName _ = "[" ++ typeName (undefined :: a) ++ "]"
+
+class GSpecifiable f where
+  gtypedef :: f a -> TypeDef
+
+instance (Datatype d, GSpecifiable' f) => GSpecifiable (D1 d f) where
+  gtypedef x = gtypedef' (moduleName x) (undefined :: f a)
+
+type ModuleName = String
+
+class GSpecifiable' f where
+  gtypedef' :: ModuleName -> f a -> TypeDef
+
+instance (GSpecifiable' f, GSpecifiable' g) => GSpecifiable' (f :+: g) where
+  gtypedef' moduleName (_ :: (f :+: g) a) =
+    gtypedef' moduleName (undefined :: f a) ++ gtypedef' moduleName (undefined :: g a)
+
+instance (Constructor c, GConsArg f) => GSpecifiable' (C1 c f) where
+  gtypedef' moduleName x = [Cons (qualifier ++ conName x) (gargs (undefined :: f a))]
+    where
+      qualifier = moduleName ++ "."
+
+class GConsArg f where
+  gargs :: f a -> [SpecifiableType]
+
+instance GConsArg U1 where
+  gargs _ = []
+
+instance (Specifiable a) => GConsArg (K1 R a) where
+  gargs _ = [SpecifiableType (undefined :: a)]
+
+instance (GConsArg f) => GConsArg (S1 s f) where
+  gargs _ = gargs (undefined :: f a)
+
+instance (GConsArg f, GConsArg g) => GConsArg (f :*: g) where
+  gargs (_ :: (f :*: g) a) =
+    gargs (undefined :: f a) ++ gargs (undefined :: g a)
--- a/src/Data/Boltzmann/Specification.hs
+++ b/src/Data/Boltzmann/Specification.hs
@ -0,0 +1,158 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+-- |
+-- Module      : Data.Boltzmann.Specification
+-- Description :
+-- Copyright   : (c) Maciej Bendkowski, 2022
+-- License     : BSD3
+-- Maintainer  : maciej.bendkowski@gmail.com
+-- Stability   : experimental
+module Data.Boltzmann.Specification
+  ( TypeSpec,
+    SystemSpec (..),
+    samplableType,
+    weight,
+    frequency,
+    defaultTypeSpec,
+    withWeights,
+    withFrequencies,
+    specification,
+    withSystem,
+    (==>),
+    collectTypes,
+    ConsFreq,
+    constructorFrequencies,
+    getWeight,
+    getFrequency,
+  )
+where
+
+import Data.Bifunctor (Bifunctor (first))
+import Data.Boltzmann.Specifiable
+  ( Cons (args),
+    Specifiable (..),
+    SpecifiableType (..),
+  )
+import qualified Data.Map as Map
+import Data.Map.Strict (Map)
+import Data.Maybe (fromJust)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Language.Haskell.TH.Syntax (Name)
+
+data TypeSpec = forall a.
+  Specifiable a =>
+  TypeSpec
+  { samplableType :: a,
+    weight :: Map String Integer,
+    frequency :: Map String Integer
+  }
+
+instance Eq TypeSpec where
+  TypeSpec {samplableType = typ} == TypeSpec {samplableType = typ'} =
+    typeName typ == typeName typ'
+
+instance Ord TypeSpec where
+  TypeSpec {samplableType = typ} <= TypeSpec {samplableType = typ'} =
+    typeName typ <= typeName typ'
+
+data SystemSpec = forall a.
+  Specifiable a =>
+  SystemSpec {targetType :: a, meanSize :: Integer, typeSpecs :: Set TypeSpec}
+
+getWeight :: SystemSpec -> String -> Integer
+getWeight sys name =
+  if Set.size res == 0
+    then 1 -- default weight
+    else fromJust (head $ Set.toList res)
+  where
+    res = Nothing `Set.delete` Set.map (getWeight' name) (typeSpecs sys)
+
+getWeight' :: String -> TypeSpec -> Maybe Integer
+getWeight' name spec = name `Map.lookup` weight spec
+
+getFrequency :: SystemSpec -> String -> Maybe Integer
+getFrequency sys name =
+  if Set.size res == 0
+    then Nothing -- default frequency
+    else head $ Set.toList res
+  where
+    res = Nothing `Set.delete` Set.map (getFrequency' name) (typeSpecs sys)
+
+getFrequency' :: String -> TypeSpec -> Maybe Integer
+getFrequency' name spec = name `Map.lookup` frequency spec
+
+defaultTypeSpec :: Specifiable a => a -> TypeSpec
+defaultTypeSpec typ =
+  TypeSpec
+    { samplableType = typ,
+      weight =
+        Map.fromList
+          [ (show '[], 0),
+            (show '(:), 0)
+          ],
+      frequency = Map.empty
+    }
+
+type Value = (Name, Integer)
+
+(==>) :: Name -> Integer -> Value
+consName ==> w = (consName, w)
+
+infix 6 ==>
+
+withWeights :: [Value] -> TypeSpec -> TypeSpec
+withWeights values spec = spec {weight = weight spec `Map.union` valMap}
+  where
+    valMap = Map.fromList $ map (first show) values
+
+withFrequencies :: [Value] -> TypeSpec -> TypeSpec
+withFrequencies values spec =
+  spec {frequency = frequency spec `Map.union` valMap}
+  where
+    valMap = Map.fromList $ map (first show) values
+
+specification :: Specifiable a => a -> (TypeSpec -> TypeSpec) -> TypeSpec
+specification typ f = f (defaultTypeSpec typ)
+
+withSystem :: Specifiable a => (a, Integer) -> [TypeSpec] -> SystemSpec
+withSystem (typ, size) specs =
+  SystemSpec
+    { targetType = typ,
+      meanSize = size,
+      typeSpecs = Set.fromList specs
+    }
+
+toSpecifiableTypes :: SystemSpec -> Set SpecifiableType
+toSpecifiableTypes = Set.map toSpecifiableType . typeSpecs
+
+toSpecifiableType :: TypeSpec -> SpecifiableType
+toSpecifiableType (TypeSpec {samplableType = t}) = SpecifiableType t
+
+collectTypes :: SystemSpec -> Set SpecifiableType
+collectTypes sys =
+  foldl collectTypesFromSpecifiableType Set.empty (toSpecifiableTypes sys)
+
+collectTypesFromSpecifiableType ::
+  Set SpecifiableType -> SpecifiableType -> Set SpecifiableType
+collectTypesFromSpecifiableType types st@(SpecifiableType typ)
+  | st `Set.member` types = types
+  | otherwise = foldl collectTypesFromCons types' (typedef typ)
+  where
+    types' = st `Set.insert` types
+
+collectTypesFromCons :: Set SpecifiableType -> Cons -> Set SpecifiableType
+collectTypesFromCons types cons =
+  foldl collectTypesFromSpecifiableType types (args cons)
+
+type ConsFreq = Map String Integer
+
+constructorFrequencies :: SystemSpec -> ConsFreq
+constructorFrequencies sys = Map.unions consFreqs
+  where
+    typeSpecs' = Set.toList (typeSpecs sys)
+    consFreqs = map constructorFrequencies' typeSpecs'
+
+constructorFrequencies' :: TypeSpec -> ConsFreq
+constructorFrequencies' (TypeSpec {frequency = freq}) = freq
--- a/src/Data/BuffonMachine.hs
+++ b/src/Data/BuffonMachine.hs
@ -0,0 +1,97 @@
+-- |
+-- Module      : Data.BuffonMachine
+-- Description :
+-- Copyright   : (c) Maciej Bendkowski, 2022
+-- License     : BSD3
+-- Maintainer  : maciej.bendkowski@gmail.com
+-- Stability   : experimental
+module Data.BuffonMachine
+  ( BuffonMachine,
+    Discrete,
+    choice,
+    run,
+    runIO,
+  )
+where
+
+import Control.Monad.Trans.State.Strict
+  ( State,
+    evalState,
+    get,
+    modify',
+    put,
+  )
+import Data.Bits (Bits (testBit))
+import Data.Vector (Vector, null, (!))
+import Data.Word (Word32)
+import System.Random (Random (random), RandomGen, StdGen, getStdGen)
+import Prelude hiding (null)
+
+data Oracle g = Oracle
+  { buffer :: !Word32,
+    usedBits :: !Int,
+    rng :: g
+  }
+
+fresh :: RandomGen g => g -> Oracle g
+fresh g = case random g of
+  (x, g') -> Oracle {buffer = x, usedBits = 0, rng = g'}
+{-# INLINE fresh #-}
+
+useBit :: Oracle g -> Oracle g
+useBit oracle = oracle {usedBits = succ (usedBits oracle)}
+{-# INLINE useBit #-}
+
+currentBit :: Oracle g -> Bool
+currentBit oracle = testBit (buffer oracle) (usedBits oracle)
+{-# INLINE currentBit #-}
+
+-- | Buffon machines depending on the given random number generator 'g'.
+type BuffonMachine g = State (Oracle g)
+
+type Bern g = BuffonMachine g Bool
+
+regenerate :: RandomGen g => Oracle g -> Oracle g
+regenerate oracle =
+  case usedBits oracle of
+    32 -> fresh (rng oracle)
+    _ -> oracle
+{-# INLINE regenerate #-}
+
+getBit :: RandomGen g => Bern g
+getBit = do
+  modify' regenerate
+  oracle <- get
+  put $ useBit oracle
+  return $ currentBit oracle
+
+-- | Discrete random variables.
+type Discrete g = BuffonMachine g Int
+
+-- |
+--  Given a compact discrete distribution generating tree (in vector form)
+--  computes a discrete random variable following that distribution.
+choice :: RandomGen g => Vector Int -> Discrete g
+choice enc
+  | null enc = return 0 -- note: single-point probability distributions.
+  | otherwise = choice' enc 0
+{-# SPECIALIZE choice :: Vector Int -> Discrete StdGen #-}
+
+choice' :: RandomGen g => Vector Int -> Int -> Discrete g
+choice' enc c = do
+  h <- getBit
+  let b = fromEnum h
+  let c' = enc ! (c + b)
+  if enc ! c' < 0 then return $ -(1 + enc ! c') else choice' enc c'
+
+-- |
+--  Runs the given Buffon machine computation
+--  using the given random generator.
+run :: RandomGen g => BuffonMachine g a -> g -> a
+run m = evalState m . fresh
+
+-- |
+--  Runs the given Buffon machine computation within the IO monad
+--  using StdGen as its random bit oracle.
+runIO :: BuffonMachine StdGen a -> IO a
+runIO m = run m <$> getStdGen
--- a/stack.yaml
+++ b/stack.yaml
@ -0,0 +1,74 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
+
+compiler: ghc-9.0.1
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+extra-deps:
+- git: https://github.com/maciej-bendkowski/paganini-hs
+  commit: 941e8f6314ea49b79c2cf1a03924cbedc981917e
+- git: https://github.com/OctopiChalmers/BinderAnn
+  commit: 8f082b23ebd4e79e86e934f41ddfcba59652fadd
+
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.7"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@ -0,0 +1,35 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages:
+- completed:
+    name: paganini-hs
+    version: 0.3.0.0
+    git: https://github.com/maciej-bendkowski/paganini-hs
+    pantry-tree:
+      size: 949
+      sha256: c20a013dc0ceed7d03a3381d0e32b4122140e183b8b3f764b9fa493fda52bc5a
+    commit: 941e8f6314ea49b79c2cf1a03924cbedc981917e
+  original:
+    git: https://github.com/maciej-bendkowski/paganini-hs
+    commit: 941e8f6314ea49b79c2cf1a03924cbedc981917e
+- completed:
+    name: BinderAnn
+    version: 0.1.0.0
+    git: https://github.com/OctopiChalmers/BinderAnn
+    pantry-tree:
+      size: 1631
+      sha256: 2e2b0b9828f0bd3698344940c4da689947b4530ae75ccc51b03c77db171244e3
+    commit: 8f082b23ebd4e79e86e934f41ddfcba59652fadd
+  original:
+    git: https://github.com/OctopiChalmers/BinderAnn
+    commit: 8f082b23ebd4e79e86e934f41ddfcba59652fadd
+snapshots:
+- completed:
+    size: 586286
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
+    sha256: cdead65fca0323144b346c94286186f4969bf85594d649c49c7557295675d8a5
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/16.yaml
--- a/test/Data/Samplers/BinTree.hs
+++ b/test/Data/Samplers/BinTree.hs
@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Samplers.BinTree where
+
+import Data.Boltzmann.Oracle (mkChoiceFun, mkWeightFun)
+import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSamplerIO)
+import Data.Types.BinTree (BinTree, binTreeSysSpec)
+
+randomBinTreeIO :: Int -> Int -> IO BinTree
+randomBinTreeIO =
+  rejectionSamplerIO
+    (sample $(mkChoiceFun binTreeSysSpec) $(mkWeightFun binTreeSysSpec))
--- a/test/Data/Samplers/Lambda.hs
+++ b/test/Data/Samplers/Lambda.hs
@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Samplers.Lambda where
+
+import Data.Boltzmann.Oracle (mkChoiceFun, mkWeightFun)
+import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSamplerIO)
+import Data.Types.Lambda (Lambda, lambdaSysSpec)
+
+randomLambdaIO :: Int -> Int -> IO Lambda
+randomLambdaIO =
+  rejectionSamplerIO
+    (sample $(mkChoiceFun lambdaSysSpec) $(mkWeightFun lambdaSysSpec))
--- a/test/Data/Samplers/Tree.hs
+++ b/test/Data/Samplers/Tree.hs
@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Samplers.Tree where
+
+import Data.Boltzmann.Oracle (mkChoiceFun, mkWeightFun)
+import Data.Boltzmann.Sampler (BoltzmannSampler (..), rejectionSamplerIO)
+import Data.Types.Tree (Tree, treeSysSpec)
+
+randomTreeIO :: Int -> Int -> IO Tree
+randomTreeIO =
+  rejectionSamplerIO
+    (sample $(mkChoiceFun treeSysSpec) $(mkWeightFun treeSysSpec))
--- a/test/Data/Types/BinTree.hs
+++ b/test/Data/Types/BinTree.hs
@ -0,0 +1,53 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Types.BinTree where
+
+import Data.Boltzmann.Sampler (BoltzmannSampler (..))
+import Data.Boltzmann.Sampler.Utils (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, 1000)
+    `withSystem` [ specification
+                     (undefined :: BinTree)
+                     ( withWeights
+                         ['Leaf ==> 0]
+                     )
+                 ]
+
+$(mkSampler ''BinTree)
--- a/test/Data/Types/Lambda.hs
+++ b/test/Data/Types/Lambda.hs
@ -0,0 +1,74 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Types.Lambda where
+
+import Data.Boltzmann.Sampler (BoltzmannSampler (..))
+import Data.Boltzmann.Sampler.Utils (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 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]
+                     )
+                 ]
+
+$(mkSampler ''DeBruijn)
+$(mkSampler ''Lambda)
--- a/test/Data/Types/Tree.hs
+++ b/test/Data/Types/Tree.hs
@ -0,0 +1,41 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Data.Types.Tree where
+
+import Data.Boltzmann.Sampler (BoltzmannSampler (..))
+import Data.Boltzmann.Sampler.Utils (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])
+
+expectedTypeDef :: TypeDef
+expectedTypeDef =
+  [Cons {name = "Data.Types.Tree.Node", args = [treeList]}]
+
+instance Size Tree where
+  size (Node xs) = 1 + sum (map size xs)
+
+treeSysSpec :: SystemSpec
+treeSysSpec =
+  (undefined :: Tree, 1000)
+    `withSystem` [defaultTypeSpec (undefined :: Tree)]
+
+$(mkSampler ''Tree)
--- a/test/Spec.hs
+++ b/test/Spec.hs
@ -0,0 +1,15 @@
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import qualified Test.Unit.Specifiable as Specifiable
+import qualified Test.Unit.Sampler as Sampler
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests = testGroup "Unit tests" unitTests
+
+unitTests :: [TestTree]
+unitTests =
+  [ Specifiable.unitTests,
+    Sampler.unitTests
+  ]
--- a/test/Test/Unit/Sampler.hs
+++ b/test/Test/Unit/Sampler.hs
@ -0,0 +1,44 @@
+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
+  ]
+
+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
+
+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
--- a/test/Test/Unit/Specifiable.hs
+++ b/test/Test/Unit/Specifiable.hs
@ -0,0 +1,49 @@
+{-# 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"
+    [typeDefinitionTests, typeNameTests]
+
+typeDefinitionTests :: TestTree
+typeDefinitionTests =
+  testGroup
+    "Type definition tests"
+    [ testCase "BinTree is correctly mapped into a type definition" $
+        BinTree.expectedTypeDef @=? typedef (undefined :: BinTree),
+      testCase "Tree is correctly mapped into a type definition" $
+        Tree.expectedTypeDef @=? typedef (undefined :: Tree),
+      testCase "DeBruijn is correctly mapped into a type definition" $
+        Lambda.expectedDeBruijnTypeDef @=? typedef (undefined :: DeBruijn),
+      testCase "Lambda is correctly mapped into a type definition" $
+        Lambda.expectedLambdaTypeDef @=? typedef (undefined :: Lambda)
+    ]
+
+typeNameTests :: TestTree
+typeNameTests =
+  testGroup
+    "Type name tests"
+    [ testCase ("BinTree's type name is '" ++ show ''BinTree ++ "'") $
+        show ''BinTree @=? typeName (undefined :: BinTree),
+      testCase ("Tree's type name is '" ++ show ''Tree ++ "'") $
+        show ''Tree @=? typeName (undefined :: Tree),
+      testCase ("Lambda's type name is '" ++ show ''Lambda ++ "'") $
+        show ''Lambda @=? typeName (undefined :: Lambda),
+      testCase "[DeBruijn]'s type name is [Data.Types.Lambda.DeBruijn]" $
+        "[Data.Types.Lambda.DeBruijn]" @=? typeName (undefined :: [DeBruijn]),
+      testCase "[[DeBruijn]]'s type name is [[Data.Types.Lambda.DeBruijn]]" $
+        "[[Data.Types.Lambda.DeBruijn]]" @=? typeName (undefined :: [[DeBruijn]])
+    ]
--- a/test/Test/Unit/Utils.hs
+++ b/test/Test/Unit/Utils.hs
@ -0,0 +1,4 @@
+module Test.Unit.Utils (Size (..)) where
+
+class Size a where
+  size :: a -> Int