mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Clean up graphviz stuff.
This commit is contained in:
parent
0f3c0cf2de
commit
ca1caa96b2
18
app/Icons.hs
18
app/Icons.hs
@ -7,6 +7,7 @@ module Icons
|
||||
drawIconsAndPortNumbers,
|
||||
PortName(..),
|
||||
nameDiagram,
|
||||
connectMaybePorts,
|
||||
connectPorts,
|
||||
connectIconToPort,
|
||||
connectIcons,
|
||||
@ -36,17 +37,26 @@ nameDiagram name dia = name .>> (dia # named name)
|
||||
|
||||
arrowOptions = with & arrowHead .~ noHead & shaftStyle %~ lwG defaultLineWidth . lc white
|
||||
|
||||
connectPorts icon0 port0 icon1 port1 =
|
||||
connectMaybePorts icon0 (Just port0) icon1 (Just port1) =
|
||||
connect'
|
||||
arrowOptions
|
||||
(icon0 .> port0)
|
||||
(icon1 .> port1)
|
||||
connectMaybePorts icon0 Nothing icon1 (Just port1) =
|
||||
connectOutside' arrowOptions icon0 (icon1 .> port1)
|
||||
connectMaybePorts icon0 (Just port0) icon1 Nothing =
|
||||
connectOutside' arrowOptions (icon0 .> port0) icon1
|
||||
connectMaybePorts icon0 Nothing icon1 Nothing =
|
||||
connectOutside' arrowOptions icon0 icon1
|
||||
|
||||
connectPorts icon0 port0 icon1 port1 =
|
||||
connectMaybePorts icon0 (Just port0) icon1 (Just port1)
|
||||
|
||||
connectIconToPort icon0 icon1 port1 =
|
||||
connectOutside' arrowOptions icon0 (icon1 .> port1)
|
||||
connectMaybePorts icon0 (Nothing :: Maybe PortName) icon1 (Just port1)
|
||||
|
||||
connectIcons =
|
||||
connectOutside' arrowOptions
|
||||
connectIcons icon0 icon1 =
|
||||
connectMaybePorts icon0 (Nothing:: Maybe PortName) icon1 (Nothing :: Maybe PortName)
|
||||
|
||||
-- | Draw the icon with circles where the ports are
|
||||
drawIconAndPorts :: Icon B -> Diagram B
|
||||
|
120
app/Main.hs
120
app/Main.hs
@ -14,69 +14,101 @@ import Data.Maybe (fromMaybe)
|
||||
import Lib
|
||||
import Icons
|
||||
|
||||
-- todo: refactor and clean up
|
||||
|
||||
ex1 = drawIconAndPorts apply0Icon
|
||||
ex2 = drawIconsAndPortNumbers apply0Icon
|
||||
-- todo: Put
|
||||
|
||||
applyDia = iconDia apply0Icon
|
||||
--apply0A = "A" .>> applyDia
|
||||
apply0A = applyDia # nameDiagram "A"
|
||||
apply0B = applyDia # nameDiagram "B"
|
||||
result = resultIcon # named "res"
|
||||
fooBox = textBox "foo" # named "foo"
|
||||
barBox = textBox "bar" # named "bar"
|
||||
-- --apply0A = "A" .>> applyDia
|
||||
-- apply0A = applyDia # nameDiagram "A"
|
||||
-- apply0B = applyDia # nameDiagram "B"
|
||||
-- result = resultIcon # named "res"
|
||||
-- fooBox = textBox "foo" # named "foo"
|
||||
-- barBox = textBox "bar" # named "bar"
|
||||
|
||||
graph = mkGraph ["A", "B", "res", "foo", "bar"]
|
||||
[("A", "B", ()),
|
||||
("res", "A", ()),
|
||||
("bar", "B", ()),
|
||||
("foo", "B", ())
|
||||
-- ex1 = drawIconAndPorts apply0Icon
|
||||
-- ex2 = drawIconsAndPortNumbers apply0Icon
|
||||
--ex3 = atPoints (map p2 [(0,0), (3,0)]) [apply0A, apply0B]
|
||||
|
||||
-- fromAtoB = ex3 # connectPorts "A" (PortName 0) "B" (PortName 2)
|
||||
--ex4 = apply0A ||| textBox "hello world" === textBox "1" === textBox "gpq" === textBox ['A'..'Z']
|
||||
|
||||
-- ex5 = resultIcon # named "res"||| hrule 1 ||| fromAtoB ||| hrule 1 ||| textBox "foo" # named "foo" === vrule 1 === textBox "bar" # named "bar"
|
||||
-- ex6 = ex5 # connectIconToPort "res" "A" (PortName 2) # connectIconToPort "foo" "B" (PortName 0)
|
||||
-- # connectIconToPort "bar" "B" (PortName 3) # centerXY
|
||||
--
|
||||
-- ex7 = ex6 # center # showOrigin # showEnvelope
|
||||
-- ex8 = enclosure ex6
|
||||
-- ex9 = lambdaRegion 3 ex6 "lam0"
|
||||
-- ex10 = ex9 # connectPorts ("lam0" .> "A") (PortName 1) "lam0" (PortName 0)
|
||||
-- # connectPorts ("lam0" .> "B") (PortName 1) "lam0" (PortName 2)
|
||||
-- ex11 = connectIcons "lam0" "y" $ ex10 === vrule 2 === textBox "y" # named "y"
|
||||
|
||||
makeNamedMap :: (IsName a) => [(a, Diagram B)] -> [(a, Diagram B)]
|
||||
makeNamedMap =
|
||||
map (\(label, dia) -> (label, dia # nameDiagram label))
|
||||
|
||||
labelDiagramMap = makeNamedMap
|
||||
[("A", applyDia ),
|
||||
("B", applyDia),
|
||||
("res", resultIcon),
|
||||
("foo", textBox "foo"),
|
||||
("bar", textBox "bar")
|
||||
]
|
||||
|
||||
labelToDiagram =
|
||||
[("A", apply0A),
|
||||
("B", apply0B),
|
||||
("res", result),
|
||||
("foo", fooBox),
|
||||
("bar", barBox)
|
||||
labels = map fst labelDiagramMap
|
||||
|
||||
portToPort a b c d = (a, Just $ PortName b, c, Just $ PortName d)
|
||||
iconToPort a c d = (a, Nothing, c, Just $ PortName d)
|
||||
iconToIcon a c = (a, Nothing, c, Nothing)
|
||||
|
||||
edges =
|
||||
[
|
||||
portToPort "A" 0 "B" 2,
|
||||
iconToPort "foo" "B" 0,
|
||||
iconToPort "res" "A" 2,
|
||||
iconToPort "foo" "B" 0,
|
||||
iconToPort "bar" "B" 3,
|
||||
iconToPort "bar" "A" 3
|
||||
]
|
||||
|
||||
ex3 = atPoints (map p2 [(0,0), (3,0)]) [apply0A, apply0B]
|
||||
edgesToGraph labels edges = mkGraph labels simpleEdges
|
||||
where
|
||||
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
||||
|
||||
fromAtoB = ex3 # connectPorts "A" (PortName 0) "B" (PortName 2)
|
||||
ex4 = apply0A ||| textBox "hello world" === textBox "1" === textBox "gpq" === textBox ['A'..'Z']
|
||||
graph = edgesToGraph labels edges
|
||||
|
||||
ex5 = resultIcon # named "res"||| hrule 1 ||| fromAtoB ||| hrule 1 ||| textBox "foo" # named "foo" === vrule 1 === textBox "bar" # named "bar"
|
||||
ex6 = ex5 # connectIconToPort "res" "A" (PortName 2) # connectIconToPort "foo" "B" (PortName 0)
|
||||
# connectIconToPort "bar" "B" (PortName 3) # centerXY
|
||||
uncurry4 f (a, b, c, d) = f a b c d
|
||||
|
||||
ex7 = ex6 # center # showOrigin # showEnvelope
|
||||
ex8 = enclosure ex6
|
||||
ex9 = lambdaRegion 3 ex6 # nameDiagram "lam0"
|
||||
ex10 = ex9 # connectPorts ("lam0" .> "A") (PortName 1) "lam0" (PortName 0)
|
||||
# connectPorts ("lam0" .> "B") (PortName 1) "lam0" (PortName 2)
|
||||
ex11 = connectIcons "lam0" "y" $ ex10 === vrule 2 === textBox "y" # named "y"
|
||||
makeConnections edges = applyAll connections
|
||||
where
|
||||
connections = map (uncurry4 connectMaybePorts) edges
|
||||
|
||||
|
||||
placeNodes layoutResult = mconcat placedNodes
|
||||
placeNodes scaleFactor layoutResult labelDiagramMap = mconcat placedNodes
|
||||
where
|
||||
(positionMap, _) = getGraph layoutResult
|
||||
placedNodes = map (\label -> place (fromMaybe mempty $ lookup label labelToDiagram) (0.04 * positionMap ! label)) $ map fst labelToDiagram
|
||||
placedNodes = map mapper labels
|
||||
mapper label = placedNode
|
||||
where
|
||||
maybeDiagram = lookup label labelDiagramMap
|
||||
placedNode = place
|
||||
(fromMaybe (error "placeNodes: label not in map") maybeDiagram)
|
||||
(scaleFactor * positionMap ! label)
|
||||
|
||||
connectNodes g =
|
||||
g # connectIconToPort "res" "A" (PortName 2) # connectIconToPort "foo" "B" (PortName 0)
|
||||
# connectIconToPort "bar" "B" (PortName 3) # connectPorts "A" (PortName 0) "B" (PortName 2)
|
||||
-- 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)
|
||||
-- # connectIconToPort "bar" "B" (PortName 3) # connectPorts "A" (PortName 0) "B" (PortName 2)
|
||||
-- # connectIconToPort "bar" "A" (PortName 3)
|
||||
|
||||
doGraphLayout :: IO (Diagram B)
|
||||
doGraphLayout = do
|
||||
connectNodes = makeConnections edges
|
||||
|
||||
doGraphLayout graph labelDiagramMap connectNodes = do
|
||||
layoutResult <- layoutGraph Neato graph
|
||||
return $ placeNodes layoutResult # connectNodes
|
||||
return $ placeNodes 0.04 layoutResult labelDiagramMap # connectNodes
|
||||
|
||||
main1 = mainWith (ex11 # bgFrame 0.1 black)
|
||||
--main1 = mainWith (ex11 # bgFrame 0.1 black)
|
||||
|
||||
main0 = do
|
||||
placedNodes <- doGraphLayout
|
||||
placedNodes <- doGraphLayout graph labelDiagramMap connectNodes
|
||||
mainWith (placedNodes # bgFrame 0.1 black)
|
||||
|
||||
main :: IO ()
|
||||
|
@ -30,6 +30,7 @@ executable glance-exe
|
||||
, diagrams-svg
|
||||
, diagrams-graphviz
|
||||
, graphviz
|
||||
, containers
|
||||
default-language: Haskell2010
|
||||
Other-modules: Icons
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user