diff --git a/app/Icons.hs b/app/Icons.hs index a32e598..af85e19 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -30,7 +30,8 @@ data Icon = Apply0Icon | ResultIcon | TextBoxIcon String | LambdaRegionIcon Int iconToDiagram Apply0Icon _ = apply0Dia iconToDiagram ResultIcon _ = resultIcon iconToDiagram (TextBoxIcon s) _ = textBox s -iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap = lambdaRegion n dia +iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap = + lambdaRegion n dia where dia = fromMaybe (error "iconToDiagram: subdiagram not found") $ lookup diagramName nameToSubdiagramMap diff --git a/app/Main.hs b/app/Main.hs index 59afcbf..ae6ec76 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,13 +11,15 @@ import Data.GraphViz.Commands import Data.Map((!)) import Data.Maybe (fromMaybe) +import Data.Typeable(Typeable) + import Lib import Icons import Rendering -- todo: Give graphviz info about the size of the nodes such that a variable scaleFactor --- todo: Test with more lambdas, (eg. two per layer, 3 or more layers) -- for subDiagrams is not necessary. +-- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly applyDia = apply0Dia -- --apply0A = "A" .>> applyDia @@ -63,17 +65,18 @@ d0Edges = iconToPort "bar" "A" 3 ] +drawing0 = Drawing d0Icons d0Edges [] +d0Name = toName "d0" + superEdges = [ portToPort ("lam0" .> "A") 1 "lam0" 0, iconToIcon "y" "lam0", iconToIcon "z" "lam0", - iconToIcon "q" "lam0" + iconToIcon "q" "lam0", + iconToIcon "A" "z" ] -drawing0 = Drawing d0Icons d0Edges [] -d0Name = toName "d0" - superIcons = toNames [ ("lam0", LambdaRegionIcon 3 d0Name), ("y", TextBoxIcon "y"), @@ -84,6 +87,35 @@ superIcons = toNames [ --superDrawing = Drawing [((toName "lam0"), LambdaRegionIcon 3 (toName"d0"))] superEdges [((toName "d0"), drawing0)] superDrawing = Drawing superIcons superEdges [(d0Name, drawing0)] +super2Icons = toNames [ + ("lam0", LambdaRegionIcon 1 d0Name), + --("y", TextBoxIcon "y"), + ("lam1", LambdaRegionIcon 2 d0Name) + ] + +super2Edges = + [ + iconToIcon "lam0" "lam1" + --iconToIcon "y" "lam0" + ] + +super2Drawing = Drawing super2Icons super2Edges [(d0Name, drawing0)] +super2Name = toName "s2" + +super3Icons = toNames [ + ("lam0", LambdaRegionIcon 3 d1Name), + --("y", TextBoxIcon "y"), + ("lam1", LambdaRegionIcon 4 d1Name) + ] + +super3Edges = + [ +-- iconToIcon "lam0" "lam1", + iconToIcon "lam0" "A" + ] +d1Name = toName "d1" +super3Drawing = Drawing super3Icons super3Edges [(d1Name, super2Drawing)] + -- This is left commented out for a future test of the manual connect functions. -- connectNodes g = -- g # connectIconToPort "res" "A" (PortName 2) # connectIconToPort "foo" "B" (PortName 0) @@ -94,7 +126,7 @@ superDrawing = Drawing superIcons superEdges [(d0Name, drawing0)] main1 :: IO () main1 = do - placedNodes <- renderDrawing superDrawing (0.1 :: Double) + placedNodes <- renderDrawing superDrawing (0.7 :: Double) mainWith (placedNodes # bgFrame 0.1 black) main :: IO () diff --git a/app/Rendering.hs b/app/Rendering.hs index 1a48cd9..a4d2d58 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-} + module Rendering ( Drawing(..), portToPort, @@ -10,6 +11,7 @@ module Rendering ( import Diagrams.Prelude import Diagrams.TwoD.GraphViz +import Diagrams.Backend.SVG(B) import Data.GraphViz --import qualified Data.GraphViz.Attributes.Complete as GVA @@ -19,24 +21,36 @@ import Data.Maybe (fromMaybe) import Icons +-- | 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. +type Edge = (Name, Maybe Int, Name, Maybe Int) + -- | A drawing is a map from names to Icons, a list of edges, -- and a map of names to subDrawings -type Edge = (Name, Maybe Int, Name, Maybe Int) data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)] +-- | Convert a map of names and icons, to a list of names and diagrams. +-- The subDiagramMap +makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram B)] makeNamedMap subDiagramMap = - map (\(label, dia) -> (label, iconToDiagram dia subDiagramMap # nameDiagram label)) + map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name)) +mapFst :: (a -> b) -> [(a, c)] -> [(b, c)] mapFst f = map (\(x, y) -> (f x, y)) toNames :: (IsName a) => [(a, b)] -> [(Name, b)] toNames = mapFst toName +portToPort :: (IsName a, IsName c) => a -> b -> c -> d -> (Name, Maybe b, Name, Maybe d) portToPort a b c d = (toName a, Just b, toName c, Just d) + +iconToPort :: (IsName a, IsName c) => a -> c -> d -> (Name, Maybe b, Name, Maybe d) iconToPort a c d = (toName a, Nothing, toName c, Just d) + +iconToIcon :: (IsName a, IsName c) => a -> c -> (Name, Maybe b, Name, Maybe d) iconToIcon a c = (toName a, Nothing, toName c, Nothing) -edgesToGraph labels edges = mkGraph labels simpleEdges +edgesToGraph names edges = mkGraph names simpleEdges where simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges @@ -46,28 +60,23 @@ makeConnections edges = applyAll connections where connections = map (uncurry4 connectMaybePorts) edges -placeNodes scaleFactor layoutResult labelDiagramMap = mconcat placedNodes +placeNodes scaleFactor layoutResult nameDiagramMap = mconcat placedNodes where (positionMap, _) = getGraph layoutResult - placedNodes = map mapper labelDiagramMap - mapper (label, diagram) = placedNode - where - --maybeDiagram = lookup label labelDiagramMap - placedNode = place - diagram - --(fromMaybe (error ("placeNodes: label not in map: " ++ (show (map fst labelDiagramMap)))) maybeDiagram) - (scaleFactor *^ (positionMap ! label)) + placedNodes = map placeNode nameDiagramMap + placeNode (name, diagram) = place diagram (scaleFactor *^ (positionMap ! name)) -doGraphLayout scaleFactor graph labelDiagramMap connectNodes = do +doGraphLayout scaleFactor graph nameDiagramMap connectNodes = do layoutResult <- layoutGraph Neato graph - return $ placeNodes scaleFactor layoutResult labelDiagramMap # connectNodes + return $ placeNodes scaleFactor layoutResult nameDiagramMap # connectNodes renderDrawing (Drawing nameIconMap edges subDrawings) scaleFactor = do subDiagramMap <- mapM subDrawingMapper subDrawings let diagramMap = makeNamedMap subDiagramMap nameIconMap - doGraphLayout scaleFactor (edgesToGraph iconNames edges) diagramMap $ makeConnections edges + --mapM_ (putStrLn . (++"\n") . show . (map fst) . names . snd) diagramMap + doGraphLayout scaleFactor (edgesToGraph iconNames edges) diagramMap (makeConnections edges) where iconNames = map fst nameIconMap - subDrawingMapper (label, subDrawing) = do - subDiagram <- renderDrawing subDrawing (0.4 * scaleFactor) - return (label, subDiagram) + subDrawingMapper (name, subDrawing) = do + subDiagram <- renderDrawing subDrawing (0.2 * scaleFactor) + return (name, subDiagram)