Lambdas now use a simple icon, not nested Drawings.

app/Icons.hs

@@ -3,6 +3,7 @@ module Icons
     (
     Icon(..),
     apply0NDia,
+    flatLambda,
     iconToDiagram,
     nameDiagram,
     textBox,
@@ -21,7 +22,7 @@ import Diagrams.Prelude
 import Diagrams.TwoD.Text(Text)
 import Data.Typeable(Typeable)
 
-import Types(Icon(..))
+import Types(Icon(..), Edge)
 import Util(fromMaybeError)
 
 -- COLO(U)RS --
@@ -51,14 +52,15 @@ colorOnBlackScheme = ColorStyle {
   apply0C = red,
   apply1C = cyan,
   boolC = orange,
-  lamArgResC = lime,
-  regionPerimC = white,
+  lamArgResC = lightSlightlyPurpleBlue,
+  regionPerimC = lime,
   caseRhsC = slightlyGreenYellow,
   patternC = lightMagenta
 }
   where
     slightlyGreenYellow = sRGB24 212 255 0
     lightMagenta = sRGB24 255 94 255
+    lightSlightlyPurpleBlue = sRGB24 67 38 255
 
 whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
 whiteOnBlackScheme = ColorStyle {
@@ -107,6 +109,7 @@ iconToDiagram (TextBoxIcon s) _ = textBox s
 iconToDiagram (GuardIcon n) _ = guardIcon n
 iconToDiagram (CaseIcon n) _ = caseIcon n
 iconToDiagram CaseResultIcon _ = caseResult
+iconToDiagram (FlatLambdaIcon n) _ = flatLambda n
 iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap =
   lambdaRegion n dia
   where
@@ -121,6 +124,7 @@ nameDiagram name dia = named name (name .>> dia)
 makePort :: (Floating n, Ord n, Semigroup m, Metric v) => Int -> QDiagram b v n m
 makePort x = mempty # named x
 --makePort x = circle 0.2 # fc green # named x
+-- Note, the version of makePort below seems to have a different type.
 --makePort x = textBox (show x) # fc green # named x
 
 
@@ -176,6 +180,8 @@ apply0PortLocations = map p2 [
     triangleWidth = circleRadius * sqrt 3
     lineCenter = circleRadius + (defaultLineWidth / 2.0)
 
+portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
+
 -- apply0N Icon--
 -- | apply0N port locations:
 -- Port 0: Function
@@ -188,7 +194,6 @@ apply0NDia ::
 apply0NDia 1 = apply0Dia
 apply0NDia n = finalDia # centerXY where
   seperation = circleRadius * 1.5
-  portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
   trianglePortsCircle = hcat [
     reflectX apply0Triangle,
     hcat $ take n $ map (\x -> makePort x <> portCircle <> strutX seperation) [2,3..],
@@ -335,3 +340,16 @@ caseIcon ::(RealFloat n,
            Typeable n,
            Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any
 caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
+
+-- | The ports of flatLambdaIcon are:
+-- 0: Optional result icon
+-- 1: The lambda function value
+-- 2,3.. : The parameters
+flatLambda n = finalDia where
+  lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
+  lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++  [makePort 1 <> lambdaCircle])
+  portIcons = take n $ map (\x -> makePort x <> portCircle) [2,3..]
+  middle = alignL (hsep 0.5 lambdaParts)
+  topAndBottomLineWidth = width middle - circleRadius
+  topAndBottomLine = hrule topAndBottomLineWidth # lc (regionPerimC colorScheme) # lwG defaultLineWidth # alignL
+  finalDia = topAndBottomLine <> (alignB $ topAndBottomLine <> (middle # alignT))

app/Main.hs

@@ -5,7 +5,7 @@ import Diagrams.Prelude
 import Diagrams.Backend.SVG.CmdLine
 import qualified Language.Haskell.Exts as Exts
 
-import Icons(apply0NDia, textBox, colorScheme, ColorStyle(..))
+import Icons(apply0NDia, flatLambda, textBox, colorScheme, ColorStyle(..))
 import Rendering(renderDrawing)
 import Util(toNames, portToPort, iconToPort, iconToIcon,
   iconToIconEnds, iconTailToPort)
@@ -14,6 +14,7 @@ import Translate(translateString, drawingsFromModule)
 
 
 -- TODO Now --
+-- Test case x of {0 -> 1; y -> y}, see if the second match forms a loop.
 -- Refactor Translate
 -- Add documentation.
 -- Update readme.
@@ -25,6 +26,8 @@ import Translate(translateString, drawingsFromModule)
 -- Move tests out of main.
 
 -- TODO Later --
+-- Highlight the names of top level declarations.
+-- Use clustered graphs. Make a test project.
 -- Consider making lines between patterns Pattern Color when the line is a reference.
 -- Consider using seperate parameter icons in functions.
 -- Make constructors in patterns PatternColor.
@@ -256,11 +259,11 @@ main1 = do
   placedNodes <- renderDrawing factLam0Drawing
   mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
 
-main2 = mainWith ((apply0NDia 3 # bgFrame 0.1 black)  :: Diagram B)
+main2 = mainWith ((flatLambda 3 # bgFrame 0.1 black)  :: Diagram B)
 
 main3 :: IO ()
 main3 = do
-  renderedDiagrams <- mapM renderDrawing allDrawings
+  renderedDiagrams <- traverse renderDrawing allDrawings
   let vCattedDrawings = vcat' (with & sep .~ 0.5) renderedDiagrams
   mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
   where
@@ -364,6 +367,20 @@ patternTests = [
   ]
 
 lambdaTests = [
+  "y = (\\x -> (\\x -> (\\x -> x) x) x)",
+  "y = (\\x -> (\\x -> (\\x -> x)))",
+  "y = (\\y -> y)",
+  "y = (\\x1 -> (\\x2 -> (\\x3 -> x1 x2 x3)))",
+  "y x = (\\z -> x)",
+  "y = (\\x -> (\\z -> x))",
+  "y x = x",
+  "y x = y x",
+  "y x = g y y",
+  "y f x = f x",
+  "y x = x y",
+  "y x1 x2 = f x1 x3 x2",
+  "y x1 x2 = f x1 x2",
+  "y x = f x1 x2",
   "{y 0 = 1; y 1= 0}",
   "y (-1) = 2",
   "y 1 = 0",
@@ -411,20 +428,6 @@ otherTests = [
   "y x1 x2 x3 = if f x1 then g x2 else h x3",
   "y x1 x2 x3 = if x1 then x2 else x3",
   "y = if b then x else n",
-  "y = (\\x -> (\\x -> (\\x -> x) x) x)",
-  "y = (\\x -> (\\x -> (\\x -> x)))",
-  "y = (\\y -> y)",
-  "y = (\\x1 -> (\\x2 -> (\\x3 -> x1 x2 x3)))",
-  "y x = (\\z -> x)",
-  "y = (\\x -> (\\z -> x))",
-  "y x = x",
-  "y x = y x",
-  "y x = g y y",
-  "y f x = f x",
-  "y x = x y",
-  "y x1 x2 = f x1 x3 x2",
-  "y x1 x2 = f x1 x2",
-  "y x = f x1 x2",
   "y2 = f x1 x2 x3 x4",
   "y = x",
   "y = f x",
@@ -462,7 +465,7 @@ translateStringToDrawing s = do
 
 main4 :: IO ()
 main4 = do
-  drawings <- mapM translateStringToDrawing testDecls
+  drawings <- traverse translateStringToDrawing testDecls
   let
     textDrawings = fmap (alignL . textBox) testDecls
     vCattedDrawings = vcat' (with & sep .~ 1) $ zipWith (===) (fmap alignL drawings) textDrawings
@@ -484,7 +487,7 @@ main5 = do
   print "\n\n"
   --print drawings
 
-  diagrams <- mapM renderDrawing drawings
+  diagrams <- traverse renderDrawing drawings
   let
     vCattedDrawings = vcat' (with & sep .~ 1) $ fmap alignL diagrams
   mainWith ((vCattedDrawings # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)

app/Rendering.hs

@@ -11,6 +11,7 @@ import Diagrams.TwoD.Text(Text)
 
 import qualified Data.GraphViz as GV
 import qualified Data.GraphViz.Attributes.Complete as GVA
+--import qualified Data.GraphViz.Types
 --import Data.GraphViz.Commands
 import qualified Data.Map as Map
 import Data.Maybe(isJust)
@@ -19,6 +20,7 @@ import Data.List(minimumBy)
 import Data.Function(on)
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Typeable(Typeable)
+--import Data.Word(Word16)
 
 import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
 import Types(Edge(..), EdgeOption(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..))
@@ -34,12 +36,13 @@ scaleFactor :: (Fractional a) => a
 scaleFactor = 0.05
 
 -- For Fdp
---scaleFactor = 0.05
+--scaleFactor = 0.09
 
 --scaleFactor = 0.04
 
 drawingToGraphvizScaleFactor :: Double
 drawingToGraphvizScaleFactor = 0.4
+--drawingToGraphvizScaleFactor = 1
 
 -- CONVERTING Edges AND Icons TO DIAGRAMS --
 
@@ -237,11 +240,18 @@ doGraphLayout graph nameDiagramMap edges = do
   return $ placeNodes layoutResult nameDiagramMap edges
   where
     layoutParams :: GV.GraphvizParams Int v e () v
+    --layoutParams :: GV.GraphvizParams Int l el Int l
     layoutParams = GV.defaultParams{
       GV.globalAttributes = [
-        --GV.NodeAttrs [GVA.Shape GVA.BoxShape]
-        GV.NodeAttrs [GVA.Shape GVA.Circle]
-        , GV.GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps, GVA.Splines GVA.LineEdges]
+        GV.NodeAttrs [GVA.Shape GVA.BoxShape]
+        --GV.NodeAttrs [GVA.Shape GVA.Circle]
+        , GV.GraphAttrs
+          [
+          GVA.Overlap GVA.ScaleOverlaps,
+          --GVA.Overlap $ GVA.PrismOverlap (Just 1000),
+          GVA.Splines GVA.LineEdges
+          --GVA.OverlapScaling (5)
+          ]
         ],
       GV.fmtEdge = const [GV.arrowTo GV.noArrow],
       GV.fmtNode = nodeAttribute
@@ -269,7 +279,7 @@ renderDrawing ::
       Renderable (Text Double) b) =>
      Drawing -> IO (QDiagram b V2 Double Any)
 renderDrawing (Drawing nameIconMap edges subDrawings) = do
-  subDiagramMap <- mapM renderSubDrawing subDrawings
+  subDiagramMap <- traverse renderSubDrawing subDrawings
   let diagramMap = makeNamedMap subDiagramMap nameIconMap
   --mapM_ (putStrLn . (++"\n") . show . (map fst) . names . snd) diagramMap
   makeConnections edges <$>

app/Translate.hs

@@ -18,7 +18,7 @@ import Data.List(unzip4, partition)
 import Control.Monad(replicateM)
 
 import Types(Drawing(..), NameAndPort(..), IDState,
-  initialIdState)
+  initialIdState, Edge)
 import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst)
 import Icons(Icon(..))
 import TranslateCore(Reference, IconGraph(..), EvalContext, GraphAndRef,
@@ -383,41 +383,25 @@ generalEvalLambda context patterns rhsEvalFun = do
   let
     patternStrings = concatMap namesInPattern patternVals
     rhsContext = patternStrings <> context
-    lambdaPorts = map (nameAndPort lambdaName) [0,1..]
+    lambdaPorts = map (nameAndPort lambdaName) [2,3..]
     patternGraph = mconcat $ map fst patternVals
 
-    (patternEdgeGraphs, rawNewBinds) =
+    (patternEdges, newBinds) =
       partitionEithers $ zipWith (makePatternEdges lambdaName) patternVals lambdaPorts
-    patternEdgeGraph = mconcat patternEdgeGraphs
-
-    newBinds = rawNewBinds
     numParameters = length patterns
   -- TODO remove coerceExpressionResult here
   (rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult
-  resultIconName <- getUniqueName "res"
-  rhsDrawingName <- DIA.toName <$> getUniqueName "rhsDraw"
   let
-    rhsAndPatternGraph@(IconGraph _ _ _ sinks _) = makeEdges $ patternGraph <> rhsRawGraph
-    qualifiedSinks = fmap (fmap (qualifyNameAndPort lambdaName)) sinks
-    (newSinks, internalEdges) = makeEdgesCore qualifiedSinks newBinds
-    rhsDrawing = makeRhsDrawing resultIconName (rhsAndPatternGraph, rhsResult)
-    icons = toNames [(lambdaName, LambdaRegionIcon numParameters rhsDrawingName)]
-    finalGraph = IconGraph icons internalEdges [(rhsDrawingName, rhsDrawing)]
-      newSinks mempty
-  pure (patternEdgeGraph <> finalGraph, justName lambdaName)
+    icons = toNames [(lambdaName, FlatLambdaIcon numParameters)]
+    resultIconEdge = makeSimpleEdge (rhsResult, nameAndPort lambdaName 0)
+    finalGraph = IconGraph icons (resultIconEdge:patternEdges) mempty
+      mempty newBinds
+  pure (deleteBindings . makeEdges $ (rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName 1)
   where
-    makeRhsDrawing :: DIA.IsName a => a -> (IconGraph, NameAndPort) -> Drawing
-    makeRhsDrawing resultIconName (rhsGraph, rhsResult)= rhsDrawing where
-      rhsNewIcons = toNames [(resultIconName, ResultIcon)]
-      rhsNewEdges = [makeSimpleEdge (rhsResult, justName resultIconName)]
-      rhsGraphWithResult = rhsGraph <> iconGraphFromIconsEdges rhsNewIcons rhsNewEdges
-      rhsDrawing = iconGraphToDrawing rhsGraphWithResult
-
     -- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern.
-    makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either IconGraph (String, Reference)
+    makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either Edge (String, Reference)
     makePatternEdges lambdaName (_, Right patPort) lamPort =
-      Left $ iconGraphFromIconsEdges mempty
-        [makeSimpleEdge (lamPort, qualifyNameAndPort lambdaName patPort)]
+      Left $ makeSimpleEdge (lamPort, patPort)
     makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort)
 
 

app/Types.hs

@@ -23,7 +23,7 @@ import Control.Monad.State(State, state)
 -- The LambdaRegionIcon's data is the number of lambda ports, and the name of it's
 -- subdrawing.
 data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
-  | LambdaRegionIcon Int Name | Apply0NIcon Int | CaseIcon Int | CaseResultIcon
+  | LambdaRegionIcon Int Name | FlatLambdaIcon Int | Apply0NIcon Int | CaseIcon Int | CaseResultIcon
   deriving (Show)
 
 data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)