Case and guard icons can now embed literals.

2024-08-17 10:50:24 +03:00 · 2016-12-19 20:27:31 -08:00 · 2016-12-19 20:27:31 -08:00 · 9523dcd609
commit 9523dcd609
parent 0185257444
9 changed files with 129 additions and 28 deletions
--- a/app/GraphAlgorithms.hs
+++ b/app/GraphAlgorithms.hs
@ -11,13 +11,14 @@ import Data.List(foldl', find)
 import Data.Maybe(catMaybes, isJust, fromMaybe)
 --import qualified Debug.Trace

-import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..))
+import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..),
+            CaseOrGuardTag(..))
 import Util(maybeBoolToBool)
 --import Util(printSelf)

 -- See graph_algs.txt for pseudocode

-data ParentType = ApplyParent | NotAParent
+data ParentType = ApplyParent | CaseOrGuardParent | NotAParent deriving (Eq, Show)

 -- START HELPER functions --

@ -26,19 +27,20 @@ syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Bool
 syntaxNodeIsEmbeddable parentType n = case (parentType, n) of
  (ApplyParent, LikeApplyNode _ _) -> True 
  (ApplyParent, LiteralNode _) -> True
+  (CaseOrGuardParent, LiteralNode _) -> True
  _ -> False

 -- | A syntaxNodeCanEmbed if it can contain other nodes
 syntaxNodeCanEmbed :: SyntaxNode -> Bool
-syntaxNodeCanEmbed n = case n of
-  LikeApplyNode _ _ -> True
-  NestedApplyNode _ _ _ -> True -- This case should not happen
-  _ -> False
+syntaxNodeCanEmbed = (NotAParent /=) . parentTypeForNode

 parentTypeForNode :: SyntaxNode -> ParentType
 parentTypeForNode n = case n of
  LikeApplyNode _ _ -> ApplyParent
  NestedApplyNode _ _ _ -> ApplyParent
+  CaseNode _ -> CaseOrGuardParent
+  GuardNode _ -> CaseOrGuardParent
+  NestedCaseOrGuardNode _ _ _ -> CaseOrGuardParent
  -- The NotAParent case should never occur.
  _ -> NotAParent

@ -205,6 +207,8 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
          newNodeLabel = (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
            _ -> oldSyntaxNode
    childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
    findChildAndEdge childNode =
--- a/app/Icons.hs
+++ b/app/Icons.hs
@ -25,6 +25,7 @@ import Diagrams.Prelude hiding ((&), (#), Name)

 import Data.List(find)
 import Data.Maybe(catMaybes, listToMaybe)
+import Data.Either(partitionEithers)

 -- import Diagrams.Backend.SVG(B)
 --import Diagrams.TwoD.Text(Text)
@ -54,6 +55,8 @@ iconToDiagram CaseResultIcon = identDiaFunc caseResult
 iconToDiagram (FlatLambdaIcon n) = identDiaFunc $ flatLambda n
 iconToDiagram (NestedApply flavor args) = nestedApplyDia flavor args
 iconToDiagram (NestedPApp args) = nestedPAppDia args
+iconToDiagram (NestedCaseIcon args) = nestedCaseDia args
+iconToDiagram (NestedGuardIcon args) = nestedGuardDia args

 applyPortAngles :: Floating n => Port -> [Angle n]
 applyPortAngles (Port x) = fmap (@@ turn) $ case x of
@ -107,6 +110,8 @@ getPortAngles icon port maybeNodeName = case icon of
  FlatLambdaIcon _ -> applyPortAngles port
  NestedApply _ args -> nestedApplyPortAngles args port maybeNodeName
  NestedPApp args -> nestedApplyPortAngles args port maybeNodeName
+  NestedCaseIcon _ -> guardPortAngles port
+  NestedGuardIcon _ -> guardPortAngles port

 -- END FUNCTIONS --

@ -208,6 +213,9 @@ nestedPAppDia :: SpecialBackend b n =>
  [Maybe (NodeName, Icon)] -> TransformableDia b n
 nestedPAppDia = generalNestedDia apply0Triangle (repeat $ patternC colorScheme)

+makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
+makeQualifiedPort n x = n .>> makePort x
+
 generalNestedDia :: SpecialBackend b n =>
  (Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
 generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
@ -215,7 +223,7 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
  (maybeFunText:args) -> centerXY $  transformedText ||| centerY finalDia
    where
      borderCol = borderCols !! nestingLevel
-      makeQualifiedPort x = name .>> makePort x
+
      transformedText = case maybeFunText of
        Just _ -> makeInnerIcon True 0 maybeFunText
        Nothing -> mempty
@ -224,14 +232,14 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
      trianglePortsCircle = hsep seperation $
        reflectX (dia borderCol) :
        zipWith (makeInnerIcon False) [2,3..] args ++
-        [makeQualifiedPort (Port 1) <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
+        [makeQualifiedPort name (Port 1) <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
  
-      allPorts = makeQualifiedPort (Port 0) <> alignL trianglePortsCircle
+      allPorts = makeQualifiedPort name (Port 0) <> alignL trianglePortsCircle
      topAndBottomLineWidth = width allPorts - circleRadius
      argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeperation) (circleRadius * 0.5)
      finalDia = argBox <> allPorts

-      makeInnerIcon _ portNum Nothing = makeQualifiedPort (Port portNum) <> portCircle
+      makeInnerIcon _ portNum Nothing = makeQualifiedPort name (Port portNum) <> portCircle
      makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
      makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
        innerLevel = if func then nestingLevel else nestingLevel + 1
@ -322,16 +330,16 @@ guardSize :: (Fractional a) => a
 guardSize = 0.7

 guardTriangle :: SpecialBackend b n =>
-  Int -> SpecialQDiagram b n
-guardTriangle x =
-  alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> makePort (Port x)
+  SpecialQDiagram b n -> SpecialQDiagram b n
+guardTriangle portDia =
+  alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> portDia
  where
    triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
      polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)

 guardLBracket :: SpecialBackend b n =>
-  Int -> SpecialQDiagram b n
-guardLBracket x = alignL (alignT ell) <> makePort (Port x)
+  SpecialQDiagram b n -> SpecialQDiagram b n
+guardLBracket portDia = alignL (alignT ell) <> portDia
  where
    ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
    ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
@ -342,12 +350,12 @@ guardLBracket x = alignL (alignT ell) <> makePort (Port x)
 -- odds -> left
 -- evens -> right
 generalGuardIcon :: SpecialBackend b n =>
-  Colour Double -> (Int -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
+  Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
 generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort (Port 1)) <> alignB (bigVerticalLine <> guardDia <> makePort (Port 0))
  where
    --guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
-    trianglesWithPorts = map guardTriangle [2,4..]
-    lBrackets = map lBracket [3, 5..]
+    trianglesWithPorts = map (guardTriangle . makePort . Port) [2,4..]
+    lBrackets = map (lBracket . makePort . Port) [3, 5..]
    trianglesAndBrackets =
      zipWith zipper trianglesWithPorts lBrackets
    zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
@ -356,6 +364,41 @@ generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomD
    guardDia = vcat (alignT $ take n trianglesAndBrackets)
    bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)

+generalNestedGuard :: SpecialBackend b n =>
+  Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> [Maybe (NodeName, Icon)] -> TransformableDia b n
+generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLevel reflect angle = named name $ case inputAndArgs of
+  [] -> mempty
+  (input : args) -> centerXY finalDia where
+    finalDia = alignT (bottomDia <> makeQualifiedPort name (Port 1)) <> alignB (inputIcon === (bigVerticalLine <> guardDia <> makeQualifiedPort name (Port 0)))
+
+    argPortNums = [2..]
+    innerIcons = fmap makeInnerIcon args
+
+    iconMapper portNum innerIcon
+      | even portNum = Right $ guardTriangle port ||| innerIcon
+      | otherwise = Left $ innerIcon ||| lBracket port
+      where
+        port = (makeQualifiedPort name (Port portNum))
+
+    -- TODO argPortNums is duplicated
+    (lBrackets, trianglesWithPorts) = partitionEithers $ zipWith iconMapper argPortNums innerIcons
+
+    trianglesAndBrackets =
+      zipWith zipper trianglesWithPorts lBrackets
+
+    zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
+      where
+        verticalLine = strutY 0.4
+
+    inputIcon = makeInnerIcon input
+    
+    guardDia = vcat (alignT $ trianglesAndBrackets)
+    bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
+
+    makeInnerIcon mNameAndIcon = case mNameAndIcon of
+      Nothing -> mempty
+      Just (iconNodeName, icon) -> iconToDiagram icon iconNodeName nestingLevel reflect angle
+
 -- | The ports of the guard icon are as follows:
 -- Port 0: Top result port
 -- Port 1: Bottom result port
@ -365,6 +408,9 @@ guardIcon :: SpecialBackend b n =>
  Int -> SpecialQDiagram b n
 guardIcon = generalGuardIcon lineCol guardLBracket mempty

+nestedGuardDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
+nestedGuardDia = generalNestedGuard lineCol guardLBracket mempty
+
 -- TODO Improve design to be more than a circle.
 caseResult :: SpecialBackend b n =>
  SpecialQDiagram b n
@ -373,8 +419,8 @@ caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.
    caseCColor = caseRhsC colorScheme

 caseC :: SpecialBackend b n =>
-  Int -> SpecialQDiagram b n
-caseC n = caseResult <> makePort (Port n)
+  SpecialQDiagram b n -> SpecialQDiagram b n
+caseC portDia = caseResult <> portDia


 -- | The ports of the case icon are as follows:
@ -386,6 +432,9 @@ caseIcon :: SpecialBackend b n =>
  Int -> SpecialQDiagram b n
 caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult

+nestedCaseDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
+nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
+
 -- | The ports of flatLambdaIcon are:
 -- 0: Result icon
 -- 1: The lambda function value
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -92,7 +92,7 @@ getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort
    edgeColors = edgeListC colorScheme
    numEdgeColors = length edgeColors
    hashedColor = edgeColors !! namePortHash
-    namePortHash = mod (nodeNum + (503 * portNum)) numEdgeColors
+    namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors
    Port portNum = fromMaybe (Port 0) mPort

    ap1ArgTexture = solid (backgroundC colorScheme)
--- a/app/Translate.hs
+++ b/app/Translate.hs
@ -274,7 +274,7 @@ evalIf c e1 e2 e3 = do
    combinedGraph =
      combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName . Port) [3, 2, 4])
    newGraph = syntaxGraphFromNodes icons <> combinedGraph
-  pure (newGraph, nameAndPort guardName (Port 0))
+  pure (newGraph, nameAndPort guardName (Port 1))

 evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef
 evalStmt c (Qualifier e) = evalExp c e
--- a/app/TranslateCore.hs
+++ b/app/TranslateCore.hs
@ -34,7 +34,7 @@ import Data.Semigroup(Semigroup, (<>))

 import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
  NameAndPort(..), IDState, getId, SgNamedNode, NodeName(..), Port(..), nodeNameToInt,
-  LikeApplyFlavor(..))
+  LikeApplyFlavor(..), CaseOrGuardTag(..))
 import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool)
 import Icons(Icon(..))

@ -177,6 +177,7 @@ nodeToIcon (FunctionDefNode n) = FlatLambdaIcon n
 nodeToIcon (GuardNode n) = GuardIcon n
 nodeToIcon (CaseNode n) = CaseIcon n
 nodeToIcon CaseResultNode = CaseResultIcon
+nodeToIcon (NestedCaseOrGuardNode tag x edges) = nestedCaseOrGuardNodeToIcon tag x edges

 makeArg :: [(SgNamedNode, Edge)] -> Int -> Maybe (NodeName, Icon)
 makeArg args port = case find (findArg (Port port)) args of
@ -190,6 +191,13 @@ nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList whe
  -- TODO Don't use hardcoded port numbers
  argList = fmap (makeArg args) (0:[2..numArgs + 1])

+nestedCaseOrGuardNodeToIcon :: CaseOrGuardTag -> Int -> [(SgNamedNode, Edge)] -> Icon
+nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
+  CaseTag -> NestedCaseIcon argList
+  GuardTag -> NestedGuardIcon argList
+  where
+    argList = fmap (makeArg args) (0:[2..( 1 + (2 * numArgs))])
+
 nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
 nestedPatternNodeToIcon str children = NestedPApp $
  Just (NodeName (-1), TextBoxIcon str)
--- a/app/Types.hs
+++ b/app/Types.hs
@ -18,6 +18,7 @@ module Types (
  SgNamedNode,
  IngSyntaxGraph,
  LikeApplyFlavor(..),
+  CaseOrGuardTag(..),
  initialIdState,
  getId,
  sgNamedNodeToSyntaxNode,
@ -42,10 +43,14 @@ data Icon = ResultIcon | TextBoxIcon String | GuardIcon Int
  -- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
  | NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
  | NestedPApp [Maybe (NodeName, Icon)]
+  | NestedCaseIcon [Maybe (NodeName, Icon)]
+  | NestedGuardIcon [Maybe (NodeName, Icon)]
  deriving (Show, Eq, Ord)

 data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord)

+data CaseOrGuardTag = CaseTag | GuardTag deriving (Show, Eq, Ord)
+
 -- TODO remove Ints from SyntaxNode data constructors.
 data SyntaxNode =
  LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition
@ -60,6 +65,7 @@ data SyntaxNode =
  | GuardNode Int
  | CaseNode Int
  | CaseResultNode -- TODO remove caseResultNode
+  | NestedCaseOrGuardNode CaseOrGuardTag Int [(SgNamedNode, Edge)]
  deriving (Show, Eq, Ord)

 newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)
--- a/test/VisualRenderingTests.hs
+++ b/test/VisualRenderingTests.hs
@ -187,6 +187,38 @@ nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where
    iconToIntPort t2 n2 2
    ]

+nestedCaseDrawing :: Drawing
+nestedCaseDrawing = Drawing icons [] where
+  [n0, n1, n2, n3, n4, n5, n6, n7, n8, n9] = fmap NodeName [0..9]
+  icons = [
+    (n0, NestedCaseIcon [Nothing, Nothing, Nothing]),
+    (n1, NestedCaseIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
+    (n3, NestedCaseIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
+    (n5, NestedCaseIcon [Nothing,
+                         Just (n6, TextBoxIcon "n6"),
+                         Just (n7, TextBoxIcon "n7"),
+                         Just (n8, TextBoxIcon "n8"),
+                         Just (n9, TextBoxIcon "n9")])
+    ]
+
+nestedGuardDrawing :: Drawing
+nestedGuardDrawing = Drawing icons edges where
+  [n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10] = fmap NodeName [0..10]
+  icons = [
+    (n10, TextBoxIcon "n10"),
+    (n0, NestedGuardIcon [Nothing, Nothing, Nothing]),
+    (n1, NestedGuardIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
+    (n3, NestedGuardIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
+    (n5, NestedGuardIcon [Nothing,
+                          Just (n6, TextBoxIcon "n6"),
+                          Just (n7, TextBoxIcon "n7"),
+                          Just (n8, TextBoxIcon "n8"),
+                          Just (n9, TextBoxIcon "n9")])
+    ]
+  edges = [
+    iconToIntPort n10 n5 0
+    ]
+
 --renderTests :: IO (Diagram B)
 renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
 renderTests = do
@ -200,6 +232,8 @@ renderTests = do
      fact1Drawing,
      fact2Drawing,
      arrowTestDrawing,
-      nestedTextDrawing
+      nestedTextDrawing,
+      nestedCaseDrawing,
+      nestedGuardDrawing
      -- TODO Add a nested test where the function expression is nested.
      ]
--- a/test/VisualTranslateTests.hs
+++ b/test/VisualTranslateTests.hs
@ -209,7 +209,8 @@ otherTests = [
  "y = f x",
  "y = f (g x1 x2) x3",
  "y = (f x1 x2) (g x1 x2)",
-  "y = Foo.bar"
+  "y = Foo.bar",
+  "y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10"
  ]

 testDecls :: [String]
--- a/todo.txt
+++ b/todo.txt
@ -1,6 +1,4 @@
 -- TODO Now --
-Case icon that can embed literals
-
 Consider adding binding variable names to the lambda icon and match icon. Don't display the name if it is only one character.

 -- TODO Later --
@ -15,11 +13,12 @@ Draw bounding boxes for lambdas (use dashed lines)
 -- Make an icon font/library with labeled ports. E.g. the apply icon would have text labels "function", "result", "arg 0", "arg 1", etc.
 -- Don't rotate text and nested icons, give them rectangular bounding boxes in GraphViz. (Perhaps use a typeclass for isRotateAble)
 -- Give lines a black border to make line crossings easier to see.
-- Let lines connect to ports in multiple locations (e.g. guard result)
+-- Let lines connect to ports other than the original source
 -- Use different line styles (e.g. dashed, solid, wavy) in addition to colors
 Use diagrams to shrink the drawing until icons start overlapping.

 -- Translate todos:
+Allow case and guard nodes to embed simple patterns and expressions.

 Fix this test so that the line colors are correct. Consider connecting the t line to the origial rhs (3,4), not the pattern result.
 y = let {t@(_,_) = (3,4)} in t + 3