mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 10:20:27 +03:00
Extract the TransformableDia parameters to TransformParams.
This commit is contained in:
Robbie Gleichman
parent
7a854d9679
commit
6f18d5f96d
319
app/Icons.hs
319
app/Icons.hs
@ -3,6 +3,7 @@
|
||||
module Icons
|
||||
(
|
||||
Icon(..),
|
||||
TransformParams(..),
|
||||
TransformableDia,
|
||||
getPortAngles,
|
||||
iconToDiagram,
|
||||
@ -36,10 +37,19 @@ import DrawingColors(colorScheme, ColorStyle(..))
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
|
||||
-- TYPES --
|
||||
-- | A TransformableDia is a function that returns a diagram for an icon when given
|
||||
-- the icon's name, its nesting depth, whether it will be reflected, and by what
|
||||
-- angle it will be rotated.
|
||||
type TransformableDia b n = NodeName -> Int -> Bool -> Angle n -> SpecialQDiagram b n
|
||||
|
||||
data TransformParams n = TransformParams {
|
||||
tpName :: NodeName -- The icon's name
|
||||
, tpNestingDepth :: Int -- The icon's nesting depth
|
||||
, tpIsReflected :: Bool -- If the icon will be reflected
|
||||
, tpAngle :: Angle n -- By what angle will the icon be rotated
|
||||
}
|
||||
|
||||
-- | A TransformableDia is a function that returns a diagram for an icon when
|
||||
-- given the icon's name, its nesting depth, whether it will be reflected, and
|
||||
-- by what angle it will be rotated.
|
||||
type TransformableDia b n = TransformParams n -> SpecialQDiagram b n
|
||||
|
||||
|
||||
-- CONSTANTS --
|
||||
defaultLineWidth :: (Fractional a) => a
|
||||
@ -61,7 +71,8 @@ iconToDiagram icon = case icon of
|
||||
nestedApplyDia ApplyNodeFlavor Nothing $ replicate (1 + n) Nothing
|
||||
ComposeIcon n ->
|
||||
nestedApplyDia ComposeNodeFlavor Nothing $ replicate (1 + n) Nothing
|
||||
PAppIcon n str -> generalTextAppDia (patternTextC colorScheme) (patternC colorScheme) n str
|
||||
PAppIcon n str ->
|
||||
generalTextAppDia (patternTextC colorScheme) (patternC colorScheme) n str
|
||||
TextBoxIcon s -> textBox s
|
||||
BindTextBoxIcon s -> identDiaFunc $ bindTextBox s
|
||||
GuardIcon n -> nestedGuardDia $ replicate (1 + (2 * n)) Nothing
|
||||
@ -111,9 +122,10 @@ findIcon name args = icon where
|
||||
Nothing -> listToMaybe $ catMaybes $ fmap findSubSubIcon filteredArgs
|
||||
Just (argNum, NamedIcon _ finalIcon) -> Just (argNum, finalIcon)
|
||||
where
|
||||
findSubSubIcon (argNum, NamedIcon _ subIcon) = case findNestedIcon name subIcon of
|
||||
Nothing -> Nothing
|
||||
Just x -> Just (argNum, x)
|
||||
findSubSubIcon (argNum, NamedIcon _ subIcon)
|
||||
= case findNestedIcon name subIcon of
|
||||
Nothing -> Nothing
|
||||
Just x -> Just (argNum, x)
|
||||
|
||||
generalNestedPortAngles :: SpecialNum n
|
||||
=> (Port -> [Angle n])
|
||||
@ -133,7 +145,11 @@ reflectXAngle x = reflectedAngle where
|
||||
reflectedAngle = (-) <$> halfTurn <*> normalizedAngle
|
||||
|
||||
-- TODO reflect the angles for the right side sub-icons
|
||||
nestedGuardPortAngles :: SpecialNum n => [Maybe NamedIcon] -> Port -> Maybe NodeName -> [Angle n]
|
||||
nestedGuardPortAngles :: SpecialNum n =>
|
||||
[Maybe NamedIcon]
|
||||
-> Port
|
||||
-> Maybe NodeName
|
||||
-> [Angle n]
|
||||
nestedGuardPortAngles args port maybeNodeName = case maybeNodeName of
|
||||
Nothing -> guardPortAngles port
|
||||
Just name -> case findIcon name args of
|
||||
@ -223,14 +239,19 @@ argumentPorts n = case n of
|
||||
|
||||
-- | Make an identity TransformableDia
|
||||
identDiaFunc :: SpecialNum n => SpecialQDiagram b n -> TransformableDia b n
|
||||
identDiaFunc dia name _ _ _ = nameDiagram name dia
|
||||
identDiaFunc dia transformParams = nameDiagram (tpName transformParams) dia
|
||||
|
||||
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
||||
nameDiagram :: SpecialNum n => NodeName -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
-- | Names the diagram and puts all sub-names in the namespace of the top level
|
||||
-- name.
|
||||
nameDiagram :: SpecialNum n =>
|
||||
NodeName
|
||||
-> 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.
|
||||
-- | 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 :: SpecialNum n => Port -> SpecialQDiagram b n
|
||||
makePort x = named x mempty
|
||||
--makePort x = circle 0.2 # fc green # named x
|
||||
@ -259,10 +280,12 @@ makeLabelledPort name reflect angle str portNum = case str of
|
||||
-- BEGIN Sub-diagrams --
|
||||
|
||||
apply0Triangle :: SpecialBackend b n => Colour Double -> SpecialQDiagram b n
|
||||
apply0Triangle col = fc col $ lw none $ rotateBy (-1/12) $ eqTriangle (2 * circleRadius)
|
||||
apply0Triangle col
|
||||
= fc col $ lw none $ rotateBy (-1/12) $ eqTriangle (2 * circleRadius)
|
||||
|
||||
composeSemiCircle :: SpecialBackend b n => Colour Double -> SpecialQDiagram b n
|
||||
composeSemiCircle col = lc col $ lwG defaultLineWidth $ wedge circleRadius yDir halfTurn
|
||||
composeSemiCircle col
|
||||
= lc col $ lwG defaultLineWidth $ wedge circleRadius yDir halfTurn
|
||||
|
||||
portCircle :: SpecialBackend b n => SpecialQDiagram b n
|
||||
portCircle = lw none $ fc lineCol $ circle (circleRadius * 0.5)
|
||||
@ -285,51 +308,94 @@ coloredApplyADia ::
|
||||
Colour Double -> Int -> SpecialQDiagram b n
|
||||
coloredApplyADia appColor n = centerXY finalDia where
|
||||
trianglePortsCircle = hcat [
|
||||
reflectX (apply0Triangle appColor),
|
||||
hcat $ take n $ map (\x -> makePort x <> portCircle <> strutX (circleRadius * 1.5)) argPortsConst,
|
||||
makePort resultPortConst <> alignR (lc appColor $ lwG defaultLineWidth $ fc appColor $ circle circleRadius)
|
||||
reflectX (apply0Triangle appColor)
|
||||
, hcat $ take n
|
||||
$ map
|
||||
(\x -> makePort x <> portCircle <> strutX (circleRadius * 1.5))
|
||||
argPortsConst
|
||||
, makePort resultPortConst
|
||||
<> alignR
|
||||
(lc appColor $ lwG defaultLineWidth $ fc appColor $ circle circleRadius)
|
||||
]
|
||||
allPorts = makePort inputPortConst <> alignL trianglePortsCircle
|
||||
topAndBottomLineWidth = width allPorts - circleRadius
|
||||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc appColor $ hrule topAndBottomLineWidth
|
||||
topAndBottomLine
|
||||
= alignL $ lwG defaultLineWidth $ lc appColor $ hrule topAndBottomLineWidth
|
||||
finalDia = topAndBottomLine === allPorts === topAndBottomLine
|
||||
|
||||
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
|
||||
generalTextAppDia
|
||||
textCol
|
||||
borderCol
|
||||
numArgs
|
||||
str
|
||||
(TransformParams name _ reflect angle)
|
||||
= nameDiagram name rotateDia
|
||||
where
|
||||
rotateDia =
|
||||
transformCorrectedTextBox str textCol borderCol reflect angle
|
||||
|||
|
||||
coloredApplyADia borderCol numArgs
|
||||
|
||||
-- TODO Refactor with generalNestedDia
|
||||
nestedPAppDia :: SpecialBackend b n =>
|
||||
[Colour Double] -> [(Maybe NamedIcon, String)] -> TransformableDia b n
|
||||
nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) -> centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
|
||||
where
|
||||
borderCol = borderCols !! nestingLevel
|
||||
nestedPAppDia
|
||||
borderCols
|
||||
funcNodeNameAndArgs
|
||||
(TransformParams name nestingLevel reflect angle)
|
||||
= named name $
|
||||
case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
(maybeFunText:args) ->
|
||||
centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
|
||||
where
|
||||
borderCol = borderCols !! nestingLevel
|
||||
|
||||
transformedText = case maybeFunText of
|
||||
(Just _, _) -> makeInnerIcon True inputPortConst maybeFunText
|
||||
(Nothing, _) -> mempty
|
||||
separation = circleRadius * 1.5
|
||||
verticalSeparation = circleRadius
|
||||
resultCircleAndPort = makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
||||
triangleAndPorts = vsep separation $
|
||||
rotate quarterTurn (apply0Triangle borderCol) :
|
||||
zipWith (makeInnerIcon False) argPortsConst args
|
||||
transformedText = case maybeFunText of
|
||||
(Just _, _) -> makeInnerIcon True inputPortConst maybeFunText
|
||||
(Nothing, _) -> mempty
|
||||
separation = circleRadius * 1.5
|
||||
verticalSeparation = circleRadius
|
||||
resultCircleAndPort
|
||||
= makeQualifiedPort name resultPortConst
|
||||
<> alignR
|
||||
(lc borderCol
|
||||
$ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
||||
triangleAndPorts = vsep separation $
|
||||
rotate quarterTurn (apply0Triangle borderCol) :
|
||||
zipWith (makeInnerIcon False) argPortsConst args
|
||||
|
||||
|
||||
allPorts = makeQualifiedPort name inputPortConst <> alignT triangleAndPorts -- alignL (strutX separation ||| trianglePortsCircle)
|
||||
topAndBottomLineWidth = width allPorts
|
||||
-- boxHeight = height
|
||||
argBox = alignT $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeparation) (circleRadius * 0.5)
|
||||
finalDia = argBox <> allPorts
|
||||
allPorts
|
||||
= makeQualifiedPort name inputPortConst <> alignT triangleAndPorts
|
||||
-- alignL (strutX separation ||| trianglePortsCircle)
|
||||
topAndBottomLineWidth = width allPorts
|
||||
-- boxHeight = height
|
||||
argBox
|
||||
= alignT $ lwG defaultLineWidth $ lc borderCol
|
||||
$ roundedRect
|
||||
topAndBottomLineWidth
|
||||
(height allPorts + verticalSeparation)
|
||||
(circleRadius * 0.5)
|
||||
finalDia = argBox <> allPorts
|
||||
|
||||
makeInnerIcon _ portNum (Nothing, str) = centerX $ makeLabelledPort name reflect angle str portNum
|
||||
makeInnerIcon True _ (Just (NamedIcon _ (TextBoxIcon t)), _) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
makeInnerIcon _ portNum (Nothing, str)
|
||||
= centerX $ makeLabelledPort name reflect angle str portNum
|
||||
makeInnerIcon True _ (Just (NamedIcon _ (TextBoxIcon t)), _)
|
||||
= transformCorrectedTextBox
|
||||
t
|
||||
(textBoxTextC colorScheme)
|
||||
borderCol
|
||||
reflect
|
||||
angle
|
||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _)
|
||||
= iconToDiagram
|
||||
icon
|
||||
(TransformParams iconNodeName innerLevel reflect angle)
|
||||
where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
generalNestedDia :: SpecialBackend b n
|
||||
=> (Colour Double -> SpecialQDiagram b n)
|
||||
@ -337,7 +403,13 @@ generalNestedDia :: SpecialBackend b n
|
||||
-> Maybe NamedIcon
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
generalNestedDia dia borderCols maybeFunText funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||
generalNestedDia
|
||||
dia
|
||||
borderCols
|
||||
maybeFunText
|
||||
funcNodeNameAndArgs
|
||||
(TransformParams name nestingLevel reflect angle)
|
||||
= named name $ case funcNodeNameAndArgs of
|
||||
[] -> mempty
|
||||
args -> centerXY $ transformedText ||| centerY finalDia
|
||||
where
|
||||
@ -351,17 +423,38 @@ generalNestedDia dia borderCols maybeFunText funcNodeNameAndArgs name nestingLev
|
||||
trianglePortsCircle = hsep seperation $
|
||||
reflectX (dia borderCol) :
|
||||
zipWith (makeInnerIcon False) argPortsConst args ++
|
||||
[makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
|
||||
[makeQualifiedPort name resultPortConst
|
||||
<> alignR
|
||||
(lc borderCol $ lwG defaultLineWidth $ fc borderCol
|
||||
$ circle circleRadius)
|
||||
]
|
||||
|
||||
allPorts = makeQualifiedPort name inputPortConst <> alignL trianglePortsCircle
|
||||
allPorts
|
||||
= makeQualifiedPort name inputPortConst <> alignL trianglePortsCircle
|
||||
topAndBottomLineWidth = width allPorts - circleRadius
|
||||
argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeperation) (circleRadius * 0.5)
|
||||
argBox
|
||||
= alignL $ lwG defaultLineWidth $ lc borderCol
|
||||
$ roundedRect
|
||||
topAndBottomLineWidth
|
||||
(height allPorts + verticalSeperation)
|
||||
(circleRadius * 0.5)
|
||||
finalDia = argBox <> allPorts
|
||||
|
||||
makeInnerIcon _ portNum Nothing = makeQualifiedPort name portNum <> portCircle
|
||||
makeInnerIcon True _ (Just (NamedIcon _ (TextBoxIcon t))) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
makeInnerIcon _ portNum Nothing
|
||||
= makeQualifiedPort name portNum <> portCircle
|
||||
makeInnerIcon True _ (Just (NamedIcon _ (TextBoxIcon t)))
|
||||
= transformCorrectedTextBox
|
||||
t
|
||||
(textBoxTextC colorScheme)
|
||||
borderCol
|
||||
reflect
|
||||
angle
|
||||
makeInnerIcon func _ (Just (NamedIcon iconNodeName icon))
|
||||
= iconToDiagram
|
||||
icon
|
||||
(TransformParams iconNodeName innerLevel reflect angle)
|
||||
where
|
||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||
|
||||
nestedApplyDia :: SpecialBackend b n
|
||||
=> LikeApplyFlavor
|
||||
@ -370,7 +463,8 @@ nestedApplyDia :: SpecialBackend b n
|
||||
-> TransformableDia b n
|
||||
nestedApplyDia flavor = case flavor of
|
||||
ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme)
|
||||
ComposeNodeFlavor -> generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
||||
ComposeNodeFlavor ->
|
||||
generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme)
|
||||
|
||||
-- END Apply like diagrams
|
||||
|
||||
@ -402,15 +496,19 @@ textFont = "monospace"
|
||||
rectForText :: (InSpace V2 n t, TrailLike t) => Int -> t
|
||||
rectForText n = rect rectangleWidth (textBoxFontSize * textBoxHeightFactor)
|
||||
where
|
||||
rectangleWidth = (fromIntegral n * textBoxFontSize * monoLetterWidthToHeightFraction)
|
||||
+ (textBoxFontSize * 0.3)
|
||||
rectangleWidth
|
||||
= (fromIntegral n * textBoxFontSize * monoLetterWidthToHeightFraction)
|
||||
+ (textBoxFontSize * 0.3)
|
||||
|
||||
-- END Text helper functions
|
||||
|
||||
commentTextArea :: SpecialBackend b n =>
|
||||
Colour Double -> String -> SpecialQDiagram b n
|
||||
commentTextArea textColor t =
|
||||
alignL $ fontSize (local textBoxFontSize) (font textFont $ fc textColor $ topLeftText t)
|
||||
alignL
|
||||
$ fontSize
|
||||
(local textBoxFontSize)
|
||||
(font textFont $ fc textColor $ topLeftText t)
|
||||
<> alignTL (lw none $ rectForText (length t))
|
||||
|
||||
multilineComment :: SpecialBackend b n =>
|
||||
@ -426,30 +524,53 @@ coloredTextBox :: SpecialBackend b n =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b n
|
||||
coloredTextBox textColor boxColor t =
|
||||
fontSize (local textBoxFontSize) (bold $ font textFont $ fc textColor $ text t)
|
||||
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
|
||||
fontSize
|
||||
(local textBoxFontSize)
|
||||
(bold $ font textFont $ fc textColor $ text t)
|
||||
<> lwG
|
||||
(0.6 * defaultLineWidth)
|
||||
(lcA boxColor
|
||||
$ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
|
||||
|
||||
transformCorrectedTextBox :: SpecialBackend b n =>
|
||||
String -> Colour Double -> Colour Double -> Bool -> Angle n -> SpecialQDiagram 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))
|
||||
rotateBy
|
||||
textBoxRotation
|
||||
(reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str))
|
||||
where
|
||||
-- If normalizeAngle is slow, the commented out function reduceAngleRange might be faster
|
||||
-- If normalizeAngle is slow, the commented out function reduceAngleRange
|
||||
-- might be faster.
|
||||
reducedAngle = normalizeAngle 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
|
||||
textBoxRotation
|
||||
= if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0
|
||||
reflectIfTrue shouldReflect dia
|
||||
= if shouldReflect then reflectX dia else dia
|
||||
|
||||
transformableBindTextBox :: SpecialBackend b n =>
|
||||
String -> Bool -> Angle n -> SpecialQDiagram b n
|
||||
transformableBindTextBox str = transformCorrectedTextBox str (bindTextBoxTextC colorScheme) (bindTextBoxC colorScheme)
|
||||
transformableBindTextBox str
|
||||
= transformCorrectedTextBox
|
||||
str
|
||||
(bindTextBoxTextC colorScheme)
|
||||
(bindTextBoxC colorScheme)
|
||||
|
||||
bindTextBox :: SpecialBackend b n =>
|
||||
String -> SpecialQDiagram b n
|
||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
||||
bindTextBox
|
||||
= coloredTextBox (bindTextBoxTextC colorScheme)
|
||||
$ opaque (bindTextBoxC colorScheme)
|
||||
|
||||
textBox :: SpecialBackend b n =>
|
||||
String -> TransformableDia b n
|
||||
textBox t name _ reflect angle = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect angle
|
||||
textBox t (TransformParams name _ reflect angle)
|
||||
= nameDiagram name $ transformCorrectedTextBox
|
||||
t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect angle
|
||||
|
||||
-- END Text boxes and icons
|
||||
|
||||
@ -460,10 +581,14 @@ guardSize = 0.7
|
||||
guardTriangle :: SpecialBackend b n =>
|
||||
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
guardTriangle portDia =
|
||||
alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> portDia
|
||||
alignL
|
||||
$ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8)))
|
||||
<> portDia
|
||||
where
|
||||
triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
|
||||
polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
|
||||
polygon
|
||||
(polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize]
|
||||
$ with)
|
||||
|
||||
-- | generalNestedGuard port layout:
|
||||
-- 0 -> top
|
||||
@ -476,7 +601,9 @@ generalNestedGuard :: SpecialBackend b n
|
||||
-> SpecialQDiagram b n
|
||||
-> [Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLevel reflect angle = named name $ case inputAndArgs of
|
||||
generalNestedGuard triangleColor lBracket bottomDia inputAndArgs
|
||||
(TransformParams name nestingLevel reflect angle)
|
||||
= named name $ case inputAndArgs of
|
||||
[] -> mempty
|
||||
input : args -> centerXY finalDia where
|
||||
finalDia = alignT (bottomDia <> makeQualifiedPort name resultPortConst)
|
||||
@ -491,19 +618,26 @@ generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLev
|
||||
where
|
||||
port = makeQualifiedPort name (Port portNum)
|
||||
|
||||
(lBrackets, trianglesWithPorts) = partitionEithers $ zipWith iconMapper argPortsConst args
|
||||
(lBrackets, trianglesWithPorts)
|
||||
= partitionEithers $ zipWith iconMapper argPortsConst args
|
||||
|
||||
trianglesAndBrackets =
|
||||
zipWith zipper trianglesWithPorts lBrackets
|
||||
|
||||
zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
|
||||
zipper thisTriangle lBrack
|
||||
= verticalLine
|
||||
===
|
||||
(alignR (extrudeRight guardSize lBrack)
|
||||
<> lc triangleColor (alignL thisTriangle))
|
||||
where
|
||||
verticalLine = strutY 0.4
|
||||
|
||||
inputIcon = makeInnerIcon False input
|
||||
|
||||
guardDia = vcat (alignT trianglesAndBrackets)
|
||||
bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||
bigVerticalLine
|
||||
= alignT
|
||||
$ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
|
||||
|
||||
makeInnerIcon innerReflected mNameAndIcon = case mNameAndIcon of
|
||||
Nothing -> mempty
|
||||
@ -511,21 +645,29 @@ generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLev
|
||||
then reflectX dia
|
||||
else dia
|
||||
where
|
||||
dia = iconToDiagram icon iconNodeName nestingLevel (innerReflected /= reflect) angle
|
||||
dia = iconToDiagram icon (TransformParams
|
||||
iconNodeName
|
||||
nestingLevel
|
||||
(innerReflected /= reflect)
|
||||
angle)
|
||||
|
||||
guardLBracket :: SpecialBackend b n =>
|
||||
SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
guardLBracket portDia = alignL (alignT ell) <> portDia
|
||||
where
|
||||
ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize, 0)]
|
||||
ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
||||
ell
|
||||
= lineJoin LineJoinRound
|
||||
$ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
||||
|
||||
-- | The ports of the guard icon are as follows:
|
||||
-- inputPortConst: Top result port (not used)
|
||||
-- resultPortConst: Bottom result port
|
||||
-- Ports 3,5...: The left ports for the booleans
|
||||
-- Ports 2,4...: The right ports for the values
|
||||
nestedGuardDia :: SpecialBackend b n => [Maybe NamedIcon] -> TransformableDia b n
|
||||
nestedGuardDia :: SpecialBackend b n =>
|
||||
[Maybe NamedIcon]
|
||||
-> TransformableDia b n
|
||||
nestedGuardDia = generalNestedGuard lineCol guardLBracket mempty
|
||||
|
||||
-- TODO Improve design to be more than a circle.
|
||||
@ -554,14 +696,27 @@ nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
|
||||
-- 1: The lambda function value
|
||||
-- 2,3.. : The parameters
|
||||
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
||||
flatLambda paramNames name _ reflect angle = named name finalDia where
|
||||
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
|
||||
lambdaParts = (makeQualifiedPort name inputPortConst <> resultIcon) : (portIcons ++ [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
|
||||
flatLambda paramNames (TransformParams name _ reflect angle)
|
||||
= named name finalDia
|
||||
where
|
||||
lambdaCircle
|
||||
= lwG defaultLineWidth
|
||||
$ lc (regionPerimC colorScheme)
|
||||
$ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
|
||||
lambdaParts
|
||||
= (makeQualifiedPort name inputPortConst <> resultIcon)
|
||||
:
|
||||
(portIcons
|
||||
++ [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
|
||||
|
||||
portIcons = zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||
portIcons
|
||||
= zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||
middle = alignL (hsep 0.5 lambdaParts)
|
||||
topAndBottomLineWidth = width middle - circleRadius
|
||||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
||||
topAndBottomLine
|
||||
= alignL
|
||||
$ lwG defaultLineWidth
|
||||
$ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
||||
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
|
||||
|
||||
-- END Main icons
|
||||
|
||||
@ -25,7 +25,8 @@ import Data.Typeable(Typeable)
|
||||
--import qualified Debug.Trace
|
||||
--import Data.Word(Word16)
|
||||
|
||||
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..), getPortAngles)
|
||||
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..)
|
||||
, getPortAngles, TransformParams(..))
|
||||
import TranslateCore(nodeToIcon)
|
||||
import Types(Edge(..), Icon, EdgeOption(..), Drawing(..), EdgeEnd(..),
|
||||
NameAndPort(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..), Port(..),
|
||||
@ -293,7 +294,7 @@ placeNodes layoutResult graph = (mconcat placedNodes, rotationMap)
|
||||
|
||||
-- todo: Not sure if the diagrams should already be centered at this point.
|
||||
placeNode (key@(NamedIcon name icon), (reflected, angle)) = place transformedDia diaPosition where
|
||||
origDia = iconToDiagram icon name 0 reflected angle
|
||||
origDia = iconToDiagram icon (TransformParams name 0 reflected angle)
|
||||
transformedDia = centerXY $ rotate angle $ (if reflected then reflectX else id) origDia
|
||||
diaPosition = graphvizScaleFactor *^ (positionMap Map.! key)
|
||||
|
||||
@ -338,7 +339,10 @@ doGraphLayout graph = do
|
||||
where
|
||||
-- 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 (NodeName (-1)) 0 False mempty :: SpecialQDiagram b Double
|
||||
dia :: SpecialQDiagram b Double
|
||||
dia = iconToDiagram
|
||||
nodeIcon
|
||||
(TransformParams (NodeName (-1)) 0 False mempty)
|
||||
|
||||
diaWidth = drawingToGraphvizScaleFactor * width dia
|
||||
diaHeight = drawingToGraphvizScaleFactor * height dia
|
||||
|
||||
@ -12,7 +12,7 @@ View circle.svg with svg-preview plug-in.
|
||||
To use ghci for the main executable:
|
||||
stack ghci glance
|
||||
|
||||
To use ghci with the test file:
|
||||
To use ghci with the test modules:
|
||||
stack ghci glance:test:glance-test
|
||||
|
||||
For all warnings (some warnings duplicated):
|
||||
|
||||
@ -10,10 +10,11 @@ import qualified Data.Graph.Inductive.Graph as ING
|
||||
import Data.List(intercalate)
|
||||
|
||||
import Types(SpecialQDiagram, SpecialBackend, NodeName(..))
|
||||
import Translate(translateStringToCollapsedGraphAndDecl, translateStringToSyntaxGraph)
|
||||
import Translate(translateStringToCollapsedGraphAndDecl
|
||||
, translateStringToSyntaxGraph)
|
||||
import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..))
|
||||
import Rendering(renderIngSyntaxGraph)
|
||||
import Icons(textBox)
|
||||
import Icons(textBox, TransformParams(..))
|
||||
|
||||
|
||||
prettyShowList :: Show a => [a] -> String
|
||||
@ -202,7 +203,7 @@ letTests = [
|
||||
-- TODO fix. See UnitTests/letTests
|
||||
"y = g $ f y",
|
||||
"y = let {a = f b; b = g a} in b",
|
||||
|
||||
|
||||
"y = let {a= 1; x = let {a = 27; x = f a 2} in x} in x",
|
||||
"y = let {a = b; b = a; d = f a} in d",
|
||||
"y = let {a = b; b = a} in a",
|
||||
@ -255,7 +256,9 @@ testDecls = mconcat [
|
||||
]
|
||||
|
||||
|
||||
translateStringToDrawing :: SpecialBackend b Double => String -> IO (SpecialQDiagram b Double)
|
||||
translateStringToDrawing :: SpecialBackend b Double =>
|
||||
String
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
translateStringToDrawing s = do
|
||||
putStrLn $ "Translating string: " ++ s
|
||||
let
|
||||
@ -280,6 +283,10 @@ visualTranslateTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
||||
visualTranslateTests = do
|
||||
drawings <- traverse translateStringToDrawing testDecls
|
||||
let
|
||||
textDrawings = fmap (\t -> alignL $ textBox t (NodeName (-1)) 0 False mempty) testDecls
|
||||
textDrawings
|
||||
= fmap
|
||||
(\t ->
|
||||
alignL $ textBox t (TransformParams (NodeName (-1)) 0 False mempty))
|
||||
testDecls
|
||||
vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
|
||||
pure vCattedDrawings
|
||||
|
||||
Loading…
Reference in New Issue
Block a user