mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Initial work for collapseNodes using graphs.
This commit is contained in:
parent
971a8ee50b
commit
7ceb5977e4
63
app/GraphAlgorithms.hs
Normal file
63
app/GraphAlgorithms.hs
Normal file
@ -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
|
@ -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
|
||||
|
29
graph_algs.txt
Normal file
29
graph_algs.txt
Normal file
@ -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
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user