Starting from 2021-07-01, all LRZ GitLab users will be required to explicitly accept the GitLab Terms of Service. Please see the detailed information at https://doku.lrz.de/display/PUBLIC/GitLab and make sure that your projects conform to the requirements.

Commit 7610121c authored by Philipp Meyer's avatar Philipp Meyer
Browse files

Extended simplifier and options to specify simplification level

parent 1329e5f6
...@@ -288,15 +288,8 @@ checkLivenessProperty net f = do ...@@ -288,15 +288,8 @@ checkLivenessProperty net f = do
getLivenessInvariant :: PetriNet -> Formula Transition -> [Cut] -> OptIO (Maybe [LivenessInvariant]) getLivenessInvariant :: PetriNet -> Formula Transition -> [Cut] -> OptIO (Maybe [LivenessInvariant])
getLivenessInvariant net f cuts = do getLivenessInvariant net f cuts = do
simp <- opt optSimpFormula
dnfCuts <- generateCuts net f cuts dnfCuts <- generateCuts net f cuts
verbosePut 2 $ "Number of " ++ (if simp > 0 then "simplified " else "") ++ verbosePut 2 $ "Number of disjuncts: " ++ show (length dnfCuts)
"disjuncts: " ++ show (length dnfCuts)
--
--z <- conciliate (transitions net)
-- (checkSimpleCuts dnfCuts) (transitionVectorConstraints net)
--verbosePut 0 $ "Conciliated set: " ++ show z
--
rs <- mapM (checkSat . checkLivenessInvariantSat net) dnfCuts rs <- mapM (checkSat . checkLivenessInvariantSat net) dnfCuts
let added = map (Just . cutToLivenessInvariant) cuts let added = map (Just . cutToLivenessInvariant) cuts
return $ sequence (rs ++ added) return $ sequence (rs ++ added)
......
...@@ -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 = 2 , optSimpFormula = 6
, optRefinementType = Just SComponentWithCutRefinement , optRefinementType = Just SComponentWithCutRefinement
, optMinimizeRefinement = 0 , optMinimizeRefinement = 0
, optInvariant = False , optInvariant = False
...@@ -87,7 +87,7 @@ options = ...@@ -87,7 +87,7 @@ options =
(NoArg (\opt -> Right opt { inputFormat = MIST })) (NoArg (\opt -> Right opt { inputFormat = MIST }))
"Use the mist input format" "Use the mist input format"
, Option "s" ["structure"] , Option "" ["structure"]
(NoArg (\opt -> Right opt { optPrintStructure = True })) (NoArg (\opt -> Right opt { optPrintStructure = True }))
"Print structural information" "Print structural information"
...@@ -218,11 +218,13 @@ options = ...@@ -218,11 +218,13 @@ options =
})) }))
"Do not use the properties given in the input file" "Do not use the properties given in the input file"
, Option "" ["simp-0"] , Option "s" ["simp"]
(NoArg (\opt -> Right opt { (ReqArg (\arg opt -> case reads arg of
optSimpFormula = 0 [(i, "")] -> Right opt { optSimpFormula = i }
})) _ -> Left ("invalid argument for simplification level: " ++ arg)
"Do not simplify formula for invariant generation" )
"LEVEL")
"Simply formula with level LEVEL"
, Option "" ["simp-1"] , Option "" ["simp-1"]
(NoArg (\opt -> Right opt { (NoArg (\opt -> Right opt {
......
...@@ -7,6 +7,8 @@ module Solver.Simplifier ( ...@@ -7,6 +7,8 @@ module Solver.Simplifier (
import Data.SBV import Data.SBV
import Data.Maybe import Data.Maybe
import Control.Monad
import Control.Monad.Identity
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
...@@ -51,34 +53,45 @@ cutTransitions (c0, cs) = S.unions (c0:cs) ...@@ -51,34 +53,45 @@ cutTransitions (c0, cs) = S.unions (c0:cs)
generateCuts :: PetriNet -> Formula Transition -> [Cut] -> OptIO [SimpleCut] generateCuts :: PetriNet -> Formula Transition -> [Cut] -> OptIO [SimpleCut]
generateCuts net f cuts = do generateCuts net f cuts = do
simp <- opt optSimpFormula simp <- opt optSimpFormula
let cs = [formulaToCut f] : map cutToSimpleDNFCuts cuts let simpFunctions =
let cs' = foldl1 (combine simp) cs [ return . simplifyCuts
let cs'' = if simp > 1 then filterInvariantTransitions net cs' else cs' , return . removeImplicants
let cs''' = if simp > 1 then simplifyCuts cs'' else cs'' , return . filterInvariantTransitions net
cs'''' <- if simp > 1 then mapM (greedySimplify net) cs''' else return cs''' , simplifyBySubsumption
if simp > 1 then simplifyBySubsumption (simplifyCuts cs'''') else return cs'''' , greedySimplify net
, simplifyBySubsumption
]
let (otfSimps, afterSimps) = splitAt 2 $ take simp simpFunctions
let simpFunction = foldl (>=>) return $ reverse afterSimps
let otfFunction = foldl (>=>) return $ reverse otfSimps
let cnfCuts = [formulaToCut f] : map cutToSimpleDNFCuts cuts
dnfCuts <- foldM (combine otfFunction) [(S.empty, [])] cnfCuts
simpFunction dnfCuts
where where
combine simp cs1 cs2 = combine simpFunction cs1 cs2 =
let cs = [ (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 ]
in if simp > 0 then simplifyCuts cs else cs
filterInvariantTransitions :: PetriNet -> [SimpleCut] -> [SimpleCut] filterInvariantTransitions :: PetriNet -> [SimpleCut] -> [SimpleCut]
filterInvariantTransitions net cuts = filterInvariantTransitions net =
let ts = S.fromList $ invariantTransitions net let ts = S.fromList $ invariantTransitions net
in map (filterTransitions ts) cuts in runIdentity . simplifyWithFilter (return . filterTransitions ts) isMoreGeneralCut
filterTransitions :: S.Set Transition -> SimpleCut -> SimpleCut filterTransitions :: S.Set Transition -> SimpleCut -> (Bool, SimpleCut)
filterTransitions ts (c0, cs) = filterTransitions ts (c0, cs) =
let c0' = c0 `S.difference` ts let c0' = c0 `S.difference` ts
cs' = filter (S.null . S.intersection ts) cs cs' = filter (S.null . S.intersection ts) cs
in (c0', cs') changed = not $ all (S.null . S.intersection ts) cs
in (changed, (c0', cs'))
invariantTransitions :: PetriNet -> [Transition] invariantTransitions :: PetriNet -> [Transition]
invariantTransitions net = filter (\t -> lpre net t == lpost net t) $ transitions net invariantTransitions net = filter (\t -> lpre net t == lpost net t) $ transitions net
removeImplicants :: [SimpleCut] -> [SimpleCut]
removeImplicants = removeWith isMoreGeneralCut
simplifyCuts :: [SimpleCut] -> [SimpleCut] simplifyCuts :: [SimpleCut] -> [SimpleCut]
simplifyCuts = removeWith isMoreGeneralCut . mapMaybe simplifyCut simplifyCuts = mapMaybe simplifyCut
simplifyCut :: SimpleCut -> Maybe SimpleCut simplifyCut :: SimpleCut -> Maybe SimpleCut
simplifyCut (c0, cs) = simplifyCut (c0, cs) =
...@@ -102,6 +115,18 @@ simplifyBySubsumption' acc (c0:cs) = do ...@@ -102,6 +115,18 @@ simplifyBySubsumption' acc (c0:cs) = do
Just _ -> c0:acc Just _ -> c0:acc
simplifyBySubsumption' acc' cs simplifyBySubsumption' acc' cs
simplifyWithFilter :: (Monad m) => (a -> m (Bool, a)) -> (a -> a -> Bool) -> [a] -> m [a]
simplifyWithFilter simp f = simpFilter []
where
simpFilter acc [] = return $ reverse acc
simpFilter acc (x:xs) = do
(changed, x') <- simp x
if changed then
simpFilter (x' : notFilter x' acc) (notFilter x' xs)
else
simpFilter (x' : acc) xs
notFilter x = filter (not . f x)
removeWith :: (a -> a -> Bool) -> [a] -> [a] removeWith :: (a -> a -> Bool) -> [a] -> [a]
removeWith f = removeCuts' [] removeWith f = removeCuts' []
where where
...@@ -109,6 +134,7 @@ removeWith f = removeCuts' [] ...@@ -109,6 +134,7 @@ removeWith f = removeCuts' []
removeCuts' acc (x:xs) = removeCuts' (x : notFilter x acc) (notFilter x xs) removeCuts' acc (x:xs) = removeCuts' (x : notFilter x acc) (notFilter x xs)
notFilter x = filter (not . f x) notFilter x = filter (not . f x)
-- c1 `isMoreGeneralCut` c2 <=> (c2 => c1)
isMoreGeneralCut :: SimpleCut -> SimpleCut -> Bool isMoreGeneralCut :: SimpleCut -> SimpleCut -> Bool
isMoreGeneralCut (c1c0, c1cs) (c2c0, c2cs) = isMoreGeneralCut (c1c0, c1cs) (c2c0, c2cs) =
c1c0 `S.isSubsetOf` c2c0 && all (\c1 -> any (`S.isSubsetOf` c1) c2cs) c1cs c1c0 `S.isSubsetOf` c2c0 && all (\c1 -> any (`S.isSubsetOf` c1) c2cs) c1cs
...@@ -144,26 +170,26 @@ formulaToCut = transformF ...@@ -144,26 +170,26 @@ formulaToCut = transformF
checkCut :: PetriNet -> SimpleCut -> OptIO Bool checkCut :: PetriNet -> SimpleCut -> OptIO Bool
checkCut net cut = do checkCut net cut = do
verbosePut 0 $ "checking cut " ++ show cut
r <- checkSat $ checkTransitionInvariantWithSimpleCutSat net cut r <- checkSat $ checkTransitionInvariantWithSimpleCutSat net cut
return $ isNothing r return $ isNothing r
greedySimplifyCut :: PetriNet -> SimpleCut -> SimpleCut-> OptIO SimpleCut greedySimplifyCut :: PetriNet -> Bool -> SimpleCut -> SimpleCut-> OptIO (Bool, SimpleCut)
greedySimplifyCut net cutAcc@(c0Acc, csAcc) (c0, cs) = greedySimplifyCut net changed cutAcc@(c0Acc, csAcc) (c0, cs) =
case (S.null c0, cs) of case (S.null c0, cs) of
(True, []) -> return cutAcc (True, []) -> return (changed, cutAcc)
(False, _) -> do (False, _) -> do
let (c, c0') = S.deleteFindMin c0 let (c, c0') = S.deleteFindMin c0
let cut = (c0Acc `S.union` c0', csAcc ++ cs) let cut = (c0Acc `S.union` c0', csAcc ++ cs)
r <- checkCut net cut r <- checkCut net cut
greedySimplifyCut net (if r then cutAcc else (S.insert c c0Acc, csAcc)) (c0', cs) greedySimplifyCut net (r || changed)
(if r then cutAcc else (S.insert c c0Acc, csAcc)) (c0', cs)
(True, c:cs') -> do (True, c:cs') -> do
let cut = (c0Acc `S.union` c0, csAcc ++ cs') let cut = (c0Acc `S.union` c0, csAcc ++ cs')
r <- checkCut net cut r <- checkCut net cut
greedySimplifyCut net (if r then cutAcc else (c0Acc, c:csAcc)) (c0, cs') greedySimplifyCut net (r || changed)
(if r then cutAcc else (c0Acc, c:csAcc)) (c0, cs')
greedySimplify :: PetriNet -> SimpleCut -> OptIO SimpleCut greedySimplify :: PetriNet -> [SimpleCut] -> OptIO [SimpleCut]
greedySimplify net cut = do greedySimplify net =
verbosePut 0 $ "simplifying cut " ++ show cut simplifyWithFilter (greedySimplifyCut net False (S.empty, [])) isMoreGeneralCut
greedySimplifyCut net (S.empty, []) cut
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