Merge branch 'json' into 'master'

Json

See merge request i7/peregrine!1

README.md

@@ -16,47 +16,39 @@ and the build system [cabal >= 1.22](https://www.haskell.org/cabal/).
 Input
 ------
 
-Peregrine takes a single population protocol as input.
-The following example shows how a protocol is encoded:
+Peregrine takes a single population protocol as JSON-encoded input.
+The following example shows the input format:
 
 ```
-population protocol "Majority Protocol" {
-    states { a b a_small b_small}
-    transitions { t1 t2 t3 t4 }
-    arcs { { a, b } -> t1 -> { a_small, b_small }
-           { b, a_small } -> t2 -> { b, b_small }
-           { a, b_small } -> t3 -> { a, a_small }
-           { a_small, b_small } -> t4 -> { a_small, a_small }
-         }
-    initial { a b }
-    true { a a_small }
-    false { b b_small }
+{
+    "title": "Majority Protocol",
+    "states": ["A", "a", "B", "b"],
+    "transitions": [
+                    { "name": "t1",
+                      "pre": ["A", "B"],
+                      "post": ["a", "b"]
+                    },
+                    { "name": "t2",
+                      "pre": ["B", "a"],
+                      "post": ["B", "b"]
+                    },
+                    { "name": "t3",
+                      "pre": ["A", "b"],
+                      "post": ["A", "a"]
+                    },
+                    { "name": "t4",
+                      "pre": ["a", "b"],
+                      "post": ["a", "a"]
+                    }
+                   ],
+    initialStates: ["A", "B"],
+    trueStates: ["A", "a"],
+    predicate: "A >= B",
+    description: "This protocol computes whether there are more B-states than A-states"
 }
 
 
 ```
-* After the keyword *population protocol* the name of the protocol is given in
-quotes.
-
-* Finite sets are specified in braces
-through space- or comma-separated lists of  names.
-Names consist of alphanumerical characters or underscores.
-
-* The set of states is given after the identifier *states*.
-
-* In order to make transitions identifiable,
-each transition must be given a name after the  keyword *transitions*.
-
-* Transitions are defined after the keyword *arcs*; there must be one definition
-  for each transition name.
-
-* The set following the keyword *initial* specifies states that can
-belong to an initial population.
-
-* The sets following the keywords *true* and *false* identify the states
-that map to true and false, respectively.
-
-
 
 Usage
 -------

benchmarks/pp-print/pp-print.cabal

@@ -21,6 +21,6 @@ executable pp-print
   main-is: Main.hs
   other-modules:
   -- other-extensions:
-  build-depends:       multiset, base >= 4.8, containers
+  build-depends:       multiset, base >= 4.8, containers, aeson, aeson-pretty, bytestring
   hs-source-dirs:      src
   default-language:    Haskell2010

benchmarks/pp-print/src/Main.hs

 import System.Environment (getArgs)
 import PopulationProtocol
 import ProtocolOutput
+import qualified Data.ByteString.Lazy as BS
 
 usageAction :: IO ()
 usageAction = do 
@@ -20,57 +21,57 @@ usageAction = do
 
 
 majorityAction :: IO ()
-majorityAction = putStr $ protocolToPetriNet createMajorityProtocol "Majority Protocol"
+majorityAction = BS.putStr $  pp2JSON createMajorityProtocol "Majority Protocol"
 
 broadCastAction :: IO ()
-broadCastAction = putStr $ protocolToPetriNet createBroadcastProtocol "BroadCast Protocol"
+broadCastAction = BS.putStr $  pp2JSON createBroadcastProtocol "BroadCast Protocol"
 
 simpleAction :: IO ()
-simpleAction = putStr $ protocolToPetriNet simpleProtocol "Simple Protocol"
+simpleAction = BS.putStr $  pp2JSON simpleProtocol "Simple Protocol"
 
 
 newBirdsAction :: [String] -> IO ()
 newBirdsAction [x] = let pp = createNewBirdsProtocol (read x) in
-     putStr $ protocolToPetriNet  pp ("New birds protocol with c = " ++ x)
+     BS.putStr $  pp2JSON  pp ("New birds protocol with c = " ++ x)
 
 
 logFlockOfBirdsAction :: [String] -> IO ()
 logFlockOfBirdsAction [x] = let pp = createLogFlockOfBirdsProtocol (read x) in
-     putStr $ protocolToPetriNet  pp ("Log Flock of birds protocol with c = " ++ x)
+     BS.putStr $  pp2JSON  pp ("Log Flock of birds protocol with c = " ++ x)
 
 effThresholdAction :: [String] -> IO () 
 effThresholdAction [x] = let pp = createEfficientThresholdProtocol (read x) in
-     putStr $ protocolToPetriNet  pp ("Efficient Flock of birds protocol with c = " ++ x)
+     BS.putStr $  pp2JSON  pp ("Efficient Flock of birds protocol with c = " ++ x)
 
 flockOfBirdsAction :: [String] -> IO ()
 flockOfBirdsAction [x] = let pp = createFlockOfBirdsProtocol (read x) in
-     putStr $ protocolToPetriNet  pp ("Flock of birds protocol with c = " ++ x)
+     BS.putStr $  pp2JSON  pp ("Flock of birds protocol with c = " ++ x)
 
 verifiableFlockOfBirdsAction :: [String] -> IO ()
 verifiableFlockOfBirdsAction [x] = let pp = createVerifiableFlockOfBirdsProtocol (read x) in
-     putStr $ protocolToPetriNet  pp ("Verifiable flock of birds protocol with c = " ++ x)
+     BS.putStr $  pp2JSON  pp ("Verifiable flock of birds protocol with c = " ++ x)
 
 oldThresholdAction :: [String] -> IO ()
 oldThresholdAction [x, y] = let  pp = createOldThresholdProtocol (read x) (read y) in
-    putStr $ protocolToPetriNet  pp ("Old Threshold Protocol with l = " ++ x ++ " and c = " ++ y)
+    BS.putStr $  pp2JSON  pp ("Old Threshold Protocol with l = " ++ x ++ " and c = " ++ y)
 oldThresholdAction _ = usageAction
 
 
 thresholdAction :: [String] -> IO ()
 thresholdAction [x, y] = let (Just pp) = createThresholdProtocol (read x) (read y) in
-    putStr $ protocolToPetriNet  pp ("Threshold Protocol with l = " ++ x ++ " and c = " ++ y)
+    BS.putStr $  pp2JSON  pp ("Threshold Protocol with l = " ++ x ++ " and c = " ++ y)
 thresholdAction _ = usageAction
 
 
 moduloAction :: [String] -> IO ()
 moduloAction [x, y] = let pp = createModuloProtocol (read x) (read y) in
-    putStr $ protocolToPetriNet  pp ("Modulo Protocol with m = " ++ x ++ " and c = " ++ y)
+    BS.putStr $  pp2JSON  pp ("Modulo Protocol with m = " ++ x ++ " and c = " ++ y)
 moduloAction _ = usageAction
 
 
 layeredProtocolAction :: [String] -> IO ()
 layeredProtocolAction [m] = let pp = createMLayerProtocol (read m) in
-    putStr $ protocolToPetriNet pp ("Layered Protocol with m = " ++ m ++ " layers.")
+    BS.putStr $  pp2JSON pp ("Layered Protocol with m = " ++ m ++ " layers.")
 
 main = do
     args <- getArgs

benchmarks/pp-print/src/ProtocolOutput.hs

+{-# LANGUAGE DeriveGeneric #-}
+
 module ProtocolOutput where
 
 import Util
-import PopulationProtocol
+import qualified PopulationProtocol as P
+import Data.Aeson
+import Data.Aeson.Encode.Pretty 
+import qualified Data.ByteString.Lazy as BS
+import GHC.Generics (Generic)
 
-nonSilentActions :: (Ord qs) => PopulationProtocol qs -> [(qs, qs)]
-nonSilentActions pp = [(q1, q2) | q1 <- states pp
-                                , q2 <- states pp
+nonSilentActions :: (Ord qs) => P.PopulationProtocol qs -> [(qs, qs)]
+nonSilentActions pp = [(q1, q2) | q1 <- P.states pp
+                                , q2 <- P.states pp
                                 , q1 <= q2
-                                , (trans pp) (q1, q2) /= (q1, q2)
-                                , (trans pp) (q1, q2) /= (q2, q1)]
+                                , (P.trans pp) (q1, q2) /= (q1, q2)
+                                , (P.trans pp) (q1, q2) /= (q2, q1)]
 
 
 places :: (Show qs) => qs -> qs -> String
 places q1 q2 =  "{ " ++ toVar q1 ++ ", " ++ toVar q2 ++ " }"
 
+data TransStruct = TransStruct { name :: String
+                               , pre :: [String]
+                               , post :: [String]
+                               } deriving (Eq, Ord, Show, Generic)
+
+data PPStruct = PPStruct { title :: String
+                         , states :: [String]
+                         , transitions :: [TransStruct]
+                         , initialStates :: [String]
+                         , trueStates :: [String]
+                         , predicate :: Maybe String
+                         } deriving (Eq, Ord, Show, Generic)
+
+instance ToJSON TransStruct
+instance ToJSON PPStruct
+                                  
 
-protocolToPetriNet :: (Show qs, Ord qs) => PopulationProtocol qs -> String -> String
-protocolToPetriNet pp name = 
-    "population protocol " ++ show name ++ " {" ++ "\n" ++
-    "    states { " ++ unwords (toVar <$> states pp) ++ "}" ++ "\n" ++
-    "    transitions { " ++ unwords (transToVar <$> nonSilentActions pp) ++ " }" ++ "\n" ++
-    "    arcs {" ++ "\n" ++
-    unlines ["       " ++ places q1 q2 ++ " -> " ++ transToVar (q1, q2) ++ " -> " ++ places q1' q2' |
-             (q1, q2) <- nonSilentActions pp, let (q1', q2') = (trans pp) (q1, q2)] ++
-    "    }\n" ++
-    "    initial {" ++ unwords (toVar <$> initial pp) ++ "}\n" ++
-    "    true {" ++ unwords (toVar <$> [q | q <- states pp, (opinion pp) q]) ++ "}\n" ++
-    "    false {" ++ unwords (toVar <$> [q | q <- states pp, not ((opinion pp) q)]) ++ "}\n" ++
-    (case (predicate pp) of
-        Nothing -> ""
-        Just p -> "    predicate { " ++ p ++ " }\n"
-    ) ++
-    "}"
+pp2JSON :: (Show qs, Ord qs) => P.PopulationProtocol qs -> String -> BS.ByteString
+pp2JSON pp str = encodePretty $ 
+        PPStruct { title = str
+                 , states = toVar <$> P.states pp
+                 , transitions = [ TransStruct { name = transToVar (q1, q2)
+                                               , pre = toVar <$> [q1, q2]
+                                               , post = toVar <$> [q1', q2']
+                                               }
+                                 | (q1, q2) <- nonSilentActions pp
+                                 , let (q1', q2') = (P.trans pp) (q1, q2)
+                                 ]
+                 , initialStates = toVar <$> P.initial pp
+                 , trueStates = toVar <$> [q | q <- P.states pp, (P.opinion pp) q]
+                 , predicate = P.predicate pp
+                 }

examples/broadcast.pp

-population protocol "Broadcast Protocol" {
-    states      { _true _false }
-    transitions { x_false_true }
-    arcs {
-       { _false, _true } -> x_false_true -> { _true, _true }
-    }
-    initial   { _true _false }
-    true      { _true }
-    false     { _false }
-    predicate { _true >= 1 }
+{ "title": "Broadcast Protocol",
+  "states": ["true", "false"],
+  "transitions": [{ "name": "true,false->true,true",
+                    "pre": ["true", "false"],
+                    "post": ["true", "true"]
+                }
+               ],
+  "initialStates": ["true", "false"],
+  "trueStates": ["true"],
+  "predicate": "true >= 1"
 }

examples/flockofbirds_v1_c4.pp

-population protocol "Flock of Birds Protocol (variant 1) with c = 4" {
-    states      { _0 _1 _2 _3 _4 }
-    transitions { x_0_4 x_1_1 x_1_2 x_1_3 x_1_4 x_2_2 x_2_3 x_2_4 x_3_3 x_3_4 }
-    arcs {
-       { _0, _4 } -> x_0_4 -> { _4, _4 }
-       { _1, _1 } -> x_1_1 -> { _2, _0 }
-       { _1, _2 } -> x_1_2 -> { _3, _0 }
-       { _1, _3 } -> x_1_3 -> { _4, _4 }
-       { _1, _4 } -> x_1_4 -> { _4, _4 }
-       { _2, _2 } -> x_2_2 -> { _4, _4 }
-       { _2, _3 } -> x_2_3 -> { _4, _4 }
-       { _2, _4 } -> x_2_4 -> { _4, _4 }
-       { _3, _3 } -> x_3_3 -> { _4, _4 }
-       { _3, _4 } -> x_3_4 -> { _4, _4 }
-    }
-    initial   { _0 _1 }
-    true      { _4 }
-    false     { _0 _1 _2 _3 }
-    predicate { _1 >= 4 }
-}

examples/flockofbirds_v2_c4.pp

-population protocol "Flock of Birds Protocol (variant 2) with c = 4" {
-    states      { _0 _1 _2 _3 _4 }
-    transitions { x_0_4 x_1_1 x_1_4 x_2_2 x_2_4 x_3_3 x_3_4 }
-    arcs {
-       { _0, _4 } -> x_0_4 -> { _4, _4 }
-       { _1, _1 } -> x_1_1 -> { _1, _2 }
-       { _1, _4 } -> x_1_4 -> { _4, _4 }
-       { _2, _2 } -> x_2_2 -> { _2, _3 }
-       { _2, _4 } -> x_2_4 -> { _4, _4 }
-       { _3, _3 } -> x_3_3 -> { _3, _4 }
-       { _3, _4 } -> x_3_4 -> { _4, _4 }
-    }
-    initial   { _0 _1 }
-    true      { _4 }
-    false     { _0 _1 _2 _3 }
-    predicate { _1 >= 4 }
-}

examples/majority.pp

-population protocol "Majority Protocol" {
-    states      { good bad neutral mildlybad }
-    transitions { x_good_bad x_good_mildlybad x_bad_neutral x_neutral_mildlybad }
-    arcs {
-       { good,    bad       } -> x_good_bad          -> { neutral,   mildlybad }
-       { good,    mildlybad } -> x_good_mildlybad    -> { good,      neutral   }
-       { bad,     neutral   } -> x_bad_neutral       -> { bad,       mildlybad }
-       { neutral, mildlybad } -> x_neutral_mildlybad -> { mildlybad, mildlybad }
-    }
-    initial   { good bad }
-    true      { good neutral }
-    false     { bad mildlybad }
-    predicate { good > bad }
-}
+{
+    "transitions": [
+        {
+            "pre": [
+                "_a",
+                "_b"
+            ],
+            "post": [
+                "_asmall",
+                "_bsmall"
+            ],
+            "name": "x__a__b"
+        },
+        {
+            "pre": [
+                "_a",
+                "_bsmall"
+            ],
+            "post": [
+                "_a",
+                "_asmall"
+            ],
+            "name": "x__a__bsmall"
+        },
+        {
+            "pre": [
+                "_b",
+                "_asmall"
+            ],
+            "post": [
+                "_b",
+                "_bsmall"
+            ],
+            "name": "x__b__asmall"
+        },
+        {
+            "pre": [
+                "_asmall",
+                "_bsmall"
+            ],
+            "post": [
+                "_bsmall",
+                "_bsmall"
+            ],
+            "name": "x__asmall__bsmall"
+        }
+    ],
+    "states": [
+        "_a",
+        "_b",
+        "_asmall",
+        "_bsmall"
+    ],
+    "initialStates": [
+        "_a",
+        "_b"
+    ],
+    "predicate": "_a > _b",
+    "trueStates": [
+        "_a",
+        "_asmall"
+    ],
+    "title": "Majority Protocol"
+}
\ No newline at end of file

examples/remainder_m3_c1.pp

-population protocol "Remainder Protocol with m = 3 and c = 1" {
-    states      { _0 _1 _2 _true _false }
-    transitions { x_0_0 x_0_1 x_0_2 x_0_true x_1_1 x_1_2 x_1_false x_2_2 x_2_true }
-    arcs {
-       { _0, _0     } -> x_0_0     -> { _0, _false }
-       { _0, _1     } -> x_0_1     -> { _1, _true  }
-       { _0, _2     } -> x_0_2     -> { _2, _false }
-       { _0, _true  } -> x_0_true  -> { _0, _false }
-       { _1, _1     } -> x_1_1     -> { _2, _false }
-       { _1, _2     } -> x_1_2     -> { _0, _false }
-       { _1, _false } -> x_1_false -> { _1, _true  }
-       { _2, _2     } -> x_2_2     -> { _1, _true  }
-       { _2, _true  } -> x_2_true  -> { _2, _false }
-    }
-    initial { _0 _1 _2 }
-    true    { _1 _true }
-    false   { _0 _2 _false }
-    predicate {
-        EXISTS k : _1 + 2 * _2 = 1 + 3*k
-    }
-}
+{
+    "transitions": [
+        {
+            "pre": [
+                "_mod0",
+                "_mod0"
+            ],
+            "post": [
+                "_mod0",
+                "_modpassivefalse"
+            ],
+            "name": "x__mod0__mod0"
+        },
+        {
+            "pre": [
+                "_mod0",
+                "_mod1"
+            ],
+            "post": [
+                "_mod1",
+                "_modpassivetrue"
+            ],
+            "name": "x__mod0__mod1"
+        },
+        {
+            "pre": [
+                "_mod0",
+                "_mod2"
+            ],
+            "post": [
+                "_mod2",
+                "_modpassivefalse"
+            ],
+            "name": "x__mod0__mod2"
+        },
+        {
+            "pre": [
+                "_mod0",
+                "_modpassivetrue"
+            ],
+            "post": [
+                "_mod0",
+                "_modpassivefalse"
+            ],
+            "name": "x__mod0__modpassivetrue"
+        },
+        {
+            "pre": [
+                "_mod1",
+                "_mod1"
+            ],
+            "post": [
+                "_mod2",
+                "_modpassivefalse"
+            ],
+            "name": "x__mod1__mod1"
+        },
+        {
+            "pre": [
+                "_mod1",
+                "_mod2"
+            ],
+            "post": [
+                "_mod0",
+                "_modpassivefalse"
+            ],
+            "name": "x__mod1__mod2"
+        },
+        {
+            "pre": [
+                "_mod1",
+                "_modpassivefalse"
+            ],
+            "post": [
+                "_mod1",
+                "_modpassivetrue"
+            ],
+            "name": "x__mod1__modpassivefalse"
+        },
+        {
+            "pre": [
+                "_mod2",
+                "_mod2"
+            ],
+            "post": [
+                "_mod1",
+                "_modpassivetrue"
+            ],
+            "name": "x__mod2__mod2"
+        },
+        {
+            "pre": [
+                "_mod2",
+                "_modpassivetrue"
+            ],
+            "post": [
+                "_mod2",
+                "_modpassivefalse"
+            ],
+            "name": "x__mod2__modpassivetrue"
+        }
+    ],
+    "states": [
+        "_mod0",
+        "_mod1",
+        "_mod2",
+        "_modpassivetrue",
+        "_modpassivefalse"
+    ],
+    "initialStates": [
+        "_mod0",
+        "_mod1",
+        "_mod2"
+    ],
+    "predicate": "EXISTS k : 0 * _mod0 + 1 * _mod1 + 2 * _mod2 = 1 + 3 * k",
+    "trueStates": [
+        "_mod1",
+        "_modpassivetrue"
+    ],
+    "title": "Modulo Protocol with m = 3 and c = 1"
+}
\ No newline at end of file

peregrine.cabal

@@ -22,8 +22,8 @@ executable peregrine
   main-is: Main.hs
   other-modules:
   -- other-extensions:
-  build-depends:       base >=4 && <5, sbv, parsec, containers, transformers,
-                       bytestring, mtl, stm, async, parallel-io
+  build-depends:       base >=4 && <5, sbv, parsec >= 3.1, containers, transformers,
+                       bytestring, mtl, stm, async, parallel-io, text, aeson
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -fsimpl-tick-factor=1000 -threaded -rtsopts -with-rtsopts=-N

src/Parser.hs

@@ -3,6 +3,8 @@ module Parser
 where
 
 import Text.Parsec
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
 
 type Parser a = Parsec String () a
 
@@ -14,7 +16,7 @@ parseString p str =
 
 parseFile :: Parser a -> String -> IO a
 parseFile p file =  do
-        contents <- readFile file
-        case parse p file contents of
+        contents <- T.unpack <$> TIO.readFile file
+	case parse p file contents of
             Left e -> print e >> fail "parse error"
             Right r -> return r

src/Parser/PP.hs

+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Parser.PP
     (parseContent)
 where
 
+import Data.Aeson
+import Data.Aeson.TH (deriveJSON, defaultOptions)
 import Control.Applicative ((<*),(*>),(<$>))
 import Data.Functor.Identity
 import Text.Parsec
+import qualified Data.Set as S
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.Text as T
 import Text.Parsec.Expr
 import Text.Parsec.Language (LanguageDef, emptyDef)
 import qualified Text.Parsec.Token as Token
-
 import Parser
 import PopulationProtocol (PopulationProtocol,makePopulationProtocolFromStrings,State(..),Transition(..))
 import Property
@@ -25,7 +33,7 @@ languageDef =
                  Token.reservedOpNames = ["->", "<", "<=", "=", "!=", ">=", ">",
                                           "+", "-", "*", "&&", "||", "!", ":"]
                  }
-
+ 
 lexer :: Token.TokenParser ()
 lexer = Token.makeTokenParser languageDef
 
@@ -68,78 +76,6 @@ ident = (identifier <|> stringLiteral) <?> "identifier"
 identList :: Parser [String]
 identList = singleOrList ident
 
-states :: Parser [String]
-states = reserved "states" *> identList
-
-transitions :: Parser [String]
-transitions = reserved "transitions" *> identList
-
-initial :: Parser [String]
-initial = reserved "initial" *> identList
-
-trueStates :: Parser [String]
-trueStates = reserved "true" *> identList
-
-falseStates :: Parser [String]
-falseStates = reserved "false" *> identList
-
-arc :: Parser [(String,String,Integer)]
-arc = do
-        lhs <- identList
-        rhsList <- many1 (do
-                reservedOp "->"