happy-dot-1.0.0.0: benchmarks/LanguageDotBench.hs

{-# LANGUAGE BangPatterns #-}
module Main where

import GraphGenerator

import Language.Dot.Parser
import Language.Dot.Syntax
import Data.List

import System.Clock

data GraphElement a = Node String [a] | Edge String String [a]

adjacency (Graph _ _ _ stmts) = adjacency' [] [] stmts
  where
    adjacency' _ _ [] = ([],[])
    adjacency' nodeAttr edgeAttr (stmt:ss) = 
      case stmt of
        (EdgeStatement subgraphs attributes) -> 
          let sgs = (map (subgraphAdjacency nodeAttr edgeAttr) subgraphs)
              edges = concatMap snd (sgs)
              nodes = map fst (sgs)
              pathEdges = makePath ((reverse attributes) ++ edgeAttr) nodes
              (ns, es) = adjacency' nodeAttr edgeAttr ss
          in ((concat nodes) ++ ns, (edges ++ pathEdges) ++ es)
        (NodeStatement (NodeId name _) attributes) -> 
          let (ns, es) = adjacency' nodeAttr edgeAttr ss
          in ((Node (show name) (nodeAttr ++ attributes)) : ns, es)
        (SubgraphStatement subgraph) -> case subgraph of
          SubgraphRef name -> 
            let (ns, es) = adjacency' nodeAttr edgeAttr ss
            in ((Node (show name) nodeAttr) : ns, es)
          NewSubgraph name stmts -> adjacency' nodeAttr edgeAttr stmts
        (AttributeStatement GraphAttributeStatement attributes)
          -> adjacency' nodeAttr edgeAttr ss
        (AssignmentStatement _ _)
          -> adjacency' nodeAttr edgeAttr ss
        (AttributeStatement EdgeAttributeStatement attributes)
          -> adjacency' nodeAttr ((reverse attributes) ++ edgeAttr) ss
        (AttributeStatement NodeAttributeStatement attributes)
          -> adjacency' ((reverse attributes) ++ nodeAttr) edgeAttr ss
    subgraphAdjacency nodeAttr edgeAttr (ENodeId _ (NodeId name port)) = ([Node (show name) []], [])
    subgraphAdjacency nodeAttr edgeAttr (ESubgraph _ (NewSubgraph _ stmts)) = adjacency' nodeAttr edgeAttr stmts
    subgraphAdjacency nodeAttr edgeAttr (ESubgraph _ (SubgraphRef name)) = ([Node (show name) nodeAttr], [])
    makePath edgeAttr [n1] = []
    makePath edgeAttr (n0:n1:ns) = [Edge v0 v1 (reverse edgeAttr) | (Node v0 _) <- n0, (Node v1 _) <- n1] ++ makePath edgeAttr (n1:ns)

runBench !gStr = do
  start <- getTime ProcessCPUTime
  let Right ast = parseDot "" gStr
      (Graph _ _ (Just (StringId name)) _ ) = ast
      (vertices, edges) = adjacency ast
      !numVerts = length vertices
      !numEdges = length edges
  end <- getTime ProcessCPUTime
  let delta = (toNanoSecs $ diffTimeSpec end start) `div` 10^6 
  return $ ( intercalate ","
              [ "language-dot"
              , name
              , show numVerts
              , show numEdges
              , show delta
              ] ,
            delta)

main = do
  results <- mapM runBench instances
  let times = map snd results
  let avg = sum times
  writeFile "benchmark-language-dot.csv" $ intercalate "\n" $ "library, instance, vertices, edges, time (ms)" : map fst results
  putStrLn $ "Total time: " ++ show avg ++ " milliseconds"