{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module: NetSpider.RPL.CLI.Analyze
-- Description: Analyze graph attributes
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- @since 0.1.3.0
module NetSpider.RPL.CLI.Analyze
  ( DODAGAttributes(..),
    analyzeDIO,
    analyzeDAO
  ) where

import Control.Applicative (empty)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Graph.Inductive (LNode, LEdge, Gr)
import qualified Data.Graph.Inductive as FGL
import Data.List (sortOn, reverse)
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import NetSpider.Log (WriterLoggingM, logErrorW, spack, logDebugW)
import NetSpider.SeqID
  (SeqIDMaker, newSeqIDMaker, convertGraph, originalIDFor)
import NetSpider.Snapshot
  ( SnapshotNode, SnapshotLink, SnapshotGraph,
    nodeId, nodeAttributes, sourceNode, destinationNode, linkAttributes,
    graphTimestamp
  )
import NetSpider.Timestamp (Timestamp, showTimestamp)
import NetSpider.RPL.DIO (SnapshotGraphDIO)
import NetSpider.RPL.DAO (SnapshotGraphDAO)
import NetSpider.RPL.FindingID
  ( IPv6ID, FindingID, FindingType(..), ipv6Only, ipv6ToText)


-- | Attributes of a DODAG.
data DODAGAttributes =
  DODAGAttributes
  { DODAGAttributes -> Int
node_num :: Int,
    DODAGAttributes -> Int
edge_num :: Int,
    DODAGAttributes -> Int
depth :: Int,
    DODAGAttributes -> IPv6ID
root :: IPv6ID,
    DODAGAttributes -> Timestamp
time :: Timestamp
  }
  deriving (Int -> DODAGAttributes -> ShowS
[DODAGAttributes] -> ShowS
DODAGAttributes -> String
(Int -> DODAGAttributes -> ShowS)
-> (DODAGAttributes -> String)
-> ([DODAGAttributes] -> ShowS)
-> Show DODAGAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DODAGAttributes] -> ShowS
$cshowList :: [DODAGAttributes] -> ShowS
show :: DODAGAttributes -> String
$cshow :: DODAGAttributes -> String
showsPrec :: Int -> DODAGAttributes -> ShowS
$cshowsPrec :: Int -> DODAGAttributes -> ShowS
Show,DODAGAttributes -> DODAGAttributes -> Bool
(DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> Eq DODAGAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DODAGAttributes -> DODAGAttributes -> Bool
$c/= :: DODAGAttributes -> DODAGAttributes -> Bool
== :: DODAGAttributes -> DODAGAttributes -> Bool
$c== :: DODAGAttributes -> DODAGAttributes -> Bool
Eq,Eq DODAGAttributes
Eq DODAGAttributes
-> (DODAGAttributes -> DODAGAttributes -> Ordering)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> DODAGAttributes)
-> (DODAGAttributes -> DODAGAttributes -> DODAGAttributes)
-> Ord DODAGAttributes
DODAGAttributes -> DODAGAttributes -> Bool
DODAGAttributes -> DODAGAttributes -> Ordering
DODAGAttributes -> DODAGAttributes -> DODAGAttributes
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
$cmin :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
max :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
$cmax :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
>= :: DODAGAttributes -> DODAGAttributes -> Bool
$c>= :: DODAGAttributes -> DODAGAttributes -> Bool
> :: DODAGAttributes -> DODAGAttributes -> Bool
$c> :: DODAGAttributes -> DODAGAttributes -> Bool
<= :: DODAGAttributes -> DODAGAttributes -> Bool
$c<= :: DODAGAttributes -> DODAGAttributes -> Bool
< :: DODAGAttributes -> DODAGAttributes -> Bool
$c< :: DODAGAttributes -> DODAGAttributes -> Bool
compare :: DODAGAttributes -> DODAGAttributes -> Ordering
$ccompare :: DODAGAttributes -> DODAGAttributes -> Ordering
$cp1Ord :: Eq DODAGAttributes
Ord)

-- | Get analysis on a DIO graph.
analyzeDIO :: SnapshotGraphDIO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDIO :: SnapshotGraphDIO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDIO = RootType
-> FindingType
-> SnapshotGraphDIO
-> WriterLoggingM (Maybe DODAGAttributes)
forall na la.
RootType
-> FindingType
-> SnapshotGraph FindingID na la
-> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric RootType
RootDest FindingType
FindingDIO

-- | Get analysis on a DAO graph.
analyzeDAO :: SnapshotGraphDAO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDAO :: SnapshotGraphDAO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDAO = RootType
-> FindingType
-> SnapshotGraphDAO
-> WriterLoggingM (Maybe DODAGAttributes)
forall na la.
RootType
-> FindingType
-> SnapshotGraph FindingID na la
-> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric RootType
RootSource FindingType
FindingDAO

analyzeGeneric :: RootType -> FindingType -> SnapshotGraph FindingID na la -> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric :: RootType
-> FindingType
-> SnapshotGraph FindingID na la
-> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric RootType
rtype FindingType
ftype SnapshotGraph FindingID na la
graph = MaybeT (WriterLoggingT Identity) DODAGAttributes
-> WriterLoggingM (Maybe DODAGAttributes)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (WriterLoggingT Identity) DODAGAttributes
 -> WriterLoggingM (Maybe DODAGAttributes))
-> MaybeT (WriterLoggingT Identity) DODAGAttributes
-> WriterLoggingM (Maybe DODAGAttributes)
forall a b. (a -> b) -> a -> b
$ MaybeT (WriterLoggingT Identity) DODAGAttributes
go
  where
    maybeLog :: Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog Maybe b
m Text
err_log =
      case Maybe b
m of
        Maybe b
Nothing -> do
          WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterLoggingT Identity () -> t (WriterLoggingT Identity) ())
-> WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> WriterLoggingT Identity ()
logErrorW Text
err_log
          t (WriterLoggingT Identity) b
forall (f :: * -> *) a. Alternative f => f a
empty
        Just b
v -> b -> t (WriterLoggingT Identity) b
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
    eitherLog :: Either Text b -> t (WriterLoggingT Identity) b
eitherLog Either Text b
e =
      case Either Text b
e of
        Left Text
err_log -> Maybe b -> Text -> t (WriterLoggingT Identity) b
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
 Alternative (t (WriterLoggingT Identity))) =>
Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog Maybe b
forall a. Maybe a
Nothing Text
err_log
        Right b
v -> b -> t (WriterLoggingT Identity) b
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
    (SeqIDMaker FindingID Int
seqid, Gr (Maybe na) la
gr) = SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int, Gr (Maybe na) la)
forall na la.
SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int, Gr (Maybe na) la)
toGr SnapshotGraph FindingID na la
graph
    ft_str :: Text
ft_str =
      case FindingType
ftype of
        FindingType
FindingDIO -> Text
"DIO"
        FindingType
FindingDAO -> Text
"DAO"
    logRootIP :: IPv6ID -> t (WriterLoggingT Identity) ()
logRootIP IPv6ID
root_ip = do
      WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterLoggingT Identity () -> t (WriterLoggingT Identity) ())
-> WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> WriterLoggingT Identity ()
logDebugW (Text
"Root of the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft_str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" graph: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IPv6ID -> Text
ipv6ToText IPv6ID
root_ip)
    logTS :: Timestamp -> t (WriterLoggingT Identity) ()
logTS Timestamp
ts = do
      WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterLoggingT Identity () -> t (WriterLoggingT Identity) ())
-> WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> WriterLoggingT Identity ()
logDebugW (Text
"Timestamp of the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft_str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" graph: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Timestamp -> Text
showTimestamp Timestamp
ts)
    go :: MaybeT (WriterLoggingT Identity) DODAGAttributes
go = do
      Int
root_node <- ((Int, Maybe na) -> Int)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Maybe na) -> Int
forall a b. (a, b) -> a
fst (MaybeT (WriterLoggingT Identity) (Int, Maybe na)
 -> MaybeT (WriterLoggingT Identity) Int)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) Int
forall a b. (a -> b) -> a -> b
$ Either Text (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
 Alternative (t (WriterLoggingT Identity))) =>
Either Text b -> t (WriterLoggingT Identity) b
eitherLog (Either Text (Int, Maybe na)
 -> MaybeT (WriterLoggingT Identity) (Int, Maybe na))
-> Either Text (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
forall a b. (a -> b) -> a -> b
$ RootType -> Gr (Maybe na) la -> Either Text (Int, Maybe na)
forall na la. RootType -> Gr na la -> Either Text (LNode na)
getRoot RootType
rtype Gr (Maybe na) la
gr
      IPv6ID
root_ip <- (FindingID -> IPv6ID)
-> MaybeT (WriterLoggingT Identity) FindingID
-> MaybeT (WriterLoggingT Identity) IPv6ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FindingID -> IPv6ID
ipv6Only (MaybeT (WriterLoggingT Identity) FindingID
 -> MaybeT (WriterLoggingT Identity) IPv6ID)
-> MaybeT (WriterLoggingT Identity) FindingID
-> MaybeT (WriterLoggingT Identity) IPv6ID
forall a b. (a -> b) -> a -> b
$ Maybe FindingID
-> Text -> MaybeT (WriterLoggingT Identity) FindingID
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
 Alternative (t (WriterLoggingT Identity))) =>
Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog
                 (SeqIDMaker FindingID Int -> Int -> Maybe FindingID
forall i n. (Eq i, Hashable i) => SeqIDMaker n i -> i -> Maybe n
originalIDFor SeqIDMaker FindingID Int
seqid Int
root_node)
                 (Text
"Cannot find the FindingID for root node " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text
forall a. Show a => a -> Text
spack Int
root_node) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".")
      IPv6ID -> MaybeT (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
IPv6ID -> t (WriterLoggingT Identity) ()
logRootIP IPv6ID
root_ip
      Timestamp
graph_ts <- Maybe Timestamp
-> Text -> MaybeT (WriterLoggingT Identity) Timestamp
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
 Alternative (t (WriterLoggingT Identity))) =>
Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog (SnapshotGraph FindingID na la -> Maybe Timestamp
forall n na la. SnapshotGraph n na la -> Maybe Timestamp
graphTimestamp SnapshotGraph FindingID na la
graph) (Text
"The graph has no timestamp.")
      Timestamp -> MaybeT (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Timestamp -> t (WriterLoggingT Identity) ()
logTS Timestamp
graph_ts
      DODAGAttributes -> MaybeT (WriterLoggingT Identity) DODAGAttributes
forall (m :: * -> *) a. Monad m => a -> m a
return DODAGAttributes :: Int -> Int -> Int -> IPv6ID -> Timestamp -> DODAGAttributes
DODAGAttributes { node_num :: Int
node_num = Gr (Maybe na) la -> Int
forall na la. Gr na la -> Int
nodeNum Gr (Maybe na) la
gr,
                               edge_num :: Int
edge_num = Gr (Maybe na) la -> Int
forall na la. Gr na la -> Int
edgeNum Gr (Maybe na) la
gr,
                               depth :: Int
depth = Int -> RootType -> Gr (Maybe na) la -> Int
forall na la. Int -> RootType -> Gr na la -> Int
getDepth Int
root_node RootType
rtype Gr (Maybe na) la
gr,
                               root :: IPv6ID
root = IPv6ID
root_ip,
                               time :: Timestamp
time = Timestamp
graph_ts
                             }

toLNode :: SnapshotNode Int na -> LNode (Maybe na)
toLNode :: SnapshotNode Int na -> LNode (Maybe na)
toLNode SnapshotNode Int na
n = (SnapshotNode Int na -> Int
forall n na. SnapshotNode n na -> n
nodeId SnapshotNode Int na
n, SnapshotNode Int na -> Maybe na
forall n na. SnapshotNode n na -> Maybe na
nodeAttributes SnapshotNode Int na
n)

toLEdge :: SnapshotLink Int la -> LEdge la
toLEdge :: SnapshotLink Int la -> LEdge la
toLEdge SnapshotLink Int la
l = (SnapshotLink Int la -> Int
forall n la. SnapshotLink n la -> n
sourceNode SnapshotLink Int la
l, SnapshotLink Int la -> Int
forall n la. SnapshotLink n la -> n
destinationNode SnapshotLink Int la
l, SnapshotLink Int la -> la
forall n la. SnapshotLink n la -> la
linkAttributes SnapshotLink Int la
l)

toGr :: SnapshotGraph FindingID na la -> (SeqIDMaker FindingID FGL.Node, Gr (Maybe na) la)
toGr :: SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int, Gr (Maybe na) la)
toGr SnapshotGraph FindingID na la
graph = (SeqIDMaker FindingID Int
got_maker, [LNode (Maybe na)] -> [LEdge la] -> Gr (Maybe na) la
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
FGL.mkGraph [LNode (Maybe na)]
lnodes [LEdge la]
ledges)
  where
    (SeqIDMaker FindingID Int
got_maker, ([SnapshotNode Int na]
new_nodes, [SnapshotLink Int la]
new_links)) = SeqIDMaker FindingID Int
-> SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int,
    ([SnapshotNode Int na], [SnapshotLink Int la]))
forall n i na la.
(Eq n, Hashable n, Enum i, Eq i, Hashable i) =>
SeqIDMaker n i
-> SnapshotGraph n na la -> (SeqIDMaker n i, SnapshotGraph i na la)
convertGraph (Int -> SeqIDMaker FindingID Int
forall i n. i -> SeqIDMaker n i
newSeqIDMaker Int
0) SnapshotGraph FindingID na la
graph
    lnodes :: [LNode (Maybe na)]
lnodes = (SnapshotNode Int na -> LNode (Maybe na))
-> [SnapshotNode Int na] -> [LNode (Maybe na)]
forall a b. (a -> b) -> [a] -> [b]
map SnapshotNode Int na -> LNode (Maybe na)
forall na. SnapshotNode Int na -> LNode (Maybe na)
toLNode [SnapshotNode Int na]
new_nodes
    ledges :: [LEdge la]
ledges = (SnapshotLink Int la -> LEdge la)
-> [SnapshotLink Int la] -> [LEdge la]
forall a b. (a -> b) -> [a] -> [b]
map SnapshotLink Int la -> LEdge la
forall la. SnapshotLink Int la -> LEdge la
toLEdge [SnapshotLink Int la]
new_links

nodeNum :: Gr na la -> Int
nodeNum :: Gr na la -> Int
nodeNum = Gr na la -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int
FGL.order

edgeNum :: Gr na la -> Int
edgeNum :: Gr na la -> Int
edgeNum = Gr na la -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int
FGL.size

data RootType = RootSource -- ^ Node with no incoming edges.
              | RootDest -- ^ Node with no outgoing edges.

getRoot :: RootType -> Gr na la -> Either Text (LNode na)
getRoot :: RootType -> Gr na la -> Either Text (LNode na)
getRoot RootType
rt Gr na la
gr = [LNode na] -> Either Text (LNode na)
forall a b. IsString a => [(Int, b)] -> Either a (Int, b)
toEither
                ([LNode na] -> Either Text (LNode na))
-> [LNode na] -> Either Text (LNode na)
forall a b. (a -> b) -> a -> b
$ [LNode na] -> [LNode na]
forall a. [a] -> [a]
reverse
                ([LNode na] -> [LNode na]) -> [LNode na] -> [LNode na]
forall a b. (a -> b) -> a -> b
$ (LNode na -> Int) -> [LNode na] -> [LNode na]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn LNode na -> Int
forall b. (Int, b) -> Int
childNum
                ([LNode na] -> [LNode na]) -> [LNode na] -> [LNode na]
forall a b. (a -> b) -> a -> b
$ (LNode na -> Bool) -> [LNode na] -> [LNode na]
forall a. (a -> Bool) -> [a] -> [a]
filter (\LNode na
n -> LNode na -> Int
forall b. (Int, b) -> Int
parentNum LNode na
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
                ([LNode na] -> [LNode na]) -> [LNode na] -> [LNode na]
forall a b. (a -> b) -> a -> b
$ Gr na la -> [LNode na]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
FGL.labNodes Gr na la
gr
  where
    ((Int, b) -> Int
parentNum, (Int, b) -> Int
childNum) =
      case RootType
rt of
        RootType
RootSource -> ((Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.indeg Gr na la
gr  (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst), (Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.outdeg Gr na la
gr (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst))
        RootType
RootDest   -> ((Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.outdeg Gr na la
gr (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst), (Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.indeg Gr na la
gr  (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst))
    toEither :: [(Int, b)] -> Either a (Int, b)
toEither [] = a -> Either a (Int, b)
forall a b. a -> Either a b
Left (a
"The graph has no node that has no parent.")
    toEither [(Int, b)
n] = (Int, b) -> Either a (Int, b)
forall a b. b -> Either a b
Right (Int, b)
n
    toEither ((Int, b)
rnode : [(Int, b)]
others) =
      if (Int, b) -> Int
forall b. (Int, b) -> Int
childNum (Int, b)
rnode Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (((Int, b) -> Bool) -> [(Int, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int, b)
n -> (Int, b) -> Int
forall b. (Int, b) -> Int
childNum (Int, b)
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) [(Int, b)]
others)
      then (Int, b) -> Either a (Int, b)
forall a b. b -> Either a b
Right (Int, b)
rnode
      else if (Int, b) -> Int
forall b. (Int, b) -> Int
childNum (Int, b)
rnode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
           then a -> Either a (Int, b)
forall a b. a -> Either a b
Left (a
"The graph contains orphan nodes only.")
           else a -> Either a (Int, b)
forall a b. a -> Either a b
Left (a
"The graph contains multiple root candidates.")

getDepth :: FGL.Node -- ^ the root node
         -> RootType -- ^ type of the root
         -> Gr na la
         -> Int
getDepth :: Int -> RootType -> Gr na la -> Int
getDepth Int
root_node RootType
rtype Gr na la
gr = [Int] -> Int
forall p. (Num p, Ord p) => [p] -> p
maximum' ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (LPath Int -> Int) -> [LPath Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LPath Int -> Int
forall a. LPath a -> Int
toPathLen ([LPath Int] -> [Int]) -> [LPath Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Gr na Int -> [LPath Int]
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Int -> gr a b -> LRTree b
FGL.spTree Int
root_node (Gr na Int -> [LPath Int]) -> Gr na Int -> [LPath Int]
forall a b. (a -> b) -> a -> b
$ Gr na la -> Gr na Int
forall c p. Gr c p -> Gr c Int
convertGr Gr na la
gr
  where
    convertGr :: Gr c p -> Gr c Int
convertGr = (Context c Int -> Context c Int) -> Gr c Int -> Gr c Int
forall (gr :: * -> * -> *) a b c d.
DynGraph gr =>
(Context a b -> Context c d) -> gr a b -> gr c d
FGL.gmap Context c Int -> Context c Int
forall a b c. (a, b, c, a) -> (a, b, c, a)
setEdgeDir (Gr c Int -> Gr c Int)
-> (Gr c p -> Gr c Int) -> Gr c p -> Gr c Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p -> Int) -> Gr c p -> Gr c Int
forall (gr :: * -> * -> *) b c a.
DynGraph gr =>
(b -> c) -> gr a b -> gr a c
FGL.emap p -> Int
forall p. p -> Int
setEdgeLabel
      where
        setEdgeLabel :: p -> Int
setEdgeLabel p
_ = (Int
1 :: Int)
        setEdgeDir :: (a, b, c, a) -> (a, b, c, a)
setEdgeDir orig :: (a, b, c, a)
orig@(a
inedges, b
n, c
nlabel, a
outedges) =
          case RootType
rtype of
            RootType
RootSource -> (a, b, c, a)
orig
            RootType
RootDest -> (a
outedges, b
n, c
nlabel, a
inedges)
    toPathLen :: LPath a -> Int
toPathLen (FGL.LP [LNode a]
nodes) = [LNode a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LNode a]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    maximum' :: [p] -> p
maximum' [] = p
0
    maximum' [p]
l = [p] -> p
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [p]
l