[Haskell-cafe] copy of boost graph library

[Thomas Bereknyei]

I was looking around and liked some of the ways that Boost organizes
its libraries.  So it got me thinking that it might be easy to use the
same for a Haskell graph library.  This IS NOT FGL, but does include
some elements of it at the end (InductiveGraph).

Mostly what I like, is that it presents a (somewhat) logical sequence
of operations for a graph writer to implement, getting a few freebies
along the way.  There aren't too many extensions or complications.
The most odd thing is the way I arranged the types.  A quick look at
some typesigs should clear up confusion, but:

Node g is the entire node, eg (Int,a)
NodeIndex is just the index eg Int
NodeLabel is just the label eg. a    the same for edge.

I'm just fishing for ideas and opinions, and whether or not this seems
simpler to use.

http://codepad.org/UXUL7LZv

{-# LANGUAGE   TypeFamilies
                ,FlexibleContexts

  #-}

  --TODO: Visitors? DFF searches

import qualified Data.IntMap as I
import Data.List (find,unfoldr,foldl')
import Data.Maybe (fromJust)
import Control.Arrow (second)

class Graph g where
    type NodeIndex g
    type EdgeIndex g
    type Node g --The entire node, including index, any labels and/or data.
    type Edge g --ditto
    node_index :: g -> Node g -> NodeIndex g
    edge_index :: g -> Edge g -> EdgeIndex g

    empty :: g
    isEmpty :: g -> Bool
    mkGraph :: [Node g] -> [Edge g] -> g

class Graph g => DirectionalGraph g where
    edges_out :: g -> NodeIndex g -> [Edge g]
    source , target :: g -> EdgeIndex g -> Node g

    degree_out :: g -> NodeIndex g -> Int
    degree_out = length ... edges_out

class DirectionalGraph g => BidirectionalGraph g where
    edges_in :: g -> NodeIndex g -> [Edge g]
    edges_both :: g -> NodeIndex g -> [Edge g]
    edges_both g n = edges_out g n ++ edges_in g n

    degree_in :: g -> NodeIndex g -> Int
    degree_in = length ... edges_in
    degree :: g -> NodeIndex g -> Int
    degree g n = degree_out g n + degree_in g n

class Graph g => AdjacencyGraph g where
    nodes_out,nodes_in,nodes_both :: g -> NodeIndex g -> [NodeIndex g]

class Graph g => VertexGraph g where
    nodes :: g -> [Node g]
    node :: g -> NodeIndex g -> Maybe (Node g)
    hasNode :: g -> NodeIndex g -> Bool
    hasNode g n = maybe False (const True) (node g n)
    order :: g -> Int
    order = length . nodes

class Graph g => EdgeGraph g where
    edges :: g -> [Edge g]
    edge :: g -> EdgeIndex g -> Maybe (Edge g)
    hasEdge :: g -> EdgeIndex g -> Bool
    hasEdge g e = maybe False (const True) (edge g e)
    size :: g -> Int
    size = length . edges

class Graph g => MutableGraph g where
    insert_node :: Node g -> g -> g --if preexists, update
    remove_node :: NodeIndex g -> g -> g
    insert_edge :: Edge g -> g -> g --if preexists, update
    remove_edge :: EdgeIndex g -> g -> g

class Graph g => PropertyGraph g where
    type NodeLabel g
    type EdgeLabel g

    node_label :: Node g -> NodeLabel g
    edge_label :: Edge g -> EdgeLabel g

    node_labelize :: NodeIndex g -> NodeLabel g -> Node g
    edge_labelize :: EdgeIndex g -> EdgeLabel g -> Edge g

    get_node_label :: g -> NodeIndex g -> NodeLabel g
    get_edge_label :: g -> EdgeIndex g -> EdgeLabel g

class (VertexGraph g,BidirectionalGraph g,MutableGraph g) =>
InductiveGraph g where
    data Context g
    edgesInC :: Context g -> [Edge g]
    nodeC :: Context g -> Node g
    edgesOutC :: Context g -> [Edge g]

    make_context :: [Edge g] -> Node g -> [Edge g] -> Context g

    --minimum definition is match or context, but default works too
    context :: g -> NodeIndex g -> Maybe (Context g)
    --context = fmap fst ... match
    context g n = do    foundNode <- node g n
                        return $ make_context (edges_in g n) foundNode
(edges_out g n)

    match :: g -> NodeIndex g -> Maybe (Context g,g)
    match g n = fmap (flip (,) $ remove_node n g) $ context g n

    insert :: Context g -> g -> g
    insert c g = foldr insert_edge g'' (edgesOutC c)
                    where
                        g' = insert_node (nodeC c) g
                        g'' = foldr insert_edge g' (edgesInC c)

    toContexts   :: g -> [Context g]
    toContexts g = unfoldr matchIt (g, map (node_index g) $ nodes g)
      where
        matchIt (_,  [])     = Nothing
        matchIt (g', (n:ns)) = fmap (second (flip (,) ns)) $ match g n

    fromContexts :: [Context g] -> g
    fromContexts = foldr insert empty

    adjust       :: (Context g -> Context g) -> NodeIndex g -> g -> g
    adjust f n g = maybe g (uncurry (insert . f)) $ match g n

    gfoldr     :: (Context g -> b -> b) -> b -> g -> b
    gfoldr f i = foldr f i . toContexts

    gfoldl'     :: (b -> Context g -> b) -> b -> g -> b
    gfoldl' f i = foldl' f i . toContexts

    gfilter   :: (Context g -> Bool) -> g -> g
    gfilter f = fromContexts . filter f . toContexts

class (InductiveGraph g) => MappableGraph g where

    gmap   :: InductiveGraph g' => (Context g -> Context g') -> g -> g'
    gmap f = fromContexts . map f . toContexts

    nmap   :: (InductiveGraph g,Edge g ~ Edge g) => (Node g -> Node g) -> g -> g
    nmap f = gmap f' where
        f' c = make_context (edgesInC c) (f $ nodeC c) (edgesOutC c)


    emap   :: ( InductiveGraph g', Node g ~ Node g') => (Edge g ->
Edge g') -> g -> g'
    emap f = gmap f' where
          f' c = make_context (map f $ edgesInC c) (nodeC c) (map f $
edgesOutC c)