boltzmann-brain (empty) → 1.3.1.3
raw patch · 17 files changed
+2483/−0 lines, 17 filesdep +arraydep +basedep +boltzmann-brainsetup-changed
Dependencies added: array, base, boltzmann-brain, containers, haskell-src-exts, hmatrix, megaparsec, mtl, multiset, process
Files
- Data/Boltzmann/Compiler.hs +27/−0
- Data/Boltzmann/Compiler/Haskell/Algebraic.hs +393/−0
- Data/Boltzmann/Compiler/Haskell/Helpers.hs +141/−0
- Data/Boltzmann/Compiler/Haskell/Rational.hs +304/−0
- Data/Boltzmann/Internal/Annotations.hs +64/−0
- Data/Boltzmann/Internal/Parser.hs +93/−0
- Data/Boltzmann/System.hs +241/−0
- Data/Boltzmann/System/Errors.hs +190/−0
- Data/Boltzmann/System/Jacobian.hs +133/−0
- Data/Boltzmann/System/Oracle.hs +85/−0
- Data/Boltzmann/System/Parser.hs +130/−0
- Data/Boltzmann/System/Tuner.hs +344/−0
- Data/Boltzmann/System/Warnings.hs +48/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +199/−0
- boltzmann-brain.cabal +59/−0
+ Data/Boltzmann/Compiler.hs view
@@ -0,0 +1,27 @@+{-|+ Module : Data.Boltzmann.Compiler+ Description : Compiler configuration utilities.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General framework of system compilers.+ -}+module Data.Boltzmann.Compiler+ ( Configuration(..)+ ) where++import Data.Boltzmann.System++-- | Compiler configurations.+class Configuration a where+ config :: PSystem Double -- ^ Parametrised system.+ -> Maybe String -- ^ Output file location.+ -> String -- ^ Module name.+ -> String -- ^ Compile note.+ -> a -- ^ Configuration.++ compile :: a -- ^ Configuration.+ -> IO () -- ^ Compiler IO action.
+ Data/Boltzmann/Compiler/Haskell/Algebraic.hs view
@@ -0,0 +1,393 @@+{-|+ Module : Data.Boltzmann.Compiler.Haskell.Algebraic+ Description : Algebraic Boltzmann system compiler for ghc-7.10.3.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Algebraic system compiler using Haskell's built-in algebraic data types+ to handle to given system types. The outcome sampler is a rejection-based+ sampler implementing the anticipated-rejection sampling scheme.+ -}+module Data.Boltzmann.Compiler.Haskell.Algebraic+ ( Conf(..)+ , compile+ , config+ ) where++import Prelude hiding (and)+import Language.Haskell.Exts hiding (List)+import qualified Language.Haskell.Exts as LHE++import Language.Haskell.Exts.SrcLoc (noLoc)++import Data.Boltzmann.System+import Data.Boltzmann.Internal.Annotations++import Data.Boltzmann.Compiler+import Data.Boltzmann.Compiler.Haskell.Helpers++-- | Default configuration type.+data Conf = Conf { paramSys :: PSystem Double -- ^ Parametrised system.+ , outputFile :: Maybe String -- ^ Output file.+ , moduleName :: String -- ^ Module name.+ , compileNote :: String -- ^ Header comment note.+ , withIO :: Bool -- ^ Generate IO actions?+ , withLists :: Bool -- ^ Generate all list samplers?+ , withShow :: Bool -- ^ Generate deriving Show?+ }++instance Configuration Conf where++ config sys file' module' compilerNote' =+ let with = withBool (annotations $ system sys)+ in Conf { paramSys = sys+ , outputFile = file'+ , moduleName = module'+ , compileNote = compilerNote'+ , withIO = "withIO" `with` True+ , withShow = "withShow" `with` True+ , withLists = "withLists" `with` False+ }++ compile conf = let sys = paramSys conf+ file' = outputFile conf+ name' = moduleName conf+ note = compileNote conf+ withIO' = withIO conf+ withLists' = withLists conf+ withShow' = withShow conf+ module' = compileModule sys name'+ withIO' withLists' withShow'+ in case file' of+ Nothing -> do+ -- write to stdout+ putStr $ moduleHeader sys note+ putStrLn $ prettyPrint module'+ Just f -> do+ -- write to given file+ let header = moduleHeader sys note+ let sampler = prettyPrint module'+ writeFile f $ header ++ sampler++moduleHeader :: PSystem Double -> String -> String+moduleHeader sys compilerNote =+ unlines (["-- | Compiler: " ++ compilerNote,+ "-- | Singularity: " ++ show (param sys),+ "-- | System type: algebraic"] ++ systemNote sys)++compileModule :: PSystem Double -> String -> Bool -> Bool -> Bool -> Module+compileModule sys mod' withIO' withLists' withShow' =+ Module noLoc (ModuleName mod') []+ Nothing (Just exports) imports decls+ where+ exports = declareExports sys withIO' withLists'+ imports = declareImports withIO'+ decls = declareADTs withShow' sys +++ declareGenerators sys +++ declareListGenerators sys withLists' +++ declareSamplers sys +++ declareListSamplers sys withLists' +++ declareSamplersIO sys withIO' +++ declareListSamplersIO sys withIO' withLists'++declareImports :: Bool -> [ImportDecl]+declareImports withIO' =+ [importFrom "Control.Monad" [importFunc "guard"],+ importFrom "Control.Monad.Trans" [importFunc "lift"],+ importFrom "Control.Monad.Trans.Maybe" [importType "MaybeT",+ importFunc "runMaybeT"],++ importFrom "Control.Monad.Random" ([importType "RandomGen",+ importFunc "Rand",+ importFunc "getRandomR"]+ ++ importIO withIO')]++importIO :: Bool -> [ImportSpec]+importIO False = []+importIO True = [importFunc "evalRandIO"]++-- Naming functions.+genName :: ShowS+genName = (++) "genRandom"++listGenName :: ShowS+listGenName t = genName t ++ "List"++samplerName :: ShowS+samplerName = (++) "sample"++listSamplerName :: ShowS+listSamplerName t = samplerName t ++ "List"++samplerIOName :: ShowS+samplerIOName t = samplerName t ++ "IO"++listSamplerIOName :: ShowS+listSamplerIOName t = listSamplerName t ++ "IO"++declareExports :: PSystem Double -> Bool -> Bool -> [ExportSpec]+declareExports sys withIO' withLists' =+ exportTypes sys +++ exportGenerators sys +++ exportListGenerators sys withLists' +++ exportSamplers sys +++ exportListSamplers sys withLists' +++ exportSamplersIO sys withIO' +++ exportListSamplersIO sys withIO' withLists'++exportGenerators :: PSystem Double -> [ExportSpec]+exportGenerators sys = map (exportFunc . genName) $ typeList sys++exportListGenerators :: PSystem Double -> Bool -> [ExportSpec]+exportListGenerators sys withLists' = map (exportFunc . listGenName) $ types' sys+ where types' = if withLists' then typeList+ else seqTypes . system++exportSamplers :: PSystem Double -> [ExportSpec]+exportSamplers sys = map (exportFunc . samplerName) $ typeList sys++exportListSamplers :: PSystem Double -> Bool -> [ExportSpec]+exportListSamplers sys withLists' = map (exportFunc . listSamplerName) $ types' sys+ where types' = if withLists' then typeList+ else seqTypes . system++exportSamplersIO :: PSystem Double -> Bool -> [ExportSpec]+exportSamplersIO _ False = []+exportSamplersIO sys True = map (exportFunc . samplerIOName) $ typeList sys++exportListSamplersIO :: PSystem Double -> Bool -> Bool -> [ExportSpec]+exportListSamplersIO _ False _ = []+exportListSamplersIO sys True withLists' = map (exportFunc . listSamplerIOName) $ types' sys+ where types' = if withLists' then typeList+ else seqTypes . system++-- Utils.+maybeT' :: Type+maybeT' = typeCons "MaybeT"++rand' :: Type+rand' = typeCons "Rand"++int' :: Type+int' = typeCons "Int"++g' :: Type+g' = typeVar "g"++randomGen' :: QName+randomGen' = unname "RandomGen"++return' :: Exp+return' = varExp "return"++nat :: [String]+nat = map show ([0..] :: [Integer])++variableStream :: [String]+variableStream = map ('x' :) nat++weightStream :: [String]+weightStream = map ('w' :) nat++-- Generators.+maybeTType :: Type -> Type+maybeTType = TyApp (TyApp maybeT' (TyApp rand' g'))++generatorType :: Type -> Type+generatorType type' = TyForall Nothing+ [ClassA randomGen' [g']]+ (TyFun int' (maybeTType $ TyTuple Boxed [type', int']))++declRandomP :: [Decl]+declRandomP = declTFun "randomP" type' [] body+ where type' = TyForall Nothing [ClassA randomGen' [g']] (maybeTType $ typeVar "Double")+ body = App (varExp "lift")+ (App (varExp "getRandomR")+ (Tuple Boxed [toLit 0, toLit 1]))++randomP :: String -> Stmt+randomP v = bind v $ varExp "randomP"++guardian :: String -> Stmt+guardian v = Qualifier $ App (varExp "guard")+ (varExp v `greater` toLit 0)++declareGenerators :: PSystem Double -> [Decl]+declareGenerators sys =+ declRandomP +++ concatMap declGenerator (paramTypesW sys)++declGenerator :: (String, [(Cons Double, Int)]) -> [Decl]+declGenerator (t, g) = declTFun (genName t) type' ["ub"] body+ where type' = generatorType $ typeCons t+ body = constrGenerator g++constrGenerator :: [(Cons Double, Int)] -> Exp+constrGenerator [(constr, w)] = rec True constr w+constrGenerator cs = Do (initSteps ++ branching)+ where branching = [Qualifier $ constrGenerator' cs]+ initSteps = [guardian "ub",+ randomP "p"]++constrGenerator' :: [(Cons Double, Int)] -> Exp+constrGenerator' [(constr, w)] = rec False constr w+constrGenerator' ((constr, w) : cs) =+ If (lessF (varExp "p") $ weight constr)+ (rec False constr w)+ (constrGenerator' cs)+constrGenerator' _ = error "I wasn't expecting the Spanish inquisition!"++rec :: Bool -> Cons Double -> Int -> Exp+rec withGuardian constr w =+ case arguments (args constr) (toLit w) variableStream weightStream of+ ([], _, _) -> applyF return' [Tuple Boxed [cons, toLit w]]+ (stmts, totalW, xs) ->+ Do ([guardian "ub" | withGuardian] ++ stmts ++ [ret cons xs (toLit w `add` totalW)])++ where cons = conExp $ func constr++arguments :: [Arg] -> Exp -> [String] -> [String] -> ([Stmt], Exp, [Exp])+arguments [] _ _ _ = ([], toLit 0, [])+arguments (Type arg:args') ub xs ws = arguments' genName arg args' ub xs ws+arguments (List arg:args') ub xs ws = arguments' listGenName arg args' ub xs ws++arguments' :: (t -> String) -> t -> [Arg] -> Exp -> [String] -> [String] -> ([Stmt], Exp, [Exp])+arguments' f arg args' ub (x:xs) (w:ws) = (stmt : stmts, argW', v : vs)+ where stmt = bindP x w $ applyF (varExp $ f arg) [varExp "ub" `sub` ub]+ (stmts, argW, vs) = arguments args' ub' xs ws+ argW' = argW `add` varExp w+ ub' = ub `sub` varExp w+ v = varExp x+arguments' _ _ _ _ _ _ = error "I wasn't expecting the Spanish inquisition!"++ret :: Exp -> [Exp] -> Exp -> Stmt+ret f [] w = Qualifier $ applyF return' [Tuple Boxed [f, w]]+ret f xs w = Qualifier $ applyF return' [Tuple Boxed [t, w]]+ where t = applyF f xs++-- List generators.+listGeneratorType :: Type -> Type+listGeneratorType type' = TyForall Nothing+ [ClassA randomGen' [g']]+ (TyFun int' (maybeTType $ TyTuple Boxed [TyList type', int']))++declareListGenerators :: PSystem Double -> Bool -> [Decl]+declareListGenerators sys withLists' = concatMap (declListGenerator sys) $ types' sys+ where types' = if withLists' then typeList+ else seqTypes . system++declListGenerator :: PSystem Double -> String -> [Decl]+declListGenerator sys t = declTFun (listGenName t) type' ["ub"] body+ where type' = listGeneratorType (typeCons t)+ body = constrListGenerator sys t++constrListGenerator :: PSystem Double -> String -> Exp+constrListGenerator sys t = Do (initSteps ++ branching)+ where branching = [Qualifier $ constrListGenerator' sys t]+ initSteps = [guardian "ub",+ randomP "p"]++constrListGenerator' :: PSystem Double -> String -> Exp+constrListGenerator' sys t =+ If (lessF (varExp "p") (typeWeight sys t))+ (retHeadList t)+ retNil++retHeadList :: String -> Exp+retHeadList t = Do+ [bindP "x" "w" (applyF (varExp $ genName t) [varExp "ub"]),+ bindP "xs" "ws" (applyF (varExp $ listGenName t) [varExp "ub" `sub` varExp "w"]),+ ret (InfixApp (varExp "x") (symbol ":") (varExp "xs"))+ [] (varExp "w" `add` varExp "ws")]++retNil :: Exp+retNil = applyF return' [Tuple Boxed [LHE.List [], toLit 0]]++-- Samplers.+samplerType :: Type -> Type+samplerType type' = TyForall Nothing+ [ClassA randomGen' [g']]+ (TyFun int'+ (TyFun int'+ (TyApp (TyApp rand' g') type')))++declareSamplers :: PSystem Double -> [Decl]+declareSamplers sys = concatMap declSampler $ typeList sys++declSampler :: String -> [Decl]+declSampler t = declTFun (samplerName t) type' ["lb","ub"] body+ where type' = samplerType (typeCons t)+ body = constructSampler t++constructSampler' :: (t -> String) -> (t -> String) -> t -> Exp+constructSampler' gen sam t =+ Do [bind "sample" (applyF (varExp "runMaybeT")+ [applyF (varExp $ gen t) [varExp "ub"]]),+ caseSample]+ where caseSample = Qualifier $ Case (varExp "sample")+ [Alt noLoc (PApp (unname "Nothing") [])+ (UnGuardedRhs rec') Nothing,+ Alt noLoc (PApp (unname "Just")+ [PTuple Boxed [PVar $ Ident "x",+ PVar $ Ident "s"]])+ (UnGuardedRhs return'') Nothing]++ rec' = applyF (varExp $ sam t) [varExp "lb", varExp "ub"]+ return'' = If (lessEq (varExp "lb") (varExp "s") `and` lessEq (varExp "s") (varExp "ub"))+ (applyF (varExp "return") [varExp "x"])+ rec'++constructSampler :: String -> Exp+constructSampler = constructSampler' genName samplerName++declareListSamplers :: PSystem Double -> Bool -> [Decl]+declareListSamplers sys withLists' = concatMap declListSampler $ types' sys+ where types' = if withLists' then typeList+ else seqTypes . system++declListSampler :: String -> [Decl]+declListSampler t = declTFun (listSamplerName t) type' ["lb","ub"] body+ where type' = samplerType (TyList $ typeCons t)+ body = constructListSampler t++constructListSampler :: String -> Exp+constructListSampler = constructSampler' listGenName listSamplerName++-- IO Samplers.+samplerIOType :: Type -> Type+samplerIOType type' = TyForall Nothing+ [] (TyFun int' (TyFun int' (TyApp (typeVar "IO") type')))++declareSamplersIO :: PSystem Double -> Bool -> [Decl]+declareSamplersIO _ False = []+declareSamplersIO sys True = concatMap declSamplerIO $ typeList sys++declSamplerIO :: String -> [Decl]+declSamplerIO t = declTFun (samplerIOName t) type' ["lb","ub"] body+ where type' = samplerIOType (typeCons t)+ body = constructSamplerIO t++constructSamplerIO' :: (t -> String) -> t -> Exp+constructSamplerIO' sam t = applyF (varExp "evalRandIO")+ [applyF (varExp $ sam t) [varExp "lb",+ varExp "ub"]]++constructSamplerIO :: String -> Exp+constructSamplerIO = constructSamplerIO' samplerName++declareListSamplersIO :: PSystem Double -> Bool -> Bool -> [Decl]+declareListSamplersIO _ False _ = []+declareListSamplersIO sys True withLists' = concatMap declListSamplerIO $ types' sys+ where types' = if withLists' then typeList+ else seqTypes . system++declListSamplerIO :: String -> [Decl]+declListSamplerIO t = declTFun (listSamplerIOName t) type' ["lb","ub"] body+ where type' = samplerIOType (TyList $ typeCons t)+ body = constructListSamplerIO t++constructListSamplerIO :: String -> Exp+constructListSamplerIO = constructSamplerIO' listSamplerName
+ Data/Boltzmann/Compiler/Haskell/Helpers.hs view
@@ -0,0 +1,141 @@+{-|+ Module : Data.Boltzmann.Compiler.Haskell.Helpers+ Description : Helper methods for ghc-7.10.3 compiler syntax.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General utilities used across system compilers.+ -}+module Data.Boltzmann.Compiler.Haskell.Helpers where++import Language.Haskell.Exts hiding (List)+import Language.Haskell.Exts.SrcLoc (noLoc)++import Data.Boltzmann.System++-- | Prepares a system/module note.+systemNote :: PSystem Double -> [String]+systemNote psys = ["-- | System size: " ++ show n,+ "-- | Constructors: " ++ show m]+ where sys = system psys+ m = constructors sys+ n = size sys++unname :: String -> QName+unname = UnQual . Ident++typeCons :: String -> Type+typeCons = TyCon . unname++typeVar :: String -> Type+typeVar = TyVar . Ident++varExp :: String -> Exp+varExp = Var . unname++conExp :: String -> Exp+conExp = Con . unname++toLit :: Int -> Exp+toLit = Lit . Int . toInteger++importType :: String -> ImportSpec+importType = IThingAll . Ident++importFunc :: String -> ImportSpec+importFunc = IVar . Ident++-- | Simple import declaration.+importFrom :: String -> [ImportSpec] -> ImportDecl+importFrom module' specs = ImportDecl { importLoc = noLoc+ , importModule = ModuleName module'+ , importQualified = False+ , importSrc = False+ , importSafe = False+ , importPkg = Nothing+ , importAs = Nothing+ , importSpecs = Just (False, specs)+ }++exportType :: String -> ExportSpec+exportType = EThingAll . unname++exportTypes :: PSystem Double -> [ExportSpec]+exportTypes sys = map exportType $ typeList sys++exportFunc :: String -> ExportSpec+exportFunc = EVar . unname++-- | Simple function declaration.+declTFun :: String -> Type -> [String] -> Exp -> [Decl]+declTFun f type' args' body = [decl, FunBind [main]]+ where decl = TypeSig noLoc [Ident f] type'+ args'' = map (PVar . Ident) args'+ main = Match noLoc (Ident f) args'' Nothing+ (UnGuardedRhs body) Nothing++symbol :: String -> QOp+symbol s = QVarOp $ UnQual (Symbol s)++greater :: Exp -> Exp -> Exp+greater x = InfixApp x (symbol ">")++less :: Exp -> Exp -> Exp+less x = InfixApp x (symbol "<")++and :: Exp -> Exp -> Exp+and x = InfixApp x (symbol "&&")++lessEq :: Exp -> Exp -> Exp+lessEq x = InfixApp x (symbol "<=")++lessF :: Real a => Exp -> a -> Exp+lessF v x = less v (Lit $ Frac (toRational x))++bind :: String -> Exp -> Stmt+bind v = Generator noLoc (PVar $ Ident v)++bindP :: String -> String -> Exp -> Stmt+bindP x y = Generator noLoc (PTuple Boxed [PVar (Ident x), PVar (Ident y)])++sub :: Exp -> Exp -> Exp+sub x (Lit (Int 0)) = x+sub x y = InfixApp x (symbol "-") y++add :: Exp -> Exp -> Exp+add x (Lit (Int 0)) = x+add (Lit (Int 0)) x = x+add x y = InfixApp x (symbol "+") y++applyF :: Exp -> [Exp] -> Exp+applyF = foldl App++dot :: Exp -> Exp -> Exp+dot x = InfixApp x (symbol ".")++declareADTs :: Real a => Bool -> PSystem a -> [Decl]+declareADTs withShow sys = map (declADT withShow) $ paramTypes sys++declADT :: Real a => Bool -> (String, [Cons a]) -> Decl+declADT withShow (t,[con]) = DataDecl noLoc flag [] (Ident t) []+ [QualConDecl noLoc [] [] (declCon con)]+ [(unname "Show", []) | withShow]++ -- generate a newtype or data type?+ where flag = if length (args con) == 1 then NewType+ else DataType++declADT withShow (t,cons) = DataDecl noLoc DataType [] (Ident t) []+ (map (QualConDecl noLoc [] [] . declCon) cons)+ [(unname "Show", []) | withShow]++declCon :: Real a => Cons a -> ConDecl+declCon expr = ConDecl (Ident $ func expr) ags+ where ags = map declArg (args expr)++declArg :: Arg -> Type+declArg (Type s) = typeVar s+declArg (List s) = TyList $ typeVar s
+ Data/Boltzmann/Compiler/Haskell/Rational.hs view
@@ -0,0 +1,304 @@+{-|+ Module : Data.Boltzmann.Compiler.Haskell.Rational+ Description : Rational Boltzmann system compiler for ghc-7.10.3.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Rational system compiler using Haskell's built-in algebraic data types+ to handle to given system types. The outcome sampler is a rejection-based+ sampler implementing the interruptible sampling scheme for strongly connected+ specifications.+ -}+module Data.Boltzmann.Compiler.Haskell.Rational+ ( Conf(..)+ , compile+ , config+ ) where++import Prelude hiding (and)+import Language.Haskell.Exts hiding (List)+import Language.Haskell.Exts.SrcLoc (noLoc)++import Data.Boltzmann.System+import Data.Boltzmann.Internal.Annotations++import Data.Boltzmann.Compiler+import Data.Boltzmann.Compiler.Haskell.Helpers++-- | Default configuration type.+data Conf = Conf { paramSys :: PSystem Double -- ^ Parametrised system.+ , outputFile :: Maybe String -- ^ Output file.+ , moduleName :: String -- ^ Module name.+ , compileNote :: String -- ^ Header comment note.+ , withIO :: Bool -- ^ Generate IO actions?+ , withShow :: Bool -- ^ Generate deriving Show?+ }++instance Configuration Conf where++ config sys file' module' compilerNote' =+ let with = withBool (annotations $ system sys)+ in Conf { paramSys = sys+ , outputFile = file'+ , moduleName = module'+ , compileNote = compilerNote'+ , withIO = "withIO" `with` True+ , withShow = "withShow" `with` True+ }++ compile conf = let sys = paramSys conf+ file' = outputFile conf+ name' = moduleName conf+ note = compileNote conf+ withIO' = withIO conf+ withShow' = withShow conf+ module' = compileModule sys name'+ withIO' withShow'+ in case file' of+ Nothing -> do+ -- write to stdout+ putStr $ moduleHeader sys note+ putStrLn $ prettyPrint module'+ Just f -> do+ -- write to given file+ let header = moduleHeader sys note+ let sampler = prettyPrint module'+ writeFile f $ header ++ sampler++moduleHeader :: PSystem Double -> String -> String+moduleHeader sys compilerNote =+ unlines (["-- | Compiler: " ++ compilerNote,+ "-- | Singularity: " ++ show (param sys),+ "-- | System type: rational"] ++ systemNote sys)++compileModule :: PSystem Double -> String -> Bool -> Bool -> Module+compileModule sys mod' withIO' withShow' =+ Module noLoc (ModuleName mod') []+ Nothing (Just exports) imports decls+ where+ exports = declareExports sys withIO'+ imports = declareImports withIO'+ decls = declareADTs withShow' sys +++ declareGenerators sys +++ declareSamplers sys +++ declareSamplersIO sys withIO'++declareImports :: Bool -> [ImportDecl]+declareImports withIO' =+ [importFrom "Control.Monad.Trans" [importFunc "lift"],+ importFrom "Control.Monad.Trans.Maybe" [importType "MaybeT",+ importFunc "runMaybeT"],++ importFrom "Control.Monad.Random" ([importType "RandomGen",+ importFunc "Rand",+ importFunc "getRandomR"]+ ++ importIO withIO')]++importIO :: Bool -> [ImportSpec]+importIO False = []+importIO True = [importFunc "evalRandIO"]++-- Naming functions.+genName :: ShowS+genName = (++) "genRandom"++listGenName :: ShowS+listGenName t = genName t ++ "List"++samplerName :: ShowS+samplerName = (++) "sample"++samplerIOName :: ShowS+samplerIOName t = samplerName t ++ "IO"++declareExports :: PSystem Double -> Bool -> [ExportSpec]+declareExports sys withIO' =+ exportTypes sys +++ exportGenerators sys +++ exportSamplers sys +++ exportSamplersIO sys withIO'++exportGenerators :: PSystem Double -> [ExportSpec]+exportGenerators sys = map (exportFunc . genName) $ typeList sys++exportSamplers :: PSystem Double -> [ExportSpec]+exportSamplers sys = map (exportFunc . samplerName) $ typeList sys++exportSamplersIO :: PSystem Double -> Bool -> [ExportSpec]+exportSamplersIO _ False = []+exportSamplersIO sys True = map (exportFunc . samplerIOName) $ typeList sys++-- Utils.+maybeT' :: Type+maybeT' = typeCons "MaybeT"++rand' :: Type+rand' = typeCons "Rand"++int' :: Type+int' = typeCons "Int"++g' :: Type+g' = typeVar "g"++randomGen' :: QName+randomGen' = unname "RandomGen"++return' :: Exp+return' = varExp "return"++nat :: [String]+nat = map show ([0..] :: [Integer])++variableStream :: [String]+variableStream = map ('x' :) nat++weightStream :: [String]+weightStream = map ('w' :) nat++-- Generators.+maybeTType :: Type -> Type+maybeTType = TyApp (TyApp maybeT' (TyApp rand' g'))++generatorType :: Type -> Type+generatorType type' = TyForall Nothing+ [ClassA randomGen' [g']]+ (TyFun int' (maybeTType $ TyTuple Boxed [type', int']))++declRandomP :: [Decl]+declRandomP = declTFun "randomP" type' [] body+ where type' = TyForall Nothing [ClassA randomGen' [g']] (maybeTType $ typeVar "Double")+ body = App (varExp "lift")+ (App (varExp "getRandomR")+ (Tuple Boxed [toLit 0, toLit 1]))++randomP :: String -> Stmt+randomP v = bind v $ varExp "randomP"++when :: String -> (Cons Double, Int) -> Exp -> Stmt+when v (cons, w) exp' =+ Qualifier $ If (varExp v `lessEq` toLit 0)+ (applyF return' [Tuple Boxed [conExp (func cons), toLit w]])+ exp'++declareGenerators :: PSystem Double -> [Decl]+declareGenerators sys =+ declRandomP +++ concatMap declGenerator (paramTypesW sys)++declGenerator :: (String, [(Cons Double, Int)]) -> [Decl]+declGenerator (t, g) = declTFun (genName t) type' ["ub"] body+ where type' = generatorType $ typeCons t+ body = constrGenerator g++atoms :: [(Cons Double, Int)] -> [(Cons Double, Int)]+atoms = filter (isAtomic . fst)++constrGenerator :: [(Cons Double, Int)] -> Exp+constrGenerator [(constr, w)] = rec constr w+constrGenerator cs = Do initSteps+ where branching = [Qualifier $ constrGenerator' cs]+ terms = atoms cs+ mainBody = randomP "p" : branching+ initSteps = if length terms == 1 then [when "ub" (head terms) (Do mainBody)]+ else mainBody++constrGenerator' :: [(Cons Double, Int)] -> Exp+constrGenerator' [(constr, w)] = rec constr w+constrGenerator' ((constr, w) : cs) =+ If (lessF (varExp "p") $ weight constr)+ (rec constr w)+ (constrGenerator' cs)+constrGenerator' _ = error "I wasn't expecting the Spanish inquisition!"++rec :: Cons Double -> Int -> Exp+rec constr w =+ case arguments (args constr) (toLit w) variableStream weightStream of+ ([], _, _) -> applyF return' [Tuple Boxed [conExp (func constr), toLit w]]+ (stmts, totalW, xs) ->+ let mainBody = stmts ++ [ret (conExp $ func constr) xs (toLit w `add` totalW)]+ interrupt = if isAtomic constr then [when "ub" (constr,w) (Do mainBody)]+ else mainBody+ in Do interrupt+++arguments :: [Arg] -> Exp -> [String] -> [String] -> ([Stmt], Exp, [Exp])+arguments [] _ _ _ = ([], toLit 0, [])+arguments (Type arg:args') ub xs ws = arguments' genName arg args' ub xs ws+arguments (List arg:args') ub xs ws = arguments' listGenName arg args' ub xs ws++arguments' :: (t -> String) -> t -> [Arg] -> Exp -> [String] -> [String] -> ([Stmt], Exp, [Exp])+arguments' f arg args' ub (x:xs) (w:ws) = (stmt : stmts, argW', v : vs)+ where stmt = bindP x w $ applyF (varExp $ f arg) [varExp "ub" `sub` ub]+ (stmts, argW, vs) = arguments args' ub' xs ws+ argW' = argW `add` varExp w+ ub' = ub `sub` varExp w+ v = varExp x+arguments' _ _ _ _ _ _ = error "I wasn't expecting the Spanish inquisition!"++ret :: Exp -> [Exp] -> Exp -> Stmt+ret f [] w = Qualifier $ applyF return' [Tuple Boxed [f, w]]+ret f xs w = Qualifier $ applyF return' [Tuple Boxed [t, w]]+ where t = applyF f xs++-- Samplers.+samplerType :: Type -> Type+samplerType type' = TyForall Nothing+ [ClassA randomGen' [g']]+ (TyFun int'+ (TyFun int'+ (TyApp (TyApp rand' g') type')))++declareSamplers :: PSystem Double -> [Decl]+declareSamplers sys = concatMap declSampler $ typeList sys++declSampler :: String -> [Decl]+declSampler t = declTFun (samplerName t) type' ["lb","ub"] body+ where type' = samplerType (typeCons t)+ body = constructSampler t++constructSampler' :: (t -> String) -> (t -> String) -> t -> Exp+constructSampler' gen sam t =+ Do [bind "sample" (applyF (varExp "runMaybeT")+ [applyF (varExp $ gen t) [varExp "lb"]]),+ caseSample]+ where caseSample = Qualifier $ Case (varExp "sample")+ [Alt noLoc (PApp (unname "Nothing") [])+ (UnGuardedRhs rec') Nothing,+ Alt noLoc (PApp (unname "Just")+ [PTuple Boxed [PVar $ Ident "x",+ PVar $ Ident "s"]])+ (UnGuardedRhs return'') Nothing]++ rec' = applyF (varExp $ sam t) [varExp "lb", varExp "ub"]+ return'' = If (lessEq (varExp "lb") (varExp "s") `and` lessEq (varExp "s") (varExp "ub"))+ (applyF (varExp "return") [varExp "x"])+ rec'++constructSampler :: String -> Exp+constructSampler = constructSampler' genName samplerName++-- IO Samplers.+samplerIOType :: Type -> Type+samplerIOType type' = TyForall Nothing+ [] (TyFun int' (TyFun int' (TyApp (typeVar "IO") type')))++declareSamplersIO :: PSystem Double -> Bool -> [Decl]+declareSamplersIO _ False = []+declareSamplersIO sys True = concatMap declSamplerIO $ typeList sys++declSamplerIO :: String -> [Decl]+declSamplerIO t = declTFun (samplerIOName t) type' ["lb","ub"] body+ where type' = samplerIOType (typeCons t)+ body = constructSamplerIO t++constructSamplerIO' :: (t -> String) -> t -> Exp+constructSamplerIO' sam t = applyF (varExp "evalRandIO")+ [applyF (varExp $ sam t) [varExp "lb",+ varExp "ub"]]++constructSamplerIO :: String -> Exp+constructSamplerIO = constructSamplerIO' samplerName
+ Data/Boltzmann/Internal/Annotations.hs view
@@ -0,0 +1,64 @@+{-|+ Module : Data.Boltzmann.Internal.Annotations+ Description : System annotation utilities.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General utilities meant for handing system annotations+ guiding the tuning and compilation process.+ -}+module Data.Boltzmann.Internal.Annotations+ ( withDefault+ , withDouble+ , withInt+ , withBool+ ) where++import Data.Maybe (fromMaybe)+import Data.Char (toLower)++import Data.Map (Map)+import qualified Data.Map as M++import Text.Read (readMaybe)++-- | Read a given key value of a map with a default fallback.+withDefault :: Read a+ => Map String String+ -> String -> a -> a++withDefault f x d = case x `M.lookup` f of+ Nothing -> d+ Just x' -> fromMaybe d (readMaybe x')++-- | `withDefault` specialised to doubles.+withDouble :: Map String String+ -> String -> Int -> Int++withDouble = withDefault++-- | `withDefault` specialised to ints.+withInt :: Map String String+ -> String -> Int -> Int++withInt = withDefault++-- | `withDefault` specialised to bools.+withBool :: Map String String+ -> String -> Bool -> Bool++withBool f x d = case x `M.lookup` f of+ Nothing -> d+ Just x' -> case map toLower x' of+ "yes" -> True -- support 'yes'+ "y" -> True -- .. and alternative 'y'+ "1" -> True -- .. and alternative '1'+ "true" -> True+ "no" -> False+ "n" -> False+ "false" -> False+ "0" -> False+ _ -> d -- error, fall back to default
+ Data/Boltzmann/Internal/Parser.hs view
@@ -0,0 +1,93 @@+{-|+ Module : Data.Boltzmann.Internal.Parser+ Description : Parser utilities for combinatorial systems.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Common parser utilities and helper functions.+ -}+module Data.Boltzmann.Internal.Parser+ ( sc++ , lexeme+ , symbol+ , parens+ , brackets+ , integer+ , double++ , sepBy2+ , parseN++ , parseFromFile+ , printError+ ) where++import Control.Monad (void)++import Text.Megaparsec+import Text.Megaparsec.String+import qualified Text.Megaparsec.Lexer as L++-- | Cut-out block and line comments parser.+sc :: Parser ()+sc = L.space (void spaceChar) lineCmnt blockCmnt+ where lineCmnt = L.skipLineComment "--"+ blockCmnt = L.skipBlockComment "{-" "-}"++-- | Lexeme parser.+-- | Lexeme parser.+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++-- | Symbol parser.+symbol :: String -> Parser String+symbol = L.symbol sc++-- | Parenthesis parser.+parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++-- | Brackets parser.+brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++-- | Integer parser.+integer :: Parser Int+integer = lexeme $ do+ n <- L.integer+ return $ fromIntegral n++-- | Double parser.+double :: Parser Double+double = lexeme L.float++-- | Separate by two parser.+sepBy2 :: Parser a -> Parser b -> Parser [a]+sepBy2 p q = do+ x <- p+ void q+ xs <- p `sepBy1` q+ return (x : xs)++-- | n-fold parser application.+parseN :: Parser a -> Int -> Parser [a]+parseN _ 0 = return []+parseN p n = do+ x <- p+ xs <- parseN p (n-1)+ return $ x : xs++-- | Uses an input file for parsing.+parseFromFile :: Parsec e String a+ -> String+ -> IO (Either (ParseError Char e) a)++parseFromFile p file = runParser p file <$> readFile file++-- | Prints the given parsing errors.+printError :: ParseError Char Dec -> IO ()+printError err = putStr $ parseErrorPretty err
+ Data/Boltzmann/System.hs view
@@ -0,0 +1,241 @@+{-|+ Module : Data.Boltzmann.System+ Description : System utilities for combinatorial specifications.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General utilities for combinatorial system of algebraic and rational systems.+ -}+module Data.Boltzmann.System+ ( System(..)+ , size+ , constructors+ , Cons(..)+ , Arg(..)+ , types++ , PSystem(..)+ , typeList+ , paramTypes+ , paramTypesW+ , typeWeight+ , seqTypes++ , SystemType(..)+ , systemType+ , hasAtoms+ , isAtomic++ , evalT+ , evalC+ , evalA+ , getIdx+ , value+ , eval+ ) where++import Data.Set (Set)+import qualified Data.Set as S++import Data.Map (Map)+import qualified Data.Map.Strict as M++import Numeric.LinearAlgebra hiding (size)++import Data.Maybe (mapMaybe)++import Data.List (nub)+import Data.Graph++-- | System of combinatorial structures.+data System a = System { defs :: Map String [Cons a] -- ^ Type definitions.+ , annotations :: Map String String -- ^ System annotations.+ } deriving (Show)++-- | Size of a combinatorial system.+size :: System a -> Int+size = M.size . defs++-- | Constructors of a combinatorial system.+constructors :: System a -> Int+constructors = length . concat . M.elems . defs++-- | Type constructor.+data Cons a = Cons { func :: String -- ^ Constructor name.+ , args :: [Arg] -- ^ Argument list.+ , weight :: a -- ^ Constructor weight.+ , frequency :: Maybe Double -- ^ Marking parameter.+ } deriving (Eq,Show)++-- | Type constructor arguments.+data Arg = Type String -- ^ Regular type reference.+ | List String -- ^ Type list reference.+ deriving (Eq,Show)++-- | The name of an argument.+argName :: Arg -> String+argName (Type s) = s+argName (List s) = s++-- | Type set of the given system.+types :: System a -> Set String+types = M.keysSet . defs++-- | Parametrised system of combinatorial structures.+data PSystem a = PSystem { system :: System a -- ^ System with probability weights.+ , values :: Vector a -- ^ Numerical values of corresponding types.+ , param :: a -- ^ Evaluation parameter.+ , weights :: System Int -- ^ System with input weights.+ } deriving (Show)++-- | Type list of the given parametrised system.+typeList :: PSystem a -> [String]+typeList = S.toList . M.keysSet . defs . system++-- | List of types with corresponding constructors.+paramTypes :: PSystem a -> [(String, [Cons a])]+paramTypes = M.toList . defs . system++-- | List of types with corresponding constructors and input weights.+paramTypesW :: PSystem a -> [(String, [(Cons a, Int)])]+paramTypesW sys = map (addW $ weights sys) xs+ where xs = paramTypes sys++addW :: System Int -> (String, [a]) -> (String, [(a, Int)])+addW sys (s, cons) = (s, zip cons ws)+ where ws = typeW sys s++typeW :: System Int -> String -> [Int]+typeW sys s = case s `M.lookup` defs sys of+ Just cons -> map weight cons+ Nothing -> []++-- | Type weight of the given parametrised system.+typeWeight :: PSystem Double -> String -> Double+typeWeight sys t = vec ! idx+ where m = defs $ system sys+ vec = values sys+ idx = M.findIndex t m++-- | List of sequence types.+seqTypes :: System a -> [String]+seqTypes = S.elems . S.fromList . concatMap seqTypesCons+ . concat . M.elems . defs++seqTypesCons :: Cons a -> [String]+seqTypesCons = mapMaybe listN . args+ where listN (List s) = Just s+ listN _ = Nothing++-- | Checks it the argument is a list.+isListArg :: Arg -> Bool+isListArg (List _) = True+isListArg _ = False++-- | Type of a combinatorial system.+-- Note: System other than rational or algebraic are not yet supported.+data SystemType = Rational+ | Algebraic+ | Unsupported String -- ^ error message++instance Show SystemType where+ show Rational = "rational"+ show Algebraic = "algebraic"+ show (Unsupported _) = "unsupported"++-- | Determines the system type.+systemType :: System a -> SystemType+systemType sys+ | not (isLinear sys) = Algebraic+ | not (isInterruptible sys) = Unsupported "Given rational system is not interruptible."+ | otherwise =+ let depGraph = dependencyGraph sys+ in case scc depGraph of+ [_] -> Rational+ xs -> Unsupported $ "Given rational system has "+ ++ show (length xs) ++ " strongly connected components."++-- | Constructs a dependency graph for the given system.+dependencyGraph :: System a -> Graph+dependencyGraph sys = buildG (0,n+d-1) (edgs ++ edgs')+ where idx s = M.findIndex s (defs sys)+ idxSeq s = n + S.findIndex s seqsSet+ edgs = concatMap (edges' atomicT idx idxSeq) $ M.toList (defs sys)+ edgs' = concatMap (\t -> [(idxSeq t, idxSeq t),+ (idxSeq t, idx t)]) seqs+ atomicT = atomicTypes sys+ seqsSet = S.fromAscList seqs+ seqs = seqTypes sys+ d = S.size seqsSet+ n = size sys++edges' :: Set String -> (String -> Int) -> (String -> Int) -> (String, [Cons b]) -> [(Vertex, Vertex)]+edges' atomicT idx idxSeq (t,cons) = concatMap edge' $ neighbours cons+ where tidx = idx t+ neighbours = nub . concatMap args+ edge' (List s) = [(tidx, idxSeq s)]+ edge' (Type s)+ | s `S.member` atomicT = [(tidx, idx s), (idx s, tidx)] -- double edge+ | otherwise = [(tidx, idx s)]++-- | Checks whether the system is linear, i.e.+-- each constructor references at most one type.+isLinear :: System a -> Bool+isLinear sys = all (all linear) (M.elems $ defs sys)+ where atomicT = atomicTypes sys+ linear cons = not (any isListArg $ args cons)+ && length (compoundArgs atomicT $ args cons) <= 1++-- | Determines whether each constructor n the system has at most one atom.+-- Note: the system is assumed to contain some atoms (see hasAtoms).+isInterruptible :: System a -> Bool+isInterruptible sys = all interruptible' $ M.elems (defs sys)+ where interruptible' cons = length (filter isAtomic cons) <= 1++compoundArgs :: Set String -> [Arg] -> [Arg]+compoundArgs atomicT = filter (\x -> argName x `S.notMember` atomicT)++-- | Determines the set of "atomic" types.+atomicTypes :: System a -> Set String+atomicTypes sys = S.fromList $ map fst ts+ where ts = filter isAtomic' $ M.toList (defs sys)+ isAtomic' (_,cons) = all isAtomic cons++isAtomic :: Cons a -> Bool+isAtomic = null . args++-- | Determines whether the system has atoms.+hasAtoms :: System a -> Bool+hasAtoms sys = any (any isAtomic) $ M.elems (defs sys)++-- | Evaluates the type in the given coordinates.+evalT :: System Int -> Double -> Vector Double -> [Cons Int] -> Double+evalT sys z ys cons = sum $ map (evalC sys z ys) cons++-- | Evaluates the constructor in the given coordinates.+evalC :: System Int -> Double -> Vector Double -> Cons Int -> Double+evalC sys z ys con = foldl (*) start $ map (evalA sys ys) (args con)+ where w = weight con+ start = if w > 0 then z ^^ w+ else 1++-- | Evaluates the argument in the given coordinates.+evalA :: System Int -> Vector Double -> Arg -> Double+evalA sys ys (Type t) = ys ! getIdx sys t+evalA sys ys (List t) = recip $ 1 - ys ! getIdx sys t++getIdx :: System Int -> String -> Int+getIdx sys x = x `M.findIndex` defs sys++value :: String -> System b -> Vector Double -> Double+value t sys vec = vec ! M.findIndex t (defs sys)++-- | Evaluates the system at the given coordinates.+eval :: System Int -> Vector Double -> Double -> Vector Double+eval sys ys z = n |> map update [0..n]+ where n = size sys+ f k = snd $ M.elemAt k (defs sys)+ update idx = evalT sys z ys $ f idx
+ Data/Boltzmann/System/Errors.hs view
@@ -0,0 +1,190 @@+{-|+ Module : Data.Boltzmann.System.Errors+ Description : Various error handling utilities.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Common error utilities for combinatorial systems.+ -}+module Data.Boltzmann.System.Errors+ ( SystemError+ , ErrorMonad+ , errors+ ) where++import Control.Monad.Except++import Data.Map (Map)+import qualified Data.Map.Strict as M++import qualified Data.Set as S++import Data.MultiSet (MultiSet)+import qualified Data.MultiSet as MultiSet++import Data.Char (isUpper)+import Text.Read (readMaybe)++import Data.Boltzmann.System+import Data.Boltzmann.System.Jacobian++-- | Semantic system errors referring to invalid+-- input data, for instance ill-founded systems.+data SystemError = Inconsistent String -- Type name+ String -- Constructor name+ String -- Argument name++ | InvalidCons String -- Type name+ String -- Constructor name++ | ClashCons [String] -- Clashing constructors+ | Illfounded -- Ill-founded system+ | Infinite -- Infinite structures++ | Frequencies [String] -- Incorrect frequencies++ | InvalidPrecision -- Invalid precision+ | InvalidMaxIter -- Invalid maxiter+ | InvalidModule -- Invalid module++ | UnsupportedSystemType String -- Invalid system type++instance Show SystemError where+ show (Inconsistent t con arg) = "[Error] Invalid argument type '"+ ++ arg ++ "' in constructor " ++ con ++ " of type " ++ t ++ "."++ show (InvalidCons t con) = "[Error] Invalid constructor '" ++ con+ ++ "' in type " ++ t ++ ": '" ++ con ++ "' names a declared type."++ show (ClashCons cons) = "[Error] Clashing constructor names: "+ ++ foldl1 (\c c' -> "'" ++ c ++ "', " ++ "'" ++ c' ++ "'") cons+ ++ "."++ show Illfounded = "[Error] Ill-founded system."++ show Infinite = "[Error] System defines no finite structures."++ show (Frequencies ts) = "[Error] Incorrect frequencies (expected real in [0.0,1.0]): "+ ++ foldl1 (\c c' -> "'" ++ c ++ "', " ++ "'" ++ c' ++ "'") ts+ ++ "."++ show InvalidPrecision = "[Error] Invalid precision annotation. "+ ++ "Expected a positive floating point number."++ show InvalidMaxIter = "[Error] Invalid maxiter annotation. "+ ++ "Expected a positive integer."++ show InvalidModule = "[Error] Invalid module annotation. "+ ++ "Expected a name starting with an upper case letter."++ show (UnsupportedSystemType s) = "[Error] Unsupported system type. " ++ s++-- | Monadic error handling wrapper.+type ErrorMonad = Either SystemError++-- | Checks whether the given input system is correct, yielding its type.+-- Otherwise, returns an appropriate SystemError.+errors :: Bool -> System Int -> ErrorMonad SystemType+errors useForce sys = do+ void $ consistent sys+ void $ validCons sys+ void $ clashCons sys+ void $ infinite sys+ void $ incorrectFrequencies sys+ void $ invalidAnnotations sys+ unless useForce $ illfounded sys+ invalidSystemType sys++invalidSystemType :: System a -> ErrorMonad SystemType+invalidSystemType sys =+ case systemType sys of+ (Unsupported s) -> throwError (UnsupportedSystemType s) `catchError` Left+ sysT -> return sysT++infinite :: System a -> ErrorMonad ()+infinite sys = unless (hasAtoms sys || not (null $ seqTypes sys)) $ throwError Infinite `catchError` Left++consistent :: System a -> ErrorMonad ()+consistent sys = mapM_ consistentType (M.toList $ defs sys) `catchError` Left+ where ts = types sys+ consistentType (t,cons) = mapM_ (consistentCons t) cons+ consistentCons t con = mapM_ (consistentArg t con) $ args con++ consistentArg :: String -> Cons a -> Arg -> ErrorMonad ()+ consistentArg t con (List s)+ | s `S.member` ts = return ()+ | otherwise = throwError $ Inconsistent t (func con) s+ consistentArg t con (Type s)+ | s `S.member` ts = return ()+ | otherwise = throwError $ Inconsistent t (func con) s++validCons :: System a -> ErrorMonad ()+validCons sys = mapM_ validType (M.toList $ defs sys) `catchError` Left+ where ts = types sys+ validType (t,cons) = mapM_ (validCon t) cons++ validCon :: String -> Cons a -> ErrorMonad ()+ validCon t con+ | null (args con) && func con `S.member` ts =+ throwError $ InvalidCons t (func con)+ | otherwise = return ()++consNames :: System a -> MultiSet String+consNames sys = MultiSet.unions (map insT $ M.elems (defs sys))+ where insT = MultiSet.fromList . map func++duplicates :: System a -> [String]+duplicates sys = map fst $ filter gather $ MultiSet.toOccurList ms+ where gather (_,n) = n /= 1+ ms = consNames sys++clashCons :: System a -> ErrorMonad ()+clashCons sys = let cs = duplicates sys in+ unless (null cs) $ throwError (ClashCons cs) `catchError` Left++illfounded :: System Int -> ErrorMonad ()+illfounded sys = unless (wellFounded sys) $ throwError Illfounded `catchError` Left++incorrectFrequencies :: System Int -> ErrorMonad ()+incorrectFrequencies sys = unless (null fs) $ throwError (Frequencies fs) `catchError` Left+ where fs = incorrectFrequencies' sys++incorrectFrequencies' :: System Int -> [String]+incorrectFrequencies' sys = concatMap incF $ M.elems (defs sys)+ where incF cons = map func $ filter incF' cons+ incF' cons = case frequency cons of+ Nothing -> False+ Just f -> 0.0 > f || 1.0 < f++-- | General, compiler-independent admissible annotations.+invalidAnnotations :: System Int -> ErrorMonad ()+invalidAnnotations sys = do+ let ann = annotations sys+ void $ precisionAnnotation ann+ void $ maxiterAnnotation ann+ moduleAnnotation ann++precisionAnnotation :: Map String String -> ErrorMonad ()+precisionAnnotation ann =+ case "precision" `M.lookup` ann of+ Nothing -> return ()+ Just x -> case readMaybe x :: Maybe Double of+ Nothing -> throwError InvalidPrecision+ Just x' -> unless (x' > 0) $ throwError InvalidPrecision `catchError` Left++maxiterAnnotation :: Map String String -> ErrorMonad ()+maxiterAnnotation ann =+ case "maxiter" `M.lookup` ann of+ Nothing -> return ()+ Just x -> case readMaybe x :: Maybe Int of+ Nothing -> throwError InvalidMaxIter+ Just x' -> unless (x' > 0) $ throwError InvalidMaxIter `catchError` Left++moduleAnnotation :: Map String String -> ErrorMonad ()+moduleAnnotation ann =+ case "module" `M.lookup` ann of+ Nothing -> return ()+ Just x -> unless (isUpper $ head x) $ throwError InvalidModule `catchError` Left
+ Data/Boltzmann/System/Jacobian.hs view
@@ -0,0 +1,133 @@+{-|+ Module : Data.Boltzmann.System.Jacobian+ Description : Jacobian matrix utilities.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General utilities related to the Jacobian associated+ with the combinatorial system. In particular, for+ well-foundness checks.+ -}+module Data.Boltzmann.System.Jacobian+ ( jacobian+ , wellFounded+ ) where++import Data.Boltzmann.System++import Data.MultiSet (MultiSet)+import qualified Data.MultiSet as S++import qualified Data.Map as M++import Numeric.LinearAlgebra hiding (size)++-- | Symbolic derivable expressions.+data Derivable = Product Derivable Derivable+ | Union Derivable Derivable+ | Func String Int+ | Seq String Int+ | Z Int++norm :: [Arg] -> (MultiSet String, MultiSet String)+norm args' = norm' args' S.empty S.empty++norm' :: [Arg] -> MultiSet String -> MultiSet String+ -> (MultiSet String, MultiSet String)++norm' (Type t : xs) ts ls = norm' xs (t `S.insert` ts) ls+norm' (List t : xs) ts ls = norm' xs ts (t `S.insert` ls)+norm' [] ts ls = (ts, ls)++toDerivableL :: [Cons Int] -> Derivable+toDerivableL cons = foldl1 Union $ map toDerivable cons++toDerivable :: Cons Int -> Derivable+toDerivable con = Product z derivs'+ where z = Z $ weight con+ derivs = toDerivable' (norm $ args con)+ derivs' = foldl Product (Z 0) derivs++toDerivable' :: (MultiSet String, MultiSet String) -> [Derivable]+toDerivable' (ts, ls) = ts' ++ ls'+ where ts' = map (uncurry Func) $ S.toOccurList ts+ ls' = map (uncurry Seq) $ S.toOccurList ls++-- | Evaluates the derivable in the given coordinates.+evalD :: System Int -> String -> Double+ -> Vector Double -> Derivable -> Double++evalD _ _ z _ (Z n) = z ^^ n+evalD sys _ _ ys (Func t n) = evalA sys ys (Type t) ^^ n+evalD sys _ _ ys (Seq t n) = evalA sys ys (List t) ^^ n++evalD sys f z ys (Product x y) = xd * yd+ where xd = evalD sys f z ys x+ yd = evalD sys f z ys y++evalD sys f z ys (Union x y) = xd + yd+ where xd = evalD sys f z ys x+ yd = evalD sys f z ys y++-- | Computes the derivative of the given derivable+-- expression at the numerical coordinates.+deriv :: System Int -> String -> Double+ -> Vector Double -> Derivable -> Double++deriv _ _ _ _ (Z _) = 0+deriv sys f _ ys (Func t n)+ | f /= t = 0+ | otherwise = let x = evalA sys ys (Type t) in+ fromIntegral n * x ^^ (n-1)++deriv sys f _ ys (Seq t n)+ | f /= t = 0+ | otherwise = let x = evalA sys ys (List t) in+ fromIntegral n * x ^^ (n+1)++deriv sys f z ys (Product x y) = x' * yd + xd * y'+ where x' = deriv sys f z ys x+ y' = deriv sys f z ys y+ xd = evalD sys f z ys x+ yd = evalD sys f z ys y++deriv sys f z ys (Union x y) = x' + y'+ where x' = deriv sys f z ys x+ y' = deriv sys f z ys y++jacobian' :: System Int -> Double -> Vector Double -> Int -> Int -> Double+jacobian' sys z ys i j = deriv sys f z ys (toDerivableL cons)+ where f = fst (M.elemAt j sys')+ cons = snd (M.elemAt i sys')+ sys' = defs sys++-- | Computes the Jacobian matrix of the+-- system at given numberical coordinates.+jacobian :: System Int -> Double -> Vector Double -> Matrix Double+jacobian sys z ys = let n = size sys in+ (n><n) [jacobian' sys z ys i j | i <- [0..n-1],+ j <- [0..n-1]]++square :: Matrix Double -> Matrix Double+square m = m <> m++-- | Fast matrix exponentiation.+power :: Matrix Double -> Int -> Matrix Double+power m 1 = m+power m n+ | odd n = m * square (power m $ n-1)+ | otherwise = square (power m $ n `div` 2)++-- | Determines whether the given system well-founded.+-- Note: The system is assumed to define no empty structures,+-- i.e. structures of size zero.+wellFounded :: System Int -> Bool+wellFounded sys = empty $ m `power` n+ where m = jacobian sys 0.0 $ n |> [0.0..]+ n = size sys++empty :: Matrix Double -> Bool+empty m = all (==0.0) $ concat (toLists m)
+ Data/Boltzmann/System/Oracle.hs view
@@ -0,0 +1,85 @@+{-|+ Module : Data.Boltzmann.System.Oracle+ Description : Numeric Newton oracle utilities.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Numerical Newton oracles meant for combinatorial systems+ without additional tuning parameters. Note that, alternatively,+ convex optimisation methods are also available.+ -}+module Data.Boltzmann.System.Oracle+ ( singularity+ , parametrise+ ) where++import qualified Data.Map as M++import Numeric.LinearAlgebra hiding (size)++import Data.Boltzmann.System+import Data.Boltzmann.System.Jacobian++computeProb :: System Int -> Double -> Vector Double -> System Double+computeProb sys z ys = sys { defs = M.mapWithKey computeProb' (defs sys) }+ where computeProb' t = computeExp (value t sys ys) 0.0+ computeExp _ _ [] = []+ computeExp tw w (e:es) = e { weight = x / tw } : computeExp tw x es+ where w' = evalC sys z ys e+ x = w' + w++-- | Compute the numerical Boltzmann probabilities for the given system.+parametrise :: System Int -> Double -> Double -> PSystem Double+parametrise sys rho eps = parametrise' initState state sys rho eps+ where initState = size sys |> [0..]+ state = newton sys initState rho++parametrise' :: Vector Double -> Vector Double+ -> System Int -> Double -> Double -> PSystem Double++parametrise' state' state sys rho eps+ | not $ halt eps state' state =+ let newState = newton sys state rho+ in parametrise' state newState sys rho eps+ | otherwise = PSystem { system = computeProb sys rho state+ , values = state+ , param = rho+ , weights = sys+ }++-- | Newton iteration for combinatorial systems.+newton :: System Int -> Vector Double -> Double -> Vector Double+newton sys state rho = state + (inv (ide - m) #> (h - state))+ where h = eval sys state rho+ m = jacobian sys rho state+ ide = ident $ size sys++-- | Finds a numerical approximation of the system's dominating singularity.+singularity :: System Int -> Double -> Double+singularity sys eps = singularity' 0 1.0+ where singularity' lb ub+ | abs (ub - lb) < eps = lb+ | otherwise = if divergent sys eps z then singularity' lb z+ else singularity' z ub+ where z = (ub + lb) / 2++divergent :: System Int -> Double -> Double -> Bool+divergent sys eps z = divergent' 0 state initState+ where initState = size sys |> [0..]+ state = newton sys initState z++ divergent' :: Int -> Vector Double -> Vector Double -> Bool+ divergent' iter v v'+ | negative v || iter >= 25 = True+ | halt eps v v' = False+ | otherwise = divergent' (iter+1) (newton sys v z) v++negative :: Vector Double -> Bool+negative v = any (< 0) $ toList v++-- | Decide whether the system diverges or not.+halt :: Double -> Vector Double -> Vector Double -> Bool+halt eps v w = all (< eps) $ toList $ cmap abs (v - w)
+ Data/Boltzmann/System/Parser.hs view
@@ -0,0 +1,130 @@+{-|+ Module : Data.Boltzmann.System.Parser+ Description : Parser utilities for combinatorial systems.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Parser utilities meant to deal with input system specifications.+ -}+module Data.Boltzmann.System.Parser+ ( parseSystem+ ) where++import Control.Monad (void)++import Text.Megaparsec+import Text.Megaparsec.String++import qualified Data.Map.Strict as M++import Data.Boltzmann.Internal.Parser+import qualified Data.Boltzmann.System as S++-- | Identifier producer.+identifierP :: Parser Char+ -> (Parser Char -> Parser String)+ -> Parser String++identifierP p f = lexeme $ (:) <$> p <*> f (alphaNumChar <|> char '_')++identifier :: Parser String+identifier = identifierP upperChar many++toFreq :: Double -> Maybe Double+toFreq x+ | x < 0 = Nothing+ | otherwise = Just x++systemStmt :: Parser (S.System Int)+systemStmt = sc *> systemStmt' <* eof+ where systemStmt' = do+ an <- many annotationStmt+ ds <- some defsStmt+ return S.System { S.defs = M.fromList ds+ , S.annotations = M.fromList an+ }++defsStmt :: Parser (String, [S.Cons Int])+defsStmt = do+ t <- identifier+ void (symbol "=")+ exprs <- try (abbrevdef t) <|> exprListStmt+ return (t, exprs)++abbrevdef :: String -> Parser [S.Cons Int]+abbrevdef f = try (listdef f) <|> tupledef f++listdef :: String -> Parser [S.Cons Int]+listdef f = do+ xs <- listStmt+ m <- option (-1.0) (brackets double)+ void (symbol ".")+ return [S.Cons { S.func = f+ , S.args = [xs]+ , S.weight = 0+ , S.frequency = toFreq m+ }]++tupledef :: String -> Parser [S.Cons Int]+tupledef f = do+ ids <- parens $ identifier `sepBy2` symbol ","+ m <- option (-1.0) (brackets double)+ void (symbol ".")+ return [S.Cons { S.func = f+ , S.args = map S.Type ids+ , S.weight = 0+ , S.frequency = toFreq m+ }]++exprListStmt :: Parser [S.Cons Int]+exprListStmt = do+ stms <- exprStmt `sepBy1` symbol "|"+ void (symbol ".")+ return stms++exprStmt :: Parser (S.Cons Int)+exprStmt = do+ f <- identifier+ as <- many argStmt+ w <- option 1 (parens integer)+ m <- option (-1.0) (brackets double)+ return S.Cons { S.func = f+ , S.args = as+ , S.weight = w+ , S.frequency = toFreq m+ }++argStmt :: Parser S.Arg+argStmt = try listStmt <|> typeStmt++listStmt :: Parser S.Arg+listStmt = do+ t <- brackets identifier+ return $ S.List t++typeStmt :: Parser S.Arg+typeStmt = do+ t <- identifier+ return $ S.Type t++annotationIdentifier :: Parser String+annotationIdentifier = identifierP (char '@') some++annotationValue :: Parser String+annotationValue = lexeme $ some (alphaNumChar <|> punctuationChar)++-- | System annotations.+annotationStmt :: Parser (String, String)+annotationStmt = do+ lhs <- annotationIdentifier+ rhs <- annotationValue+ return (tail lhs, rhs)++-- | Parses the given system specification.+parseSystem :: String+ -> IO (Either (ParseError Char Dec) (S.System Int))++parseSystem = parseFromFile systemStmt
+ Data/Boltzmann/System/Tuner.hs view
@@ -0,0 +1,344 @@+{-|+ Module : Data.Boltzmann.System.Tuner+ Description : Interface utilities with the Paganini tuner.+ Copyright : (c) Maciej Bendkowski, 2017++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General utilities managing the IO interface between Boltzmann Brain+ and the Paganini tuner script.+ -}+module Data.Boltzmann.System.Tuner+ ( PSolver(..)+ , PArg(..)+ , defaultArgs+ , writeSpecification+ , readPaganini+ , runPaganini+ ) where++import Control.Monad+import Control.Exception++import System.IO+import System.Exit+import System.Process hiding (system)++import Text.Megaparsec+import Text.Megaparsec.String++import Numeric.LinearAlgebra hiding (size,double)++import Data.Map (Map)+import qualified Data.Map.Strict as M++import Data.MultiSet (MultiSet)+import qualified Data.MultiSet as B+import qualified Data.Set as S++import Data.Maybe++import Data.Boltzmann.System+import Data.Boltzmann.Internal.Parser++-- | Catch IO exceptions.+try' :: IO a -> IO (Either IOException a)+try' = Control.Exception.try++-- | Paganini convex program solvers.+data PSolver = SCS+ | ECOS+ | CVXOPT++instance Show PSolver where+ show SCS = "SCS"+ show ECOS = "ECOS"+ show CVXOPT = "CVXOPT"++-- | Paganini arguments.+data PArg = PArg { solver :: PSolver+ , precision :: Double+ , maxiters :: Int+ , sysType :: SystemType+ } deriving (Show)++toArgs :: PArg -> [String]+toArgs arg = ["-s", show (solver arg)+ ,"-p", show (precision arg)+ ,"-m", show (maxiters arg)+ ,"-t", show (sysType arg)]++rationalArgs :: PArg+rationalArgs = PArg { solver = SCS+ , precision = 1.0e-20+ , maxiters = 2500+ , sysType = Rational+ }++algebraicArgs :: PArg+algebraicArgs = PArg { solver = ECOS+ , precision = 1.0e-20+ , maxiters = 20+ , sysType = Algebraic+ }++-- | Determines default Paganini arguments.+-- Note: It is assumed that the given system is either+-- rational or algebraic. Otherwise, and error is raised.+defaultArgs :: System a -> PArg+defaultArgs sys =+ case systemType sys of+ Rational -> rationalArgs+ Algebraic -> algebraicArgs+ _ -> error "Unsupported"++logger :: String -> IO ()+logger s = hPutStrLn stderr ("[LOG] " ++ s)++writeListLn :: Show a => Handle -> [a] -> IO ()+writeListLn h xs = hPutStrLn h (showsList xs)++printer :: Show a => (a -> String -> String) -> [a] -> String+printer _ [] = ""+printer f xs = foldl1 (\a b -> (a . (" " ++) . b))+ (map f xs) ""++showsList :: Show a => [a]+ -> String++showsList = printer shows++-- | Writes the system specification into the given+-- file handle. In paricular, to Paganini's standard+-- input handle.+writeSpecification :: System Int -> Handle -> IO ()+writeSpecification sys hout = do+ logger "Writing specification"+ let freqs = frequencies sys+ let seqs = seqTypes sys+ let spec = toPSpec sys++ -- # of equations and frequencies+ writeListLn hout [numTypes spec + numSeqTypes spec+ ,length freqs]++ -- vector of frequencies+ writeListLn hout freqs++ -- type specifications+ let find' x = x `S.findIndex` M.keysSet (defs sys)+ foldM_ (typeSpecification hout find' spec) 0 (M.elems $ defs sys)++ -- sequence specifications+ mapM_ (seqSpecification hout find' spec) seqs++ logger "Finished writing specification"++getArgs :: System Int -> Maybe PArg -> PArg+getArgs sys = fromMaybe (defaultArgs sys)++handleIOEx :: String -> IO a+handleIOEx ex = do+ hPutStrLn stderr $ "[ERROR] " ++ ex+ exitWith (ExitFailure 1)++-- | Communicates with Paganini and collects the respective+-- tuning vector for the given system. If communication is not possible,+-- for instance due to the missing Paganini script, the current process+-- is terminated with an error message on the standard error output.+runPaganini :: System Int -> Maybe PArg+ -> IO (Either (ParseError Char Dec)+ (PSystem Double))++runPaganini sys arg = do++ logger "Running paganini"+ let arg' = getArgs sys arg+ logger (printer (++) $ "Arguments: " : toArgs arg')++ -- Execute the paganini tuning script.+ pp <- try' $ createProcess (proc "paganini" (toArgs arg')){ std_out = CreatePipe+ , std_in = CreatePipe }++ case pp of+ Left _ -> handleIOEx "Could not locate the paganini tuner. Is is available in the PATH?"+ Right (Just hin, Just hout, _, _) -> do++ -- write to paganini's stdout+ writeSpecification sys hin++ -- read output parameters+ s <- hGetContents hout+ let spec = toPSpec sys+ let pag = parse (paganiniStmt spec) "" s++ case pag of+ Left err -> return $ Left err+ Right (rho, us, ts) -> do+ logger "Parsed paganini output"+ let ts' = fromList ts+ let sys' = parametrise sys rho ts' us+ logger "Finished"+ return $ Right sys'++ _ -> handleIOEx "Could not establish inter-process communication with paganini."++-- | Parses the given input string as a Paganini tuning vector.+readPaganini :: System Int -> String+ -> IO (Either (ParseError Char Dec)+ (PSystem Double))++readPaganini sys f = do+ let spec = toPSpec sys+ pag <- parsePaganini spec f+ case pag of+ Left err -> return $ Left err+ Right (rho, us, ts) -> do+ let ts' = fromList ts+ return (Right $ parametrise sys rho ts' us)++frequencies :: System Int -> [Double]+frequencies sys = concatMap (mapMaybe frequency)+ ((M.elems . defs) sys)++-- | Paganini helper specification.+data PSpec = PSpec { numFreqs :: Int+ , numTypes :: Int+ , numSeqTypes :: Int+ }++toPSpec :: System Int -> PSpec+toPSpec sys = PSpec { numFreqs = d+ , numTypes = ts+ , numSeqTypes = ss+ }++ where ts = size sys+ d = length $ frequencies sys+ ss = length $ seqTypes sys++typeSpecification :: Handle -> (String -> Int) -> PSpec+ -> Int -> [Cons Int] -> IO Int++typeSpecification hout find' spec idx cons = do+ let n = length cons+ hPrint hout n -- # of constructors+ foldM (consSpecification hout find' spec) idx cons++consSpecification :: Handle -> (String -> Int) -> PSpec+ -> Int -> Cons Int -> IO Int++consSpecification hout find' spec idx cons = do+ let (vec, idx') = consVec find' spec idx cons+ writeListLn hout vec -- constructor specification+ return idx'++indicator :: Int -> Int -> [Int]+indicator n k = indicator' n k 1++indicator' :: Int -> Int -> Int -> [Int]+indicator' 0 _ _ = []+indicator' n 0 x = x : replicate (n-1) 0+indicator' n k x = 0 : indicator' (n-1) (k-1) x++occurrences :: Cons a -> (MultiSet String, MultiSet String)+occurrences cons = occurrences' (B.empty,B.empty) $ args cons++occurrences' :: (MultiSet String, MultiSet String)+ -> [Arg] -> (MultiSet String, MultiSet String)++occurrences' (ts,sts) [] = (ts,sts)+occurrences' (ts,sts) (Type s : xs) = occurrences' (s `B.insert` ts,sts) xs+occurrences' (ts,sts) (List s : xs) = occurrences' (ts, s `B.insert` sts) xs++consVec :: (String -> Int) -> PSpec -> Int -> Cons Int -> ([Int], Int)+consVec find' spec idx cons =+ let (tocc, socc) = occurrences cons+ w = fromIntegral $ weight cons+ dv = indicator' (numFreqs spec) idx (weight cons)+ tv = typeVec find' (numTypes spec) tocc+ sv = typeVec find' (numSeqTypes spec) socc++ in case frequency cons of+ Just _ -> (w : dv ++ tv ++ sv, idx + 1)+ Nothing -> (w : replicate (numFreqs spec) 0 ++ tv ++ sv, idx)++typeVec :: (String -> Int) -> Int -> MultiSet String -> [Int]+typeVec find' size' m = typeVec' find' vec ls+ where vec = M.fromList [(n,0) | n <- [0..size'-1]]+ ls = B.toOccurList m++typeVec' :: (String -> Int) -> Map Int Int -> [(String,Int)] -> [Int]+typeVec' _ vec [] = M.elems vec+typeVec' find' vec ((t,n) : xs) = typeVec' find' vec' xs+ where vec' = M.insert (find' t) n vec++seqSpecification :: Handle -> (String -> Int) -> PSpec+ -> String -> IO ()++seqSpecification hout find' spec st = do+ let n = 1 + numTypes spec + numFreqs spec + numSeqTypes spec+ let f = replicate (numFreqs spec) 0+ let t = indicator (numTypes spec) (find' st)+ let s = indicator (numSeqTypes spec) (find' st)+ hPrint hout (2 :: Int) -- # of constructors+ writeListLn hout $ replicate n (0 :: Int)+ writeListLn hout $ 0 : f ++ t ++ s++paganiniStmt :: PSpec -> Parser (Double, [Double], [Double])+paganiniStmt spec = do+ rho <- double+ us <- parseN double $ numFreqs spec+ ts <- parseN double $ numTypes spec+ return (rho, us, ts)++-- | Parses the given Paganini specification.+parsePaganini :: PSpec -> String+ -> IO (Either (ParseError Char Dec)+ (Double, [Double], [Double]))++parsePaganini spec = parseFromFile (paganiniStmt spec)++-- | Compute the numerical Boltzmann probabilities for the given system.+parametrise :: System Int -> Double -> Vector Double -> [Double] -> PSystem Double+parametrise sys rho ts us = PSystem { system = computeProb sys rho ts us+ , values = ts+ , param = rho+ , weights = sys+ }++evalExp :: System Int -> Double -> Vector Double+ -> [Double] -> Cons Int -> (Double, [Double])++evalExp sys rho ts us exp' =+ let w = weight exp'+ xs = args exp'+ exp'' = (rho ^^ w) * product (map (evalA sys ts) xs)+ in case frequency exp' of+ Nothing -> (exp'', us)+ Just _ -> (head us ^^ w * exp'', tail us)++computeExp :: System Int -> Double -> Vector Double+ -> [Double] -> Double -> Double -> [Cons Int]+ -> ([Cons Double], [Double])++computeExp _ _ _ us _ _ [] = ([], us)+computeExp sys rho ts us tw w (e:es) = (e { weight = x / tw } : es', us'')+ where (es', us'') = computeExp sys rho ts us' tw x es+ (w', us') = evalExp sys rho ts us e+ x = w + w'++computeProb' :: System Int -> Double -> Vector Double+ -> [Double] -> [(String, [Cons Int])]+ -> [(String, [Cons Double])]++computeProb' _ _ _ _ [] = []+computeProb' sys rho ts us ((t,cons):tys) = (t,cons') : tys'+ where (cons', us') = computeExp sys rho ts us (value t sys ts) 0.0 cons+ tys' = computeProb' sys rho ts us' tys++computeProb :: System Int -> Double -> Vector Double -> [Double] -> System Double+computeProb sys rho ts us = sys { defs = M.fromList tys }+ where tys = computeProb' sys rho ts us (M.toList $ defs sys)
+ Data/Boltzmann/System/Warnings.hs view
@@ -0,0 +1,48 @@+{-|+ Module : Data.Boltzmann.System.Warnings+ Description : Various warning handling utilities.+ Copyright : (c) Maciej Bendkowski, 2018++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Warning utilities meant to deal with, skippable, well-foundness checks+ or other redundant sanity checks of the considered combinatorial system.+ -}+module Data.Boltzmann.System.Warnings+ ( SystemWarning+ , WarningMonad+ , warnings+ ) where++import Control.Monad.Except++import qualified Data.Map.Strict as M++import Data.Boltzmann.System++-- | Semantic system warnings.+data SystemWarning = NullCons String -- Type name+ String -- Constructor name++instance Show SystemWarning where+ show (NullCons t con) = "[Warning] Invalid constructor '" ++ con+ ++ "' in type " ++ t ++ ": encountered a structure of size 0."++-- | Monadic warning handling wrapper.+type WarningMonad = Either SystemWarning++-- | Checks whether the given input system admits no warnings.+warnings :: System Int -> WarningMonad ()+warnings = nullCons++nullCons :: (Num a, Eq a) => System a -> WarningMonad ()+nullCons sys = mapM_ nullType (M.toList $ defs sys) `catchError` Left+ where nullType (t,cons) = mapM_ (nullCon t) cons++ nullCon :: (Num a, Eq a) => String -> Cons a -> WarningMonad ()+ nullCon t con+ | null (args con) && weight con == 0 =+ throwError $ NullCons t (func con)+ | otherwise = return ()
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Maciej Bendkowski and Sergey Dovgal (c) 2017++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,199 @@+{-|+ Module : Main+ Description : Boltzmann brain executable.+ Copyright : (c) Maciej Bendkowski, 2018++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental+ -}+module Main+ ( main+ ) where++import System.IO+import System.Exit+import System.Console.GetOpt+import System.Environment++import Control.Monad (when)+import Data.Either (isLeft)+import Data.Maybe (fromMaybe)+import Data.List (nub)++import qualified Data.Map as M++import Data.Boltzmann.System+import Data.Boltzmann.System.Parser+import Data.Boltzmann.System.Errors+import Data.Boltzmann.System.Warnings+import Data.Boltzmann.Internal.Parser++import qualified Data.Boltzmann.System.Tuner as T++import Data.Boltzmann.Compiler+import qualified Data.Boltzmann.Compiler.Haskell.Algebraic as A+import qualified Data.Boltzmann.Compiler.Haskell.Rational as R++data Flag = OutputFile String+ | InputPaganini String+ | OutputPaganini+ | Force+ | Werror+ | Version+ | Help+ deriving (Eq)++options :: [OptDescr Flag]+options = [Option "o" ["output"] (ReqArg OutputFile "FILE")+ "Optional output file.",++ Option "p" ["paganini-in"] (ReqArg InputPaganini "FILE")+ "Paganini tuning vector for the given system.",++ Option "s" ["paganini-out"] (NoArg OutputPaganini)+ "Output a suitable Paganini specification for the given system.",++ Option "f" ["force"] (NoArg Force)+ "Whether to skip the well-foundedness check.",++ Option "w" ["werror"] (NoArg Werror)+ "Whether to treat warnings as errors.",++ Option "v" ["version"] (NoArg Version)+ "Prints the program version number.",++ Option "h?" ["help"] (NoArg Help)+ "Prints this help message."]++usageHeader :: String+usageHeader = "Usage: bb [OPTIONS...]"++versionHeader :: String+versionHeader = "Boltzmann Brain v1.3.1.3 (c) Maciej Bendkowski and Sergey Dovgal 2018"++compilerTimestamp :: String+compilerTimestamp = "Boltzmann Brain v1.3.1.3"++getPrecision :: System a -> Double+getPrecision sys =+ case "precision" `M.lookup` annotations sys of+ Just x -> read x :: Double+ Nothing -> 1.0e-9++getMaxIter :: System a -> Maybe Int+getMaxIter sys =+ case "maxiter" `M.lookup` annotations sys of+ Just x -> return (read x :: Int)+ Nothing -> Nothing++getModuleName :: System a -> String+getModuleName sys = fromMaybe "Sampler" ("module" `M.lookup` annotations sys)++output :: [Flag] -> Maybe String+output (OutputFile f : _) = Just f+output (_:fs) = output fs+output [] = Nothing++toPaganini :: [Flag] -> Bool+toPaganini flags = OutputPaganini `elem` flags++useForce :: [Flag] -> Bool+useForce flags = Force `elem` flags++fromPaganini :: [Flag] -> Maybe String+fromPaganini (InputPaganini s : _) = Just s+fromPaganini (_:fs) = fromPaganini fs+fromPaganini [] = Nothing++parse :: [String] -> IO ([Flag], [String])+parse argv = case getOpt Permute options argv of+ (ops, nonops, [])+ | Help `elem` ops -> do+ putStr $ usageInfo usageHeader options+ exitSuccess+ | Version `elem` ops -> do+ putStrLn versionHeader+ exitSuccess+ | otherwise -> return (nub (concatMap mkset ops), fs)+ where+ fs = if null nonops then [] else nonops+ mkset x = [x]+ (_, _, errs) -> do+ hPutStr stderr (concat errs ++ usageInfo usageHeader options)+ exitWith (ExitFailure 1)++run :: [Flag]+ -> String+ -> IO ()++run flags f = do+ sys <- parseSystem f+ case sys of+ Left err -> printError err+ Right sys' -> do+ let ws = warnings sys'+ reportSystemWarnings ws+ case errors (useForce flags) sys' of+ Left err' -> reportSystemError err'+ Right sysT -> do+ when (exitWerror flags ws) $ exitWith (ExitFailure 1)+ if toPaganini flags then writeSpec sys' (output flags)+ else runCompiler sys' sysT flags++exitWerror :: [Flag] -> WarningMonad () -> Bool+exitWerror flags ws = isLeft ws && Werror `elem` flags++writeSpec :: System Int -> Maybe FilePath -> IO ()+writeSpec sys' (Just f) = withFile f WriteMode (T.writeSpecification sys')+writeSpec sys' Nothing = T.writeSpecification sys' stdout++confCompiler :: PSystem Double -> Maybe String -> SystemType -> IO ()+confCompiler sys outputFile Rational = do+ let conf = config sys outputFile+ (getModuleName $ system sys)+ compilerTimestamp :: R.Conf+ R.compile conf++confCompiler sys outputFile Algebraic = do+ let conf = config sys outputFile+ (getModuleName $ system sys)+ compilerTimestamp :: A.Conf+ A.compile conf++confCompiler _ _ _ = error "I wasn't expecting the Spanish inquisition!"++runCompiler :: System Int -> SystemType -> [Flag] -> IO ()+runCompiler sys sysT flags =+ case fromPaganini flags of+ Nothing -> do+ let arg = T.defaultArgs sys+ pag <- T.runPaganini sys (Just $ arg { T.precision = getPrecision sys+ , T.maxiters = fromMaybe (T.maxiters arg)+ (getMaxIter sys) })+ case pag of+ Left err -> printError err+ Right sys' -> confCompiler sys' (output flags) sysT+ Just s -> do+ pag <- T.readPaganini sys s+ case pag of+ Left err -> printError err+ Right sys' -> confCompiler sys' (output flags) sysT++reportSystemError :: SystemError -> IO ()+reportSystemError err = do+ hPrint stderr err+ exitWith (ExitFailure 1)++reportSystemWarnings :: WarningMonad () -> IO ()+reportSystemWarnings (Left ws) = hPrint stderr ws+reportSystemWarnings _ = return ()++main :: IO ()+main = do+ (ops, fs) <- getArgs >>= parse+ case fs of+ [] -> do hPutStr stderr (usageInfo usageHeader options)+ exitWith (ExitFailure 1)+ (f:_) -> do run ops f+ exitSuccess
+ boltzmann-brain.cabal view
@@ -0,0 +1,59 @@+name: boltzmann-brain+version: 1.3.1.3+synopsis: Boltzmann sampler compiler for combinatorial systems.+description: Boltzmann Brain is a combinatorial system sampler compiler.+ Using an easy and intuitive specification input representing a+ combinatorial system, Boltzmann Brain constructs a working,+ self-contained module implementing a dedicated singular,+ rejection-based Boltzmann sampler with some additional+ control over the constructor frequencies in the generated structures.+homepage: https://github.com/maciej-bendkowski/boltzmann-brain+license: BSD3+license-file: LICENSE+author: Maciej Bendkowski+maintainer: maciej.bendkowski@tcs.uj.edu.pl+copyright: 2018 Maciej Bendkowski+category: Math+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Data.Boltzmann.System+ , Data.Boltzmann.System.Oracle+ , Data.Boltzmann.System.Parser+ , Data.Boltzmann.System.Jacobian+ , Data.Boltzmann.System.Errors+ , Data.Boltzmann.System.Warnings+ , Data.Boltzmann.System.Tuner+ , Data.Boltzmann.Internal.Annotations+ , Data.Boltzmann.Internal.Parser+ , Data.Boltzmann.Compiler+ , Data.Boltzmann.Compiler.Haskell.Helpers+ , Data.Boltzmann.Compiler.Haskell.Algebraic+ , Data.Boltzmann.Compiler.Haskell.Rational+ build-depends: base >= 4.7 && < 5+ , containers >= 0.5.6+ , megaparsec >= 5.2.0+ , array >= 0.5.1+ , haskell-src-exts == 1.17.1+ , mtl >= 2.2.1+ , multiset >= 0.3.3+ , hmatrix >= 0.18.0.0+ , process >= 1.4.3.0+ ghc-options: -O2 -Wall+ default-language: Haskell2010++executable bb+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , hmatrix >= 0.18.0.0+ , containers >= 0.5.6+ , boltzmann-brain+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/maciej-bendkowski/boltzmann-brain