mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add Apply0N, extract types to Types.hs, add end options to Edge type.
This commit is contained in:
parent
e311a9b38f
commit
d5e0b6bf63
37
app/Icons.hs
37
app/Icons.hs
@ -13,24 +13,19 @@ module Icons
|
|||||||
lambdaRegion,
|
lambdaRegion,
|
||||||
resultIcon,
|
resultIcon,
|
||||||
guardIcon,
|
guardIcon,
|
||||||
|
apply0NDia
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude
|
||||||
import Diagrams.Backend.SVG(B)
|
import Diagrams.Backend.SVG(B)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
|
||||||
-- TYPES --
|
import Types(Icon(..), Edge(..))
|
||||||
-- | A datatype that represents an icon.
|
|
||||||
-- The BranchIcon is used as a branching point for a line.
|
|
||||||
-- The TextBoxIcon's data is the text that appears in the text box.
|
|
||||||
-- The LambdaRegionIcon's data is the number of lambda ports, and the name of it's
|
|
||||||
-- subdrawing.
|
|
||||||
data Icon = Apply0Icon | ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
|
|
||||||
| LambdaRegionIcon Int Name
|
|
||||||
|
|
||||||
-- FUNCTIONS --
|
-- FUNCTIONS --
|
||||||
|
|
||||||
iconToDiagram Apply0Icon _ = apply0Dia
|
iconToDiagram Apply0Icon _ = apply0Dia
|
||||||
|
iconToDiagram (Apply0NIcon n) _ = apply0NDia n
|
||||||
iconToDiagram ResultIcon _ = resultIcon
|
iconToDiagram ResultIcon _ = resultIcon
|
||||||
iconToDiagram BranchIcon _ = branchIcon
|
iconToDiagram BranchIcon _ = branchIcon
|
||||||
iconToDiagram (TextBoxIcon s) _ = textBox s
|
iconToDiagram (TextBoxIcon s) _ = textBox s
|
||||||
@ -45,16 +40,17 @@ nameDiagram name dia = name .>> (dia # named name)
|
|||||||
|
|
||||||
arrowOptions = with & arrowHead .~ noHead & shaftStyle %~ lwG defaultLineWidth . lc white
|
arrowOptions = with & arrowHead .~ noHead & shaftStyle %~ lwG defaultLineWidth . lc white
|
||||||
|
|
||||||
connectMaybePorts icon0 (Just port0) icon1 (Just port1) =
|
connectMaybePorts :: Edge -> Diagram B -> Diagram B
|
||||||
|
connectMaybePorts (Edge (icon0, Just port0, icon1, Just port1) _) =
|
||||||
connect'
|
connect'
|
||||||
arrowOptions
|
arrowOptions
|
||||||
(icon0 .> port0)
|
(icon0 .> port0)
|
||||||
(icon1 .> port1)
|
(icon1 .> port1)
|
||||||
connectMaybePorts icon0 Nothing icon1 (Just port1) =
|
connectMaybePorts (Edge (icon0, Nothing, icon1, Just port1) _) =
|
||||||
connectOutside' arrowOptions icon0 (icon1 .> port1)
|
connectOutside' arrowOptions icon0 (icon1 .> port1)
|
||||||
connectMaybePorts icon0 (Just port0) icon1 Nothing =
|
connectMaybePorts (Edge (icon0, Just port0, icon1, Nothing) _) =
|
||||||
connectOutside' arrowOptions (icon0 .> port0) icon1
|
connectOutside' arrowOptions (icon0 .> port0) icon1
|
||||||
connectMaybePorts icon0 Nothing icon1 Nothing =
|
connectMaybePorts (Edge (icon0, Nothing, icon1, Nothing) _) =
|
||||||
connectOutside' arrowOptions icon0 icon1
|
connectOutside' arrowOptions icon0 icon1
|
||||||
|
|
||||||
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
||||||
@ -85,7 +81,7 @@ apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc red # lw
|
|||||||
apply0Line = rect apply0LineWidth (2 * circleRadius) # fc white # lw none
|
apply0Line = rect apply0LineWidth (2 * circleRadius) # fc white # lw none
|
||||||
|
|
||||||
--apply0Dia :: Diagram B
|
--apply0Dia :: Diagram B
|
||||||
apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations
|
apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations # centerXY
|
||||||
|
|
||||||
apply0PortLocations = map p2 [
|
apply0PortLocations = map p2 [
|
||||||
(circleRadius + apply0LineWidth + triangleWidth, 0),
|
(circleRadius + apply0LineWidth + triangleWidth, 0),
|
||||||
@ -96,6 +92,21 @@ apply0PortLocations = map p2 [
|
|||||||
triangleWidth = circleRadius * sqrt 3
|
triangleWidth = circleRadius * sqrt 3
|
||||||
lineCenter = circleRadius + (apply0LineWidth / 2.0)
|
lineCenter = circleRadius + (apply0LineWidth / 2.0)
|
||||||
|
|
||||||
|
-- apply0N Icon--
|
||||||
|
|
||||||
|
apply0NDia :: Int -> Diagram B
|
||||||
|
apply0NDia n = finalDia # centerXY where
|
||||||
|
seperation = 0.6
|
||||||
|
trianglePortsCircle = hcat [
|
||||||
|
reflectX apply0Triangle,
|
||||||
|
hcat $ take n $ map (\x -> makePort x <> strutX seperation) [2,3..],
|
||||||
|
makePort 1 <> alignR (circle circleRadius # fc red # lwG defaultLineWidth # lc red)
|
||||||
|
]
|
||||||
|
allPorts = makePort 0 <> alignL trianglePortsCircle
|
||||||
|
topAndBottomLineWidth = width allPorts - circleRadius
|
||||||
|
topAndBottomLine = hrule topAndBottomLineWidth # lc red # lwG defaultLineWidth # alignL
|
||||||
|
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||||
|
|
||||||
-- TEXT ICON --
|
-- TEXT ICON --
|
||||||
textBoxFontSize = 1
|
textBoxFontSize = 1
|
||||||
monoLetterWidthToHeightFraction = 0.6
|
monoLetterWidthToHeightFraction = 0.6
|
||||||
|
23
app/Main.hs
23
app/Main.hs
@ -14,8 +14,9 @@ import Data.Maybe (fromMaybe)
|
|||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
import Lib
|
import Lib
|
||||||
import Icons
|
import Icons(apply0Dia, apply0NDia)
|
||||||
import Rendering
|
import Rendering(toNames, portToPort, iconToPort, iconToIcon, renderDrawing)
|
||||||
|
import Types(Icon(..), Drawing(..))
|
||||||
|
|
||||||
-- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly
|
-- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly
|
||||||
-- todo: Find out and fix why connectinos to sub-icons need to be qualified twice (eg. "lam0" .> "arg" .> "arg")
|
-- todo: Find out and fix why connectinos to sub-icons need to be qualified twice (eg. "lam0" .> "arg" .> "arg")
|
||||||
@ -24,6 +25,7 @@ import Rendering
|
|||||||
-- todo: add port to bottom of guard.
|
-- todo: add port to bottom of guard.
|
||||||
-- todo: use constants for icon name strings in Main
|
-- todo: use constants for icon name strings in Main
|
||||||
-- todo: figure out local vs. global icon positions
|
-- todo: figure out local vs. global icon positions
|
||||||
|
-- todo: replace hrule and vrule with strutX and strutY
|
||||||
|
|
||||||
applyDia = apply0Dia
|
applyDia = apply0Dia
|
||||||
-- --apply0A = "A" .>> applyDia
|
-- --apply0A = "A" .>> applyDia
|
||||||
@ -131,8 +133,9 @@ fact0Icons = toNames
|
|||||||
("-1Ap", Apply0Icon),
|
("-1Ap", Apply0Icon),
|
||||||
("*", TextBoxIcon "*"),
|
("*", TextBoxIcon "*"),
|
||||||
("recurAp", Apply0Icon),
|
("recurAp", Apply0Icon),
|
||||||
("*Ap1", Apply0Icon),
|
("*Ap", Apply0NIcon 2),
|
||||||
("*Ap2", Apply0Icon),
|
--("*Ap1", Apply0Icon),
|
||||||
|
--("*Ap2", Apply0Icon),
|
||||||
("arg", BranchIcon),
|
("arg", BranchIcon),
|
||||||
("res", ResultIcon)
|
("res", ResultIcon)
|
||||||
]
|
]
|
||||||
@ -141,14 +144,14 @@ fact0Edges = [
|
|||||||
iconToPort "eq0" "eq0Ap" 0,
|
iconToPort "eq0" "eq0Ap" 0,
|
||||||
portToPort "eq0Ap" 2 "g0" 1,
|
portToPort "eq0Ap" 2 "g0" 1,
|
||||||
iconToPort "-1" "-1Ap" 0,
|
iconToPort "-1" "-1Ap" 0,
|
||||||
iconToPort "*" "*Ap1" 0,
|
iconToPort "*" "*Ap" 0,
|
||||||
iconToPort "one" "g0" 2,
|
iconToPort "one" "g0" 2,
|
||||||
portToPort "*Ap2" 2 "g0" 4,
|
portToPort "*Ap" 1 "g0" 4,
|
||||||
portToPort "*Ap1" 2 "*Ap2" 0,
|
--portToPort "*Ap" 3 "recurAp" 0,
|
||||||
portToPort "recurAp" 2 "*Ap1" 1,
|
portToPort "recurAp" 2 "*Ap" 3,
|
||||||
iconToPort "arg" "eq0Ap" 1,
|
iconToPort "arg" "eq0Ap" 1,
|
||||||
iconToPort "arg" "-1Ap" 1,
|
iconToPort "arg" "-1Ap" 1,
|
||||||
iconToPort "arg" "*Ap2" 1,
|
iconToPort "arg" "*Ap" 2,
|
||||||
portToPort "-1Ap" 2 "recurAp" 1,
|
portToPort "-1Ap" 2 "recurAp" 1,
|
||||||
iconToPort "res" "g0" 0
|
iconToPort "res" "g0" 0
|
||||||
]
|
]
|
||||||
@ -183,7 +186,7 @@ main1 = do
|
|||||||
placedNodes <- renderDrawing factLam0Drawing
|
placedNodes <- renderDrawing factLam0Drawing
|
||||||
mainWith (placedNodes # bgFrame 0.1 black)
|
mainWith (placedNodes # bgFrame 0.1 black)
|
||||||
|
|
||||||
main2 = mainWith (guardIcon 3 # bgFrame 0.1 black)
|
main2 = mainWith (apply0NDia 3 # bgFrame 0.1 black)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = main1
|
main = main1
|
||||||
|
@ -21,16 +21,11 @@ import Data.Maybe(fromMaybe, isJust)
|
|||||||
import qualified Debug.Trace
|
import qualified Debug.Trace
|
||||||
import Data.List(minimumBy)
|
import Data.List(minimumBy)
|
||||||
import Data.Function(on)
|
import Data.Function(on)
|
||||||
|
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||||
|
|
||||||
import Icons
|
import Icons
|
||||||
|
import Types(Edge(..), Connection, Drawing(..), EdgeEndType(..))
|
||||||
|
|
||||||
-- | 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
|
|
||||||
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)]
|
|
||||||
|
|
||||||
-- | Convert a map of names and icons, to a list of names and diagrams.
|
-- | Convert a map of names and icons, to a list of names and diagrams.
|
||||||
-- The subDiagramMap
|
-- The subDiagramMap
|
||||||
@ -44,27 +39,32 @@ mapFst f = map (\(x, y) -> (f x, y))
|
|||||||
toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
|
toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
|
||||||
toNames = mapFst toName
|
toNames = mapFst toName
|
||||||
|
|
||||||
portToPort :: (IsName a, IsName c) => a -> b -> c -> d -> (Name, Maybe b, Name, Maybe d)
|
noEnds = (NoEnd, NoEnd)
|
||||||
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)
|
--portToPort :: (IsName a, IsName c) => a -> b -> c -> d -> Edge
|
||||||
iconToPort a c d = (toName a, Nothing, toName c, Just d)
|
portToPort :: (IsName a, IsName b) => a -> Int -> b -> Int -> Edge
|
||||||
|
portToPort a b c d = Edge (toName a, Just b, toName c, Just d) noEnds
|
||||||
|
|
||||||
iconToIcon :: (IsName a, IsName c) => a -> c -> (Name, Maybe b, Name, Maybe d)
|
iconToPort :: (IsName a, IsName b) => a -> b -> Int -> Edge
|
||||||
iconToIcon a c = (toName a, Nothing, toName c, Nothing)
|
iconToPort a c d = Edge (toName a, Nothing, toName c, Just d) noEnds
|
||||||
|
|
||||||
|
iconToIcon :: (IsName a, IsName b) => a -> b -> Edge
|
||||||
|
iconToIcon a c = Edge (toName a, Nothing, toName c, Nothing) noEnds
|
||||||
|
|
||||||
|
edgesToGraph :: (Ord v) => [v] -> [(v, t, v , t1)] -> Gr v ()
|
||||||
edgesToGraph names edges = mkGraph names simpleEdges
|
edgesToGraph names edges = mkGraph names simpleEdges
|
||||||
where
|
where
|
||||||
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
||||||
|
|
||||||
uncurry4 f (a, b, c, d) = f a b c d
|
uncurry4 f (a, b, c, d) = f a b c d
|
||||||
|
|
||||||
|
makeConnections :: [Edge] -> Diagram B -> Diagram B
|
||||||
makeConnections edges = applyAll connections
|
makeConnections edges = applyAll connections
|
||||||
where
|
where
|
||||||
connections = map (uncurry4 connectMaybePorts) edges
|
connections = map connectMaybePorts edges
|
||||||
|
|
||||||
-- | Returns [(myport, other node, other node's port)]
|
-- | Returns [(myport, other node, other node's port)]
|
||||||
connectedPorts :: [Edge] -> Name -> [(Int, Name, Maybe Int)]
|
connectedPorts :: [Connection] -> Name -> [(Int, Name, Maybe Int)]
|
||||||
connectedPorts edges name = map edgeToPort $ filter nameInEdge edges
|
connectedPorts edges name = map edgeToPort $ filter nameInEdge edges
|
||||||
where
|
where
|
||||||
nameInEdge (n1, p1, n2, p2) = (name == n1 && isJust p1) || (name == n2 && isJust p2)
|
nameInEdge (n1, p1, n2, p2) = (name == n1 && isJust p1) || (name == n2 && isJust p2)
|
||||||
@ -100,12 +100,14 @@ angleWithMinDist myLocation edges =
|
|||||||
-- constant
|
-- constant
|
||||||
scaleFactor = 0.02
|
scaleFactor = 0.02
|
||||||
|
|
||||||
|
getFromMapAndScale :: (Fractional a, Functor f, Ord k) => Map.Map k (f a) -> k -> f a
|
||||||
getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name)
|
getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name)
|
||||||
|
|
||||||
-- | rotateNodes rotates the nodes such that the distance of its connecting lines
|
-- | rotateNodes rotates the nodes such that the distance of its connecting lines
|
||||||
-- are minimized.
|
-- are minimized.
|
||||||
-- Precondition: the diagrams are already centered
|
-- Precondition: the diagrams are already centered
|
||||||
-- todo: confirm precondition (or use a newtype)
|
-- todo: confirm precondition (or use a newtype)
|
||||||
|
rotateNodes :: Map.Map Name (Point V2 Double) -> [(Name, Diagram B)] -> [Connection] -> [(Name, Diagram B)]
|
||||||
rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||||
where
|
where
|
||||||
rotateDiagram (name, dia) = (name, diaToUse)
|
rotateDiagram (name, dia) = (name, diaToUse)
|
||||||
@ -139,6 +141,7 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
|||||||
-- todo: Not sure if the diagrams should already be centered at this point.
|
-- todo: Not sure if the diagrams should already be centered at this point.
|
||||||
placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name))
|
placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name))
|
||||||
|
|
||||||
|
doGraphLayout :: Gr Name e -> [(Name, Diagram B)] -> (Diagram B -> r) -> [Connection] -> IO r
|
||||||
doGraphLayout graph nameDiagramMap connectNodes edges = do
|
doGraphLayout graph nameDiagramMap connectNodes edges = do
|
||||||
layoutResult <- layoutGraph' layoutParams Neato graph
|
layoutResult <- layoutGraph' layoutParams Neato graph
|
||||||
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
||||||
@ -147,7 +150,7 @@ doGraphLayout graph nameDiagramMap connectNodes edges = do
|
|||||||
layoutParams = defaultParams{
|
layoutParams = defaultParams{
|
||||||
globalAttributes =
|
globalAttributes =
|
||||||
[ NodeAttrs [shape Circle]
|
[ NodeAttrs [shape Circle]
|
||||||
, GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps]
|
, GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps, GVA.Splines GVA.LineEdges]
|
||||||
],
|
],
|
||||||
fmtEdge = const [arrowTo noArrow],
|
fmtEdge = const [arrowTo noArrow],
|
||||||
fmtNode = nodeAttribute
|
fmtNode = nodeAttribute
|
||||||
@ -163,12 +166,14 @@ doGraphLayout graph nameDiagramMap connectNodes edges = do
|
|||||||
-- to name the nodes in order
|
-- to name the nodes in order
|
||||||
(_, dia) = nameDiagramMap !! nodeInt
|
(_, dia) = nameDiagramMap !! nodeInt
|
||||||
|
|
||||||
|
renderDrawing :: Drawing -> IO (Diagram B)
|
||||||
renderDrawing (Drawing nameIconMap edges subDrawings) = do
|
renderDrawing (Drawing nameIconMap edges subDrawings) = do
|
||||||
subDiagramMap <- mapM subDrawingMapper subDrawings
|
subDiagramMap <- mapM subDrawingMapper subDrawings
|
||||||
let diagramMap = makeNamedMap subDiagramMap nameIconMap
|
let diagramMap = makeNamedMap subDiagramMap nameIconMap
|
||||||
--mapM_ (putStrLn . (++"\n") . show . (map fst) . names . snd) diagramMap
|
--mapM_ (putStrLn . (++"\n") . show . (map fst) . names . snd) diagramMap
|
||||||
doGraphLayout (edgesToGraph iconNames edges) diagramMap (makeConnections edges) edges
|
doGraphLayout (edgesToGraph iconNames connections) diagramMap (makeConnections edges) connections
|
||||||
where
|
where
|
||||||
|
connections = map edgeConnection edges
|
||||||
iconNames = map fst nameIconMap
|
iconNames = map fst nameIconMap
|
||||||
subDrawingMapper (name, subDrawing) = do
|
subDrawingMapper (name, subDrawing) = do
|
||||||
subDiagram <- renderDrawing subDrawing
|
subDiagram <- renderDrawing subDrawing
|
||||||
|
26
app/Types.hs
Normal file
26
app/Types.hs
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||||
|
|
||||||
|
module Types where
|
||||||
|
|
||||||
|
import Diagrams.Prelude(Name)
|
||||||
|
|
||||||
|
-- TYPES --
|
||||||
|
-- | A datatype that represents an icon.
|
||||||
|
-- The BranchIcon is used as a branching point for a line.
|
||||||
|
-- The TextBoxIcon's data is the text that appears in the text box.
|
||||||
|
-- The LambdaRegionIcon's data is the number of lambda ports, and the name of it's
|
||||||
|
-- subdrawing.
|
||||||
|
data Icon = Apply0Icon | ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
|
||||||
|
| LambdaRegionIcon Int Name | Apply0NIcon Int
|
||||||
|
|
||||||
|
type Connection = (Name, Maybe Int, Name, Maybe Int)
|
||||||
|
|
||||||
|
-- | 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.
|
||||||
|
data Edge = Edge {edgeConnection :: Connection, edgeEnds :: (EdgeEndType, EdgeEndType)}
|
||||||
|
|
||||||
|
data EdgeEndType = Ap1Result | Ap1Arg | NoEnd
|
||||||
|
|
||||||
|
-- | A drawing is a map from names to Icons, a list of edges,
|
||||||
|
-- and a map of names to subDrawings
|
||||||
|
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)]
|
@ -31,8 +31,9 @@ executable glance-exe
|
|||||||
, diagrams-graphviz
|
, diagrams-graphviz
|
||||||
, graphviz
|
, graphviz
|
||||||
, containers
|
, containers
|
||||||
|
, fgl
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
Other-modules: Icons, Rendering
|
Other-modules: Icons, Rendering, Types
|
||||||
|
|
||||||
test-suite glance-test
|
test-suite glance-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
|
Loading…
Reference in New Issue
Block a user