| 1 | 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. |
| 2 | |
| 3 | {{{ |
| 4 | {-# LANGUAGE RankNTypes #-} |
| 5 | |
| 6 | -- a tiny annotated graph library |
| 7 | -- Edward Kmett 2010 |
| 8 | |
| 9 | module Data.Graph.Annotated where |
| 10 | |
| 11 | import Data.Sequence as S |
| 12 | import Data.Sequence (Sequence, ViewL(..), ViewR(..), (><)) |
| 13 | import Data.Vector as V |
| 14 | import Data.Ix |
| 15 | import qualified Data.Graph as G |
| 16 | import Data.Graph (Graph) |
| 17 | import Control.Monad.Writer.Instances |
| 18 | |
| 19 | class PFunctor f where |
| 20 | first :: (a -> b) -> f a c -> f b c |
| 21 | |
| 22 | -- a simple safe graph library based on Data.Graph for prototyping |
| 23 | -- TODO: use Vector [Int] or Rope (Vector [Int]) |
| 24 | newtype Graph b = Graph { runGraph :: G.Graph } |
| 25 | |
| 26 | newtype Vertex b = Vertex { vertexId :: Int } |
| 27 | deriving (Enum,Ix,Eq,Ord,Show,Typeable) |
| 28 | |
| 29 | vertices :: Graph b -> [Vertex b] |
| 30 | vertices = fmap Vertex . G.vertices . runGraph |
| 31 | |
| 32 | dfs :: Graph b -> [Vertex b] -> Forest (Vertex b) |
| 33 | dfs g vs = fmap Vertex <$> G.dfs (runGraph g) (vertexId <$> vs) |
| 34 | |
| 35 | dff :: Graph b -> Forest (Vertex b) |
| 36 | dff g = Vertex <$> G.dff (runGraph g) |
| 37 | |
| 38 | topSort :: Graph b -> [Vertex b] |
| 39 | topSort g = Vertex <$> G.topSort (runGraph g) |
| 40 | |
| 41 | components :: Graph b -> Forest (Vertex b) |
| 42 | components g = fmap Vertex <$> G.components (runGraph g) |
| 43 | |
| 44 | newtype Edge b = Edge (Vertex b, Vertex b) |
| 45 | deriving (Ix,Eq,Ord,Show,Typeable) |
| 46 | |
| 47 | edges :: Graph b -> [Edge b] |
| 48 | edges = fmap Edge . G.edges . runGraph |
| 49 | |
| 50 | newtype NodeAnn a b = NodeAnn (G.Table a) |
| 51 | |
| 52 | instance PFunctor NodeAnn where |
| 53 | first f (NodeAnn t) = NodeAnn (f <$> t) |
| 54 | |
| 55 | indegree :: Graph b -> NodeAnn Int b |
| 56 | indegree = NodeAnn . G.indegree . runGraph |
| 57 | |
| 58 | outdegree :: Graph b -> NodeAnn Int b |
| 59 | outdegree = NodeAnn . G.outdegree . runGraph |
| 60 | |
| 61 | data Degree b = Degree { indegree :: NodeAnn Int b, outDegree :: NodeAnn Int b } |
| 62 | |
| 63 | degree :: Graph b -> (Degree `Annotated` Graph) b |
| 64 | degree g = (g, Degree (indegree g) (outdegree g)) |
| 65 | |
| 66 | -- newtype NodeMap k b = NodeAnn (Map k IntSet) (IntMap [k]) |
| 67 | -- tag :: Ord k => k -> Vertex b -> NodeMap k b -> NodeMap k b |
| 68 | -- lookup :: NodeMap k b -> k -> [Vertex b] |
| 69 | |
| 70 | -- used internally, expose? |
| 71 | class Functor w => Comonad w where |
| 72 | extract :: w a -> a |
| 73 | extend :: (w a -> b) -> w a -> w b |
| 74 | duplicate :: w a -> w (w a) |
| 75 | |
| 76 | duplicate = extend id |
| 77 | extend f = fmap f . duplicate |
| 78 | |
| 79 | instance Comonad ((,)e) where |
| 80 | extract = snd |
| 81 | extend f ea = (fst ea, f ea) |
| 82 | duplicate f ea@(e,_) = (e, f ea) |
| 83 | |
| 84 | type Annotated f s b = (s b, f b) |
| 85 | |
| 86 | -- existentially wrapped annotation |
| 87 | -- data Ann f s = forall b. Ann ((f `Annotated` s) b) |
| 88 | |
| 89 | -- runAnn :: Ann f s -> (forall b. (f `Annotated` s) b -> r) -> r |
| 90 | -- runAnn (Ann a) k = k a |
| 91 | |
| 92 | -- a boxed up annotated structure |
| 93 | newtype Ann f s = Ann { runAnn :: forall r. (forall b. (f `Annotated` s) b -> r) -> r } |
| 94 | |
| 95 | -- we can transpose node annotations easily |
| 96 | data Transpose b |
| 97 | |
| 98 | class TransposableAnn f where |
| 99 | transposeAnn :: (f `Annotated` Graph) a -> f (Transpose a) |
| 100 | |
| 101 | instance TransposableAnn (NodeAnn a) where |
| 102 | transposeAnn (NodeAnn t) = NodeAnn t |
| 103 | |
| 104 | transpose :: TransposableAnn f => (f `Annotated` Graph) b -> (f `Annotated` Graph) (Transpose b) |
| 105 | transpose g = (G.transpose (runGraph g), transposeAnn g) |
| 106 | |
| 107 | }}} |