From 692577138d95bd6a9529abc2e622b07576a0152e Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Mon, 21 Mar 2016 17:36:02 -0700 Subject: [PATCH] Integrate text with apply icons. --- app/Icons.hs | 30 +++++++++++++++++++++++------- app/Translate.hs | 34 +++++++++++++++++++++++++++++----- app/Types.hs | 3 ++- 3 files changed, 54 insertions(+), 13 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index 5a39606..66f9b27 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -40,7 +40,8 @@ data ColorStyle a = ColorStyle { lamArgResC :: Colour a, regionPerimC :: Colour a, caseRhsC :: Colour a, - patternC :: Colour a + patternC :: Colour a, + patternTextC :: Colour a } colorOnBlackScheme :: (Floating a, Ord a) => ColorStyle a @@ -55,7 +56,8 @@ colorOnBlackScheme = ColorStyle { lamArgResC = lightSlightlyPurpleBlue, regionPerimC = lime, caseRhsC = slightlyGreenYellow, - patternC = lightMagenta + patternC = lightMagenta, + patternTextC = cyan } where slightlyGreenYellow = sRGB24 212 255 0 @@ -74,7 +76,8 @@ whiteOnBlackScheme = ColorStyle { lamArgResC = white, regionPerimC = white, caseRhsC = white, - patternC = white + patternC = white, + patternTextC = white } -- Use this to test that all of the colors use the colorScheme @@ -90,7 +93,8 @@ randomColorScheme = ColorStyle { lamArgResC = red, regionPerimC = cyan, caseRhsC = red, - patternC = olive + patternC = olive, + patternTextC = coral } lineCol :: (Floating a, Ord a) => Colour a @@ -103,6 +107,8 @@ iconToDiagram :: Renderable (Text n) b) => Icon -> [(Name, QDiagram b V2 n Any)] -> QDiagram b V2 n Any iconToDiagram (ApplyAIcon n) _ = applyADia n +iconToDiagram (PAppIcon n str) _ = pAppDia n str +iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str iconToDiagram ResultIcon _ = resultIcon iconToDiagram BranchIcon _ = branchIcon iconToDiagram (TextBoxIcon s) _ = textBox s @@ -167,7 +173,7 @@ applyA0Dia :: (RealFloat n, Typeable n, Monoid m, Semigroup m, TrailLike (QDiagram b V2 n m)) => QDiagram b V2 n m -applyA0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations # centerXY +applyA0Dia = ((resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations) # reflectX # centerXY apply0PortLocations :: Floating a => [P2 a] apply0PortLocations = map p2 [ @@ -191,7 +197,7 @@ applyADia :: (RealFloat n, Typeable n, Monoid m, Semigroup m, TrailLike (QDiagram b V2 n m)) => Int -> QDiagram b V2 n m -applyADia 1 = applyA0Dia +--applyADia 1 = applyA0Dia applyADia n = finalDia # centerXY where seperation = circleRadius * 1.5 trianglePortsCircle = hcat [ @@ -204,6 +210,16 @@ applyADia n = finalDia # centerXY where topAndBottomLine = hrule topAndBottomLineWidth # lc (apply0C colorScheme) # lwG defaultLineWidth # alignL finalDia = topAndBottomLine === allPorts === topAndBottomLine +--textApplyADia :: _ => Int -> String -> QDiagram b V2 n m +textApplyADia :: (RealFloat n, Typeable n, Renderable (Path V2 n) b, + Renderable (Text n) b) => + Int -> String -> QDiagram b V2 n Any +textApplyADia numArgs functionName = textBox functionName ||| applyADia numArgs + +pAppDia numArgs constructorName = + coloredTextBox (patternTextC colorScheme) (opaque (patternC colorScheme)) constructorName + ||| applyADia numArgs + -- TEXT ICON -- textBoxFontSize :: (Num a) => a textBoxFontSize = 1 @@ -347,7 +363,7 @@ caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult -- 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]) + lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> (alignR lambdaCircle)]) portIcons = take n $ map (\x -> makePort x <> portCircle) [2,3..] middle = alignL (hsep 0.5 lambdaParts) topAndBottomLineWidth = width middle - circleRadius diff --git a/app/Translate.hs b/app/Translate.hs index 65d602b..b831b56 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -52,12 +52,10 @@ evalPApp :: QName -> [Pat] -> State IDState (IconGraph, NameAndPort) evalPApp name [] = makeBox $ qNameToString name evalPApp name patterns = do patName <- DIA.toName <$> getUniqueName "pat" - let - context = mempty evaledPatterns <- mapM evalPattern patterns - constructorName <- evalQName name context let - gr = makeApplyGraph True patName constructorName evaledPatterns (length evaledPatterns) + constructorName = qNameToString name + gr = makeTextApplyGraph True patName constructorName evaledPatterns (length evaledPatterns) pure gr @@ -106,8 +104,33 @@ evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference) evalQOp (QVarOp n) = evalQName n evalQOp (QConOp n) = evalQName n +makeTextApplyGraph :: Bool -> DIA.Name -> String -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort) +makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1) + where + argumentPorts = map (nameAndPort applyIconName) [2,3..] + combinedGraph = combineExpressions inPattern $ zip argVals argumentPorts + icon = if inPattern + then PAppIcon + else TextApplyAIcon + icons = [(applyIconName, icon numArgs funStr)] + newGraph = iconGraphFromIcons icons + evalApp :: EvalContext -> (Exp, [Exp]) -> State IDState (IconGraph, NameAndPort) -evalApp c (funExp, argExps) = do +evalApp c exps@(funExp, argExps) = case funExp of + (Var n) -> makeTextApp n + (Con n) -> makeTextApp n + _ -> evalAppNoText c exps + where + makeTextApp funName = let funStr = qNameToString funName in + if funStr `elem` c + then evalAppNoText c exps + else do + argVals <- mapM (evalExp c) argExps + applyIconName <- DIA.toName <$> getUniqueName "app0" + pure $ makeTextApplyGraph False applyIconName funStr argVals (length argExps) + +evalAppNoText :: EvalContext -> (Exp, [Exp]) -> State IDState (IconGraph, NameAndPort) +evalAppNoText c (funExp, argExps) = do funVal <- evalExp c funExp argVals <- mapM (evalExp c) argExps applyIconName <- DIA.toName <$> getUniqueName "app0" @@ -399,6 +422,7 @@ generalEvalLambda context patterns rhsEvalFun = do pure (deleteBindings . makeEdges $ (rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName 1) where -- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern. + -- makePatternEdges creates the edges between the patterns and the parameter ports. makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either Edge (String, Reference) makePatternEdges lambdaName (_, Right patPort) lamPort = Left $ makeSimpleEdge (lamPort, patPort) diff --git a/app/Types.hs b/app/Types.hs index e79e6d4..ad4dcbd 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -23,7 +23,8 @@ 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 | FlatLambdaIcon Int | ApplyAIcon Int | CaseIcon Int | CaseResultIcon + | LambdaRegionIcon Int Name | FlatLambdaIcon Int | ApplyAIcon Int + | TextApplyAIcon Int String | PAppIcon Int String | CaseIcon Int | CaseResultIcon deriving (Show) data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)