{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Pangraph (
Pangraph, Edge, Vertex, Attribute,
Key, Value, VertexID, EdgeID, MalformedEdge,
makePangraph, makeEdge, makeVertex,
edgeList, vertexList, lookupVertex, lookupEdge,
edgeAttributes, vertexAttributes,
edgeEndpoints, edgeID, vertexID
) where
import Data.Maybe (mapMaybe)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.ByteString as BS
import qualified Algebra.Graph.ToGraph as Alga
import qualified Algebra.Graph as Alga
data Pangraph = Pangraph
{ vertices' :: Map VertexID Vertex
, edges' :: Map EdgeID Edge
} deriving (Eq)
data Vertex = Vertex
{ vertexID' :: VertexID
, vertexAttributes' :: [Attribute]
} deriving (Eq)
data Edge = Edge
{ edgeID' :: Maybe EdgeID
, endpoints' :: (VertexID, VertexID)
, edgeAttributes' :: [Attribute]
} deriving (Eq)
type EdgeID = Int
type VertexID = BS.ByteString
type Attribute = (Key, Value)
type Key = BS.ByteString
type Value = BS.ByteString
type MalformedEdge = (Edge, (Maybe VertexID, Maybe VertexID))
instance Show Pangraph where
show p = "makePangraph " ++ show (Map.elems (vertices' p)) ++ " " ++ show (Map.elems (edges' p))
instance Show Vertex where
show (Vertex i as) = unwords ["makeVertex", show i, show as]
instance Show Edge where
show (Edge _ e as) = unwords ["makeEdge", show e, show as]
instance Alga.ToGraph Pangraph where
type ToVertex Pangraph = VertexID
toGraph p = Alga.vertices (map vertexID . vertexList $ p) `Alga.overlay` Alga.edges (map edgeEndpoints $ edgeList p)
makePangraph :: [Vertex] -> [Edge] -> Maybe Pangraph
makePangraph vs es = case verifyGraph vertexMap es of
[] -> (Just . Pangraph vertexMap) edgeMap
_ -> Nothing
where
vertexMap :: Map VertexID Vertex
vertexMap = Map.fromList $ zip (map vertexID vs) vs
edgeMap :: Map EdgeID Edge
edgeMap = Map.fromList indexEdges
indexEdges :: [(EdgeID, Edge)]
indexEdges = map (\(i, Edge _ a as) -> (i, Edge (Just i) a as )) $ zip [0..] es
verifyGraph :: Map VertexID Vertex -> [Edge] -> [MalformedEdge]
verifyGraph vs = let
lookupEndpoints :: (Edge, (VertexID, VertexID)) -> Maybe MalformedEdge
lookupEndpoints (e, (v1,v2)) =
case (Map.lookup v1 vs, Map.lookup v2 vs) of
(Just _ , Just _) -> Nothing
(Nothing, Just _) -> Just (e, (Just v1, Nothing))
(Just _ , Nothing) -> Just (e, (Nothing, Just v2))
(Nothing, Nothing) -> Just (e, (Just v1, Just v2))
in mapMaybe (\e -> lookupEndpoints (e, edgeEndpoints e))
makeEdge :: (VertexID, VertexID) -> [Attribute] -> Edge
makeEdge = Edge Nothing
makeVertex :: VertexID -> [Attribute] -> Vertex
makeVertex = Vertex
edgeList :: Pangraph -> [Edge]
edgeList p = Map.elems $ edges' p
vertexList :: Pangraph -> [Vertex]
vertexList p = Map.elems $ vertices' p
lookupEdge :: EdgeID -> Pangraph -> Maybe Edge
lookupEdge key p = Map.lookup key $ edges' p
lookupVertex :: VertexID -> Pangraph -> Maybe Vertex
lookupVertex key p = Map.lookup key $ vertices' p
edgeAttributes :: Edge -> [Attribute]
edgeAttributes = edgeAttributes'
vertexAttributes :: Vertex -> [Attribute]
vertexAttributes = vertexAttributes'
edgeEndpoints :: Edge -> (VertexID, VertexID)
edgeEndpoints = endpoints'
edgeID :: Edge -> Maybe EdgeID
edgeID = edgeID'
vertexID :: Vertex -> VertexID
vertexID = vertexID'