{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | The functions in this module implement pruning of 'PureGraph's,
-- to remove hidden nodes as far as possible, while still showing the
-- structure between non-hidden nodes.
--
-- NB.  It is assumed the PureGraph is acyclic!
module Graphs.PureGraphPrune(
   pureGraphPrune,
   ) where


import Data.Maybe

import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)

import Util.ExtendedPrelude

import Graphs.PureGraph


-- | Remove "hidden" vertices as far as possible from a graph, which
-- must be acyclic, while still preserving the structure as far as possible.
pureGraphPrune ::
   (Ord nodeInfo,Ord arcInfo)
   => (nodeInfo -> Bool) -- ^ This function returns True if a node is hidden.
   -> PureGraph nodeInfo arcInfo
   -> PureGraph nodeInfo (Maybe arcInfo)
   -- ^ In the returned graph, we use 'Nothing' to indicate the arcs
   -- which don't correspond to arcs in the original graph.
pureGraphPrune :: (nodeInfo -> Bool)
-> PureGraph nodeInfo arcInfo -> PureGraph nodeInfo (Maybe arcInfo)
pureGraphPrune nodeInfo -> Bool
isHidden (PureGraph nodeInfo arcInfo
pureGraph0 :: PureGraph nodeInfo arcInfo) =
   let
      pureGraph1 :: PureGraph nodeInfo (Maybe arcInfo)
      pureGraph1 :: PureGraph nodeInfo (Maybe arcInfo)
pureGraph1 = (arcInfo -> Maybe arcInfo)
-> PureGraph nodeInfo arcInfo -> PureGraph nodeInfo (Maybe arcInfo)
forall arcInfo1 arcInfo2 nodeInfo.
(arcInfo1 -> arcInfo2)
-> PureGraph nodeInfo arcInfo1 -> PureGraph nodeInfo arcInfo2
mapArcInfo arcInfo -> Maybe arcInfo
forall a. a -> Maybe a
Just PureGraph nodeInfo arcInfo
pureGraph0

      pureGraph2 :: PureGraph nodeInfo (Maybe arcInfo)
      pureGraph2 :: PureGraph nodeInfo (Maybe arcInfo)
pureGraph2 = (nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
(Ord nodeInfo, Ord arcInfo) =>
(nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
zTrans nodeInfo -> Bool
isHidden PureGraph nodeInfo (Maybe arcInfo)
pureGraph1

      pureGraph3 :: PureGraph nodeInfo (Maybe arcInfo)
      pureGraph3 :: PureGraph nodeInfo (Maybe arcInfo)
pureGraph3 = (nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
Ord nodeInfo =>
(nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
findNotHanging nodeInfo -> Bool
isHidden PureGraph nodeInfo (Maybe arcInfo)
pureGraph2

      pureGraph4 :: PureGraph nodeInfo (Maybe arcInfo)
      pureGraph4 :: PureGraph nodeInfo (Maybe arcInfo)
pureGraph4 = (nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
Ord nodeInfo =>
(nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
removeOneHiddenParent nodeInfo -> Bool
isHidden PureGraph nodeInfo (Maybe arcInfo)
pureGraph3
   in
      PureGraph nodeInfo (Maybe arcInfo)
pureGraph4


-- | Computes list in which parents always precede their children.
orderGraph :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> [nodeInfo]
orderGraph :: PureGraph nodeInfo arcInfo -> [nodeInfo]
orderGraph ((PureGraph Map nodeInfo (NodeData nodeInfo arcInfo)
fm) :: PureGraph nodeInfo arcInfo) =
      [nodeInfo] -> [nodeInfo]
forall a. [a] -> [a]
reverse ((Set nodeInfo, [nodeInfo]) -> [nodeInfo]
forall a b. (a, b) -> b
snd (((Set nodeInfo, [nodeInfo])
 -> nodeInfo -> (Set nodeInfo, [nodeInfo]))
-> (Set nodeInfo, [nodeInfo])
-> [nodeInfo]
-> (Set nodeInfo, [nodeInfo])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Set nodeInfo, [nodeInfo])
-> nodeInfo -> (Set nodeInfo, [nodeInfo])
visit (Set nodeInfo
forall a. Set a
Set.empty,[]) (Map nodeInfo (NodeData nodeInfo arcInfo) -> [nodeInfo]
forall k a. Map k a -> [k]
Map.keys Map nodeInfo (NodeData nodeInfo arcInfo)
fm)))
   where
      visit :: (Set nodeInfo,[nodeInfo]) -> nodeInfo
         -> (Set nodeInfo,[nodeInfo])
      visit :: (Set nodeInfo, [nodeInfo])
-> nodeInfo -> (Set nodeInfo, [nodeInfo])
visit (sl0 :: (Set nodeInfo, [nodeInfo])
sl0 @ (Set nodeInfo
set0,[nodeInfo]
list0)) nodeInfo
a =
         if nodeInfo -> Set nodeInfo -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member nodeInfo
a Set nodeInfo
set0
            then
               (Set nodeInfo, [nodeInfo])
sl0
            else
               let
                  nodeData :: NodeData nodeInfo arcInfo
                  Just NodeData nodeInfo arcInfo
nodeData = nodeInfo
-> Map nodeInfo (NodeData nodeInfo arcInfo)
-> Maybe (NodeData nodeInfo arcInfo)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeInfo
a Map nodeInfo (NodeData nodeInfo arcInfo)
fm

                  set1 :: Set nodeInfo
set1 = nodeInfo -> Set nodeInfo -> Set nodeInfo
forall a. Ord a => a -> Set a -> Set a
Set.insert nodeInfo
a Set nodeInfo
set0

                  (Set nodeInfo
set2,[nodeInfo]
list1) = ((Set nodeInfo, [nodeInfo])
 -> nodeInfo -> (Set nodeInfo, [nodeInfo]))
-> (Set nodeInfo, [nodeInfo])
-> [nodeInfo]
-> (Set nodeInfo, [nodeInfo])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Set nodeInfo, [nodeInfo])
-> nodeInfo -> (Set nodeInfo, [nodeInfo])
visit (Set nodeInfo
set1,[nodeInfo]
list0)
                     (NodeData nodeInfo arcInfo -> [nodeInfo]
forall nodeInfo arcInfo. NodeData nodeInfo arcInfo -> [nodeInfo]
parentNodes NodeData nodeInfo arcInfo
nodeData)
               in
                  (Set nodeInfo
set2,nodeInfo
anodeInfo -> [nodeInfo] -> [nodeInfo]
forall a. a -> [a] -> [a]
:[nodeInfo]
list1)

-- | Transform the Dag according to the Z function.
-- The rule is that hidden nodes with just one parent get replaced
-- in parent lists by their parent (repeatedly).
zTrans :: (Ord nodeInfo,Ord arcInfo)
   => (nodeInfo -> Bool)
   -> PureGraph nodeInfo (Maybe arcInfo)
   -> PureGraph nodeInfo (Maybe arcInfo)
zTrans :: (nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
zTrans nodeInfo -> Bool
isHidden ((pureGraph :: PureGraph nodeInfo (Maybe arcInfo)
pureGraph @ (PureGraph Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm))
      :: PureGraph nodeInfo (Maybe arcInfo)) =
   let
      ordered :: [nodeInfo]
ordered = PureGraph nodeInfo (Maybe arcInfo) -> [nodeInfo]
forall nodeInfo arcInfo.
Ord nodeInfo =>
PureGraph nodeInfo arcInfo -> [nodeInfo]
orderGraph PureGraph nodeInfo (Maybe arcInfo)
pureGraph

      compute ::
          Map.Map nodeInfo (nodeInfo,NodeData nodeInfo (Maybe arcInfo))
          -> nodeInfo
          -> Map.Map nodeInfo (nodeInfo,NodeData nodeInfo (Maybe arcInfo))
      compute :: Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> nodeInfo
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
compute Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
z0 (nodeInfo
a :: nodeInfo) =
         let
            nodeData :: NodeData nodeInfo (Maybe arcInfo)
            Just NodeData nodeInfo (Maybe arcInfo)
nodeData = nodeInfo
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Maybe (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeInfo
a Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm

            mapParent ::
               ArcData nodeInfo (Maybe arcInfo)
               -> ArcData nodeInfo (Maybe arcInfo)
            mapParent :: ArcData nodeInfo (Maybe arcInfo)
-> ArcData nodeInfo (Maybe arcInfo)
mapParent ArcData nodeInfo (Maybe arcInfo)
arcData = case nodeInfo
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> Maybe (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ArcData nodeInfo (Maybe arcInfo) -> nodeInfo
forall nodeInfo arcInfo. ArcData nodeInfo arcInfo -> nodeInfo
target ArcData nodeInfo (Maybe arcInfo)
arcData) Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
z0 of
               Just (nodeInfo
parentNode,NodeData nodeInfo (Maybe arcInfo)
_) | nodeInfo
parentNode nodeInfo -> nodeInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= ArcData nodeInfo (Maybe arcInfo) -> nodeInfo
forall nodeInfo arcInfo. ArcData nodeInfo arcInfo -> nodeInfo
target ArcData nodeInfo (Maybe arcInfo)
arcData
                  -> nodeInfo -> ArcData nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
nodeInfo -> ArcData nodeInfo (Maybe arcInfo)
newArc nodeInfo
parentNode
               Maybe (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
_ -> ArcData nodeInfo (Maybe arcInfo)
arcData

            parents1 :: [ArcData nodeInfo (Maybe arcInfo)]
parents1 = [ArcData nodeInfo (Maybe arcInfo)]
-> [ArcData nodeInfo (Maybe arcInfo)]
forall a. Ord a => [a] -> [a]
uniqOrd ((ArcData nodeInfo (Maybe arcInfo)
 -> ArcData nodeInfo (Maybe arcInfo))
-> [ArcData nodeInfo (Maybe arcInfo)]
-> [ArcData nodeInfo (Maybe arcInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ArcData nodeInfo (Maybe arcInfo)
-> ArcData nodeInfo (Maybe arcInfo)
mapParent (NodeData nodeInfo (Maybe arcInfo)
-> [ArcData nodeInfo (Maybe arcInfo)]
forall nodeInfo arcInfo.
NodeData nodeInfo arcInfo -> [ArcData nodeInfo arcInfo]
parents NodeData nodeInfo (Maybe arcInfo)
nodeData))

            za :: nodeInfo
za =
               if nodeInfo -> Bool
isHidden nodeInfo
a
                  then
                     case [ArcData nodeInfo (Maybe arcInfo)]
parents1 of
                        [ArcData nodeInfo (Maybe arcInfo)
parent1] -> ArcData nodeInfo (Maybe arcInfo) -> nodeInfo
forall nodeInfo arcInfo. ArcData nodeInfo arcInfo -> nodeInfo
target ArcData nodeInfo (Maybe arcInfo)
parent1
                        [ArcData nodeInfo (Maybe arcInfo)]
_ -> nodeInfo
a
                  else
                     nodeInfo
a
         in
            nodeInfo
-> (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeInfo
a (nodeInfo
za,NodeData :: forall nodeInfo arcInfo.
[ArcData nodeInfo arcInfo] -> NodeData nodeInfo arcInfo
NodeData {
               parents :: [ArcData nodeInfo (Maybe arcInfo)]
parents = [ArcData nodeInfo (Maybe arcInfo)]
parents1
               }) Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
z0

      zMap :: Map.Map nodeInfo (nodeInfo,NodeData nodeInfo (Maybe arcInfo))
      zMap :: Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
zMap = (Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
 -> nodeInfo
 -> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo)))
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> [nodeInfo]
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> nodeInfo
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
compute Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall k a. Map k a
Map.empty [nodeInfo]
ordered

      fm2 :: Map.Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
      fm2 :: Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm2 = (nodeInfo
 -> (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
 -> NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey
         (\ nodeInfo
a (nodeInfo
_,NodeData nodeInfo (Maybe arcInfo)
nodeData) -> NodeData nodeInfo (Maybe arcInfo)
nodeData)
         Map nodeInfo (nodeInfo, NodeData nodeInfo (Maybe arcInfo))
zMap
   in
      Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> PureGraph nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
Map nodeInfo (NodeData nodeInfo arcInfo)
-> PureGraph nodeInfo arcInfo
PureGraph Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm2

-- | Compute all nodes which are either not hidden, or have a descendant
-- which is not hidden, and then delete all other nodes.
findNotHanging :: Ord nodeInfo
   => (nodeInfo -> Bool)
   -> PureGraph nodeInfo (Maybe arcInfo)
   -> PureGraph nodeInfo (Maybe arcInfo)
findNotHanging :: (nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
findNotHanging nodeInfo -> Bool
isHidden (PureGraph Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm :: PureGraph nodeInfo (Maybe arcInfo)) =
   let
      visit :: Set nodeInfo -> nodeInfo -> Set nodeInfo
      visit :: Set nodeInfo -> nodeInfo -> Set nodeInfo
visit Set nodeInfo
set0 nodeInfo
a =
         let
            set1 :: Set nodeInfo
set1 = nodeInfo -> Set nodeInfo -> Set nodeInfo
forall a. Ord a => a -> Set a -> Set a
Set.insert nodeInfo
a Set nodeInfo
set0
            Just NodeData nodeInfo (Maybe arcInfo)
nodeData = nodeInfo
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Maybe (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeInfo
a Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm
         in
            Set nodeInfo -> [nodeInfo] -> Set nodeInfo
visits Set nodeInfo
set1 (NodeData nodeInfo (Maybe arcInfo) -> [nodeInfo]
forall nodeInfo arcInfo. NodeData nodeInfo arcInfo -> [nodeInfo]
parentNodes NodeData nodeInfo (Maybe arcInfo)
nodeData)

      visits :: Set nodeInfo -> [nodeInfo] -> Set nodeInfo
      visits :: Set nodeInfo -> [nodeInfo] -> Set nodeInfo
visits Set nodeInfo
set0 [nodeInfo]
as = (Set nodeInfo -> nodeInfo -> Set nodeInfo)
-> Set nodeInfo -> [nodeInfo] -> Set nodeInfo
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Set nodeInfo -> nodeInfo -> Set nodeInfo
visit Set nodeInfo
set0 [nodeInfo]
as

      notHidden :: [nodeInfo]
      notHidden :: [nodeInfo]
notHidden = (nodeInfo -> Maybe nodeInfo) -> [nodeInfo] -> [nodeInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
         (\ nodeInfo
a -> if nodeInfo -> Bool
isHidden nodeInfo
a then Maybe nodeInfo
forall a. Maybe a
Nothing else nodeInfo -> Maybe nodeInfo
forall a. a -> Maybe a
Just nodeInfo
a)
         (Map nodeInfo (NodeData nodeInfo (Maybe arcInfo)) -> [nodeInfo]
forall k a. Map k a -> [k]
Map.keys Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm)

      notHanging :: Set nodeInfo
      notHanging :: Set nodeInfo
notHanging = Set nodeInfo -> [nodeInfo] -> Set nodeInfo
visits Set nodeInfo
forall a. Set a
Set.empty [nodeInfo]
notHidden

      notHangingFM :: Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
notHangingFM = (Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
 -> nodeInfo -> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo)))
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> [nodeInfo]
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
         (\ Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0 nodeInfo
a ->
            let
               Just NodeData nodeInfo (Maybe arcInfo)
nodeData = nodeInfo
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Maybe (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeInfo
a Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm
            in
               nodeInfo
-> NodeData nodeInfo (Maybe arcInfo)
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeInfo
a NodeData nodeInfo (Maybe arcInfo)
nodeData Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0
            )
         Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall k a. Map k a
Map.empty
         (Set nodeInfo -> [nodeInfo]
forall a. Set a -> [a]
Set.toList Set nodeInfo
notHanging)
   in
      Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> PureGraph nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
Map nodeInfo (NodeData nodeInfo arcInfo)
-> PureGraph nodeInfo arcInfo
PureGraph Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
notHangingFM

-- | Compute the number of children each node has in a Dag
nChildren :: Ord nodeInfo => PureGraph nodeInfo arcInfo -> nodeInfo -> Int
nChildren :: PureGraph nodeInfo arcInfo -> nodeInfo -> Int
nChildren (PureGraph Map nodeInfo (NodeData nodeInfo arcInfo)
fm :: PureGraph nodeInfo arcInfo) nodeInfo
nf =
   let
      fm1 :: Map nodeInfo Int
fm1 = (nodeInfo
 -> NodeData nodeInfo arcInfo
 -> Map nodeInfo Int
 -> Map nodeInfo Int)
-> Map nodeInfo Int
-> Map nodeInfo (NodeData nodeInfo arcInfo)
-> Map nodeInfo Int
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
         (\ nodeInfo
a NodeData nodeInfo arcInfo
nodeData Map nodeInfo Int
fm0 ->
            let
               parents1 :: [nodeInfo]
parents1 = NodeData nodeInfo arcInfo -> [nodeInfo]
forall nodeInfo arcInfo. NodeData nodeInfo arcInfo -> [nodeInfo]
parentNodes NodeData nodeInfo arcInfo
nodeData
            in
               (Map nodeInfo Int -> nodeInfo -> Map nodeInfo Int)
-> Map nodeInfo Int -> [nodeInfo] -> Map nodeInfo Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                  (\ Map nodeInfo Int
fm0 nodeInfo
parent ->
                     nodeInfo -> Int -> Map nodeInfo Int -> Map nodeInfo Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeInfo
parent (Int -> nodeInfo -> Map nodeInfo Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 nodeInfo
parent Map nodeInfo Int
fm0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                     Map nodeInfo Int
fm0
                     )
                  Map nodeInfo Int
fm0
                  [nodeInfo]
parents1
            )
         (Map nodeInfo Int
forall k a. Map k a
Map.empty :: Map.Map nodeInfo Int)
         Map nodeInfo (NodeData nodeInfo arcInfo)
fm
   in
      Int -> nodeInfo -> Map nodeInfo Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 nodeInfo
nf Map nodeInfo Int
fm1

-- | For nodes with one hidden parent, which has just that child,
-- delete the hidden parent and replace the original node's parents by the
-- hidden parent's parents.
--
-- NB.  We don't have to worry about this being applied recursively provided
-- zTrans has already been applied, since that removes chains of hidden
-- vertices.
removeOneHiddenParent :: forall nodeInfo arcInfo . Ord nodeInfo
   => (nodeInfo -> Bool)
   -> PureGraph nodeInfo (Maybe arcInfo)
   -> PureGraph nodeInfo (Maybe arcInfo)
removeOneHiddenParent :: (nodeInfo -> Bool)
-> PureGraph nodeInfo (Maybe arcInfo)
-> PureGraph nodeInfo (Maybe arcInfo)
removeOneHiddenParent nodeInfo -> Bool
isHidden (pureGraph :: PureGraph nodeInfo (Maybe arcInfo)
pureGraph @ (PureGraph Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0)
      ::  PureGraph nodeInfo (Maybe arcInfo)) =
   let
      nc :: nodeInfo -> Int
nc = PureGraph nodeInfo (Maybe arcInfo) -> nodeInfo -> Int
forall nodeInfo arcInfo.
Ord nodeInfo =>
PureGraph nodeInfo arcInfo -> nodeInfo -> Int
nChildren PureGraph nodeInfo (Maybe arcInfo)
pureGraph

      candidates0 :: [(nodeInfo,NodeData nodeInfo (Maybe arcInfo))]
      candidates0 :: [(nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
candidates0 = Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> [(nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
forall k a. Map k a -> [(k, a)]
Map.toList Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0

      deletions :: [(nodeInfo,nodeInfo,NodeData nodeInfo (Maybe arcInfo))]
      deletions :: [(nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
deletions = ((nodeInfo, NodeData nodeInfo (Maybe arcInfo))
 -> Maybe (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo)))
-> [(nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
-> [(nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
         (\ (nodeInfo
a,NodeData nodeInfo (Maybe arcInfo)
nodeData) -> case NodeData nodeInfo (Maybe arcInfo) -> [nodeInfo]
forall nodeInfo arcInfo. NodeData nodeInfo arcInfo -> [nodeInfo]
parentNodes NodeData nodeInfo (Maybe arcInfo)
nodeData of
           [nodeInfo
parent] ->
              if nodeInfo -> Int
nc nodeInfo
parent Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                 then
                    case nodeInfo
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Maybe (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup nodeInfo
parent Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0 of
                       Just NodeData nodeInfo (Maybe arcInfo)
nodeData | nodeInfo -> Bool
isHidden nodeInfo
parent ->
                          let
                             parentNodes1 :: [nodeInfo]
parentNodes1 = NodeData nodeInfo (Maybe arcInfo) -> [nodeInfo]
forall nodeInfo arcInfo. NodeData nodeInfo arcInfo -> [nodeInfo]
parentNodes NodeData nodeInfo (Maybe arcInfo)
nodeData
                             parents1 :: [ArcData nodeInfo (Maybe arcInfo)]
parents1 = (nodeInfo -> ArcData nodeInfo (Maybe arcInfo))
-> [nodeInfo] -> [ArcData nodeInfo (Maybe arcInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap nodeInfo -> ArcData nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
nodeInfo -> ArcData nodeInfo (Maybe arcInfo)
newArc [nodeInfo]
parentNodes1
                          in
                             (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))
-> Maybe (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall a. a -> Maybe a
Just (nodeInfo
a,nodeInfo
parent,NodeData :: forall nodeInfo arcInfo.
[ArcData nodeInfo arcInfo] -> NodeData nodeInfo arcInfo
NodeData {parents :: [ArcData nodeInfo (Maybe arcInfo)]
parents = [ArcData nodeInfo (Maybe arcInfo)]
forall arcInfo. [ArcData nodeInfo (Maybe arcInfo)]
parents1})
                       Maybe (NodeData nodeInfo (Maybe arcInfo))
_ -> Maybe (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall a. Maybe a
Nothing
                 else
                    Maybe (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall a. Maybe a
Nothing
           [nodeInfo]
_ -> Maybe (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))
forall a. Maybe a
Nothing
           )
        [(nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
candidates0

      fm1 :: Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm1 = (Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
 -> (nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))
 -> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo)))
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> [(nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
         (\ Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0 (nodeInfo
a,nodeInfo
parent,NodeData nodeInfo (Maybe arcInfo)
nodeData) ->
            (nodeInfo
-> NodeData nodeInfo (Maybe arcInfo)
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert nodeInfo
a NodeData nodeInfo (Maybe arcInfo)
nodeData (nodeInfo
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete nodeInfo
parent Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0))
            )
         Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm0
         [(nodeInfo, nodeInfo, NodeData nodeInfo (Maybe arcInfo))]
deletions
   in
       Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
-> PureGraph nodeInfo (Maybe arcInfo)
forall nodeInfo arcInfo.
Map nodeInfo (NodeData nodeInfo arcInfo)
-> PureGraph nodeInfo arcInfo
PureGraph Map nodeInfo (NodeData nodeInfo (Maybe arcInfo))
fm1

newArc :: nodeInfo -> ArcData nodeInfo (Maybe arcInfo)
newArc :: nodeInfo -> ArcData nodeInfo (Maybe arcInfo)
newArc nodeInfo
nodeInfo = ArcData :: forall nodeInfo arcInfo.
arcInfo -> nodeInfo -> ArcData nodeInfo arcInfo
ArcData {target :: nodeInfo
target = nodeInfo
nodeInfo,arcInfo :: Maybe arcInfo
arcInfo = Maybe arcInfo
forall a. Maybe a
Nothing}