TGraph.hs

-- | Transactionnal graph
module Haskus.Utils.STM.TGraph
   ( deepFirst
   , breadthFirst
   , TNode (..)
   , singleton
   , linkTo
   )
where

import qualified Data.Set as Set

import Haskus.Utils.STM
import Haskus.Utils.Flow
import Haskus.Utils.STM.TList (TList)
import qualified Haskus.Utils.STM.TList as TList

-- | Deep-first graph traversal
--
-- before is executed when the node is entered
-- after is executed when the node is leaved
-- children gets node's children
--
deepFirst :: (Monad m, Ord a) => (a -> m ()) -> (a -> m ()) -> (a -> m [a]) -> [a] -> m ()
deepFirst before after children = foldM_ go Set.empty
   where
      go visited x 
         | Set.member x visited = 
            -- the node is already visited
            return visited

         | otherwise = do
            before x
            cs <- children x
            -- add current node to the visited ones to avoid "loops"
            let visited' = Set.insert x visited
            -- visited "children" nodes
            visited'' <- foldM go visited' cs
            after x
            return visited''

-- | Breadth-first graph traversal
--
-- visit is executed when the node is entered. If False is returned, the traversal ends
-- children gets node's children
--
breadthFirst :: (Monad m, Ord a) => (a -> m Bool) -> (a -> m [a]) -> [a] -> m ()
breadthFirst visit children = go Set.empty
   where
      go _ [] = 
         -- there are no more nodes to visit
         return ()

      go visited (x:xs) 
         | Set.member x visited = 
            -- the node is already visited, we skip it
            go visited xs

         | otherwise = do
            b <- visit x
            -- if "visit" returns False, we stop the traversal
            when b $ do
               -- otherwise we add children to the list of nodes to
               -- visit and we continue the traversal
               cs <- children x
               go (Set.insert x visited) (xs ++ cs)


-- | A node contains a value and two lists of incoming/outgoing edges
data TNode a r = TNode
   { nodeValue :: a
   , nodeEdgeIn :: TList (r, TNode a r)
   , nodeEdgeOut :: TList (r, TNode a r)
   }

-- | Create a graph node
singleton :: a -> STM (TNode a r)
singleton v = TNode v <$> TList.empty <*> TList.empty

-- | Link two nodes together
linkTo :: TNode a r -> r -> TNode a r -> STM ()
linkTo src rel dst = do
   void $ TList.append (rel, src) (nodeEdgeIn dst)
   void $ TList.append (rel, dst) (nodeEdgeOut src)