mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add unit tests for findTreeRoots. Fix findTreeRoots. Improve renderFglGraph.
This commit is contained in:
parent
2788bdf4f2
commit
b36ffd400a
@ -1,5 +1,6 @@
|
||||
module GraphAlgorithms(
|
||||
collapseNodes
|
||||
collapseNodes,
|
||||
findTreeRoots
|
||||
) where
|
||||
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
@ -26,7 +27,8 @@ collapseNodes originalGraph = originalGraph where
|
||||
-- These nodes are thus each a root of a collapsed node tree.
|
||||
-- A node is a treeRoot if all of these conditions are true:
|
||||
-- 1. The SyntaxNode can embed other nodes (i.e. syntaxNodeCanEmbed is true)
|
||||
-- 2. The node has at least one parent that can not embed (i.e. the node has a parent where syntaxNodeCanEmbed is false.)
|
||||
-- 2. The node has no parents that can embed it
|
||||
-- TODO These rules should be revised to allow cycles to be embedded.
|
||||
-- Note: A treeRoot may not actually have any embeddable children, since collapseTree will do nothing in that case.
|
||||
findTreeRoots :: ING.DynGraph gr => SyntaxGraph gr -> [ING.Node]
|
||||
findTreeRoots graph = filterNodes (isTreeRoot graph) graph
|
||||
@ -37,9 +39,10 @@ filterNodes :: ING.DynGraph gr => (ING.Node -> Bool) -> gr a b -> [ING.Node]
|
||||
filterNodes pred gr = ING.nodes $ ING.nfilter pred gr
|
||||
|
||||
isTreeRoot :: ING.Graph gr => SyntaxGraph gr -> ING.Node -> Bool
|
||||
isTreeRoot graph node = graphNodeCanEmbed graph node && hasAParentThatCannotEmbed where
|
||||
hasAParentThatCannotEmbed = not $ null parentsThatCannotEmbed
|
||||
parentsThatCannotEmbed = filter (not . graphNodeCanEmbed graph) (findParents graph node)
|
||||
isTreeRoot graph node = graphNodeCanEmbed graph node && noParentsCanEmbed where
|
||||
noParentsCanEmbed = null parentsThatCanEmbed
|
||||
parentsThatCanEmbed = filter (graphNodeCanEmbed graph) parents
|
||||
parents = findParents graph node
|
||||
|
||||
findParents :: ING.Graph gr => gr a b -> ING.Node -> [ING.Node]
|
||||
-- TODO, may need to use ING.pre or ING.neighbors instead of ING.suc'
|
||||
|
@ -9,14 +9,17 @@ import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||
import qualified Data.Graph.Inductive.Graph as ING
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
|
||||
import Test.HUnit
|
||||
|
||||
import Icons(textBox, colorScheme, ColorStyle(..), coloredTextBox)
|
||||
import Rendering(renderDrawing, customLayoutParams)
|
||||
import Util(toNames, portToPort, iconToPort, iconToIcon,
|
||||
iconToIconEnds, iconTailToPort)
|
||||
import Types(Icon(..), Drawing(..), EdgeEnd(..), SgNamedNode, Edge)
|
||||
import Types(Icon(..), Drawing(..), EdgeEnd(..), SgNamedNode, Edge, SyntaxNode(..))
|
||||
import Translate(translateString, stringToSyntaxGraph)
|
||||
import TranslateCore(syntaxGraphToFglGraph)
|
||||
import GraphAlgorithms(collapseNodes)
|
||||
import qualified GraphAlgorithms
|
||||
|
||||
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
||||
d0Icons = toNames
|
||||
@ -417,17 +420,20 @@ graphTests = do
|
||||
nodeFunc (name, syntaxNode) =
|
||||
place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
|
||||
|
||||
-- For Neato
|
||||
scaleFactor = 0.12
|
||||
|
||||
renderFglGraph :: FGR.Gr SgNamedNode Edge -> IO (Diagram B)
|
||||
renderFglGraph fglGraph = do
|
||||
layedOutGraph <- DiaGV.layoutGraph' layoutParams GVA.Neato fglGraph
|
||||
pure $ DiaGV.drawGraph
|
||||
nodeFunc
|
||||
(\_ _ _ _ _ p -> lc white $ stroke p)
|
||||
--(\_ _ _ _ _ p -> lc white $ stroke p)
|
||||
(\_ p₁ _ p₂ _ p -> lcA (withOpacity white 0.5) $ arrowBetween (scaleFactor *^ p₁) (scaleFactor *^ p₂))
|
||||
layedOutGraph
|
||||
where
|
||||
nodeFunc (name, syntaxNode) =
|
||||
place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
|
||||
nodeFunc (name, syntaxNode) point =
|
||||
place (coloredTextBox white (opaque white) (show name ++ show syntaxNode) :: Diagram B) (scaleFactor *^ point)
|
||||
layoutParams :: GV.GraphvizParams Int v e () v
|
||||
layoutParams = customLayoutParams{
|
||||
GV.fmtNode = nodeAttribute
|
||||
@ -443,7 +449,8 @@ collapseTestStrings = [
|
||||
"y = x",
|
||||
"y = 1.0",
|
||||
"y = f x",
|
||||
"y = f x1 x2"
|
||||
"y = f x1 x2",
|
||||
"y = f (g x)"
|
||||
]
|
||||
|
||||
makeCollapseTest :: String -> IO (Diagram B)
|
||||
@ -472,9 +479,9 @@ collapseTests = do
|
||||
|
||||
drawingsAndNames :: [(String, IO (Diagram B))]
|
||||
drawingsAndNames = [
|
||||
("translate-tests", translateTests),
|
||||
("render-tests", renderTests),
|
||||
("graph-tests", graphTests),
|
||||
-- ("translate-tests", translateTests),
|
||||
-- ("render-tests", renderTests),
|
||||
-- ("graph-tests", graphTests),
|
||||
("collapse-tests", collapseTests)
|
||||
]
|
||||
|
||||
@ -496,6 +503,23 @@ testCollapse = do
|
||||
putStrLn "\nfglOut:"
|
||||
ING.prettyPrint fglOut
|
||||
|
||||
makeTreeRootTest (testName, expected, haskellString) = TestCase $ assertEqual testName expected actual where
|
||||
actual = (fmap (ING.lab graph) treeRoots) where
|
||||
graph = syntaxGraphToFglGraph $ stringToSyntaxGraph haskellString
|
||||
treeRoots = GraphAlgorithms.findTreeRoots graph
|
||||
|
||||
treeRootTests = TestList $ fmap makeTreeRootTest treeRootTestList where
|
||||
treeRootTestList = [
|
||||
("single apply", [Just (toName "app02", ApplyNode 1)], "y = f x"),
|
||||
("double apply", [Just (toName "app04", ApplyNode 1)], "y = f (g x)")
|
||||
]
|
||||
|
||||
collapseUnitTests = TestList[TestLabel "findTreeRoots" treeRootTests]
|
||||
|
||||
main :: IO ()
|
||||
main = renderDrawings drawingsAndNames
|
||||
--main = print "Hello world"
|
||||
main = do
|
||||
renderDrawings drawingsAndNames
|
||||
runTestTT collapseUnitTests
|
||||
pure ()
|
||||
--main = testCollapse
|
||||
|
Loading…
Reference in New Issue
Block a user