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

Commit 0bbb82c8 authored by Philipp J. Meyer's avatar Philipp J. Meyer
Browse files

working constraints for terminal marking reachable

parent ae3faf35
...@@ -5,7 +5,7 @@ import System.IO ...@@ -5,7 +5,7 @@ import System.IO
import Control.Monad import Control.Monad
import Control.Concurrent.ParallelIO import Control.Concurrent.ParallelIO
import Control.Arrow (first) import Control.Arrow (first)
import Data.List (partition,minimumBy) import Data.List (partition,minimumBy,genericLength)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Maybe import Data.Maybe
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
...@@ -535,18 +535,27 @@ checkTerminalMarkingReachableProperty net = do ...@@ -535,18 +535,27 @@ checkTerminalMarkingReachableProperty net = do
let nonTrivialTriplets = filter (not . trivialTriplet) triplets let nonTrivialTriplets = filter (not . trivialTriplet) triplets
let emptyTriplets = filter emptyTriplet triplets let emptyTriplets = filter emptyTriplet triplets
let nonTrivialNonEmptyTriplets = filter (not . emptyTriplet) nonTrivialTriplets let nonTrivialNonEmptyTriplets = filter (not . emptyTriplet) nonTrivialTriplets
liftIO $ putStrLn $ "All triplets (" ++ show (length triplets) ++ "):" -- TODO optimize triplet computation
liftIO $ putStrLn $ unlines $ map show triplets -- liftIO $ putStrLn $ "All triplets (" ++ show (length triplets) ++ "):"
liftIO $ putStrLn $ "Trivial triplets (" ++ show (length trivialTriplets) ++ "):" -- liftIO $ putStrLn $ unlines $ map show triplets
liftIO $ putStrLn $ unlines $ map show trivialTriplets -- liftIO $ putStrLn $ "Trivial triplets (" ++ show (length trivialTriplets) ++ "):"
liftIO $ putStrLn $ "Empty triplets (" ++ show (length emptyTriplets) ++ "):" -- liftIO $ putStrLn $ unlines $ map show trivialTriplets
liftIO $ putStrLn $ unlines $ map show emptyTriplets -- liftIO $ putStrLn $ "Empty triplets (" ++ show (length emptyTriplets) ++ "):"
liftIO $ putStrLn $ "Non-trivial, non-empty triplets (" ++ show (length nonTrivialNonEmptyTriplets) ++ "):" -- liftIO $ putStrLn $ unlines $ map show emptyTriplets
liftIO $ putStrLn $ unlines $ map show nonTrivialNonEmptyTriplets -- liftIO $ putStrLn $ "Non-trivial, non-empty triplets (" ++ show (length nonTrivialNonEmptyTriplets) ++ "):"
return Satisfied -- liftIO $ putStrLn $ unlines $ map show nonTrivialNonEmptyTriplets
r <- checkSat $ checkTerminalMarkingReachableSat net nonTrivialTriplets 2 checkTerminalMarkingReachableProperty' net nonTrivialTriplets 1 $ genericLength $ transitions net
checkTerminalMarkingReachableProperty' :: PetriNet -> [Triplet] -> Integer -> Integer -> OptIO PropResult
checkTerminalMarkingReachableProperty' net triplets k kmax = do
verbosePut 1 $ "Checking terminal marking reachable with at most " ++ show k ++ " partitions"
r <- checkSat $ checkTerminalMarkingReachableSat net triplets k
case r of case r of
Nothing -> return Unknown Nothing ->
if k < kmax then
checkTerminalMarkingReachableProperty' net triplets (k + 1) kmax
else
return Unknown
Just inv -> do Just inv -> do
invariant <- opt optInvariant invariant <- opt optInvariant
if invariant then if invariant then
......
...@@ -6,7 +6,7 @@ module Solver.TerminalMarkingReachable ...@@ -6,7 +6,7 @@ module Solver.TerminalMarkingReachable
where where
import Data.SBV import Data.SBV
import Data.List (intercalate) import Data.List (intercalate,genericReplicate)
import qualified Data.Map as M import qualified Data.Map as M
import Util import Util
...@@ -17,36 +17,65 @@ import StructuralComputation ...@@ -17,36 +17,65 @@ import StructuralComputation
type TerminalMarkingReachableInvariant = [BlockInvariant] type TerminalMarkingReachableInvariant = [BlockInvariant]
data BlockInvariant = data BlockInvariant =
BlockInvariant (Int, [Transition], IVector Place) BlockInvariant (Integer, [Transition], IVector Place)
instance Invariant BlockInvariant where instance Invariant BlockInvariant where
invariantSize (BlockInvariant (_, _, yi)) = size yi invariantSize (BlockInvariant (_, ti, yi)) = if null ti then 0 else size yi
instance Show BlockInvariant where instance Show BlockInvariant where
show (BlockInvariant (i, ti, yi)) = show (BlockInvariant (i, ti, yi)) =
"T_" ++ show i ++ ": " ++ show ti ++ "; " ++ intercalate " + " (map showWeighted (items yi)) "T_" ++ show i ++ ": " ++ show ti ++
(if null ti then "" else " => " ++ intercalate " + " (map showWeighted (items yi)))
nonNegativityConstraints :: (Ord a, Show a) => SIMap a -> SBool nonNegativityConstraints :: (Ord a, Show a) => SIMap a -> SBool
nonNegativityConstraints m = nonNegativityConstraints m =
bAnd $ map checkVal $ vals m bAnd $ map checkVal $ vals m
where checkVal x = x .>= 0 where checkVal x = x .>= 0
checkTerminalMarkingReachable :: PetriNet -> [Triplet] -> Int -> [SIMap Place] -> SIMap Transition -> SBool checkNonNegativityConstraints :: (Ord a, Show a) => [SIMap a] -> SBool
checkTerminalMarkingReachable net triplets k ys b = checkNonNegativityConstraints xs =
bAnd (map nonNegativityConstraints ys) bAnd $ map nonNegativityConstraints xs
-- farkas lemma constraints
-- triplet constraints
-- block constraints
checkTerminalMarkingReachableSat :: PetriNet -> [Triplet] -> Int -> ConstraintProblem Integer TerminalMarkingReachableInvariant blockTerminationConstraints :: PetriNet -> Integer -> SIMap Transition -> SIMap Place -> SBool
blockTerminationConstraints net i b y =
bAnd $ map checkTransition $ transitions net
where checkTransition t =
let incoming = map addPlace $ lpre net t
outgoing = map addPlace $ lpost net t
in (val b t .== literal i) ==> (sum outgoing - sum incoming .< 0)
addPlace (p, w) = literal w * val y p
terminationConstraints :: PetriNet -> Integer -> SIMap Transition -> [SIMap Place] -> SBool
terminationConstraints net k b ys =
bAnd $ [blockTerminationConstraints net i b y | (i,y) <- zip [1..] ys]
blockConstraints :: PetriNet -> Integer -> SIMap Transition -> SBool
blockConstraints net k b =
bAnd $ map checkBlock $ transitions net
where checkBlock t = literal 1 .<= val b t &&& val b t .<= literal k
blockOrderConstraints :: PetriNet -> [Triplet] -> Integer -> SIMap Transition -> SBool
blockOrderConstraints net triplets k b =
bAnd $ map checkTriplet triplets
where checkTriplet (s,t,ts) = (val b s .> val b t) ==> bOr (map (\t' -> val b t' .== val b t) ts)
checkTerminalMarkingReachable :: PetriNet -> [Triplet] -> Integer -> SIMap Transition -> [SIMap Place] -> SBool
checkTerminalMarkingReachable net triplets k b ys =
blockConstraints net k b &&&
terminationConstraints net k b ys &&&
blockOrderConstraints net triplets k b &&&
checkNonNegativityConstraints ys
checkTerminalMarkingReachableSat :: PetriNet -> [Triplet] -> Integer -> ConstraintProblem Integer TerminalMarkingReachableInvariant
checkTerminalMarkingReachableSat net triplets k = checkTerminalMarkingReachableSat net triplets k =
let makeYName i = (++) (replicate i '\'') let makeYName i = (++) (genericReplicate i '\'')
ys = [makeVarMapWith (makeYName i) $ places net | i <- [1..k]] ys = [makeVarMapWith (makeYName i) $ places net | i <- [1..k]]
b = makeVarMap $ transitions net b = makeVarMap $ transitions net
in ("terminal marking reachable", "invariant", in ("terminal marking reachable", "invariant",
concat (map getNames ys) ++ getNames b, concat (map getNames ys) ++ getNames b,
\fm -> checkTerminalMarkingReachable net triplets k (map (fmap fm) ys) (fmap fm b), \fm -> checkTerminalMarkingReachable net triplets k (fmap fm b) (map (fmap fm) ys),
\fm -> invariantFromAssignment (map (fmap fm) ys) (fmap fm b)) \fm -> invariantFromAssignment net k (fmap fm b) (map (fmap fm) ys))
invariantFromAssignment :: [IMap Place] -> IMap Transition -> TerminalMarkingReachableInvariant invariantFromAssignment :: PetriNet -> Integer -> IMap Transition -> [IMap Place] -> TerminalMarkingReachableInvariant
invariantFromAssignment ys b = [BlockInvariant (1, [], buildVector [])] invariantFromAssignment net k b ys =
[BlockInvariant (i, M.keys (M.filter (== i) b), makeVector y) | (i,y) <- zip [1..] ys]
...@@ -10,6 +10,7 @@ import qualified Data.Map as M ...@@ -10,6 +10,7 @@ import qualified Data.Map as M
type Triplet = (Transition, Transition, [Transition]) type Triplet = (Transition, Transition, [Transition])
-- TODO: optimize
generateTriplets :: PetriNet -> [Triplet] generateTriplets :: PetriNet -> [Triplet]
generateTriplets net = generateTriplets net =
let let
......
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