6.5.2021, 9:00 - 11:00: Due to updates GitLab may be unavailable for some minutes between 09:00 and 11:00.

Commit a2c3d0b7 authored by Philipp Meyer's avatar Philipp Meyer

Testing different simplifications in parallel

parent 48963ebf
...@@ -22,7 +22,7 @@ executable slapnet ...@@ -22,7 +22,7 @@ executable slapnet
other-modules: other-modules:
-- other-extensions: -- other-extensions:
build-depends: base >=4 && <5, sbv, parsec, containers, transformers, build-depends: base >=4 && <5, sbv, parsec, containers, transformers,
bytestring, mtl bytestring, mtl, stm, async, parallel-io
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -fsimpl-tick-factor=1000 ghc-options: -fsimpl-tick-factor=1000 -threaded -rtsopts -with-rtsopts=-N
...@@ -3,6 +3,7 @@ module Main where ...@@ -3,6 +3,7 @@ module Main where
import System.Exit import System.Exit
import System.IO import System.IO
import Control.Monad import Control.Monad
import Control.Concurrent.ParallelIO
import Control.Arrow (first) import Control.Arrow (first)
import Data.List (partition) import Data.List (partition)
import Data.Maybe import Data.Maybe
...@@ -405,14 +406,19 @@ main = do ...@@ -405,14 +406,19 @@ main = do
exitSuccessWith :: String -> IO () exitSuccessWith :: String -> IO ()
exitSuccessWith msg = do exitSuccessWith msg = do
putStrLn msg putStrLn msg
exitSuccess cleanupAndExitWith ExitSuccess
exitFailureWith :: String -> IO () exitFailureWith :: String -> IO ()
exitFailureWith msg = do exitFailureWith msg = do
putStrLn msg putStrLn msg
exitWith $ ExitFailure 2 cleanupAndExitWith $ ExitFailure 2
exitErrorWith :: String -> IO () exitErrorWith :: String -> IO ()
exitErrorWith msg = do exitErrorWith msg = do
hPutStrLn stderr msg hPutStrLn stderr msg
exitWith $ ExitFailure 3 cleanupAndExitWith $ ExitFailure 3
cleanupAndExitWith :: ExitCode -> IO ()
cleanupAndExitWith code = do
stopGlobalPool
exitWith code
...@@ -59,7 +59,7 @@ startOptions = Options { inputFormat = PNET ...@@ -59,7 +59,7 @@ startOptions = Options { inputFormat = PNET
, optShowVersion = False , optShowVersion = False
, optProperties = [] , optProperties = []
, optTransformations = [] , optTransformations = []
, optSimpFormula = 6 , optSimpFormula = 100
, optRefinementType = Just SComponentWithCutRefinement , optRefinementType = Just SComponentWithCutRefinement
, optMinimizeRefinement = 0 , optMinimizeRefinement = 0
, optInvariant = False , optInvariant = False
......
...@@ -7,6 +7,9 @@ module Solver.Simplifier ( ...@@ -7,6 +7,9 @@ module Solver.Simplifier (
import Data.SBV import Data.SBV
import Data.Maybe import Data.Maybe
import Data.Ord (comparing)
import Data.List (minimumBy)
import Control.Arrow (second)
import Control.Monad import Control.Monad
import Control.Monad.Identity import Control.Monad.Identity
import qualified Data.Map as M import qualified Data.Map as M
...@@ -50,47 +53,66 @@ checkSubsumptionSat c0 cs = ...@@ -50,47 +53,66 @@ checkSubsumptionSat c0 cs =
cutTransitions :: SimpleCut -> S.Set Transition cutTransitions :: SimpleCut -> S.Set Transition
cutTransitions (c0, cs) = S.unions (c0:cs) cutTransitions (c0, cs) = S.unions (c0:cs)
generateCuts :: PetriNet -> Formula Transition -> [Cut] -> OptIO [SimpleCut] type SimpConfig = ([[SimpleCut] -> OptIO [SimpleCut]], SimpleCut, SimpleCut, Int)
generateCuts net f cuts = do
simp <- opt optSimpFormula
let simpFunctions = simpWithoutFormula :: PetriNet -> Formula Transition -> SimpConfig
simpWithoutFormula net f =
(
[ return . simplifyCuts [ return . simplifyCuts
, return . removeImplicants , return . removeImplicants
, simplifyBySubsumption
, greedySimplify net f , greedySimplify net f
, return . combineCuts
, simplifyBySubsumption , simplifyBySubsumption
] ]
let (otfSimps, afterSimps) = splitAt 2 $ take simp simpFunctions , (S.empty, [])
let simpFunction = foldl (>=>) return afterSimps , second (S.fromList (transitions net) :) (formulaToCut f)
let otfFunction = foldl (>=>) return otfSimps , 2
let cnfCuts = map cutToSimpleDNFCuts cuts )
dnfCuts <- foldM (combine otfFunction) [(S.empty, [])] cnfCuts
simpCuts <- simpFunction dnfCuts simpWithFormula :: PetriNet -> Formula Transition -> SimpConfig
simpWithFormula net f =
let simpFunctions' = (
[ return . simplifyCuts [ return . simplifyCuts
, return . removeImplicants , return . removeImplicants
, return . filterInvariantTransitions net , return . filterInvariantTransitions net
, simplifyBySubsumption
, greedySimplify net FTrue , greedySimplify net FTrue
, return . combineCuts
, simplifyBySubsumption , simplifyBySubsumption
] ]
let (otfSimps', afterSimps') = splitAt 2 $ take simp simpFunctions' , second (S.fromList (transitions net) :) (formulaToCut f)
let simpFunction' = foldl (>=>) return afterSimps' , (S.empty, [])
let otfFunction' = foldl (>=>) return otfSimps' , 2
)
let (fc0, fcs) = formulaToCut f
let addedTransitions = S.fromList (transitions net) applySimpConfig :: SimpConfig -> [Cut] -> OptIO [SimpleCut]
let addedCut = (fc0, addedTransitions : fcs) applySimpConfig (simpFunctions, initialCut, afterCut, otfIndex) cuts = do
simpCutsWithFormula <- combine otfFunction' [addedCut] simpCuts simp <- opt optSimpFormula
simpCuts' <- simpFunction' simpCutsWithFormula let (otfSimps, afterSimps) = splitAt otfIndex $ take simp simpFunctions
return simpCuts' let simpFunction = foldl (>=>) return afterSimps
let otfFunction = foldl (>=>) return otfSimps
let cnfCuts = map cutToSimpleDNFCuts cuts
dnfCuts <- foldM (combine otfFunction) [initialCut] cnfCuts
simpCuts <- simpFunction dnfCuts
combine otfFunction [afterCut] simpCuts
where where
combine simpFunction cs1 cs2 = combine simpFunction cs1 cs2 =
simpFunction [ (c1c0 `S.union` c2c0, c1cs ++ c2cs) simpFunction [ (c1c0 `S.union` c2c0, c1cs ++ c2cs)
| (c1c0, c1cs) <- cs1, (c2c0, c2cs) <- cs2 ] | (c1c0, c1cs) <- cs1, (c2c0, c2cs) <- cs2 ]
generateCuts :: PetriNet -> Formula Transition -> [Cut] -> OptIO [SimpleCut]
generateCuts net f cuts = do
let configs = [simpWithFormula, simpWithoutFormula]
let tasks = map (\c -> applySimpConfig (c net f) cuts) configs
rs <- parallelIO tasks
return $ minimumBy (comparing length) rs
combineCuts :: [SimpleCut] -> [SimpleCut]
combineCuts cuts =
M.toList $ M.fromListWith combineFunc cuts
where
combineFunc cs cs' =
simplifyPositiveCut [ c `S.union` c' | c <- cs, c' <- cs' ]
filterInvariantTransitions :: PetriNet -> [SimpleCut] -> [SimpleCut] filterInvariantTransitions :: PetriNet -> [SimpleCut] -> [SimpleCut]
filterInvariantTransitions net = filterInvariantTransitions net =
let ts = S.fromList $ invariantTransitions net let ts = S.fromList $ invariantTransitions net
...@@ -115,12 +137,15 @@ simplifyCuts = mapMaybe simplifyCut ...@@ -115,12 +137,15 @@ simplifyCuts = mapMaybe simplifyCut
simplifyCut :: SimpleCut -> Maybe SimpleCut simplifyCut :: SimpleCut -> Maybe SimpleCut
simplifyCut (c0, cs) = simplifyCut (c0, cs) =
let remove b a = a `S.difference` b let remove b a = a `S.difference` b
cs' = removeWith S.isSubsetOf $ map (remove c0) cs cs' = simplifyPositiveCut $ map (remove c0) cs
in if any S.null cs' then in if any S.null cs' then
Nothing Nothing
else else
Just (c0, cs') Just (c0, cs')
simplifyPositiveCut :: [S.Set Transition] -> [S.Set Transition]
simplifyPositiveCut = removeWith S.isSubsetOf
simplifyBySubsumption :: [SimpleCut] -> OptIO [SimpleCut] simplifyBySubsumption :: [SimpleCut] -> OptIO [SimpleCut]
simplifyBySubsumption = simplifyBySubsumption' [] simplifyBySubsumption = simplifyBySubsumption' []
......
...@@ -5,15 +5,16 @@ module Util ...@@ -5,15 +5,16 @@ module Util
listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal, listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal,
makeVarMap,makeVarMapWith,buildVector,makeVector,getNames, makeVarMap,makeVarMapWith,buildVector,makeVector,getNames,
Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted, Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted,
OptIO,verbosePut,opt,putLine) OptIO,verbosePut,opt,putLine,parallelIO)
where where
import Data.SBV import Data.SBV
import qualified Data.Map as M import qualified Data.Map as M
import Control.Monad
import Data.List import Data.List
import Data.Ord import Data.Ord
import Data.Function import Data.Function
import Control.Concurrent.ParallelIO
import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import System.IO import System.IO
...@@ -115,6 +116,11 @@ verbosePut level str = do ...@@ -115,6 +116,11 @@ verbosePut level str = do
putLine :: String -> OptIO () putLine :: String -> OptIO ()
putLine = liftIO . putStrLn putLine = liftIO . putStrLn
parallelIO :: [OptIO a] -> OptIO [a]
parallelIO tasks = do
opts <- ask
liftIO $ parallel $ map (`runReaderT` opts) tasks
{- {-
- String functions - String functions
-} -}
......
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