diff --git a/app/Main.hs b/app/Main.hs index 4665527..3450865 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -14,7 +14,6 @@ import Rendering(toNames, portToPort, iconToPort, iconToIcon, import Types(Icon(..), Drawing(..), EdgeEnd(..)) -- TODO Now -- --- todo: figure out how to deal with the difference between arrow heads and arrow tails -- todo: consider moving portToPort etc. to a new file -- TODO Later -- @@ -177,6 +176,24 @@ fact1Drawing = Drawing fact1Icons fact1Edges [] factLam1Drawing = Drawing factLam0Icons factLam0Edges [(fact0Name, fact1Drawing)] +(arr1, arr2, arr3, arr4) = ("arr1", "arr2", "arr3", "arr4") + +arrowTestIcons = toNames [ + (arr1, TextBoxIcon "1"), + (arr2, TextBoxIcon "2"), + (arr3, TextBoxIcon "3"), + (arr4, TextBoxIcon "4") + ] + +arrowTestEdges = [ + iconToIconEnds arr1 EndAp1Arg arr2 EndAp1Result, + iconToIconEnds arr1 EndAp1Result arr3 EndAp1Arg, + iconToIconEnds arr2 EndAp1Result arr3 EndAp1Result, + iconToIconEnds arr1 EndAp1Arg arr4 EndAp1Arg + ] + +arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges [] + main1 :: IO () main1 = do placedNodes <- renderDrawing factLam1Drawing diff --git a/app/Rendering.hs b/app/Rendering.hs index 95eff33..13ba2d9 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -13,7 +13,7 @@ module Rendering ( ) where import Diagrams.Prelude -import Diagrams.TwoD.GraphViz +import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph') import Diagrams.Backend.SVG(B) import qualified Data.GraphViz as GV @@ -29,23 +29,25 @@ import Data.Typeable(Typeable) import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..)) import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..)) +import Control.Arrow(first) -- | Convert a map of names and icons, to a list of names and diagrams. --- The subDiagramMap +-- 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 subDiagramMap = map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name)) mapFst :: (a -> b) -> [(a, c)] -> [(b, c)] -mapFst f = map (\(x, y) -> (f x, y)) +mapFst f = map (first f) toNames :: (IsName a) => [(a, b)] -> [(Name, b)] toNames = mapFst toName noEnds = (EndNone, EndNone) ---portToPort :: (IsName a, IsName c) => a -> b -> c -> d -> Edge +-- Edge constructors -- portToPort :: (IsName a, IsName b) => a -> Int -> b -> Int -> Edge portToPort a b c d = Edge (toName a, Just b, toName c, Just d) noEnds @@ -65,30 +67,45 @@ iconHeadToPort a endHead c d = Edge (toName a, Nothing, toName c, Just d) (EndNo iconTailToPort a endTail c d = Edge (toName a, Nothing, toName c, Just d) (endTail, EndNone) +-- | Make an inductive Graph from a list of node names, and a list of Connections. edgesToGraph :: (Ord v) => [v] -> [(v, t, v , t1)] -> Gr v () edgesToGraph names edges = mkGraph names simpleEdges where simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges --- Custom arrow tail for the arg1 result circle. + +-- | Custom arrow tail for the arg1 result circle. -- The ArrowHT type does not seem to be documented. -arg1ResHT :: (RealFloat n) => ArrowHT n -arg1ResHT len _ = (circle (len / 2) # alignR, mempty) +arg1ResT :: (RealFloat n) => ArrowHT n +arg1ResT len _ = (circle (len / 2) # alignR, mempty) + +-- | Arrow head version of arg1ResT +arg1ResH :: (RealFloat n) => ArrowHT n +arg1ResH len _ = (circle (len / 2) # alignL, mempty) getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> ArrowOpts n getArrowOpts (t, h) = arrowOptions where - lookupEnd :: (RealFloat n, Typeable n) => EdgeEnd -> ArrowOpts n -> ArrowOpts n - lookupEnd EndNone = id - lookupEnd EndAp1Arg = (arrowHead .~ arrowheadDart (0.4 @@ turn)) - . (headTexture .~ solid (backgroundC colorScheme)) . (headStyle %~ (lw thick . lc (apply1C colorScheme) )) - lookupEnd EndAp1Result = (arrowTail .~ arg1ResHT) . (tailTexture .~ solid (apply1C colorScheme)) + ap1ArgTexture = solid (backgroundC colorScheme) + ap1ArgStyle = lw thick . lc (apply1C colorScheme) + ap1ResultTexture = solid (apply1C colorScheme) + + lookupTail EndNone = id + lookupTail EndAp1Arg = (arrowTail .~ dart') + . (tailTexture .~ ap1ArgTexture) . (tailStyle %~ ap1ArgStyle) + lookupTail EndAp1Result = (arrowTail .~ arg1ResT) . (tailTexture .~ ap1ResultTexture) + + lookupHead EndNone = id + lookupHead EndAp1Arg = (arrowHead .~ arrowheadDart (0.4 @@ turn)) + . (headTexture .~ ap1ArgTexture) . (headStyle %~ ap1ArgStyle) + lookupHead EndAp1Result = (arrowHead .~ arg1ResH) . (headTexture .~ ap1ResultTexture) + arrowOptions = with & arrowHead .~ noHead & arrowTail .~ noTail - & lengths .~ normalized 0.04 + & lengths .~ global 0.75 & shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme) - & lookupEnd t & lookupEnd h + & lookupTail t & lookupHead h plainLine = getArrowOpts (EndNone, EndNone) @@ -146,6 +163,7 @@ angleWithMinDist myLocation edges = -- constant scaleFactor = 0.02 +--scaleFactor = 0.04 getFromMapAndScale :: (Fractional a, Functor f, Ord k) => Map.Map k (f a) -> k -> f a getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name) @@ -191,6 +209,7 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes doGraphLayout :: Gr Name e -> [(Name, Diagram B)] -> (Diagram B -> r) -> [Connection] -> IO r doGraphLayout graph nameDiagramMap connectNodes edges = do layoutResult <- layoutGraph' layoutParams GVA.Neato graph + -- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph return $ placeNodes layoutResult nameDiagramMap edges # connectNodes where layoutParams :: GV.GraphvizParams Int v e () v