Add unit tests for findTreeRoots. Fix findTreeRoots. Improve renderFglGraph.

app/GraphAlgorithms.hs

@@ -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'

test/AllTests.hs

@@ -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