Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.