From 04bfff59c935fe764b3fb8a407cf29d8e4a54a1b Mon Sep 17 00:00:00 2001 From: Maciej Bendkowski Date: Fri, 14 Jan 2022 21:39:04 +0100 Subject: [PATCH] Minimal Haddock documentation. --- src/Data/Boltzmann/Oracle.hs | 63 ++++++++++++++++------------- src/Data/Boltzmann/Sampler.hs | 46 ++++++++++++++++++--- src/Data/Boltzmann/Sampler/Utils.hs | 18 ++++++++- src/Data/Boltzmann/Specification.hs | 57 ++++++++++++++++++++++---- test/Test/Unit/Specification.hs | 4 +- 5 files changed, 142 insertions(+), 46 deletions(-) diff --git a/src/Data/Boltzmann/Oracle.hs b/src/Data/Boltzmann/Oracle.hs index 3b193ea..a0a50f5 100644 --- a/src/Data/Boltzmann/Oracle.hs +++ b/src/Data/Boltzmann/Oracle.hs @@ -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)|] diff --git a/src/Data/Boltzmann/Sampler.hs b/src/Data/Boltzmann/Sampler.hs index 5a43ed8..fd5ab58 100644 --- a/src/Data/Boltzmann/Sampler.hs +++ b/src/Data/Boltzmann/Sampler.hs @@ -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) diff --git a/src/Data/Boltzmann/Sampler/Utils.hs b/src/Data/Boltzmann/Sampler/Utils.hs index 958ac68..b716dcc 100644 --- a/src/Data/Boltzmann/Sampler/Utils.hs +++ b/src/Data/Boltzmann/Sampler/Utils.hs @@ -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 diff --git a/src/Data/Boltzmann/Specification.hs b/src/Data/Boltzmann/Specification.hs index f10262a..cf58f6a 100644 --- a/src/Data/Boltzmann/Specification.hs +++ b/src/Data/Boltzmann/Specification.hs @@ -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 diff --git a/test/Test/Unit/Specification.hs b/test/Test/Unit/Specification.hs index 27b2c0f..ea5f226 100644 --- a/test/Test/Unit/Specification.hs +++ b/test/Test/Unit/Specification.hs @@ -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 }