mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Clean up and test recursive drawings.
This commit is contained in:
parent
2ac3ee04a7
commit
636a2ee5b0
@ -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
|
||||
|
||||
|
44
app/Main.hs
44
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 ()
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user