asciidiagram 1.0 → 1.1
raw patch · 3 files changed
+594/−590 lines, 3 filesdep ~rasterific-svgdep ~svg-treePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: rasterific-svg, svg-tree
API changes (from Hackage documentation)
Files
- asciidiagram.cabal +85/−85
- changelog +8/−5
- src/Text/AsciiDiagram/SvgRender.hs +501/−500
asciidiagram.cabal view
@@ -1,85 +1,85 @@--- Initial hitaa.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ -name: asciidiagram -version: 1.0 -synopsis: Pretty rendering of Ascii diagram into svg or png. -description: - Asciidiagram Ascii art diagram like this: - . - @ - , \/---------+ - +---------+ | | - | ASCII +----\>| Diagram | - +---------+ | | - | | +--+------\/ - \\---*-----\/\<=======\/ - @ - . - Into this: - . - <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAR0AAABnCAQAAACXrV7jAAAH+UlEQVR4Xu3cbZCVZRkH8N++srssirgqqIKKGK4WphWQMjJjilCUaASklgCZKr6RpgphlRWK0kiZVqmmY5ImyppbZiU1lglqUCqb4bsk5oq87sKyu3dfmWGneFzZPQ9evw87c87HM//538+e67qPnSyEEEIIIYQQQgghhBBCCCGEEEIIodguqMjOFIbudsmWUS3Vg159foC8Kequ6IQe1XdWjbms58n2kT/V/zcbpXaOUF79h08eeVNVufzqluiEqu+MGPLTKlI8wGUS9mubfkNPmUXrhNNOaesryShaJ+wx/rNVsovWCeuPHCrJLFontJX2kl20Tthrt82pQmbROmG3yq2yi9YJNm8pSbKLGVYgrZFvfSiKAyt06YGVolE7J71vo2OjfKsWuik6SXYhWgftdh0hWidaJ6ITIjphgekas7dORCdMcJxJFsssohP6etQ8szQD0ToyCDOMMU5DZ6KzxAO+qvf785/zla7S240AWOReL6swwFx9wD/dYrk2g0x3OG73CICxJmK2FwBc6GNyYrCnzTLP/3WfhSixr7GOAcDN6n3UuPdn6/zS4zY5x+GAH5pjsrFarLRVwmKTDfZp5ZZ5Si0OMtxrbvdlexsg4YP2tsQjZqKPJDcqXW+sSVZD0jFetNQFWjxjvEmuVQy4wkeMkt6v0Zns5+rUAuaaajaAZJ2zjHCLUkDCCCMsdbvPqUXCqSj3sHNB0glf19VG+ofpfuF/6uk8UG+qY4zDSs+gnyaVgEaP+bcyw3wQ0OhXmvRThLFK8FuD1aizzmj90eZxDZoNcrwyySInWeAQQ92jj9GFG50GrxmtUZ3LAKUatCoB8Ij1vqZE2qGwpl14EJHAaLXudzKWud1mz3pAH8AYPQy0ymzzTMQSnzfMvuZr8mFjFGOWT3nAnprN81v9fd+tjsD1jrBQmXNMs9zTpvuzJ/3eYYUanUVqHKnRAisNBN90sROdbbSe4O/KHSx1GJokbfcOKPTWucq2FptktR1Waxk41ale9nEA1NsTXOAaE3Gd4e7EaKe5VhngJ64xySZHqzPdF10IlvqMJxyLFyyyvz+pc7TnCjc6DxkrGarMQpeA8Qa7wQyzzHQ61usn0XF08t86zds+JicdIyEBKm2VOvwU+kg22uBAiyS85RgJB+BtCXCaiZIqX7CPZHcJb6nBWglTJMWmKdZDq1SY48/nrTRXuyonqDcDcLgfW2W+y202RZV3tNteQrv27d7JlQbjNMhotRod+54btdqqVCsY5U4n6usaexkCYE/AFeBJF3tRBQCq0aq6sAcR9RivFcXarbYPgH3N8bx6kw223vMGZTiw8iLrV4IJbPGkCR22Tr3r/NRJuNVsCS/r7wobHeVeFVIH3dzkdMd7WCX2lyS2+1uQ0fm1MSaBFlPd5xxJEaDFegMlJ/imK92mJ2hRDkiQ3+is3nYQseMH1jsu0+QLUgefwrOqjJK0WIKkTZ3rTAAkQJIkAGtscKIKST2StG0gJQozOq9b4QrHAkZa6Gyvm+hDettqqXXmS/bwPRcaYbgSy53pTCzwqLX4hl5OMg5zvOQVRc7CWY5W4H5hukaZrDHZJsvUuMMB4EcabMB8NUY4xTHmm+Ygv7IHKHG8S8zVS6VBzneI7e3nEN/1nL97UWl+BhFvu8hwCXCex7To40tesU4P04xTJeET/uAh/1JqqtES9nEYhoO9JByowmFOAr0kBW5i1tYeBiqda4RiCdQ4ALWgt2SYuz2oyTX2Vydp8ppRxtui0W1O9ziYqlYCwF3u8Jbj3eQOg7S7WD/JVxwkmeowqUtWv9ML8m0gRbpPetV76Xem+KODwPfN7YJe6U9R/sefsSXoQCWucrIqK93s80qk2E3eEWGghe6xwFb7m+NTsXQRrbPjhhgCIBV2dD4ghOzRoUinhBS/Ix5C3DnPIFpn96Z1+1kVd84zi+iUt6mItfbsgs1l1kd0sovWsaHCW/GVYGZho5LWNtE6mUXrPKnXsrURnexCfdPae0V0sorW+Y+HStwV0cksfG1T8c1WRXQyidbZ6sqmJcubr4yliwxCo9+4aVNTfdMZWuim1gkfkC8Hv/JS/7KNPR7ecJ0nOrlg+oZ860eRLEKx9s6PPx39XKrV9cIEG9TrHu3v0Vr7KvlW27TuUKvkzY3+4eY8L130KGlLJXKtR5sK+dPfw+Q5OlvaSpJ8ay6zXv5s8FzO16FKWp4pq5JnAygSurx1VL+8YtBRuZ/8doOITutjTw36sPxaus3kN0dGWWpNzqOz6b76z07tJbce7HjyW+MHJipUlX5mSO5bx0Mr2t+0t3x6s+PJ70h361vA0fmyv3oz/9HReu3My368m056xxwPYqzL7aGrzNx+8lvpajMUst1dagzkPzrXP3HaDYeeX6oT2kxxgjWYbYp7lHTX5Hew+w1W2Jqdbfmucldpr6q/DNvv0sqDvVuPuMcfAcf5nBO6bvK7BQAzXK0y7rV2ZXToUTqt54yNA6qbm8tbymXnSt8GzPSd7pj89nW3kVDA0RnpapO8FjcktzVu6J1/7QkM2/TEGe7v4snvBD9Qs13PjjQSLLaYbn41ybe0+roFcqfUzlS3YtVFB3+7lJmtK1aps3O1y5+/OdkzthOtQ03vmzaMo9f9a8/RqIvk7MAS0SkonX9MDvEjKfMcpUGI6GSnwVHmeZdCGOkNSXYhqLHALiqEEEIIIYQQQgghhBBCCCGE8F9DWMtlMskJNQAAAABJRU5ErkJggg==>> - . - See the documentation of the Text.AsciiDiagram module for the - description of the input format. - -license: BSD3 ---license-file: -author: Vincent Berthoux -maintainer: vincent.berthoux@gmail.com --- copyright: -category: Text, Diagram -build-type: Simple -extra-source-files: changelog -extra-doc-files: docimages/*.svg -cabal-version: >=1.10 - -Source-Repository head - Type: git - Location: git://github.com/Twinside/asciidiagram.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/asciidiagram.git - Tag: v1.0 - -library - ghc-options: -O2 -Wall - exposed-modules: Text.AsciiDiagram - - other-modules: Text.AsciiDiagram.DiagramCleaner - , Text.AsciiDiagram.Geometry - , Text.AsciiDiagram.Graph - , Text.AsciiDiagram.Parser - , Text.AsciiDiagram.Reconstructor - , Text.AsciiDiagram.SvgRender - - -- containers >= 0.5.2.1 for Set.elemAt - build-depends: base >=4.6 && <4.9 - , vector >= 0.10 - , text >= 1.2 && < 1.3 - , linear >= 1.16 - , containers >= 0.5 - , mtl >= 2.1 && < 2.3 - , lens >= 4.6 && < 4.8 - , svg-tree >= 0.1 && < 0.2 - , rasterific-svg >= 0.1 && < 0.2 - , FontyFruity >= 0.5 && < 0.6 - , JuicyPixels >= 3.2 - - hs-source-dirs: src - default-language: Haskell2010 - -Executable asciidiagram - Main-Is: asciidiagram.hs - default-language: Haskell2010 - ghc-options: -O2 -Wall - Hs-Source-Dirs: exec-src - Build-Depends: base >= 4.6 - , optparse-applicative - , rasterific-svg - , JuicyPixels - , filepath - , asciidiagram - , svg-tree - , text - +-- Initial hitaa.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/+name: asciidiagram+version: 1.1+synopsis: Pretty rendering of Ascii diagram into svg or png.+description: + Asciidiagram Ascii art diagram like this:+ .+ @+ , \/---------++ +---------+ | |+ | ASCII +----\>| Diagram |+ +---------+ | |+ | | +--+------\/+ \\---*-----\/\<=======\/+ @+ .+ Into this:+ .+ <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAR0AAABnCAQAAACXrV7jAAAH+UlEQVR4Xu3cbZCVZRkH8N++srssirgqqIKKGK4WphWQMjJjilCUaASklgCZKr6RpgphlRWK0kiZVqmmY5ImyppbZiU1lglqUCqb4bsk5oq87sKyu3dfmWGneFzZPQ9evw87c87HM//538+e67qPnSyEEEIIIYQQQgghhBBCCCGEEEIIodguqMjOFIbudsmWUS3Vg159foC8Kequ6IQe1XdWjbms58n2kT/V/zcbpXaOUF79h08eeVNVufzqluiEqu+MGPLTKlI8wGUS9mubfkNPmUXrhNNOaesryShaJ+wx/rNVsovWCeuPHCrJLFontJX2kl20Tthrt82pQmbROmG3yq2yi9YJNm8pSbKLGVYgrZFvfSiKAyt06YGVolE7J71vo2OjfKsWuik6SXYhWgftdh0hWidaJ6ITIjphgekas7dORCdMcJxJFsssohP6etQ8szQD0ToyCDOMMU5DZ6KzxAO+qvf785/zla7S240AWOReL6swwFx9wD/dYrk2g0x3OG73CICxJmK2FwBc6GNyYrCnzTLP/3WfhSixr7GOAcDN6n3UuPdn6/zS4zY5x+GAH5pjsrFarLRVwmKTDfZp5ZZ5Si0OMtxrbvdlexsg4YP2tsQjZqKPJDcqXW+sSVZD0jFetNQFWjxjvEmuVQy4wkeMkt6v0Zns5+rUAuaaajaAZJ2zjHCLUkDCCCMsdbvPqUXCqSj3sHNB0glf19VG+ofpfuF/6uk8UG+qY4zDSs+gnyaVgEaP+bcyw3wQ0OhXmvRThLFK8FuD1aizzmj90eZxDZoNcrwyySInWeAQQ92jj9GFG50GrxmtUZ3LAKUatCoB8Ij1vqZE2qGwpl14EJHAaLXudzKWud1mz3pAH8AYPQy0ymzzTMQSnzfMvuZr8mFjFGOWT3nAnprN81v9fd+tjsD1jrBQmXNMs9zTpvuzJ/3eYYUanUVqHKnRAisNBN90sROdbbSe4O/KHSx1GJokbfcOKPTWucq2FptktR1Waxk41ale9nEA1NsTXOAaE3Gd4e7EaKe5VhngJ64xySZHqzPdF10IlvqMJxyLFyyyvz+pc7TnCjc6DxkrGarMQpeA8Qa7wQyzzHQ61usn0XF08t86zds+JicdIyEBKm2VOvwU+kg22uBAiyS85RgJB+BtCXCaiZIqX7CPZHcJb6nBWglTJMWmKdZDq1SY48/nrTRXuyonqDcDcLgfW2W+y202RZV3tNteQrv27d7JlQbjNMhotRod+54btdqqVCsY5U4n6usaexkCYE/AFeBJF3tRBQCq0aq6sAcR9RivFcXarbYPgH3N8bx6kw223vMGZTiw8iLrV4IJbPGkCR22Tr3r/NRJuNVsCS/r7wobHeVeFVIH3dzkdMd7WCX2lyS2+1uQ0fm1MSaBFlPd5xxJEaDFegMlJ/imK92mJ2hRDkiQ3+is3nYQseMH1jsu0+QLUgefwrOqjJK0WIKkTZ3rTAAkQJIkAGtscKIKST2StG0gJQozOq9b4QrHAkZa6Gyvm+hDettqqXXmS/bwPRcaYbgSy53pTCzwqLX4hl5OMg5zvOQVRc7CWY5W4H5hukaZrDHZJsvUuMMB4EcabMB8NUY4xTHmm+Ygv7IHKHG8S8zVS6VBzneI7e3nEN/1nL97UWl+BhFvu8hwCXCex7To40tesU4P04xTJeET/uAh/1JqqtES9nEYhoO9JByowmFOAr0kBW5i1tYeBiqda4RiCdQ4ALWgt2SYuz2oyTX2Vydp8ppRxtui0W1O9ziYqlYCwF3u8Jbj3eQOg7S7WD/JVxwkmeowqUtWv9ML8m0gRbpPetV76Xem+KODwPfN7YJe6U9R/sefsSXoQCWucrIqK93s80qk2E3eEWGghe6xwFb7m+NTsXQRrbPjhhgCIBV2dD4ghOzRoUinhBS/Ix5C3DnPIFpn96Z1+1kVd84zi+iUt6mItfbsgs1l1kd0sovWsaHCW/GVYGZho5LWNtE6mUXrPKnXsrURnexCfdPae0V0sorW+Y+HStwV0cksfG1T8c1WRXQyidbZ6sqmJcubr4yliwxCo9+4aVNTfdMZWuim1gkfkC8Hv/JS/7KNPR7ecJ0nOrlg+oZ860eRLEKx9s6PPx39XKrV9cIEG9TrHu3v0Vr7KvlW27TuUKvkzY3+4eY8L130KGlLJXKtR5sK+dPfw+Q5OlvaSpJ8ay6zXv5s8FzO16FKWp4pq5JnAygSurx1VL+8YtBRuZ/8doOITutjTw36sPxaus3kN0dGWWpNzqOz6b76z07tJbce7HjyW+MHJipUlX5mSO5bx0Mr2t+0t3x6s+PJ70h361vA0fmyv3oz/9HReu3My368m056xxwPYqzL7aGrzNx+8lvpajMUst1dagzkPzrXP3HaDYeeX6oT2kxxgjWYbYp7lHTX5Hew+w1W2Jqdbfmucldpr6q/DNvv0sqDvVuPuMcfAcf5nBO6bvK7BQAzXK0y7rV2ZXToUTqt54yNA6qbm8tbymXnSt8GzPSd7pj89nW3kVDA0RnpapO8FjcktzVu6J1/7QkM2/TEGe7v4snvBD9Qs13PjjQSLLaYbn41ybe0+roFcqfUzlS3YtVFB3+7lJmtK1aps3O1y5+/OdkzthOtQ03vmzaMo9f9a8/RqIvk7MAS0SkonX9MDvEjKfMcpUGI6GSnwVHmeZdCGOkNSXYhqLHALiqEEEIIIYQQQgghhBBCCCGE8F9DWMtlMskJNQAAAABJRU5ErkJggg==>>+ .+ See the documentation of the Text.AsciiDiagram module for the+ description of the input format.++license: BSD3+--license-file: +author: Vincent Berthoux+maintainer: vincent.berthoux@gmail.com+-- copyright: +category: Text, Diagram+build-type: Simple+extra-source-files: changelog+extra-doc-files: docimages/*.svg+cabal-version: >=1.10++Source-Repository head+ Type: git+ Location: git://github.com/Twinside/asciidiagram.git++Source-Repository this+ Type: git+ Location: git://github.com/Twinside/asciidiagram.git+ Tag: v1.1++library+ ghc-options: -O2 -Wall+ exposed-modules: Text.AsciiDiagram++ other-modules: Text.AsciiDiagram.DiagramCleaner+ , Text.AsciiDiagram.Geometry+ , Text.AsciiDiagram.Graph+ , Text.AsciiDiagram.Parser+ , Text.AsciiDiagram.Reconstructor+ , Text.AsciiDiagram.SvgRender++ -- containers >= 0.5.2.1 for Set.elemAt+ build-depends: base >=4.6 && <4.9+ , vector >= 0.10+ , text >= 1.2 && < 1.3+ , linear >= 1.16+ , containers >= 0.5+ , mtl >= 2.1 && < 2.3+ , lens >= 4.6 && < 4.8+ , svg-tree >= 0.3 && < 0.4+ , rasterific-svg >= 0.2 && < 0.3+ , FontyFruity >= 0.5 && < 0.6+ , JuicyPixels >= 3.2++ hs-source-dirs: src+ default-language: Haskell2010++Executable asciidiagram+ Main-Is: asciidiagram.hs+ default-language: Haskell2010+ ghc-options: -O2 -Wall+ Hs-Source-Dirs: exec-src+ Build-Depends: base >= 4.6+ , optparse-applicative+ , rasterific-svg+ , JuicyPixels+ , filepath+ , asciidiagram+ , svg-tree+ , text+
changelog view
@@ -1,5 +1,8 @@--*-change-log-*- - -v0.1 - * Initial version - +-*-change-log-*-++v1.1+ * Bump: svg-tree & rasterific-svg dependencies++v0.1+ * Initial version+
src/Text/AsciiDiagram/SvgRender.hs view
@@ -1,500 +1,501 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Text.AsciiDiagram.SvgRender( svgOfDiagram ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -#endif - -import Control.Applicative( (<$>) ) -import Control.Monad.State.Strict( execState ) -import Data.Monoid( Last( .. ), (<>) ) - -import Graphics.Svg.Types - ( HasDrawAttributes( .. ) - , Texture( ColorRef ) - , Document( .. ) - , drawAttr ) -import Graphics.Svg( cssRulesOfText ) - -import Codec.Picture( PixelRGBA8( PixelRGBA8 ) ) -import qualified Graphics.Svg.Types as Svg -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import Text.Printf -import Linear( V2( .. ) - , (^+^) - , (^-^) - , (^*) - , perp - , normalize - ) -import Control.Lens( zoom, (.=), (%=), (%~), (&) ) - -import Text.AsciiDiagram.Geometry -import Text.AsciiDiagram.DiagramCleaner - -{-import Debug.Trace-} -{-import Text.Groom-} - -data GridSize = GridSize - { _gridCellWidth :: !Float - , _gridCellHeight :: !Float - , _gridShapeContraction :: !Float - } - deriving (Eq, Show) - - -toSvg :: GridSize -> Point -> Svg.RPoint -toSvg s (V2 x y) = - V2 (_gridCellWidth s * fromIntegral (x + 1)) - (_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 = execState . zoom drawAttr $ do - strokeColor .= toLC 0 0 0 255 - attrClass %= ("filled_shape":) - strokeWidth .= toL (Svg.Num 1) - where - toL = Last . Just - toLC r g b a = - toL . ColorRef $ PixelRGBA8 r g b a - -applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a -applyLineArrowDrawAttr = execState . zoom drawAttr $ do - fillColor .= toLC 0 0 0 255 - strokeColor .= toL Svg.FillNone - strokeWidth .= toL (Svg.Num 0) - where - toL = Last . Just - toLC r g b a = - toL . ColorRef $ PixelRGBA8 r g b a - -applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a -applyBulletDrawAttr = execState . zoom drawAttr $ do - attrClass %= ("bullet":) - -applyDefaultLineDrawAttr :: (Svg.WithDrawAttributes a) => a -> a -applyDefaultLineDrawAttr = execState . zoom drawAttr $ do - attrClass %= ("line_element":) - fillColor .= toL Svg.FillNone - strokeColor .= toLC 0 0 0 255 - strokeWidth .= toL (Svg.Num 1) - where - toL = Last . Just - toLC r g b a = - toL . ColorRef $ PixelRGBA8 r g b a - - -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 - - --- > --- > ^ perp:(0, -n) --- > | --- > (x, y)| (x + n, y) --- > +-------------------+ b --- > a| --- > v correction --- -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 = correctionVector before p - v2 = 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 = v1 - | otherwise = v1 ^+^ v2 - where v1 = correctionVectorOf scale before p - v2 = 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 = - 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 = - 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, _) -> - 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 = correctionVectorOf gscale p after - toS = toSvg gscale -curveCorner gscale (Just before) p Nothing = - smoothCurveTo (toS p) $ toS p ^+^ vec - where vec = 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 = 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 = 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 x, Svg.Num y) - , Svg._circleRadius = Svg.Num $ 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 :: GridSize -> Shape -> Svg.Tree -shapeToTree 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 - $ 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 = V2 contraction contraction - - maxiPoint = toSvg gscale maxi ^-^ contractionVector - pt@(V2 px py) = toSvg gscale mini ^+^ contractionVector - V2 sWidth sHeight = maxiPoint ^-^ pt - - - -shapeToTree gscale shape = - case concat arrows of - [] -> svgPath - lst -> Svg.GroupTree $ Svg.defaultSvg { Svg._groupChildren = svgPath : lst } - where - toS = toSvg gscale - shapeElems = associateNextPoint (shapeIsClosed shape) - . reorderShapePoints - $ rollToSegment shape - - svgPath = classSet shape . dashingSet shape . Svg.PathTree - $ 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 = - 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 - -defaultCss :: Float -> T.Text -defaultCss textSize = T.pack $ printf - ("\n" <> - "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <> - ".dashed_elem { stroke-dasharray: 4, 3 }\n" <> - ".filled_shape { fill: url(#shape_light) }\n" <> - ".bullet { stroke-width: 1px; fill: white; stroke: black }\n" - ) - (2 + floor textSize :: Int) - -lightShapeGradient :: Svg.Element -lightShapeGradient = Svg.ElementLinearGradient $ - Svg.defaultSvg - { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0) - , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1) - , Svg._linearGradientStops = - [ Svg.GradientStop 0 $ PixelRGBA8 245 245 245 255 - , Svg.GradientStop 1 $ PixelRGBA8 216 216 216 255 - ] - } - --- | Transform an Ascii diagram to a SVG document which --- can be saved or converted to an image. -svgOfDiagram :: Diagram -> Svg.Document -svgOfDiagram diagram = Document - { _viewBox = Nothing - , _width = - toSvgSize _gridCellWidth $ _diagramCellWidth diagram + 1 - , _height = - toSvgSize _gridCellHeight $ _diagramCellHeight diagram + 1 - , _elements = closedSvg ++ lineSvg ++ textSvg - , _definitions = M.fromList - [("shape_light", lightShapeGradient)] - , _description = "" - , _styleRules = defaultCssRules ++ customCssRules - , _documentLocation = "" - } - where - (closed, opened) = S.partition shapeIsClosed shapes - - defaultCssRules = - cssRulesOfText . defaultCss $ _gridCellHeight scale - - customCssRules = - cssRulesOfText . T.unlines $ _diagramStyles diagram - - shapes = _diagramShapes diagram - - closedSvg = - applyDefaultShapeDrawAttr . shapeToTree scale <$> filter isShapePossible - (S.toList closed) - lineSvg = - applyDefaultLineDrawAttr . shapeToTree strokeScale <$> S.toList opened - - toSvgSize accessor var = - Just . Svg.Num $ fromIntegral var * accessor scale + 5 - - textSvg = textToTree scale <$> _diagramTexts diagram - - strokeScale = scale { _gridShapeContraction = 0 } - scale = GridSize - { _gridCellWidth = 10 - , _gridCellHeight = 14 - , _gridShapeContraction = 1.5 - } - +{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Text.AsciiDiagram.SvgRender( svgOfDiagram ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+#endif++import Control.Applicative( (<$>) )+import Control.Monad.State.Strict( execState )+import Data.Monoid( Last( .. ), (<>) )++import Graphics.Svg.Types+ ( HasDrawAttributes( .. )+ , Texture( ColorRef )+ , Document( .. )+ , drawAttr )+import Graphics.Svg( cssRulesOfText )++import Codec.Picture( PixelRGBA8( PixelRGBA8 ) )+import qualified Graphics.Svg.Types as Svg+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Text.Printf+import Linear( V2( .. )+ , (^+^)+ , (^-^)+ , (^*)+ , perp+ , normalize+ )+import Control.Lens( zoom, (.=), (%=), (%~), (&) )++import Text.AsciiDiagram.Geometry+import Text.AsciiDiagram.DiagramCleaner++{-import Debug.Trace-}+{-import Text.Groom-}++data GridSize = GridSize+ { _gridCellWidth :: !Float+ , _gridCellHeight :: !Float+ , _gridShapeContraction :: !Float+ }+ deriving (Eq, Show)+++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 = execState . zoom drawAttr $ do+ strokeColor .= toLC 0 0 0 255+ attrClass %= ("filled_shape":) + strokeWidth .= toL (Svg.Num 1)+ where+ toL = Last . Just+ toLC r g b a =+ toL . ColorRef $ PixelRGBA8 r g b a++applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a+applyLineArrowDrawAttr = execState . zoom drawAttr $ do+ fillColor .= toLC 0 0 0 255+ strokeColor .= toL Svg.FillNone+ strokeWidth .= toL (Svg.Num 0)+ where+ toL = Last . Just+ toLC r g b a =+ toL . ColorRef $ PixelRGBA8 r g b a++applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a+applyBulletDrawAttr = execState . zoom drawAttr $ do+ attrClass %= ("bullet":)++applyDefaultLineDrawAttr :: (Svg.WithDrawAttributes a) => a -> a+applyDefaultLineDrawAttr = execState . zoom drawAttr $ do+ attrClass %= ("line_element":)+ fillColor .= toL Svg.FillNone+ strokeColor .= toLC 0 0 0 255+ strokeWidth .= toL (Svg.Num 1)+ where+ toL = Last . Just+ toLC r g b a =+ toL . ColorRef $ PixelRGBA8 r g b a+++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+++-- >+-- > ^ perp:(0, -n)+-- > |+-- > (x, y)| (x + n, y)+-- > +-------------------+ b+-- > a|+-- > v correction+--+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 :: GridSize -> Shape -> Svg.Tree+shapeToTree 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+ $ 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 gscale shape =+ case concat arrows of+ [] -> svgPath+ lst -> Svg.GroupTree $ Svg.defaultSvg { Svg._groupChildren = svgPath : lst }+ where+ toS = toSvg gscale+ shapeElems = associateNextPoint (shapeIsClosed shape)+ . reorderShapePoints+ $ rollToSegment shape++ svgPath = classSet shape . dashingSet shape . Svg.PathTree+ $ 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++defaultCss :: Float -> T.Text+defaultCss textSize = T.pack $ printf+ ("\n" <>+ "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <>+ ".dashed_elem { stroke-dasharray: 4, 3 }\n" <>+ ".filled_shape { fill: url(#shape_light) }\n" <>+ ".bullet { stroke-width: 1px; fill: white; stroke: black }\n"+ )+ (2 + floor textSize :: Int)++lightShapeGradient :: Svg.Element+lightShapeGradient = Svg.ElementLinearGradient $+ Svg.defaultSvg+ { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0)+ , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1)+ , Svg._linearGradientStops =+ [ Svg.GradientStop 0 $ PixelRGBA8 245 245 245 255+ , Svg.GradientStop 1 $ PixelRGBA8 216 216 216 255+ ]+ }++-- | Transform an Ascii diagram to a SVG document which+-- can be saved or converted to an image.+svgOfDiagram :: Diagram -> Svg.Document+svgOfDiagram diagram = Document+ { _viewBox = Nothing+ , _width =+ toSvgSize _gridCellWidth $ _diagramCellWidth diagram + 1+ , _height =+ toSvgSize _gridCellHeight $ _diagramCellHeight diagram + 1+ , _elements = closedSvg ++ lineSvg ++ textSvg+ , _definitions = M.fromList+ [("shape_light", lightShapeGradient)]+ , _description = ""+ , _styleRules = defaultCssRules ++ customCssRules+ , _documentLocation = ""+ }+ where+ (closed, opened) = S.partition shapeIsClosed shapes++ defaultCssRules =+ cssRulesOfText . defaultCss $ _gridCellHeight scale++ customCssRules = + cssRulesOfText . T.unlines $ _diagramStyles diagram++ shapes = _diagramShapes diagram++ closedSvg =+ applyDefaultShapeDrawAttr . shapeToTree scale <$> filter isShapePossible+ (S.toList closed)+ lineSvg =+ applyDefaultLineDrawAttr . shapeToTree strokeScale <$> S.toList opened++ toSvgSize accessor var =+ Just . Svg.Num . realToFrac $ fromIntegral var * accessor scale + 5++ textSvg = textToTree scale <$> _diagramTexts diagram++ strokeScale = scale { _gridShapeContraction = 0 }+ scale = GridSize+ { _gridCellWidth = 10+ , _gridCellHeight = 14+ , _gridShapeContraction = 1.5+ }+