Version 1 (modified by alpmestan, 3 years ago)

--

Thomas Bereknyei, Edward Kmett and Alp Mestanogullari started working a on a new version of HNN, which probably requires a nicer graph library. Here is a draft of the latter.

```{-# LANGUAGE RankNTypes #-}

-- a tiny annotated graph library
-- Edward Kmett 2010

module Data.Graph.Annotated where

import Data.Sequence as S
import Data.Sequence (Sequence, ViewL(..), ViewR(..), (><))
import Data.Vector as V
import Data.Ix
import qualified Data.Graph as G
import Data.Graph (Graph)
import Control.Monad.Writer.Instances

class PFunctor f where
first :: (a -> b) -> f a c -> f b c

-- a simple safe graph library based on Data.Graph for prototyping
-- TODO: use Vector [Int] or Rope (Vector [Int])
newtype Graph b = Graph { runGraph :: G.Graph }

newtype Vertex b = Vertex { vertexId :: Int }
deriving (Enum,Ix,Eq,Ord,Show,Typeable)

vertices :: Graph b -> [Vertex b]
vertices = fmap Vertex . G.vertices . runGraph

dfs :: Graph b -> [Vertex b] -> Forest (Vertex b)
dfs g vs = fmap Vertex <\$> G.dfs (runGraph g) (vertexId <\$> vs)

dff :: Graph b -> Forest (Vertex b)
dff g = Vertex <\$> G.dff (runGraph g)

topSort :: Graph b -> [Vertex b]
topSort g = Vertex <\$> G.topSort (runGraph g)

components :: Graph b -> Forest (Vertex b)
components g = fmap Vertex <\$> G.components (runGraph g)

newtype Edge b = Edge (Vertex b, Vertex b)
deriving (Ix,Eq,Ord,Show,Typeable)

edges :: Graph b -> [Edge b]
edges = fmap Edge . G.edges . runGraph

newtype NodeAnn a b = NodeAnn (G.Table a)

instance PFunctor NodeAnn where
first f (NodeAnn t) = NodeAnn (f <\$> t)

indegree :: Graph b -> NodeAnn Int b
indegree = NodeAnn . G.indegree . runGraph

outdegree :: Graph b -> NodeAnn Int b
outdegree = NodeAnn . G.outdegree . runGraph

data Degree b = Degree { indegree :: NodeAnn Int b, outDegree :: NodeAnn Int b }

degree :: Graph b -> (Degree `Annotated` Graph) b
degree g = (g, Degree (indegree g) (outdegree g))

-- newtype NodeMap k b = NodeAnn (Map k IntSet) (IntMap [k])
-- tag :: Ord k => k -> Vertex b -> NodeMap k b -> NodeMap k b
-- lookup :: NodeMap k b -> k -> [Vertex b]

-- used internally, expose?
class Functor w => Comonad w where
extract :: w a -> a
extend :: (w a -> b) -> w a -> w b
duplicate :: w a -> w (w a)

duplicate = extend id
extend f = fmap f . duplicate

instance Comonad ((,)e) where
extract = snd
extend f ea = (fst ea, f ea)
duplicate f ea@(e,_) = (e, f ea)

type Annotated f s b = (s b, f b)

-- existentially wrapped annotation
-- data Ann f s = forall b. Ann ((f `Annotated` s) b)

-- runAnn :: Ann f s -> (forall b. (f `Annotated` s) b -> r) -> r
-- runAnn (Ann a) k = k a

-- a boxed up annotated structure
newtype Ann f s = Ann { runAnn :: forall r. (forall b. (f `Annotated` s) b -> r) -> r }

-- we can transpose node annotations easily
data Transpose b

class TransposableAnn f where
transposeAnn :: (f `Annotated` Graph) a -> f (Transpose a)

instance TransposableAnn (NodeAnn a) where
transposeAnn (NodeAnn t) = NodeAnn t

transpose :: TransposableAnn f => (f `Annotated` Graph) b -> (f `Annotated` Graph) (Transpose b)
transpose g = (G.transpose (runGraph g),  transposeAnn g)

```