From dd758a38adda03605c54a08c553e13d021841742 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Fri, 8 Apr 2016 23:54:59 -0700 Subject: [PATCH] Translate nested icons. Fix nested icons missing edges in GraphViz graph. --- app/Icons.hs | 26 +++++++++++++++++--------- app/Rendering.hs | 10 +++++++++- app/Translate.hs | 29 ++++++++++++++++++++++++++++- app/Types.hs | 1 + glance.cabal | 1 + 5 files changed, 56 insertions(+), 11 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index ba042f7..f3014d0 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -43,13 +43,14 @@ iconToDiagram (PAppIcon n str) _ = pAppDia n str iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str iconToDiagram ResultIcon _ = identDiaFunc resultIcon iconToDiagram BranchIcon _ = identDiaFunc branchIcon -iconToDiagram (TextBoxIcon s) _ = identDiaFunc $ textBox s +iconToDiagram (TextBoxIcon s) _ = textBox s iconToDiagram (BindTextBoxIcon s) _ = identDiaFunc $ bindTextBox s iconToDiagram (GuardIcon n) _ = identDiaFunc $ guardIcon n iconToDiagram (CaseIcon n) _ = identDiaFunc $ caseIcon n iconToDiagram CaseResultIcon _ = identDiaFunc caseResult iconToDiagram (FlatLambdaIcon n) _ = identDiaFunc $ flatLambda n iconToDiagram (NestedApply s args) _ = nestedApplyDia s args +iconToDiagram (NestedPApp s args) _ = nestedPAppDia s args iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap = identDiaFunc $ lambdaRegion n dia where @@ -138,24 +139,31 @@ transformCorrectedTextBox str textCol borderCol reflect angle = textBoxRotation = if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0 reflectIfTrue shouldReflect dia = if shouldReflect then reflectX dia else dia - nestedApplyDia :: SpecialBackend b => String -> [Maybe (Name, Icon)] -> TransformableDia b -nestedApplyDia funText args reflect angle = transformedText ||| centerY finalDia +nestedApplyDia = generalNestedDia (textBoxC colorScheme) (apply0C colorScheme) + +nestedPAppDia :: SpecialBackend b => + String -> [Maybe (Name, Icon)] -> TransformableDia b +nestedPAppDia = generalNestedDia (patternTextC colorScheme) (patternC colorScheme) + +generalNestedDia :: SpecialBackend b => + Colour Double -> Colour Double-> String -> [Maybe (Name, Icon)] -> TransformableDia b +generalNestedDia textCol borderCol funText args reflect angle = centerXY $ transformedText ||| centerY finalDia where - transformedText = transformCorrectedTextBox funText (textBoxTextC colorScheme) (apply0C colorScheme) reflect angle + transformedText = transformCorrectedTextBox funText textCol borderCol reflect angle seperation = circleRadius * 1.5 verticalSeperation = circleRadius appColor = apply0C colorScheme n = length args trianglePortsCircle = hsep seperation $ - reflectX (fc appColor apply0Triangle) : + reflectX (fc borderCol apply0Triangle) : zipWith makeInnerIcon [2,3..] args ++ - [makePort 1 <> alignR (circle circleRadius # fc appColor # lwG defaultLineWidth # lc appColor)] + [makePort 1 <> alignR (circle circleRadius # fc borderCol # lwG defaultLineWidth # lc borderCol)] allPorts = makePort 0 <> alignL trianglePortsCircle topAndBottomLineWidth = width allPorts - circleRadius - argBox = rect topAndBottomLineWidth (height allPorts + verticalSeperation)# lc appColor # lwG defaultLineWidth # alignL + argBox = rect topAndBottomLineWidth (height allPorts + verticalSeperation)# lc borderCol # lwG defaultLineWidth # alignL finalDia = argBox <> allPorts makeInnerIcon portNum Nothing = makePort portNum <> portCircle @@ -171,8 +179,8 @@ textBoxHeightFactor :: (Fractional a) => a textBoxHeightFactor = 1.1 textBox :: SpecialBackend b => - String -> SpecialQDiagram b -textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme) + String -> TransformableDia b +textBox t = transformCorrectedTextBox t (textBoxTextC colorScheme) $ textBoxC colorScheme bindTextBox :: SpecialBackend b => String -> SpecialQDiagram b diff --git a/app/Rendering.hs b/app/Rendering.hs index dd3e94f..ac1d33e 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -6,6 +6,7 @@ module Rendering ( import Diagrams.Prelude import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph') +import Diagrams.Core.Names(Name(..)) --import Diagrams.Backend.SVG(B) import qualified Data.GraphViz as GV @@ -57,11 +58,18 @@ makeNamedMap :: SpecialBackend b => makeNamedMap subDiagramMap = map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap)) +-- Note that the name type alias is different from the Name constructor. +getTopLevelName :: Name -> Name +getTopLevelName (Name []) = Name [] +getTopLevelName (Name (x:_)) = Name [x] + + +-- TODO: Not sure if using getTopLevelName here will break the old nested lambda icon. -- | Make an inductive Graph from a list of node names, and a list of Connections. edgesToGraph :: [Name] -> [(NameAndPort, NameAndPort)] -> Gr Name () edgesToGraph iconNames edges = mkGraph iconNames simpleEdges where - simpleEdges = map (\(NameAndPort a _, NameAndPort c _) -> (a, c, ())) edges + simpleEdges = map (\(NameAndPort a _, NameAndPort c _) -> (getTopLevelName a, getTopLevelName c, ())) edges -- | Custom arrow tail for the arg1 result circle. -- The ArrowHT type does not seem to be documented. diff --git a/app/Translate.hs b/app/Translate.hs index 022436f..e8e0f74 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -16,6 +16,7 @@ import Control.Monad.State(State, evalState) import Data.Either(partitionEithers) import Data.List(unzip4, partition) import Control.Monad(replicateM) +import Data.Maybe(catMaybes) import Types(Drawing(..), NameAndPort(..), IDState, initialIdState, Edge) @@ -108,8 +109,34 @@ qOpToString :: QOp -> String qOpToString (QVarOp n) = qNameToString n qOpToString (QConOp n) = qNameToString n +--decideIfNested :: ((IconGraph, r), p) -> (Maybe ((IconGraph, r), p), Maybe (DIA.Name, Icon)) +decideIfNested valAndPort@((IconGraph [nameAndIcon] [] [] sinks bindings, _), _) = (Nothing, Just nameAndIcon, sinks, bindings) +decideIfNested valAndPort = (Just valAndPort, Nothing, [], []) + makeTextApplyGraph :: Bool -> DIA.Name -> String -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort) -makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1) +makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = result + where + result = nestedApplyResult + argumentPorts = map (nameAndPort applyIconName) [2,3..] + (unnestedArgsAndPort, nestedArgs, nestedSinks, nestedBindings) = unzip4 $ map decideIfNested (zip argVals argumentPorts) + qualifiedSinks = map qualifySink (mconcat nestedSinks) + qualifySink (str, (NameAndPort n p)) = (str, NameAndPort (applyIconName DIA..> n) p) + + qualifiedBinds = map qualifyBinds (mconcat nestedBindings) + qualifyBinds (str, ref) = (str, qualifiedRef) where + qualifiedRef = case ref of + Left _ -> ref + Right (NameAndPort n p) -> Right $ NameAndPort (applyIconName DIA..> n) p + + combinedGraph = combineExpressions inPattern $ catMaybes unnestedArgsAndPort + icon = if inPattern then NestedPApp else NestedApply + icons = [(applyIconName, icon funStr nestedArgs)] + newGraph = IconGraph icons [] [] qualifiedSinks qualifiedBinds + nestedApplyResult = (newGraph <> combinedGraph, nameAndPort applyIconName 1) + + +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 diff --git a/app/Types.hs b/app/Types.hs index adf5cd9..10d93bc 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -31,6 +31,7 @@ data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int | BindTextBoxIcon String -- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)] | NestedApply String [Maybe (Name, Icon)] + | NestedPApp String [Maybe (Name, Icon)] deriving (Show) data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show) diff --git a/glance.cabal b/glance.cabal index b0fc40d..54612be 100644 --- a/glance.cabal +++ b/glance.cabal @@ -26,6 +26,7 @@ executable glance-exe build-depends: base , glance , diagrams + , diagrams-core , diagrams-lib , diagrams-svg , diagrams-graphviz