Commit c51c68df authored by Philipp Meyer's avatar Philipp Meyer

Made output much faster by using byte string builders

parent f0373636
......@@ -21,6 +21,8 @@ executable slapnet
main-is: Main.hs
other-modules:
-- other-extensions:
build-depends: base >=4 && <5, sbv, parsec, containers, transformers
build-depends: base >=4 && <5, sbv, parsec, containers, transformers,
bytestring
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -fsimpl-tick-factor=1000
......@@ -10,6 +10,7 @@ import Control.Monad
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Data.List (partition)
import qualified Data.ByteString.Lazy as L
import Parser
import qualified Parser.PNET as PNET
......@@ -180,16 +181,16 @@ parseArgs = do
writeFiles :: Int -> String -> PetriNet -> [Property] -> IO ()
writeFiles verbosity basename net props = do
verbosePut verbosity 1 $ "Writing " ++ showNetName net ++ " to " ++ basename
writeFile basename $ LOLAPrinter.printNet net
L.writeFile basename $ LOLAPrinter.printNet net
mapM_ (\(p,i) -> do
let file = basename ++ ".task" ++ show i
verbosePut verbosity 1 $ "Writing " ++ showPropertyName p ++
" to " ++ file
writeFile file $ LOLAPrinter.printProperty p
L.writeFile file $ LOLAPrinter.printProperty p
) (zip props [(1::Integer)..])
verbosePut verbosity 1 $ "Writing properties to " ++ basename ++ ".sara"
writeFile (basename ++ ".sara") $ unlines $
map (SARAPrinter.printProperty basename net) props
L.writeFile (basename ++ ".sara") $
SARAPrinter.printProperties basename net props
checkFile :: Parser (PetriNet,[Property]) -> Int -> Bool ->
[ImplicitProperty] -> [NetTransformation] ->
......@@ -206,10 +207,10 @@ checkFile parser verbosity refine implicitProperties transformations
"Places: " ++ show (length $ places net') ++ "; " ++
"Transitions: " ++ show (length $ transitions net')
verbosePut verbosity 3 $ show net'
rs <- mapM (checkProperty verbosity net' refine) props'''
case output of
Just outputfile -> writeFiles verbosity outputfile net' props'''
Nothing -> return ()
rs <- mapM (checkProperty verbosity net' refine) props'''
verbosePut verbosity 0 ""
return $ and rs
......
module Printer
(validateId)
(validateId,intercalate)
where
import Data.Char
import Data.ByteString.Builder
import Data.Monoid
validateId :: String -> String
validateId "" = "_"
validateId (x:xs) = (if isAlpha x then x else '_') :
map (\c -> if isAlphaNum c then c else '_') xs
intercalate :: Builder -> [Builder] -> Builder
intercalate _ [] = mempty
intercalate sep (x:xs) = x <> go xs
where go = foldr (\y -> (<>) (sep <> y)) mempty
{-# LANGUAGE OverloadedStrings #-}
module Printer.LOLA
(printNet,printProperty)
where
import Data.List (intercalate)
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
import Data.Monoid
import Printer
import PetriNet
import Property
printNet :: PetriNet -> String
printNet net =
let showWeight (p,x) = p ++ ":" ++ show x
ps = "PLACE " ++ intercalate "," (places net) ++ ";\n"
is = "MARKING " ++ intercalate ","
(map showWeight (initials net)) ++ ";\n"
renderNet :: PetriNet -> Builder
renderNet net =
let showWeight (p,x) = stringUtf8 p <> ":" <> integerDec x
ps = "PLACE " <> intercalate ","
(map stringUtf8 (places net)) <> ";\n"
is = "MARKING " <> intercalate ","
(map showWeight (initials net)) <> ";\n"
makeTransition t =
let (preT,postT) = context net t
preS = "CONSUME " ++ intercalate ","
(map showWeight preT) ++ ";\n"
postS = "PRODUCE " ++ intercalate ","
(map showWeight postT) ++ ";\n"
in "TRANSITION " ++ t ++ "\n" ++ preS ++ postS
preS = "CONSUME " <> intercalate ","
(map showWeight preT) <> ";\n"
postS = "PRODUCE " <> intercalate ","
(map showWeight postT) <> ";\n"
in "TRANSITION " <> stringUtf8 t <> "\n" <> preS <> postS
ts = map makeTransition (transitions net)
in unlines (ps:is:ts)
printTerm :: Term -> String
printTerm (Var x) = x
printTerm (Const c) = show c
printTerm (Minus t) = "-" ++ printTerm t
printTerm (t :+: u) = "(" ++ printTerm t ++ " + " ++ printTerm u ++ ")"
printTerm (t :-: u) = "(" ++ printTerm t ++ " - " ++ printTerm u ++ ")"
printTerm (t :*: u) = printTerm t ++ " * " ++ printTerm u
printOp :: Op -> String
printOp Gt = " > "
printOp Ge = " >= "
printOp Eq = " = "
printOp Ne = " != "
printOp Le = " <= "
printOp Lt = " < "
printLinIneq :: LinearInequation -> String
printLinIneq (LinIneq lhs op rhs) = printTerm lhs ++ printOp op ++ printTerm rhs
printFormula :: Formula -> String
printFormula FTrue = "TRUE"
printFormula FFalse = "FALSE"
printFormula (Atom a) = printLinIneq a
printFormula (Neg p) = "NOT " ++ "(" ++ printFormula p ++ ")"
printFormula (p :&: q) = printFormula p ++ " AND " ++ printFormula q
printFormula (p :|: q) = "(" ++ printFormula p ++ " OR " ++ printFormula q ++ ")"
printProperty :: Property -> String
printProperty (Property _ Safety f) = "EF (" ++ printFormula f ++ ")\n"
printProperty (Property _ Liveness _) =
in intercalate "\n" (ps:is:ts)
printNet :: PetriNet -> L.ByteString
printNet = toLazyByteString . renderNet
renderTerm :: Term -> Builder
renderTerm (Var x) = stringUtf8 x
renderTerm (Const c) = integerDec c
renderTerm (Minus t) = "-" <> renderTerm t
renderTerm (t :+: u) = "(" <> renderTerm t <> " + " <> renderTerm u <> ")"
renderTerm (t :-: u) = "(" <> renderTerm t <> " - " <> renderTerm u <> ")"
renderTerm (t :*: u) = renderTerm t <> " * " <> renderTerm u
renderOp :: Op -> Builder
renderOp Gt = " > "
renderOp Ge = " >= "
renderOp Eq = " = "
renderOp Ne = " != "
renderOp Le = " <= "
renderOp Lt = " < "
renderLinIneq :: LinearInequation -> Builder
renderLinIneq (LinIneq lhs op rhs) =
renderTerm lhs <> renderOp op <> renderTerm rhs
renderFormula :: Formula -> Builder
renderFormula FTrue = "TRUE"
renderFormula FFalse = "FALSE"
renderFormula (Atom a) = renderLinIneq a
renderFormula (Neg p) = "NOT " <> "(" <> renderFormula p <> ")"
renderFormula (p :&: q) = renderFormula p <> " AND " <> renderFormula q
renderFormula (p :|: q) = "(" <> renderFormula p <> " OR " <> renderFormula q <> ")"
renderProperty :: Property -> Builder
renderProperty (Property _ Safety f) = "EF (" <> renderFormula f <> ")\n"
renderProperty (Property _ Liveness _) =
error "liveness property not supported for lola"
printProperty :: Property -> L.ByteString
printProperty = toLazyByteString . renderProperty
{-# LANGUAGE OverloadedStrings #-}
module Printer.SARA
(printProperty)
(printProperties)
where
import Data.List (intercalate)
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder
import Data.Monoid
import Printer
import PetriNet
import Property
printSimpleTerm :: Integer -> Term -> String
printSimpleTerm fac (Var x) = if fac == 1 then x else show fac ++ x
printSimpleTerm fac (Const c) = show (fac*c)
printSimpleTerm fac (Const c :*: t) = printSimpleTerm (fac*c) t
printSimpleTerm fac (t :*: Const c) = printSimpleTerm (fac*c) t
printSimpleTerm fac (Minus t) = printSimpleTerm (-fac) t
printSimpleTerm _ t = error $ "term not supported for sara: " ++ show t
printTerm :: Term -> String
printTerm (t :+: u) = printTerm t ++ "+" ++ printSimpleTerm 1 u
printTerm (t :-: u) = printTerm t ++ "+" ++ printSimpleTerm (-1) u
printTerm t = printSimpleTerm 1 t
printOp :: Op -> String
printOp Ge = ">"
printOp Eq = ":"
printOp Le = "<"
printOp op = error $ "operand not supported for sara: " ++ show op
printLinIneq :: LinearInequation -> String
printLinIneq (LinIneq lhs op (Const c)) = printTerm lhs ++ printOp op ++ show c
printLinIneq l = error $ "linear inequation not supported for sara: " ++ show l
printFormula :: Formula -> String
printFormula (Atom a) = printLinIneq a
printFormula (Neg _) = error "negation not supported for sara"
printFormula (p :&: q) = printFormula p ++ "," ++ printFormula q
printFormula f = error $ "formula not supported for sara: " ++ show f
printProperty :: String -> PetriNet -> Property -> String
printProperty filename net (Property propname Safety f) =
"PROBLEM " ++ validateId propname ++ ":\n" ++
"GOAL REACHABILITY;\n" ++
"FILE " ++ reverse (takeWhile (/='/') (reverse filename)) ++
" TYPE LOLA;\n" ++
"INITIAL " ++ intercalate ","
(map (\(p,i) -> p ++ ":" ++ show i) (initials net)) ++ ";\n" ++
"FINAL COVER;\n" ++
"CONSTRAINTS " ++ printFormula f ++ ";"
printProperty _ _ (Property _ Liveness _) =
renderSimpleTerm :: Integer -> Term -> Builder
renderSimpleTerm fac (Var x) = if fac == 1 then stringUtf8 x
else integerDec fac <> stringUtf8 x
renderSimpleTerm fac (Const c) = integerDec (fac*c)
renderSimpleTerm fac (Const c :*: t) = renderSimpleTerm (fac*c) t
renderSimpleTerm fac (t :*: Const c) = renderSimpleTerm (fac*c) t
renderSimpleTerm fac (Minus t) = renderSimpleTerm (-fac) t
renderSimpleTerm _ t = error $ "term not supported for sara: " <> show t
renderTerm :: Term -> Builder
renderTerm (t :+: u) = renderTerm t <> "+" <> renderSimpleTerm 1 u
renderTerm (t :-: u) = renderTerm t <> "+" <> renderSimpleTerm (-1) u
renderTerm t = renderSimpleTerm 1 t
renderOp :: Op -> Builder
renderOp Ge = ">"
renderOp Eq = ":"
renderOp Le = "<"
renderOp op = error $ "operand not supported for sara: " <> show op
renderLinIneq :: LinearInequation -> Builder
renderLinIneq (LinIneq lhs op (Const c)) =
renderTerm lhs <> renderOp op <> integerDec c
renderLinIneq l = error $ "linear inequation not supported for sara: " <> show l
renderFormula :: Formula -> Builder
renderFormula (Atom a) = renderLinIneq a
renderFormula (Neg _) = error "negation not supported for sara"
renderFormula (p :&: q) = renderFormula p <> "," <> renderFormula q
renderFormula f = error $ "formula not supported for sara: " <> show f
renderProperty :: String -> PetriNet -> Property -> Builder
renderProperty filename net (Property propname Safety f) =
"PROBLEM " <> stringUtf8 (validateId propname) <> ":\n" <>
"GOAL REACHABILITY;\n" <>
"FILE " <> stringUtf8 (reverse (takeWhile (/='/') (reverse filename)))
<> " TYPE LOLA;\n" <>
"INITIAL " <> intercalate ","
(map (\(p,i) -> stringUtf8 p <> ":" <> integerDec i) (initials net))
<> ";\n" <>
"FINAL COVER;\n" <>
"CONSTRAINTS " <> renderFormula f <> ";"
renderProperty _ _ (Property _ Liveness _) =
error "liveness property not supported for sara"
printProperties :: String -> PetriNet -> [Property] -> L.ByteString
printProperties filename net props =
toLazyByteString $ intercalate "\n" $
map (renderProperty filename net) props
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment