mirror of
https://github.com/rgleichman/glance.git
synced 2024-11-30 05:47:46 +03:00
Generalize the number type in SepcialQDiagram
This commit is contained in:
Robbie Gleichman
parent
59cd6757fe
commit
0f9c4d5b80
126
app/Icons.hs
126
app/Icons.hs
@ -31,18 +31,18 @@ import Data.Typeable(Typeable)
|
||||
--import Diagrams.TwoD.Text(Text)
|
||||
--import Data.Maybe(fromMaybe)
|
||||
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend)
|
||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum)
|
||||
import DrawingColors(colorScheme, ColorStyle(..))
|
||||
|
||||
-- TYPES --
|
||||
type TransformableDia b = (Name -> Bool -> Double -> SpecialQDiagram b)
|
||||
type TransformableDia b n = Name -> Bool -> Angle n -> SpecialQDiagram b n
|
||||
|
||||
-- COLORS --
|
||||
lineCol :: Colour Double
|
||||
lineCol = lineC colorScheme
|
||||
|
||||
-- FUNCTIONS --
|
||||
iconToDiagram :: SpecialBackend b => Icon -> TransformableDia b
|
||||
iconToDiagram :: SpecialBackend b n => Icon -> TransformableDia b n
|
||||
iconToDiagram (ApplyAIcon n) = identDiaFunc $ applyADia n
|
||||
iconToDiagram (PAppIcon n str) = pAppDia n str
|
||||
iconToDiagram ResultIcon = identDiaFunc resultIcon
|
||||
@ -114,16 +114,16 @@ portAngles icon port maybeName = case icon of
|
||||
|
||||
-- Warning: the first argument to nameDiagram can be almost any type,
|
||||
-- so be careful with the parameter order.
|
||||
identDiaFunc :: SpecialQDiagram b -> TransformableDia b
|
||||
identDiaFunc :: SpecialNum n => SpecialQDiagram b n -> TransformableDia b n
|
||||
identDiaFunc dia name _ _ = nameDiagram name dia
|
||||
|
||||
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
||||
nameDiagram :: IsName nm => nm -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
nameDiagram :: (IsName nm, SpecialNum n) => nm -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
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 :: Int -> SpecialQDiagram b
|
||||
makePort :: SpecialNum n => Int -> SpecialQDiagram b n
|
||||
makePort x = named x mempty
|
||||
--makePort x = circle 0.2 # fc green # named x
|
||||
-- Note, the version of makePort below seems to have a different type.
|
||||
@ -137,13 +137,10 @@ defaultLineWidth = 0.15
|
||||
circleRadius :: (Fractional a) => a
|
||||
circleRadius = 0.5
|
||||
|
||||
apply0Triangle ::
|
||||
(Typeable (N b), Transformable b, HasStyle b, TrailLike b,
|
||||
V b ~ V2) =>
|
||||
b
|
||||
apply0Triangle :: SpecialBackend b n => SpecialQDiagram b n
|
||||
apply0Triangle = lw none $ rotateBy (-1/12) $ eqTriangle (2 * circleRadius)
|
||||
|
||||
portCircle :: (SpecialBackend b) => SpecialQDiagram b
|
||||
portCircle :: SpecialBackend b n => SpecialQDiagram b n
|
||||
portCircle = lw none $ fc lineCol $ circle (circleRadius * 0.5)
|
||||
|
||||
-- applyA Icon--
|
||||
@ -152,8 +149,8 @@ portCircle = lw none $ fc lineCol $ circle (circleRadius * 0.5)
|
||||
-- Port 1: Result
|
||||
-- Ports 2,3..: Arguments
|
||||
coloredApplyADia ::
|
||||
(SpecialBackend b) =>
|
||||
Colour Double -> Int -> SpecialQDiagram b
|
||||
(SpecialBackend b n) =>
|
||||
Colour Double -> Int -> SpecialQDiagram b n
|
||||
coloredApplyADia appColor n = centerXY finalDia where
|
||||
trianglePortsCircle = hcat [
|
||||
reflectX (fc appColor apply0Triangle),
|
||||
@ -165,46 +162,46 @@ coloredApplyADia appColor n = centerXY finalDia where
|
||||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc appColor $ hrule topAndBottomLineWidth
|
||||
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||
|
||||
applyADia :: SpecialBackend b => Int -> SpecialQDiagram b
|
||||
applyADia :: SpecialBackend b n => Int -> SpecialQDiagram b n
|
||||
applyADia = coloredApplyADia (apply0C colorScheme)
|
||||
|
||||
textApplyADia :: SpecialBackend b =>
|
||||
Int -> String -> TransformableDia b
|
||||
textApplyADia :: SpecialBackend b n =>
|
||||
Int -> String -> TransformableDia b n
|
||||
textApplyADia = generalTextAppDia (textBoxTextC colorScheme) (apply0C colorScheme)
|
||||
|
||||
pAppDia :: SpecialBackend b =>
|
||||
Int -> String -> TransformableDia b
|
||||
pAppDia :: SpecialBackend b n =>
|
||||
Int -> String -> TransformableDia b n
|
||||
pAppDia = generalTextAppDia (patternTextC colorScheme) (patternC colorScheme)
|
||||
|
||||
--Get the decimal part of a float
|
||||
reduceAngleRange :: Double -> Double
|
||||
reduceAngleRange :: SpecialNum a => a -> a
|
||||
reduceAngleRange x = x - fromInteger (floor x)
|
||||
|
||||
generalTextAppDia :: SpecialBackend b =>
|
||||
Colour Double -> Colour Double -> Int -> String -> TransformableDia b
|
||||
generalTextAppDia :: SpecialBackend b n =>
|
||||
Colour Double -> Colour Double -> Int -> String -> TransformableDia b n
|
||||
generalTextAppDia textCol borderCol numArgs str name reflect angle = nameDiagram name rotateDia where
|
||||
rotateDia = transformCorrectedTextBox str textCol borderCol reflect angle |||
|
||||
coloredApplyADia borderCol numArgs
|
||||
|
||||
transformCorrectedTextBox :: SpecialBackend b =>
|
||||
String -> Colour Double -> Colour Double -> Bool -> Double -> SpecialQDiagram b
|
||||
transformCorrectedTextBox :: SpecialBackend b n =>
|
||||
String -> Colour Double -> Colour Double -> Bool -> Angle n -> SpecialQDiagram b n
|
||||
transformCorrectedTextBox str textCol borderCol reflect angle =
|
||||
rotateBy textBoxRotation (reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str))
|
||||
where
|
||||
reducedAngle = reduceAngleRange angle
|
||||
reducedAngle = reduceAngleRange (angle ^. turn)
|
||||
textBoxRotation = if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0
|
||||
reflectIfTrue shouldReflect dia = if shouldReflect then reflectX dia else dia
|
||||
|
||||
nestedApplyDia :: SpecialBackend b =>
|
||||
[Maybe (Name, Icon)] -> TransformableDia b
|
||||
nestedApplyDia :: SpecialBackend b n =>
|
||||
[Maybe (Name, Icon)] -> TransformableDia b n
|
||||
nestedApplyDia = generalNestedDia (apply0C colorScheme)
|
||||
|
||||
nestedPAppDia :: SpecialBackend b =>
|
||||
[Maybe (Name, Icon)] -> TransformableDia b
|
||||
nestedPAppDia :: SpecialBackend b n =>
|
||||
[Maybe (Name, Icon)] -> TransformableDia b n
|
||||
nestedPAppDia = generalNestedDia (patternC colorScheme)
|
||||
|
||||
generalNestedDia :: SpecialBackend b =>
|
||||
Colour Double -> [Maybe (Name, Icon)] -> TransformableDia b
|
||||
generalNestedDia :: SpecialBackend b n =>
|
||||
Colour Double -> [Maybe (Name, Icon)] -> TransformableDia b n
|
||||
generalNestedDia borderCol funcNameAndArgs name reflect angle = named name $ case funcNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia
|
||||
@ -237,18 +234,17 @@ monoLetterWidthToHeightFraction = 0.61
|
||||
textBoxHeightFactor :: (Fractional a) => a
|
||||
textBoxHeightFactor = 1.1
|
||||
|
||||
textBox :: SpecialBackend b =>
|
||||
String -> TransformableDia b
|
||||
textBox t name reflect rotate = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect rotate
|
||||
textBox :: SpecialBackend b n =>
|
||||
String -> TransformableDia b n
|
||||
textBox t name reflect angle = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect angle
|
||||
|
||||
bindTextBox :: SpecialBackend b =>
|
||||
String -> SpecialQDiagram b
|
||||
bindTextBox :: SpecialBackend b n =>
|
||||
String -> SpecialQDiagram b n
|
||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
||||
|
||||
|
||||
multilineComment :: SpecialBackend b =>
|
||||
multilineComment :: SpecialBackend b n =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b n
|
||||
multilineComment textColor boxColor t = lwG (0.6 * defaultLineWidth) textDia
|
||||
where
|
||||
textLines = lines t
|
||||
@ -265,64 +261,64 @@ rectForText n = rect rectangleWidth (textBoxFontSize * textBoxHeightFactor)
|
||||
|
||||
-- Since the normal SVG text has no size, some hackery is needed to determine
|
||||
-- the size of the text's bounding box.
|
||||
coloredTextBox :: SpecialBackend b =>
|
||||
coloredTextBox :: SpecialBackend b n =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b n
|
||||
coloredTextBox textColor boxColor t =
|
||||
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
||||
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ rectForText (length t))
|
||||
|
||||
commentTextArea :: SpecialBackend b =>
|
||||
Colour Double -> String -> SpecialQDiagram b
|
||||
commentTextArea :: SpecialBackend b n =>
|
||||
Colour Double -> String -> SpecialQDiagram b n
|
||||
commentTextArea textColor t =
|
||||
alignL $ fontSize (local textBoxFontSize) (font "freemono" $ fc textColor $ topLeftText t)
|
||||
<> alignTL (lw none $ rectForText (length t))
|
||||
|
||||
-- ENCLOSING REGION --
|
||||
enclosure :: SpecialBackend b =>
|
||||
SpecialQDiagram b -> SpecialQDiagram b
|
||||
enclosure :: SpecialBackend b n =>
|
||||
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
enclosure dia = dia <> lwG defaultLineWidth (lc (regionPerimC colorScheme) $ boundingRect (frame 0.5 dia))
|
||||
|
||||
-- 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 ::
|
||||
SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n
|
||||
lambdaIcon x = alignB (coloredTextBox (lamArgResC colorScheme) transparent "λ") <> 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 :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
lambdaRegion :: SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
lambdaRegion n dia =
|
||||
centerXY $ centerX lambdaIcons === centerX (enclosure dia)
|
||||
where lambdaIcons = hsep 0.4 (take n (map lambdaIcon [0,1..]))
|
||||
|
||||
-- RESULT ICON --
|
||||
resultIcon :: SpecialBackend b => SpecialQDiagram b
|
||||
resultIcon :: SpecialBackend b n => SpecialQDiagram b n
|
||||
resultIcon = lw none $ fc (lamArgResC colorScheme) unitSquare
|
||||
|
||||
-- BRANCH ICON --
|
||||
branchIcon :: SpecialBackend b => SpecialQDiagram b
|
||||
branchIcon :: SpecialBackend b n => SpecialQDiagram b n
|
||||
branchIcon = lw none $ lc lineCol $ fc lineCol $ circle circleRadius
|
||||
|
||||
-- GUARD ICON --
|
||||
guardSize :: (Fractional a) => a
|
||||
guardSize = 0.7
|
||||
|
||||
guardTriangle :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardTriangle :: SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n
|
||||
guardTriangle x =
|
||||
alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> makePort x
|
||||
where
|
||||
triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
|
||||
polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
|
||||
|
||||
guardLBracket :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardLBracket :: SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n
|
||||
guardLBracket x = alignL (alignT ell) <> makePort x
|
||||
where
|
||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
|
||||
@ -333,8 +329,8 @@ guardLBracket x = alignL (alignT ell) <> makePort x
|
||||
-- 1 -> bottom
|
||||
-- odds -> left
|
||||
-- evens -> right
|
||||
generalGuardIcon :: SpecialBackend b =>
|
||||
Colour Double -> (Int -> SpecialQDiagram b) -> SpecialQDiagram b -> Int -> SpecialQDiagram b
|
||||
generalGuardIcon :: SpecialBackend b n =>
|
||||
Colour Double -> (Int -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
|
||||
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..]))
|
||||
@ -353,19 +349,19 @@ 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 :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
guardIcon :: SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n
|
||||
guardIcon = generalGuardIcon lineCol guardLBracket mempty
|
||||
|
||||
-- TODO Improve design to be more than a circle.
|
||||
caseResult :: SpecialBackend b =>
|
||||
SpecialQDiagram b
|
||||
caseResult :: SpecialBackend b n =>
|
||||
SpecialQDiagram b n
|
||||
caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.7)
|
||||
where
|
||||
caseCColor = caseRhsC colorScheme
|
||||
|
||||
caseC :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
caseC :: SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n
|
||||
caseC n = caseResult <> makePort n
|
||||
|
||||
|
||||
@ -374,15 +370,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 :: SpecialBackend b =>
|
||||
Int -> SpecialQDiagram b
|
||||
caseIcon :: SpecialBackend b n =>
|
||||
Int -> SpecialQDiagram b n
|
||||
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 :: SpecialBackend b n => Int -> SpecialQDiagram b n
|
||||
flatLambda n = finalDia where
|
||||
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle circleRadius
|
||||
lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++ [makePort 1 <> alignR lambdaCircle])
|
||||
|
||||
@ -31,7 +31,7 @@ import Data.Typeable(Typeable)
|
||||
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..), portAngles)
|
||||
import TranslateCore(nodeToIcon)
|
||||
import Types(Edge(..), Icon, EdgeOption(..), Connection, Drawing(..), EdgeEnd(..),
|
||||
NameAndPort(..), SpecialQDiagram, SpecialBackend, SyntaxNode)
|
||||
NameAndPort(..), SpecialQDiagram, SpecialBackend, SyntaxNode, SpecialNum)
|
||||
import Util(fromMaybeError)
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
@ -48,7 +48,7 @@ graphvizScaleFactor = 0.12
|
||||
|
||||
--scaleFactor = 0.04
|
||||
|
||||
drawingToGraphvizScaleFactor :: Double
|
||||
drawingToGraphvizScaleFactor :: Fractional a => a
|
||||
-- For Neato, ScaleOverlaps
|
||||
--drawingToGraphvizScaleFactor = 0.08
|
||||
|
||||
@ -120,10 +120,8 @@ getArrowOpts (t, h) opts (fromAngle, toAngle) = arrowOptions
|
||||
lookupHead h $ lookupTail t with
|
||||
|
||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||
--connectMaybePorts :: SpecialBackend b =>
|
||||
-- a -> Edge -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
connectMaybePorts :: (Floating n, SpecialBackend b) =>
|
||||
(Angle Double, Angle Double)-> Edge -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
connectMaybePorts :: SpecialBackend b n =>
|
||||
(Angle n, Angle n)-> Edge -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
connectMaybePorts portAngles (Edge opts ends (NameAndPort name0 mPort1, NameAndPort name1 mPort2)) =
|
||||
connectFunc (getArrowOpts ends opts portAngles) qPort0 qPort1 where
|
||||
(connectFunc, qPort0, qPort1) = case (mPort1, mPort2) of
|
||||
@ -145,7 +143,7 @@ findPortAngles (nodeName, nodeIcon) (NameAndPort diaName mPort) = case mPort of
|
||||
foundAngles = portAngles nodeIcon port mName
|
||||
|
||||
-- TODO Clean up the Angle arithmatic
|
||||
pickClosestAngle :: (Bool, Angle Double) -> Angle Double -> Angle Double -> Angle Double -> [Angle Double] -> Angle Double
|
||||
pickClosestAngle :: SpecialNum n => (Bool, Angle n) -> Angle n -> Angle n -> Angle n -> [Angle n] -> Angle n
|
||||
pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles = case angles of
|
||||
[] -> emptyCase
|
||||
_ -> (-) <$>
|
||||
@ -162,15 +160,15 @@ pickClosestAngle (nodeFlip, nodeAngle) emptyCase target shaftAngle angles = case
|
||||
(+) <$> angle <*> nodeAngle
|
||||
|
||||
|
||||
nodeAngle :: [((Name, Icon), (Bool, Angle Double))] -> (Name, Icon) -> (Bool, Angle Double)
|
||||
nodeAngle :: Show n => [((Name, Icon), (Bool, Angle n))] -> (Name, Icon) -> (Bool, Angle n)
|
||||
nodeAngle rotationMap key =
|
||||
fromMaybeError ("nodeVector: key not in rotaionMap. key = " ++ show key ++ "\n\n rotationMap = " ++ show rotationMap)
|
||||
$ lookup key rotationMap
|
||||
|
||||
|
||||
makeEdge :: (SpecialBackend b, ING.Graph gr) =>
|
||||
gr (Name, Icon) Edge -> SpecialQDiagram b -> [((Name, Icon), (Bool, Angle Double))] ->
|
||||
ING.LEdge Edge -> SpecialQDiagram b -> SpecialQDiagram b
|
||||
makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
|
||||
gr (Name, Icon) Edge -> SpecialQDiagram b n -> [((Name, Icon), (Bool, Angle n))] ->
|
||||
ING.LEdge Edge -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePort1))) =
|
||||
connectMaybePorts portAngles edge
|
||||
where
|
||||
@ -188,7 +186,7 @@ makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePor
|
||||
shaftVector = port1Point .-. port0Point
|
||||
shaftAngle = signedAngleBetween shaftVector unitX
|
||||
|
||||
icon0PortAngle = pickClosestAngle node0Angle (0 @@ turn) shaftAngle shaftAngle $ findPortAngles node0label namePort0
|
||||
icon0PortAngle = pickClosestAngle node0Angle mempty shaftAngle shaftAngle $ findPortAngles node0label namePort0
|
||||
|
||||
shaftAnglePlusOneHalf = (+) <$> shaftAngle <*> (1/2 @@ turn)
|
||||
icon1PortAngle = pickClosestAngle node1Angle (1/2 @@ turn) shaftAnglePlusOneHalf shaftAngle $ findPortAngles node1label namePort1
|
||||
@ -200,8 +198,8 @@ makeEdge graph dia rotationMap (node0, node1, edge@(Edge _ _ (namePort0, namePor
|
||||
portAngles = (icon0PortAngle, icon1PortAngle)
|
||||
|
||||
|
||||
addEdges :: (SpecialBackend b, ING.Graph gr) =>
|
||||
gr (Name, Icon) Edge -> (SpecialQDiagram b, [((Name, Icon), (Bool, Angle Double))])-> SpecialQDiagram b
|
||||
addEdges :: (SpecialBackend b n, ING.Graph gr) =>
|
||||
gr (Name, Icon) Edge -> (SpecialQDiagram b n, [((Name, Icon), (Bool, Angle n))]) -> SpecialQDiagram b n
|
||||
addEdges graph (dia, rotationMap) = applyAll connections dia
|
||||
where
|
||||
connections = makeEdge graph dia rotationMap <$> ING.labEdges graph
|
||||
@ -217,10 +215,10 @@ addEdges graph (dia, rotationMap) = applyAll connections dia
|
||||
-- of (this icon's port, icon that connects to this port), return the sum of the
|
||||
-- distances (possibly squared) between the ports and the icons they connect to.
|
||||
-- This function is used to find that angle that minimizes the sum of distances.
|
||||
totalLenghtOfLines :: Double -> P2 Double -> [(P2 Double, P2 Double)] -> Double
|
||||
totalLenghtOfLines :: Floating a => a -> P2 a -> [(P2 a, P2 a)] -> a
|
||||
totalLenghtOfLines angle myLocation edges = sum $ map edgeDist edges
|
||||
where
|
||||
edgeDist :: (P2 Double, P2 Double) -> Double
|
||||
--edgeDist :: (P2 Double, P2 Double) -> Double
|
||||
edgeDist (relativePortLocation, iconLocation) =
|
||||
-- The squaring here is arbitrary. Distance should be replaced with angle diff.
|
||||
(norm $ absPortVec ^-^ iconLocationVec) ** 2
|
||||
@ -235,7 +233,7 @@ totalLenghtOfLines angle myLocation edges = sum $ map edgeDist edges
|
||||
-- minimizes the the sum of the distances (possibly squared) between the ports
|
||||
-- and the icons they connect to. Returns (angle, sum of distances).
|
||||
-- todo: Return 0 immediatly if edges == [].
|
||||
angleWithMinDist :: P2 Double -> [(P2 Double, P2 Double)] -> (Double, Double)
|
||||
angleWithMinDist :: SpecialNum a => P2 a -> [(P2 a, P2 a)] -> (a, a)
|
||||
angleWithMinDist myLocation edges =
|
||||
minimumBy (compare `on` snd) $ map totalLength [0,(1/12)..1]
|
||||
where
|
||||
@ -259,40 +257,40 @@ connectedPorts edges name = map edgeToPort $ filter nameInEdge edges
|
||||
-- are minimized.
|
||||
-- Precondition: the diagrams are already centered
|
||||
-- todo: confirm precondition (or use a newtype)
|
||||
rotateNodes :: SpecialBackend b =>
|
||||
Map.Map (Name, Icon) (Point V2 Double)
|
||||
rotateNodes :: SpecialBackend b n =>
|
||||
Map.Map (Name, Icon) (Point V2 n)
|
||||
-> [Connection]
|
||||
-> [((Name, Icon), SpecialQDiagram b, (Bool, Angle Double))]
|
||||
-> [((Name, Icon), SpecialQDiagram b n, (Bool, Angle n))]
|
||||
rotateNodes positionMap edges = map rotateDiagram (Map.keys positionMap)
|
||||
where
|
||||
positionMapNameKeys = Map.mapKeys fst positionMap
|
||||
rotateDiagram key@(name, icon) = (key, transformedDia, (flip, angle @@ turn))
|
||||
rotateDiagram key@(name, icon) = (key, transformedDia, (flip, angle))
|
||||
where
|
||||
originalDia = iconToDiagram icon name
|
||||
flip = flippedDist < unflippedDist
|
||||
angle = if flip then flippedAngle else unflippedAngle
|
||||
angle = (if flip then flippedAngle else unflippedAngle) @@ turn
|
||||
internallTransformedDia = originalDia flip angle
|
||||
transformedDia = rotateBy angle $ (if flip then reflectX else id) internallTransformedDia
|
||||
transformedDia = rotate angle $ (if flip then reflectX else id) internallTransformedDia
|
||||
|
||||
(unflippedAngle, unflippedDist) = minAngleForDia (originalDia False 0)
|
||||
(flippedAngle, flippedDist) = minAngleForDia (reflectX $ originalDia True 0)
|
||||
(unflippedAngle, unflippedDist) = minAngleForDia (originalDia False mempty)
|
||||
(flippedAngle, flippedDist) = minAngleForDia (reflectX $ originalDia True mempty)
|
||||
--minAngleForDia :: QDiagram b V2 Double m -> (Double, Double)
|
||||
minAngleForDia dia = minAngle where
|
||||
--ports = Debug.Trace.trace ((show $ names dia) ++ "\n") $ names dia
|
||||
ports = names dia
|
||||
namesOfPortsWithLines = connectedPorts edges name
|
||||
|
||||
iconInMap :: (Int, Name, Maybe Int) -> Bool
|
||||
--iconInMap :: (Int, Name, Maybe Int) -> Bool
|
||||
iconInMap (_, otherIconName, _) = Map.member otherIconName positionMapNameKeys
|
||||
|
||||
getPortPoint :: Int -> P2 Double
|
||||
--getPortPoint :: Int -> P2 Double
|
||||
getPortPoint x =
|
||||
-- TODO remove partial function head.
|
||||
head $ fromMaybeError
|
||||
("rotateNodes: port not found. Port: " ++ show x ++ ". Valid ports: " ++ show ports)
|
||||
(lookup (name .> toName x) ports)
|
||||
|
||||
makePortEdge :: (Int, Name, Maybe Int) -> (P2 Double, P2 Double)
|
||||
--makePortEdge :: (Int, Name, Maybe Int) -> (P2 Double, P2 Double)
|
||||
makePortEdge (portInt, otherIconName, _) =
|
||||
(getPortPoint portInt, getFromMapAndScale positionMapNameKeys otherIconName)
|
||||
|
||||
@ -303,16 +301,16 @@ rotateNodes positionMap edges = map rotateDiagram (Map.keys positionMap)
|
||||
|
||||
type LayoutResult a b = Gr (GV.AttributeNode (Name, b)) (GV.AttributeNode a)
|
||||
|
||||
placeNodes :: forall a b. SpecialBackend b =>
|
||||
placeNodes :: forall a b. SpecialBackend b Double =>
|
||||
LayoutResult a Icon
|
||||
-> [Edge]
|
||||
-> (SpecialQDiagram b, [((Name, Icon), (Bool, Angle Double))])
|
||||
-> (SpecialQDiagram b Double, [((Name, Icon), (Bool, Angle Double))])
|
||||
placeNodes layoutResult edges = (mconcat placedNodes, rotationMap)
|
||||
where
|
||||
connections = fmap edgeConnection edges
|
||||
positionMap = fst $ getGraph layoutResult
|
||||
-- The type annotation for rotatedNameDiagramMap is necessary here
|
||||
rotatedNameDiagramMap = rotateNodes positionMap connections :: [((Name, Icon), SpecialQDiagram b, (Bool, Angle Double))]
|
||||
rotatedNameDiagramMap = rotateNodes positionMap connections :: [((Name, Icon), SpecialQDiagram b Double, (Bool, Angle Double))]
|
||||
rotationMap = fmap (\(x, _, z) -> (x, z)) rotatedNameDiagramMap
|
||||
|
||||
placedNodes = map placeNode rotatedNameDiagramMap
|
||||
@ -339,11 +337,11 @@ customLayoutParams = GV.defaultParams{
|
||||
GV.fmtEdge = const [GV.arrowTo GV.noArrow]
|
||||
}
|
||||
|
||||
doGraphLayout :: forall b.
|
||||
SpecialBackend b =>
|
||||
doGraphLayout :: forall b n.
|
||||
SpecialBackend b Double =>
|
||||
Gr (Name, Icon) Edge
|
||||
-> [Edge]
|
||||
-> IO (SpecialQDiagram b)
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
doGraphLayout graph edges = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
@ -360,9 +358,9 @@ doGraphLayout graph edges = do
|
||||
--[GVA.Width diaWidth, GVA.Height diaHeight]
|
||||
[GVA.Width circleDiameter, GVA.Height circleDiameter]
|
||||
where
|
||||
-- This type annotation (:: SpecialQDiagram b) requires Scoped Typed Variables, which only works if the function's
|
||||
-- This type annotation (:: SpecialQDiagram b n) requires Scoped Typed Variables, which only works if the function's
|
||||
-- type signiture has "forall b e."
|
||||
dia = iconToDiagram nodeIcon (toName "") False 0 :: SpecialQDiagram b
|
||||
dia = iconToDiagram nodeIcon (toName "") False mempty :: SpecialQDiagram b Double
|
||||
|
||||
diaWidth = drawingToGraphvizScaleFactor * width dia
|
||||
diaHeight = drawingToGraphvizScaleFactor * height dia
|
||||
@ -372,16 +370,16 @@ doGraphLayout graph edges = do
|
||||
-- | 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 ::
|
||||
SpecialBackend b =>
|
||||
Drawing -> IO (SpecialQDiagram b)
|
||||
SpecialBackend b Double =>
|
||||
Drawing -> IO (SpecialQDiagram b Double)
|
||||
renderDrawing = renderIconGraph . drawingToIconGraph
|
||||
|
||||
renderIngSyntaxGraph ::
|
||||
SpecialBackend b =>
|
||||
Gr (Name, SyntaxNode) Edge -> IO (SpecialQDiagram b)
|
||||
SpecialBackend b Double =>
|
||||
Gr (Name, SyntaxNode) Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIngSyntaxGraph = renderIconGraph . ING.nmap (Control.Arrow.second nodeToIcon)
|
||||
|
||||
renderIconGraph :: SpecialBackend b => Gr (Name, Icon) Edge -> IO (SpecialQDiagram b)
|
||||
renderIconGraph :: SpecialBackend b Double => Gr (Name, Icon) Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIconGraph iconGraph = diagramAction where
|
||||
edges = ING.edgeLabel <$> ING.labEdges iconGraph
|
||||
diagramAction = doGraphLayout iconGraph edges
|
||||
|
||||
11
app/Types.hs
11
app/Types.hs
@ -12,6 +12,7 @@ module Types (
|
||||
IDState,
|
||||
SpecialQDiagram,
|
||||
SpecialBackend,
|
||||
SpecialNum,
|
||||
SgNamedNode,
|
||||
IngSyntaxGraph,
|
||||
initialIdState,
|
||||
@ -21,7 +22,9 @@ module Types (
|
||||
|
||||
import Diagrams.Prelude(Name, QDiagram, V2, Any, Renderable, Path)
|
||||
import Diagrams.TwoD.Text(Text)
|
||||
|
||||
import Control.Monad.State(State, state)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
-- TYPES --
|
||||
-- | A datatype that represents an icon.
|
||||
@ -75,10 +78,12 @@ data Drawing = Drawing [(Name, Icon)] [Edge] deriving (Show, Eq)
|
||||
-- | 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 SpecialNum n = (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n)
|
||||
|
||||
type SpecialQDiagram b = QDiagram b V2 Double Any
|
||||
-- Note that SpecialBackend is a constraint synonym, not a type synonym.
|
||||
type SpecialBackend b n = (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b)
|
||||
|
||||
type SpecialQDiagram b n = QDiagram b V2 n Any
|
||||
|
||||
type SgNamedNode = (Name, SyntaxNode)
|
||||
type IngSyntaxGraph gr = gr SgNamedNode Edge
|
||||
|
||||
@ -459,7 +459,7 @@ translateTests :: IO (Diagram B)
|
||||
translateTests = do
|
||||
drawings <- traverse translateStringToDrawing testDecls
|
||||
let
|
||||
textDrawings = fmap (\t -> alignL $ textBox t (toName "") False 0) testDecls
|
||||
textDrawings = fmap (\t -> alignL $ textBox t (toName "") False mempty) testDecls
|
||||
vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
|
||||
pure vCattedDrawings
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user