mirror of
https://github.com/rgleichman/glance.git
synced 2024-10-26 16:51:29 +03:00
Simplify types.
This commit is contained in:
parent
f331e8dca8
commit
287b477d1b
178
app/Icons.hs
178
app/Icons.hs
@ -22,9 +22,12 @@ import Diagrams.Prelude
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Types(Icon(..), Edge)
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend)
|
||||
import Util(fromMaybeError)
|
||||
|
||||
-- TYPES --
|
||||
type TransformableDia b = (Bool -> Double -> SpecialQDiagram b)
|
||||
|
||||
-- COLO(U)RS --
|
||||
colorScheme :: (Floating a, Ord a) => ColorStyle a
|
||||
colorScheme = colorOnBlackScheme
|
||||
@ -109,19 +112,12 @@ randomColorScheme = ColorStyle {
|
||||
lineCol :: (Floating a, Ord a) => Colour a
|
||||
lineCol = lineC colorScheme
|
||||
|
||||
type TransformableDia a b c d = (Bool -> Double -> QDiagram a b c d)
|
||||
|
||||
-- FUNCTIONS --
|
||||
-- Optimization: The apply0NDia's can be memoized.
|
||||
-- iconToDiagram ::
|
||||
-- (RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
-- Renderable (Text n) b) =>
|
||||
-- Icon -> [(Name, QDiagram b V2 n Any)] -> TransformableDia b V2 n Any
|
||||
iconToDiagram ::_ =>
|
||||
Icon -> [(Name, QDiagram b V2 Double Any)] -> Bool -> Double -> QDiagram b V2 Double Any
|
||||
iconToDiagram :: SpecialBackend b => Icon -> [(Name, SpecialQDiagram b)] -> Bool -> Double -> SpecialQDiagram b
|
||||
iconToDiagram (ApplyAIcon n) _ = identDiaFunc $ applyADia n
|
||||
iconToDiagram (PAppIcon n str) _ = diaFunc $ pAppDia n str
|
||||
iconToDiagram (TextApplyAIcon n str) _ = diaFunc $ textApplyADia n str
|
||||
iconToDiagram (PAppIcon n str) _ = pAppDia n str
|
||||
iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str
|
||||
iconToDiagram ResultIcon _ = identDiaFunc resultIcon
|
||||
iconToDiagram BranchIcon _ = identDiaFunc branchIcon
|
||||
iconToDiagram (TextBoxIcon s) _ = identDiaFunc $ textBox s
|
||||
@ -135,41 +131,22 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap =
|
||||
where
|
||||
dia = fromMaybeError "iconToDiagram: subdiagram not found" $ lookup diagramName nameToSubdiagramMap
|
||||
|
||||
--Get the decimal part of a float
|
||||
--reduceAngleRange :: Double -> Double
|
||||
reduceAngleRange :: Double -> Double
|
||||
reduceAngleRange x = x - fromInteger (floor x)
|
||||
|
||||
-- Make an identity TransformableDia
|
||||
identDiaFunc :: _ => QDiagram b V2 n m -> TransformableDia b V2 n m
|
||||
identDiaFunc :: SpecialQDiagram b -> TransformableDia b
|
||||
identDiaFunc dia _ _ = dia
|
||||
|
||||
--makeSymmetricTransDia :: _ => QDiagram b V2 n m -> nm -> Bool -> n -> QDiagram b V2 n m
|
||||
--makeSymmetricTransDia dia nm reflect angle = nameDiagram nm $ rotateBy (if reflect then angle + (1/2) else angle) dia
|
||||
|
||||
diaFunc dia reflect angle = dia reflect angle
|
||||
|
||||
-- | 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 :: (SpecialBackend b, IsName nm) => nm -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
nameDiagram name dia = named name (name .>> dia)
|
||||
|
||||
-- | 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 :: (Floating n, Ord n, Semigroup m, Metric v) => Int -> QDiagram b v n m
|
||||
makePort :: Int -> SpecialQDiagram b
|
||||
makePort x = mempty # named x
|
||||
--makePort x = circle 0.2 # fc green # named x
|
||||
-- Note, the version of makePort below seems to have a different type.
|
||||
--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..] :: [Int]))
|
||||
|
||||
-- CONSTANTS --
|
||||
defaultLineWidth :: (Fractional a) => a
|
||||
defaultLineWidth = 0.15
|
||||
@ -178,54 +155,23 @@ defaultLineWidth = 0.15
|
||||
circleRadius :: (Fractional a) => a
|
||||
circleRadius = 0.5
|
||||
|
||||
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 ::
|
||||
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
||||
V b ~ V2) =>
|
||||
b
|
||||
apply0Triangle = eqTriangle (2 * circleRadius) # rotateBy (-1/12) # lw none
|
||||
|
||||
apply0Line ::
|
||||
(Typeable (N b), HasStyle b, TrailLike b, V b ~ V2) => b
|
||||
apply0Line = rect defaultLineWidth (2 * circleRadius) # fc lineCol # lw none
|
||||
|
||||
--apply0Dia :: (Juxtaposable a, Semigroup a) => GeneralDiagram a
|
||||
applyA0Dia ::
|
||||
(RealFloat n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
QDiagram b V2 n m
|
||||
applyA0Dia = ((resultCircle ||| apply0Line ||| fc (apply0C colorScheme) apply0Triangle) <> makePortDiagrams apply0PortLocations) # reflectX # centerXY
|
||||
|
||||
apply0PortLocations :: Floating a => [P2 a]
|
||||
apply0PortLocations = map p2 [
|
||||
(circleRadius + defaultLineWidth + triangleWidth, 0),
|
||||
(-circleRadius,0),
|
||||
(lineCenter,-circleRadius)
|
||||
--(lineCenter,circleRadius),
|
||||
]
|
||||
where
|
||||
triangleWidth = circleRadius * sqrt 3
|
||||
lineCenter = circleRadius + (defaultLineWidth / 2.0)
|
||||
|
||||
portCircle :: (SpecialBackend b) => SpecialQDiagram b
|
||||
portCircle = circle (circleRadius * 0.5) # fc lineCol # lw none
|
||||
|
||||
-- apply0N Icon--
|
||||
-- applyA Icon--
|
||||
-- | apply0N port locations:
|
||||
-- Port 0: Function
|
||||
-- Port 1: Result
|
||||
-- Ports 2,3..: Arguments
|
||||
coloredApplyADia ::
|
||||
(RealFloat n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
Colour Double -> Int -> QDiagram b V2 n m
|
||||
--applyADia 1 = applyA0Dia
|
||||
(SpecialBackend b) =>
|
||||
Colour Double -> Int -> SpecialQDiagram b
|
||||
coloredApplyADia appColor n = finalDia # centerXY where
|
||||
seperation = circleRadius * 1.5
|
||||
trianglePortsCircle = hcat [
|
||||
@ -238,18 +184,23 @@ coloredApplyADia appColor n = finalDia # centerXY where
|
||||
topAndBottomLine = hrule topAndBottomLineWidth # lc appColor # lwG defaultLineWidth # alignL
|
||||
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||
|
||||
applyADia :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||
applyADia = coloredApplyADia (apply0C colorScheme)
|
||||
|
||||
--textApplyADia :: _ => Int -> String -> QDiagram b V2 n m
|
||||
textApplyADia :: _ =>
|
||||
Int -> String -> TransformableDia b V2 Double Any
|
||||
textApplyADia :: SpecialBackend b =>
|
||||
Int -> String -> TransformableDia b
|
||||
textApplyADia = generalTextAppDia (textBoxTextC colorScheme) (apply0C colorScheme)
|
||||
|
||||
pAppDia :: _ =>
|
||||
Int -> String -> TransformableDia b V2 Double Any
|
||||
pAppDia :: SpecialBackend b =>
|
||||
Int -> String -> TransformableDia b
|
||||
pAppDia = generalTextAppDia (patternTextC colorScheme) (patternC colorScheme)
|
||||
|
||||
generalTextAppDia :: _ => Colour Double -> Colour Double -> Int -> String -> Bool -> Double -> QDiagram b V2 n Any
|
||||
--Get the decimal part of a float
|
||||
reduceAngleRange :: Double -> Double
|
||||
reduceAngleRange x = x - fromInteger (floor x)
|
||||
|
||||
generalTextAppDia :: SpecialBackend b =>
|
||||
Colour Double -> Colour Double -> Int -> String -> Bool -> Double -> SpecialQDiagram b
|
||||
generalTextAppDia textCol borderCol numArgs str reflect angle = rotateDia where
|
||||
rotateDia = rotateBy textBoxRotation (reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str)) |||
|
||||
coloredApplyADia borderCol numArgs
|
||||
@ -265,25 +216,19 @@ monoLetterWidthToHeightFraction = 0.61
|
||||
textBoxHeightFactor :: (Fractional a) => a
|
||||
textBoxHeightFactor = 1.1
|
||||
|
||||
textBox ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Text n) b) =>
|
||||
String -> QDiagram b V2 n Any
|
||||
textBox :: SpecialBackend b =>
|
||||
String -> SpecialQDiagram b
|
||||
textBox = coloredTextBox (textBoxTextC colorScheme) $ opaque (textBoxC colorScheme)
|
||||
|
||||
bindTextBox ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b,
|
||||
Renderable (Text n) b) =>
|
||||
String -> QDiagram b V2 n Any
|
||||
bindTextBox :: SpecialBackend b =>
|
||||
String -> SpecialQDiagram b
|
||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC 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 :: SpecialBackend b =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b
|
||||
coloredTextBox textColor boxColor t =
|
||||
text t # fc textColor # font "freemono" # bold # fontSize (local textBoxFontSize)
|
||||
<> rect rectangleWidth (textBoxFontSize * textBoxHeightFactor) # lcA boxColor # lwG (0.6 * defaultLineWidth)
|
||||
@ -293,67 +238,57 @@ 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 :: SpecialBackend b =>
|
||||
SpecialQDiagram b -> SpecialQDiagram b
|
||||
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
|
||||
SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
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 :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
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 :: SpecialBackend b => SpecialQDiagram b
|
||||
resultIcon = unitSquare # lw none # fc (lamArgResC colorScheme)
|
||||
|
||||
-- BRANCH ICON --
|
||||
branchIcon :: GeneralDiagram a
|
||||
branchIcon :: SpecialBackend b => SpecialQDiagram b
|
||||
branchIcon = circle circleRadius # fc lineCol # lc lineCol # lw none
|
||||
|
||||
-- GUARD ICON --
|
||||
guardSize :: (Fractional a) => a
|
||||
guardSize = 0.7
|
||||
|
||||
guardTriangle ::
|
||||
(Floating n, Ord n, Typeable n, Monoid m, Semigroup m,
|
||||
TrailLike (QDiagram b V2 n m)) =>
|
||||
Int -> QDiagram b V2 n m
|
||||
guardTriangle :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardTriangle x =
|
||||
((triangleAndPort ||| (hrule (guardSize * 0.8) # lwG defaultLineWidth)) # alignR) <> makePort x # alignL
|
||||
where
|
||||
triangleAndPort = polygon (with & polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize])
|
||||
# rotateBy (1/8) # lwG defaultLineWidth # alignT # alignR
|
||||
|
||||
guardLBracket ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Int -> QDiagram b V2 n Any
|
||||
guardLBracket :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardLBracket x = ell # alignT # alignL <> makePort x
|
||||
where
|
||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
||||
ell = ellShape # strokeLine # lc (boolC colorScheme) # lwG defaultLineWidth # lineJoin LineJoinRound
|
||||
|
||||
generalGuardIcon ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Colour Double -> (Int -> QDiagram b V2 n Any) -> QDiagram b V2 n Any -> Int -> QDiagram b V2 n Any
|
||||
generalGuardIcon :: SpecialBackend b =>
|
||||
Colour Double -> (Int -> SpecialQDiagram b) -> SpecialQDiagram b -> Int -> SpecialQDiagram b
|
||||
generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort 1) <> alignB (bigVerticalLine <> guardDia <> makePort 0)
|
||||
where
|
||||
--guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
|
||||
@ -372,21 +307,18 @@ generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomD
|
||||
-- Port 1: Bottom result port
|
||||
-- Ports 3,5...: The left ports for the booleans
|
||||
-- Ports 2,4...: The right ports for the values
|
||||
guardIcon ::
|
||||
(RealFloat n, Typeable n, Renderable (Path V2 n) b) =>
|
||||
Int -> QDiagram b V2 n Any
|
||||
guardIcon :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
||||
|
||||
-- TODO Improve design to be more than a circle.
|
||||
caseResult :: (RealFloat n,
|
||||
Typeable n,
|
||||
Renderable (Path V2 n) b) => QDiagram b V2 n Any
|
||||
caseResult :: SpecialBackend b =>
|
||||
SpecialQDiagram b
|
||||
caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where
|
||||
caseCColor = caseRhsC colorScheme
|
||||
|
||||
caseC :: (RealFloat n,
|
||||
Typeable n,
|
||||
Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any
|
||||
caseC :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
caseC n = caseResult <> makePort n
|
||||
|
||||
|
||||
@ -395,15 +327,15 @@ caseC n = caseResult <> makePort n
|
||||
-- Port 1: Bottom result port
|
||||
-- Ports 3,5...: The left ports for the results
|
||||
-- Ports 2,4...: The right ports for the patterns
|
||||
caseIcon ::(RealFloat n,
|
||||
Typeable n,
|
||||
Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any
|
||||
caseIcon :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
|
||||
|
||||
-- | The ports of flatLambdaIcon are:
|
||||
-- 0: Result icon
|
||||
-- 1: The lambda function value
|
||||
-- 2,3.. : The parameters
|
||||
flatLambda :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||
flatLambda n = finalDia where
|
||||
lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
|
||||
lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle])
|
||||
|
33
app/Main.hs
33
app/Main.hs
@ -18,40 +18,31 @@ import Translate(translateString, drawingsFromModule)
|
||||
|
||||
-- Refactor Translate
|
||||
-- Add documentation.
|
||||
-- Update readme.
|
||||
-- Test reference lookup in case rhs.
|
||||
-- Have the file be a command line argument to main.
|
||||
-- In evalPatBind, give the edge from the rhs to the pattern a special arrowhead.
|
||||
-- Line intersections should have a small circle. This could probably be done with
|
||||
-- a line ending.
|
||||
|
||||
-- Move tests out of main.
|
||||
|
||||
-- TODO Later --
|
||||
-- Visual todos
|
||||
-- Visual todos:
|
||||
-- Give lines a black border to make line crossings easier to see.
|
||||
-- Give lines that cross the border of a lambda function a special color.
|
||||
-- Line intersections should have a small circle. This could probably be done with
|
||||
-- a line ending.
|
||||
-- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
|
||||
-- Let lines connect to ports in multiple locations (eg. case value, or guard result)
|
||||
-- Rotate icons based on the outgoing line's difference from ideal angle, not line distance.
|
||||
-- Improve line routing. Draw curved lines with outgoing lines at fixed angles.
|
||||
-- - connectPerim might be useful for this.
|
||||
|
||||
-- Translate todos:
|
||||
-- Fix test case x of {0 -> 1; y -> y}.
|
||||
|
||||
-- Have icon rotation just rotate internal items, not the entire diagram.
|
||||
-- Use a nested tree layout. A graph can take an optional (name, Icon) as filling a port.
|
||||
-- Use clustered graphs. Make a test project.
|
||||
-- Consider making lines between patterns Pattern Color when the line is a reference.
|
||||
-- Consider using seperate parameter icons in functions.
|
||||
-- Add function name and type to LambdaIcons.
|
||||
-- Add proper RecConstr, and RecUpdate support.
|
||||
-- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case.
|
||||
-- Eliminate BranchIcon in Alts.
|
||||
-- Eliminate BranchIcon for the identity funciton "y x = x"
|
||||
-- otherwise Guard special case
|
||||
-- Let lines connect to ports in multiple locations (eg. argument for Apply0Dia)
|
||||
-- Add a small black border to lines to help distinguish line crossings.
|
||||
-- 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: Rotate based on difference from ideal tangent angle, not line distance.
|
||||
-- todo: Try using connectPerim for port to port connections. Hopefully this will draw a spline.
|
||||
-- todo: layout and rotate considering external connections.
|
||||
|
||||
--Other todos:
|
||||
-- Use a nested tree layout. A graph can take an optional (name, Icon) instead of a port.
|
||||
|
||||
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
||||
d0Icons = toNames
|
||||
|
@ -6,7 +6,6 @@ module Rendering (
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
--import Diagrams.Backend.SVG(B)
|
||||
|
||||
import qualified Data.GraphViz as GV
|
||||
@ -22,8 +21,9 @@ import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||
import Data.Typeable(Typeable)
|
||||
--import Data.Word(Word16)
|
||||
|
||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||
import Types(Edge(..), EdgeOption(..), Connection, Drawing(..), EdgeEnd(..), NameAndPort(..))
|
||||
import Icons(colorScheme, iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||
import Types(Edge(..), Icon, EdgeOption(..), Connection, Drawing(..), EdgeEnd(..),
|
||||
NameAndPort(..), SpecialQDiagram, SpecialBackend)
|
||||
import Util(fromMaybeError)
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
@ -52,13 +52,7 @@ drawingToGraphvizScaleFactor = 0.15
|
||||
-- | 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 ::
|
||||
-- (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 :: SpecialBackend b => [(Name, SpecialQDiagram b)] -> [(t, Icon)] -> [(t, Bool -> Double -> SpecialQDiagram b)]
|
||||
makeNamedMap subDiagramMap =
|
||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap))
|
||||
|
||||
@ -179,12 +173,11 @@ connectedPorts edges name = map edgeToPort $ filter nameInEdge edges
|
||||
-- are minimized.
|
||||
-- Precondition: the diagrams are already centered
|
||||
-- todo: confirm precondition (or use a newtype)
|
||||
rotateNodes ::
|
||||
Semigroup m =>
|
||||
Map.Map Name (Point V2 Double)
|
||||
-> [(Name, Bool -> Double -> QDiagram b V2 Double m)]
|
||||
-> [Connection]
|
||||
-> [(Name, QDiagram b V2 Double m)]
|
||||
rotateNodes :: SpecialBackend b =>
|
||||
Map.Map Name (Point V2 Double)
|
||||
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
|
||||
-> [Connection]
|
||||
-> [(Name, SpecialQDiagram b)]
|
||||
rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||
where
|
||||
rotateDiagram (name, originalDia) = (name, nameDiagram name transformedDia)
|
||||
@ -219,12 +212,11 @@ rotateNodes positionMap nameDiagramMap edges = map rotateDiagram nameDiagramMap
|
||||
minAngle = angleWithMinDist (getFromMapAndScale positionMap name) portEdges
|
||||
|
||||
type LayoutResult a = Gr (GV.AttributeNode Name) (GV.AttributeNode a)
|
||||
placeNodes ::
|
||||
(Monoid m, Semigroup m) =>
|
||||
LayoutResult a
|
||||
-> [(Name, Bool -> Double -> QDiagram b V2 Double m)]
|
||||
-> [Connection]
|
||||
-> QDiagram b V2 Double m
|
||||
placeNodes :: SpecialBackend b =>
|
||||
LayoutResult a
|
||||
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
|
||||
-> [Connection]
|
||||
-> SpecialQDiagram b
|
||||
placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
|
||||
where
|
||||
(positionMap, _) = getGraph layoutResult
|
||||
@ -234,12 +226,11 @@ 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, Bool -> Double -> QDiagram b V2 Double m)]
|
||||
-> [Connection]
|
||||
-> IO (QDiagram b V2 Double m)
|
||||
doGraphLayout :: SpecialBackend b =>
|
||||
Gr Name e
|
||||
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
|
||||
-> [Connection]
|
||||
-> IO (SpecialQDiagram b)
|
||||
doGraphLayout graph nameDiagramMap edges = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
@ -272,19 +263,18 @@ doGraphLayout graph nameDiagramMap edges = do
|
||||
where
|
||||
--todo: Hack! Using (!!) here relies upon the implementation of Diagrams.TwoD.GraphViz.mkGraph
|
||||
-- to name the nodes in order
|
||||
(_, unTransformedDia) = (nameDiagramMap !! nodeInt)
|
||||
(_, unTransformedDia) = nameDiagramMap !! nodeInt
|
||||
dia = unTransformedDia False 0
|
||||
|
||||
diaWidth = drawingToGraphvizScaleFactor * (width dia)
|
||||
diaHeight = drawingToGraphvizScaleFactor * (height dia)
|
||||
diaWidth = drawingToGraphvizScaleFactor * width dia
|
||||
diaHeight = drawingToGraphvizScaleFactor * height dia
|
||||
circleDiameter' = max diaWidth diaHeight
|
||||
circleDiameter = if circleDiameter' <= 0.01 then error ("circleDiameter too small: " ++ show circleDiameter') else circleDiameter'
|
||||
|
||||
|
||||
-- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
|
||||
-- lines connecting ports and icons. IO is needed for the GraphViz layout.
|
||||
renderDrawing ::
|
||||
_ =>
|
||||
renderDrawing :: SpecialBackend b =>
|
||||
Drawing -> IO (QDiagram b V2 Double Any)
|
||||
renderDrawing (Drawing nameIconMap edges subDrawings) = do
|
||||
subDiagramMap <- traverse renderSubDrawing subDrawings
|
||||
|
@ -23,8 +23,8 @@ import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst)
|
||||
import Icons(Icon(..))
|
||||
import TranslateCore(Reference, IconGraph(..), EvalContext, GraphAndRef,
|
||||
iconGraphFromIcons, iconGraphFromIconsEdges, getUniqueName, combineExpressions,
|
||||
edgesForRefPortList, iconGraphToDrawing, qualifyNameAndPort, makeApplyGraph,
|
||||
namesInPattern, lookupReference, deleteBindings, makeEdges, makeEdgesCore,
|
||||
edgesForRefPortList, iconGraphToDrawing, makeApplyGraph,
|
||||
namesInPattern, lookupReference, deleteBindings, makeEdges,
|
||||
coerceExpressionResult, makeBox, nTupleString, nListString)
|
||||
|
||||
-- OVERVIEW --
|
||||
@ -100,9 +100,9 @@ evalQName qName@(UnQual _) c = strToGraphRef c (qNameToString qName)
|
||||
evalQName qName@(Qual _ _) c = strToGraphRef c (qNameToString qName)
|
||||
evalQName qName _ = fmap Right <$> makeBox (qNameToString qName)
|
||||
|
||||
evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference)
|
||||
evalQOp (QVarOp n) = evalQName n
|
||||
evalQOp (QConOp n) = evalQName n
|
||||
-- evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference)
|
||||
-- evalQOp (QVarOp n) = evalQName n
|
||||
-- evalQOp (QConOp n) = evalQName n
|
||||
|
||||
qOpToString :: QOp -> String
|
||||
qOpToString (QVarOp n) = qNameToString n
|
||||
@ -308,10 +308,11 @@ evalTuple c exps = do
|
||||
applyIconName <- DIA.toName <$> getUniqueName "tupleApp"
|
||||
pure $ makeTextApplyGraph False applyIconName (nTupleString (length exps)) argVals (length exps)
|
||||
|
||||
makeVarExp :: String -> Exp
|
||||
makeVarExp = Var . UnQual . Ident
|
||||
|
||||
evalListExp :: EvalContext -> [Exp] -> State IDState (IconGraph, NameAndPort)
|
||||
evalListExp c [] = makeBox "[]"
|
||||
evalListExp _ [] = makeBox "[]"
|
||||
evalListExp c exps = evalApp c (makeVarExp . nListString . length $ exps, exps)
|
||||
|
||||
evalLeftSection :: EvalContext -> Exp -> QOp -> State IDState (IconGraph, NameAndPort)
|
||||
@ -329,6 +330,7 @@ evalRightSection c op e = do
|
||||
evalEnums :: EvalContext -> String -> [Exp] -> State IDState (IconGraph, Reference)
|
||||
evalEnums c s exps = fmap Right <$> evalApp c (Var . UnQual . Ident $ s, exps)
|
||||
|
||||
makeQVarOp :: String -> QOp
|
||||
makeQVarOp = QVarOp . UnQual . Ident
|
||||
|
||||
desugarDo :: [Stmt] -> Exp
|
||||
@ -341,7 +343,7 @@ desugarDo (LetStmt binds : stmts) = Let binds (desugarDo stmts)
|
||||
|
||||
-- TODO: Finish evalRecConstr
|
||||
evalRecConstr :: EvalContext -> QName -> [Exts.FieldUpdate] -> State IDState (IconGraph, Reference)
|
||||
evalRecConstr c qName updates = evalQName qName c
|
||||
evalRecConstr c qName _ = evalQName qName c
|
||||
|
||||
evalExp :: EvalContext -> Exp -> State IDState (IconGraph, Reference)
|
||||
evalExp c x = case x of
|
||||
@ -364,7 +366,7 @@ evalExp c x = case x of
|
||||
RightSection op e -> fmap Right <$> evalRightSection c op e
|
||||
RecConstr n updates -> evalRecConstr c n updates
|
||||
-- TODO: Do RecUpdate correcly
|
||||
RecUpdate e updates -> evalExp c e
|
||||
RecUpdate e _ -> evalExp c e
|
||||
EnumFrom e -> evalEnums c "enumFrom" [e]
|
||||
EnumFromTo e1 e2 -> evalEnums c "enumFromTo" [e1, e2]
|
||||
EnumFromThen e1 e2 -> evalEnums c "enumFromThen" [e1, e2]
|
||||
@ -412,7 +414,7 @@ generalEvalLambda context patterns rhsEvalFun = do
|
||||
patternGraph = mconcat $ map fst patternVals
|
||||
|
||||
(patternEdges, newBinds) =
|
||||
partitionEithers $ zipWith (makePatternEdges lambdaName) patternVals lambdaPorts
|
||||
partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts
|
||||
numParameters = length patterns
|
||||
-- TODO remove coerceExpressionResult here
|
||||
(rhsRawGraph, rhsResult) <- rhsEvalFun rhsContext >>= coerceExpressionResult
|
||||
@ -425,10 +427,10 @@ generalEvalLambda context patterns rhsEvalFun = do
|
||||
where
|
||||
-- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern.
|
||||
-- makePatternEdges creates the edges between the patterns and the parameter ports.
|
||||
makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either Edge (String, Reference)
|
||||
makePatternEdges lambdaName (_, Right patPort) lamPort =
|
||||
makePatternEdges :: GraphAndRef -> NameAndPort -> Either Edge (String, Reference)
|
||||
makePatternEdges (_, Right patPort) lamPort =
|
||||
Left $ makeSimpleEdge (lamPort, patPort)
|
||||
makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort)
|
||||
makePatternEdges (_, Left str) lamPort = Right (str, Right lamPort)
|
||||
|
||||
|
||||
evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort)
|
||||
|
@ -9,14 +9,14 @@ module TranslateCore(
|
||||
getUniqueName,
|
||||
edgesForRefPortList,
|
||||
combineExpressions,
|
||||
qualifyNameAndPort,
|
||||
--qualifyNameAndPort,
|
||||
iconGraphToDrawing,
|
||||
makeApplyGraph,
|
||||
namesInPattern,
|
||||
lookupReference,
|
||||
deleteBindings,
|
||||
makeEdges,
|
||||
makeEdgesCore,
|
||||
--makeEdgesCore,
|
||||
coerceExpressionResult,
|
||||
makeBox,
|
||||
nTupleString,
|
||||
@ -91,8 +91,8 @@ combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs
|
||||
else IconGraph mempty mempty mempty [(str, port)] mempty
|
||||
Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
|
||||
|
||||
qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
||||
qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
||||
-- qualifyNameAndPort :: String -> NameAndPort -> NameAndPort
|
||||
-- qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p
|
||||
|
||||
iconGraphToDrawing :: IconGraph -> Drawing
|
||||
iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings
|
||||
|
12
app/Types.hs
12
app/Types.hs
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ConstraintKinds #-}
|
||||
|
||||
module Types (
|
||||
Icon(..),
|
||||
@ -9,11 +9,14 @@ module Types (
|
||||
EdgeEnd(..),
|
||||
Drawing(..),
|
||||
IDState,
|
||||
SpecialQDiagram,
|
||||
SpecialBackend,
|
||||
initialIdState,
|
||||
getId
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude(Name)
|
||||
import Diagrams.Prelude(Name, QDiagram, V2, Any, Renderable, Path)
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
import Control.Monad.State(State, state)
|
||||
|
||||
-- TYPES --
|
||||
@ -48,6 +51,11 @@ data Drawing = Drawing [(Name, Icon)] [Edge] [(Name, Drawing)] deriving (Show)
|
||||
-- | IDState is an Abstract Data Type that is used as a state whose value is a unique id.
|
||||
newtype IDState = IDState Int deriving (Eq, Show)
|
||||
|
||||
-- Note that SpecialBackend is a constraint synonym, not a type synonym.
|
||||
type SpecialBackend b = (Renderable (Path V2 Double) b, Renderable (Text Double) b)
|
||||
|
||||
type SpecialQDiagram b = QDiagram b V2 Double Any
|
||||
|
||||
initialIdState :: IDState
|
||||
initialIdState = IDState 0
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user