Learning transition systems from event logs and transforming the transition system into an equivalent Petri net using state-based regions

MinimalSaturatedNet.hs

{-# 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