maciej-bendkowski/generic-boltzmann-brain
1
1
Fork 0
mirror of https://github.com/maciej-bendkowski/generic-boltzmann-brain.git synced 2024-08-17 00:20:40 +03:00
Code Issues Projects Releases Wiki Activity

Minimal Haddock documentation.

Browse Source
This commit is contained in:
Maciej Bendkowski 2022-01-14 21:39:04 +01:00
parent 35cf7afd05
commit 04bfff59c9
5 changed files with 142 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
src/Data/Boltzmann/Oracle.hs
View File

@ -1,14 +1,15 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module : Data.Boltzmann.Oracle
-- Description :
-- Description : Sampler tuners and (Template Haskell) generators.
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
--
--
module Data.Boltzmann.Oracle
( mkSpecSampler,
)
@ -24,6 +25,7 @@ import Data.Boltzmann.Specifiable
)
import Data.Boltzmann.Specification (getWeight)
import qualified Data.Boltzmann.Specification as S
import Data.BuffonMachine (DDG)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromJust)
@ -43,8 +45,7 @@ import Data.Paganini
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Vector
( Vector,
fromList,
( fromList,
)
import Instances.TH.Lift ()
import Language.Haskell.TH
@ -65,10 +66,11 @@ import Language.Haskell.TH.Syntax
sum' :: Num a => [a] -> a
sum' = foldl1 (+)
-- | Map from type names to generic Let variables.
type VarDefs = Map String Let
-- Discrete distribution generating tree.
type SystemDDGs = Map String (Vector Int)
-- | Map from type names to discrete distribution generating trees.
type SystemDDGs = Map String DDG
mkVariables :: Set SpecifiableType -> Spec VarDefs
mkVariables sys = do
@ -100,36 +102,36 @@ data Params = Params
}
mkTypeVariables :: Params -> Set SpecifiableType -> Spec ()
mkTypeVariables variables types =
mapM_ (mkTypeVariable variables) (Set.toList types)
mkTypeVariables params types =
mapM_ (mkTypeVariable params) (Set.toList types)
mkTypeVariable :: Params -> SpecifiableType -> Spec ()
mkTypeVariable variables (SpecifiableType typ) = do
let (Let x) = typeVariable variables Map.! typeName typ
x .=. typeExpr variables (typedef typ)
mkTypeVariable params (SpecifiableType typ) = do
let (Let x) = typeVariable params Map.! typeName typ
x .=. typeExpr params (typedef typ)
typeExpr :: Params -> TypeDef -> Expr
typeExpr variables = sum' . map (consExpr variables)
typeExpr params = sum' . map (consExpr params)
consExpr :: Params -> Cons -> Expr
consExpr variables cons = defaults u * z ^ w * product args'
consExpr params 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)
z = sizeVar params
u = name cons `Map.lookup` markingVariable params
w = systemSpec params `getWeight` name cons
args' = map (argExpr params) (args cons)
argExpr :: Params -> SpecifiableType -> Expr
argExpr variables (SpecifiableType typ) =
let Let x = typeVariable variables Map.! typeName typ in x
argExpr params (SpecifiableType typ) =
let Let x = typeVariable params Map.! typeName typ in x
defaults :: (Num p, FromVariable p) => Maybe Let -> p
defaults Nothing = 1
defaults (Just (Let x)) = x
mkDDGs :: Params -> Spec SystemDDGs
mkDDGs variables = do
let typeList = Map.toList $ typeVariable variables
mkDDGs params = do
let typeList = Map.toList $ typeVariable params
ddgs <-
mapM
( \(n, x) -> do
@ -145,13 +147,13 @@ paganiniSpecIO = debugPaganini . paganiniSpec
paganiniSpec :: S.SystemSpec -> Spec SystemDDGs
paganiniSpec sys@(S.SystemSpec {S.targetType = target, S.meanSize = n}) = do
let samplableTypes = S.collectTypes sys
let specifiableTypes = S.collectTypes sys
Let z <- variable' n
varDefs <- mkVariables samplableTypes
varDefs <- mkVariables specifiableTypes
markDefs <- mkMarkingVariables sys
let variables =
let params =
Params
{ sizeVar = z,
typeVariable = varDefs,
@ -159,11 +161,11 @@ paganiniSpec sys@(S.SystemSpec {S.targetType = target, S.meanSize = n}) = do
systemSpec = sys
}
mkTypeVariables variables samplableTypes
mkTypeVariables params specifiableTypes
let (Let t) = varDefs Map.! typeName target
tune t -- tune for target variable.
mkDDGs variables
mkDDGs params
systemDDGs :: S.SystemSpec -> IO SystemDDGs
systemDDGs sys = do
@ -178,7 +180,7 @@ mkChoiceFun sys = do
matches <- mapM mkChoiceFun' $ Map.toList ddgs
return $ LamCaseE matches
mkChoiceFun' :: (String, Vector Int) -> Q Match
mkChoiceFun' :: (String, DDG) -> Q Match
mkChoiceFun' (s, ddg) = do
listExpr <- [|ddg|]
return $ Match (LitP (StringL s)) (NormalB listExpr) []
@ -199,5 +201,10 @@ mkWeightMatch sys cons = return $ Match (LitP (StringL s)) (NormalB $ LitE (Inte
s = name cons
w = sys `S.getWeight` s
-- | Given a system specification:
--
-- * tunes the specification using the external `paganini` library, and
-- * uses so obtained constructor probability distributions to generate,
-- at compile-time, a dedicated analytic sampler.
mkSpecSampler :: S.SystemSpec -> Q Exp
mkSpecSampler sys = [|sample $(mkChoiceFun sys) $(mkWeightFun sys)|]

46
src/Data/Boltzmann/Sampler.hs
View File

@ -7,13 +7,15 @@
-- |
-- Module : Data.Boltzmann.Sampler
-- Description :
-- Description : Boltzmann sampler for specifiable types.
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
-- Stability : experimental
module Data.Boltzmann.Sampler
( RejectionSampler,
DDGSelector,
WeightSelector,
BoltzmannSampler (..),
rejectionSampler,
rejectionSamplerIO,
@ -24,14 +26,29 @@ 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 Data.BuffonMachine (BuffonMachine, DDG, choice, runIO)
import System.Random (RandomGen, StdGen)
-- | Samplers which might "reject" generated objects, i.e. return `Nothing` instead.
type RejectionSampler g a = MaybeT (BuffonMachine g) (a, Int)
-- | Selector functions mapping (fully qualified) constructor names to their `DDG`s.
type DDGSelector = String -> DDG
-- | Selector functions mapping (fully qualified) constructor names to their weights.
type WeightSelector = String -> Int
-- | Multiparametric Boltzmann samplers.
class BoltzmannSampler a where
sample :: RandomGen g => (String -> Vector Int) -> (String -> Int) -> Int -> RejectionSampler g a
sample ::
RandomGen g =>
-- | Function mapping constructor names to corresponding `DDG`s.
DDGSelector ->
-- | Function mapping constructor names to corresponding weights.
WeightSelector ->
-- | Upper bound for the generated objects' weight.
Int ->
RejectionSampler g a
instance (Specifiable a, BoltzmannSampler a) => BoltzmannSampler [a] where
sample ddgs weight ub = do
@ -46,7 +63,16 @@ instance (Specifiable a, BoltzmannSampler a) => BoltzmannSampler [a] where
return (x : xs, w + ws + wcons)
)
rejectionSampler :: RandomGen g => (Int -> RejectionSampler g a) -> Int -> Int -> BuffonMachine g a
-- | Rejection sampler generating objects within a prescribed size window.
rejectionSampler ::
RandomGen g =>
-- | Function producing rejection samplers given weight upper bounds.
(Int -> RejectionSampler g a) ->
-- | Lower bound for the generated objects' weight.
Int ->
-- | Upper bound for the generated objects' weight.
Int ->
BuffonMachine g a
rejectionSampler sam lb ub =
do
str <- runMaybeT (sam ub)
@ -57,5 +83,13 @@ rejectionSampler sam lb ub =
then return x
else rejectionSampler sam lb ub
rejectionSamplerIO :: (Int -> RejectionSampler StdGen a) -> Int -> Int -> IO a
-- | `IO` variant of `rejectionsampler`.
rejectionSamplerIO ::
-- | Function producing rejection samplers given weight upper bounds.
(Int -> RejectionSampler StdGen a) ->
-- | Lower bound for the generated objects' weight.
Int ->
-- | Upper bound for the generated objects' weight.
Int ->
IO a
rejectionSamplerIO sam lb ub = runIO (rejectionSampler sam lb ub)

18
src/Data/Boltzmann/Sampler/Utils.hs
View File

@ -5,7 +5,7 @@
-- |
-- Module : Data.Boltzmann.Oracle
-- Description :
-- Description : Template Haskell utilities for sampler generation.
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
@ -24,7 +24,20 @@ import Language.Haskell.TH.Datatype
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 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
@ -164,6 +177,7 @@ genConstrGroup typ = do
let consInfo = datatypeCons typInfo
return $ zip consInfo [0 :: Integer ..]
-- | Given a type name `a`, instantiates it as `BoltzmannSampler` of `a`.
mkSampler :: Name -> Q [Dec]
mkSampler typ = do
samplerBody <- gen typ

57
src/Data/Boltzmann/Specification.hs
View File

@ -3,7 +3,7 @@
-- |
-- Module : Data.Boltzmann.Specification
-- Description :
-- Description : System and type specifications for specifiable types.
-- Copyright : (c) Maciej Bendkowski, 2022
-- License : BSD3
-- Maintainer : maciej.bendkowski@gmail.com
@ -19,6 +19,7 @@ module Data.Boltzmann.Specification
(==>),
collectTypes,
ConsFreq,
Value,
constructorFrequencies,
getWeight,
getFrequency,
@ -38,26 +39,44 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Language.Haskell.TH.Syntax (Name)
-- | Specifications corresponding to specifiable types.
data TypeSpec = forall a.
Specifiable a =>
TypeSpec
{ samplableType :: a,
{ -- | Corresponding specifiable type `a`.
specifiableType :: a,
-- | Constructors of `a` mapped to their (custom) weight. If no custom
-- weight is provided, a default one of 1 is assumed.
weight :: Map String Integer,
-- | Constructors of `a` mapped to their (custom) frequencies. If no custom
-- frequency is provided, no frequency is assumed.
frequency :: Map String Integer
}
instance Eq TypeSpec where
TypeSpec {samplableType = typ} == TypeSpec {samplableType = typ'} =
TypeSpec {specifiableType = typ} == TypeSpec {specifiableType = typ'} =
typeName typ == typeName typ'
instance Ord TypeSpec where
TypeSpec {samplableType = typ} <= TypeSpec {samplableType = typ'} =
TypeSpec {specifiableType = typ} <= TypeSpec {specifiableType = typ'} =
typeName typ <= typeName typ'
-- | System specifications corresponding to a set of interdependent, specifiable types.
data SystemSpec = forall a.
Specifiable a =>
SystemSpec {targetType :: a, meanSize :: Integer, typeSpecs :: Set TypeSpec}
SystemSpec
{ -- | Specifiable which is designated as the "target" tuning type.
targetType :: a,
-- | Target mean size of the objects corresponding to the tuned system.
meanSize :: Integer,
-- | Set of interdependent, specifiable types.
typeSpecs :: Set TypeSpec
}
-- | Finds the weight of a given (fully qualified) constructor name in the
-- corresponding system specification. If no weight is provided in the system,
-- or the system does not mention the input type, a default value of 1 is
-- returned.
getWeight :: SystemSpec -> String -> Integer
getWeight sys name =
if Set.size res == 0
@ -69,6 +88,10 @@ getWeight sys name =
getWeight' :: String -> TypeSpec -> Maybe Integer
getWeight' name spec = name `Map.lookup` weight spec
-- | Finds the frequency of a given (fully qualified) constructor name in the
-- corresponding system specification. If no frequency is provided in the
-- system, or the system does not mention the input type, `Nothing` is
-- returned.
getFrequency :: SystemSpec -> String -> Maybe Integer
getFrequency sys name =
if Set.size res == 0
@ -80,10 +103,13 @@ getFrequency sys name =
getFrequency' :: String -> TypeSpec -> Maybe Integer
getFrequency' name spec = name `Map.lookup` frequency spec
-- | Default type specification corresponding to the given specifiable type.
-- The specification has no constructor frequencies (no multiparametric
-- tuning). List constructors have weight 0, all others have weight 1.
defaultTypeSpec :: Specifiable a => a -> TypeSpec
defaultTypeSpec typ =
TypeSpec
{ samplableType = typ,
{ specifiableType = typ,
weight =
Map.fromList
[ (show '[], 0),
@ -92,28 +118,40 @@ defaultTypeSpec typ =
frequency = Map.empty
}
-- | Constructor names with associated numeric values (for either weights or frequencies).
type Value = (Name, Integer)
-- | Convenience notation for `Value`.
(==>) :: Name -> Integer -> Value
consName ==> w = (consName, w)
infix 6 ==>
-- | Assigns weight values to the given type specification.
withWeights :: [Value] -> TypeSpec -> TypeSpec
withWeights values spec = spec {weight = weight spec `Map.union` valMap}
where
valMap = Map.fromList $ map (first show) values
-- | Assigns frequency values to the given type specification.
withFrequencies :: [Value] -> TypeSpec -> TypeSpec
withFrequencies values spec =
spec {frequency = frequency spec `Map.union` valMap}
where
valMap = Map.fromList $ map (first show) values
-- | Convenience function constructing type specifications building on top of `defaultTypeSpec`.
specification :: Specifiable a => a -> (TypeSpec -> TypeSpec) -> TypeSpec
specification typ f = f (defaultTypeSpec typ)
withSystem :: Specifiable a => (a, Integer) -> [TypeSpec] -> SystemSpec
-- | Constructs a system specification.
withSystem ::
Specifiable a =>
-- | Target specifiable type.
(a, Integer) ->
-- | Corresponding type specifications.
[TypeSpec] ->
SystemSpec
withSystem (typ, size) specs =
SystemSpec
{ targetType = typ,
@ -125,8 +163,9 @@ toSpecifiableTypes :: SystemSpec -> Set SpecifiableType
toSpecifiableTypes = Set.map toSpecifiableType . typeSpecs
toSpecifiableType :: TypeSpec -> SpecifiableType
toSpecifiableType (TypeSpec {samplableType = t}) = SpecifiableType t
toSpecifiableType (TypeSpec {specifiableType = t}) = SpecifiableType t
-- | Set of specifiable types involved in the given system specification.
collectTypes :: SystemSpec -> Set SpecifiableType
collectTypes sys =
foldl collectTypesFromSpecifiableType Set.empty (toSpecifiableTypes sys)
@ -143,8 +182,10 @@ collectTypesFromCons :: Set SpecifiableType -> Cons -> Set SpecifiableType
collectTypesFromCons types cons =
foldl collectTypesFromSpecifiableType types (args cons)
-- | (Fully qualified) constructor names mapped to their frequencies.
type ConsFreq = Map String Integer
-- | Finds all constructor frequencies for the given system specification.
constructorFrequencies :: SystemSpec -> ConsFreq
constructorFrequencies sys = Map.unions consFreqs
where

4
test/Test/Unit/Specification.hs
View File

@ -124,14 +124,14 @@ typeSpecTests =
where
a =
Specification.TypeSpec
{ Specification.samplableType = undefined :: Lambda,
{ Specification.specifiableType = undefined :: Lambda,
Specification.weight = Map.empty,
Specification.frequency = Map.empty
}
b =
Specification.TypeSpec
{ Specification.samplableType = undefined :: BinTree,
{ Specification.specifiableType = undefined :: BinTree,
Specification.weight = Map.empty,
Specification.frequency = Map.empty
}