Improve formatting of GraphAlgorithms.hs and Types.hs.

This commit is contained in:
Robbie Gleichman 2018-11-12 00:21:50 -08:00
parent 9e7d01ab82
commit 9380cb6ea2
2 changed files with 127 additions and 62 deletions

View File

@ -20,12 +20,14 @@ import Util(maybeBoolToBool, sgNamedNodeToSyntaxNode)
-- See graph_algs.txt for pseudocode
data ParentType = ApplyParent | CaseParent | GuardParent | NotAParent deriving (Eq, Show)
data ParentType = ApplyParent | CaseParent | GuardParent | NotAParent
deriving (Eq, Show)
data DirectionalEdge a = ParentToChild a | ChildToParent a deriving (Eq, Show)
-- START HELPER functions --
-- TODO Replace with records.
unwrapDirectionalEdge :: DirectionalEdge a -> a
unwrapDirectionalEdge d = case d of
ParentToChild e -> e
@ -74,7 +76,8 @@ findNeighbors :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> [ING.Node]
findNeighbors graph node = filter parentFilter $ ING.neighbors graph node where
parentFilter parentNode = parentNode /= node
findParentsWithEdges :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
findParentsWithEdges :: ING.Graph gr =>
IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
findParentsWithEdges graph node = filter parentFilter adjacencies where
parentFilter (_, parentNode) = parentNode /= node
(incomingEdges, _, _, outgoingEdges) = ING.context graph node
@ -82,16 +85,19 @@ findParentsWithEdges graph node = filter parentFilter adjacencies where
mappedOutgoingEdges = fmap (Arrow.first ChildToParent) outgoingEdges
adjacencies = mappedIncomingEdges ++ mappedOutgoingEdges
-- | graphNodeCanEmbed returns true if the label (SyntaxNode) associated with the
-- node can be embedded in other SyntaxNodes (i.e. nodeCanEmbed is True)
-- | graphNodeCanEmbed returns true if the label (SyntaxNode) associated with
-- the node can be embedded in other SyntaxNodes (i.e. nodeCanEmbed is True)
graphNodeCanEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Bool
graphNodeCanEmbed graph node = maybeBoolToBool $ fmap syntaxNodeCanEmbed (lookupSyntaxNode graph node)
graphNodeCanEmbed graph node
= maybeBoolToBool $ fmap syntaxNodeCanEmbed (lookupSyntaxNode graph node)
lookupSyntaxNode :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
lookupSyntaxNode :: ING.Graph gr =>
IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
lookupSyntaxNode gr node = sgNamedNodeToSyntaxNode <$> ING.lab gr node
lookupParentType :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ParentType
lookupParentType graph node = fromMaybe NotAParent $ parentTypeForNode <$> lookupSyntaxNode graph node
lookupParentType graph node
= fromMaybe NotAParent $ parentTypeForNode <$> lookupSyntaxNode graph node
-- | filterNodes returns a list of the nodes in the graph
-- where the filter function is true.
@ -101,7 +107,8 @@ filterNodes condition gr = ING.nodes $ ING.nfilter condition gr
-- | Replace the a node's label
changeNodeLabel :: ING.DynGraph gr => gr a b -> ING.Node -> a -> gr a b
changeNodeLabel graph node newLabel = case ING.match node graph of
(Just (inEdges, _, _, outEdges), restOfTheGraph) -> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph
(Just (inEdges, _, _, outEdges), restOfTheGraph)
-> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph
(Nothing, _) -> graph
findEdgeLabel :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
@ -109,20 +116,29 @@ findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
labelledEdges = ING.lneighbors graph node1
matchingEdges = find ((== node2) . snd) labelledEdges
parentCanEmbedChild :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ING.Node -> DirectionalEdge Edge -> Bool
parentCanEmbedChild graph parent child directionalEdge = case lookupSyntaxNode graph child of
Nothing -> False
Just childSyntaxNode -> syntaxNodeIsEmbeddable parentType childSyntaxNode parentPort where
parentType = lookupParentType graph parent
parentPort = case directionalEdge of
ParentToChild edge -> port where
(NameAndPort _ port, _) = edgeConnection edge
ChildToParent edge -> port where
(_, NameAndPort _ port) = edgeConnection edge
parentCanEmbedChild :: ING.Graph gr =>
IngSyntaxGraph gr -> ING.Node -> ING.Node -> DirectionalEdge Edge -> Bool
parentCanEmbedChild graph parent child directionalEdge
= case lookupSyntaxNode graph child of
Nothing -> False
Just childSyntaxNode
-> syntaxNodeIsEmbeddable parentType childSyntaxNode parentPort
where
parentType = lookupParentType graph parent
parentPort = case directionalEdge of
ParentToChild edge -> port where
(NameAndPort _ port, _) = edgeConnection edge
ChildToParent edge -> port where
(_, NameAndPort _ port) = edgeConnection edge
findParentsThatCanEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
findParentsThatCanEmbed graph child = filter parentFilter (findParentsWithEdges graph child) where
parentFilter (directionalEdge, parentNode) = graphNodeCanEmbed graph parentNode && parentCanEmbedChild graph parentNode child directionalEdge
findParentsThatCanEmbed :: ING.Graph gr =>
IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
findParentsThatCanEmbed graph child
= filter parentFilter (findParentsWithEdges graph child)
where
parentFilter (directionalEdge, parentNode)
= graphNodeCanEmbed graph parentNode
&& parentCanEmbedChild graph parentNode child directionalEdge
-- | Finds the first edge from the first node to the second node
findEdge :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
@ -131,17 +147,23 @@ findEdge graph fromNode toNode = lookup toNode $ ING.lsuc graph fromNode
edgeIsSingular :: ING.Graph gr => gr a Edge -> ING.Node -> Edge -> Bool
edgeIsSingular graph node edge = numEdges == 1 where
(childNamePort, _) = edgeConnection edge
edgeLabels = filter (childNamePort ==) $ (fst . edgeConnection . snd) <$> ING.lsuc graph node
edgeLabels = filter
(childNamePort ==)
((fst . edgeConnection . snd) <$> ING.lsuc graph node)
numEdges = length edgeLabels
parentIsOnlyEdge :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ING.Node -> Bool
parentIsOnlyEdge :: ING.Graph gr =>
IngSyntaxGraph gr -> ING.Node -> ING.Node -> Bool
parentIsOnlyEdge graph parent child = case findEdge graph child parent of
Just edge -> edgeIsSingular graph child edge
Nothing -> case findEdge graph parent child of
Just edge -> edgeIsSingular graph parent edge
Nothing -> error "parentIsOnlyEdge: There is no edge from the child to the parent."
findParentThatWillEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Maybe (DirectionalEdge Edge, ING.Node)
Nothing
-> error
"parentIsOnlyEdge: There is no edge from the child to the parent."
findParentThatWillEmbed :: ING.Graph gr =>
IngSyntaxGraph gr -> ING.Node -> Maybe (DirectionalEdge Edge, ING.Node)
findParentThatWillEmbed graph child =
case findParentsThatCanEmbed graph child of
[parent] -> if parentIsOnlyEdge graph (snd parent) child
@ -153,7 +175,8 @@ findParentThatWillEmbed graph child =
collapseNodes :: (ING.DynGraph gr) => IngSyntaxGraph gr -> IngSyntaxGraph gr
collapseNodes originalGraph = finalGraph where
-- findTreeRoots returns a list of nodes that will embed other nodes, but are not embedded themselves.
-- findTreeRoots returns a list of nodes that will embed other nodes, but are
-- not embedded themselves.
-- These nodes are thus each a root of a collapsed node tree.
treeRoots = findTreeRoots originalGraph
-- Now collapse each tree of nodes
@ -161,15 +184,18 @@ collapseNodes originalGraph = finalGraph where
-- START findTreeRoots functions --
-- |findTreeRoots returns a list of nodes that might embed other nodes, but are not embedded themselves.
-- | findTreeRoots returns a list of nodes that might embed other nodes, but are
-- not embedded themselves.
-- 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 will not be embedded.
-- Note: A treeRoot may not actually have any embeddable children, since collapseTree will do nothing in that case.
-- Note: A treeRoot may not actually have any embeddable children, since
-- collapseTree will do nothing in that case.
findTreeRoots :: ING.DynGraph gr => IngSyntaxGraph gr -> [ING.Node]
findTreeRoots graph = filterNodes isTreeRoot graph where
isTreeRoot node = graphNodeCanEmbed graph node && not (nodeWillBeEmbedded graph node)
isTreeRoot node
= graphNodeCanEmbed graph node && not (nodeWillBeEmbedded graph node)
nodeWillBeEmbedded :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Bool
nodeWillBeEmbedded graph node = isJust $ findParentThatWillEmbed graph node
@ -177,43 +203,66 @@ nodeWillBeEmbedded graph node = isJust $ findParentThatWillEmbed graph node
-- END findTreeRoots functions
-- START collapseRoots functions
collapseRoots :: ING.DynGraph gr => IngSyntaxGraph gr -> IngSyntaxGraph gr -> [ING.Node] -> IngSyntaxGraph gr
collapseRoots :: ING.DynGraph gr =>
IngSyntaxGraph gr -> IngSyntaxGraph gr -> [ING.Node] -> IngSyntaxGraph gr
collapseRoots originalGraph = foldl' (collapseTree originalGraph)
collapseTree :: ING.DynGraph gr => IngSyntaxGraph gr -> IngSyntaxGraph gr -> ING.Node -> IngSyntaxGraph gr
collapseTree :: ING.DynGraph gr =>
IngSyntaxGraph gr -> IngSyntaxGraph gr -> ING.Node -> IngSyntaxGraph gr
collapseTree originalGraph oldGraph rootNode = case childrenToEmbed of
[] -> oldGraph
_ -> finalGraph
where
-- Need to use the original graph for finding children, otherwise a node can be embedded when it is used twice in
-- what will be a single embedding node. Examples:
-- Need to use the original graph for finding children, otherwise a node can
-- be embedded when it is used twice in what will be a single embedding
-- node.
-- Examples:
-- "y = foo (3 + bazOf2) bazOf2 where bazOf2 = baz 2",
-- "y = foo (3 + bazOf2) (8 * bazOf2) where bazOf2 = baz 2"
childrenToEmbedWithEdges = findChildrenToEmbed rootNode originalGraph
childrenToEmbed = fmap snd childrenToEmbedWithEdges
-- Recursively collapse the children nodes
graphWithCollapsedChildren = collapseRoots originalGraph oldGraph childrenToEmbed
-- Modify the rootNode label (i.e. SyntaxNode) to incorporate the children it is embedding
graphWithEmbeddedChildren = embedChildSyntaxNodes rootNode childrenToEmbed graphWithCollapsedChildren
-- Transfer the edges of the children to rootNode
childEdgesToTransfer = findChildEdgesToTransfer rootNode childrenToEmbedWithEdges graphWithEmbeddedChildren
graphWithEdgesTransferred = ING.insEdges childEdgesToTransfer graphWithEmbeddedChildren
-- Delete the children that have been embedded (and any or their remaining edges)
graphWithCollapsedChildren
= collapseRoots originalGraph oldGraph childrenToEmbed
-- Modify the rootNode label (i.e. SyntaxNode) to incorporate the children
-- it is embedding.
graphWithEmbeddedChildren = embedChildSyntaxNodes
rootNode
childrenToEmbed
graphWithCollapsedChildren
-- Transfer the edges of the children to rootNode.
childEdgesToTransfer = findChildEdgesToTransfer
rootNode
childrenToEmbedWithEdges
graphWithEmbeddedChildren
graphWithEdgesTransferred
= ING.insEdges childEdgesToTransfer graphWithEmbeddedChildren
-- Delete the children that have been embedded (and any or their remaining
-- edges).
finalGraph = deleteChildren childrenToEmbed graphWithEdgesTransferred
-- | findChildrenToEmbed returns a list of the node's children that can be embedded
-- | findChildrenToEmbed returns a list of the node's children that can be
-- embedded.
-- A child can be embedded iff all of these conditions are true:
-- 1. The node is not a treeRoot (otherwise a cycle of embedding could occur)
-- 2. The SyntaxNode is embeddable (i.e. syntaxNodeIsEmbeddable is True)
-- 3. The node has exactly one parent that can embed (i.e. nodeCanEmbed is True for one parent)
findChildrenToEmbed :: ING.Graph gr => ING.Node -> IngSyntaxGraph gr -> ING.Adj (DirectionalEdge Edge)-- [ING.Node]
-- 1. The node is not a treeRoot (otherwise a cycle of embedding could occur).
-- 2. The SyntaxNode is embeddable (i.e. syntaxNodeIsEmbeddable is True).
-- 3. The node has exactly one parent that can embed (i.e. nodeCanEmbed is True
-- for one parent).
findChildrenToEmbed :: ING.Graph gr =>
ING.Node -> IngSyntaxGraph gr -> ING.Adj (DirectionalEdge Edge)
findChildrenToEmbed node graph = if graphNodeCanEmbed graph node
then childrenToEmbed
else []
where
childrenToEmbed = catMaybes $ fmap (childCanBeEmbedded node graph) (findNeighbors graph node)
childrenToEmbed =
catMaybes
$ fmap (childCanBeEmbedded node graph) (findNeighbors graph node)
childCanBeEmbedded :: ING.Graph gr => ING.Node -> IngSyntaxGraph gr -> ING.Node -> Maybe (DirectionalEdge Edge, ING.Node)
childCanBeEmbedded :: ING.Graph gr =>
ING.Node
-> IngSyntaxGraph gr
-> ING.Node
-> Maybe (DirectionalEdge Edge, ING.Node)
childCanBeEmbedded parentNode graph child = case
findParentThatWillEmbed graph child of
Nothing -> Nothing
@ -226,9 +275,14 @@ edgesNotEqual dirEdge (_, _, e) = e /= unwrapDirectionalEdge dirEdge
findChildEdgesToTransfer :: (Eq b, ING.Graph gr) =>
ING.Node -> ING.Adj (DirectionalEdge b) -> gr a b-> [ING.LEdge b]
findChildEdgesToTransfer parentNode childrenToEmbed graph = concatMap makeLabelledGraphEdges childrenToEmbed where
makeLabelledGraphEdges (directionalParentToChildEdge, childNode) = changeEdgeToParent parentNode childNode <$>
filter (edgesNotEqual directionalParentToChildEdge) (ING.inn graph childNode ++ ING.out graph childNode)
findChildEdgesToTransfer parentNode childrenToEmbed graph
= concatMap makeLabelledGraphEdges childrenToEmbed
where
makeLabelledGraphEdges (directionalParentToChildEdge, childNode)
= changeEdgeToParent parentNode childNode
<$> filter
(edgesNotEqual directionalParentToChildEdge)
(ING.inn graph childNode ++ ING.out graph childNode)
changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
changeEdgeToParent parentNode childNode lEdge@(fromNode, toNode, edgeLabel)
@ -237,7 +291,8 @@ changeEdgeToParent parentNode childNode lEdge@(fromNode, toNode, edgeLabel)
| otherwise = lEdge
-- | Change the node label of the parent to be nested.
embedChildSyntaxNodes :: ING.DynGraph gr => ING.Node -> [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
embedChildSyntaxNodes :: ING.DynGraph gr =>
ING.Node -> [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
[] -> oldGraph
_ -> newGraph
@ -250,16 +305,21 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
SgNamedNode nodeName oldSyntaxNode = oldNodeLabel
newNodeLabel = SgNamedNode nodeName newSyntaxNode
newSyntaxNode = case oldSyntaxNode of
LikeApplyNode flavor x -> NestedApplyNode flavor x childrenAndEdgesToParent
CaseNode x -> NestedCaseOrGuardNode CaseTag x childrenAndEdgesToParent
GuardNode x -> NestedCaseOrGuardNode GuardTag x childrenAndEdgesToParent
LikeApplyNode flavor x
-> NestedApplyNode flavor x childrenAndEdgesToParent
CaseNode x
-> NestedCaseOrGuardNode CaseTag x childrenAndEdgesToParent
GuardNode x
-> NestedCaseOrGuardNode GuardTag x childrenAndEdgesToParent
_ -> oldSyntaxNode
childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
findChildAndEdge childNode =
(,) <$> ING.lab oldGraph childNode <*> findEdgeLabel oldGraph parentNode childNode
(,) <$> ING.lab oldGraph childNode
<*> findEdgeLabel oldGraph parentNode childNode
deleteChildren :: ING.Graph gr => [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
deleteChildren :: ING.Graph gr =>
[ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
deleteChildren = ING.delNodes
-- END collapseRoots functions

View File

@ -81,7 +81,8 @@ data SgNamedNode = SgNamedNode {
-- TODO remove Ints from SyntaxNode data constructors.
data SyntaxNode =
LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition
-- Function application, composition, and applying to a composition
LikeApplyNode LikeApplyFlavor Int
-- NestedApplyNode is only created in GraphAlgorithms, not during translation.
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
| NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)]
@ -112,20 +113,24 @@ data EdgeEnd = EndNone deriving (Show, Eq, Ord)
-- | An Edge has an name of the source icon, and its optional port number,
-- and the name of the destination icon, and its optional port number.
data Edge = Edge {edgeOptions::[EdgeOption], edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
data Edge = Edge { edgeOptions :: [EdgeOption]
, edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
deriving (Show, Eq, Ord)
-- | A drawing is a map from names to Icons, a list of edges,
-- and a map of names to subDrawings
data Drawing = Drawing [NamedIcon] [Edge] deriving (Show, Eq)
-- | IDState is an Abstract Data Type that is used as a state whose value is a unique id.
-- | IDState is an Abstract Data Type that is used as a state whose value is a
-- unique id.
newtype IDState = IDState Int deriving (Eq, Show)
type SpecialNum n = (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n)
type SpecialNum n
= (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n)
-- Note that SpecialBackend is a constraint synonym, not a type synonym.
type SpecialBackend b n = (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b)
type SpecialBackend b n
= (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b)
type SpecialQDiagram b n = QDiagram b V2 n Any