[ create a new paste ] login | about

Link: http://codepad.org/UXUL7LZv    [ raw code | fork ]

Haskell, pasted on Sep 14:
{-# 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)


Create a new paste based on this one


Comments: