mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Remove the backend as an import for all files except Main.hs. Add type signitures.
This commit is contained in:
parent
041032dc94
commit
5e34428b50
90
app/Icons.hs
90
app/Icons.hs
@ -1,11 +1,9 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, RankNTypes #-}
|
||||
module Icons
|
||||
(
|
||||
Icon(..),
|
||||
apply0Dia,
|
||||
iconToDiagram,
|
||||
--drawIconAndPorts,
|
||||
--drawIconsAndPortNumbers,
|
||||
nameDiagram,
|
||||
textBox,
|
||||
enclosure,
|
||||
@ -19,8 +17,10 @@ module Icons
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.Backend.SVG(B)
|
||||
-- import Diagrams.Backend.SVG(B)
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Types(Icon(..), Edge(..))
|
||||
|
||||
@ -80,10 +80,15 @@ randomColorScheme = ColorStyle {
|
||||
regionPerimC = cyan
|
||||
}
|
||||
|
||||
lineCol :: (Floating a, Ord a) => Colour a
|
||||
lineCol = lineC colorScheme
|
||||
|
||||
-- FUNCTIONS --
|
||||
|
||||
iconToDiagram ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Text n) b) =>
|
||||
Icon -> [(Name, QDiagram b V2 n Any)] -> QDiagram b V2 n Any
|
||||
iconToDiagram Apply0Icon _ = apply0Dia
|
||||
iconToDiagram (Apply0NIcon n) _ = apply0NDia n
|
||||
iconToDiagram ResultIcon _ = resultIcon
|
||||
@ -96,18 +101,24 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap =
|
||||
dia = fromMaybe (error "iconToDiagram: subdiagram not found") $ lookup diagramName nameToSubdiagramMap
|
||||
|
||||
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
||||
nameDiagram :: (Floating n, Ord n, Semigroup m, Metric v, IsName nm) => nm -> QDiagram b v n m -> QDiagram b v n m
|
||||
nameDiagram name dia = name .>> (dia # named name)
|
||||
|
||||
-- | Make an port with an integer name. Always use <> to add a ports (not === or |||)
|
||||
--- since mempty has no size and will not be placed where you want it.
|
||||
makePort :: Int -> Diagram B
|
||||
makePort :: (Floating n, Ord n, Semigroup m, Metric v) => Int -> QDiagram b v n m
|
||||
makePort x = mempty # named x
|
||||
--makePort x = circle 0.2 # fc green # named x
|
||||
--makePort x = textBox (show x) # fc green # named x
|
||||
|
||||
|
||||
--makePortDiagrams :: [P2 Double] -> Diagram B
|
||||
--makePortDiagrams ::(Monoid a, Semigroup a, HasOrigin a, b ~ N a) => [P2 b] -> GeneralDiagram a
|
||||
makePortDiagrams ::
|
||||
(Floating n, Ord n, Semigroup m, Metric v) =>
|
||||
[Point v n] -> QDiagram b v n m
|
||||
makePortDiagrams points =
|
||||
atPoints points (map makePort [0,1..])
|
||||
atPoints points (map makePort ([0,1..] :: [Int]))
|
||||
|
||||
-- CONSTANTS --
|
||||
defaultLineWidth = 0.15
|
||||
@ -116,18 +127,32 @@ defaultLineWidth = 0.15
|
||||
circleRadius = 0.5
|
||||
apply0LineWidth = defaultLineWidth
|
||||
|
||||
--resultCircle :: Diagram B
|
||||
type GeneralDiagram b = (Transformable b, RealFloat (N b), Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
||||
|
||||
resultCircle ::
|
||||
(RealFloat (N b), Typeable (N b), Transformable b, HasStyle b,
|
||||
TrailLike b, V b ~ V2) =>
|
||||
b
|
||||
resultCircle = circle circleRadius # fc (apply0C colorScheme) # lw none
|
||||
|
||||
--apply0Triangle :: Diagram B
|
||||
apply0Triangle ::
|
||||
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
||||
V b ~ V2) =>
|
||||
b
|
||||
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # fc (apply0C colorScheme) # lw none
|
||||
|
||||
--apply0Line :: Diagram B
|
||||
apply0Line ::
|
||||
(Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
||||
apply0Line = rect apply0LineWidth (2 * circleRadius) # fc lineCol # lw none
|
||||
|
||||
--apply0Dia :: Diagram B
|
||||
--apply0Dia :: (Juxtaposable a, Semigroup a) => GeneralDiagram a
|
||||
apply0Dia ::
|
||||
(RealFloat n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
QDiagram b V2 n m
|
||||
apply0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations # centerXY
|
||||
|
||||
apply0PortLocations :: Floating a => [P2 a]
|
||||
apply0PortLocations = map p2 [
|
||||
(circleRadius + apply0LineWidth + triangleWidth, 0),
|
||||
(lineCenter,circleRadius),
|
||||
@ -139,7 +164,10 @@ apply0PortLocations = map p2 [
|
||||
|
||||
-- apply0N Icon--
|
||||
|
||||
apply0NDia :: Int -> Diagram B
|
||||
apply0NDia ::
|
||||
(RealFloat n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
Int -> QDiagram b V2 n m
|
||||
apply0NDia n = finalDia # centerXY where
|
||||
seperation = circleRadius * 1.5
|
||||
trianglePortsCircle = hcat [
|
||||
@ -157,11 +185,19 @@ textBoxFontSize = 1
|
||||
monoLetterWidthToHeightFraction = 0.6
|
||||
textBoxHeightFactor = 1.1
|
||||
|
||||
--textBox :: String -> Diagram B
|
||||
textBox ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Text n) b) =>
|
||||
String -> QDiagram b V2 n Any
|
||||
textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme)
|
||||
|
||||
-- Since the normal SVG text has no size, some hackery is needed to determine
|
||||
-- the size of the text's bounding box.
|
||||
coloredTextBox ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Diagrams.TwoD.Text.Text n) b) =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> QDiagram b V2 n Any
|
||||
coloredTextBox textColor boxColor t =
|
||||
text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
|
||||
<> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor
|
||||
@ -171,38 +207,58 @@ coloredTextBox textColor boxColor t =
|
||||
+ (textBoxFontSize * 0.2)
|
||||
|
||||
-- ENCLOSING REGION --
|
||||
enclosure ::
|
||||
(Floating n, Ord n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
QDiagram b V2 n m -> QDiagram b V2 n m
|
||||
enclosure dia = dia <> boundingRect (dia # frame 0.5) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
||||
|
||||
-- LAMBDA ICON --
|
||||
-- Don't use === here to put the port under the text box since mempty will stay
|
||||
-- at the origin of the text box.
|
||||
lambdaIcon ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Diagrams.TwoD.Text.Text n) b) =>
|
||||
Int -> QDiagram b V2 n Any
|
||||
lambdaIcon x = coloredTextBox (lamArgResC colorScheme) transparent "λ" # alignB <> makePort x
|
||||
|
||||
-- LAMBDA REGION --
|
||||
|
||||
-- | 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.
|
||||
lambdaRegion ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Diagrams.TwoD.Text.Text n) b) =>
|
||||
Int -> QDiagram b V2 n Any -> QDiagram b V2 n Any
|
||||
lambdaRegion n dia =
|
||||
centerXY $ lambdaIcons # centerX === (enclosure dia # centerX)
|
||||
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
||||
|
||||
-- RESULT ICON --
|
||||
resultIcon ::
|
||||
(Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
||||
resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
|
||||
|
||||
-- BRANCH ICON --
|
||||
branchIcon :: Diagram B
|
||||
branchIcon :: GeneralDiagram a
|
||||
branchIcon = circle 0.3 # fc lineCol # lc lineCol
|
||||
|
||||
-- GUARD ICON --
|
||||
guardSize = 0.7
|
||||
guardTriangle :: Int -> Diagram B
|
||||
|
||||
guardTriangle ::
|
||||
(Floating n, Ord n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
Int -> QDiagram b V2 n m
|
||||
guardTriangle x =
|
||||
((triangleAndPort ||| (hrule (guardSize * 0.8) # lc lineCol # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
|
||||
where
|
||||
triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
|
||||
# rotateBy (1/8)# lc lineCol # lwG defaultLineWidth # alignT # alignR
|
||||
|
||||
guardLBracket :: Int -> Diagram B
|
||||
guardLBracket ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Int -> QDiagram b V2 n Any
|
||||
guardLBracket x = ell # alignT # alignL <> makePort x
|
||||
where
|
||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
||||
@ -213,7 +269,9 @@ guardLBracket x = ell # alignT # alignL <> makePort x
|
||||
-- Port 1: Bottom result port
|
||||
-- Ports 3,5...: The left ports for the booleans
|
||||
-- Ports 2,4...: The right ports for the values
|
||||
guardIcon :: Int -> Diagram B
|
||||
guardIcon ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Int -> QDiagram b V2 n Any
|
||||
guardIcon n = centerXY $ makePort 1 <> alignB (vcat (take n trianglesAndBrackets # alignT) <> makePort 0)
|
||||
where
|
||||
--guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
|
||||
|
@ -235,9 +235,9 @@ arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges []
|
||||
main1 :: IO ()
|
||||
main1 = do
|
||||
placedNodes <- renderDrawing factLam1Drawing
|
||||
mainWith (placedNodes # bgFrame 1 (backgroundC colorScheme))
|
||||
mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
|
||||
main2 = mainWith (apply0NDia 3 # bgFrame 0.1 black)
|
||||
main2 = mainWith ((apply0NDia 3 # bgFrame 0.1 black) :: Diagram B)
|
||||
|
||||
main :: IO ()
|
||||
main = main1
|
||||
|
@ -6,7 +6,8 @@ module Rendering (
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
import Diagrams.Backend.SVG(B)
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
--import Diagrams.Backend.SVG(B)
|
||||
|
||||
import qualified Data.GraphViz as GV
|
||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||
@ -25,7 +26,12 @@ import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
|
||||
-- | Convert a map of names and icons, to a list of names and diagrams.
|
||||
-- The first argument is the subdiagram map used for the inside of lambdaIcons
|
||||
-- The second argument is the map of icons that should be converted to diagrams.
|
||||
makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram B)]
|
||||
--makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram B)]
|
||||
makeNamedMap ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Diagrams.TwoD.Text.Text n) b, IsName nm) =>
|
||||
[(Name, QDiagram b V2 n Any)]
|
||||
-> [(nm, Icon)] -> [(nm, QDiagram b V2 n Any)]
|
||||
makeNamedMap subDiagramMap =
|
||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name))
|
||||
|
||||
@ -68,9 +74,12 @@ getArrowOpts (t, h) = arrowOptions
|
||||
& shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
|
||||
& lookupTail t & lookupHead h
|
||||
|
||||
plainLine :: (RealFloat n, Typeable n) => ArrowOpts n
|
||||
plainLine = getArrowOpts (EndNone, EndNone)
|
||||
|
||||
connectMaybePorts :: Edge -> Diagram B -> Diagram B
|
||||
connectMaybePorts ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Edge -> QDiagram b V2 n Any -> QDiagram b V2 n Any
|
||||
connectMaybePorts (Edge (icon0, Just port0, icon1, Just port1) ends) =
|
||||
connect'
|
||||
(getArrowOpts ends)
|
||||
@ -83,7 +92,9 @@ connectMaybePorts (Edge (icon0, Just port0, icon1, Nothing) ends) =
|
||||
connectMaybePorts (Edge (icon0, Nothing, icon1, Nothing) ends) =
|
||||
connectOutside' (getArrowOpts ends) icon0 icon1
|
||||
|
||||
makeConnections :: [Edge] -> Diagram B -> Diagram B
|
||||
makeConnections ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
[Edge] -> QDiagram b V2 n Any -> QDiagram b V2 n Any
|
||||
makeConnections edges = applyAll connections
|
||||
where
|
||||
connections = map connectMaybePorts edges
|
||||
@ -133,7 +144,12 @@ getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name)
|
||||
-- are minimized.
|
||||
-- Precondition: the diagrams are already centered
|
||||
-- todo: confirm precondition (or use a newtype)
|
||||
rotateNodes :: Map.Map Name (Point V2 Double) -> [(Name, Diagram B)] -> [Connection] -> [(Name, Diagram B)]
|
||||
rotateNodes ::
|
||||
Semigroup m =>
|
||||
Map.Map Name (Point V2 Double)
|
||||
-> [(Name, QDiagram b V2 Double m)]
|
||||
-> [Connection]
|
||||
-> [(Name, QDiagram b V2 Double m)]
|
||||
rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||
where
|
||||
rotateDiagram (name, dia) = (name, diaToUse)
|
||||
@ -144,7 +160,7 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||
diaToUse = if flippedDist < unflippedDist
|
||||
then rotateBy flippedAngle flippedDia
|
||||
else rotateBy unflippedAngle dia
|
||||
minAngleForDia :: Diagram B -> (Double, Double)
|
||||
--minAngleForDia :: Diagram B -> (Double, Double)
|
||||
minAngleForDia dia = minAngle where
|
||||
--ports = Debug.Trace.trace ((show $ names dia) ++ "\n") $ names dia
|
||||
ports = names dia
|
||||
@ -158,6 +174,13 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||
(lookup (name .> x) ports)
|
||||
minAngle = angleWithMinDist (getFromMapAndScale positionMap name) portEdges
|
||||
|
||||
type LayoutResult a = Gr (GV.AttributeNode Name) (GV.AttributeNode a)
|
||||
placeNodes ::
|
||||
(Monoid m, Semigroup m) =>
|
||||
LayoutResult a
|
||||
-> [(Name, QDiagram b V2 Double m)]
|
||||
-> [Connection]
|
||||
-> QDiagram b V2 Double m
|
||||
placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
||||
where
|
||||
(positionMap, _) = getGraph layoutResult
|
||||
@ -167,7 +190,13 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
||||
-- todo: Not sure if the diagrams should already be centered at this point.
|
||||
placeNode (name, diagram) = place (diagram # centerXY) (scaleFactor *^ (positionMap Map.! name))
|
||||
|
||||
doGraphLayout :: Gr Name e -> [(Name, Diagram B)] -> (Diagram B -> r) -> [Connection] -> IO r
|
||||
doGraphLayout ::
|
||||
(Monoid m, Semigroup m) =>
|
||||
Gr Name e
|
||||
-> [(Name, QDiagram b V2 Double m)]
|
||||
-> (QDiagram b V2 Double m -> r)
|
||||
-> [Connection]
|
||||
-> IO r
|
||||
doGraphLayout graph nameDiagramMap connectNodes edges = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
@ -193,7 +222,10 @@ doGraphLayout graph nameDiagramMap connectNodes edges = do
|
||||
-- to name the nodes in order
|
||||
(_, dia) = nameDiagramMap !! nodeInt
|
||||
|
||||
renderDrawing :: Drawing -> IO (Diagram B)
|
||||
renderDrawing ::
|
||||
(Renderable (Path V2 Double) b,
|
||||
Renderable (Text Double) b) =>
|
||||
Drawing -> IO (QDiagram b V2 Double Any)
|
||||
renderDrawing (Drawing nameIconMap edges subDrawings) = do
|
||||
subDiagramMap <- mapM subDrawingMapper subDrawings
|
||||
let diagramMap = makeNamedMap subDiagramMap nameIconMap
|
||||
|
@ -21,6 +21,7 @@ mapFst f = map (first f)
|
||||
toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
|
||||
toNames = mapFst toName
|
||||
|
||||
noEnds :: (EdgeEnd, EdgeEnd)
|
||||
noEnds = (EndNone, EndNone)
|
||||
|
||||
-- Edge constructors --
|
||||
@ -39,6 +40,8 @@ iconToIcon a c = Edge (toName a, Nothing, toName c, Nothing) noEnds
|
||||
iconToIconEnds :: (IsName a, IsName b) => a -> EdgeEnd -> b -> EdgeEnd -> Edge
|
||||
iconToIconEnds a b c d = Edge (toName a, Nothing, toName c, Nothing) (b, d)
|
||||
|
||||
iconHeadToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
iconHeadToPort a endHead c d = Edge (toName a, Nothing, toName c, Just d) (EndNone, endHead)
|
||||
|
||||
iconTailToPort :: (IsName a, IsName b) => a -> EdgeEnd -> b -> Int -> Edge
|
||||
iconTailToPort a endTail c d = Edge (toName a, Nothing, toName c, Just d) (endTail, EndNone)
|
||||
|
Loading…
Reference in New Issue
Block a user