{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Text.AsciiDiagram.SvgRender
( GridSize( .. )
, defaultGridSize
, svgOfDiagram
, svgOfDiagramAtSize
, defaultLibrary
) where
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid( mempty )
import Control.Applicative( (<$>) )
#endif
import Data.Monoid( (<>) )
import Control.Monad.State.Strict( execState )
import Graphics.Svg.Types
( HasDrawAttributes( .. )
, Document( .. )
, drawAttr )
import Graphics.Svg( cssRulesOfText )
import qualified Graphics.Svg.Types as Svg
import qualified Graphics.Svg.CssTypes as Css
import qualified Data.Set as S
import qualified Data.Text as T
import Linear( V2( .. )
, (^+^)
, (^-^)
, (^*)
, perp
, normalize
)
import Control.Lens( zoom, (^.), (.=), (%=), (%~), (&) )
import Text.AsciiDiagram.BoundingBoxEstimation
import Text.AsciiDiagram.DefaultContext
import Text.AsciiDiagram.DiagramCleaner
import Text.AsciiDiagram.Geometry
data GridSize = GridSize
{ _gridCellWidth :: !Float
, _gridCellHeight :: !Float
, _gridShapeContraction :: !Float
}
deriving (Eq, Show)
defaultGridSize :: GridSize
defaultGridSize = GridSize
{ _gridCellWidth = 10
, _gridCellHeight = 14
, _gridShapeContraction = 1.5
}
toSvg :: GridSize -> Point -> Svg.RPoint
toSvg s (V2 x y) =
V2 (realToFrac $ _gridCellWidth s * fromIntegral (x + 1))
(realToFrac $ _gridCellHeight s * fromIntegral (y + 1))
setDashingInformation :: (Svg.WithDrawAttributes a) => a -> a
setDashingInformation = execState $ do
drawAttr . attrClass %= ("dashed_elem":)
isShapeDashed :: Shape -> Bool
isShapeDashed = any isDashed . shapeElements where
isDashed (ShapeAnchor _ _) = False
isDashed (ShapeSegment Segment { _segDraw = SegmentSolid }) = False
isDashed (ShapeSegment Segment { _segDraw = SegmentDashed }) = True
applyDefaultShapeDrawAttr :: (Svg.WithDrawAttributes a) => a -> a
applyDefaultShapeDrawAttr el =
el & drawAttr.attrClass %~ ("filled_shape":)
applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a
applyLineArrowDrawAttr el =
el & drawAttr.attrClass %~ ("arrow_head":)
applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a
applyBulletDrawAttr el =
el & drawAttr.attrClass %~ ("bullet":)
cleanupUseAttributes :: (Svg.WithDrawAttributes a) => a -> a
cleanupUseAttributes = execState . zoom drawAttr $ do
attrClass .= []
applyDefaultLineDrawAttr :: (Svg.WithDrawAttributes a) => a -> a
applyDefaultLineDrawAttr el =
el & drawAttr.attrClass %~ ("line_element":)
startPointOf :: ShapeElement -> Point
startPointOf (ShapeAnchor p _) = p
startPointOf (ShapeSegment seg) = _segStart seg
manathanDistance :: Point -> Point -> Int
manathanDistance a b = x + y where
V2 x y = abs <$> a ^-^ b
isNearBy :: Point -> Point -> Bool
isNearBy a b = manathanDistance a b <= 1
initialPrevious :: Bool -> [ShapeElement] -> Maybe Point
initialPrevious False _ = Nothing
initialPrevious True [] = Nothing
initialPrevious True lst@(x:_) = Just point
where
sp = startPointOf x
point = case last lst of
ShapeAnchor pp _ -> pp
ShapeSegment seg
| manathanDistance sp (_segStart seg) <
manathanDistance sp (_segEnd seg) -> _segStart seg
ShapeSegment seg -> _segEnd seg
swapSegment :: Segment -> Segment
swapSegment seg =
seg { _segStart = _segEnd seg, _segEnd = _segStart seg }
rollToSegment :: Shape -> Shape
rollToSegment shape | not $ shapeIsClosed shape = shape
rollToSegment shape = shape { shapeElements = segments ++ anchorPrefix } where
(anchorPrefix, segments) = span isAnchor $ shapeElements shape
isAnchor (ShapeSegment _) = False
isAnchor (ShapeAnchor _ _) = True
reorderShapePoints :: Shape -> [(Maybe Point, ShapeElement)]
reorderShapePoints shape = outList where
outList = go initialPrev elements
elements = shapeElements shape
initialPrev = initialPrevious (shapeIsClosed shape) elements
go _ [] = []
go prev (a@(ShapeAnchor p _):rest) =
(prev, a) : go (Just p) rest
go prev (s@(ShapeSegment seg):rest)
| start == _segEnd seg = (prev, s) : go (Just start) rest
where start = _segStart seg
go prev@(Just prevPoint) (s@(ShapeSegment seg):rest)
| prevPoint `isNearBy` start =
(prev, s) : go (Just end) rest
| otherwise =
(prev, ShapeSegment $ swapSegment seg) : go (Just start) rest
where start = _segStart seg
end = _segEnd seg
go Nothing (s@(ShapeSegment seg):rest@(nextShape:_)) =
case nextShape of
ShapeAnchor p _ | p `isNearBy` start ->
(Nothing, ShapeSegment $ swapSegment seg) : go (Just start) rest
ShapeAnchor _ _ ->
(Nothing, s) : go (Just $ _segEnd seg) rest
ShapeSegment _ -> (Nothing, s) : go (Just $ _segEnd seg) rest
where start = _segStart seg
go Nothing [e@(ShapeSegment _)] = [(Nothing, e)]
associateNextPoint :: Bool -> [(a, ShapeElement)]
-> [(a, ShapeElement, Maybe Point)]
associateNextPoint isClosed elements = go elements where
startingPoint =
Just . startPointOf . head $ map snd elements
go [] = []
go [(p, s)]
| isClosed = [(p, s, startingPoint)]
| otherwise = [(p, s, Nothing)]
go ((p, s):xs@((_, y):_)) =
(p, s, Just $ startPointOf y) : go xs
correctionVectorOf :: Integral a => GridSize -> V2 a -> V2 a -> V2 Float
correctionVectorOf size a b = normalize dir ^* _gridShapeContraction size
where
dir = fromIntegral . negate <$> perp (b ^-^ a)
startPoint :: GridSize -> [(Maybe Point, ShapeElement, Maybe Point)]
-> Svg.RPoint
startPoint gscale shapeElems = case shapeElems of
[] -> V2 0 0
(Just before, ShapeAnchor p _, Just after):_ -> toS p ^+^ combined
where v1 = realToFrac <$> correctionVector before p
v2 = realToFrac <$> correctionVector p after
combined | v1 == v2 = v1
| otherwise = v1 ^+^ v2
(before, ShapeSegment seg, _):_ -> pp ^+^ vc where
vc = segmentCorrectionVector gscale before seg
pp = toS $ _segStart seg
(_, ShapeAnchor p _, _):_ -> toS p
where
correctionVector = correctionVectorOf gscale
toS = toSvg gscale
anchorCorrection :: GridSize -> Point -> Point -> Point
-> Svg.RPoint
anchorCorrection scale before p after
| v1 == v2 = realToFrac <$> v1
| otherwise = v1 ^+^ v2
where v1 = realToFrac <$> correctionVectorOf scale before p
v2 = realToFrac <$> correctionVectorOf scale p after
moveTo, lineTo :: Svg.RPoint -> Svg.PathCommand
moveTo p = Svg.MoveTo Svg.OriginAbsolute [p]
lineTo p = Svg.LineTo Svg.OriginAbsolute [p]
smoothCurveTo :: Svg.RPoint -> Svg.RPoint -> Svg.PathCommand
smoothCurveTo p1 p =
Svg.SmoothCurveTo Svg.OriginAbsolute [(p1, p)]
shapeClosing :: Shape -> [Svg.PathCommand]
shapeClosing Shape { shapeIsClosed = True } = [Svg.EndPath]
shapeClosing _ = []
segmentCorrectionVector :: GridSize -> Maybe Point -> Segment -> Svg.RPoint
segmentCorrectionVector gscale before seg | _segStart seg == _segEnd seg =
realToFrac <$> case (before, _segKind seg) of
(Just v1, _) -> correctionVectorOf gscale v1 (_segEnd seg)
(Nothing, SegmentHorizontal) -> V2 0 $ _gridShapeContraction gscale
(Nothing, SegmentVertical) -> V2 (negate $ _gridShapeContraction gscale) 0
segmentCorrectionVector gscale _ seg =
realToFrac <$> correctionVectorOf gscale (_segStart seg) (_segEnd seg)
straightCorner :: GridSize -> Bool -> Maybe Point -> Point -> Maybe Point
-> ([Svg.PathCommand], [Svg.Tree])
straightCorner gscale isBullet pBefore p pAfter
| isBullet = ([lineTo finalPoint], [renderBullet gscale finalPoint])
| otherwise = ([lineTo finalPoint], [])
where
pSvg = toSvg gscale p
finalPoint = case (pBefore, pAfter) of
(Just before, Just after) ->
anchorCorrection gscale before p after ^+^ pSvg
(Just before, _) ->
(realToFrac <$> correctionVectorOf gscale before p) ^+^ pSvg
_ -> pSvg
curveCorner :: GridSize -> Maybe Point -> Point -> Maybe Point -> Svg.PathCommand
curveCorner gscale _ p (Just after) =
smoothCurveTo (toS p) $ toS after ^+^ correction
where correction = realToFrac <$> correctionVectorOf gscale p after
toS = toSvg gscale
curveCorner gscale (Just before) p Nothing =
smoothCurveTo (toS p) $ toS p ^+^ vec
where vec = realToFrac <$> correctionVectorOf gscale before p
toS = toSvg gscale
curveCorner gscale _ p _ = lineTo $ toSvg gscale p
roundedCorner :: GridSize -> Point -> Point -> Maybe Point -> Svg.PathCommand
roundedCorner gscale p1 p2 (Just lastPoint) =
Svg.CurveTo Svg.OriginAbsolute [(toS p1, toS p2, toS lastPoint ^+^ vec)]
where toS = toSvg gscale
vec = realToFrac <$> correctionVectorOf gscale p2 lastPoint
roundedCorner gscale p1 p2 after =
curveCorner gscale (Just p1) p2 after
toPathRooted :: [Svg.RPoint] -> GridSize -> Point -> Svg.Tree
toPathRooted pts gscale p =
applyLineArrowDrawAttr . Svg.PathTree $ Svg.Path mempty pathCommands
where
pt = fromIntegral <$> p
sizes =
realToFrac <$> V2 (_gridCellWidth gscale) (_gridCellHeight gscale)
toGrid pp = lineTo $ (pt ^+^ pp) * sizes
pathCommands = case pts of
[] -> []
x:xs -> moveTo ((pt ^+^ x) * sizes)
: fmap toGrid xs ++ [Svg.EndPath]
toRightArrow :: GridSize -> Point -> Svg.Tree
toRightArrow =
toPathRooted [ V2 1 0.5
, V2 2 1
, V2 1 1.5
]
toLeftArrow :: GridSize -> Point -> Svg.Tree
toLeftArrow =
toPathRooted [ V2 1 0.5
, V2 0 1
, V2 1 1.5
]
toTopArrow :: GridSize -> Point -> Svg.Tree
toTopArrow =
toPathRooted [ V2 0.5 1
, V2 1.5 1
, V2 1 0
]
toBottomArrow :: GridSize -> Point -> Svg.Tree
toBottomArrow =
toPathRooted [ V2 0.5 1
, V2 1.5 1
, V2 1 2
]
renderBullet :: GridSize -> Svg.RPoint -> Svg.Tree
renderBullet gscale (V2 x y) = applyBulletDrawAttr $ Svg.CircleTree Svg.defaultSvg
{ Svg._circleCenter = (Svg.Num $ realToFrac x, Svg.Num $ realToFrac y)
, Svg._circleRadius = Svg.Num . realToFrac $ halfWidth - 2
}
where halfWidth = _gridCellWidth gscale / 2
dashingSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a
dashingSet shape
| isShapeDashed shape = setDashingInformation
| otherwise = id
classSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a
classSet shape e =
e & drawAttr . attrClass %~ (++ S.toList (shapeTags shape))
shapeToTree :: (forall a. (Svg.WithDrawAttributes a) => a -> a)
-> GridSize -> Shape -> Svg.Tree
shapeToTree classSetter gscale shape@Shape
{ shapeIsClosed = True
, shapeElements =
[ ShapeSegment _
, ShapeAnchor p0 AnchorMulti
, ShapeSegment _
, ShapeAnchor p1 AnchorMulti
, ShapeSegment _
, ShapeAnchor p2 AnchorMulti
, ShapeSegment _
, ShapeAnchor p3 AnchorMulti ]
} = classSet shape
. dashingSet shape
. Svg.RectangleTree
. classSetter
$ Svg.defaultSvg
{ Svg._rectWidth = Svg.Num sWidth
, Svg._rectHeight = Svg.Num sHeight
, Svg._rectUpperLeftCorner = (Svg.Num px, Svg.Num py) }
where
pts = [p0, p1, p2, p3]
mini = minimum pts
maxi = maximum pts
contraction = _gridShapeContraction gscale
contractionVector = realToFrac <$> V2 contraction contraction
maxiPoint = toSvg gscale maxi ^-^ contractionVector
pt@(V2 px py) = toSvg gscale mini ^+^ contractionVector
V2 sWidth sHeight = maxiPoint ^-^ pt
shapeToTree classSetter gscale shape =
case concat arrows of
[] -> svgPath
lst -> Svg.GroupTree . classSet shape
$ Svg.defaultSvg { Svg._groupChildren = svgPath : lst }
where
toS = toSvg gscale
shapeElems = associateNextPoint (shapeIsClosed shape)
. reorderShapePoints
$ rollToSegment shape
svgPath = classSet shape . dashingSet shape . Svg.PathTree
. classSetter
$ Svg.Path mempty pathCommands
pathCommands =
moveTo (startPoint gscale shapeElems)
: concat pathes ++ shapeClosing shape
(pathes, arrows) = unzip $ toPath shapeElems
toPath [] = []
toPath ((before, ShapeSegment seg, Just _):rest) =
([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest
where vc = segmentCorrectionVector gscale before seg
toPath ((before, ShapeSegment seg, Nothing):rest) =
([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest
where vc = segmentCorrectionVector gscale before seg'
extension = signum <$> (_segEnd seg ^-^ _segStart seg)
seg' = seg { _segEnd = _segEnd seg ^+^ extension }
toPath ((_, ShapeAnchor p1 AnchorFirstDiag, _)
:(_, ShapeAnchor p2 AnchorSecondDiag, after)
:rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest
toPath ((_, ShapeAnchor p1 AnchorSecondDiag, _)
:(_, ShapeAnchor p2 AnchorFirstDiag, after)
:rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest
toPath ((before, ShapeAnchor p a, after):rest) = anchorJoin : toPath rest
where
anchorJoin = case a of
AnchorPoint -> straightCorner gscale False before p after
AnchorMulti -> straightCorner gscale False before p after
AnchorBullet -> straightCorner gscale True before p after
AnchorFirstDiag -> ([curveCorner gscale before p after], [])
AnchorSecondDiag -> ([curveCorner gscale before p after], [])
AnchorArrowUp -> ([lineTo $ toS p], [toTopArrow gscale p])
AnchorArrowDown -> ([lineTo $ toS p], [toBottomArrow gscale p])
AnchorArrowLeft -> ([lineTo $ toS p], [toLeftArrow gscale p])
AnchorArrowRight -> ([lineTo $ toS p], [toRightArrow gscale p])
textToTree :: GridSize -> TextZone -> Svg.Tree
textToTree gscale zone = Svg.TextTree Nothing txt
where
correction = realToFrac <$>
V2 (negate $ _gridCellWidth gscale)
(_gridCellHeight gscale) ^* 0.5
V2 x y = toSvg gscale (_textZoneOrigin zone) ^+^ correction
txt = Svg.textAt (Svg.Num (x+0.5), Svg.Num (y+0.5)) $ _textZoneContent zone
svgOfDiagram :: Diagram -> Svg.Document
svgOfDiagram =
svgOfDiagramAtSize defaultGridSize (defaultLibrary defaultGridSize)
svgOfShape :: GridSize -> Shape -> Svg.Tree
svgOfShape scale shape
| shapeIsClosed shape =
shapeToTree applyDefaultShapeDrawAttr scale shape
| otherwise =
shapeToTree applyDefaultLineDrawAttr strokeScale shape
where
strokeScale = scale { _gridShapeContraction = 0 }
svgOfElement :: GridSize -> Element -> Svg.Tree
svgOfElement scale (ElemText txt) = textToTree scale txt
svgOfElement scale (ElemShape shape) =
case shapeChildren shape of
[] -> svgOfShape scale shape
_:_ -> Svg.GroupTree $ group
where
thisShape = svgOfShape scale shape
group = Svg.defaultSvg
{ Svg._groupDrawAttributes =
mempty { Svg._attrClass = S.toList $ shapeTags shape }
, Svg._groupChildren =
thisShape : fmap (svgOfElement scale) (shapeChildren shape)
, Svg._groupViewBox = Nothing
}
shapeRewriter :: [Css.CssRule] -> Svg.Tree -> Svg.Tree
shapeRewriter rules = Svg.zipTree go where
go [] = Svg.None
go ([]:_) = Svg.None
go context@((t:_):_) = case reverse shapeDeclarations of
[] -> t
(([Css.CssIdent i]:_): _) -> Svg.UseTree (useInfo i) Nothing
_ -> t
where
useInfo name = cleanupUseAttributes $ Svg.Use
{ Svg._useDrawAttributes = t ^. Svg.drawAttr
, Svg._useBase = (Css.Num x, Css.Num y)
, Svg._useName = T.unpack name
, Svg._useWidth = Just (Css.Num w)
, Svg._useHeight = Just (Css.Num h)
}
BoundingBox pMin@(V2 x y) pMax = boundingBoxOf t
V2 w h = pMax ^-^ pMin
shapeDeclarations =
[el | Css.CssDeclaration "shape" el <- Css.findMatchingDeclarations rules context]
svgOfDiagramAtSize :: GridSize -> Svg.Document -> Diagram -> Svg.Document
svgOfDiagramAtSize scale style diagram = Document
{ _viewBox = Nothing
, _width =
toSvgSize _gridCellWidth $ _diagramCellWidth diagram + 1
, _height =
toSvgSize _gridCellHeight $ _diagramCellHeight diagram + 1
, _elements =
shapeRewriter allRules . svgOfElement scale <$> shapes
, _definitions = _definitions style
, _description = ""
, _styleRules = allRules
, _documentLocation = ""
}
where
allRules = _styleRules style <> customCssRules
customCssRules =
cssRulesOfText . T.unlines $ _diagramStyles diagram
isDrawable (ElemText _) = True
isDrawable (ElemShape shape) =
not (shapeIsClosed shape) || isShapePossible shape
shapes = filter isDrawable . S.toList $ _diagramElements diagram
toSvgSize accessor var =
Just . Svg.Num . realToFrac $ fromIntegral var * accessor scale + 5
defaultLibrary :: GridSize -> Svg.Document
defaultLibrary size = Document
{ _viewBox = Nothing
, _width = Nothing
, _height = Nothing
, _elements = []
, _definitions = defaultDefinitions
, _description = ""
, _styleRules = defaultCssRules $ _gridCellHeight size
, _documentLocation = ""
}