boltzmann-brain 1.4 → 1.6
raw patch · 26 files changed
+1810/−1040 lines, 26 filesdep +filepathdep +template-haskelldep ~aesondep ~bytestringdep ~containers
Dependencies added: filepath, template-haskell
Dependency ranges changed: aeson, bytestring, containers, directory, graphviz, haskell-src-exts, megaparsec, multiset, process, text, time, transformers
Files
- Data/Boltzmann/Compiler.hs +1/−1
- Data/Boltzmann/Compiler/Haskell/Algebraic.hs +184/−201
- Data/Boltzmann/Compiler/Haskell/Helpers.hs +179/−86
- Data/Boltzmann/Compiler/Haskell/Rational.hs +232/−200
- Data/Boltzmann/Internal/Annotations.hs +1/−1
- Data/Boltzmann/Internal/Logging.hs +5/−14
- Data/Boltzmann/Internal/Parser.hs +36/−13
- Data/Boltzmann/Internal/TH.hs +24/−0
- Data/Boltzmann/Internal/Tuner.hs +69/−0
- Data/Boltzmann/Internal/Utils.hs +34/−1
- Data/Boltzmann/System.hs +101/−12
- Data/Boltzmann/System/Annotations.hs +42/−0
- Data/Boltzmann/System/Errors.hs +16/−13
- Data/Boltzmann/System/Parser.hs +9/−119
- Data/Boltzmann/System/Parser/Algebraic.hs +103/−0
- Data/Boltzmann/System/Parser/Rational.hs +97/−0
- Data/Boltzmann/System/Renderer.hs +1/−1
- Data/Boltzmann/System/Sampler.hs +1/−1
- Data/Boltzmann/System/Tuner.hs +72/−268
- Data/Boltzmann/System/Tuner/Algebraic.hs +199/−0
- Data/Boltzmann/System/Tuner/Rational.hs +135/−0
- Data/Boltzmann/System/Utils.hs +21/−5
- Data/Boltzmann/System/Warnings.hs +52/−7
- LICENSE +1/−1
- app/Main.hs +165/−76
- boltzmann-brain.cabal +30/−20
Data/Boltzmann/Compiler.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Compiler Description : Compiler configuration utilities.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl
Data/Boltzmann/Compiler/Haskell/Algebraic.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Compiler.Haskell.Algebraic- Description : Algebraic Boltzmann system compiler for ghc-7.10.3.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Description : Algebraic Boltzmann system compiler for GHC.+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -21,10 +21,9 @@ 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.Internal.Utils (getTime) import Data.Boltzmann.Compiler import Data.Boltzmann.Compiler.Haskell.Helpers@@ -59,50 +58,64 @@ module' = compileModule sys name' withIO' withLists' withShow' in do- putStr $ moduleHeader sys note+ time <- getTime+ putStr $ moduleHeader sys note time putStrLn $ prettyPrint module' -moduleHeader :: PSystem Double -> String -> String-moduleHeader sys compilerNote =- unlines (["-- | Compiler: " ++ compilerNote,- "-- | Singularity: " ++ show (param sys),- "-- | System type: algebraic"] ++ systemNote sys)+moduleHeader :: PSystem Double -> String -> String -> String+moduleHeader sys compilerNote time =+ unlines (["-- | Compiler: " ++ compilerNote,+ "-- | Generated at: " ++ time,+ "-- | Singularity: " ++ show (param sys)]+ ++ systemNote sys (show Algebraic)) -compileModule :: PSystem Double -> String -> Bool -> Bool -> Bool -> Module+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'+ Module () (Just $ ModuleHead () (ModuleName () mod')+ Nothing (Just $ ExportSpecList () exports))+ [LanguagePragma () [Ident () "TemplateHaskell"]] imports decls+ where+ exports = declareExports sys withIO' withLists'+ imports = declareImports withIO'+ decls = declareADTs withShow' sys +++ declareDecisionTrees sys +++ declareListDecisionTrees sys withLists' +++ declareGenerators sys +++ declareListGenerators sys withLists' +++ declareGenericSampler +++ declareSamplersIO sys withIO' +++ declareListSamplersIO sys withIO' withLists' -declareImports :: Bool -> [ImportDecl]+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')]+ importFrom "Data.Buffon.Machine" ([importType' "BuffonMachine",+ importType "DecisionTree",+ importFunc "decisionTree",+ importFunc "choice"]+ ++ importIO withIO'), -importIO :: Bool -> [ImportSpec]-importIO False = []-importIO True = [importFunc "evalRandIO"]+ importQual "Language.Haskell.TH.Syntax" "TH", + importFrom "System.Random" [importType "RandomGen"]]++importIO :: Bool -> [ImportSpec ()]+importIO withIO' = [importFunc "runRIO" | withIO']+ -- Naming functions. genName :: ShowS genName = (++) "genRandom" +decisionTreeName :: ShowS+decisionTreeName = (++) "decisionTree"++decisionTreeListName :: ShowS+decisionTreeListName = (++) "decisionTreeList"+ listGenName :: ShowS listGenName t = genName t ++ "List" @@ -118,266 +131,236 @@ listSamplerIOName :: ShowS listSamplerIOName t = listSamplerName t ++ "IO" -declareExports :: PSystem Double -> Bool -> Bool -> [ExportSpec]+genericSamplerName :: String+genericSamplerName = "sample"++declareExports :: PSystem Double -> Bool -> Bool -> [ExportSpec ()] declareExports sys withIO' withLists' = exportTypes sys ++ exportGenerators sys ++ exportListGenerators sys withLists' ++- exportSamplers sys ++- exportListSamplers sys withLists' +++ exportGenericSampler ++ exportSamplersIO sys withIO' ++ exportListSamplersIO sys withIO' withLists' -exportGenerators :: PSystem Double -> [ExportSpec]+exportGenerators :: PSystem Double -> [ExportSpec ()] exportGenerators sys = map (exportFunc . genName) $ typeList sys -exportListGenerators :: PSystem Double -> Bool -> [ExportSpec]+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+exportGenericSampler :: [ExportSpec ()]+exportGenericSampler = [exportFunc genericSamplerName] -exportSamplersIO :: PSystem Double -> Bool -> [ExportSpec]+exportSamplersIO :: PSystem Double -> Bool -> [ExportSpec ()] exportSamplersIO _ False = [] exportSamplersIO sys True = map (exportFunc . samplerIOName) $ typeList sys -exportListSamplersIO :: PSystem Double -> Bool -> Bool -> [ExportSpec]+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'))+maybeTType :: Type () -> Type ()+maybeTType = TyApp () (TyApp () maybeT' (TyApp () buffonMachine' g')) -generatorType :: Type -> Type-generatorType type' = TyForall Nothing- [ClassA randomGen' [g']]- (TyFun int' (maybeTType $ TyTuple Boxed [type', int']))+generatorType :: Type () -> Type ()+generatorType type' = TyForall () Nothing+ (Just $ CxTuple () [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]))+guardian :: String -> Stmt ()+guardian v = Qualifier () $ App () (varExp "guard")+ (varExp v `greater` toLit 0) -randomP :: String -> Stmt-randomP v = bind v $ varExp "randomP"+declareDecisionTrees :: PSystem Double -> [Decl ()]+declareDecisionTrees sys =+ concatMap declareDecisionTree (paramTypesW sys) -guardian :: String -> Stmt-guardian v = Qualifier $ App (varExp "guard")- (varExp v `greater` toLit 0)+declareDecisionT :: Exp () -> String -> [Decl ()]+declareDecisionT prob name' = declTFun name' type' [] body+ where type' = decisionTreeType+ body = spliceExp lift'+ lift' = applyF (qVarExp "TH" "lift") [dt']+ dt' = applyF (varExp "decisionTree") [prob] -declareGenerators :: PSystem Double -> [Decl]+declareDecisionTree :: (String, [(Cons Double, Int)]) -> [Decl ()]+declareDecisionTree (t, g) = declareDecisionT prob name'+ where name' = decisionTreeName t+ prob = LHE.List () (init $ probList g)++declareGenerators :: PSystem Double -> [Decl ()] declareGenerators sys =- declRandomP ++- concatMap declGenerator (paramTypesW sys)+ concatMap declGenerator (paramTypesW sys) -declGenerator :: (String, [(Cons Double, Int)]) -> [Decl]+declGenerator :: (String, [(Cons Double, Int)]) -> [Decl ()] declGenerator (t, g) = declTFun (genName t) type' ["ub"] body where type' = generatorType $ typeCons t- body = constrGenerator g+ body = constrGenerator t g -constrGenerator :: [(Cons Double, Int)] -> Exp-constrGenerator [(constr, w)] = rec True constr w-constrGenerator cs = Do (initSteps ++ branching)- where branching = [Qualifier $ constrGenerator' cs]+constrGenerator :: String -> [(Cons Double, Int)] -> Exp ()+constrGenerator _ [(constr, w)] = rec True constr w+constrGenerator t cs = Do () (initSteps ++ branching)+ where branching = [Qualifier () $ Case () (varExp "n")+ (constrGenerator' 0 cs)] initSteps = [guardian "ub",- randomP "p"]+ choiceN "n" (varExp $ decisionTreeName t)] -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!"+constrGenerator' :: Int -> [(Cons Double, Int)] -> [Alt ()]+constrGenerator' _ [(constr, w)] =+ [caseAlt' (UnGuardedRhs () $ rec False constr w)] -rec :: Bool -> Cons Double -> Int -> Exp+constrGenerator' n ((constr, w) : cs) =+ caseAlt (show n) (UnGuardedRhs () $ rec False constr w)+ : constrGenerator' (succ n) 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]]+ ([], _, _) -> applyF return' [Tuple () Boxed [cons, toLit w]] (stmts, totalW, xs) ->- Do ([guardian "ub" | withGuardian] ++ stmts ++ [ret cons xs (toLit w `add` totalW)])+ 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 :: [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' :: (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]]+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']))+declareListDecisionTrees :: PSystem Double -> Bool -> [Decl ()]+declareListDecisionTrees sys withLists' =+ concatMap (declareListDecisionTree sys) (types' sys)+ where types' = if withLists' then typeList+ else seqTypes . system -declareListGenerators :: PSystem Double -> Bool -> [Decl]-declareListGenerators sys withLists' = concatMap (declListGenerator sys) $ types' sys+declareListDecisionTree :: PSystem Double -> String -> [Decl ()]+declareListDecisionTree sys t = declareDecisionT prob name'+ where name' = decisionTreeListName t+ prob = LHE.List () [Lit () (Frac () t' (show t'))]+ t' = toRational $ typeWeight sys t++listGeneratorType :: Type () -> Type ()+listGeneratorType type' = TyForall () Nothing+ (Just $ CxTuple () [ClassA () randomGen' [g']])+ (TyFun () int' (maybeTType $ TyTuple () Boxed [TyList () type', int']))++declareListGenerators :: PSystem Double -> Bool -> [Decl ()]+declareListGenerators sys withLists' =+ concatMap declListGenerator $ 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+declListGenerator :: String -> [Decl ()]+declListGenerator t = declTFun (listGenName t) type' ["ub"] body where type' = listGeneratorType (typeCons t)- body = constrListGenerator sys t+ body = constrListGenerator t -constrListGenerator :: PSystem Double -> String -> Exp-constrListGenerator sys t = Do (initSteps ++ branching)- where branching = [Qualifier $ constrListGenerator' sys t]+constrListGenerator :: String -> Exp ()+constrListGenerator t = Do () (initSteps ++ branching)+ where branching = [Qualifier () $ Case () (varExp "n")+ (constrListGenerator' 0 t)] initSteps = [guardian "ub",- randomP "p"]+ choiceN "n" (varExp $ decisionTreeListName t)] -constrListGenerator' :: PSystem Double -> String -> Exp-constrListGenerator' sys t =- If (lessF (varExp "p") (typeWeight sys t))- (retHeadList t)- retNil+constrListGenerator' :: Int -> String -> [Alt ()]+constrListGenerator' n t =+ [caseAlt (show n) (UnGuardedRhs () $ retHeadList t)+ ,caseAlt' (UnGuardedRhs () retNil)] -retHeadList :: String -> Exp-retHeadList t = Do+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"))+ ret (InfixApp () (varExp "x") (symbol ":") (varExp "xs")) [] (varExp "w" `add` varExp "ws")] -retNil :: Exp-retNil = applyF return' [Tuple Boxed [LHE.List [], toLit 0]]+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+genericSamplerType :: Type ()+genericSamplerType =+ TyForall () Nothing (Just $ CxTuple () [ClassA () randomGen' [g']])+ (TyFun () (TyFun () int' (maybeTType $ TyTuple () Boxed [TyVar () (Ident () "a"), int']))+ (TyFun () int' (TyFun () int' (TyApp () (TyApp () buffonMachine' g') $ TyVar () (Ident () "a"))))) -declSampler :: String -> [Decl]-declSampler t = declTFun (samplerName t) type' ["lb","ub"] body- where type' = samplerType (typeCons t)- body = constructSampler t+declareGenericSampler :: [Decl ()]+declareGenericSampler = declTFun genericSamplerName type' ["gen","lb","ub"] body+ where type' = genericSamplerType+ body = constructGenericSampler -constructSampler' :: (t -> String) -> (t -> String) -> t -> Exp-constructSampler' gen sam t =- Do [bind "sample" (applyF (varExp "runMaybeT")- [applyF (varExp $ gen t) [varExp "ub"]]),+constructGenericSampler :: Exp ()+constructGenericSampler =+ Do () [bind "str" (applyF (varExp "runMaybeT")+ [applyF (varExp "gen") [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]+ where caseSample = Qualifier () $ Case () (varExp "str")+ [Alt () (PApp () (unname "Nothing") [])+ (UnGuardedRhs () rec') Nothing,+ Alt () (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"))+ rec' = applyF (varExp genericSamplerName)+ [varExp "gen", 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')))+samplerIOType :: Type () -> Type ()+samplerIOType type' = TyForall () Nothing+ Nothing (TyFun () int' (TyFun () int' (TyApp () (typeVar "IO") type'))) -declareSamplersIO :: PSystem Double -> Bool -> [Decl]+declareSamplersIO :: PSystem Double -> Bool -> [Decl ()] declareSamplersIO _ False = [] declareSamplersIO sys True = concatMap declSamplerIO $ typeList sys -declSamplerIO :: String -> [Decl]+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"]]+ body = constructSamplerIO genName t -constructSamplerIO :: String -> Exp-constructSamplerIO = constructSamplerIO' samplerName+constructSamplerIO :: (a -> String) -> a -> Exp ()+constructSamplerIO f t = applyF (varExp "runRIO")+ [applyF (varExp genericSamplerName)+ [varExp (f t),+ varExp "lb",+ varExp "ub"]] -declareListSamplersIO :: PSystem Double -> Bool -> Bool -> [Decl]+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 :: 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+ where type' = samplerIOType (TyList () $ typeCons t)+ body = constructSamplerIO listGenName t
Data/Boltzmann/Compiler/Haskell/Helpers.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Compiler.Haskell.Helpers- Description : Helper methods for ghc-7.10.3 compiler syntax.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Description : Helper methods for GHC syntax.+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -12,130 +12,223 @@ 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]+systemNote :: PSystem Double -> String -> [String]+systemNote psys t = ["-- | System: " ++ p,+ "-- | System type: " ++ t,+ "-- | Stability: experimental"]+ where sys = system psys+ p = "(Types: " ++ show n ++ ", Constr: " ++ show m ++ ")" m = constructors sys n = size sys -unname :: String -> QName-unname = UnQual . Ident+unname :: String -> QName ()+unname = UnQual () . Ident () -typeCons :: String -> Type-typeCons = TyCon . unname+typeCons :: String -> Type ()+typeCons = TyCon () . unname -typeVar :: String -> Type-typeVar = TyVar . Ident+typeVar :: String -> Type ()+typeVar = TyVar () . Ident () -varExp :: String -> Exp-varExp = Var . unname+varExp :: String -> Exp ()+varExp = Var () . unname -conExp :: String -> Exp-conExp = Con . unname+qVarExp :: String -> String -> Exp ()+qVarExp m s = Var () $ Qual () (ModuleName () m) (Ident () s) -toLit :: Int -> Exp-toLit = Lit . Int . toInteger+conExp :: String -> Exp ()+conExp = Con () . unname -importType :: String -> ImportSpec-importType = IThingAll . Ident+spliceExp :: Exp () -> Exp ()+spliceExp = SpliceExp () . ParenSplice () -importFunc :: String -> ImportSpec-importFunc = IVar . Ident+toLit :: Int -> Exp ()+toLit n = Lit () (Int () (toInteger n) (show n)) +importType :: String -> ImportSpec ()+importType = IThingAll () . Ident ()++importType' :: String -> ImportSpec ()+importType' = IAbs () (NoNamespace ()). 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)- }+importFrom :: String -> [ImportSpec ()] -> ImportDecl ()+importFrom module' specs =+ ImportDecl { importAnn = ()+ , importModule = ModuleName () module'+ , importQualified = False+ , importSrc = False+ , importSafe = False+ , importPkg = Nothing+ , importAs = Nothing+ , importSpecs = Just $ ImportSpecList () False specs+ } -exportType :: String -> ExportSpec-exportType = EThingAll . unname+importQual :: String -> String -> ImportDecl ()+importQual module' synonym =+ ImportDecl { importAnn = ()+ , importModule = ModuleName () module'+ , importQualified = True+ , importSrc = False+ , importSafe = False+ , importPkg = Nothing+ , importAs = Just (ModuleName () synonym)+ , importSpecs = Nothing+ } -exportTypes :: PSystem Double -> [ExportSpec]+exportType :: String -> ExportSpec ()+exportType s = EThingWith () (NoWildcard ()) (unname s) []++exportTypes :: PSystem Double -> [ExportSpec ()] exportTypes sys = map exportType $ typeList sys -exportFunc :: String -> ExportSpec-exportFunc = EVar . unname+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+declTFun :: String -> Type () -> [String] -> Exp () -> [Decl ()]+declTFun f type' args' body = [decl, FunBind () [main]]+ where decl = TypeSig () [Ident () f] type'+ args'' = map (PVar () . Ident ()) args'+ main = Match () (Ident () f) args'' (UnGuardedRhs () body) Nothing -symbol :: String -> QOp-symbol s = QVarOp $ UnQual (Symbol s)+symbol :: String -> QOp ()+symbol s = QVarOp () $ UnQual () (Symbol () s) -greater :: Exp -> Exp -> Exp-greater x = InfixApp x (symbol ">")+greater :: Exp () -> Exp () -> Exp ()+greater x = InfixApp () x (symbol ">") -less :: Exp -> Exp -> Exp-less x = InfixApp x (symbol "<")+less :: Exp () -> Exp () -> Exp ()+less x = InfixApp () x (symbol "<") -and :: Exp -> Exp -> Exp-and x = InfixApp x (symbol "&&")+and :: Exp () -> Exp () -> Exp ()+and x = InfixApp () x (symbol "&&") -lessEq :: Exp -> Exp -> Exp-lessEq 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))+toDouble :: Double -> Exp ()+toDouble x = Lit () $ Frac () (toRational x) (show (toRational x)) -bind :: String -> Exp -> Stmt-bind v = Generator noLoc (PVar $ Ident v)+toString :: String -> Exp ()+toString s = Lit () $ String () s s -bindP :: String -> String -> Exp -> Stmt-bindP x y = Generator noLoc (PTuple Boxed [PVar (Ident x), PVar (Ident y)])+lessF :: Real a => Exp () -> a -> Exp ()+lessF v x = less v (Lit () (Frac () (toRational x) (show (toRational x)))) -sub :: Exp -> Exp -> Exp-sub x (Lit (Int 0)) = x-sub x y = InfixApp x (symbol "-") y+bind :: String -> Exp () -> Stmt ()+bind v = Generator () (PVar () $ Ident () v) -add :: Exp -> Exp -> Exp-add x (Lit (Int 0)) = x-add (Lit (Int 0)) x = x-add x y = InfixApp x (symbol "+") y+bindP :: String -> String -> Exp () -> Stmt ()+bindP x y = Generator ()+ (PTuple () Boxed [PVar () (Ident () x), PVar () (Ident () y)]) -applyF :: Exp -> [Exp] -> Exp-applyF = foldl App+sub :: Exp () -> Exp () -> Exp ()+sub x (Lit () (Int () 0 "0")) = x+sub x y = InfixApp () x (symbol "-") y -dot :: Exp -> Exp -> Exp-dot x = InfixApp x (symbol ".")+add :: Exp () -> Exp () -> Exp ()+add x (Lit () (Int () 0 "0")) = x+add (Lit () (Int () 0 "0")) x = x+add x y = InfixApp () x (symbol "+") y -declareADTs :: Bool -> PSystem a -> [Decl]-declareADTs withShow sys = map (declADT withShow) $ paramTypes sys+applyF :: Exp () -> [Exp ()] -> Exp ()+applyF = foldl (App ()) -declADT :: Bool -> (String, [Cons a]) -> Decl-declADT withShow (t,[con]) = DataDecl noLoc flag [] (Ident t) []- [QualConDecl noLoc [] [] (declCon con)]- [(unname "Show", []) | withShow]+dot :: Exp () -> Exp () -> Exp ()+dot x = InfixApp () x (symbol ".") - -- generate a newtype or data type?- where flag = if length (args con) == 1 then NewType- else DataType+declareADTs :: Bool -> PSystem a -> [Decl ()]+declareADTs withShow sys =+ map (declADT withShow) $ paramTypes sys -declADT withShow (t,cons) = DataDecl noLoc DataType [] (Ident t) []- (map (QualConDecl noLoc [] [] . declCon) cons)- [(unname "Show", []) | withShow]+declADT :: Bool -> (String, [Cons a]) -> Decl ()+declADT withShow (t,[con]) = DataDecl () flag Nothing (DHead () (Ident () t))+ [QualConDecl () Nothing Nothing (declCon con)]+ [Deriving () Nothing [IRule () Nothing Nothing+ (IHCon () (unname "Show"))] | withShow] -declCon :: Cons a -> ConDecl-declCon expr = ConDecl (Ident $ func expr) ags+ -- generate a newtype or data type?+ where flag = if length (args con) == 1 then NewType ()+ else DataType ()++declADT withShow (t,cons) = DataDecl () (DataType ()) Nothing (DHead () (Ident () t))+ (map (QualConDecl () Nothing Nothing . declCon) cons)+ [Deriving () Nothing [IRule () Nothing Nothing+ (IHCon () (unname "Show"))] | withShow]++declCon :: Cons a -> ConDecl ()+declCon expr = ConDecl () (Ident () $ func expr) ags where ags = map declArg (args expr) -declArg :: Arg -> Type+declArg :: Arg -> Type () declArg (Type s) = typeVar s-declArg (List s) = TyList $ typeVar s+declArg (List s) = TyList () $ typeVar s++caseAlt :: String -> Rhs () -> Alt ()+caseAlt n rhs =+ Alt () (PVar () $ Ident () n) rhs Nothing++caseAlt' :: Rhs () -> Alt ()+caseAlt' rhs =+ Alt () (PWildCard ()) rhs Nothing++caseInt :: String -> [(Int, Rhs () )] -> Exp ()+caseInt n xs = Case () (varExp n) (caseInt' xs)++caseInt' :: [(Int, Rhs ())] -> [Alt ()]+caseInt' [] = error "Absurd case"+caseInt' [(_,rhs)] = [caseAlt' rhs]+caseInt' ((n,rhs) : xs) = x : caseInt' xs+ where x = caseAlt (show n) rhs++-- Utils.+maybeT' :: Type ()+maybeT' = typeCons "MaybeT"++buffonMachine' :: Type ()+buffonMachine' = typeCons "BuffonMachine"++int' :: Type ()+int' = typeCons "Int"++g' :: Type ()+g' = typeVar "g"++randomGen' :: QName ()+randomGen' = unname "RandomGen"++return' :: Exp ()+return' = varExp "return"++double' :: Type ()+double' = typeCons "Double"++nat :: [String]+nat = map show ([0..] :: [Integer])++variableStream :: [String]+variableStream = map ('x' :) nat++weightStream :: [String]+weightStream = map ('w' :) nat++decisionTreeType :: Type ()+decisionTreeType = TyForall () Nothing Nothing+ (TyApp () (typeCons "DecisionTree") int')++probList :: [(Cons Double, Int)] -> [Exp ()]+probList = map (\x -> Lit () (Frac () (f x) (show (f x))))+ where f = toRational . weight . fst++choiceN :: String -> Exp () -> Stmt ()+choiceN v s = bind v $ applyF (varExp "lift")+ [applyF (varExp "choice") [s]]
Data/Boltzmann/Compiler/Haskell/Rational.hs view
@@ -1,16 +1,17 @@ {-|- Module : Data.Boltzmann.Compiler.Haskell.Rational- Description : Rational Boltzmann system compiler for ghc-7.10.3.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Module : Data.Boltzmann.Compiler.Haskell.Matrix+ Description : Rational Boltzmann system compiler for GHC.+ Copyright : (c) Maciej Bendkowski, 2017-2019 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.+ Transition matrix system compiler for rational specifications.+ The outcome sampler is a rejection-based sampler implementing the+ interruptible sampling scheme for strongly connected specifications.+ Internally, the system is represented as a adjacency-list graph with+ additional labels on edges (transition letters). -} module Data.Boltzmann.Compiler.Haskell.Rational ( Conf(..)@@ -19,11 +20,18 @@ ) where import Prelude hiding (and)-import Language.Haskell.Exts hiding (List)-import Language.Haskell.Exts.SrcLoc (noLoc) +import Language.Haskell.Exts hiding (List,Cons)+import qualified Language.Haskell.Exts as LHE++import qualified Data.Set as S+import qualified Data.Map.Strict as M++import Data.Maybe (fromMaybe)+ import Data.Boltzmann.System import Data.Boltzmann.Internal.Annotations+import Data.Boltzmann.Internal.Utils (getTime) import Data.Boltzmann.Compiler import Data.Boltzmann.Compiler.Haskell.Helpers@@ -33,262 +41,286 @@ , 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 module' compilerNote' =- let with = withBool (annotations $ system sys)+ let with = withBool (annotations $ system sys) in Conf { paramSys = sys , moduleName = module' , compileNote = compilerNote'- , withIO = "withIO" `with` True- , withShow = "withShow" `with` True+ , withIO = "withIO" `with` True } compile conf = let sys = paramSys conf name' = moduleName conf note = compileNote conf withIO' = withIO conf- withShow' = withShow conf- module' = compileModule sys name'- withIO' withShow'+ module' = compileModule sys name' withIO' in do- putStr $ moduleHeader sys note+ time <- getTime+ putStr $ moduleHeader sys note time putStrLn $ prettyPrint module' -moduleHeader :: PSystem Double -> String -> String-moduleHeader sys compilerNote =- unlines (["-- | Compiler: " ++ compilerNote,- "-- | Singularity: " ++ show (param sys),- "-- | System type: rational"] ++ systemNote sys)+moduleHeader :: PSystem Double -> String -> String -> String+moduleHeader sys compilerNote time =+ unlines (["-- | Compiler: " ++ compilerNote,+ "-- | Generated at: " ++ time,+ "-- | Singularity: " ++ show (param sys)]+ ++ systemNote sys (show Rational)) -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'+compileModule :: PSystem Double -> String -> Bool -> Module ()+compileModule sys mod' withIO' =+ Module ()+ (Just $ ModuleHead () (ModuleName () mod') Nothing+ (Just . ExportSpecList () $ declareExports withIO'))+ [LanguagePragma () [Ident () "TemplateHaskell"]]+ (declareImports withIO')+ (decls sys withIO') -declareImports :: Bool -> [ImportDecl]+declareExports :: Bool -> [ExportSpec ()]+declareExports withIO' =+ exportFunc "sampleWord"+ : exportFunc "startingState"+ : [exportFunc "sampleWordIO" | 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')]+ importFrom "Data.Buffon.Machine" ([importType' "BuffonMachine",+ importType "DecisionTree",+ importFunc "decisionTree",+ importFunc "choice"]+ ++ importIO withIO'), -importIO :: Bool -> [ImportSpec]-importIO False = []-importIO True = [importFunc "evalRandIO"]+ importQual "Language.Haskell.TH.Syntax" "TH", --- Naming functions.-genName :: ShowS-genName = (++) "genRandom"+ importFrom "System.Random" [importType "RandomGen"]] -listGenName :: ShowS-listGenName t = genName t ++ "List"+importIO :: Bool -> [ImportSpec ()]+importIO withIO' = [importFunc "runRIO" | withIO'] -samplerName :: ShowS-samplerName = (++) "sample"+decls :: PSystem Double -> Bool -> [Decl ()]+decls sys withIO' = symbolDecl :+ declWeight sys+ ++ declSymb sys+ ++ declDecisionTrees sys+ ++ declTerminals sys+ ++ declGraph sys+ ++ declGen+ ++ declSampler+ ++ declStartingState sys+ ++ concat [declSamplerIO | withIO'] -samplerIOName :: ShowS-samplerIOName t = samplerName t ++ "IO"+-- | Type synonym for alphabet letters.+symbolDecl :: Decl ()+symbolDecl = TypeDecl () (DHead () (Ident () "Symbol")) (TyCon () $ unname "String") -declareExports :: PSystem Double -> Bool -> [ExportSpec]-declareExports sys withIO' =- exportTypes sys ++- exportGenerators sys ++- exportSamplers sys ++- exportSamplersIO sys withIO'+-- | Converts the given system into+-- corresponding a graph representation.+toGraph :: PSystem Double -> [[(Int, Int)]]+toGraph sys = map (typeAdj $ types sys') typs+ where typs = M.toList (defs sys')+ sys' = system sys+ lts = alphabet sys' -exportGenerators :: PSystem Double -> [ExportSpec]-exportGenerators sys = map (exportFunc . genName) $ typeList sys+ typeAdj typs' (_, cons) = map (consAdj typs') cons -exportSamplers :: PSystem Double -> [ExportSpec]-exportSamplers sys = map (exportFunc . samplerName) $ typeList sys+ -- | Assigns the given constructor a reference index,+ -- pointing to the following node (type).+ typeIdx typs' con+ | isAtomic con = -1 -- note: epsilon transition.+ | otherwise = let typ = argName (head $ args con)+ in typ `S.findIndex` typs' -exportSamplersIO :: PSystem Double -> Bool -> [ExportSpec]-exportSamplersIO _ False = []-exportSamplersIO sys True = map (exportFunc . samplerIOName) $ typeList sys+ consAdj typs' con = (n, w)+ where a = func con -- note: that's in fact the transition letter.+ n = typeIdx typs' con+ w = fromMaybe (-1) (a `lookupLetter` lts) --- Utils.-maybeT' :: Type-maybeT' = typeCons "MaybeT"+buffonMachineType :: Type ()+buffonMachineType = typeCons "BuffonMachine" -rand' :: Type-rand' = typeCons "Rand"+maybeTType :: Type () -> Type ()+maybeTType = TyApp () (TyApp () maybeT' (TyApp () buffonMachineType g')) -int' :: Type-int' = typeCons "Int"+letters :: PSystem Double -> [Letter]+letters = S.toList . alphabet . system -g' :: Type-g' = typeVar "g"+getWeights :: Int -> [Letter] -> [(Int, Rhs ())]+getWeights n (s : xs) = (n, UnGuardedRhs () $ toLit (weightL s)) : xs'+ where xs' = getWeights (succ n) xs -randomGen' :: QName-randomGen' = unname "RandomGen"+getWeights _ _ = [] -return' :: Exp-return' = varExp "return"+getSymbols :: Int -> [Letter] -> [(Int, Rhs ())]+getSymbols n (s : xs) = (n, UnGuardedRhs () $ toString (symb s)) : xs'+ where xs' = getSymbols (succ n) xs -nat :: [String]-nat = map show ([0..] :: [Integer])+getSymbols _ _ = [] -variableStream :: [String]-variableStream = map ('x' :) nat+-- | Symbol weights.+declWeight :: PSystem Double -> [Decl ()]+declWeight sys = declTFun "weight" type' ["n"] body+ where type' = TyFun () int' int'+ body = caseInt "n" $ getWeights 0 (letters sys) -weightStream :: [String]-weightStream = map ('w' :) nat+-- | Symbol strings.+declSymb :: PSystem Double -> [Decl ()]+declSymb sys = declTFun "symbol" type' ["n"] body+ where type' = TyFun () int' (typeCons "Symbol")+ body = caseInt "n" $ getSymbols 0 (letters sys) --- Generators.-maybeTType :: Type -> Type-maybeTType = TyApp (TyApp maybeT' (TyApp rand' g'))+getDecisionTree :: (String, [(Cons Double, Int)]) -> Exp ()+getDecisionTree (_, g) = spliceExp lift'+ where lift' = applyF (qVarExp "TH" "lift") [dt']+ dt' = applyF (varExp "decisionTree") [prob]+ prob = LHE.List () (init $ probList g) -generatorType :: Type -> Type-generatorType type' = TyForall Nothing- [ClassA randomGen' [g']]- (TyFun int' (maybeTType $ TyTuple Boxed [type', int']))+getDecitionTrees :: Int -> [(String, [(Cons Double, Int)])] -> [(Int, Rhs ())]+getDecitionTrees n (s : xs) = (n, UnGuardedRhs () $ getDecisionTree s) : xs'+ where xs' = getDecitionTrees (succ n) xs -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]))+getDecitionTrees _ _ = [] -randomP :: String -> Stmt-randomP v = bind v $ varExp "randomP"+declDecisionTrees :: PSystem Double -> [Decl ()]+declDecisionTrees sys = declTFun "decisionTrees" type' ["s"] body+ where type' = TyFun () int' decisionTreeType+ body = caseInt "s" $ getDecitionTrees 0 (paramTypesW sys) -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'+getTerminals :: Int -> [(String, [(Cons Double, Int)])] -> [(Int, Rhs ())]+getTerminals n (s : xs) = (n, UnGuardedRhs () $ getTerminal s) : xs'+ where xs' = getTerminals (succ n) xs -declareGenerators :: PSystem Double -> [Decl]-declareGenerators sys =- declRandomP ++- concatMap declGenerator (paramTypesW sys)+getTerminals _ _ = [] -declGenerator :: (String, [(Cons Double, Int)]) -> [Decl]-declGenerator (t, g) = declTFun (genName t) type' ["ub"] body- where type' = generatorType $ typeCons t- body = constrGenerator g+getTerminal :: (String, [(Cons Double, Int)]) -> Exp ()+getTerminal (_, g)+ | any (isAtomic . fst) g = conExp "True"+ | otherwise = conExp "False" -atoms :: [(Cons Double, Int)] -> [(Cons Double, Int)]-atoms = filter (isAtomic . fst)+declTerminals :: PSystem Double -> [Decl ()]+declTerminals sys = declTFun "isTerminal" type' ["s"] body+ where type' = TyForall () Nothing Nothing (TyFun () int' (typeCons "Bool"))+ body = caseInt "s" $ getTerminals 0 (paramTypesW sys) -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+declGraph :: PSystem Double -> [Decl ()]+declGraph sys = declTFun "transitionMatrix" type' ["n", "m"] body+ where type' = TyForall () Nothing Nothing (TyFun () int'+ (TyFun () int' (TyTuple () Boxed [int', int']))) -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!"+ graph = toGraph sys+ body = caseInt "n" [(i, UnGuardedRhs () $ getNeighbourhood (graph !! i))+ | i <- [0..pred (length graph)]] -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+getNeighbourhood :: [(Int, Int)] -> Exp ()+getNeighbourhood xs =+ caseInt "m" (getNeighbourhood' 0 xs) +getNeighbourhood' :: Int -> [(Int, Int)] -> [(Int, Rhs ())]+getNeighbourhood' n ((k,w) : xs) = (n, UnGuardedRhs () p) : xs'+ where xs' = getNeighbourhood' (succ n) xs+ p = Tuple () Boxed [toLit k, toLit w] -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+getNeighbourhood' _ _ = [] -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!"+declGen :: [Decl ()]+declGen = declTFun "genWord" type' ["ub", "s", "acc", "ct"] mainIfStmt+ where type' = TyForall () Nothing (Just $ CxTuple () [ClassA () randomGen' [g']])+ (TyFun () int' $ TyFun () int' $ TyFun () (TyList () $ typeCons "Symbol")+ $ TyFun () int' (maybeTType $ TyTuple () Boxed+ [TyList () $ typeCons "Symbol", int'])) -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+ mainIfStmt = If () (varExp "ub" `lessEq` toLit 0+ `and` applyF (varExp "isTerminal") [varExp "s"])+ (App () return' (Tuple () Boxed [varExp "acc", varExp "ct"]))+ mainBody --- Samplers.-samplerType :: Type -> Type-samplerType type' = TyForall Nothing- [ClassA randomGen' [g']]- (TyFun int'- (TyFun int'- (TyApp (TyApp rand' g') type')))+ mainBody = Do () [ choiceStmt+ , getNext+ , ifStmt] -declareSamplers :: PSystem Double -> [Decl]-declareSamplers sys = concatMap declSampler $ typeList sys+ choiceStmt = choiceN "n" (applyF (varExp "decisionTrees") [varExp "s"]) -declSampler :: String -> [Decl]-declSampler t = declTFun (samplerName t) type' ["lb","ub"] body- where type' = samplerType (typeCons t)- body = constructSampler t+ getNext = LetStmt () (BDecls () [getNext'])+ getNext' = PatBind ()+ (PTuple () Boxed [PVar () $ Ident () "s'", PVar () $ Ident () "i"])+ (UnGuardedRhs () $ applyF (varExp "transitionMatrix")+ [varExp "s", varExp "n"]) Nothing -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]+ ifStmt = Qualifier () $ If () (less (varExp "s'") (toLit 0))+ (App () return' (Tuple () Boxed [varExp "acc", varExp "ct"])) elseStmt - 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'+ elseStmt = Do () [ bindSymbol+ , recursiveCall] -constructSampler :: String -> Exp-constructSampler = constructSampler' genName samplerName+ bindSymbol = LetStmt () (BDecls () [bindSymbol'])+ bindSymbol' = PatBind ()+ (PTuple () Boxed [PVar () $ Ident () "a", PVar () $ Ident () "w"])+ (UnGuardedRhs () $+ Tuple () Boxed [ applyF (varExp "symbol") [varExp "i"]+ , applyF (varExp "weight") [varExp "i"]])+ Nothing --- IO Samplers.-samplerIOType :: Type -> Type-samplerIOType type' = TyForall Nothing- [] (TyFun int' (TyFun int' (TyApp (typeVar "IO") type')))+ recursiveCall = Qualifier () $ applyF (varExp "genWord")+ [varExp "ub" `sub` varExp "w", varExp "s'",+ InfixApp () (varExp "a") (symbol ":") (varExp "acc"),+ varExp "w" `add` varExp "ct"] -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+declSampler :: [Decl ()]+declSampler = declTFun "sampleWord" type' ["lb", "ub", "s"] constructSampler+ where type' = TyForall () Nothing (Just $ CxTuple () [ClassA () randomGen' [g']])+ (TyFun () int' $ TyFun () int' $ TyFun () int' $ TyApp () (TyApp () buffonMachineType g')+ (TyList () $ typeCons "Symbol")) -constructSamplerIO' :: (t -> String) -> t -> Exp-constructSamplerIO' sam t = applyF (varExp "evalRandIO")- [applyF (varExp $ sam t) [varExp "lb",- varExp "ub"]]+constructSampler :: Exp ()+constructSampler =+ Do () [bind "str" (applyF (varExp "runMaybeT")+ [applyF (varExp "genWord") [varExp "lb", varExp "s", LHE.List () [], toLit 0]]),+ caseSample]+ where caseSample = Qualifier () $ Case () (varExp "str")+ [Alt () (PApp () (unname "Nothing") [])+ (UnGuardedRhs () rec') Nothing,+ Alt () (PApp () (unname "Just")+ [PTuple () Boxed [PVar () $ Ident () "w",+ PVar () $ Ident () "n"]])+ (UnGuardedRhs () return'') Nothing] -constructSamplerIO :: String -> Exp-constructSamplerIO = constructSamplerIO' samplerName+ rec' = applyF (varExp "sampleWord") [varExp "lb", varExp "ub", varExp "s"]+ return'' = If () (lessEq (varExp "lb") (varExp "n") `and` lessEq (varExp "n") (varExp "ub"))+ (applyF (varExp "return") [varExp "w"])+ rec'++declSamplerIO :: [Decl ()]+declSamplerIO = declTFun "sampleWordIO" type' ["lb","ub", "s"] body+ where body = constructSamplerIO+ type' = TyForall () Nothing Nothing+ (TyFun () int' (TyFun () int'+ (TyFun () int'+ (TyApp () (typeVar "IO")+ (TyList () $ typeCons "Symbol")))))++constructSamplerIO :: Exp ()+constructSamplerIO = applyF (varExp "runRIO")+ [applyF (varExp "sampleWord")+ [varExp "lb"+ ,varExp "ub"+ ,varExp "s"]]++-- | Finds the starting state for the sampler.+startingState :: PSystem Double -> Int+startingState sys =+ gen `S.findIndex` types sys'+ where sys' = system sys+ ann' = annotations sys'+ gen = withString ann' "generate" (initType sys')++declStartingState :: PSystem Double -> [Decl ()]+declStartingState sys = declTFun "startingState" type' [] body+ where body = toLit (startingState sys)+ type' = TyForall () Nothing Nothing int'
Data/Boltzmann/Internal/Annotations.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Internal.Annotations Description : System annotation utilities.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl
Data/Boltzmann/Internal/Logging.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Internal.Logging Description : Basic logging utilities.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -22,21 +22,12 @@ import Prelude hiding (log, fail) -import Data.Time.Clock-import Data.Time.LocalTime-import Data.Time.Format- import System.IO import System.Exit import System.Console.Pretty -getTime :: IO String-getTime = do- now <- getCurrentTime- timeZone <- getCurrentTimeZone- let t = utcToLocalTime timeZone now- return $ formatTime defaultTimeLocale "%d-%m-%Y %H:%M:%S" t+import Data.Boltzmann.Internal.Utils data Level = Info | Warning@@ -44,9 +35,9 @@ | Error instance Show Level where- show Info = "INFO"- show Warning = "WARN"- show Hint = "HINT"+ show Info = "INF"+ show Warning = "WAR"+ show Hint = "TIP" show Error = "ERR" lvlColor :: Level -> Color
Data/Boltzmann/Internal/Parser.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Internal.Parser Description : Parser utilities for combinatorial systems.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -12,10 +12,15 @@ module Data.Boltzmann.Internal.Parser ( sc + , identifierP+ , identifier+ , toFreq+ , lexeme , symbol , parens , brackets+ , setBrackets , integer , double @@ -26,14 +31,30 @@ , printError ) where -import System.IO-import System.Exit import Control.Monad (void)-+import Data.Void+import System.Exit+import System.IO import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L +type Parser = Parsec Void String++-- | 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+ -- | Cut-out block and line comments parser. sc :: Parser () sc = L.space (void spaceChar) lineCmnt blockCmnt@@ -56,11 +77,13 @@ brackets :: Parser a -> Parser a brackets = between (symbol "[") (symbol "]") +-- | Curly brackets parser.+setBrackets :: Parser a -> Parser a+setBrackets = between (symbol "{") (symbol "}")+ -- | Integer parser. integer :: Parser Int-integer = lexeme $ do- n <- L.integer- return $ fromIntegral n+integer = lexeme L.decimal -- | Double parser. double :: Parser Double@@ -85,14 +108,14 @@ -- | Uses an input file for parsing. parseFromFile :: Parsec e String a -> String- -> IO (Either (ParseError Char e) a)+ -> IO (Either (ParseErrorBundle String e) a) parseFromFile p file = runParser p file <$> readFile file -- | Prints the given parsing errors.-printError :: (ShowToken t, Ord t, ShowErrorComponent e)- => ParseError t e -> IO a+printError :: (Stream t, ShowErrorComponent e)+ => ParseErrorBundle t e -> IO a printError err = do- hPutStr stderr $ parseErrorPretty err+ hPutStr stderr $ errorBundlePretty err exitWith (ExitFailure 1)
+ Data/Boltzmann/Internal/TH.hs view
@@ -0,0 +1,24 @@+{-|+ Module : Data.Boltzmann.Internal.TH+ Description : Template haskell utilities.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ General template haskell utilities.+ -}+module Data.Boltzmann.Internal.TH+ ( compileTime+ ) where++import Language.Haskell.TH++import Data.Boltzmann.Internal.Utils (getTime)++-- | Compile-time date.+compileTime :: Q Exp+compileTime = do+ t <- runIO getTime+ litE (StringL t)
+ Data/Boltzmann/Internal/Tuner.hs view
@@ -0,0 +1,69 @@+{-|+ Module : Data.Boltzmann.Internal.Tuner+ Description : General interface utilities for Paganini.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental+ -}+module Data.Boltzmann.Internal.Tuner+ ( PArg(..)+ , toArgs+ , getArgs+ , defaultArgs++ , PSpec(..)+ , Parametrisation(..)+ ) where++import Data.Maybe++import Data.Boltzmann.System++-- | Paganini arguments.+data PArg = PArg { precision :: Double+ , maxiters :: Int+ , sysType :: SystemType+ } deriving (Show)++toArgs :: PArg -> [String]+toArgs arg = ["--from-stdin"+ ,"-p", show (precision arg)+ ,"-m", show (maxiters arg)+ ,"-t", show (sysType arg)]++rationalArgs :: PArg+rationalArgs = PArg { precision = 1.0e-20+ , maxiters = 2500+ , sysType = Rational+ }++algebraicArgs :: PArg+algebraicArgs = PArg { precision = 1.0e-20+ , maxiters = 250+ , 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"++getArgs :: System Int -> Maybe PArg -> PArg+getArgs sys = fromMaybe (defaultArgs sys)++-- | Paganini helper specification.+data PSpec = PSpec { numFreqs :: Int+ , numTypes :: Int+ , numSeqTypes :: Int+ } deriving (Show)++-- | Parametrisation type.+data Parametrisation = Cummulative -- ^ Cummulative branching probabilities.+ | Regular -- ^ Independent probability masses.
Data/Boltzmann/Internal/Utils.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.Internal.Utils Description : General utilities for boltzmann-brain.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -20,10 +20,43 @@ , boldColor , csv++ , getTime++ , writeListLn+ , printer+ , showsList ) where +import System.IO+ import System.Console.Pretty import Text.EditDistance++import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.Format++getTime :: IO String+getTime = do+ now <- getCurrentTime+ timeZone <- getCurrentTimeZone+ let t = utcToLocalTime timeZone now+ return $ formatTime defaultTimeLocale "%d-%m-%Y %H:%M:%S" t++writeListLn :: Show a => Handle -> [a] -> IO ()+writeListLn h xs = hPutStrLn h (showsList xs)++printer :: (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+ -- | Produces a comma separated value (csv) representation -- of the given list of string. Note that after each comma
Data/Boltzmann/System.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System Description : System utilities for combinatorial specifications.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -11,7 +11,16 @@ -} {-# LANGUAGE OverloadedStrings #-} module Data.Boltzmann.System- ( System(..)+ ( Alphabet+ , Letter(..)+ , Format(..)+ , isAlgebraicF+ , isRationalF+ , letterFreq+ , letterWeight+ , lookupLetter++ , System(..) , size , constructors , Cons(..)@@ -29,6 +38,8 @@ , SystemType(..) , systemType+ , isAlgebraic+ , isRational , hasAtoms , isAtomic @@ -58,23 +69,89 @@ import Data.Aeson +import Data.Boltzmann.System.Annotations++-- | Set of letters with auxiliary frequencies.+-- Note: Used for rational specification only.+type Alphabet = Set Letter++-- | Letter symbols with optional frequencies.+data Letter = Letter { symb :: String+ , freq :: Maybe Double+ , weightL :: Int+ } deriving (Show,Eq)++-- | Given a string and an alphabet, finds+-- the corresponding letter frequency.+letterFreq :: String -> Alphabet -> Maybe Double+letterFreq s alph =+ let x = Letter { symb = s, freq = Nothing, weightL = 0 }+ in case x `S.lookupIndex` alph of+ Nothing -> Nothing+ Just idx -> freq (idx `S.elemAt` alph)++-- | Given a string and an alphabet, finds+-- the corresponding letter weight.+letterWeight :: String -> Alphabet -> Maybe Int+letterWeight s alph =+ let x = Letter { symb = s, freq = Nothing, weightL = 0 }+ in case x `S.lookupIndex` alph of+ Nothing -> Nothing+ Just idx -> Just $ weightL (idx `S.elemAt` alph)++-- | Given a string and an alphabet, finds+-- the corresponding letter index.+lookupLetter :: String -> Alphabet -> Maybe Int+lookupLetter s alph =+ let x = Letter { symb = s, freq = Nothing, weightL = 0 }+ in x `S.lookupIndex` alph++instance Ord Letter where+ compare a b = compare (symb a) (symb b) -- ignore frequencies.++instance ToJSON Letter where+ toJSON letter = object ["symbol" .= symb letter+ ,"freq" .= freq letter+ ,"weight" .= weightL letter+ ]++-- | Input specification format.+data Format = AlgebraicF+ | RationalF++instance Show Format where+ show AlgebraicF = "algebraic"+ show RationalF = "rational"++isAlgebraicF :: Format -> Bool+isAlgebraicF AlgebraicF = True+isAlgebraicF _ = False++isRationalF :: Format -> Bool+isRationalF = not . isAlgebraicF+ -- | System of combinatorial structures.-data System a = System { defs :: Map String [Cons a] -- ^ Type definitions.- , annotations :: Map String String -- ^ System annotations.+data System a = System { defs :: Map String [Cons a] -- ^ Type definitions.+ , alphabet :: Alphabet -- ^ System alphabet.+ , annotations :: Annotations -- ^ System annotations. } deriving (Show) -newtype SystemT a = SystemT { systemTypes :: [TypeT a] }- deriving (Show)+data SystemT a = SystemT { systemTypes :: [TypeT a]+ , systemAlphabet :: Alphabet+ , systemAnnotations :: Annotations+ } deriving (Show) instance ToJSON a => ToJSON (SystemT a) where- toJSON sys = object ["types" .= systemTypes sys]+ toJSON sys = object ["types" .= systemTypes sys+ ,"alphabet" .= systemAlphabet sys+ ,"annotations" .= systemAnnotations sys] data TypeT a = TypeT { typeName :: String , constrs :: [ConsT a] } deriving (Show) instance ToJSON a => ToJSON (TypeT a) where- toJSON t = object ["name" .= typeName t+ toJSON t = object ["name" .= typeName t ,"constructors" .= constrs t ] @@ -96,13 +173,17 @@ } deriving (Show) instance ToJSON ArgT where- toJSON t = object ["name" .= argumentName t- ,"type" .= argumentType t+ toJSON t = object ["name" .= argumentName t+ ,"type" .= argumentType t ] -- | Converts a given system to an output format. toSystemT :: System a -> SystemT a-toSystemT sys = SystemT { systemTypes = map toTypeT (M.toList $ defs sys) }+toSystemT sys =+ SystemT { systemTypes = map toTypeT (M.toList $ defs sys)+ , systemAlphabet = alphabet sys+ , systemAnnotations = annotations sys+ } toTypeT :: (String, [Cons a]) -> TypeT a toTypeT (t, cons) = TypeT { typeName = t@@ -215,6 +296,14 @@ show Algebraic = "algebraic" show (Unsupported _) = "unsupported" +isAlgebraic :: SystemType -> Bool+isAlgebraic Algebraic = True+isAlgebraic _ = False++isRational :: SystemType -> Bool+isRational Rational = True+isRational _ = False+ -- | Determines the system type. systemType :: System a -> SystemType systemType sys@@ -258,7 +347,7 @@ 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.+-- | Determines whether each constructor in 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)
+ Data/Boltzmann/System/Annotations.hs view
@@ -0,0 +1,42 @@+{-|+ Module : Data.Boltzmann.System.Annotations+ Description : Annotation utilities for combinatorial samplers.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental+ -}+module Data.Boltzmann.System.Annotations+ ( Annotations+ , annotationParser+ ) where++import Data.Map (Map)++import Text.Megaparsec+import Text.Megaparsec.Char+import Data.Void++import Data.Boltzmann.Internal.Parser++type Parser = Parsec Void String++annIdentifier :: Parser String+annIdentifier = identifierP (char '@') some++annValue :: Parser String+annValue = lexeme $ some (alphaNumChar <|> punctuationChar)++-- | System annotations.+annotationStmt :: Parser (String, String)+annotationStmt = do+ lhs <- annIdentifier+ rhs <- annValue+ return (tail lhs, rhs) -- note: dropping the leading '@'++annotationParser :: Parser [(String, String)]+annotationParser = many annotationStmt++-- | System annotations.+type Annotations = Map String String
Data/Boltzmann/System/Errors.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System.Errors Description : Various error handling utilities.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -170,8 +170,9 @@ wellFoundedErrors :: System Int -> [ErrorExt] wellFoundedErrors sys =- [ErrorExt WellFoundedError |- not (isEmptyAtZero sys) || not (wellFoundedAtZero sys)]+ -- note: do not check well-foundness of systems other than algebraic.+ [ErrorExt WellFoundedError | isAlgebraic (systemType sys) &&+ (not (isEmptyAtZero sys) || not (wellFoundedAtZero sys))] instance SystemErr WellFoundedError where report _ = "Given system is not well-founded at zero."@@ -202,7 +203,7 @@ -- | Unsupported system type. newtype SysTypeError = SysTypeError { sysTypeMsg :: String -- ^ System type message.- }+ } -- | Checks if the specification type is supported. supportedSystemType :: System a -> Either SysTypeError SystemType@@ -244,29 +245,31 @@ (exitWith $ ExitFailure 1) -- | Some trivial errors.-trivialErrors :: System a -> [ErrorExt]-trivialErrors sys+trivialErrors :: Format -> System a -> [ErrorExt]+trivialErrors format sys = concat [argRefErrors sys ,consRefErrors sys- ,clashConsErrors sys ,freqErrors sys ]+ ++ -- note: the following errors are inherent to algebraic specification formats.+ concat [clashConsErrors sys | isAlgebraicF format] -- | Some less trivial errors. otherErrors :: System Int -> [ErrorExt] otherErrors sys- = infLangErrors sys ++ wellFoundedErrors sys+ = infLangErrors sys+ ++ wellFoundedErrors sys -- | Checks whether the given input system is correct, yielding its type.--- Otherwise, terminate with an appropriate system error message.-errors :: Bool -> System Int -> IO SystemType-errors force sys =+-- Otherwise, terminates with an appropriate system error message.+errors :: Format -> Bool -> System Int -> IO SystemType+errors format force sys = if force then checkSysType $ supportedSystemType sys -- the force is strong with this one. else do checkErrors (annotationErrors sys $ annotations sys)- checkErrors (trivialErrors sys)+ checkErrors (trivialErrors format sys) checkErrors (otherErrors sys)- errors True sys+ errors format True sys annotationErrors :: System a -> Map String String -> [ErrorExt] annotationErrors sys ann
Data/Boltzmann/System/Parser.hs view
@@ -1,137 +1,27 @@ {-| Module : Data.Boltzmann.System.Parser- Description : Parser utilities for combinatorial systems.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Description : General system parsing utilities.+ Copyright : (c) Maciej Bendkowski, 2017-2019 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 ( parseSpec- , parseFileSpec ) where -import Control.Monad (void)- import Text.Megaparsec-import Text.Megaparsec.String--import qualified Data.Map.Strict as M+import Data.Void -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 from the given input file.-parseFileSpec :: String- -> IO (Either (ParseError Char Dec) (S.System Int))--parseFileSpec = parseFromFile systemStmt+import qualified Data.Boltzmann.System.Parser.Algebraic as A+import qualified Data.Boltzmann.System.Parser.Rational as R -- | Parses the given system specification.-parseSpec :: String- -> IO (Either (ParseError Char Dec) (S.System Int))+parseSpec :: S.Format -> String+ -> IO (Either (ParseErrorBundle String Void) (S.System Int)) -parseSpec s = return $ parse systemStmt "" s+parseSpec S.RationalF s = return $ parse R.systemStmt "" s+parseSpec S.AlgebraicF s = return $ parse A.systemStmt "" s
+ Data/Boltzmann/System/Parser/Algebraic.hs view
@@ -0,0 +1,103 @@+{-|+ Module : Data.Boltzmann.System.Parser.Algebraic+ Description : Parser utilities for algebraic specifications.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Parser utilities meant to deal with algebraic system specifications.+ -}+module Data.Boltzmann.System.Parser.Algebraic+ ( systemStmt+ ) where++import Control.Monad (void)++import Text.Megaparsec+import Data.Void++import qualified Data.Set as Z+import qualified Data.Map.Strict as M++import Data.Boltzmann.Internal.Parser+import qualified Data.Boltzmann.System as S++import Data.Boltzmann.System.Annotations++type Parser = Parsec Void String++-- | Algebraic system specification parser.+systemStmt :: Parser (S.System Int)+systemStmt = sc *> systemStmt' <* eof+ where systemStmt' = do+ an <- annotationParser+ ds <- some defsStmt+ return S.System { S.defs = M.fromList ds+ , S.annotations = M.fromList an+ , S.alphabet = Z.empty+ }++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
+ Data/Boltzmann/System/Parser/Rational.hs view
@@ -0,0 +1,97 @@+{-|+ Module : Data.Boltzmann.System.Parser.Rational+ Description : Parser utilities for rational systems.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental++ Parser utilities meant to deal with rational system specifications.+ -}+module Data.Boltzmann.System.Parser.Rational+ ( systemStmt+ ) where++import Control.Monad (void)++import Text.Megaparsec+import Text.Megaparsec.Char+import Data.Void++import qualified Data.Set as Z+import qualified Data.Map.Strict as M++import Data.Boltzmann.Internal.Parser+import qualified Data.Boltzmann.System as S++import Data.Boltzmann.System.Annotations++type Parser = Parsec Void String++-- | Rational system specification parser.+systemStmt :: Parser (S.System Int)+systemStmt = sc *> systemStmt' <* eof+ where systemStmt' = do+ an <- annotationParser+ alph <- alphabetStmt+ ds <- some (defsStmt alph)+ return S.System { S.defs = M.fromList ds+ , S.annotations = M.fromList an+ , S.alphabet = alph+ }++-- | Letter identifier.+letterIdent :: Parser String+letterIdent = lexeme $ some (alphaNumChar <|> char '_')++-- | Letter parser.+letterStmt :: Parser S.Letter+letterStmt = do+ letter <- letterIdent+ letterF <- option (-1.0) (symbol ":" >> double)+ letterW <- option (length letter) (parens integer)+ return S.Letter { S.symb = letter+ , S.freq = toFreq letterF+ , S.weightL = letterW+ }++-- | Alphabet specification parser.+alphabetStmt :: Parser S.Alphabet+alphabetStmt = do+ ls <- setBrackets $ letterStmt `sepBy1` symbol ","+ return $ Z.fromList ls++defsStmt :: S.Alphabet -> Parser (String, [S.Cons Int])+defsStmt alph = do+ t <- identifier+ void (symbol "->")+ exprs <- exprListStmt alph+ return (t, exprs)++exprListStmt :: S.Alphabet -> Parser [S.Cons Int]+exprListStmt alph = try (epsStmt <|> exprStmt alph) `sepBy1` symbol "|"++epsStmt :: Parser (S.Cons Int)+epsStmt = do+ void (symbol "_")+ return S.Cons { S.func = "_"+ , S.args = []+ , S.weight = 0+ , S.frequency = Nothing+ }++exprStmt :: S.Alphabet -> Parser (S.Cons Int)+exprStmt alph = do+ typ <- identifier+ letter <- option "" (parens letterIdent) -- potential epsilon transitions.+ let x = S.Letter { S.symb = letter, S.freq = Nothing, S.weightL = 0 }+ let w = case x `Z.lookupIndex` alph of+ Nothing -> 0 -- epsilon transitions or not existing symbols.+ Just idx -> S.weightL $ Z.elemAt idx alph++ return S.Cons { S.func = letter+ , S.args = [S.Type typ]+ , S.frequency = Nothing+ , S.weight = w+ }
Data/Boltzmann/System/Renderer.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System.Renderer Description : Simple graph rendering utilities for combinatorial structures.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl
Data/Boltzmann/System/Sampler.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System.Sampler Description : Sampler utilities for combinatorial systems.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl
Data/Boltzmann/System/Tuner.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System.Tuner Description : Interface utilities with the Paganini tuner.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -11,159 +11,75 @@ and the Paganini tuner script. -} module Data.Boltzmann.System.Tuner- ( PSolver(..)- , PArg(..)- , defaultArgs- , writeSpecification- , readPaganini+ ( readPaganini , runPaganini- , Parametrisation(..) ) where -import Control.Monad import Control.Exception -import System.IO-import System.Process hiding (system) -import Text.Megaparsec-import Text.Megaparsec.String+import Data.Void+import qualified Data.Map.Strict as M 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 System.IO -import Data.Maybe+import System.Process hiding (system)+import Text.Megaparsec -import Data.Boltzmann.System-import Data.Boltzmann.Internal.Parser import Data.Boltzmann.Internal.Logging+import Data.Boltzmann.Internal.Parser+import Data.Boltzmann.Internal.Tuner+import Data.Boltzmann.Internal.Utils+import Data.Boltzmann.System+import qualified Data.Boltzmann.System.Tuner.Algebraic as A+import qualified Data.Boltzmann.System.Tuner.Rational as R +type Parser = Parsec Void String+ -- | 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 = ["--from-stdin"- ,"-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"--writeListLn :: Show a => Handle -> [a] -> IO ()-writeListLn h xs = hPutStrLn h (showsList xs)--printer :: (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- info "Writing system 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--getArgs :: System Int -> Maybe PArg -> PArg-getArgs sys = fromMaybe (defaultArgs sys)- -- | 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 -> Parametrisation -> Maybe PArg- -> IO (Either (ParseError Char Dec)- (PSystem Double))+runPaganini :: Format+ -> System Int+ -> Parametrisation+ -> Maybe PArg+ -> IO (Either (ParseErrorBundle String Void) (PSystem Double)) -runPaganini sys paramT arg = do+runPaganini sysFormat sys paramT arg = do info "Running paganini..."+ let arg' = getArgs sys arg info (printer (++) $ "Arguments: " : toArgs arg') -- Execute the paganini tuning script.- pp <- try' $ createProcess (proc "paganini" (toArgs arg')){ std_out = CreatePipe- , std_in = CreatePipe }+ pp <- try' $ createProcess+ (proc "medulla" (toArgs arg'))+ { std_out = CreatePipe, std_in = CreatePipe } case pp of- Left _ -> fail' "Could not locate the paganini tuner. Is is available in the PATH?"+ Left _ -> fail' "Could not locate the medulla tuner. Is is available in the PATH?" Right (Just hin, Just hout, _, _) -> do -- write to paganini's stdout- writeSpecification sys hin+ info "Writing system specification..."+ case sysFormat of+ RationalF -> R.writeSpecification sys hin+ AlgebraicF -> A.writeSpecification sys hin -- read output parameters+ let spec = case sysFormat of+ RationalF -> R.toPSpec sys+ AlgebraicF -> A.toPSpec sys+ s <- hGetContents hout- let spec = toPSpec sys let pag = parse (paganiniStmt spec) "" s case pag of@@ -171,112 +87,27 @@ Right (rho, us, ts) -> do info "Parsing paganini output..." let ts' = fromList ts- let sys' = parametrise sys paramT rho ts' us+ let sys' = parametrise sysFormat sys paramT rho ts' us return $ Right sys' - _ -> fail' "Could not establish inter-process communication with paganini."+ _ -> fail' "Could not establish inter-process communication with medulla." -- | Parses the given input string as a Paganini tuning vector.-readPaganini :: System Int -> Parametrisation -> String- -> IO (Either (ParseError Char Dec)+readPaganini :: Format -> System Int -> Parametrisation -> String+ -> IO (Either (ParseErrorBundle String Void) (PSystem Double)) -readPaganini sys paramT f = do- let spec = toPSpec sys+readPaganini sysFormat sys paramT f = do+ let spec = case sysFormat of+ RationalF -> R.toPSpec sys+ AlgebraicF -> A.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 paramT 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+ return (Right $ parametrise sysFormat sys paramT rho ts' us) paganiniStmt :: PSpec -> Parser (Double, [Double], [Double]) paganiniStmt spec = do@@ -287,69 +118,42 @@ -- | Parses the given Paganini specification. parsePaganini :: PSpec -> String- -> IO (Either (ParseError Char Dec)+ -> IO (Either (ParseErrorBundle String Void) (Double, [Double], [Double])) parsePaganini spec = parseFromFile (paganiniStmt spec) --- | Parametrisation type.-data Parametrisation = Cummulative -- ^ Cummulative branching probabilities.- | Regular -- ^ Independent probability masses.+accumulateCons :: Double -> [Cons Double] -> [Cons Double]+accumulateCons _ [] = []+accumulateCons acc (con : xs) =+ con' : accumulateCons acc' xs+ where con' = con { weight = w + acc }+ acc' = acc + w+ w = weight con +accumulateType :: (String, [Cons Double]) -> (String, [Cons Double])+accumulateType (t, cons) =+ (t, accumulateCons 0 cons)++accumulate :: PSystem Double -> PSystem Double+accumulate psys = psys { system = sys { defs = M.fromList types' } }+ where sys = system psys+ typs = M.toList (defs sys)+ types' = map accumulateType typs+ -- | Compute the numerical branching probabilities for the given system.-parametrise :: System Int+parametrise :: Format+ -> System Int -> Parametrisation -> Double -> Vector Double -> [Double] -> PSystem Double -parametrise sys paramT rho ts us = PSystem { system = computeProb sys paramT 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- -> Parametrisation- -> Double -> Vector Double- -> [Double] -> Double -> Double -> [Cons Int]- -> ([Cons Double], [Double])--computeExp _ _ _ _ us _ _ [] = ([], us)-computeExp sys Cummulative rho ts us tw w (e:es) = (e { weight = x / tw } : es', us'')- where (es', us'') = computeExp sys Cummulative rho ts us' tw x es- (w', us') = evalExp sys rho ts us e- x = w + w'--computeExp sys Regular rho ts us tw _ (e:es) = (e { weight = w' / tw } : es', us'')- where (es', us'') = computeExp sys Regular rho ts us' tw 0 es- (w', us') = evalExp sys rho ts us e--computeProb' :: System Int- -> Parametrisation- -> Double -> Vector Double- -> [Double] -> [(String, [Cons Int])]- -> [(String, [Cons Double])]--computeProb' _ _ _ _ _ [] = []-computeProb' sys paramT rho ts us ((t,cons):tys) = (t,cons') : tys'- where (cons', us') = computeExp sys paramT rho ts us (value t sys ts) 0.0 cons- tys' = computeProb' sys paramT rho ts us' tys--computeProb :: System Int- -> Parametrisation- -> Double -> Vector Double- -> [Double] -> System Double+parametrise sysFormat sys paramT rho ts us =+ let sys' = paramFun sys rho ts us+ paramFun = case sysFormat of+ RationalF -> R.paramSystem+ AlgebraicF -> A.paramSystem -computeProb sys paramT rho ts us = sys { defs = M.fromList tys }- where tys = computeProb' sys paramT rho ts us (M.toList $ defs sys)+ in case paramT of+ Regular -> sys'+ Cummulative -> accumulate sys'
+ Data/Boltzmann/System/Tuner/Algebraic.hs view
@@ -0,0 +1,199 @@+{-|+ Module : Data.Boltzmann.System.Tuner.Algebraic+ Description : Interface utilities with the Paganini tuner.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ 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.Algebraic+ ( writeSpecification+ , paramSystem+ , toPSpec+ ) where++import Control.Monad++import System.IO++import qualified Data.Map.Strict as M++import Numeric.LinearAlgebra hiding (size)++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.Utils+import Data.Boltzmann.Internal.Tuner++-- | 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+ 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++frequencies :: System Int -> [Double]+frequencies sys = concatMap (mapMaybe frequency)+ ((M.elems . defs) sys)++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') = sparseConsVec find' spec idx cons+ writeListLn hout vec -- constructor specification+ return idx'++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++-- | Prepends a pair to a list if its+-- first component is positive.+sparsePrepend :: (Num a, Ord a)+ => (a, b) -> [(a, b)] -> [(a, b)]++sparsePrepend x xs+ | fst x > 0 = x : xs+ | otherwise = xs++prependWeight :: (Num a, Ord a, Num b)+ => Cons a -> [(a, b)] -> [(a, b)]++prependWeight cons =+ sparsePrepend (weight cons, 0)++prependFreq :: (Num a, Ord a, Num b)+ => Cons a -> b -> [(a, b)] -> [(a, b)]++prependFreq cons idx xs+ | isJust (frequency cons) =+ sparsePrepend (weight cons, 1 + idx) xs -- note: offset for z+ | otherwise = xs++sparseTypeVec :: Num a => (b -> a) -> a -> [(b, c)] -> [(c, a)]+sparseTypeVec _ _ [] = []+sparseTypeVec find' offset ((t,n) : xs) =+ (n, offset + find' t) : sparseTypeVec find' offset xs++sparseConsVec :: (String -> Int) -> PSpec+ -> Int -> Cons Int -> ([(Int,Int)], Int)++sparseConsVec find' spec idx cons =+ let (tocc, socc) = occurrences cons++ us = numFreqs spec+ -- sparse type representation+ tv = sparseTypeVec find' (1 + us) (B.toOccurList tocc)++ ts = numTypes spec+ -- sparse sequence representation+ sv = sparseTypeVec find' (1 + us + ts) (B.toOccurList socc)++ -- prepend weight and frequency+ xs = prependWeight cons (prependFreq cons idx $ tv ++ sv)++ in case frequency cons of+ Just _ -> (xs, idx + 1)+ Nothing -> (xs, idx)++seqSpecification :: Handle -> (String -> Int) -> PSpec+ -> String -> IO ()++seqSpecification hout find' spec st = do+ hPrint hout (2 :: Int) -- # of constructors+ writeListLn hout ([] :: [Int]) -- empty sequence constructor+ let offset = 1 + numFreqs spec+ writeListLn hout [(1, offset + find' st) :: (Int,Int)+ ,(1, offset + numTypes spec + find' st)] -- cons constructor++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 _ (e:es) = (e { weight = w' / tw } : es', us'')+ where (es', us'') = computeExp sys rho ts us' tw 0 es+ (w', us') = evalExp sys rho ts us e++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 cons+ tys' = computeProb sys rho ts us' tys++paramSystem :: System Int+ -> Double -> Vector Double+ -> [Double] -> PSystem Double++paramSystem sys rho ts us = sys'+ where types' = computeProb sys rho ts us (M.toList $ defs sys)+ sys' = PSystem { system = sys { defs = M.fromList types' }+ , values = ts+ , param = rho+ , weights = sys+ }
+ Data/Boltzmann/System/Tuner/Rational.hs view
@@ -0,0 +1,135 @@+{-|+ Module : Data.Boltzmann.System.Tuner.Rational+ Description : Interface utilities with the Paganini tuner.+ Copyright : (c) Maciej Bendkowski, 2017-2019++ License : BSD3+ Maintainer : maciej.bendkowski@tcs.uj.edu.pl+ Stability : experimental+ -}+module Data.Boltzmann.System.Tuner.Rational+ ( writeSpecification+ , paramSystem+ , toPSpec+ ) where++import System.IO++import Data.Maybe++import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Map.Strict as M++import Numeric.LinearAlgebra hiding (size)++import Data.Boltzmann.System++import Data.Boltzmann.Internal.Utils+import Data.Boltzmann.Internal.Tuner++toPSpec :: System Int -> PSpec+toPSpec sys = PSpec { numFreqs = s+ , numTypes = t+ , numSeqTypes = 0+ }++ where t = size sys+ alph = alphabet sys+ s = S.size (tunedLetters alph)++frequencies :: Set Letter -> [Double]+frequencies alph = mapMaybe freq (S.toList alph)++tunedLetters :: Set Letter -> Set Letter+tunedLetters = S.filter (isJust . freq)++writeSpecification :: System Int -> Handle -> IO ()+writeSpecification sys hout = do+ let spec = toPSpec sys++ -- # of equations and tuned symbols.+ writeListLn hout [numTypes spec, numFreqs spec]++ -- # requested letter frequencies.+ writeListLn hout (frequencies $ alphabet sys)++ -- type specifications+ let types' = types sys+ let alph = tunedLetters $ alphabet sys+ mapM_ (typeSpecification hout alph types') (M.elems $ defs sys)++typeSpecification :: Handle -> Set Letter -> Set String -> [Cons Int] -> IO ()+typeSpecification hout alph types' cons = do+ let n = length cons+ hPrint hout n -- # of constructors+ mapM_ (consSpecification hout alph types') cons++sparsePrepend :: (Num a, Ord a)+ => (a, b) -> [(a, b)]+sparsePrepend x+ | fst x > 0 = [x]+ | otherwise = []++consSpecification :: Handle -> Set Letter -> Set String -> Cons Int -> IO ()+consSpecification hout alph types' con = do+ let z = weight con+ let us = sparseMarkLetter alph z (func con) -- note: func con is the transition letter.+ let offset = 1 + S.size alph+ let ts = if isAtomic con then [] -- note: epsilon transition.+ else sparseMarkType offset types' (head $ args con)++ writeListLn hout (sparsePrepend (z,0) ++ us ++ ts)++sparseMarkLetter :: Set Letter -> Int -> String -> [(Int,Int)]+sparseMarkLetter _ _ "_" = []+sparseMarkLetter alph w u =+ case letter `S.lookupIndex` alph of+ Nothing -> []+ Just idx -> sparsePrepend (w, 1 + idx) -- note: offset for z+ where+ letter = Letter { symb = u, freq = Nothing, weightL = 0 }++sparseMarkType :: Int -> Set String -> Arg -> [(Int,Int)]+sparseMarkType offset types' (Type typ) = [(1, offset + idx)]+ where idx = typ `S.findIndex` types'++sparseMarkType _ _ _ = error "I wasn't expecting the Spanish inquisition!"++freqL :: Cons Int -> [Double] -> Alphabet -> Double+freqL con us alph =+ let f = func con -- note: func con is in fact the letter name.+ idx = Letter { symb = f, freq = Nothing, weightL = 0 } `S.findIndex` tunedLetters alph+ in case f `letterFreq` alph of+ Just _ -> us !! idx ^^ weight con+ Nothing -> 1++paramCons :: System Int -> Double -> Vector Double+ -> [Double] -> Double -> Cons Int -> Cons Double++paramCons sys rho ts us typW con+ | isAtomic con = con { weight = recip typW } -- note: epsilon transition+ | otherwise =+ let z = rho ^^ weight con+ u = freqL con us (alphabet sys)+ w = z * u * value (argName $ head $ args con) sys ts+ in con { weight = w / typW }++paramType :: System Int -> Double -> Vector Double+ -> [Double] -> (String, [Cons Int]) -> (String, [Cons Double])++paramType sys rho ts us (t, cons) =+ (t, map (paramCons sys rho ts us typW) cons)+ where typW = value t sys ts++paramSystem :: System Int -> Double -> Vector Double+ -> [Double] -> PSystem Double++paramSystem sys rho ts us = sys'+ where typs = M.toList (defs sys)+ types' = map (paramType sys rho ts us) typs+ sys' = PSystem { system = sys { defs = M.fromList types' }+ , values = ts+ , param = rho+ , weights = sys+ }
Data/Boltzmann/System/Utils.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System.Utils Description : Various routines for combinatorial systems.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -17,14 +17,16 @@ ( isEmptyAtZero , zeroCoordinates , wellFoundedAtZero+ , polynomial ) where -import Data.Map (Map)-import qualified Data.Map.Strict as M+import Prelude hiding ((<>)) -import Numeric.LinearAlgebra hiding (size)+import Data.Map (Map)+import qualified Data.Map.Strict as M+import Numeric.LinearAlgebra hiding (size) -import Data.Boltzmann.System+import Data.Boltzmann.System -- | Non-strict multiplication. (.*) :: (Num a, Eq a) => a -> a -> a@@ -165,3 +167,17 @@ wellFoundedAtZero sys | isNilpotent (jacobian sys) = not $ zeroCoordinates sys | otherwise = False++-- | Yields an infinite stream of successive evaluation iterations+-- in form of Y[m+1] = H(Z, Y[m]); starting with the given Y[0] and z.+evals :: System Int -> Vector Double -> Double -> [Vector Double]+evals sys ys z = ys : evals sys (eval sys ys z) z++-- | Checks whether the given system, assumed to satisfy H(0,0) = 0+-- and having a nilpotent Jacobian, encodes an implicit polynomial+-- species. See also the isPolynomial subroutine of Pivoteau et al.+polynomial :: System Int -> Bool+polynomial sys = hs !! m == hs !! (m+1)+ where m = size sys+ hs = evals sys vec 1 -- note: numerical evaluation.+ vec = vector $ replicate m 0
Data/Boltzmann/System/Warnings.hs view
@@ -1,7 +1,7 @@ {-| Module : Data.Boltzmann.System.Warnings Description : Various warning handling utilities.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl@@ -16,13 +16,15 @@ ) where import Control.Monad (unless)-import Data.Maybe (mapMaybe) -import System.Exit+import Data.Maybe (mapMaybe)+import Data.List (isPrefixOf) +import qualified Data.Set as S import qualified Data.Map.Strict as M import Data.Boltzmann.System+import Data.Boltzmann.System.Utils import Data.Boltzmann.Internal.Utils import qualified Data.Boltzmann.Internal.Logging as L@@ -61,6 +63,45 @@ cons' = quote $ consWeightCons warn typ' = quote $ consWeightType warn +-- | Skipping the well-foundness check.+data SkipWellFoundness = SkipWellFoundness++skipWellFoundness :: System a -> [WarningExt]+skipWellFoundness sys =+ [WarningExt SkipWellFoundness | not (isAlgebraic $ systemType sys)]++instance SystemWarn SkipWellFoundness where+ report _ = "Given system specifies a rational language. Skipping well-foundness check."++-- | Alphabet with prefix symbols.+newtype PrefixAlphabetWarn =+ PrefixAlphabetWarn { conflicts :: [(String, String)] -- ^ Conflicting symbols.+ }++-- | Raises a warning if the given system alphabet is not prefix-free.+prefixAlphabetWarn :: System a -> [WarningExt]+prefixAlphabetWarn sys =+ [WarningExt PrefixAlphabetWarn { conflicts = conflicting }+ | not (null conflicting)]+ where alph = S.toList $ alphabet sys+ symbolPairs = [(symb a, symb b) | a <- alph, b <- alph, a < b]+ conflicting = filter (uncurry isPrefixOf) symbolPairs++instance SystemWarn PrefixAlphabetWarn where+ report warn = "The system alphabet is not prefix-free. Conflicts: "+ ++ csv (map (\(a,b) -> "(" ++ quote a ++ " and " ++ quote b ++ ")") $ conflicts warn)+ ++ "."++-- | Polynomial species (i.e. finite specification languages).+data PolynomialSpecies = PolynomialSpecies++polynomialWarn :: System Int -> [WarningExt]+polynomialWarn sys =+ [WarningExt PolynomialSpecies | polynomial sys]++instance SystemWarn PolynomialSpecies where+ report _ = "Given system specifies a finite language."+ -- | Reports the given warning. reportWarning :: WarningExt -> IO () reportWarning (WarningExt warn) = L.warn (report warn)@@ -69,12 +110,16 @@ checkWarns werror warns = do mapM_ reportWarning warns unless (null warns || not werror)- (exitWith $ ExitFailure 1)+ (L.fail' "Warnings reported while the --werror flag is enabled. Exiting.") -- | List of checked warnings. warningList :: System Int -> [WarningExt]-warningList = consWeightWarn+warningList sys = skipWellFoundness sys+ ++ consWeightWarn sys+ ++ polynomialWarn sys+ ++ prefixAlphabetWarn sys -- | Checks whether the given input system admits no warnings.-warnings :: Bool -> System Int -> IO ()-warnings werror sys = checkWarns werror (warningList sys)+warnings :: Bool -> Bool -> System Int -> IO ()+warnings werror force sys =+ unless force (checkWarns werror $ warningList sys)
LICENSE view
@@ -1,4 +1,4 @@-Copyright Maciej Bendkowski and Sergey Dovgal (c) 2017-2018+Copyright Maciej Bendkowski and Sergey Dovgal (c) 2017-2019 All rights reserved.
app/Main.hs view
@@ -1,98 +1,104 @@ {-| Module : Main Description : Boltzmann brain executable.- Copyright : (c) Maciej Bendkowski, 2017-2018+ Copyright : (c) Maciej Bendkowski, 2017-2019 License : BSD3 Maintainer : maciej.bendkowski@tcs.uj.edu.pl Stability : experimental -}+{-# LANGUAGE TemplateHaskell #-} module Main ( main ) where import Prelude hiding (fail)--import System.IO-import System.Exit-import System.Console.GetOpt-import System.Environment--import GHC.IO.Handle-import System.Directory (doesFileExist)- import Control.Monad (replicateM, unless) import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.Text.Lazy.IO as T--import Text.Megaparsec hiding (parse)- import qualified Data.Map.Strict as M+import qualified Data.Text.Lazy.IO as T -import Data.Boltzmann.System-import Data.Boltzmann.System.Parser-import Data.Boltzmann.System.Errors-import Data.Boltzmann.System.Warnings-import Data.Boltzmann.System.Sampler-import Data.Boltzmann.System.Renderer+import GHC.IO.Handle -import Data.Boltzmann.Internal.Parser-import Data.Boltzmann.Internal.Annotations-import Data.Boltzmann.Internal.Logging-import Data.Boltzmann.Internal.Utils+import System.Console.GetOpt+import System.Directory (doesFileExist)+import System.Environment+import System.Exit+import System.FilePath (takeExtension)+import System.IO -import qualified Data.Boltzmann.System.Tuner as T+import Text.Megaparsec hiding (parse) import Data.Boltzmann.Compiler import qualified Data.Boltzmann.Compiler.Haskell.Algebraic as A import qualified Data.Boltzmann.Compiler.Haskell.Rational as R+import Data.Boltzmann.Internal.Annotations+import Data.Boltzmann.Internal.Logging+import Data.Boltzmann.Internal.Parser+import Data.Boltzmann.Internal.TH (compileTime)+import qualified Data.Boltzmann.Internal.Tuner as T+import Data.Boltzmann.Internal.Utils+import Data.Boltzmann.System+import Data.Boltzmann.System.Errors+import Data.Boltzmann.System.Parser+import Data.Boltzmann.System.Renderer+import Data.Boltzmann.System.Sampler+import Data.Boltzmann.System.Tuner+import qualified Data.Boltzmann.System.Tuner.Algebraic as TA+import qualified Data.Boltzmann.System.Tuner.Rational as TR+import Data.Boltzmann.System.Warnings data Flag = InputFile String -- ^ input file location | OutputFile String -- ^ output file location | TuningFile String -- ^ paganini tuning data file location- | Force -- ^ whether to skip some sanity check+ | Format String -- ^ whether to assume a rational input specification format+ | Force -- ^ whether to skip sanity checks | Werror -- ^ whether to treat warnings as errors | Help -- ^ whether to print usage help text deriving (Show,Eq) options :: [OptDescr Flag] options = [Option "i" ["input"] (ReqArg InputFile "FILE")- "Optional input file. If not given, stdin is used instead.",+ "Input specification file. If not given, STDIN is used instead.", Option "o" ["output"] (ReqArg OutputFile "FILE")- "Optional output file. If not given, stdout is used instead.",+ "Output file. If not given, STDOUT is used instead.", Option "t" ["tuning-data"] (ReqArg TuningFile "FILE")- "Optional paganini tuning data file corresponding to the input specification.",+ "Tuning data file created using paganini.", + Option "r" ["format"] (ReqArg Format "EXT")+ "Input format (algebraic|rational). Default: algebaic.",+ Option "w" ["werror"] (NoArg Werror)- "Whether to treat warnings as errors.",+ "Whether to treat warnings as errors or not.", Option "f" ["force"] (NoArg Force)- "Whether skip some sanity checks such as the well-foundedness check.",+ "Whether to skip input specification correctness checks.", Option "h?" ["help"] (NoArg Help) "Prints this help message."] version :: String-version = "v1.4"+version = "v1.6" signature :: String signature = "Boltzmann Brain " ++ version versionHeader :: String-versionHeader = signature ++ " (c) 2017-2018."+versionHeader = signature ++ " (c) 2017-2019." -- | Available boltzmann-brain commands. commands :: [(String, String)]-commands = [("compile","Generates a Boltzmann sampler corresponding to the given specification.")- ,("sample","Generates a random structure corresponding to the given specification.")- ,("render","Generates a random structure and outputs its dotfile representation.")- ,("tune","Decorates the given specification with appropriate Boltzmann branching probabilities.")- ,("spec","Generates a paganini input tuning problem corresponding to the given specification.")- ]+commands =+ [("compile", "Generates an analytic sampler corresponding to the given specification.")+ ,("sample" , "Generates a random structure corresponding to the given specification.")+ ,("render" , "Generates a random structure and outputs its dotfile representation.")+ ,("tune" , "Decorates the given specification with appropriate branching probabilities.")+ ,("spec" , "Generates a corresponding paganini input tuning problem.")+ ] -- | Renders the given commands and its description. renderCmd :: (String -> String) -> (String, String) -> IO String@@ -115,14 +121,51 @@ usageHeader = do commandsMsg' <- commandsMsg usage' <- underline "Usage:"- return $ unlines [versionHeader, ""+ return $ unlines [artLogo+ ,"" -- newline ,commandsMsg' ,usage' ++ " bb [COMMAND] [OPTIONS...]" ] compilerTimestamp :: String-compilerTimestamp = signature+compilerTimestamp = signature ++ " (" ++ $compileTime ++ ")" +compilerBuild :: String+compilerBuild = "Build time: " ++ $compileTime ++ "." -- Note: computed at compilation++align :: String -> String -> String+align s t = s ++ t ++ replicate (80 - length s - length t) ' '++logoHeader :: String+logoHeader = align s versionHeader+ where s = " `/:/::- ` ././:.` "++buildTimeHeader :: String+buildTimeHeader = align s compilerBuild+ where s = " .- `..- "++artLogo :: String+artLogo =+ unlines+ [" .-- ",+ " .-` ./:`` ` ",+ " .:.-` `.-` ..--:/ .+- ``....:::. ",+ " ``.:`-:-::` --..:--//:+/-````:-`.```.-` `//::///---`",+ " ``::-:` //+:. `. `...`-::.++//++/:----:-:.-:/-`/oo+::/-",+ " /o. .:::/-.-:` ` -://:::/:// .::`.-..::/:- ",+ " `` ``````.-:` `.`...-/`. `- ``.` `.:/:` -:. ",+ " ...+-/-:--::-:` -::/-/:-`.-.`..:::/+:. `+` ",+ " `:-.-::::--::.```:/+:-:` ./+/:-+:. :-`.` --. ",+ " `` .`.:-``.////-``../++:/::-:/--::::-+/:. -+- ",+ "..`..-...:```````-:::`.`.///:-.` ``-.-``.:. ` `/.:/:` `-` ",+ "`:////::/+-/+/.`:/o++/:::++-:-.-- . ` `.+/. ` ",+ " ` :/:``--.:- .--/+++-::-:-: ` .:. ",+ " -::+:./:://+:--.-:://-``/+-` .` ",+ " -/`.- -/o+/o+/+//+++//o+. ",+ " ` `:/+/s+-...```.://-- ",+ logoHeader ,+ buildTimeHeader ]+ inputF :: [Flag] -> Maybe String inputF (InputFile f : _) = Just f inputF (_:fs) = inputF fs@@ -138,33 +181,67 @@ tuningF (_:fs) = tuningF fs tuningF [] = Nothing +format :: [Flag] -> Maybe Format+format (Format "algebraic" : _) = Just AlgebraicF+format (Format "rational" : _) = Just RationalF+format (_:fs) = format fs+format [] = Nothing+ -- | Logs an error and exists with the usage info. failWithUsage :: String -> IO a failWithUsage m = do- let msg' = ensureLn m usage' <- usageHeader- fail' (msg' ++ usageInfo usage' options)+ putStrLn $ usageInfo usage' options+ fail' m -- | Prints the usage info and exists. usage :: IO a usage = do usage' <- usageHeader- putStrLn $ usageInfo usage' options+ putStr $ usageInfo usage' options exitSuccess --- | Parses the cli arguments into the command string+-- | Parses the CLI arguments into the command string -- and some additional (optional) flags. parse :: [String] -> IO (String, [Flag]) parse argv = case getOpt Permute options argv of (opts, cmds, [])- | null cmds -> usage | Help `elem` opts -> usage+ | null cmds -> failWithUsage "Expected a single command." | length cmds /= 1 -> failWithUsage "Expected a single command." | otherwise -> return (head cmds, opts) (_, _, errs) -> failWithUsage $ concat errs +parseFileExt :: FilePath -> Maybe Format+parseFileExt file =+ case takeExtension file of+ ".rat" -> Just RationalF+ ".alg" -> Just AlgebraicF+ _ -> Nothing++inputFormat :: [Flag] -> FilePath -> IO Format+inputFormat opts file = case format opts of+ Just f -> return f+ Nothing ->+ case parseFileExt file of+ Nothing -> do+ warn $ "Cannot guess input specification format."+ ++ " Defaulting to 'algebraic'."+ hint $ "Use conventional file extensions"+ ++ " '.rat', '.alg' or use the --format flag."+ return AlgebraicF+ Just inFormat -> return inFormat++getInputFormat :: [Flag] -> IO Format+getInputFormat opts =+ case inputF opts of+ Just file -> inputFormat opts file+ Nothing -> case format opts of+ Just f -> return f+ Nothing -> return AlgebraicF -- default+ -- | Sets up stdout and stdin IO handles. handleIO :: [Flag] -> IO () handleIO opts = do@@ -202,11 +279,12 @@ unrecognisedCmd cmd = do let cmd' = quote cmd cmdHint <- bold $ closest (map fst commands) cmd- return $ "Unrecognised command " ++ cmd' ++ ". Did you meant " ++ cmdHint ++ "?"+ return $ "Unrecognised command " ++ cmd' +++ ". Did you mean " ++ cmdHint ++ "?" -- | Prints parsing errors or returns the parsed system.-getSystem :: (ShowToken t, Ord t, ShowErrorComponent e)- => Either (ParseError t e) a -> IO a+getSystem :: (Stream t, ShowErrorComponent e)+ => Either (ParseErrorBundle t e) a -> IO a getSystem (Left err) = printError err getSystem (Right sys) = return sys@@ -215,23 +293,27 @@ -- and warnings checks. Returns the parsed system and its type. parseSystem :: [Flag] -> IO (System Int, SystemType) parseSystem opts = do+ inFormat <- getInputFormat opts+ info $ "Using "++ quote (show inFormat) ++ " specification format."+ info "Parsing system..." text <- getContents- dat <- parseSpec text+ dat <- parseSpec inFormat text sys <- getSystem dat + let force = Force `elem` opts+ sysType <- errors inFormat force sys -- check for errors+ let werror = Werror `elem` opts- warnings werror sys -- check for warnings+ warnings werror force sys -- check for warnings - let force = Force `elem` opts- sysType <- errors force sys -- check for errors return (sys, sysType) tuningConf :: System a -> (Double, Int) tuningConf sys = (precision, maxiter) where arg = T.defaultArgs sys ann = annotations sys- precision = withDouble ann "precision" 1.0e-9+ precision = withDouble ann "precision" 1.0e-20 maxiter = withInt ann "maxiter" (T.maxiters arg) -- | Tunes the given system by either parsing the given paganini@@ -246,32 +328,37 @@ Nothing -> do let arg = T.defaultArgs sys let (precision, maxiter) = tuningConf sys- dat <- T.runPaganini sys prob (Just $ arg { T.precision = precision- , T.maxiters = maxiter- })+ sysFormat <- getInputFormat opts+ dat <- runPaganini sysFormat sys prob+ (Just $ arg { T.precision = precision+ , T.maxiters = maxiter+ }) getSystem dat Just file -> do- dat <- T.readPaganini sys prob file+ sysFormat <- getInputFormat opts+ dat <- readPaganini sysFormat sys prob file getSystem dat compilerConf :: System a -> String compilerConf sys = moduleName where ann = annotations sys- moduleName = withDefault ann "module" "Sampler"+ moduleName = withString ann "module" "Sampler" -- | Runs the specification compiler. runCompiler :: [Flag] -> IO () runCompiler opts = do- (sys, sysType) <- parseSystem opts+ (sys, _) <- parseSystem opts let moduleName = compilerConf sys - tunedSystem <- tuneSystem sys opts T.Cummulative+ tunedSystem <- tuneSystem sys opts T.Regular info "Running sampler compiler..." - case sysType of- Rational -> R.compile (config tunedSystem moduleName compilerTimestamp :: R.Conf)- Algebraic -> A.compile (config tunedSystem moduleName compilerTimestamp :: A.Conf)- _ -> fail' "Unsupported system type."+ sysFormat <- getInputFormat opts+ case sysFormat of+ RationalF -> R.compile (config tunedSystem moduleName+ compilerTimestamp :: R.Conf)+ AlgebraicF -> A.compile (config tunedSystem moduleName+ compilerTimestamp :: A.Conf) samplerConf :: System Int -> [Flag] -> IO (Int, Int, Int, String) samplerConf sys opts =@@ -279,17 +366,19 @@ n = withInt ann "samples" 1 lb = withInt ann "lowerBound" 10 ub = withInt ann "upperBound" 200- gen = withDefault ann "generate" (initType sys)+ gen = withString ann "generate" (initType sys) in case "samples" `M.lookup` ann of- Just _ -> return (lb, ub, n, gen)- Nothing -> do- let f = if Werror `elem` opts then warn' else warn- f "No explicit @samples annotation. Sampling a single structure."- return (lb, ub, n, gen)+ Just _ -> return (lb, ub, n, gen)+ Nothing -> do+ let f = if Werror `elem` opts then warn' else warn+ f "No explicit @samples annotation. Sampling a single structure."+ return (lb, ub, n, gen) getSamples :: System Int -> [Flag] -> IO [Structure] getSamples sys opts = do (lb, ub, n, genT) <- samplerConf sys opts+ -- TODO: Consider having generic method of generating samples+ -- reusing the compiler code. Ad-hoc compilation? tunedSystem <- tuneSystem sys opts T.Cummulative replicateM n (sampleStrIO tunedSystem genT lb ub) -- get n samples. @@ -333,13 +422,13 @@ runTuner opts = do (sys, _) <- parseSystem opts tunedSystem <- tuneSystem sys opts T.Regular-- info "Writing system output..." B.putStr $ encode (toSystemT $ system tunedSystem) runSpec :: [Flag] -> IO () runSpec opts = do (sys, _) <- parseSystem opts-- info "Writing system output..."- T.writeSpecification sys stdout -- write specification to output+ sysFormat <- getInputFormat opts+ -- write specification to output+ case sysFormat of+ RationalF -> TR.writeSpecification sys stdout+ AlgebraicF -> TA.writeSpecification sys stdout
boltzmann-brain.cabal view
@@ -1,6 +1,6 @@ name: boltzmann-brain-version: 1.4-synopsis: Boltzmann sampler compiler for combinatorial systems.+version: 1.6+synopsis: Analytic 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,@@ -12,7 +12,7 @@ license-file: LICENSE author: Maciej Bendkowski maintainer: maciej.bendkowski@tcs.uj.edu.pl-copyright: 2017-2018 Maciej Bendkowski+copyright: 2017-2019 Maciej Bendkowski category: Math build-type: Simple -- extra-source-files:@@ -20,13 +20,20 @@ library exposed-modules: Data.Boltzmann.System+ , Data.Boltzmann.System.Annotations , Data.Boltzmann.System.Utils- , Data.Boltzmann.System.Parser , Data.Boltzmann.System.Errors , Data.Boltzmann.System.Warnings , Data.Boltzmann.System.Tuner+ , Data.Boltzmann.System.Tuner.Algebraic+ , Data.Boltzmann.System.Tuner.Rational , Data.Boltzmann.System.Sampler , Data.Boltzmann.System.Renderer+ , Data.Boltzmann.System.Parser+ , Data.Boltzmann.System.Parser.Algebraic+ , Data.Boltzmann.System.Parser.Rational+ , Data.Boltzmann.Internal.TH+ , Data.Boltzmann.Internal.Tuner , Data.Boltzmann.Internal.Annotations , Data.Boltzmann.Internal.Logging , Data.Boltzmann.Internal.Parser@@ -36,22 +43,24 @@ , Data.Boltzmann.Compiler.Haskell.Algebraic , Data.Boltzmann.Compiler.Haskell.Rational build-depends: base >= 4.7 && < 5+ , bytestring >= 0.10.8.2 , containers >= 0.5.6- , megaparsec >= 5.2.0- , haskell-src-exts == 1.17.1+ , haskell-src-exts >= 1.21+ , megaparsec >= 7 , mtl >= 2.2.1- , multiset >= 0.3.3+ , multiset >= 0.3.4.1 , hmatrix >= 0.18.0.0- , process >= 1.4.3.0- , aeson >= 1.1.2.0- , transformers >= 0.5.4.0+ , process >= 1.6.5+ , aeson >= 1.4.6+ , transformers >= 0.5.6 , MonadRandom >= 0.5.1- , graphviz >= 2999.18- , text >= 1.2.2.2+ , graphviz >= 2999.20+ , text >= 1.2.3 , random >= 1.1- , time >= 1.6.0.1+ , time >= 1.8 , pretty-terminal >= 0.1.0.0 , edit-distance >= 0.2.2.1+ , template-haskell >= 2.11.1.0 ghc-options: -O2 -Wall -Wcompat@@ -72,14 +81,15 @@ -threaded -rtsopts -with-rtsopts=-N- build-depends: base- , containers >= 0.5.6- , megaparsec >= 5.2.0- , bytestring >= 0.10.8.1- , aeson >= 1.1.2.0- , text >= 1.2.2.2- , directory >= 1.3.0.0+ build-depends: aeson + , base , boltzmann-brain+ , bytestring+ , containers + , directory+ , filepath + , megaparsec+ , text default-language: Haskell2010 source-repository head