Use bezier curves for edges.

2024-09-11 15:05:41 +03:00 · 2016-12-01 20:46:24 -08:00 · 2016-12-01 20:46:24 -08:00 · a250b479a5
commit a250b479a5
parent 334369afac
5 changed files with 163 additions and 55 deletions
--- a/app/Icons.hs
+++ b/app/Icons.hs
@ -3,10 +3,10 @@ module Icons
    (
    Icon(..),
    TransformableDia,
+    portAngles,
    applyADia,
    flatLambda,
    iconToDiagram,
-    nameDiagram,
    textBox,
    multilineComment,
    enclosure,
@ -22,27 +22,31 @@ module Icons
    ) where

 import Diagrams.Prelude hiding ((&), (#))
+
+import Data.List(find)
+import Data.Maybe(catMaybes, listToMaybe)
+import Data.Typeable(Typeable)
+
 -- import Diagrams.Backend.SVG(B)
 --import Diagrams.TwoD.Text(Text)
-import Data.Typeable(Typeable)
 --import Data.Maybe(fromMaybe)

 import Types(Icon(..), SpecialQDiagram, SpecialBackend)
 import DrawingColors(colorScheme, ColorStyle(..))

 -- TYPES --
-type TransformableDia b = (Bool -> Double -> SpecialQDiagram b)
+-- TODO Consider changing the order to
+-- (Name -> Bool -> Double -> SpecialQDiagram b)
+type TransformableDia b = (Bool -> Double -> Name -> SpecialQDiagram b)

 -- COLORS --
 lineCol :: Colour Double
 lineCol = lineC colorScheme

 -- FUNCTIONS --
-- Optimization: The apply0NDia's can be memoized.
 iconToDiagram :: SpecialBackend b => Icon -> TransformableDia b
 iconToDiagram (ApplyAIcon n) = identDiaFunc $ applyADia n
 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) = textBox s
@ -54,9 +58,63 @@ iconToDiagram (FlatLambdaIcon n) = identDiaFunc $ flatLambda n
 iconToDiagram (NestedApply args) = nestedApplyDia args
 iconToDiagram (NestedPApp args) = nestedPAppDia args

+applyPortAngles :: (Integral a, Floating n) => a -> [Angle n]
+applyPortAngles x = case x of
+  0 -> [1/2 @@ turn]
+  1 -> [0 @@ turn]
+  _ -> fmap (@@ turn) [1/4, 3/4]
+
+guardPortAngles :: (Integral a, Floating n) => a -> [Angle n]
+guardPortAngles port = case port of
+  0 -> [1/4 @@ turn]
+  1 -> [3/4 @@ turn]
+  _ -> otherAngles where otherAngles
+                           | even port = [0 @@ turn]
+                           | otherwise = [1/2 @@ turn]
+
+findNestedIcon :: Name -> Icon -> Maybe Icon
+findNestedIcon name icon = case icon of
+  NestedApply args -> findIcon name args
+  NestedPApp args -> findIcon name args
+  _ -> Nothing
+
+findIcon :: Name -> [Maybe (Name, Icon)] -> Maybe Icon
+findIcon name args = icon where
+  filteredArgs = catMaybes args
+  nameMatches (n, _) = n == name
+  icon = case filteredArgs of
+    [] -> Nothing
+    _ ->  case find nameMatches filteredArgs of
+      Nothing -> listToMaybe $ catMaybes $ fmap (findNestedIcon name . snd) filteredArgs
+      Just (_, finalIcon) -> Just finalIcon
+  
+nestedApplyPortAngles :: (Integral a, Floating n) => [Maybe (Name, Icon)] -> a -> Maybe Name -> [Angle n]
+nestedApplyPortAngles args port maybeName = case maybeName of
+  Nothing -> applyPortAngles port
+  Just name -> case findIcon name args of
+    Nothing -> []
+    Just icon -> portAngles icon port Nothing
+
+portAngles :: (Integral a, Floating n) => Icon -> a -> Maybe Name -> [Angle n]
+portAngles icon port maybeName = case icon of
+  ApplyAIcon _ -> applyPortAngles port
+  PAppIcon _ _ -> applyPortAngles port
+  ResultIcon -> []
+  BranchIcon -> []
+  TextBoxIcon _ -> []
+  BindTextBoxIcon _ -> []
+  GuardIcon _ -> guardPortAngles port
+  CaseIcon _ -> guardPortAngles port
+  CaseResultIcon -> []
+  FlatLambdaIcon _ -> applyPortAngles port
+  NestedApply args -> nestedApplyPortAngles args port maybeName
+  NestedPApp args -> nestedApplyPortAngles args port maybeName
+
+-- END FUNCTIONS --
+
 -- Make an identity TransformableDia
 identDiaFunc :: SpecialQDiagram b -> TransformableDia b
-identDiaFunc dia _ _ = dia
+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
@ -122,13 +180,13 @@ 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
+  Colour Double -> Colour Double -> Int -> String -> TransformableDia b
+generalTextAppDia textCol borderCol numArgs str reflect angle name = nameDiagram name rotateDia where
  rotateDia = transformCorrectedTextBox str textCol borderCol reflect angle |||
    coloredApplyADia borderCol numArgs

 transformCorrectedTextBox :: SpecialBackend b =>
-  String -> Colour Double -> Colour Double -> TransformableDia b
+  String -> Colour Double -> Colour Double -> Bool -> Double -> SpecialQDiagram b
 transformCorrectedTextBox str textCol borderCol reflect angle =
  rotateBy textBoxRotation (reflectIfTrue reflect (coloredTextBox textCol (opaque borderCol) str))
  where
@ -146,10 +204,11 @@ nestedPAppDia = generalNestedDia (patternC colorScheme)

 generalNestedDia :: SpecialBackend b =>
  Colour Double -> [Maybe (Name, Icon)] -> TransformableDia b
-generalNestedDia borderCol funcNameAndArgs reflect angle = case funcNameAndArgs of
+generalNestedDia borderCol funcNameAndArgs reflect angle name = named name $ case funcNameAndArgs of
  [] -> mempty
  (maybeFunText:args) -> centerXY $  transformedText ||| centerY finalDia
    where
+      makeQualifiedPort x = name .>> makePort x
      transformedText = case maybeFunText of
        Just _ -> makeInnerIcon 0 maybeFunText
        Nothing -> mempty
@ -158,15 +217,15 @@ generalNestedDia borderCol funcNameAndArgs reflect angle = case funcNameAndArgs
      trianglePortsCircle = hsep seperation $
        reflectX (fc borderCol apply0Triangle) :
        zipWith makeInnerIcon [2,3..] args ++
-        [makePort 1 <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
+        [makeQualifiedPort 1 <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
  
-      allPorts = makePort 0 <> alignL trianglePortsCircle
+      allPorts = makeQualifiedPort 0 <> alignL trianglePortsCircle
      topAndBottomLineWidth = width allPorts - circleRadius
      argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ rect topAndBottomLineWidth (height allPorts + verticalSeperation)
      finalDia = argBox <> allPorts

-      makeInnerIcon portNum Nothing = makePort portNum <> portCircle
-      makeInnerIcon _ (Just (iconName, icon)) = nameDiagram iconName $ iconToDiagram icon reflect angle
+      makeInnerIcon portNum Nothing = makeQualifiedPort portNum <> portCircle
+      makeInnerIcon _ (Just (iconName, icon)) = iconToDiagram icon reflect angle iconName


 -- TEXT ICON --
@ -179,7 +238,7 @@ textBoxHeightFactor = 1.1

 textBox :: SpecialBackend b =>
  String -> TransformableDia b
-textBox t = transformCorrectedTextBox t (textBoxTextC colorScheme) $ textBoxC colorScheme
+textBox t reflect rotate name = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect rotate

 bindTextBox :: SpecialBackend b =>
  String -> SpecialQDiagram b
@ -268,6 +327,11 @@ guardLBracket x = alignL (alignT ell) <> makePort x
    ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
    ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)

+-- | generalGuardIcon port layout:
+-- 0 -> top
+-- 1 -> bottom
+-- odds -> left
+-- evens -> right
 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)
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@ -28,7 +28,7 @@ import Data.Typeable(Typeable)
 --import qualified Debug.Trace
 --import Data.Word(Word16)

-import Icons(colorScheme, iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..), TransformableDia)
+import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..), portAngles)
 import TranslateCore(nodeToIcon)
 import Types(Edge(..), Icon, EdgeOption(..), Connection, Drawing(..), EdgeEnd(..),
  NameAndPort(..), SpecialQDiagram, SpecialBackend, SyntaxNode)
@ -92,8 +92,8 @@ bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where
  c1 = rotate angle1 (scale scaleFactor unitX)
  c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x

-getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption]-> ArrowOpts n
-getArrowOpts (t, h) opts = arrowOptions
+getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> [EdgeOption] -> (Angle n, Angle n) -> ArrowOpts n
+getArrowOpts (t, h) opts (fromAngle, toAngle) = arrowOptions
  where
    shaftColor = if EdgeInPattern `elem` opts then patternC else lineC
    ap1ArgTexture = solid (backgroundC colorScheme)
@ -113,30 +113,72 @@ getArrowOpts (t, h) opts = arrowOptions
    arrowOptions =
      arrowHead .~ noHead $
      arrowTail .~ noTail $
+      arrowShaft .~ bezierShaft fromAngle toAngle $
      lengths .~ global 0.75 $
-      shaftStyle %~ (lwG defaultLineWidth . lc (shaftColor colorScheme)) $
+      shaftStyle %~ (lwG defaultLineWidth . lcA (withOpacity (shaftColor colorScheme) 0.7)) $
      lookupHead h $ lookupTail t with

 -- | Given an Edge, return a transformation on Diagrams that will draw a line.
-connectMaybePorts :: SpecialBackend b =>
-  Edge -> SpecialQDiagram b -> SpecialQDiagram b
-connectMaybePorts (Edge opts ends (NameAndPort icon0 (Just port0), NameAndPort icon1 (Just port1))) =
-  connect'
-  (getArrowOpts ends opts)
-  (icon0 .> port0)
-  (icon1 .> port1)
-connectMaybePorts (Edge opts ends (NameAndPort icon0 Nothing, NameAndPort icon1 (Just port1))) =
-  connectOutside' (getArrowOpts ends opts) icon0 (icon1 .> port1)
-connectMaybePorts (Edge opts ends (NameAndPort icon0 (Just port0), NameAndPort icon1 Nothing)) =
-  connectOutside' (getArrowOpts ends opts) (icon0 .> port0) icon1
-connectMaybePorts (Edge opts ends (NameAndPort icon0 Nothing, NameAndPort icon1 Nothing)) =
-  connectOutside' (getArrowOpts ends opts) icon0 icon1
+--connectMaybePorts :: SpecialBackend b =>
+--  a -> Edge -> SpecialQDiagram b -> SpecialQDiagram b
+connectMaybePorts :: (Floating n, SpecialBackend b) =>
+  (Angle Double, Angle Double)-> Edge -> SpecialQDiagram b -> SpecialQDiagram b
+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
+    (Just port0, Just port1) -> (connect', name0 .> port0, name1 .> port1)
+    (Nothing, Just port1) -> (connectOutside', name0, name1 .> port1)
+    (Just port0, Nothing) -> (connectOutside', name0 .> port0, name1)
+    (_, _) -> (connectOutside', name0, name1)

-makeConnections :: SpecialBackend b =>
-  [Edge] -> SpecialQDiagram b -> SpecialQDiagram b
-makeConnections edges = applyAll connections
+-- START addEdges --
+nameAndPortToName (NameAndPort name mPort) = case mPort of
+  Nothing -> name
+  Just port -> name .> port
+
+findPortAngles :: Floating n => (Name, Icon) -> NameAndPort -> [Angle n]
+findPortAngles (nodeName, nodeIcon) (NameAndPort diaName mPort) = case mPort of
+  Nothing -> []
+  Just port -> foundAngles where
+    mName = if nodeName == diaName then Nothing else Just diaName
+    foundAngles = portAngles nodeIcon port mName
+
+makeEdge :: (SpecialBackend b, ING.Graph gr) =>
+  gr (Name, Icon) Edge -> SpecialQDiagram b -> ING.LEdge Edge -> SpecialQDiagram b -> SpecialQDiagram b
+makeEdge graph dia (node0, node1, edge@(Edge _ _ (namePort0, namePort1))) =
+  connectMaybePorts portAngles edge
  where
-    connections = map connectMaybePorts edges
+    node0label = fromMaybeError ("node0 is not in graph. node0: " ++ show node0) $
+      ING.lab graph node0
+    node1label = fromMaybeError ("node0 is not in graph. node1: " ++ show node1) $
+      ING.lab graph node1
+    icon0Angle = case findPortAngles node0label namePort0 of
+      [] -> 0 @@ turn
+      (x:_) -> ((x ^. turn) - (shaftAngle ^. turn)) @@ turn
+    icon1Angle =  case findPortAngles node1label namePort1 of
+      [] -> 1/2 @@ turn
+      (x:_) -> ((x ^. turn) - (shaftAngle ^. turn)) @@ turn
+
+    diaNamePointMap = names dia
+    port0Point = getPortPoint $ nameAndPortToName namePort0
+    port1Point = getPortPoint $ nameAndPortToName namePort1
+    shaftVector = port1Point .-. port0Point
+    shaftAngle = signedAngleBetween shaftVector unitX
+    --fromAngle = icon0Angle - shaftAngle
+    --toAngle = icon1Angle - shaftAngle
+
+    getPortPoint n = head $ fromMaybeError
+      ("makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: " ++ show diaNamePointMap)
+      (lookup n diaNamePointMap)
+    
+    portAngles = (icon0Angle, icon1Angle)
+
+
+addEdges :: (SpecialBackend b, ING.Graph gr) =>
+  gr (Name, Icon) Edge -> SpecialQDiagram b -> SpecialQDiagram b
+addEdges graph dia = applyAll connections dia
+  where
+    connections = fmap (makeEdge graph dia) $ ING.labEdges graph

 -- ROTATING/FLIPPING ICONS --

@ -198,14 +240,14 @@ rotateNodes :: SpecialBackend b =>
 rotateNodes positionMap edges = map rotateDiagram (Map.keys positionMap)
  where
    positionMapNameKeys = Map.mapKeys fst positionMap
-    rotateDiagram key@(name, icon) = (key, nameDiagram name transformedDia)
+    rotateDiagram key@(name, icon) = (key, transformedDia)
      where
        originalDia = iconToDiagram icon
        transformedDia = if flippedDist < unflippedDist
-          then rotateBy flippedAngle . reflectX $ originalDia True flippedAngle
-          else rotateBy unflippedAngle $ originalDia False unflippedAngle
-        (unflippedAngle, unflippedDist) = minAngleForDia (originalDia False 0)
-        (flippedAngle, flippedDist) = minAngleForDia (reflectX $ originalDia True 0)
+          then rotateBy flippedAngle . reflectX $ originalDia True flippedAngle name
+          else rotateBy unflippedAngle $ originalDia False unflippedAngle name
+        (unflippedAngle, unflippedDist) = minAngleForDia (originalDia False 0 name)
+        (flippedAngle, flippedDist) = minAngleForDia (reflectX $ originalDia True 0 name)
        --minAngleForDia :: QDiagram b V2 Double m -> (Double, Double)
        minAngleForDia dia = minAngle where
        --ports = Debug.Trace.trace ((show $ names dia) ++ "\n") $ names dia
@ -235,14 +277,15 @@ type LayoutResult a b = Gr (GV.AttributeNode (Name, b)) (GV.AttributeNode a)

 placeNodes :: SpecialBackend b =>
   LayoutResult a Icon
-   -> [Connection]
+   -> [Edge]
   -> SpecialQDiagram b
 placeNodes layoutResult edges = mconcat placedNodes
  where
+    connections = fmap edgeConnection edges
    positionMap = fst $ getGraph layoutResult
-    rotatedNameDiagramMap = rotateNodes positionMap edges
-    placedNodes = map placeNode rotatedNameDiagramMap
-    --placedNodes = map placeNode nameDiagramMap
+    --rotatedNameDiagramMap = rotateNodes positionMap connections
+    --placedNodes = map placeNode rotatedNameDiagramMap
+    placedNodes = map placeNode $ (\key@(name, icon) -> (key, iconToDiagram icon False 0 name)) <$> Map.keys positionMap
    -- todo: Not sure if the diagrams should already be centered at this point.
    placeNode (name, diagram) = place (centerXY diagram) (graphvizScaleFactor *^ (positionMap Map.! name))

@ -265,15 +308,15 @@ customLayoutParams = GV.defaultParams{
  GV.fmtEdge = const [GV.arrowTo GV.noArrow]
  }

-doGraphLayout :: forall b e.
+doGraphLayout :: forall b.
  SpecialBackend b =>
-  Gr (Name, Icon) e
-  -> [Connection]
+  Gr (Name, Icon) Edge
+  -> [Edge]
  -> IO (SpecialQDiagram b)
 doGraphLayout graph edges = do
  layoutResult <- layoutGraph' layoutParams GVA.Neato graph
  --  layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
-  return $ placeNodes layoutResult edges
+  pure $ addEdges graph $ placeNodes layoutResult edges
  where
    layoutParams :: GV.GraphvizParams Int (Name,Icon) e () (Name,Icon)
    --layoutParams :: GV.GraphvizParams Int l el Int l
@ -288,7 +331,7 @@ doGraphLayout graph edges = do
      where
        -- This type annotation (:: SpecialQDiagram b) requires Scoped Typed Variables, which only works if the function's
        -- type signiture has "forall b e."
-        dia = iconToDiagram nodeIcon False 0 :: SpecialQDiagram b
+        dia = iconToDiagram nodeIcon False 0 (toName ""):: SpecialQDiagram b

        diaWidth = drawingToGraphvizScaleFactor * width dia
        diaHeight = drawingToGraphvizScaleFactor * height dia
@ -310,6 +353,4 @@ renderIngSyntaxGraph = renderIconGraph . ING.nmap (Control.Arrow.second nodeToIc
 renderIconGraph :: SpecialBackend b => Gr (Name, Icon) Edge -> IO (SpecialQDiagram b)
 renderIconGraph iconGraph = diagramAction where
  edges = ING.edgeLabel <$> ING.labEdges iconGraph
-  connections = fmap edgeConnection edges
-  diagramAction = makeConnections edges <$>
-    doGraphLayout iconGraph connections
+  diagramAction = doGraphLayout iconGraph edges
--- a/app/Types.hs
+++ b/app/Types.hs
@ -31,7 +31,7 @@ import Control.Monad.State(State, state)
 -- subdrawing.
 data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
  | FlatLambdaIcon Int | ApplyAIcon Int
-  | TextApplyAIcon Int String | PAppIcon Int String | CaseIcon Int | CaseResultIcon
+  | PAppIcon Int String | CaseIcon Int | CaseResultIcon
  | BindTextBoxIcon String
  -- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
  | NestedApply [Maybe (Name, Icon)]
--- a/test/AllTests.hs
+++ b/test/AllTests.hs
@ -454,7 +454,7 @@ translateTests :: IO (Diagram B)
 translateTests = do
  drawings <- traverse translateStringToDrawing testDecls
  let
-    textDrawings = fmap (\t -> alignL $ textBox t False 0) testDecls
+    textDrawings = fmap (\t -> alignL $ textBox t False 0 (toName "")) testDecls
    vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
  pure vCattedDrawings

--- a/todo.txt
+++ b/todo.txt
@ -9,6 +9,9 @@
 Fix the arrowheads being too big for SyntaxGraph darwings.

 -- Visual todos:
+Pick the best port angle
+Fix the port angle of the function port of nested apply. It should be [1/4, 3/4], not [1/2]
+
 -- Consider putting the function name in nested apply and pattern apply in a colored box.
 -- Make an icon font/library with labeled ports. E.g. the apply icon would have text labels "function", "result", "arg 0", "arg 1", etc.
 -- Fix rotation missing edges to nested diagrams.