mirror of
https://github.com/maciej-bendkowski/generic-boltzmann-brain.git
synced 2024-08-17 00:20:40 +03:00
Minimal Haddock documentation.
This commit is contained in:
parent
35cf7afd05
commit
04bfff59c9
@ -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)|]
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
Loading…
Reference in New Issue
Block a user