Commit 32e9bb7b authored by Kai Zhang's avatar Kai Zhang

add Binary instance

parent e573be11
...@@ -55,6 +55,7 @@ library ...@@ -55,6 +55,7 @@ library
build-depends: build-depends:
base >=4.0 && <5.0 base >=4.0 && <5.0
, binary
, bytestring >=0.9 , bytestring >=0.9
, bytestring-lexing >=0.5 , bytestring-lexing >=0.5
, colour , colour
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
module IGraph module IGraph
( LGraph(..) ( LGraph(..)
, U(..) , U(..)
...@@ -24,31 +24,48 @@ module IGraph ...@@ -24,31 +24,48 @@ module IGraph
, emap , emap
) where ) where
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad (liftM, forM_) import Control.Monad (forM_, liftM)
import Control.Monad.ST (runST) import Control.Monad.Primitive
import Control.Monad.Primitive import Control.Monad.ST (runST)
import qualified Data.HashMap.Strict as M import Data.Hashable (Hashable)
import Data.List (nub) import qualified Data.HashMap.Strict as M
import Data.Hashable (Hashable) import Data.List (nub)
import Data.Maybe import Data.Maybe
import System.IO.Unsafe (unsafePerformIO) import Data.Binary
import System.IO.Unsafe (unsafePerformIO)
import IGraph.Mutable
import IGraph.Internal.Graph import IGraph.Internal.Attribute
import IGraph.Internal.Constants import IGraph.Internal.Constants
import IGraph.Internal.Attribute import IGraph.Internal.Graph
import IGraph.Internal.Selector import IGraph.Internal.Selector
import IGraph.Mutable
type Node = Int type Node = Int
type Edge = (Node, Node) type Edge = (Node, Node)
-- | graph with labeled nodes and edges -- | graph with labeled nodes and edges
data LGraph d v e = LGraph data LGraph d v e = LGraph
{ _graph :: IGraphPtr { _graph :: IGraphPtr
, _labelToNode :: M.HashMap v [Node] , _labelToNode :: M.HashMap v [Node]
} }
instance ( Binary v, Hashable v, Read v, Show v, Eq v
, Binary e, Read e, Show e, Graph d) => Binary (LGraph d v e) where
put gr = do
put nlabs
put es
put elabs
where
nlabs = map (nodeLab gr) $ nodes gr
es = edges gr
elabs = map (edgeLab gr) es
get = do
nlabs <- get
es <- get
elabs <- get
return $ mkGraph nlabs $ zip es elabs
class MGraph d => Graph d where class MGraph d => Graph d where
isDirected :: LGraph d v e -> Bool isDirected :: LGraph d v e -> Bool
isD :: d -> Bool isD :: d -> Bool
...@@ -118,29 +135,23 @@ instance Graph D where ...@@ -118,29 +135,23 @@ instance Graph D where
isD = const True isD = const True
mkGraph :: (Graph d, Hashable v, Read v, Eq v, Show v, Show e) mkGraph :: (Graph d, Hashable v, Read v, Eq v, Show v, Show e)
=> (Node, Maybe [v]) -> ([Edge], Maybe [e]) -> LGraph d v e => [v] -> [(Edge, e)] -> LGraph d v e
mkGraph (n, vattr) (es,eattr) = runST $ do mkGraph vattr es = runST $ do
g <- new 0 g <- new 0
let addV | isNothing vattr = addNodes n g addLNodes n vattr g
| otherwise = addLNodes n (fromJust vattr) g addLEdges (map (\((fr,to),x) -> (fr,to,x)) es) g
addE | isNothing eattr = addEdges es g
| otherwise = addLEdges (zip' es (fromJust eattr)) g
addV
addE
unsafeFreeze g unsafeFreeze g
where where
zip' a b | length a /= length b = error "incorrect length" n = length vattr
| otherwise = zipWith (\(x,y) z -> (x,y,z)) a b
fromLabeledEdges :: (Graph d, Hashable v, Read v, Eq v, Show v, Show e) fromLabeledEdges :: (Graph d, Hashable v, Read v, Eq v, Show v, Show e)
=> [((v, v), e)] -> LGraph d v e => [((v, v), e)] -> LGraph d v e
fromLabeledEdges es = mkGraph (n, Just labels) (es', Just $ snd $ unzip es) fromLabeledEdges es = mkGraph labels es'
where where
es' = map (f *** f) $ fst $ unzip es es' = flip map es $ \((fr, to), x) -> ((f fr, f to), x)
where f x = M.lookupDefault undefined x labelToId where f x = M.lookupDefault undefined x labelToId
labels = nub $ concat [ [a,b] | ((a,b),_) <- es ] labels = nub $ concat [ [a,b] | ((a,b),_) <- es ]
labelToId = M.fromList $ zip labels [0..] labelToId = M.fromList $ zip labels [0..]
n = M.size labelToId
unsafeFreeze :: (Hashable v, Eq v, Read v, PrimMonad m) => MLGraph (PrimState m) d v e -> m (LGraph d v e) unsafeFreeze :: (Hashable v, Eq v, Read v, PrimMonad m) => MLGraph (PrimState m) d v e -> m (LGraph d v e)
unsafeFreeze (MLGraph g) = return $ LGraph g labToId unsafeFreeze (MLGraph g) = return $ LGraph g labToId
......
...@@ -42,4 +42,4 @@ triad = map make xs ...@@ -42,4 +42,4 @@ triad = map make xs
] ]
make :: [(Int, Int)] -> LGraph D () () make :: [(Int, Int)] -> LGraph D () ()
make xs = mkGraph (length xs, Nothing) (xs, Nothing) make xs = mkGraph (replicate (length xs) ()) $ zip xs $ repeat ()
...@@ -26,7 +26,7 @@ fromAdjMatrix bs = ...@@ -26,7 +26,7 @@ fromAdjMatrix bs =
ncol = length $ head mat ncol = length $ head mat
in if nrow /= ncol in if nrow /= ncol
then error "fromAdjMatrix: nrow != ncol" then error "fromAdjMatrix: nrow != ncol"
else mkGraph (nrow, Just $ B.words header) (es, Nothing) else mkGraph (B.words header) $ zip es $ repeat ()
where where
f ((i,j),v) = i < j && v /= 0 f ((i,j),v) = i < j && v /= 0
{-# INLINE fromAdjMatrix #-} {-# INLINE fromAdjMatrix #-}
...@@ -41,6 +41,6 @@ readAdjMatrixWeighted fl = do ...@@ -41,6 +41,6 @@ readAdjMatrixWeighted fl = do
ncol = length $ head mat ncol = length $ head mat
if nrow /= ncol if nrow /= ncol
then error "nrow != ncol" then error "nrow != ncol"
else return $ mkGraph (nrow, Just $ B.words header) (es, Just ws) else return $ mkGraph (B.words header) $ zip es ws
where where
f ((i,j),v) = i < j && v /= 0 f ((i,j),v) = i < j && v /= 0
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment