module Modelling.PetriNet.Reach.Draw (drawToFile, isPetriDrawable) where

import qualified Data.Map                         as M (fromList)
import qualified Data.Set                         as S (toList)

import Capabilities.Cache               (MonadCache)
import Capabilities.Diagrams            (MonadDiagrams)
import Capabilities.Graphviz            (MonadGraphviz)
import Modelling.PetriNet.Diagram       (cacheNet, isNetDrawable)
import Modelling.PetriNet.Reach.Type (
  Net (connections, places, start, transitions),
  mark,
  )
import Modelling.PetriNet.Types (
  DrawSettings (..),
  PetriLike (PetriLike),
  SimpleNode (SimplePlace, SimpleTransition),
  )

import Control.Monad.Catch              (MonadCatch, MonadThrow)
import Control.Monad.Extra              ((&&^))
import Data.GraphViz                    (GraphvizCommand)
import Data.List                        (group, sort)

drawToFile
  :: (
    Ord s,
    Ord t,
    Show s,
    Show t,
    MonadCache m,
    MonadDiagrams m,
    MonadGraphviz m,
    MonadThrow m
    )
  => Bool
  -> FilePath
  -> GraphvizCommand
  -> Net s t
  -> m FilePath
drawToFile :: forall s t (m :: * -> *).
(Ord s, Ord t, Show s, Show t, MonadCache m, MonadDiagrams m,
 MonadGraphviz m, MonadThrow m) =>
Bool -> FilePath -> GraphvizCommand -> Net s t -> m FilePath
drawToFile Bool
hidePlaceNames FilePath
path GraphvizCommand
cmd Net s t
net = FilePath
-> PetriLike SimpleNode FilePath -> DrawSettings -> m FilePath
forall (n :: * -> *) (p :: (* -> *) -> * -> *) (m :: * -> *).
(Data (n FilePath), Data (p n FilePath), MonadCache m,
 MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n,
 Typeable n, Typeable p) =>
FilePath -> p n FilePath -> DrawSettings -> m FilePath
cacheNet
    FilePath
path
    ((s -> FilePath)
-> (t -> FilePath) -> Net s t -> PetriLike SimpleNode FilePath
forall a s t.
(Ord a, Ord s, Ord t) =>
(s -> a) -> (t -> a) -> Net s t -> PetriLike SimpleNode a
toPetriLike s -> FilePath
forall a. Show a => a -> FilePath
show t -> FilePath
forall a. Show a => a -> FilePath
show Net s t
net)
    (DrawSettings -> m FilePath) -> DrawSettings -> m FilePath
forall a b. (a -> b) -> a -> b
$ Bool -> GraphvizCommand -> DrawSettings
reachDrawSettings Bool
hidePlaceNames GraphvizCommand
cmd

reachDrawSettings :: Bool -> GraphvizCommand -> DrawSettings
reachDrawSettings :: Bool -> GraphvizCommand -> DrawSettings
reachDrawSettings Bool
hidePlaceNames GraphvizCommand
cmd =
    DrawSettings {
      $sel:with1Weights:DrawSettings :: Bool
with1Weights = Bool
False,
      $sel:withPlaceNames:DrawSettings :: Bool
withPlaceNames = Bool -> Bool
not Bool
hidePlaceNames,
      $sel:withSvgHighlighting:DrawSettings :: Bool
withSvgHighlighting = Bool
True,
      $sel:withTransitionNames:DrawSettings :: Bool
withTransitionNames = Bool
True,
      $sel:withGraphvizCommand:DrawSettings :: GraphvizCommand
withGraphvizCommand = GraphvizCommand
cmd
      }

{-|
Checks if the 'Net' is drawable.
It is a more specific version of 'isNetDrawable' for Reach tasks.
It attempts to draw the Petri net with and without place names
and succeeds only if both are successful.
-}
isPetriDrawable
  :: (
    MonadCatch m,
    MonadDiagrams m,
    MonadGraphviz m,
    Ord s,
    Ord t,
    Show s,
    Show t
    )
  => Net s t
  -> GraphvizCommand
  -> m Bool
isPetriDrawable :: forall (m :: * -> *) s t.
(MonadCatch m, MonadDiagrams m, MonadGraphviz m, Ord s, Ord t,
 Show s, Show t) =>
Net s t -> GraphvizCommand -> m Bool
isPetriDrawable Net s t
petri GraphvizCommand
cmd =
  let canDraw :: Bool -> m Bool
canDraw Bool
withoutPlaceNames = PetriLike SimpleNode FilePath -> DrawSettings -> m Bool
forall (m :: * -> *) (p :: (* -> *) -> * -> *) (n :: * -> *).
(MonadCatch m, MonadDiagrams m, MonadGraphviz m, Net p n) =>
p n FilePath -> DrawSettings -> m Bool
isNetDrawable ((s -> FilePath)
-> (t -> FilePath) -> Net s t -> PetriLike SimpleNode FilePath
forall a s t.
(Ord a, Ord s, Ord t) =>
(s -> a) -> (t -> a) -> Net s t -> PetriLike SimpleNode a
toPetriLike s -> FilePath
forall a. Show a => a -> FilePath
show t -> FilePath
forall a. Show a => a -> FilePath
show Net s t
petri)
        (DrawSettings -> m Bool) -> DrawSettings -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> GraphvizCommand -> DrawSettings
reachDrawSettings Bool
withoutPlaceNames GraphvizCommand
cmd
  in Bool -> m Bool
forall {m :: * -> *}.
(MonadCatch m, MonadDiagrams m, MonadGraphviz m) =>
Bool -> m Bool
canDraw Bool
True m Bool -> m Bool -> m Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
&&^ Bool -> m Bool
forall {m :: * -> *}.
(MonadCatch m, MonadDiagrams m, MonadGraphviz m) =>
Bool -> m Bool
canDraw Bool
False

{-|
Requires two functions that provide unique ids for places and nodes.
This function does not check if resulting ids overlap.
-}
toPetriLike
  :: (Ord a, Ord s, Ord t)
  => (s -> a)
  -> (t -> a)
  -> Net s t
  -> PetriLike SimpleNode a
toPetriLike :: forall a s t.
(Ord a, Ord s, Ord t) =>
(s -> a) -> (t -> a) -> Net s t -> PetriLike SimpleNode a
toPetriLike s -> a
fp t -> a
ft Net s t
n = Map a (SimpleNode a) -> PetriLike SimpleNode a
forall (n :: * -> *) a. Map a (n a) -> PetriLike n a
PetriLike (Map a (SimpleNode a) -> PetriLike SimpleNode a)
-> Map a (SimpleNode a) -> PetriLike SimpleNode a
forall a b. (a -> b) -> a -> b
$ [(a, SimpleNode a)] -> Map a (SimpleNode a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(a, SimpleNode a)] -> Map a (SimpleNode a))
-> [(a, SimpleNode a)] -> Map a (SimpleNode a)
forall a b. (a -> b) -> a -> b
$ [(a, SimpleNode a)]
ps [(a, SimpleNode a)] -> [(a, SimpleNode a)] -> [(a, SimpleNode a)]
forall a. [a] -> [a] -> [a]
++ [(a, SimpleNode a)]
ts
  where
    ps :: [(a, SimpleNode a)]
ps = do
      s
p <- Set s -> [s]
forall a. Set a -> [a]
S.toList (Set s -> [s]) -> Set s -> [s]
forall a b. (a -> b) -> a -> b
$ Net s t -> Set s
forall s t. Net s t -> Set s
places Net s t
n
      let i :: Int
i = State s -> s -> Int
forall s. Ord s => State s -> s -> Int
mark (Net s t -> State s
forall s t. Net s t -> State s
start Net s t
n) s
p
          filterC :: (Connection s t -> Bool) -> [Connection s t]
filterC Connection s t -> Bool
f = (Connection s t -> Bool) -> [Connection s t] -> [Connection s t]
forall a. (a -> Bool) -> [a] -> [a]
filter Connection s t -> Bool
f ([Connection s t] -> [Connection s t])
-> [Connection s t] -> [Connection s t]
forall a b. (a -> b) -> a -> b
$ Net s t -> [Connection s t]
forall s t. Net s t -> [Connection s t]
connections Net s t
n
          countP :: [s] -> Int
countP = [s] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([s] -> Int) -> ([s] -> [s]) -> [s] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> Bool) -> [s] -> [s]
forall a. (a -> Bool) -> [a] -> [a]
filter (s
p s -> s -> Bool
forall a. Eq a => a -> a -> Bool
==)
          outcome :: [(a, Int)]
outcome =
            [ (t -> a
ft t
t, [s] -> Int
countP [s]
xs)
            | ([s]
xs,t
t,[s]
_) <- (Connection s t -> Bool) -> [Connection s t]
filterC (\([s]
from,t
_,[s]
_) -> s
p s -> [s] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [s]
from)
            ]
      (a, SimpleNode a) -> [(a, SimpleNode a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> a
fp s
p, Int -> Map a Int -> SimpleNode a
forall a. Int -> Map a Int -> SimpleNode a
SimplePlace Int
i ([(a, Int)] -> Map a Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(a, Int)]
outcome))
    ts :: [(a, SimpleNode a)]
ts = do
      t
t <- Set t -> [t]
forall a. Set a -> [a]
S.toList (Set t -> [t]) -> Set t -> [t]
forall a b. (a -> b) -> a -> b
$ Net s t -> Set t
forall s t. Net s t -> Set t
transitions Net s t
n
      let filterC :: [Connection s t]
filterC = (Connection s t -> Bool) -> [Connection s t] -> [Connection s t]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([s]
_,t
x,[s]
_) -> t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
t) ([Connection s t] -> [Connection s t])
-> [Connection s t] -> [Connection s t]
forall a b. (a -> b) -> a -> b
$ Net s t -> [Connection s t]
forall s t. Net s t -> [Connection s t]
connections Net s t
n
          outcome :: [(a, Int)]
outcome =
            [ (s -> a
fp (s -> a) -> s -> a
forall a b. (a -> b) -> a -> b
$ [s] -> s
forall a. HasCallStack => [a] -> a
head [s]
xs', [s] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [s]
xs')
            | ([s]
_,t
_,[s]
xs) <- [Connection s t]
filterC,
              [s]
xs' <- [s] -> [[s]]
forall a. Eq a => [a] -> [[a]]
group ([s] -> [[s]]) -> [s] -> [[s]]
forall a b. (a -> b) -> a -> b
$ [s] -> [s]
forall a. Ord a => [a] -> [a]
sort [s]
xs
            ]
      (a, SimpleNode a) -> [(a, SimpleNode a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (t -> a
ft t
t, Map a Int -> SimpleNode a
forall a. Map a Int -> SimpleNode a
SimpleTransition ([(a, Int)] -> Map a Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(a, Int)]
outcome))