mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
clean up
This commit is contained in:
parent
120dc18b88
commit
2ac3ee04a7
84
app/Icons.hs
84
app/Icons.hs
@ -6,12 +6,8 @@ module Icons
|
|||||||
iconToDiagram,
|
iconToDiagram,
|
||||||
--drawIconAndPorts,
|
--drawIconAndPorts,
|
||||||
--drawIconsAndPortNumbers,
|
--drawIconsAndPortNumbers,
|
||||||
PortName(..),
|
|
||||||
nameDiagram,
|
nameDiagram,
|
||||||
connectMaybePorts,
|
connectMaybePorts,
|
||||||
connectPorts,
|
|
||||||
connectIconToPort,
|
|
||||||
connectIcons,
|
|
||||||
textBox,
|
textBox,
|
||||||
enclosure,
|
enclosure,
|
||||||
lambdaRegion,
|
lambdaRegion,
|
||||||
@ -19,15 +15,18 @@ module Icons
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude
|
||||||
import Diagrams.Backend.SVG.CmdLine
|
import Diagrams.Backend.SVG(B)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
|
||||||
|
-- TYPES --
|
||||||
-- | A datatype that represents an icon.
|
-- | A datatype that represents an icon.
|
||||||
-- The TextBoxIcon's data is the text that appears in the text box.
|
-- 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
|
-- The LambdaRegionIcon's data is the number of lambda ports, and the name of it's
|
||||||
-- subdrawing.
|
-- subdrawing.
|
||||||
data Icon = Apply0Icon | ResultIcon | TextBoxIcon String | LambdaRegionIcon Int Name
|
data Icon = Apply0Icon | ResultIcon | TextBoxIcon String | LambdaRegionIcon Int Name
|
||||||
|
|
||||||
|
-- FUNCTIONS --
|
||||||
|
|
||||||
iconToDiagram Apply0Icon _ = apply0Dia
|
iconToDiagram Apply0Icon _ = apply0Dia
|
||||||
iconToDiagram ResultIcon _ = resultIcon
|
iconToDiagram ResultIcon _ = resultIcon
|
||||||
iconToDiagram (TextBoxIcon s) _ = textBox s
|
iconToDiagram (TextBoxIcon s) _ = textBox s
|
||||||
@ -35,13 +34,6 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap = lambdaRegio
|
|||||||
where
|
where
|
||||||
dia = fromMaybe (error "iconToDiagram: subdiagram not found") $ lookup diagramName nameToSubdiagramMap
|
dia = fromMaybe (error "iconToDiagram: subdiagram not found") $ lookup diagramName nameToSubdiagramMap
|
||||||
|
|
||||||
-- | PortName is a simple wrapper around Int that is used for the diagram names
|
|
||||||
-- of all the ports.
|
|
||||||
instance IsName PortName
|
|
||||||
newtype PortName = PortName Int deriving (Show, Ord, Eq)
|
|
||||||
|
|
||||||
defaultLineWidth = 0.15
|
|
||||||
|
|
||||||
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
||||||
nameDiagram name dia = name .>> (dia # named name)
|
nameDiagram name dia = name .>> (dia # named name)
|
||||||
|
|
||||||
@ -59,51 +51,33 @@ connectMaybePorts icon0 (Just port0) icon1 Nothing =
|
|||||||
connectMaybePorts icon0 Nothing icon1 Nothing =
|
connectMaybePorts icon0 Nothing icon1 Nothing =
|
||||||
connectOutside' arrowOptions icon0 icon1
|
connectOutside' arrowOptions icon0 icon1
|
||||||
|
|
||||||
connectPorts icon0 port0 icon1 port1 =
|
makePort :: Int -> Diagram B
|
||||||
connectMaybePorts icon0 (Just port0) icon1 (Just port1)
|
makePort x = mempty # named x
|
||||||
|
|
||||||
connectIconToPort icon0 icon1 port1 =
|
|
||||||
connectMaybePorts icon0 (Nothing :: Maybe PortName) icon1 (Just port1)
|
|
||||||
|
|
||||||
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
|
|
||||||
-- drawIconAndPorts (Icon dia ports) =
|
|
||||||
-- vertCircles <> dia
|
|
||||||
-- where
|
|
||||||
-- vertCircles = atPoints ports $ repeat $ circle 0.05 # lw none # fc blue
|
|
||||||
--
|
|
||||||
-- drawIconsAndPortNumbers :: Icon B -> Diagram B
|
|
||||||
-- drawIconsAndPortNumbers (Icon dia ports) =
|
|
||||||
-- portNumbers <> dia
|
|
||||||
-- where
|
|
||||||
-- portNumbers = atPoints ports $ map makeNumDia [0,1..]
|
|
||||||
-- makeNumDia num = text (show num) # fontSize (local 0.1) # fc blue <> square 0.1 # fc white
|
|
||||||
|
|
||||||
-- APPLY 0 ICON --
|
|
||||||
circleRadius = 0.5
|
|
||||||
apply0LineWidth = defaultLineWidth
|
|
||||||
|
|
||||||
resultCircle :: Diagram B
|
|
||||||
resultCircle = circle circleRadius # fc red # lw none
|
|
||||||
|
|
||||||
apply0Triangle :: Diagram B
|
|
||||||
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc red # lw none
|
|
||||||
|
|
||||||
apply0Line :: Diagram B
|
|
||||||
apply0Line = rect apply0LineWidth (2 * circleRadius) # fc white # lw none
|
|
||||||
|
|
||||||
apply0Dia :: Diagram B
|
|
||||||
apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams verts
|
|
||||||
|
|
||||||
makePort x = mempty # named (PortName x)
|
|
||||||
|
|
||||||
makePortDiagrams points =
|
makePortDiagrams points =
|
||||||
atPoints points (map makePort [0,1..])
|
atPoints points (map makePort [0,1..])
|
||||||
|
|
||||||
verts = map p2 [
|
-- CONSTANTS --
|
||||||
|
defaultLineWidth = 0.15
|
||||||
|
|
||||||
|
-- APPLY0 ICON --
|
||||||
|
circleRadius = 0.5
|
||||||
|
apply0LineWidth = defaultLineWidth
|
||||||
|
|
||||||
|
--resultCircle :: Diagram B
|
||||||
|
resultCircle = circle circleRadius # fc red # lw none
|
||||||
|
|
||||||
|
--apply0Triangle :: Diagram B
|
||||||
|
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc red # lw none
|
||||||
|
|
||||||
|
--apply0Line :: Diagram B
|
||||||
|
apply0Line = rect apply0LineWidth (2 * circleRadius) # fc white # lw none
|
||||||
|
|
||||||
|
--apply0Dia :: Diagram B
|
||||||
|
apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations
|
||||||
|
|
||||||
|
apply0PortLocations = map p2 [
|
||||||
(circleRadius + apply0LineWidth + triangleWidth, 0),
|
(circleRadius + apply0LineWidth + triangleWidth, 0),
|
||||||
(lineCenter,circleRadius),
|
(lineCenter,circleRadius),
|
||||||
(-circleRadius,0),
|
(-circleRadius,0),
|
||||||
@ -117,7 +91,7 @@ textBoxFontSize = 1
|
|||||||
monoLetterWidthToHeightFraction = 0.6
|
monoLetterWidthToHeightFraction = 0.6
|
||||||
textBoxHeightFactor = 1.1
|
textBoxHeightFactor = 1.1
|
||||||
|
|
||||||
textBox :: String -> Diagram B
|
--textBox :: String -> Diagram B
|
||||||
textBox = coloredTextBox white $ opaque white
|
textBox = coloredTextBox white $ opaque white
|
||||||
|
|
||||||
-- Since the normal SVG text has no size, some hackery is needed to determine
|
-- Since the normal SVG text has no size, some hackery is needed to determine
|
||||||
@ -142,7 +116,9 @@ lambdaIcon x = coloredTextBox lime transparent "λ" # alignB <> makePort x
|
|||||||
|
|
||||||
-- | lambdaRegion takes as an argument the numbers of parameters to the lambda,
|
-- | lambdaRegion takes as an argument the numbers of parameters to the lambda,
|
||||||
-- and draws the diagram inside a region with the lambda icons on top.
|
-- and draws the diagram inside a region with the lambda icons on top.
|
||||||
lambdaRegion n dia = centerXY $ hsep 0.4 (take n (map lambdaIcon [0,1..])) # centerX === (enclosure dia # centerX)
|
lambdaRegion n dia =
|
||||||
|
centerXY $ lambdaIcons # centerX === (enclosure dia # centerX)
|
||||||
|
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
||||||
|
|
||||||
-- RESULT ICON --
|
-- RESULT ICON --
|
||||||
resultIcon = unitSquare # lw none # fc lime
|
resultIcon = unitSquare # lw none # fc lime
|
||||||
|
@ -15,8 +15,6 @@ import Lib
|
|||||||
import Icons
|
import Icons
|
||||||
import Rendering
|
import Rendering
|
||||||
|
|
||||||
-- todo: Clean up. Put renderDrawing code in a new file.
|
|
||||||
|
|
||||||
-- todo: Give graphviz info about the size of the nodes such that a variable scaleFactor
|
-- 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)
|
-- todo: Test with more lambdas, (eg. two per layer, 3 or more layers)
|
||||||
-- for subDiagrams is not necessary.
|
-- for subDiagrams is not necessary.
|
||||||
@ -94,8 +92,9 @@ superDrawing = Drawing superIcons superEdges [(d0Name, drawing0)]
|
|||||||
|
|
||||||
--main1 = mainWith (ex11 # bgFrame 0.1 black)
|
--main1 = mainWith (ex11 # bgFrame 0.1 black)
|
||||||
|
|
||||||
|
main1 :: IO ()
|
||||||
main1 = do
|
main1 = do
|
||||||
placedNodes <- renderDrawing superDrawing 0.1
|
placedNodes <- renderDrawing superDrawing (0.1 :: Double)
|
||||||
mainWith (placedNodes # bgFrame 0.1 black)
|
mainWith (placedNodes # bgFrame 0.1 black)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
@ -12,8 +12,8 @@ import Diagrams.Prelude
|
|||||||
import Diagrams.TwoD.GraphViz
|
import Diagrams.TwoD.GraphViz
|
||||||
|
|
||||||
import Data.GraphViz
|
import Data.GraphViz
|
||||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
--import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||||
import Data.GraphViz.Commands
|
--import Data.GraphViz.Commands
|
||||||
import Data.Map((!))
|
import Data.Map((!))
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
|
||||||
@ -21,7 +21,8 @@ import Icons
|
|||||||
|
|
||||||
-- | A drawing is a map from names to Icons, a list of edges,
|
-- | A drawing is a map from names to Icons, a list of edges,
|
||||||
-- and a map of names to subDrawings
|
-- and a map of names to subDrawings
|
||||||
data Drawing b = Drawing [(Name, Icon)] b [(Name, Drawing b)]
|
type Edge = (Name, Maybe Int, Name, Maybe Int)
|
||||||
|
data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)]
|
||||||
|
|
||||||
makeNamedMap subDiagramMap =
|
makeNamedMap subDiagramMap =
|
||||||
map (\(label, dia) -> (label, iconToDiagram dia subDiagramMap # nameDiagram label))
|
map (\(label, dia) -> (label, iconToDiagram dia subDiagramMap # nameDiagram label))
|
||||||
@ -31,8 +32,8 @@ 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 a b c d = (toName a, Just $ PortName b, toName c, Just $ PortName d)
|
portToPort a b c d = (toName a, Just b, toName c, Just d)
|
||||||
iconToPort a c d = (toName a, Nothing, toName c, Just $ PortName d)
|
iconToPort a c d = (toName a, Nothing, toName c, Just d)
|
||||||
iconToIcon a c = (toName a, Nothing, toName c, Nothing)
|
iconToIcon a c = (toName a, Nothing, toName c, Nothing)
|
||||||
|
|
||||||
edgesToGraph labels edges = mkGraph labels simpleEdges
|
edgesToGraph labels edges = mkGraph labels simpleEdges
|
||||||
@ -55,7 +56,7 @@ placeNodes scaleFactor layoutResult labelDiagramMap = mconcat placedNodes
|
|||||||
placedNode = place
|
placedNode = place
|
||||||
diagram
|
diagram
|
||||||
--(fromMaybe (error ("placeNodes: label not in map: " ++ (show (map fst labelDiagramMap)))) maybeDiagram)
|
--(fromMaybe (error ("placeNodes: label not in map: " ++ (show (map fst labelDiagramMap)))) maybeDiagram)
|
||||||
(scaleFactor * positionMap ! label)
|
(scaleFactor *^ (positionMap ! label))
|
||||||
|
|
||||||
doGraphLayout scaleFactor graph labelDiagramMap connectNodes = do
|
doGraphLayout scaleFactor graph labelDiagramMap connectNodes = do
|
||||||
layoutResult <- layoutGraph Neato graph
|
layoutResult <- layoutGraph Neato graph
|
||||||
|
@ -32,7 +32,7 @@ executable glance-exe
|
|||||||
, graphviz
|
, graphviz
|
||||||
, containers
|
, containers
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
Other-modules: Icons
|
Other-modules: Icons, Rendering
|
||||||
|
|
||||||
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