diff --git a/Data/Boltzmann/Compiler.hs b/Data/Boltzmann/Compiler.hs --- a/Data/Boltzmann/Compiler.hs +++ b/Data/Boltzmann/Compiler.hs @@ -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 diff --git a/Data/Boltzmann/Compiler/Haskell/Algebraic.hs b/Data/Boltzmann/Compiler/Haskell/Algebraic.hs --- a/Data/Boltzmann/Compiler/Haskell/Algebraic.hs +++ b/Data/Boltzmann/Compiler/Haskell/Algebraic.hs @@ -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 diff --git a/Data/Boltzmann/Compiler/Haskell/Helpers.hs b/Data/Boltzmann/Compiler/Haskell/Helpers.hs --- a/Data/Boltzmann/Compiler/Haskell/Helpers.hs +++ b/Data/Boltzmann/Compiler/Haskell/Helpers.hs @@ -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]] diff --git a/Data/Boltzmann/Compiler/Haskell/Rational.hs b/Data/Boltzmann/Compiler/Haskell/Rational.hs --- a/Data/Boltzmann/Compiler/Haskell/Rational.hs +++ b/Data/Boltzmann/Compiler/Haskell/Rational.hs @@ -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' diff --git a/Data/Boltzmann/Internal/Annotations.hs b/Data/Boltzmann/Internal/Annotations.hs --- a/Data/Boltzmann/Internal/Annotations.hs +++ b/Data/Boltzmann/Internal/Annotations.hs @@ -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 diff --git a/Data/Boltzmann/Internal/Logging.hs b/Data/Boltzmann/Internal/Logging.hs --- a/Data/Boltzmann/Internal/Logging.hs +++ b/Data/Boltzmann/Internal/Logging.hs @@ -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 diff --git a/Data/Boltzmann/Internal/Parser.hs b/Data/Boltzmann/Internal/Parser.hs --- a/Data/Boltzmann/Internal/Parser.hs +++ b/Data/Boltzmann/Internal/Parser.hs @@ -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) diff --git a/Data/Boltzmann/Internal/TH.hs b/Data/Boltzmann/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/Internal/TH.hs @@ -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) diff --git a/Data/Boltzmann/Internal/Tuner.hs b/Data/Boltzmann/Internal/Tuner.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/Internal/Tuner.hs @@ -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. diff --git a/Data/Boltzmann/Internal/Utils.hs b/Data/Boltzmann/Internal/Utils.hs --- a/Data/Boltzmann/Internal/Utils.hs +++ b/Data/Boltzmann/Internal/Utils.hs @@ -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 diff --git a/Data/Boltzmann/System.hs b/Data/Boltzmann/System.hs --- a/Data/Boltzmann/System.hs +++ b/Data/Boltzmann/System.hs @@ -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) diff --git a/Data/Boltzmann/System/Annotations.hs b/Data/Boltzmann/System/Annotations.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/System/Annotations.hs @@ -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 diff --git a/Data/Boltzmann/System/Errors.hs b/Data/Boltzmann/System/Errors.hs --- a/Data/Boltzmann/System/Errors.hs +++ b/Data/Boltzmann/System/Errors.hs @@ -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 diff --git a/Data/Boltzmann/System/Parser.hs b/Data/Boltzmann/System/Parser.hs --- a/Data/Boltzmann/System/Parser.hs +++ b/Data/Boltzmann/System/Parser.hs @@ -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 diff --git a/Data/Boltzmann/System/Parser/Algebraic.hs b/Data/Boltzmann/System/Parser/Algebraic.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/System/Parser/Algebraic.hs @@ -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 diff --git a/Data/Boltzmann/System/Parser/Rational.hs b/Data/Boltzmann/System/Parser/Rational.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/System/Parser/Rational.hs @@ -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 + } diff --git a/Data/Boltzmann/System/Renderer.hs b/Data/Boltzmann/System/Renderer.hs --- a/Data/Boltzmann/System/Renderer.hs +++ b/Data/Boltzmann/System/Renderer.hs @@ -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 diff --git a/Data/Boltzmann/System/Sampler.hs b/Data/Boltzmann/System/Sampler.hs --- a/Data/Boltzmann/System/Sampler.hs +++ b/Data/Boltzmann/System/Sampler.hs @@ -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 diff --git a/Data/Boltzmann/System/Tuner.hs b/Data/Boltzmann/System/Tuner.hs --- a/Data/Boltzmann/System/Tuner.hs +++ b/Data/Boltzmann/System/Tuner.hs @@ -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' diff --git a/Data/Boltzmann/System/Tuner/Algebraic.hs b/Data/Boltzmann/System/Tuner/Algebraic.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/System/Tuner/Algebraic.hs @@ -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 + } diff --git a/Data/Boltzmann/System/Tuner/Rational.hs b/Data/Boltzmann/System/Tuner/Rational.hs new file mode 100644 --- /dev/null +++ b/Data/Boltzmann/System/Tuner/Rational.hs @@ -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 + } diff --git a/Data/Boltzmann/System/Utils.hs b/Data/Boltzmann/System/Utils.hs --- a/Data/Boltzmann/System/Utils.hs +++ b/Data/Boltzmann/System/Utils.hs @@ -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 diff --git a/Data/Boltzmann/System/Warnings.hs b/Data/Boltzmann/System/Warnings.hs --- a/Data/Boltzmann/System/Warnings.hs +++ b/Data/Boltzmann/System/Warnings.hs @@ -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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/boltzmann-brain.cabal b/boltzmann-brain.cabal --- a/boltzmann-brain.cabal +++ b/boltzmann-brain.cabal @@ -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