mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 10:20:27 +03:00
Moved functions from Main to Rendering
This commit is contained in:
Robbie Gleichman
parent
f0fdb5829a
commit
120dc18b88
73
app/Main.hs
73
app/Main.hs
@ -13,6 +13,7 @@ import Data.Maybe (fromMaybe)
|
||||
|
||||
import Lib
|
||||
import Icons
|
||||
import Rendering
|
||||
|
||||
-- todo: Clean up. Put renderDrawing code in a new file.
|
||||
|
||||
@ -46,16 +47,7 @@ applyDia = apply0Dia
|
||||
-- # connectPorts ("lam0" .> "B") (PortName 1) "lam0" (PortName 2)
|
||||
-- ex11 = connectIcons "lam0" "y" $ ex10 === vrule 2 === textBox "y" # named "y"
|
||||
|
||||
-- | A drawing is a map from names to Icons, a list of edges, and a map of names to subDrawings
|
||||
data Drawing b = Drawing [(Name, Icon)] b [(Name, Drawing b)]
|
||||
|
||||
makeNamedMap subDiagramMap =
|
||||
map (\(label, dia) -> (label, iconToDiagram dia subDiagramMap # nameDiagram label))
|
||||
|
||||
mapFst f = map (\(x, y) -> (f x, y))
|
||||
toNames = mapFst toName
|
||||
|
||||
rawDiagramMap = toNames $
|
||||
d0Icons = toNames
|
||||
[("A", Apply0Icon),
|
||||
("B", Apply0Icon),
|
||||
("res", ResultIcon),
|
||||
@ -63,11 +55,7 @@ rawDiagramMap = toNames $
|
||||
("bar", TextBoxIcon "bar")
|
||||
]
|
||||
|
||||
portToPort a b c d = (toName a, Just $ PortName b, toName c, Just $ PortName d)
|
||||
iconToPort a c d = (toName a, Nothing, toName c, Just $ PortName d)
|
||||
iconToIcon a c = (toName a, Nothing, toName c, Nothing)
|
||||
|
||||
edges =
|
||||
d0Edges =
|
||||
[
|
||||
portToPort "A" 0 "B" 2,
|
||||
iconToPort "foo" "B" 0,
|
||||
@ -85,40 +73,18 @@ superEdges =
|
||||
iconToIcon "q" "lam0"
|
||||
]
|
||||
|
||||
drawing0 = Drawing rawDiagramMap edges []
|
||||
drawing0 = Drawing d0Icons d0Edges []
|
||||
d0Name = toName "d0"
|
||||
|
||||
superIcons = toNames $ [
|
||||
("lam0", LambdaRegionIcon 3 (toName "d0")),
|
||||
superIcons = toNames [
|
||||
("lam0", LambdaRegionIcon 3 d0Name),
|
||||
("y", TextBoxIcon "y"),
|
||||
("z", TextBoxIcon "z"),
|
||||
("q", TextBoxIcon "q")
|
||||
]
|
||||
|
||||
--superDrawing :: (IsName c) => Drawing Name c
|
||||
--superDrawing = Drawing [((toName "lam0"), LambdaRegionIcon 3 (toName"d0"))] superEdges [((toName "d0"), drawing0)]
|
||||
superDrawing = Drawing superIcons superEdges [(toName "d0", drawing0)]
|
||||
|
||||
edgesToGraph labels edges = mkGraph labels simpleEdges
|
||||
where
|
||||
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
||||
|
||||
uncurry4 f (a, b, c, d) = f a b c d
|
||||
|
||||
makeConnections edges = applyAll connections
|
||||
where
|
||||
connections = map (uncurry4 connectMaybePorts) edges
|
||||
|
||||
placeNodes scaleFactor layoutResult labelDiagramMap = 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)
|
||||
superDrawing = Drawing superIcons superEdges [(d0Name, drawing0)]
|
||||
|
||||
-- This is left commented out for a future test of the manual connect functions.
|
||||
-- connectNodes g =
|
||||
@ -126,31 +92,8 @@ placeNodes scaleFactor layoutResult labelDiagramMap = mconcat placedNodes
|
||||
-- # connectIconToPort "bar" "B" (PortName 3) # connectPorts "A" (PortName 0) "B" (PortName 2)
|
||||
-- # connectIconToPort "bar" "A" (PortName 3)
|
||||
|
||||
|
||||
doGraphLayout scaleFactor graph labelDiagramMap connectNodes = do
|
||||
layoutResult <- layoutGraph Neato graph
|
||||
return $ placeNodes scaleFactor layoutResult labelDiagramMap # connectNodes
|
||||
--where
|
||||
--diagramScaleConstant = 0.04
|
||||
--diagramScaleConstant = 0.1
|
||||
|
||||
--main1 = mainWith (ex11 # bgFrame 0.1 black)
|
||||
|
||||
--renderDrawing :: Drawing a -> IO (Diagram B)
|
||||
renderDrawing (Drawing nameIconMap edges subDrawings) scaleFactor = do
|
||||
subDiagramMap <- mapM subDrawingMapper subDrawings
|
||||
let diagramMap = makeNamedMap subDiagramMap nameIconMap
|
||||
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)
|
||||
|
||||
-- main0 = do
|
||||
-- placedNodes <- doGraphLayout graph labelDiagramMap connectNodes
|
||||
-- mainWith (placedNodes # bgFrame 0.1 black)
|
||||
|
||||
main1 = do
|
||||
placedNodes <- renderDrawing superDrawing 0.1
|
||||
mainWith (placedNodes # bgFrame 0.1 black)
|
||||
|
||||
72
app/Rendering.hs
Normal file
72
app/Rendering.hs
Normal file
@ -0,0 +1,72 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||
module Rendering (
|
||||
Drawing(..),
|
||||
portToPort,
|
||||
iconToPort,
|
||||
iconToIcon,
|
||||
toNames,
|
||||
renderDrawing
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.TwoD.GraphViz
|
||||
|
||||
import Data.GraphViz
|
||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||
import Data.GraphViz.Commands
|
||||
import Data.Map((!))
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
||||
import Icons
|
||||
|
||||
-- | A drawing is a map from names to Icons, a list of edges,
|
||||
-- and a map of names to subDrawings
|
||||
data Drawing b = Drawing [(Name, Icon)] b [(Name, Drawing b)]
|
||||
|
||||
makeNamedMap subDiagramMap =
|
||||
map (\(label, dia) -> (label, iconToDiagram dia subDiagramMap # nameDiagram label))
|
||||
|
||||
mapFst f = map (\(x, y) -> (f x, y))
|
||||
|
||||
toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
|
||||
toNames = mapFst toName
|
||||
|
||||
portToPort a b c d = (toName a, Just $ PortName b, toName c, Just $ PortName d)
|
||||
iconToPort a c d = (toName a, Nothing, toName c, Just $ PortName d)
|
||||
iconToIcon a c = (toName a, Nothing, toName c, Nothing)
|
||||
|
||||
edgesToGraph labels edges = mkGraph labels simpleEdges
|
||||
where
|
||||
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
||||
|
||||
uncurry4 f (a, b, c, d) = f a b c d
|
||||
|
||||
makeConnections edges = applyAll connections
|
||||
where
|
||||
connections = map (uncurry4 connectMaybePorts) edges
|
||||
|
||||
placeNodes scaleFactor layoutResult labelDiagramMap = 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)
|
||||
|
||||
doGraphLayout scaleFactor graph labelDiagramMap connectNodes = do
|
||||
layoutResult <- layoutGraph Neato graph
|
||||
return $ placeNodes scaleFactor layoutResult labelDiagramMap # 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
|
||||
where
|
||||
iconNames = map fst nameIconMap
|
||||
subDrawingMapper (label, subDrawing) = do
|
||||
subDiagram <- renderDrawing subDrawing (0.4 * scaleFactor)
|
||||
return (label, subDiagram)
|
||||
Loading…
Reference in New Issue
Block a user