Skip to content
{{ message }}

Instantly share code, notes, and snippets.

# msakai/MinimalSaturatedNet.hs

Last active Aug 29, 2015
Learning transition systems from event logs and transforming the transition system into an equivalent Petri net using state-based regions
 {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -- | This module provides two functionality: -- -- * Learning transition systems from event logs -- -- * Transforming the transition system into an equivalent Petri net using state-based regions. -- -- References: -- -- * Wil van der Aalst, "Process Mining: Data science in Action", Week 3, -- https://www.coursera.org/course/procmin import Prelude hiding (any) import Control.Monad import Data.Foldable (toList, any) import Data.Function import Data.List hiding (any) import Data.Maybe import Data.MultiSet (MultiSet) -- http://hackage.haskell.org/package/multiset import qualified Data.MultiSet as MultiSet import Data.Sequence (Seq, (|>), ViewL (..), ViewR (..)) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set type TransitionSystem s a = (Set s, Set a, Set (s,a,s)) learnTransitionSystem :: forall a s. (Ord a, Ord s) => ((Seq a, Seq a) -> s) -> Set [a] -> TransitionSystem s a learnTransitionSystem abstract traces = (states, activities, transitions) where f :: Seq a -> Seq a -> [(s,a,s)] f past future = case Seq.viewl future of EmptyL -> [] x :< xs -> (curr, x, abstract (past |> x, xs)) : f (past |> x) xs where curr = abstract (past, future) transitions :: Set (s,a,s) transitions = Set.fromList [(s1,a,s2) | trace <- Set.toList traces, (s1,a,s2) <- f Seq.empty (Seq.fromList trace)] states :: Set s states = Set.map (\(s1,_,_) -> s1) transitions `Set.union` Set.map (\(_,_,s2) -> s2) transitions activities :: Set a activities = Set.unions [Set.fromList trace | trace <- Set.toList traces] exampleTraces1 :: Set String exampleTraces1 = Set.fromList ["abcd", "acbd", "aed"] -- past without abstraction test1 = learnTransitionSystem (\(past, _future) -> past) exampleTraces1 -- future without abstraction test2 = learnTransitionSystem (\(_past, future) -> future) exampleTraces1 -- past with multiset abstraction test3 = learnTransitionSystem abstract exampleTraces1 where abstract (past, _future) = MultiSet.fromList (toList past) -- only last event matters for state test4 = learnTransitionSystem abstract exampleTraces1 where abstract (past, _future) = case Seq.viewr past of EmptyR -> "" _ :> x -> [x] -- only next event matters for state test5 = learnTransitionSystem abstract exampleTraces1 where abstract (_past, future) = case Seq.viewl future of EmptyL -> "" x :< _ -> [x] exampleTraces2 :: Set String exampleTraces2 = Set.fromList ["abcd", "acbd", "abcefbcd", "abcefcbd", "acbefbcd", "acbefbcefcbd"] -- only last event matters test6 = learnTransitionSystem abstract exampleTraces2 where abstract (past, _future) = case Seq.viewr past of EmptyR -> "" _ :> x -> [x] -- only last two event matters (set abstraction) test7 = learnTransitionSystem abstract exampleTraces2 where abstract (past, _future) = case Seq.viewr past of EmptyR -> Set.empty xs :> x1 -> case Seq.viewr xs of EmptyR -> Set.singleton x1 _ :> x2 -> Set.fromList [x2,x1] data PetriNetArc p t = P2T p t | T2P t p deriving (Eq, Ord, Show) type PetriNet p t = (Set p, Set t, MultiSet (PetriNetArc p t)) type MarkedPetriNet p t = (PetriNet p t, MultiSet p) type Region s = Set s isDisjoint :: Ord a => Set a -> Set a -> Bool isDisjoint xs ys = Set.null (xs `Set.intersection` ys) removeNonMinimals :: forall a. Ord a => Set (Set a) -> Set (Set a) removeNonMinimals = foldl' f Set.empty . sortBy (compare `on` Set.size) . Set.toList where f :: Set (Set a) -> (Set a) -> Set (Set a) f xss ys = if any (`Set.isSubsetOf` ys) xss then xss else Set.insert ys xss minimalNontrivialRegions :: forall a s. (Ord a, Ord s) => TransitionSystem s a -> Set (Region s) minimalNontrivialRegions (states, _activities, transitions) = removeNonMinimals \$ Set.fromList \$ loop Set.empty Set.empty states where isRegion :: Set s -> Bool isRegion curr = isDisjoint enters exits && isDisjoint enters notcrossings && isDisjoint exits notcrossings where enters = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.notMember` curr, s2 `Set.member` curr] exits = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.member` curr, s2 `Set.notMember` curr] notcrossings = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.member` curr == s2 `Set.member` curr] stabilize :: Set s -> Set s -> Maybe (Set s, Set s) stabilize curr comp | not (isDisjoint curr comp) = Nothing | not (isDisjoint enters exits && isDisjoint enters notcrossings && isDisjoint exits notcrossings) = Nothing | curr == curr' && comp == comp' = Just (curr, comp) | otherwise = stabilize curr' comp' where enters = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.member` comp, s2 `Set.member` curr] exits = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.member` curr, s2 `Set.member` comp] notcrossings = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, (s1 `Set.member` curr && s2 `Set.member` curr) || (s1 `Set.member` comp && s2 `Set.member` comp)] curr' = curr `Set.union` Set.unions (map f (Set.toList transitions)) where f (s1,a,s2) | a `Set.member` enters = Set.singleton s2 | a `Set.member` exits = Set.singleton s1 | a `Set.member` notcrossings && (s1 `Set.member` curr || s2 `Set.member` curr) = Set.fromList [s1,s2] | otherwise = Set.empty comp' = comp `Set.union` Set.unions (map f (Set.toList transitions)) where f (s1,a,s2) | a `Set.member` enters = Set.singleton s1 | a `Set.member` exits = Set.singleton s2 | a `Set.member` notcrossings && (s1 `Set.member` comp || s2 `Set.member` comp) = Set.fromList [s1,s2] | otherwise = Set.empty loop :: Set s -> Set s -> Set s -> [Region s] loop curr comp rest | curr == states = [] | not (Set.null curr) && isRegion curr = return curr | otherwise = case Set.minView rest of Nothing -> [] Just (s, rest') -> msum [ do (curr', comp') <- maybeToList \$ stabilize (Set.insert s curr) comp loop curr' comp' (rest' `Set.difference` curr' `Set.difference` comp') , do (curr', comp') <- maybeToList \$ stabilize curr (Set.insert s comp) loop curr' comp' (rest' `Set.difference` curr' `Set.difference` comp') ] exampleTransitionSystem :: TransitionSystem Int Char exampleTransitionSystem = ( Set.fromList [1..10] , Set.fromList "abcde" , Set.fromList [ (1,'a',2) , (2,'b',3) , (2,'c',4) , (2,'d',5) , (3,'c',6) , (3,'d',7) , (4,'b',6) , (4,'d',8) , (5,'b',7) , (5,'c',8) , (6,'d',9) , (7,'c',9) , (8,'b',9) , (9,'e',10) ] ) test8 = minimalNontrivialRegions exampleTransitionSystem minimalSaturatedNet :: (Ord a, Ord s) => TransitionSystem s a -> s -> MarkedPetriNet (Region s) a minimalSaturatedNet ts@(_states, activities, transitions) startState = ((regions, activities, arcs), marking) where regions = minimalNontrivialRegions ts arcs = MultiSet.unions [f r | r <- Set.toList regions] where f region = MultiSet.union (MultiSet.fromList [T2P a region | a <- Set.toList enters]) (MultiSet.fromList [P2T region a | a <- Set.toList exits]) where enters = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.notMember` region, s2 `Set.member` region] exits = Set.fromList [a | (s1,a,s2) <- Set.toList transitions, s1 `Set.member` region, s2 `Set.notMember` region] marking = MultiSet.fromList [r | r <- Set.toList regions, startState `Set.member` r] test9 = minimalSaturatedNet exampleTransitionSystem 1
to join this conversation on GitHub. Already have an account? Sign in to comment