Initial work for collapseNodes using graphs.

app/GraphAlgorithms.hs

@@ -0,0 +1,63 @@
+module GraphAlgorithms(
+  collapseNodes
+  ) where
+
+import qualified Data.Graph.Inductive.PatriciaTree as FGR
+import qualified Data.Graph.Inductive.Graph as ING
+import Types(SgNamedNode, Edge, SyntaxNode(..), sgNamedNodeToSyntaxNode)
+import Data.Maybe(listToMaybe)
+
+collapseNodes :: (ING.DynGraph gr) => gr SgNamedNode Edge -> gr SgNamedNode Edge
+collapseNodes initialGraph = ING.ufold folder ING.empty initialGraph where
+  folder context accumGraph = newGraph where
+    newGraph
+      | not (willBeEmbedded context initialGraph) = context ING.& accumGraph
+      | otherwise = accumGraph
+
+-- | True if the node in the context will be embedded in another node
+willBeEmbedded :: (ING.Graph gr) => ING.Context SgNamedNode Edge -> gr SgNamedNode Edge-> Bool
+willBeEmbedded context gr = currentNodeEmbeddable && parentCanEmbed where
+  currentNode = ING.labNode' context
+  currentNodeEmbeddable = nodeIsEmbeddable (extractSyntaxNode currentNode)
+  parentCanEmbed = maybeBoolToBool $ fmap (nodeCanEmbed . sgNamedNodeToSyntaxNode) (nodesParent gr context)
+
+-- | (Just True) = True, Nothing = False
+maybeBoolToBool :: Maybe Bool -> Bool
+maybeBoolToBool = or
+
+-- TODO make this work with pattern apply also
+nodesParent :: (ING.Graph gr) => gr a b -> ING.Context a b -> Maybe a
+nodesParent gr context =  listToMaybe (ING.pre' context) >>= ING.lab gr
+
+-- | A nodeIsEmbeddable if it can be collapsed into another node
+nodeIsEmbeddable :: SyntaxNode -> Bool
+nodeIsEmbeddable n = case n of
+  ApplyNode _ -> True
+  PatternApplyNode _ _ -> True
+  NameNode _ -> True
+  LiteralNode _ -> True
+  FunctionDefNode _ -> False
+  GuardNode _ -> False
+  CaseNode _ -> False
+  BranchNode -> False
+  CaseResultNode -> False
+  -- Don't use a catch all (i.e. irrefutable) pattern here so that if other
+  -- SyntaxNodes are added we will get a warning here.
+
+-- | A nodeCanEmbed if it can contain other nodes
+nodeCanEmbed :: SyntaxNode -> Bool
+nodeCanEmbed n = case n of
+  ApplyNode _ -> True
+  PatternApplyNode _ _ -> True
+  NameNode _ -> False
+  LiteralNode _ -> False
+  FunctionDefNode _ -> False
+  GuardNode _ -> False
+  CaseNode _ -> False
+  BranchNode -> False
+  CaseResultNode -> False
+  -- Don't use a catch all (i.e. irrefutable) pattern here so that if other
+  -- SyntaxNodes are added we will get a warning here.
+
+extractSyntaxNode :: ING.LNode SgNamedNode -> SyntaxNode
+extractSyntaxNode = snd . snd

glance.cabal

@@ -37,7 +37,7 @@ executable glance-exe
                      , mtl
                      , semigroups
   default-language:    Haskell2010
-  Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors
+  Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors, GraphAlgorithms
 
 test-suite glance-test
   type:                exitcode-stdio-1.0
@@ -59,7 +59,7 @@ test-suite glance-test
                      , semigroups
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
-  Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors
+  Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors, GraphAlgorithms
 
 
 source-repository head

graph_algs.txt

@@ -0,0 +1,29 @@
+-- Pseudocode for collapsing a syntax graph.
+
+-- To make the problem simpler, collapseNodes just cares about the
+collapseNodes :: SyntaxGraph -> SyntaxGraph
+collapseNodes inGraph = graphFold foldFunc initialOutputGraph inGraph where
+  initialOutputGraph = emptyGraph
+
+  foldFunc :: SyntaxGraph -> Context -> SyntaxGraph
+  foldFunc oldGraph context = let node = nodeInContext context in
+    -- The node can not be embedded, and can not embed other nodes, so it is by itself.
+    -- We thus just add it to the accumulator graph.
+    -- willEmbed is true iff the current node will embed other nodes in the graph
+    | not (willBeEmbedded context inGraph) && not (willEmbed context inGraph) = context & oldGraph
+    -- willBeEmbedded checks to see if the parent of the current node will embed the current node
+    -- In this case the current node will be embedded, and does not embed other node.
+    -- We do not add the current node since it will be embedded in its parent.
+    -- This case is not necessary. If the current node were to be added, it would simply be
+    -- removed again from the accumulation graph.
+    | willBeEmbedded context inGraph && not (willEmbed context) = oldGraph
+    -- This node will embed other nodes.
+    -- First we find our children that will be embedded. If the child is in the
+    -- oldGraph, then we also need to remove the child from the oldGraph.
+    -- If the child is not yet in the oldGraph, then we just embed it.
+    | willEmbed context inGraph =
+      newGraph where
+        (oldGraphChildren, oldGraphWithChildrenRemoved) = findAndRemoveChildren oldGraph context
+        remainingChildrem = getRemainingChildren oldGraphChildren inGraph context
+        embeddedNode = makeEmbeddedNode context oldGraphChildren remainingChildren
+        newGarph = embeddedNode & oldGraphWithChildrenRemoved

test/AllTests.hs

@@ -3,15 +3,20 @@ import Diagrams.Prelude hiding ((#), (&))
 import Diagrams.Backend.SVG.CmdLine
 import Diagrams.Backend.SVG (renderSVG)
 import Diagrams.TwoD.GraphViz as DiaGV
+import qualified Data.GraphViz as GV
 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 Icons(textBox, colorScheme, ColorStyle(..), coloredTextBox)
 import Rendering(renderDrawing)
 import Util(toNames, portToPort, iconToPort, iconToIcon,
   iconToIconEnds, iconTailToPort)
-import Types(Icon(..), Drawing(..), EdgeEnd(..))
+import Types(Icon(..), Drawing(..), EdgeEnd(..), SgNamedNode, Edge)
 import Translate(translateString, stringToSyntaxGraph)
 import TranslateCore(syntaxGraphToFglGraph)
+import GraphAlgorithms(collapseNodes)
 
 (d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
 d0Icons = toNames
@@ -399,6 +404,7 @@ translateTests = do
     vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
   pure vCattedDrawings
 
+-- TODO Remove graphTests
 graphTests :: IO (Diagram B)
 graphTests = do
   layedOutGraph <- DiaGV.layoutGraph GVA.Neato fglGraph
@@ -411,12 +417,59 @@ graphTests = do
     nodeFunc (name, syntaxNode) =
       place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
 
+-- TODO Refactor with doGraphLayout in Rendering.hs
+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)
+    layedOutGraph
+  where
+    nodeFunc (name, syntaxNode) =
+      place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
+    layoutParams :: GV.GraphvizParams Int v e () v
+    layoutParams = GV.defaultParams{
+    GV.globalAttributes = [
+      GV.NodeAttrs [GVA.Shape GVA.BoxShape]
+      --GV.NodeAttrs [GVA.Shape GVA.Circle]
+      , GV.GraphAttrs
+        [
+        --GVA.Overlap GVA.KeepOverlaps,
+        --GVA.Overlap GVA.ScaleOverlaps,
+        GVA.Overlap $ GVA.PrismOverlap (Just 5000),
+        GVA.Splines GVA.LineEdges,
+        GVA.OverlapScaling 8,
+        --GVA.OverlapScaling 4,
+        GVA.OverlapShrink True
+        ]
+      ],
+    GV.fmtEdge = const [GV.arrowTo GV.noArrow],
+    GV.fmtNode = nodeAttribute
+    }
+    nodeAttribute :: (Int, l) -> [GV.Attribute]
+    nodeAttribute (nodeInt, _) =
+      -- GVA.Width and GVA.Height have a minimum of 0.01
+      --[GVA.Width diaWidth, GVA.Height diaHeight]
+      [GVA.Width 0.01, GVA.Height 0.01]
+
+-- TODO Make this work for many input strings
+collapseTests :: IO (Diagram B)
+collapseTests = do
+  --DiaGV.simpleGraphDiagram GVA.Neato fglGraph
+  before <- renderFglGraph fglGraph
+  after <- renderFglGraph collapsedGraph
+  pure (before === after)
+  where
+    fglGraph = syntaxGraphToFglGraph $ stringToSyntaxGraph "y = f x"
+    collapsedGraph = collapseNodes fglGraph
 
 drawingsAndNames :: [(String, IO (Diagram B))]
 drawingsAndNames = [
   ("translate-tests", translateTests),
   ("render-tests", renderTests),
-  ("graph-tests", graphTests)
+  ("graph-tests", graphTests),
+  ("collapse-tests", collapseTests)
   ]
 
 renderDrawings :: [(String, IO (Diagram B))] -> IO ()
@@ -426,5 +479,17 @@ renderDrawings = mapM_ saveDrawing where
     -- TODO Replace string concatenation with proper path manipulation functions.
     renderSVG ("test/test-output/" ++ name ++ ".svg") (mkWidth 700) (bgFrame 1 (backgroundC colorScheme) dia)
 
+-- TODO Clean up this function
+testCollapse :: IO ()
+testCollapse = do
+  let
+    fglIn = syntaxGraphToFglGraph $ stringToSyntaxGraph "y = f x"
+    fglOut = collapseNodes fglIn
+  putStrLn "fglIn:"
+  ING.prettyPrint fglIn
+  putStrLn "\nfglOut:"
+  ING.prettyPrint fglOut
+
 main :: IO ()
 main = renderDrawings drawingsAndNames
+--main = testCollapse