0 | module Graphics.DOT.Utils.Filters
  1 |
  2 | import Graphics.DOT.AST
  3 |
  4 | import Data.String
  5 | import Data.List1
  6 |
  7 | %default total
  8 |
  9 | ----------------
 10 | -- Visibility --
 11 | ----------------
 12 |
 13 | ||| Returns `True` iff the `DOTID` was a `NameID` or a `StringID` containing the
 14 | ||| value 'style.
 15 | export
 16 | dotidIsStyle : DOTID -> Bool
 17 | dotidIsStyle (NameID "style") = True
 18 | dotidIsStyle (StringID "\"style\"") = True
 19 | dotidIsStyle _ = False
 20 |
 21 | ||| Returns `True` iff the `DOTID` was a `NameID` or a `StringID` containing the
 22 | ||| value 'invis'.
 23 | export
 24 | dotidIsInvis : DOTID -> Bool
 25 | dotidIsInvis (NameID "invis") = True
 26 | dotidIsInvis (StringID "\"invis\"") = True
 27 | dotidIsInvis _ = False
 28 |
 29 | ||| Returns `True` iff the given assignment sets 'style' to 'invis'.
 30 | assignIsInvis : Assign -> Bool
 31 | assignIsInvis (MkAssign lhs rhs) = dotidIsStyle lhs && dotidIsInvis rhs
 32 |
 33 | ||| Remove any assignment which assigns to the value "invis".
 34 | export
 35 | %inline
 36 | removeInvisAssign : List Assign -> List Assign
 37 | removeInvisAssign = filter (not . assignIsInvis)
 38 |
 39 | ||| Returns `True` iff the given Edge is explicitly invisible.
 40 | export
 41 | isInvisEdge : Stmt -> Bool
 42 | isInvisEdge (EdgeStmt x rhs (assigns :: attrs)) =
 43 |    any assignIsInvis assigns || any (any assignIsInvis) attrs
 44 | isInvisEdge _ = False
 45 |
 46 | ||| Remove all invisible edges from the given `Graph`.
 47 | export
 48 | removeInvisEdges : Graph -> Graph
 49 | removeInvisEdges g@(MkGraph strict graphTy mID_ []) = g
 50 | removeInvisEdges (MkGraph strict graphTy mID_ stmts) =
 51 |    MkGraph strict graphTy mID_ $ filter (not . isInvisEdge) stmts
 52 |
 53 | ----------------
 54 | -- Clustering --
 55 | ----------------
 56 |
 57 | ||| Returns `True` iff the `DOTID` is either a `StringID` or a `NameID`, whose
 58 | ||| value starts with the word "cluster".
 59 | export
 60 | dotidIsCluster : DOTID -> Bool
 61 | dotidIsCluster (StringID id_) = isPrefixOf "\"cluster" $ toLower id_
 62 | dotidIsCluster (NameID name) = isPrefixOf "cluster" $ toLower name
 63 | dotidIsCluster _ = False
 64 |
 65 | ||| Returns `True` iff the `Graph` is a named subgraph, whose name starts with
 66 | ||| the word "cluster".
 67 | export
 68 | graphIsCluster : Graph -> Bool
 69 | graphIsCluster (MkGraph strict SubgraphKW (Just graphID) stmtList) =
 70 |    dotidIsCluster graphID
 71 | graphIsCluster _ = False
 72 |
 73 | ||| Returns `True` iff the `Subgraph` is a named subgraph, whose name starts
 74 | ||| with the word "cluster".
 75 | export
 76 | subgraphIsCluster : Subgraph -> Bool
 77 | subgraphIsCluster (MkSubgraph (Just (kw, (Just subgraphID))) stmtList) =
 78 |    dotidIsCluster subgraphID
 79 | subgraphIsCluster _ = False
 80 |
 81 | ||| Returns `True` iff the `EdgeRHS` connects to a cluster subgraph.
 82 | export
 83 | edgeRHSHasCluster : EdgeRHS -> Bool
 84 | edgeRHSHasCluster (MkEdgeRHS op (Right subgr)) = subgraphIsCluster subgr
 85 | edgeRHSHasCluster _ = False
 86 |
 87 | ||| Returns `True` iff the given `Stmt` contains a cluster subgraph.
 88 | export
 89 | stmtHasCluster : Stmt -> Bool
 90 | stmtHasCluster (EdgeStmt (Right subgr) erhss _) =
 91 |    subgraphIsCluster subgr || any edgeRHSHasCluster erhss
 92 | stmtHasCluster (EdgeStmt _ erhss _) = any edgeRHSHasCluster erhss
 93 | stmtHasCluster (SubgraphStmt subgr) = subgraphIsCluster subgr
 94 | stmtHasCluster _ = False
 95 |
 96 | ||| Remove any cluster subgraphs from the given `Graph`.
 97 | export
 98 | removeClusters : Graph -> Graph
 99 | removeClusters g@(MkGraph strict graphTy mID_ []) = g
100 | removeClusters (MkGraph strict graphTy mID_ stmts) =
101 |    MkGraph strict graphTy mID_ $ filter (not . stmtHasCluster) stmts
102 |
103 |