GEXF.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleInstances #-}
module IGraph.Exporter.GEXF
    ( NodeAttr(..)
    , defaultNodeAttributes
    , EdgeAttr(..)
    , defaultEdgeAttributes
    , genXMLTree
    , writeGEXF
    ) where

import           Data.Colour       (AlphaColour, alphaChannel, black, opaque,
                                    over)
import           Data.Colour.SRGB  (channelBlue, channelGreen, channelRed,
                                    toSRGB24)
import           Data.Serialize
import Data.Function (on)
import           Data.Singletons   (SingI)
import           GHC.Generics
import           IGraph
import           Text.XML.HXT.Core

instance Serialize (AlphaColour Double) where
    get = do
        x <- get
        return $ read x
    put x = put $ show x

data NodeAttr = NodeAttr
    { _size       :: Double
    , _nodeColour :: AlphaColour Double
    , _nodeLabel  :: String
    , _positionX  :: Double
    , _positionY  :: Double
    , _nodeZindex :: Int
    } deriving (Show, Read, Eq, Generic)

instance Ord NodeAttr where
    compare = compare `on` _nodeLabel
instance Serialize NodeAttr

defaultNodeAttributes :: NodeAttr
defaultNodeAttributes = NodeAttr
    { _size = 0.15
    , _nodeColour = opaque black
    , _nodeLabel = ""
    , _positionX = 0
    , _positionY = 0
    , _nodeZindex = 1
    }

data EdgeAttr = EdgeAttr
    { _edgeLabel       :: String
    , _edgeColour      :: AlphaColour Double
    , _edgeWeight      :: Double
    , _edgeArrowLength :: Double
    , _edgeZindex      :: Int
    } deriving (Show, Read, Eq, Generic)

instance Ord EdgeAttr where
    compare = compare `on` _edgeLabel
instance Serialize EdgeAttr

defaultEdgeAttributes :: EdgeAttr
defaultEdgeAttributes = EdgeAttr
    { _edgeLabel = ""
    , _edgeColour = opaque black
    , _edgeWeight = 1.0
    , _edgeArrowLength = 10
    , _edgeZindex = 2
    }

genXMLTree :: (SingI d, ArrowXml a) => Graph d NodeAttr EdgeAttr -> a XmlTree XmlTree
genXMLTree gr = root [] [gexf]
  where
    gexf = mkelem "gexf" [ attr "version" $ txt "1.2"
                              , attr "xmlns" $ txt "http://www.gexf.net/1.2draft"
                              , attr "xmlns:viz" $ txt "http://www.gexf.net/1.2draft/viz"
                              , attr "xmlns:xsi" $ txt "http://www.w3.org/2001/XMLSchema-instance"
                              , attr "xsi:schemaLocation" $ txt "http://www.gexf.net/1.2draft http://www.gexf.net/1.2draft/gexf.xsd"
                              ] [graph]
    directed | isDirected gr = "directed"
             | otherwise = "undirected"
    graph = mkelem "graph" [ attr "mode" $ txt "static"
                           , attr "defaultedgetype" $ txt directed
                           ] [ns, es]
    ns = mkelem "nodes" [] $ map mkNode $ nodes gr
    es = mkelem "edges" [] $ map mkEdge $ edges gr
    mkNode i =
        mkelem "node" [ attr "id" $ txt $ show i
                      , attr "label" $ txt $ _nodeLabel at ]
                      [ aelem "viz:position" [ attr "x" $ txt $ show $ _positionX at
                                             , attr "y" $ txt $ show $ _positionY at ]
                      , aelem "viz:color" [ attr "r" $ txt r
                                          , attr "g" $ txt g
                                          , attr "b" $ txt b
                                          , attr "a" $ txt a ]
                      , aelem "viz:size" [attr "value" $ txt $ show $ _size at]
                      ]
      where
        at = nodeLab gr i
        rgb = toSRGB24 $ _nodeColour at `over` black
        r = show (fromIntegral $ channelRed rgb :: Int)
        b = show (fromIntegral $ channelBlue rgb :: Int)
        g = show (fromIntegral $ channelGreen rgb :: Int)
        a = show $ alphaChannel $ _nodeColour at

    mkEdge (fr,to) =
        mkelem "edge" [ attr "source" $ txt $ show fr
                      , attr "target" $ txt $ show to
                      , attr "weight" $ txt $ show $ _edgeWeight at ]
                      [ aelem "viz:color" [ attr "r" $ txt r
                                          , attr "g" $ txt g
                                          , attr "b" $ txt b
                                          , attr "a" $ txt a ]
                      ]
      where
        at = edgeLab gr (fr,to)
        rgb = toSRGB24 $ _edgeColour at `over` black
        r = show (fromIntegral $ channelRed rgb :: Int)
        b = show (fromIntegral $ channelBlue rgb :: Int)
        g = show (fromIntegral $ channelGreen rgb :: Int)
        a = show $ alphaChannel $ _edgeColour at
{-# INLINE genXMLTree #-}

writeGEXF :: SingI d => FilePath -> Graph d NodeAttr EdgeAttr -> IO ()
writeGEXF fl gr = runX (genXMLTree gr >>> writeDocument config fl) >> return ()
  where
    config = [withIndent yes]