asciidiagram 1.3.3 → 1.3.3.1
raw patch · 11 files changed
+1996/−1975 lines, 11 filesdep +faildep +semigroupsPVP ok
version bump matches the API change (PVP)
Dependencies added: fail, semigroups
API changes (from Hackage documentation)
Files
- asciidiagram.cabal +8/−3
- changelog.md +4/−0
- exec-src/asciidiagram.hs +178/−178
- src/Text/AsciiDiagram.hs +628/−628
- src/Text/AsciiDiagram/BoundingBoxEstimation.hs +7/−3
- src/Text/AsciiDiagram/DiagramCleaner.hs +131/−131
- src/Text/AsciiDiagram/Geometry.hs +6/−2
- src/Text/AsciiDiagram/Graph.hs +7/−3
- src/Text/AsciiDiagram/Parser.hs +224/−224
- src/Text/AsciiDiagram/Reconstructor.hs +266/−266
- src/Text/AsciiDiagram/SvgRender.hs +537/−537
asciidiagram.cabal view
@@ -1,7 +1,7 @@ -- Initial hitaa.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: asciidiagram -version: 1.3.3 +version: 1.3.3.1 synopsis: Pretty rendering of Ascii diagram into svg or png. description: Transform Ascii art diagram like this: @@ -31,7 +31,7 @@ build-type: Simple extra-source-files: changelog.md extra-doc-files: docimages/*.svg -cabal-version: >=1.10 +cabal-version: >=1.18 Source-Repository head Type: git @@ -40,7 +40,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/asciidiagram.git - Tag: v1.3.3 + Tag: v1.3.3.1 library ghc-options: -O2 -Wall @@ -54,6 +54,11 @@ , Text.AsciiDiagram.Reconstructor , Text.AsciiDiagram.BoundingBoxEstimation , Text.AsciiDiagram.SvgRender + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 + build-depends: fail == 4.9.*, semigroups == 0.18.* -- containers >= 0.5.2.1 for Set.elemAt build-depends: base >=4.6 && < 5
changelog.md view
@@ -1,6 +1,10 @@ Change log ========== +v1.3.3.1 March 2018 +-------------------- + * Adding Semigroup instance for GHC 8.4 + v1.3.3 November 2017 -------------------- * Fixing compilation issue.
exec-src/asciidiagram.hs view
@@ -1,178 +1,178 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>), pure ) -#endif - -import Control.Applicative( (<|>) ) -import Control.Monad( when ) -import Data.Monoid( (<>) ) - -import qualified Data.ByteString.Lazy as LB -import qualified Data.Text.IO as STIO -import System.Directory( getTemporaryDirectory ) -import System.FilePath( (</>) - , replaceExtension - , takeExtension ) - -import Graphics.Svg( Document, loadSvgFile, saveXmlFile ) -import Graphics.Rasterific.Svg( loadCreateFontCache ) -import Graphics.Text.TrueType( FontCache ) -import Codec.Picture( writePng ) -import Options.Applicative( Parser - , ParserInfo - , argument - , execParser - , flag - , fullDesc - , header - , help - , helper - , info - , long - , metavar - , optional - , progDesc - , short - , str - , strOption - , switch - ) -import Graphics.Rasterific.Svg( renderSvgDocument - , pdfOfSvgDocument ) -import Text.AsciiDiagram - -data Mode - = Convert !(FilePath, FilePath) - | DumpLibrary !FilePath - -data Options = Options - { _workingMode :: !Mode - , _verbose :: !Bool - , _withLibrary :: !(Maybe FilePath) - , _format :: !(Maybe Format) - } - -data Format = FormatSvg | FormatPng | FormatPdf - -ioParser :: Parser (String, String) -ioParser = (,) - <$> argument str - (metavar "INPUTFILE" - <> help "Text file of the Ascii diagram to parse.") - <*> (argument str - (metavar "OUTPUTFILE" - <> help ("Output file name, same as input with" - <> " different extension if unspecified.")) - <|> pure "") - -modeParser :: Parser Mode -modeParser = (Convert <$> ioParser) <|> (DumpLibrary <$> dumpParser) - where - dumpParser = strOption - ( long "dump-library" - <> short 'd' - <> metavar "FILENAME" - <> help "Dump the default shape library & styles in an SVG document") - -argParser :: Parser Options -argParser = Options - <$> modeParser - <*> ( switch (long "verbose" <> help "Display more information") ) - <*> ( optional $ strOption - ( long "with-library" - <> short 'l' - <> metavar "LIBRARY_FILENAME" - <> help "Use a custom shape & style library instead of the default one") ) - <*> ( flag Nothing (Just FormatSvg) - ( long "svg" - <> help "Force the use of the SVG format (deduced from extension otherwise)") - <|> flag Nothing (Just FormatPng) - ( long "png" - <> help "Force the use of the PNG format (deduced from extension otherwise) (by default)") - <|> flag Nothing (Just FormatPdf) - ( long "pdf" - <> help "Force the use of the PDF format (deduced from extension otherwise)") - ) - -progOptions :: ParserInfo Options -progOptions = info (helper <*> argParser) - ( fullDesc - <> progDesc "Convert INPUTFILE into a svg or png OUTPUTFILE" - <> header "asciidiagram - A pretty printer for ASCII art diagram to SVG." ) - -formatOfOuputFilename :: FilePath -> Format -formatOfOuputFilename f = case takeExtension f of - ".png" -> FormatPng - ".svg" -> FormatSvg - ".pdf" -> FormatPdf - _ -> FormatPng - -getFontCache :: Bool -> IO FontCache -getFontCache verbose = do - when verbose $ putStrLn "Loading/Building font cache (can be long)" - tempDir <- getTemporaryDirectory - loadCreateFontCache $ tempDir </> "asciidiagram-fonty-fontcache" - - -loadLibrary :: Options -> IO Document -loadLibrary opt = case _withLibrary opt of - Nothing -> return defaultLib - Just p -> loadLib p - where - defaultLib = defaultLibrary defaultGridSize - loadLib p = do - f <- loadSvgFile p - case f of - Just doc -> return doc - Nothing -> do - putStrLn "Invalid library file, using default lib" - return defaultLib - -runConversion :: Options -> FilePath -> FilePath -> IO () -runConversion opt inputFile outputFile = do - verbose . putStrLn $ "Loading file " ++ inputFile - inputData <- STIO.readFile inputFile - lib <- loadLibrary opt - let diag = parseAsciiDiagram inputData - svg = svgOfDiagramAtSize defaultGridSize lib diag - format = _format opt <|> (pure $ formatOfOuputFilename outputFile) - case format of - Nothing -> saveDoc svg - Just FormatSvg -> saveDoc svg - Just FormatPng -> savePng svg - Just FormatPdf -> savePdf svg - where - verbose = when $ _verbose opt - saveDoc svg = do - verbose . putStrLn $ "Writing SVG file " ++ outputFile - saveXmlFile (savingPath "svg") svg - - savingPath ext = case outputFile of - "" -> replaceExtension inputFile ext - p -> p - - savePdf svg = do - cache <- getFontCache $ _verbose opt - verbose . putStrLn $ "Writing PDF file " ++ outputFile - (pdf, _) <- pdfOfSvgDocument cache Nothing 96 svg - LB.writeFile (savingPath "pdf") pdf - - savePng svg = do - cache <- getFontCache $ _verbose opt - verbose . putStrLn $ "Writing PNG file " ++ outputFile - (img, _) <- renderSvgDocument cache Nothing 96 svg - writePng (savingPath "png") img - -dumpLibrary :: FilePath -> IO () -dumpLibrary path = - saveXmlFile path $ defaultLibrary defaultGridSize - -main :: IO () -main = execParser progOptions >>= \opts -> - case _workingMode opts of - Convert (i, o) -> runConversion opts i o - DumpLibrary p -> dumpLibrary p - +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>), (<*>), pure )+#endif++import Control.Applicative( (<|>) )+import Control.Monad( when )+import Data.Monoid( (<>) )++import qualified Data.ByteString.Lazy as LB+import qualified Data.Text.IO as STIO+import System.Directory( getTemporaryDirectory )+import System.FilePath( (</>)+ , replaceExtension+ , takeExtension )++import Graphics.Svg( Document, loadSvgFile, saveXmlFile )+import Graphics.Rasterific.Svg( loadCreateFontCache )+import Graphics.Text.TrueType( FontCache )+import Codec.Picture( writePng )+import Options.Applicative( Parser+ , ParserInfo+ , argument+ , execParser+ , flag+ , fullDesc+ , header+ , help+ , helper+ , info+ , long+ , metavar+ , optional+ , progDesc+ , short+ , str+ , strOption+ , switch+ )+import Graphics.Rasterific.Svg( renderSvgDocument+ , pdfOfSvgDocument )+import Text.AsciiDiagram++data Mode+ = Convert !(FilePath, FilePath)+ | DumpLibrary !FilePath++data Options = Options+ { _workingMode :: !Mode+ , _verbose :: !Bool+ , _withLibrary :: !(Maybe FilePath)+ , _format :: !(Maybe Format)+ }++data Format = FormatSvg | FormatPng | FormatPdf++ioParser :: Parser (String, String)+ioParser = (,)+ <$> argument str+ (metavar "INPUTFILE"+ <> help "Text file of the Ascii diagram to parse.")+ <*> (argument str+ (metavar "OUTPUTFILE"+ <> help ("Output file name, same as input with"+ <> " different extension if unspecified."))+ <|> pure "")++modeParser :: Parser Mode+modeParser = (Convert <$> ioParser) <|> (DumpLibrary <$> dumpParser)+ where + dumpParser = strOption + ( long "dump-library"+ <> short 'd'+ <> metavar "FILENAME"+ <> help "Dump the default shape library & styles in an SVG document") ++argParser :: Parser Options+argParser = Options+ <$> modeParser+ <*> ( switch (long "verbose" <> help "Display more information") )+ <*> ( optional $ strOption+ ( long "with-library"+ <> short 'l'+ <> metavar "LIBRARY_FILENAME"+ <> help "Use a custom shape & style library instead of the default one") )+ <*> ( flag Nothing (Just FormatSvg)+ ( long "svg"+ <> help "Force the use of the SVG format (deduced from extension otherwise)")+ <|> flag Nothing (Just FormatPng)+ ( long "png"+ <> help "Force the use of the PNG format (deduced from extension otherwise) (by default)")+ <|> flag Nothing (Just FormatPdf)+ ( long "pdf"+ <> help "Force the use of the PDF format (deduced from extension otherwise)")+ )++progOptions :: ParserInfo Options+progOptions = info (helper <*> argParser)+ ( fullDesc+ <> progDesc "Convert INPUTFILE into a svg or png OUTPUTFILE"+ <> header "asciidiagram - A pretty printer for ASCII art diagram to SVG." )++formatOfOuputFilename :: FilePath -> Format+formatOfOuputFilename f = case takeExtension f of+ ".png" -> FormatPng+ ".svg" -> FormatSvg+ ".pdf" -> FormatPdf+ _ -> FormatPng++getFontCache :: Bool -> IO FontCache+getFontCache verbose = do+ when verbose $ putStrLn "Loading/Building font cache (can be long)"+ tempDir <- getTemporaryDirectory + loadCreateFontCache $ tempDir </> "asciidiagram-fonty-fontcache"+++loadLibrary :: Options -> IO Document+loadLibrary opt = case _withLibrary opt of+ Nothing -> return defaultLib+ Just p -> loadLib p+ where+ defaultLib = defaultLibrary defaultGridSize+ loadLib p = do+ f <- loadSvgFile p+ case f of+ Just doc -> return doc+ Nothing -> do+ putStrLn "Invalid library file, using default lib"+ return defaultLib ++runConversion :: Options -> FilePath -> FilePath -> IO ()+runConversion opt inputFile outputFile = do+ verbose . putStrLn $ "Loading file " ++ inputFile+ inputData <- STIO.readFile inputFile+ lib <- loadLibrary opt+ let diag = parseAsciiDiagram inputData+ svg = svgOfDiagramAtSize defaultGridSize lib diag+ format = _format opt <|> (pure $ formatOfOuputFilename outputFile)+ case format of+ Nothing -> saveDoc svg+ Just FormatSvg -> saveDoc svg+ Just FormatPng -> savePng svg+ Just FormatPdf -> savePdf svg+ where+ verbose = when $ _verbose opt+ saveDoc svg = do+ verbose . putStrLn $ "Writing SVG file " ++ outputFile+ saveXmlFile (savingPath "svg") svg++ savingPath ext = case outputFile of+ "" -> replaceExtension inputFile ext+ p -> p++ savePdf svg = do+ cache <- getFontCache $ _verbose opt+ verbose . putStrLn $ "Writing PDF file " ++ outputFile+ (pdf, _) <- pdfOfSvgDocument cache Nothing 96 svg+ LB.writeFile (savingPath "pdf") pdf++ savePng svg = do+ cache <- getFontCache $ _verbose opt+ verbose . putStrLn $ "Writing PNG file " ++ outputFile+ (img, _) <- renderSvgDocument cache Nothing 96 svg+ writePng (savingPath "png") img++dumpLibrary :: FilePath -> IO ()+dumpLibrary path =+ saveXmlFile path $ defaultLibrary defaultGridSize++main :: IO ()+main = execParser progOptions >>= \opts ->+ case _workingMode opts of+ Convert (i, o) -> runConversion opts i o+ DumpLibrary p -> dumpLibrary p+
src/Text/AsciiDiagram.hs view
@@ -1,628 +1,628 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} --- | This module gives access to the ascii diagram parser and --- SVG renderer. --- --- Ascii diagram, transform your ASCII art drawing to a nicer --- representation --- --- @ --- \/---------+ --- +---------+ | | --- | ASCII +----\>| Diagram | --- +---------+ | | --- |{flat} | +--+------\/ --- \\---*-----\/\<=======\/ --- ::: .flat .filled_shape { fill: #DDD; } --- @ --- <<docimages/baseExample.svg>> --- --- To render the diagram as a PNG file, you have to use the --- library rasterific-svg and JuicyPixels. --- --- As a sample usage, to save a diagram to png, you can use --- the following snippet. --- --- > import Codec.Picture( writePng ) --- > import Text.AsciiDiagram( imageOfDiagram ) --- > import Graphics.Rasterific.Svg( loadCreateFontCache ) --- > --- > saveDiagramToFile :: FilePath -> Diagram -> IO () --- > saveDiagramToFile path diag = do --- > cache <- loadCreateFontCache "asciidiagram-fonty-fontcache" --- > imageOfDiagram cache 96 diag --- > writePng path img --- -module Text.AsciiDiagram - ( - -- $introDoc - -- * Diagram format - - -- ** Lines - -- $linesdoc - - -- ** Shapes - -- $shapesdoc - - -- ** Bullets - -- $bulletdoc - - -- ** Styles - -- $styledoc - - -- ** Hierarchical styles - -- $hierarchicalDoc - - -- ** Shapes - -- $shapeDoc - - -- * Functions - svgOfDiagram - , parseAsciiDiagram - , saveAsciiDiagramAsSvg - , imageOfDiagram - , pdfOfDiagram - - -- * Customized rendering - , svgOfDiagramAtSize - , GridSize( .. ) - , defaultGridSize - , saveAsciiDiagramAsSvgAtSize - , imageOfDiagramAtSize - , pdfOfDiagramAtSize - - -- * Library - , defaultLibrary - - -- * Document description - , Diagram( .. ) - , TextZone( .. ) - , Shape( .. ) - , ShapeElement( .. ) - , Anchor( .. ) - , Segment( .. ) - , SegmentKind( .. ) - , SegmentDraw( .. ) - , Point - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -#endif - -import Data.Monoid( (<>)) -import Control.Monad( forM_ ) -import Control.Monad.ST( runST ) -import Data.Function( on ) -import Data.List( partition, sortBy ) -import qualified Data.ByteString.Lazy as LB -import qualified Data.Foldable as F -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM -import Linear( V2( V2 ) ) - -import Text.AsciiDiagram.Parser -import Text.AsciiDiagram.Reconstructor -import Text.AsciiDiagram.SvgRender -import Text.AsciiDiagram.Geometry -import Text.AsciiDiagram.DiagramCleaner - -import Codec.Picture( Image, PixelRGBA8 ) -import Graphics.Text.TrueType( FontCache ) -import Graphics.Svg( saveXmlFile ) -import Graphics.Rasterific.Svg( renderSvgDocument, pdfOfSvgDocument ) - -{-import Debug.Trace-} -{-import Text.Groom-} -{-import Text.Printf-} - -data CharBoard = CharBoard - { _boardWidth :: !Int - , _boardHeight :: !Int - , _boardData :: !(VU.Vector Char) - } - deriving (Eq, Show) - -textOfCharBoard :: CharBoard -> [T.Text] -textOfCharBoard board = fetch <$> zip [0 .. h - 1] [0, w..] where - w = _boardWidth board - h = _boardHeight board - charData = _boardData board - - fetch (_, startIdx) = - T.pack . VU.toList . VU.take w $ VU.drop startIdx charData - -charBoardOfText :: [T.Text] -> CharBoard -charBoardOfText textLines = CharBoard - { _boardWidth = twidth - , _boardHeight = theight - , _boardData = charData - } - where - twidth = maximum $ fmap T.length textLines - theight = length textLines - - lineIndices = zip [0, twidth ..] textLines - - charData = runST $ do - emptyBoard <- VUM.replicate (twidth * theight) ' ' - - forM_ lineIndices $ \(lineIndex, l) -> do - let chars = zip [lineIndex, lineIndex + 1 ..] $ T.unpack l - forM_ chars $ \(idx, c) -> do - VUM.unsafeWrite emptyBoard idx c - - VU.unsafeFreeze emptyBoard - - -pointsOfShape :: F.Foldable f => f Shape -> [Point] -pointsOfShape = F.concatMap (F.concatMap go . shapeElements) where - go (ShapeAnchor p _) = [p] - go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey }) - | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]] - | sx == ex = [V2 sx yy | yy <- [sy .. ey]] - | sy == ey && sx >= ex = [V2 xx sy | xx <- [ex .. sx]] - | sy == ey = [V2 xx sy | xx <- [sx .. ex]] - | otherwise = [] - -cleanLines :: [Int] -> CharBoard -> CharBoard -cleanLines idxs board = board { _boardData = _boardData board VU.// toSet } - where - xMax = _boardWidth board - 1 - toSet = [(lineIndex + column, ' ') - | lineNum <- idxs - , let lineIndex = lineNum * _boardWidth board - , column <- [0 .. xMax] - ] - -cleanupShapes :: (F.Foldable f) => f Shape -> CharBoard -> CharBoard -cleanupShapes shapes board = board { _boardData = _boardData board VU.// toSet } - where - toSet = [(x + y * _boardWidth board, ' ') | V2 x y <- pointsOfShape shapes] - - -pointComp :: Point -> Point -> Ordering -pointComp (V2 x1 y1) (V2 x2 y2) = case compare y1 y2 of - EQ -> compare x1 x2 - a -> a - -featuresOfClosedShape :: Shape -> [Point] -featuresOfClosedShape = F.fold . go . shapeElements where - go [] = [] - -- If we got something like +----+ we skip the first anchor and - -- the segment. - go ( ShapeAnchor (V2 _ ay1) _ - : ShapeSegment Segment { _segStart = V2 _ sy, _segEnd = V2 _ ey } - : rest@(ShapeAnchor (V2 _ ay2) _ : _) - ) - | ay1 == ay2 && sy == ey && ay1 == sy = go rest - go (ShapeAnchor p _: rest) = [p] : go rest - go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey } : rest) - | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]] : after - | sx == ex = [V2 sx yy | yy <- [sy .. ey]] : after - | otherwise = after - where after = go rest - -rangesOfOpenedShape :: Shape -> [(Point, Point)] -rangesOfOpenedShape s = fmap dup . sortBy pointComp $ pointsOfShape [s] - where dup a = (a, a) - -rangesOfClosedShape :: Shape -> [(Point, Point)] -rangesOfClosedShape shape = pairAssoc sortedPoints - where - pairAssoc [] = [] - pairAssoc [_] = [] - pairAssoc (p1@(V2 _ y1):lst@(p2@(V2 _ y2):rest)) - | y1 == y2 = (p1, p2) : pairAssoc rest - | otherwise = pairAssoc lst - - sortedPoints = sortBy pointComp $ featuresOfClosedShape shape - - -class RangeDecomposable a where - rangesOf :: a -> [(Point, Point)] - -instance RangeDecomposable Shape where - rangesOf s - | shapeIsClosed s = rangesOfClosedShape s - | otherwise = rangesOfOpenedShape s - -instance RangeDecomposable TextZone where - rangesOf txt = [(orig, V2 (x + txtLength) y)] where - orig@(V2 x y) = _textZoneOrigin txt - txtLength = T.length $ _textZoneContent txt - - -contains :: (RangeDecomposable a, RangeDecomposable b) => a -> b -> Bool -contains sa sb = go (rangesOf sa) (rangesOf sb) where - go _ [] = True - go [] (_:_) = False - go ((V2 _ ya, _):rest1) rest2@((V2 _ yb, _):_) - -- A part of second shape is before potentially englobing shpae - -- so sa can't contain sb - | ya > yb = False - -- sa may be bigger, just skip - | ya < yb = go rest1 rest2 - -- here ya == yb - go sal@((V2 xa1 _, V2 xa2 _):rest1) - sar@((V2 xb1 _, V2 xb2 _):rest2) - -- sb is before any range of sa, so we must have - -- missed something, sa not containing sb - | xb1 < xa1 = False - -- sb is in the range bounds - | xa1 <= xb1 && xb2 <= xa2 = go sal rest2 - -- Maybe sa has another range on the same line - | xb1 > xa2 = go rest1 sar - | otherwise = False - -areaOfShape :: Shape -> Int -areaOfShape = F.sum . fmap dist . rangesOfClosedShape - where - -- we can use manathan distance here - dist (V2 x1 y1, V2 x2 y2) = abs (x1 - x2) + abs (y1 - y2) - -sortByArea :: [Shape] -> [Shape] -sortByArea shapes = sorted <> opened - where - (closed, opened) = partition shapeIsClosed shapes - sorted = - fmap snd . reverse $ sortBy (compare `on` fst) [(areaOfShape s, s) | s <- closed] - -hierarchise :: [Shape] -> [TextZone] -> [TextZone] -> [Element] -hierarchise shapes allTexts = finalize . go areaSortedShapes allTexts where - areaSortedShapes = sortByArea shapes - - finalize (topShapes, topText, _topTags) = - (ElemShape <$> topShapes) <> (ElemText <$> topText) - - go [] texts tags = ([], texts, tags) - go (x:xs) texts tags | not (shapeIsClosed x) = (x:outShapes, outTexts, outTags) - where - (outShapes, outTexts, outTags) = go xs texts tags - go (x:xs) texts tags = (newShape : restShapes, restText, restTags) - where - (shapeInShape, shapeOutShape) = partition (x `contains`) xs - (textInShape, textOutShape) = partition (x `contains`) texts - (tagsInShape, tagsOutShape) = partition (x `contains`) tags - - (innerShapes, innerText, innerTags) = go shapeInShape textInShape tagsInShape - (restShapes, restText, restTags) = go shapeOutShape textOutShape tagsOutShape - - newShape = x - { shapeChildren = - (ElemShape <$> innerShapes) <> (ElemText <$> innerText) - , shapeTags = S.fromList $ _textZoneContent <$> innerTags - } - --- | Analyze an ascii diagram and extract all it's features. -parseAsciiDiagram :: T.Text -> Diagram -parseAsciiDiagram content = Diagram - { _diagramElements = S.fromList allElements - , _diagramCellWidth = maximum $ fmap T.length textLines - , _diagramCellHeight = length textLines - length styleLines - , _diagramStyles = reverse styleLines - } - where - textLines = T.lines content - allElements = hierarchise (S.toList validShapes) nonEmptyZones tags - - nonEmptyZones = [t | t <- zones, not . T.null $ _textZoneContent t] - (tags, zones) = detectTagFromTextZone $ extractTextZones shapeCleanedText - (styleLineNumber, styleLines) = unzip $ styleLine parsed - - shapeCleanedText = - textOfCharBoard . cleanLines styleLineNumber - . cleanupShapes validShapes - $ charBoardOfText textLines - - parsed = parseTextLines textLines - reconstructed = - reconstruct (anchorMap parsed) $ segmentSet parsed - validShapes = S.filter isShapePossible reconstructed - --- | Helper function helping you save a diagram as --- a SVG file on disk. -saveAsciiDiagramAsSvg :: FilePath -> Diagram -> IO () -saveAsciiDiagramAsSvg fileName diagram = - saveXmlFile fileName $ svgOfDiagram diagram - --- | Helper function helping you save a diagram as --- a SVG file on disk with a customized grid size. -saveAsciiDiagramAsSvgAtSize :: FilePath -> GridSize -> Diagram -> IO () -saveAsciiDiagramAsSvgAtSize fileName gridSize = - saveXmlFile fileName . svgOfDiagramAtSize gridSize (defaultLibrary gridSize) - --- | Render a Diagram as an image. The Dpi --- is 96. The IO dependency is there to allow loading of the --- font files used in the document. -imageOfDiagram :: FontCache -> Diagram -> IO (Image PixelRGBA8) -imageOfDiagram cache = - fmap fst . renderSvgDocument cache Nothing 96 . svgOfDiagram - --- | Render a Diagram as an image with a custom grid size. The Dpi --- is 96. The IO dependency is there to allow loading of the --- font files used in the document. -imageOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO (Image PixelRGBA8) -imageOfDiagramAtSize cache gridSize = - fmap fst . renderSvgDocument cache Nothing 96 - . svgOfDiagramAtSize gridSize (defaultLibrary gridSize) - --- | Render a Diagram into a PDF file. IO dependency to allow --- loading of the font files used in the document. -pdfOfDiagram :: FontCache -> Diagram -> IO LB.ByteString -pdfOfDiagram cache = - fmap fst . pdfOfSvgDocument cache Nothing 96 . svgOfDiagram - --- | Render a Diagram into a PDF file with a custom grid size. --- IO dependency to allow loading of the font files used in the document. -pdfOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO LB.ByteString -pdfOfDiagramAtSize cache size = - fmap fst . pdfOfSvgDocument cache Nothing 96 - . svgOfDiagramAtSize size (defaultLibrary size) - --- $introDoc --- Ascii diagram, transform your ASCII art drawing to a nicer --- representation --- --- --- @ --- \/---------+ --- +---------+ | | --- | ASCII +----\>| Diagram | --- +---------+ | | --- |{flat} | +--+------\/ --- \\---*-----\/\<=======\/ --- ::: .flat .filled_shape { fill: #DED; } --- @ --- <<docimages/baseExample.svg>> --- - --- $linesdoc --- The basic syntax of asciidiagrams is made of lines made out --- of \'-\' and \'|\' characters. They can be connected with anchors --- like \'+\' (direct connection) or \'\\\' and \'\/\' (smooth connections) --- --- --- @ --- ----- --- ------- --- --- | | --- | | --- | \\---- --- | --- +----- --- @ --- <<docimages/simple_lines.svg>> --- --- You can use dashed lines by using ':' for vertical lines or '=' for --- horizontal line --- --- --- @ --- ----- --- -=----- --- --- | : --- | | --- | \\---- --- | --- +--=-- --- @ --- <<docimages/dashed_lines.svg>> --- --- Arrows are made out of the \'\<\', \'\>\', \'^\' and \'v\' --- characters. --- If the arrows are not connected to any lines, the text is left as is. --- --- --- @ --- ^ --- | --- | --- \<----+----\> --- | \< \> v ^ --- | --- v --- --- @ --- <<docimages/arrows.svg>> --- - --- $shapesdoc --- If the lines are closed, then it is detected as such and rendered --- differently --- --- --- @ --- +------+ --- | | --- | +--+ --- | | | --- +---+--+ | --- | | --- +-----+ --- @ --- <<docimages/complexClosed.svg>> --- --- If any of the segment posess one of the dashing markers (\':\' or \'=\') --- Then the full shape will be dashed. --- --- --- @ --- +--+ +--+ +=-+ +=-+ --- | | : | | | | : --- +--+ +--+ +--+ +-=+ --- @ --- <<docimages/dashingClosed.svg>> --- --- Any of the angle of a shape can curved one of the smooth corner anchor --- (\'\\\' or \'\/\') --- --- --- @ --- \/--+ +--\\ +--+ \/--+ --- | | | | | | | | --- +--+ +--+ \\--+ +--+ --- --- \/--+ \/--\\ \/--+ \/--\\ . --- | | | | | | | | --- +--\/ +--+ \\--\/ +--\/ --- --- \/--\\ . --- | | --- \\--\/ --- . --- @ --- <<docimages/curvedCorner.svg>> --- - --- $bulletdoc --- Adding a \'*\' on a line or on a shape add a little circle on it. --- If the bullet is not attached to any shape or lines, then it --- will be render like any other text. --- --- --- @ --- *-*-* --- | | *----* --- +---\/ | --- * * * --- @ --- <<docimages/bulletTest.svg>> --- --- When used at connection points, it behaves like the \'+\' anchor. --- - --- $styledoc --- The shapes can ba annotated with a tag like `{tagname}`. --- Tags will be inserted in the class attribute of the shape --- and can then be stylized with a CSS. --- --- --- @ --- +--------+ +--------+ --- | Source +--------\>| op1 | --- | {src} | \\---+----\/ --- +--------+ | --- +-------*\<--\/ --- +------+\<--| op2 | --- | Dest | +-------+ --- |{dst} | --- +------+ --- --- ::: .src .filled_shape { fill: #AAF; } --- ::: .dst .filled_shape { stroke: #FAA; stroke-width: 3px; } --- @ --- <<docimages/styleExample.svg>> --- --- Inline css styles are introduced with the ":::" prefix --- at the beginning of the line. They are introduced in the --- style section of the generated CSS file --- --- The generated geometry also possess some predefined class --- which are overidable: --- --- * "dashed_elem" is applied on every dashed element. --- --- * "filled_shape" is applied on every closed shape. --- --- * "arrow_head" is applied on arrow head. --- --- * "bullet" on every bullet placed on a shape or line. --- --- * "line_element" on every line element, this include the arrow head. --- --- You can then customize the appearance of the diagram as you want. --- - --- $hierarchicalDoc --- Starting with version 1.3, all shapes, text and lines are --- hierachised, a shape within a shape will be integrated within --- the same group. This allows more complex styling: --- --- --- @ --- \/------------------------------------------------------\\ . --- |s100 | --- | \/----------------------------\\ | --- | |s1 \/--------\\ | e1 \/--------\\ | --- | | *---\>| s2 | +-------\>| s10 | | --- | +----+ \\---+----\/ | \\--------\/ | --- | | i4 | | | ^ | --- | |{ii}+---------\\| e1 {lo} | | | --- | +----+ vv | ealarm | | e0 \/-------------\\ . --- | | \/--------\\ +-----------\/ +----------\>| s50 | --- | +----\\ | s3 {lu}| | | \\-------------\/ --- | | o5 | e2 \\--+-----\/ | | --- | |{oo}|\<---------\/ |\<-\\ | --- | \\-+--+--------------------+--\/ | | --- | | | | eReset | --- | | \\-----\/ | --- | v | --- | \/--------\\ | --- | | s20 | {li} | --- | \\--------\/ | --- \\------------------------------------------------------\/ --- --- ::: .li .line_element { stroke: purple; } --- ::: .li .arrow_head, .li text { fill: gray; } --- ::: .lo .line_element { stroke: blue; } --- ::: .lo .arrow_head, .lo text { fill: green; } --- ::: .lu .line_element { stroke: red; } --- ::: .lu .arrow_head, .lu text { fill: orange; } --- ::: .ii .filled_shape { fill: #DDF; } --- ::: .ii text { fill: blue; } --- ::: .oo .filled_shape { fill: #DFD; } --- ::: .oo text { fill: pink; } --- @ --- <<docimages/deepStyleExample.svg>> --- --- In the previous example, we can see that the lines color are --- 'shape scoped' and the tag applied to the shape above them --- applies to them --- - --- $shapeDoc --- From version 1.3, you can substitute the shape of your element --- with one from a shape library. Right now the shape library is --- relatively small: --- --- --- @ --- +---------+ +----------+ --- | | | | --- | circle | | | --- | | | io | --- |{circle} | | {io} | --- +---------+ +----------+ --- --- +----------+ +----------+ --- |document | | | --- | | | | --- | | | storage | --- |{document}| | {storage}| --- +----------+ +----------+ --- --- ::: .circle .filled_shape { shape: circle; } --- ::: .document .filled_shape { shape: document; } --- ::: .storage .filled_shape { shape: storage; } --- ::: .io .filled_shape { shape: io; } --- @ --- <<docimages/shapeExample.svg>> --- --- The mechanism use CSS styling to change the shape, if a CSS rule --- possess a `shape` pseudo attribute, then the generated shape is replaced --- with a SVG `use` tag with the value of the shape attribute as `href` --- --- But, you can create your own style library and change the default --- stylesheet. You can retrieve the default one with the shell command --- `asciidiagram --dump-library default-lib.svg` --- --- You can then add your own symbols tag in it and use it by calling --- `asciidiagram --with-library your-lib.svg`. --- +{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+-- | This module gives access to the ascii diagram parser and+-- SVG renderer.+--+-- Ascii diagram, transform your ASCII art drawing to a nicer+-- representation+-- +-- @+-- \/---------++-- +---------+ | |+-- | ASCII +----\>| Diagram |+-- +---------+ | |+-- |{flat} | +--+------\/+-- \\---*-----\/\<=======\/+-- ::: .flat .filled_shape { fill: #DDD; }+-- @+-- <<docimages/baseExample.svg>>+-- +-- To render the diagram as a PNG file, you have to use the+-- library rasterific-svg and JuicyPixels.+--+-- As a sample usage, to save a diagram to png, you can use+-- the following snippet.+--+-- > import Codec.Picture( writePng )+-- > import Text.AsciiDiagram( imageOfDiagram )+-- > import Graphics.Rasterific.Svg( loadCreateFontCache )+-- >+-- > saveDiagramToFile :: FilePath -> Diagram -> IO ()+-- > saveDiagramToFile path diag = do+-- > cache <- loadCreateFontCache "asciidiagram-fonty-fontcache"+-- > imageOfDiagram cache 96 diag+-- > writePng path img+--+module Text.AsciiDiagram+ ( + -- $introDoc+ -- * Diagram format++ -- ** Lines+ -- $linesdoc++ -- ** Shapes+ -- $shapesdoc++ -- ** Bullets+ -- $bulletdoc++ -- ** Styles+ -- $styledoc++ -- ** Hierarchical styles+ -- $hierarchicalDoc++ -- ** Shapes+ -- $shapeDoc++ -- * Functions+ svgOfDiagram+ , parseAsciiDiagram+ , saveAsciiDiagramAsSvg+ , imageOfDiagram+ , pdfOfDiagram++ -- * Customized rendering+ , svgOfDiagramAtSize + , GridSize( .. )+ , defaultGridSize+ , saveAsciiDiagramAsSvgAtSize+ , imageOfDiagramAtSize+ , pdfOfDiagramAtSize++ -- * Library+ , defaultLibrary++ -- * Document description+ , Diagram( .. ) + , TextZone( .. )+ , Shape( .. )+ , ShapeElement( .. )+ , Anchor( .. )+ , Segment( .. )+ , SegmentKind( .. )+ , SegmentDraw( .. )+ , Point+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+#endif++import Data.Monoid( (<>))+import Control.Monad( forM_ )+import Control.Monad.ST( runST )+import Data.Function( on )+import Data.List( partition, sortBy )+import qualified Data.ByteString.Lazy as LB+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import Linear( V2( V2 ) )++import Text.AsciiDiagram.Parser+import Text.AsciiDiagram.Reconstructor+import Text.AsciiDiagram.SvgRender+import Text.AsciiDiagram.Geometry+import Text.AsciiDiagram.DiagramCleaner++import Codec.Picture( Image, PixelRGBA8 )+import Graphics.Text.TrueType( FontCache )+import Graphics.Svg( saveXmlFile )+import Graphics.Rasterific.Svg( renderSvgDocument, pdfOfSvgDocument )++{-import Debug.Trace-}+{-import Text.Groom-}+{-import Text.Printf-}++data CharBoard = CharBoard+ { _boardWidth :: !Int+ , _boardHeight :: !Int+ , _boardData :: !(VU.Vector Char)+ }+ deriving (Eq, Show)++textOfCharBoard :: CharBoard -> [T.Text]+textOfCharBoard board = fetch <$> zip [0 .. h - 1] [0, w..] where+ w = _boardWidth board+ h = _boardHeight board+ charData = _boardData board++ fetch (_, startIdx) =+ T.pack . VU.toList . VU.take w $ VU.drop startIdx charData++charBoardOfText :: [T.Text] -> CharBoard+charBoardOfText textLines = CharBoard+ { _boardWidth = twidth+ , _boardHeight = theight+ , _boardData = charData+ }+ where+ twidth = maximum $ fmap T.length textLines+ theight = length textLines+ + lineIndices = zip [0, twidth ..] textLines++ charData = runST $ do+ emptyBoard <- VUM.replicate (twidth * theight) ' '++ forM_ lineIndices $ \(lineIndex, l) -> do+ let chars = zip [lineIndex, lineIndex + 1 ..] $ T.unpack l+ forM_ chars $ \(idx, c) -> do+ VUM.unsafeWrite emptyBoard idx c++ VU.unsafeFreeze emptyBoard+++pointsOfShape :: F.Foldable f => f Shape -> [Point]+pointsOfShape = F.concatMap (F.concatMap go . shapeElements) where+ go (ShapeAnchor p _) = [p]+ go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey })+ | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]]+ | sx == ex = [V2 sx yy | yy <- [sy .. ey]]+ | sy == ey && sx >= ex = [V2 xx sy | xx <- [ex .. sx]]+ | sy == ey = [V2 xx sy | xx <- [sx .. ex]]+ | otherwise = []++cleanLines :: [Int] -> CharBoard -> CharBoard+cleanLines idxs board = board { _boardData = _boardData board VU.// toSet }+ where+ xMax = _boardWidth board - 1+ toSet = [(lineIndex + column, ' ')+ | lineNum <- idxs+ , let lineIndex = lineNum * _boardWidth board+ , column <- [0 .. xMax]+ ]++cleanupShapes :: (F.Foldable f) => f Shape -> CharBoard -> CharBoard+cleanupShapes shapes board = board { _boardData = _boardData board VU.// toSet }+ where+ toSet = [(x + y * _boardWidth board, ' ') | V2 x y <- pointsOfShape shapes]+++pointComp :: Point -> Point -> Ordering+pointComp (V2 x1 y1) (V2 x2 y2) = case compare y1 y2 of+ EQ -> compare x1 x2+ a -> a++featuresOfClosedShape :: Shape -> [Point]+featuresOfClosedShape = F.fold . go . shapeElements where+ go [] = []+ -- If we got something like +----+ we skip the first anchor and+ -- the segment.+ go ( ShapeAnchor (V2 _ ay1) _+ : ShapeSegment Segment { _segStart = V2 _ sy, _segEnd = V2 _ ey }+ : rest@(ShapeAnchor (V2 _ ay2) _ : _)+ )+ | ay1 == ay2 && sy == ey && ay1 == sy = go rest+ go (ShapeAnchor p _: rest) = [p] : go rest+ go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey } : rest)+ | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]] : after+ | sx == ex = [V2 sx yy | yy <- [sy .. ey]] : after+ | otherwise = after+ where after = go rest++rangesOfOpenedShape :: Shape -> [(Point, Point)]+rangesOfOpenedShape s = fmap dup . sortBy pointComp $ pointsOfShape [s]+ where dup a = (a, a)++rangesOfClosedShape :: Shape -> [(Point, Point)]+rangesOfClosedShape shape = pairAssoc sortedPoints+ where+ pairAssoc [] = []+ pairAssoc [_] = []+ pairAssoc (p1@(V2 _ y1):lst@(p2@(V2 _ y2):rest))+ | y1 == y2 = (p1, p2) : pairAssoc rest+ | otherwise = pairAssoc lst++ sortedPoints = sortBy pointComp $ featuresOfClosedShape shape+++class RangeDecomposable a where+ rangesOf :: a -> [(Point, Point)]++instance RangeDecomposable Shape where+ rangesOf s+ | shapeIsClosed s = rangesOfClosedShape s+ | otherwise = rangesOfOpenedShape s++instance RangeDecomposable TextZone where+ rangesOf txt = [(orig, V2 (x + txtLength) y)] where+ orig@(V2 x y) = _textZoneOrigin txt+ txtLength = T.length $ _textZoneContent txt+++contains :: (RangeDecomposable a, RangeDecomposable b) => a -> b -> Bool+contains sa sb = go (rangesOf sa) (rangesOf sb) where+ go _ [] = True+ go [] (_:_) = False+ go ((V2 _ ya, _):rest1) rest2@((V2 _ yb, _):_)+ -- A part of second shape is before potentially englobing shpae+ -- so sa can't contain sb+ | ya > yb = False + -- sa may be bigger, just skip+ | ya < yb = go rest1 rest2+ -- here ya == yb+ go sal@((V2 xa1 _, V2 xa2 _):rest1)+ sar@((V2 xb1 _, V2 xb2 _):rest2)+ -- sb is before any range of sa, so we must have+ -- missed something, sa not containing sb+ | xb1 < xa1 = False+ -- sb is in the range bounds+ | xa1 <= xb1 && xb2 <= xa2 = go sal rest2+ -- Maybe sa has another range on the same line+ | xb1 > xa2 = go rest1 sar+ | otherwise = False+ +areaOfShape :: Shape -> Int+areaOfShape = F.sum . fmap dist . rangesOfClosedShape+ where+ -- we can use manathan distance here+ dist (V2 x1 y1, V2 x2 y2) = abs (x1 - x2) + abs (y1 - y2)++sortByArea :: [Shape] -> [Shape]+sortByArea shapes = sorted <> opened+ where+ (closed, opened) = partition shapeIsClosed shapes+ sorted =+ fmap snd . reverse $ sortBy (compare `on` fst) [(areaOfShape s, s) | s <- closed]++hierarchise :: [Shape] -> [TextZone] -> [TextZone] -> [Element]+hierarchise shapes allTexts = finalize . go areaSortedShapes allTexts where+ areaSortedShapes = sortByArea shapes++ finalize (topShapes, topText, _topTags) =+ (ElemShape <$> topShapes) <> (ElemText <$> topText)++ go [] texts tags = ([], texts, tags)+ go (x:xs) texts tags | not (shapeIsClosed x) = (x:outShapes, outTexts, outTags)+ where+ (outShapes, outTexts, outTags) = go xs texts tags+ go (x:xs) texts tags = (newShape : restShapes, restText, restTags)+ where+ (shapeInShape, shapeOutShape) = partition (x `contains`) xs+ (textInShape, textOutShape) = partition (x `contains`) texts+ (tagsInShape, tagsOutShape) = partition (x `contains`) tags++ (innerShapes, innerText, innerTags) = go shapeInShape textInShape tagsInShape+ (restShapes, restText, restTags) = go shapeOutShape textOutShape tagsOutShape++ newShape = x+ { shapeChildren =+ (ElemShape <$> innerShapes) <> (ElemText <$> innerText)+ , shapeTags = S.fromList $ _textZoneContent <$> innerTags+ }++-- | Analyze an ascii diagram and extract all it's features.+parseAsciiDiagram :: T.Text -> Diagram+parseAsciiDiagram content = Diagram+ { _diagramElements = S.fromList allElements+ , _diagramCellWidth = maximum $ fmap T.length textLines+ , _diagramCellHeight = length textLines - length styleLines+ , _diagramStyles = reverse styleLines+ }+ where+ textLines = T.lines content+ allElements = hierarchise (S.toList validShapes) nonEmptyZones tags++ nonEmptyZones = [t | t <- zones, not . T.null $ _textZoneContent t]+ (tags, zones) = detectTagFromTextZone $ extractTextZones shapeCleanedText + (styleLineNumber, styleLines) = unzip $ styleLine parsed++ shapeCleanedText =+ textOfCharBoard . cleanLines styleLineNumber+ . cleanupShapes validShapes+ $ charBoardOfText textLines+ + parsed = parseTextLines textLines+ reconstructed =+ reconstruct (anchorMap parsed) $ segmentSet parsed+ validShapes = S.filter isShapePossible reconstructed++-- | Helper function helping you save a diagram as+-- a SVG file on disk.+saveAsciiDiagramAsSvg :: FilePath -> Diagram -> IO ()+saveAsciiDiagramAsSvg fileName diagram =+ saveXmlFile fileName $ svgOfDiagram diagram++-- | Helper function helping you save a diagram as+-- a SVG file on disk with a customized grid size.+saveAsciiDiagramAsSvgAtSize :: FilePath -> GridSize -> Diagram -> IO ()+saveAsciiDiagramAsSvgAtSize fileName gridSize =+ saveXmlFile fileName . svgOfDiagramAtSize gridSize (defaultLibrary gridSize)++-- | Render a Diagram as an image. The Dpi+-- is 96. The IO dependency is there to allow loading of the+-- font files used in the document.+imageOfDiagram :: FontCache -> Diagram -> IO (Image PixelRGBA8)+imageOfDiagram cache = + fmap fst . renderSvgDocument cache Nothing 96 . svgOfDiagram++-- | Render a Diagram as an image with a custom grid size. The Dpi+-- is 96. The IO dependency is there to allow loading of the+-- font files used in the document.+imageOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO (Image PixelRGBA8)+imageOfDiagramAtSize cache gridSize =+ fmap fst . renderSvgDocument cache Nothing 96+ . svgOfDiagramAtSize gridSize (defaultLibrary gridSize)++-- | Render a Diagram into a PDF file. IO dependency to allow+-- loading of the font files used in the document.+pdfOfDiagram :: FontCache -> Diagram -> IO LB.ByteString+pdfOfDiagram cache =+ fmap fst . pdfOfSvgDocument cache Nothing 96 . svgOfDiagram++-- | Render a Diagram into a PDF file with a custom grid size.+-- IO dependency to allow loading of the font files used in the document.+pdfOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO LB.ByteString+pdfOfDiagramAtSize cache size =+ fmap fst . pdfOfSvgDocument cache Nothing 96+ . svgOfDiagramAtSize size (defaultLibrary size)++-- $introDoc+-- Ascii diagram, transform your ASCII art drawing to a nicer+-- representation+-- +-- +-- @+-- \/---------++-- +---------+ | |+-- | ASCII +----\>| Diagram |+-- +---------+ | |+-- |{flat} | +--+------\/+-- \\---*-----\/\<=======\/+-- ::: .flat .filled_shape { fill: #DED; }+-- @+-- <<docimages/baseExample.svg>>+-- ++-- $linesdoc+-- The basic syntax of asciidiagrams is made of lines made out+-- of \'-\' and \'|\' characters. They can be connected with anchors+-- like \'+\' (direct connection) or \'\\\' and \'\/\' (smooth connections)+-- +-- +-- @+-- ----- +-- ------- +-- +-- | | +-- | | +-- | \\---- +-- | +-- +----- +-- @+-- <<docimages/simple_lines.svg>>+-- +-- You can use dashed lines by using ':' for vertical lines or '=' for+-- horizontal line+-- +-- +-- @+-- ----- +-- -=----- +-- +-- | : +-- | | +-- | \\---- +-- | +-- +--=-- +-- @+-- <<docimages/dashed_lines.svg>>+-- +-- Arrows are made out of the \'\<\', \'\>\', \'^\' and \'v\'+-- characters.+-- If the arrows are not connected to any lines, the text is left as is.+-- +-- +-- @+-- ^+-- |+-- |+-- \<----+----\>+-- | \< \> v ^+-- |+-- v+-- +-- @+-- <<docimages/arrows.svg>>+-- ++-- $shapesdoc+-- If the lines are closed, then it is detected as such and rendered+-- differently+-- +-- +-- @+-- +------++-- | |+-- | +--++-- | | |+-- +---+--+ |+-- | |+-- +-----++-- @+-- <<docimages/complexClosed.svg>>+-- +-- If any of the segment posess one of the dashing markers (\':\' or \'=\')+-- Then the full shape will be dashed.+-- +-- +-- @+-- +--+ +--+ +=-+ +=-++-- | | : | | | | :+-- +--+ +--+ +--+ +-=++-- @+-- <<docimages/dashingClosed.svg>>+-- +-- Any of the angle of a shape can curved one of the smooth corner anchor+-- (\'\\\' or \'\/\')+-- +-- +-- @+-- \/--+ +--\\ +--+ \/--++-- | | | | | | | |+-- +--+ +--+ \\--+ +--++-- +-- \/--+ \/--\\ \/--+ \/--\\ .+-- | | | | | | | |+-- +--\/ +--+ \\--\/ +--\/+-- +-- \/--\\ .+-- | |+-- \\--\/+-- .+-- @+-- <<docimages/curvedCorner.svg>>+-- ++-- $bulletdoc+-- Adding a \'*\' on a line or on a shape add a little circle on it.+-- If the bullet is not attached to any shape or lines, then it+-- will be render like any other text.+-- +-- +-- @+-- *-*-*+-- | | *----*+-- +---\/ |+-- * * *+-- @+-- <<docimages/bulletTest.svg>>+-- +-- When used at connection points, it behaves like the \'+\' anchor.+-- ++-- $styledoc+-- The shapes can ba annotated with a tag like `{tagname}`.+-- Tags will be inserted in the class attribute of the shape+-- and can then be stylized with a CSS.+-- +-- +-- @+-- +--------+ +--------++-- | Source +--------\>| op1 |+-- | {src} | \\---+----\/+-- +--------+ |+-- +-------*\<--\/+-- +------+\<--| op2 |+-- | Dest | +-------++-- |{dst} |+-- +------++-- +-- ::: .src .filled_shape { fill: #AAF; }+-- ::: .dst .filled_shape { stroke: #FAA; stroke-width: 3px; }+-- @+-- <<docimages/styleExample.svg>>+-- +-- Inline css styles are introduced with the ":::" prefix+-- at the beginning of the line. They are introduced in the+-- style section of the generated CSS file+-- +-- The generated geometry also possess some predefined class+-- which are overidable:+-- +-- * "dashed_elem" is applied on every dashed element.+-- +-- * "filled_shape" is applied on every closed shape.+-- +-- * "arrow_head" is applied on arrow head.+-- +-- * "bullet" on every bullet placed on a shape or line.+-- +-- * "line_element" on every line element, this include the arrow head.+-- +-- You can then customize the appearance of the diagram as you want.+-- ++-- $hierarchicalDoc+-- Starting with version 1.3, all shapes, text and lines are+-- hierachised, a shape within a shape will be integrated within+-- the same group. This allows more complex styling: +-- +-- +-- @+-- \/------------------------------------------------------\\ .+-- |s100 |+-- | \/----------------------------\\ |+-- | |s1 \/--------\\ | e1 \/--------\\ |+-- | | *---\>| s2 | +-------\>| s10 | |+-- | +----+ \\---+----\/ | \\--------\/ |+-- | | i4 | | | ^ |+-- | |{ii}+---------\\| e1 {lo} | | |+-- | +----+ vv | ealarm | | e0 \/-------------\\ .+-- | | \/--------\\ +-----------\/ +----------\>| s50 |+-- | +----\\ | s3 {lu}| | | \\-------------\/+-- | | o5 | e2 \\--+-----\/ | |+-- | |{oo}|\<---------\/ |\<-\\ |+-- | \\-+--+--------------------+--\/ | |+-- | | | | eReset |+-- | | \\-----\/ |+-- | v |+-- | \/--------\\ |+-- | | s20 | {li} |+-- | \\--------\/ |+-- \\------------------------------------------------------\/+-- +-- ::: .li .line_element { stroke: purple; }+-- ::: .li .arrow_head, .li text { fill: gray; }+-- ::: .lo .line_element { stroke: blue; }+-- ::: .lo .arrow_head, .lo text { fill: green; }+-- ::: .lu .line_element { stroke: red; }+-- ::: .lu .arrow_head, .lu text { fill: orange; }+-- ::: .ii .filled_shape { fill: #DDF; }+-- ::: .ii text { fill: blue; }+-- ::: .oo .filled_shape { fill: #DFD; }+-- ::: .oo text { fill: pink; }+-- @+-- <<docimages/deepStyleExample.svg>>+-- +-- In the previous example, we can see that the lines color are+-- 'shape scoped' and the tag applied to the shape above them+-- applies to them+-- ++-- $shapeDoc+-- From version 1.3, you can substitute the shape of your element+-- with one from a shape library. Right now the shape library is+-- relatively small:+-- +-- +-- @+-- +---------+ +----------++-- | | | |+-- | circle | | |+-- | | | io |+-- |{circle} | | {io} |+-- +---------+ +----------++-- +-- +----------+ +----------++-- |document | | |+-- | | | |+-- | | | storage |+-- |{document}| | {storage}|+-- +----------+ +----------++-- +-- ::: .circle .filled_shape { shape: circle; }+-- ::: .document .filled_shape { shape: document; }+-- ::: .storage .filled_shape { shape: storage; }+-- ::: .io .filled_shape { shape: io; }+-- @+-- <<docimages/shapeExample.svg>>+-- +-- The mechanism use CSS styling to change the shape, if a CSS rule+-- possess a `shape` pseudo attribute, then the generated shape is replaced+-- with a SVG `use` tag with the value of the shape attribute as `href`+-- +-- But, you can create your own style library and change the default+-- stylesheet. You can retrieve the default one with the shell command+-- `asciidiagram --dump-library default-lib.svg`+-- +-- You can then add your own symbols tag in it and use it by calling+-- `asciidiagram --with-library your-lib.svg`.+--
src/Text/AsciiDiagram/BoundingBoxEstimation.hs view
@@ -11,7 +11,7 @@ ) #endif -import Data.Monoid( (<>) ) +import Data.Semigroup( Semigroup( .. )) import Linear( V2( .. ) , (^+^) , (^-^) @@ -25,10 +25,13 @@ } deriving (Eq, Show) +instance Semigroup BoundingBox where + (<>) (BoundingBox min1 max1) (BoundingBox min2 max2) = + BoundingBox (min <$> min1 <*> min2) (max <$> max1 <*> max2) + instance Monoid BoundingBox where mempty = BoundingBox (V2 0 0) (V2 0 0) - mappend (BoundingBox min1 max1) (BoundingBox min2 max2) = - BoundingBox (min <$> min1 <*> min2) (max <$> max1 <*> max2) + mappend = (<>) toEstimatedLength :: Number -> Coord toEstimatedLength n = case toUserUnit 96 n of @@ -121,4 +124,5 @@ ImageTree _ -> mempty GroupTree g -> boundingBoxOf g SymbolTree s -> boundingBoxOf s + MeshGradientTree _ -> mempty
src/Text/AsciiDiagram/DiagramCleaner.hs view
@@ -1,131 +1,131 @@-{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} -module Text.AsciiDiagram.DiagramCleaner - ( isShapePossible - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -import Control.Applicative( Applicative, (<*>), (<$>) ) -#endif - -import Control.Applicative( liftA2 ) -import Data.List( tails ) -import Text.AsciiDiagram.Geometry -import Linear( V2( V2 ) - , (^-^) - ) - -compareDirections :: Applicative f - => (Int -> Int -> Bool) -> f Int -> f Int -> f Bool -compareDirections f = liftA2 diffSign - where - diffSign 0 0 = True - diffSign aa bb = f aa bb - -checkRoundedCorners :: (Int -> Int -> Bool) - -> Segment -> Point -> Point -> Segment - -> Bool -checkRoundedCorners f s1 ap1 ap2 s2 = okX && okY - where - V2 dirX dirY = ap2 ^-^ ap1 - fromS1 = _segEnd s1 ^-^ ap1 - fromS2 = _segStart s2 ^-^ ap2 - - signDirs = signum <$> V2 dirY dirX - - V2 okX okY = (&&) - <$> (compareDirections f signDirs (signum <$> fromS1)) - <*> (compareDirections f signDirs (signum <$> fromS2)) - -checkClosedShape :: Shape -> Bool -checkClosedShape shape = all checkClosed elements where - elements = - (++ shapeElements shape) <$> tails (shapeElements shape) - - - -checkClosed :: [ShapeElement] -> Bool --- dir fromS1 fromS1 --- ---> -----> <---- ^ 2 \--- 3 --- /\ | 1 /---- 0 0 ----/ 1 | | \ --- 1/ \2 dir | / / | dir dir | / --- | | | \ \ | | 1 /--- 0 --- 0| |3 v 2 \---- 3 3 ----\ 2 v --- -----> <---- --- fromS2 fromS2 --- --- OK OK BAD BAD -checkClosed - ( ShapeSegment s1 - : ShapeAnchor ap1 AnchorFirstDiag -- '/' - : ShapeAnchor ap2 AnchorSecondDiag -- '\' - : ShapeSegment s2 - : _) = checkRoundedCorners (==) s1 ap1 ap2 s2 - --- dir fromS1 fromS1 --- ---> -----> <---- ^ 1 \--- 0 --- /\ | 2 /---- 3 3 ----/ 2 | | \ --- 2/ \1 dir | / / | dir dir | / --- | | | \ \ | | 2 /--- 3 --- 3| |0 v 1 \---- 0 0 ----\ 1 v --- -----> <---- --- fromS2 fromS2 --- --- OK OK BAD BAD -checkClosed - ( ShapeSegment s1 - : ShapeAnchor ap1 AnchorSecondDiag -- '\' - : ShapeAnchor ap2 AnchorFirstDiag -- '/' - : ShapeSegment s2 - : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2 - -checkClosed - ( ShapeAnchor _ AnchorFirstDiag - : ShapeAnchor _ AnchorSecondDiag - : ShapeAnchor _ AnchorFirstDiag - : ShapeAnchor _ AnchorSecondDiag - : _) = False - -checkClosed - ( ShapeAnchor _ AnchorSecondDiag - : ShapeAnchor _ AnchorFirstDiag - : ShapeAnchor _ AnchorSecondDiag - : ShapeAnchor _ AnchorFirstDiag - : _) = False - -checkClosed _ = True - -isBullet :: ShapeElement -> Bool -isBullet (ShapeAnchor _ AnchorBullet) = True -isBullet _ = False - -checkOpened :: [ShapeElement] -> Bool -checkOpened - [ ShapeAnchor _ AnchorFirstDiag - , ShapeAnchor _ AnchorSecondDiag] = False -checkOpened [ ShapeAnchor _ AnchorSecondDiag - , ShapeAnchor _ AnchorFirstDiag] = False -checkOpened (all isBullet -> True) = False -checkOpened - ( ShapeAnchor ap1 AnchorFirstDiag -- '/' - : ShapeAnchor ap2 AnchorSecondDiag -- '\' - : ShapeSegment s2 - : _) = checkRoundedCorners (==) s1 ap1 ap2 s2 - where s1 = mempty { _segEnd = ap1 } -checkOpened - ( ShapeAnchor ap1 AnchorSecondDiag -- '\' - : ShapeAnchor ap2 AnchorFirstDiag -- '/' - : ShapeSegment s2 - : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2 - where s1 = mempty { _segEnd = ap1 } -checkOpened _ = True - -checkOpenedShape :: Shape -> Bool -checkOpenedShape = checkOpened . shapeElements - -isShapePossible :: Shape -> Bool -isShapePossible shape - | shapeIsClosed shape = checkClosedShape shape - | otherwise = checkOpenedShape shape - +{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+module Text.AsciiDiagram.DiagramCleaner+ ( isShapePossible+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( Applicative, (<*>), (<$>) )+#endif++import Control.Applicative( liftA2 )+import Data.List( tails )+import Text.AsciiDiagram.Geometry+import Linear( V2( V2 )+ , (^-^)+ )++compareDirections :: Applicative f+ => (Int -> Int -> Bool) -> f Int -> f Int -> f Bool+compareDirections f = liftA2 diffSign+ where+ diffSign 0 0 = True+ diffSign aa bb = f aa bb++checkRoundedCorners :: (Int -> Int -> Bool)+ -> Segment -> Point -> Point -> Segment+ -> Bool+checkRoundedCorners f s1 ap1 ap2 s2 = okX && okY+ where+ V2 dirX dirY = ap2 ^-^ ap1+ fromS1 = _segEnd s1 ^-^ ap1+ fromS2 = _segStart s2 ^-^ ap2 ++ signDirs = signum <$> V2 dirY dirX++ V2 okX okY = (&&)+ <$> (compareDirections f signDirs (signum <$> fromS1))+ <*> (compareDirections f signDirs (signum <$> fromS2))++checkClosedShape :: Shape -> Bool+checkClosedShape shape = all checkClosed elements where+ elements =+ (++ shapeElements shape) <$> tails (shapeElements shape) ++++checkClosed :: [ShapeElement] -> Bool+-- dir fromS1 fromS1+-- ---> -----> <---- ^ 2 \--- 3+-- /\ | 1 /---- 0 0 ----/ 1 | | \+-- 1/ \2 dir | / / | dir dir | /+-- | | | \ \ | | 1 /--- 0+-- 0| |3 v 2 \---- 3 3 ----\ 2 v+-- -----> <----+-- fromS2 fromS2+-- +-- OK OK BAD BAD+checkClosed+ ( ShapeSegment s1+ : ShapeAnchor ap1 AnchorFirstDiag -- '/'+ : ShapeAnchor ap2 AnchorSecondDiag -- '\'+ : ShapeSegment s2+ : _) = checkRoundedCorners (==) s1 ap1 ap2 s2++-- dir fromS1 fromS1+-- ---> -----> <---- ^ 1 \--- 0+-- /\ | 2 /---- 3 3 ----/ 2 | | \+-- 2/ \1 dir | / / | dir dir | /+-- | | | \ \ | | 2 /--- 3+-- 3| |0 v 1 \---- 0 0 ----\ 1 v+-- -----> <----+-- fromS2 fromS2+-- +-- OK OK BAD BAD+checkClosed+ ( ShapeSegment s1+ : ShapeAnchor ap1 AnchorSecondDiag -- '\'+ : ShapeAnchor ap2 AnchorFirstDiag -- '/'+ : ShapeSegment s2+ : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2++checkClosed+ ( ShapeAnchor _ AnchorFirstDiag+ : ShapeAnchor _ AnchorSecondDiag+ : ShapeAnchor _ AnchorFirstDiag+ : ShapeAnchor _ AnchorSecondDiag+ : _) = False++checkClosed+ ( ShapeAnchor _ AnchorSecondDiag+ : ShapeAnchor _ AnchorFirstDiag+ : ShapeAnchor _ AnchorSecondDiag+ : ShapeAnchor _ AnchorFirstDiag+ : _) = False++checkClosed _ = True++isBullet :: ShapeElement -> Bool+isBullet (ShapeAnchor _ AnchorBullet) = True+isBullet _ = False++checkOpened :: [ShapeElement] -> Bool+checkOpened+ [ ShapeAnchor _ AnchorFirstDiag+ , ShapeAnchor _ AnchorSecondDiag] = False+checkOpened [ ShapeAnchor _ AnchorSecondDiag+ , ShapeAnchor _ AnchorFirstDiag] = False+checkOpened (all isBullet -> True) = False+checkOpened+ ( ShapeAnchor ap1 AnchorFirstDiag -- '/'+ : ShapeAnchor ap2 AnchorSecondDiag -- '\'+ : ShapeSegment s2+ : _) = checkRoundedCorners (==) s1 ap1 ap2 s2+ where s1 = mempty { _segEnd = ap1 }+checkOpened+ ( ShapeAnchor ap1 AnchorSecondDiag -- '\'+ : ShapeAnchor ap2 AnchorFirstDiag -- '/'+ : ShapeSegment s2+ : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2+ where s1 = mempty { _segEnd = ap1 }+checkOpened _ = True++checkOpenedShape :: Shape -> Bool+checkOpenedShape = checkOpened . shapeElements++isShapePossible :: Shape -> Bool+isShapePossible shape+ | shapeIsClosed shape = checkClosedShape shape+ | otherwise = checkOpenedShape shape+
src/Text/AsciiDiagram/Geometry.hs view
@@ -17,6 +17,7 @@ import Data.Monoid( Monoid( mappend, mempty )) #endif +import Data.Semigroup( Semigroup( .. ) ) import qualified Data.Set as S import qualified Data.Text as T import Linear( V2( .. ) ) @@ -97,10 +98,13 @@ kind = shows k draw = shows dr +instance Semigroup Segment where + (<>) (Segment a _ _ _) (Segment _ b k d) = + Segment a b k d + instance Monoid Segment where mempty = Segment 0 0 SegmentVertical SegmentSolid - mappend (Segment a _ _ _) (Segment _ b k d) = - Segment a b k d + mappend = (<>) -- | Describe a composant of shapes. Can -- be composed of anchors like "+*/\\" or
src/Text/AsciiDiagram/Graph.hs view
@@ -20,6 +20,7 @@ import Control.Applicative( (<$>) ) #endif +import Data.Semigroup( Semigroup( .. )) import Control.Monad( forM_, when ) import Control.Monad.State.Strict( execState ) import Control.Monad.State.Class( MonadState ) @@ -68,12 +69,15 @@ , _edges = mempty } -instance (Ord v) => Monoid (Graph v vi e) where - mempty = emptyGraph - mappend a b = Graph +instance Ord v => Semigroup (Graph v vi e) where + (<>) a b = Graph { _vertices = (mappend `on` _vertices) a b , _edges = (mappend `on` _edges) a b } + +instance (Ord v) => Monoid (Graph v vi e) where + mempty = emptyGraph + mappend = (<>) addVertice :: Ord v => v -> vinfo -> Graph v vinfo edgeInfo
src/Text/AsciiDiagram/Parser.hs view
@@ -1,224 +1,224 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} --- | Module in charge of finding the various segment --- in an ASCII text and the various anchors. -module Text.AsciiDiagram.Parser( ParsingState( .. ) - , parseText - , parseTextLines - , extractTextZones - , detectTagFromTextZone - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -import Control.Applicative( (<$>) ) -#endif - -import Control.Monad( foldM, when ) -import Control.Monad.State.Strict( State - , execState - , modify ) -import qualified Data.Foldable as F -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Traversable as TT -import qualified Data.Vector.Unboxed as VU -import Linear( V2( .. ) ) - -import Text.AsciiDiagram.Geometry - -isAnchor :: Char -> Bool -isAnchor c = c `VU.elem` anchors - where - anchors = VU.fromList "<>^vV+/\\*" - -anchorOfChar :: Char -> Anchor -anchorOfChar '+' = AnchorMulti -anchorOfChar '/' = AnchorFirstDiag -anchorOfChar '\\' = AnchorSecondDiag -anchorOfChar '>' = AnchorArrowRight -anchorOfChar '<' = AnchorArrowLeft -anchorOfChar '^' = AnchorArrowUp -anchorOfChar 'V' = AnchorArrowDown -anchorOfChar 'v' = AnchorArrowDown -anchorOfChar '*' = AnchorBullet -anchorOfChar _ = AnchorMulti - -isHorizontalLine :: Char -> Bool -isHorizontalLine c = c `VU.elem` horizontalLineElements - where - horizontalLineElements = VU.fromList "-=" - -isVerticalLine :: Char -> Bool -isVerticalLine c = c `VU.elem` verticalLineElements - where - verticalLineElements = VU.fromList ":|" - -isDashed :: Char -> Bool -isDashed c = case c of - ':' -> True - '=' -> True - _ -> False - - -data ParsingState = ParsingState - { anchorMap :: !(M.Map Point Anchor) - , segmentSet :: !(S.Set Segment) - , currentSegment :: !(Maybe Segment) - , styleLine :: [(Int, T.Text)] - } - deriving Show - -emptyParsingState :: ParsingState -emptyParsingState = ParsingState - { anchorMap = mempty - , segmentSet = mempty - , currentSegment = Nothing - , styleLine = mempty - } - -type Parsing = State ParsingState - -type LineNumber = Int - -addAnchor :: Point -> Char -> Parsing () -addAnchor p c = modify $ \s -> - s { anchorMap = M.insert p (anchorOfChar c) $ anchorMap s } - -addSegment :: Segment -> Parsing () -addSegment seg = modify $ \s -> - s { segmentSet = S.insert seg $ segmentSet s } - -addStyleLine :: (Int, T.Text) -> Parsing () -addStyleLine l = modify $ \s -> - s { styleLine = l : styleLine s } - -continueHorizontalSegment :: Point -> Parsing () -continueHorizontalSegment p = modify $ \s -> - s { currentSegment = Just . update $ currentSegment s } - where update Nothing = mempty { _segStart = p - , _segEnd = p - , _segKind = SegmentHorizontal - } - update (Just seg) = seg { _segEnd = p - , _segKind = SegmentHorizontal - } - -setHorizontaDashing :: Parsing () -setHorizontaDashing = modify $ \s -> - s { currentSegment = setDashed <$> currentSegment s } - where - setDashed seg = seg { _segDraw = SegmentDashed } - -stopHorizontalSegment :: Parsing () -stopHorizontalSegment = modify $ \s -> - s { segmentSet = inserter (currentSegment s) $ segmentSet s - , currentSegment = Nothing - } - where - inserter Nothing s = s - inserter (Just seg) s = S.insert seg s - -continueVerticalSegment :: Maybe Segment -> Point -> Parsing (Maybe Segment) -continueVerticalSegment Nothing p = return $ Just seg where - seg = mempty { _segStart = p - , _segEnd = p - , _segKind = SegmentVertical } -continueVerticalSegment (Just seg) p = - return $ Just seg { _segEnd = p, _segKind = SegmentVertical } - -stopVerticalSegment :: Maybe Segment -> Parsing (Maybe a) -stopVerticalSegment Nothing = return Nothing -stopVerticalSegment (Just seg) = do - addSegment seg - return Nothing - -parseLine :: [Maybe Segment] -> (LineNumber, T.Text) - -> Parsing [Maybe Segment] -parseLine prevSegments (n, T.stripPrefix ":::" -> Just txt) = do - addStyleLine (n, txt) - return prevSegments -parseLine prevSegments (lineNumber, txt) = do - ret <- TT.mapM go $ zip3 [0 ..] prevSegments stringLine - stopHorizontalSegment - return ret - where - stringLine = T.unpack txt ++ repeat ' ' - - go (columnNumber, vertical, c) | isHorizontalLine c = do - let point = V2 columnNumber lineNumber - continueHorizontalSegment point - when (isDashed c) $ setHorizontaDashing - stopVerticalSegment vertical - - go (columnNumber, vertical, c) | isVerticalLine c = do - let point = V2 columnNumber lineNumber - dashingSet seg - | isDashed c = seg { _segDraw = SegmentDashed } - | otherwise = seg - stopHorizontalSegment - fmap dashingSet <$> continueVerticalSegment vertical point - - go (columnNumber, vertical, c) | isAnchor c = do - let point = V2 columnNumber lineNumber - addAnchor point c - stopHorizontalSegment - stopVerticalSegment vertical - - go (_, vertical, _) = do - stopHorizontalSegment - stopVerticalSegment vertical - -maximumLineLength :: [T.Text] -> Int -maximumLineLength [] = 0 -maximumLineLength lst = maximum $ T.length <$> lst - -parseTextLines :: [T.Text] -> ParsingState -parseTextLines lst = flip execState emptyParsingState $ do - let initialLine = replicate (maximumLineLength lst) Nothing - lastVerticalLine <- foldM parseLine initialLine $ zip [0 ..] lst - mapM_ stopVerticalSegment lastVerticalLine - - --- | Extract the segment information of a given text. -parseText :: T.Text -> ParsingState -parseText = parseTextLines . T.lines - -zoneFromLine :: (Int, T.Text) -> [TextZone] -zoneFromLine (lineIndex, line) = eatSpaces 0 $ T.split (== ' ') line where - eatSpaces ix lst = case lst of - [] -> [] - ("":rest) -> eatSpaces (ix + 1) rest - _ -> createZoneFrom ix lst - - createZoneFrom ix = go ix where - go endIdx [] | ix == endIdx = [] - go _ [] = [TextZone (V2 ix lineIndex) $ T.drop ix line] - go endIdx ("":rest) = zone : eatSpaces (endIdx + 1) rest - where origin = V2 ix lineIndex - zone = TextZone origin . T.drop ix $ T.take endIdx line - go endIdx (x:xs) = go (endIdx + T.length x + 1) xs - -extractTextZones :: [T.Text] -> [TextZone] -extractTextZones = F.concatMap zoneFromLine . zip [0 ..] - -detectTagFromTextZone :: [TextZone] -> ([TextZone], [TextZone]) -detectTagFromTextZone zones = (concat foundTags, concat normalZones) where - (foundTags, normalZones) = unzip $ fmap findTag zones - - findTag zone@(TextZone (V2 x y) txt) = - case splitTags y x $ T.split (== ' ') txt of - ([], _) -> ([], [zone]) - tagsAndText -> tagsAndText - - splitTags _ _ [] = ([], []) - splitTags y ix (thisTxt : rest) - | tlength >= 3 && T.head thisTxt == '{' && T.last thisTxt == '}' = - (TextZone (V2 ix y) tagText: afterTags, normalTexts) - | otherwise = (afterTags, TextZone (V2 ix y) thisTxt : normalTexts) - where tlength = T.length thisTxt - tagText = T.init $ T.drop 1 thisTxt - (afterTags, normalTexts) = splitTags y (ix + tlength + 1) rest - +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+-- | Module in charge of finding the various segment+-- in an ASCII text and the various anchors.+module Text.AsciiDiagram.Parser( ParsingState( .. )+ , parseText+ , parseTextLines+ , extractTextZones+ , detectTagFromTextZone+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( (<$>) )+#endif++import Control.Monad( foldM, when )+import Control.Monad.State.Strict( State+ , execState+ , modify )+import qualified Data.Foldable as F+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Traversable as TT+import qualified Data.Vector.Unboxed as VU+import Linear( V2( .. ) )++import Text.AsciiDiagram.Geometry++isAnchor :: Char -> Bool+isAnchor c = c `VU.elem` anchors+ where+ anchors = VU.fromList "<>^vV+/\\*"+ +anchorOfChar :: Char -> Anchor+anchorOfChar '+' = AnchorMulti+anchorOfChar '/' = AnchorFirstDiag+anchorOfChar '\\' = AnchorSecondDiag+anchorOfChar '>' = AnchorArrowRight+anchorOfChar '<' = AnchorArrowLeft+anchorOfChar '^' = AnchorArrowUp+anchorOfChar 'V' = AnchorArrowDown+anchorOfChar 'v' = AnchorArrowDown+anchorOfChar '*' = AnchorBullet+anchorOfChar _ = AnchorMulti++isHorizontalLine :: Char -> Bool+isHorizontalLine c = c `VU.elem` horizontalLineElements+ where+ horizontalLineElements = VU.fromList "-="++isVerticalLine :: Char -> Bool+isVerticalLine c = c `VU.elem` verticalLineElements+ where+ verticalLineElements = VU.fromList ":|"++isDashed :: Char -> Bool+isDashed c = case c of+ ':' -> True+ '=' -> True+ _ -> False+++data ParsingState = ParsingState+ { anchorMap :: !(M.Map Point Anchor)+ , segmentSet :: !(S.Set Segment)+ , currentSegment :: !(Maybe Segment)+ , styleLine :: [(Int, T.Text)]+ }+ deriving Show++emptyParsingState :: ParsingState+emptyParsingState = ParsingState+ { anchorMap = mempty+ , segmentSet = mempty+ , currentSegment = Nothing+ , styleLine = mempty+ }++type Parsing = State ParsingState++type LineNumber = Int++addAnchor :: Point -> Char -> Parsing ()+addAnchor p c = modify $ \s ->+ s { anchorMap = M.insert p (anchorOfChar c) $ anchorMap s }++addSegment :: Segment -> Parsing ()+addSegment seg = modify $ \s ->+ s { segmentSet = S.insert seg $ segmentSet s }++addStyleLine :: (Int, T.Text) -> Parsing ()+addStyleLine l = modify $ \s ->+ s { styleLine = l : styleLine s }++continueHorizontalSegment :: Point -> Parsing ()+continueHorizontalSegment p = modify $ \s ->+ s { currentSegment = Just . update $ currentSegment s }+ where update Nothing = mempty { _segStart = p+ , _segEnd = p+ , _segKind = SegmentHorizontal+ }+ update (Just seg) = seg { _segEnd = p+ , _segKind = SegmentHorizontal+ }++setHorizontaDashing :: Parsing ()+setHorizontaDashing = modify $ \s ->+ s { currentSegment = setDashed <$> currentSegment s }+ where+ setDashed seg = seg { _segDraw = SegmentDashed }++stopHorizontalSegment :: Parsing ()+stopHorizontalSegment = modify $ \s ->+ s { segmentSet = inserter (currentSegment s) $ segmentSet s+ , currentSegment = Nothing+ }+ where+ inserter Nothing s = s+ inserter (Just seg) s = S.insert seg s++continueVerticalSegment :: Maybe Segment -> Point -> Parsing (Maybe Segment)+continueVerticalSegment Nothing p = return $ Just seg where+ seg = mempty { _segStart = p+ , _segEnd = p+ , _segKind = SegmentVertical }+continueVerticalSegment (Just seg) p =+ return $ Just seg { _segEnd = p, _segKind = SegmentVertical }++stopVerticalSegment :: Maybe Segment -> Parsing (Maybe a)+stopVerticalSegment Nothing = return Nothing+stopVerticalSegment (Just seg) = do+ addSegment seg+ return Nothing++parseLine :: [Maybe Segment] -> (LineNumber, T.Text)+ -> Parsing [Maybe Segment]+parseLine prevSegments (n, T.stripPrefix ":::" -> Just txt) = do+ addStyleLine (n, txt)+ return prevSegments+parseLine prevSegments (lineNumber, txt) = do+ ret <- TT.mapM go $ zip3 [0 ..] prevSegments stringLine+ stopHorizontalSegment+ return ret+ where+ stringLine = T.unpack txt ++ repeat ' '++ go (columnNumber, vertical, c) | isHorizontalLine c = do+ let point = V2 columnNumber lineNumber+ continueHorizontalSegment point+ when (isDashed c) $ setHorizontaDashing+ stopVerticalSegment vertical++ go (columnNumber, vertical, c) | isVerticalLine c = do+ let point = V2 columnNumber lineNumber+ dashingSet seg+ | isDashed c = seg { _segDraw = SegmentDashed }+ | otherwise = seg+ stopHorizontalSegment+ fmap dashingSet <$> continueVerticalSegment vertical point++ go (columnNumber, vertical, c) | isAnchor c = do+ let point = V2 columnNumber lineNumber+ addAnchor point c+ stopHorizontalSegment+ stopVerticalSegment vertical++ go (_, vertical, _) = do+ stopHorizontalSegment+ stopVerticalSegment vertical++maximumLineLength :: [T.Text] -> Int+maximumLineLength [] = 0+maximumLineLength lst = maximum $ T.length <$> lst++parseTextLines :: [T.Text] -> ParsingState+parseTextLines lst = flip execState emptyParsingState $ do+ let initialLine = replicate (maximumLineLength lst) Nothing+ lastVerticalLine <- foldM parseLine initialLine $ zip [0 ..] lst+ mapM_ stopVerticalSegment lastVerticalLine + ++-- | Extract the segment information of a given text.+parseText :: T.Text -> ParsingState+parseText = parseTextLines . T.lines++zoneFromLine :: (Int, T.Text) -> [TextZone]+zoneFromLine (lineIndex, line) = eatSpaces 0 $ T.split (== ' ') line where+ eatSpaces ix lst = case lst of+ [] -> []+ ("":rest) -> eatSpaces (ix + 1) rest+ _ -> createZoneFrom ix lst++ createZoneFrom ix = go ix where+ go endIdx [] | ix == endIdx = []+ go _ [] = [TextZone (V2 ix lineIndex) $ T.drop ix line]+ go endIdx ("":rest) = zone : eatSpaces (endIdx + 1) rest+ where origin = V2 ix lineIndex+ zone = TextZone origin . T.drop ix $ T.take endIdx line+ go endIdx (x:xs) = go (endIdx + T.length x + 1) xs++extractTextZones :: [T.Text] -> [TextZone]+extractTextZones = F.concatMap zoneFromLine . zip [0 ..]++detectTagFromTextZone :: [TextZone] -> ([TextZone], [TextZone])+detectTagFromTextZone zones = (concat foundTags, concat normalZones) where+ (foundTags, normalZones) = unzip $ fmap findTag zones++ findTag zone@(TextZone (V2 x y) txt) =+ case splitTags y x $ T.split (== ' ') txt of+ ([], _) -> ([], [zone])+ tagsAndText -> tagsAndText++ splitTags _ _ [] = ([], [])+ splitTags y ix (thisTxt : rest)+ | tlength >= 3 && T.head thisTxt == '{' && T.last thisTxt == '}' = + (TextZone (V2 ix y) tagText: afterTags, normalTexts)+ | otherwise = (afterTags, TextZone (V2 ix y) thisTxt : normalTexts)+ where tlength = T.length thisTxt+ tagText = T.init $ T.drop 1 thisTxt+ (afterTags, normalTexts) = splitTags y (ix + tlength + 1) rest+
src/Text/AsciiDiagram/Reconstructor.hs view
@@ -1,266 +1,266 @@-{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | This module will try to reconstruct closed shapes and --- lines from -- the set of anchors and segments. --- --- The output of this module may be duplicated, needing --- deduplication as post processing. --- --- This is mostly a depth first search in the set of anchors --- and segments. -module Text.AsciiDiagram.Reconstructor( reconstruct ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -import Control.Applicative( (<$>) ) -#endif - -import Control.Monad( when ) -import Control.Monad.State.Strict( execState ) -import Control.Monad.State.Class( get ) -import Data.Function( on ) -import Data.List( sortBy ) -import Data.Maybe( catMaybes ) -import qualified Data.Foldable as F -import qualified Data.Set as S -import qualified Data.Map as M -import qualified Data.Vector as V -import Linear( V2( .. ), (^+^), (^-^) ) - -import Text.AsciiDiagram.Geometry -import Text.AsciiDiagram.Graph -import Control.Lens - -{-import Debug.Trace-} -{-import Text.Printf-} -{-import Text.Groom-} - -data Direction - = LeftToRight - | RightToLeft - | TopToBottom - | BottomToTop - | NoDirection - deriving (Eq, Show) - - - -directionOfVector :: Vector -> Direction -directionOfVector (V2 0 n) - | n > 0 = TopToBottom - | otherwise = BottomToTop -directionOfVector (V2 n 0) - | n > 0 = LeftToRight - | otherwise = RightToLeft -directionOfVector _ = NoDirection - - - --- --- ****|**** --- *** | *** --- ** 1 ** --- * | * --- -----0----+---2------ --- * ^ * --- ** : ** --- *** : *** --- ****:**** --- --- --- ****|**** --- *** | *** --- ** 0 ** --- * | * --- =========>+---1------ --- * | * --- ** 2 ** --- *** | *** --- ****|**** --- --- --- ****|**** --- *** | *** --- ** 2 ** --- * | * --- -----1----+<========= --- * | * --- ** 0 ** --- *** | *** --- ****|**** --- --- --- ****:**** --- *** : *** --- ** : ** --- * V * --- -----2----+---0------ --- * | * --- ** 1 ** --- *** | *** --- ****|**** --- -vectorsForAnchor :: Anchor -> Direction -> [Vector] -vectorsForAnchor anchor dir = case (anchor, dir) of - (AnchorArrowUp, _) -> [down] - (AnchorArrowDown, _) -> [up] - (AnchorArrowLeft, _) -> [right] - (AnchorArrowRight, _) -> [left] - - (_, LeftToRight) -> [up, right, down, left] - (_, TopToBottom) -> [right, down, left, up] - (_, NoDirection) -> [right, down, left, up] - (_, RightToLeft) -> [down, left, up, right] - (_, BottomToTop) -> [left, up, right, down] - - where - left = V2 (-1) 0 - up = V2 0 (-1) - right = V2 1 0 - down = V2 0 1 - -directionVectorOf :: Point -> Point -> Vector -directionVectorOf a b = signum <$> a ^-^ b - -nextDirectionAfterAnchor :: Anchor -> Point -> Point -> [Point] -nextDirectionAfterAnchor anchor previousPoint anchorPosition = - [delta | delta <- deltas - , let nextPoint = anchorPosition ^+^ delta - , nextPoint /= previousPoint] - where - directionVector = directionVectorOf anchorPosition previousPoint - direction = directionOfVector directionVector - deltas = vectorsForAnchor anchor direction - -nextPointAfterAnchor :: Anchor -> Point -> Point -> [Point] -nextPointAfterAnchor anchor prev p = - (^+^ p) <$> nextDirectionAfterAnchor anchor prev p - -segmentManathanLength :: Segment -> Int -segmentManathanLength seg = x + y where - V2 x y = abs <$> _segEnd seg ^-^ _segStart seg - - -segmentDirectionMap :: S.Set Segment -> M.Map Point SegmentKind -segmentDirectionMap = S.fold go mempty where - go seg = M.insert (_segEnd seg) k . M.insert (_segStart seg) k - where - k = _segKind seg - -toGraph :: M.Map Point Anchor -> S.Set Segment - -> Graph Point ShapeElement Segment -toGraph anchors segs = execState graphCreator baseGraph where - baseGraph = graphOfVertices $ M.mapWithKey ShapeAnchor anchors - - segDirs = segmentDirectionMap segs - - graphCreator = do - F.traverse_ linkSegments segs - F.traverse_ linkAnchors $ M.assocs anchors - - linkOf p1 p2 | p1 < p2 = (p1, p2) - | otherwise = (p2, p1) - - linkAnchors (p, a) = F.traverse_ createLinks nextPoints where - nextPoints = nextPointAfterAnchor a (V2 (-1) (-1)) p - createLinks nextPoint = do - nextExists <- has (vertices . ix nextPoint) <$> get - let dirNext = nextPoint ^-^ p - nextP = M.lookup nextPoint anchors - nextS = M.lookup nextPoint segDirs - nextIsOk = case (nextP, nextS) of - (Just AnchorArrowUp, _) -> V2 0 (-1) == dirNext - (Just AnchorArrowDown, _) -> V2 0 1 == dirNext - (Just AnchorArrowLeft, _) -> V2 (-1) 0 == dirNext - (Just AnchorArrowRight, _) -> V2 1 0 == dirNext - (Just _, _) -> True - (Nothing, Nothing) -> True - (Nothing, Just SegmentHorizontal) -> - (abs <$> dirNext) == V2 1 0 - (Nothing, Just SegmentVertical) -> - (abs <$> dirNext) == V2 0 1 - - alreadyLinked <- has (edges . ix (linkOf p nextPoint)) <$> get - when (nextExists && nextIsOk && not alreadyLinked) $ - edges . at (linkOf p nextPoint) ?= mempty - - linkSegments seg | segmentManathanLength seg == 0 = do - vertices . at (_segStart seg ) ?= ShapeSegment seg - linkSegments seg@(Segment { _segStart = p1, _segEnd = p2 }) = do - vertices . at p1 ?= ShapeSegment seg - vertices . at p2 ?= ShapeSegment seg - edges . at (linkOf p1 p2) ?= seg - -findClockwisePossible :: S.Set Point -> Maybe Point -> Point - -> [Point] -findClockwisePossible adjacents Nothing p = - findClockwisePossible adjacents (Just p) p -findClockwisePossible adjacents (Just prev) p = - fmap snd $ sortBy (compare `on` fst) indexedAdjacents - where - -- don't care about specific direction, restrictions should have - -- been made during the construction of the graph. - dirArray = V.fromList $ nextDirectionAfterAnchor AnchorMulti prev p - zipIndex k = (V.elemIndex dir dirArray, k) - where dir = directionVectorOf k p - indexedAdjacents = - [(idx, nextPoint) - | (Just idx, nextPoint) <- zipIndex <$> S.elems adjacents - , nextPoint /= prev] - -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x - -instance PlanarVertice (V2 Int) where - getClockwiseMost adj prev = - safeHead . findClockwisePossible adj prev - getCounterClockwiseMost adj prev = - safeHead . reverse . findClockwisePossible adj prev - -dedupEqual :: Eq a => [a] -> [a] -dedupEqual [] = [] -dedupEqual (x:rest@(y:_)) | x == y = dedupEqual rest -dedupEqual (x:xs) = x : dedupEqual xs - - --- | Break filaments at multi anchor to ensure proper dashing --- of the segments. -breakFilaments :: Filament ShapeElement -> [Filament ShapeElement] -breakFilaments = go where - go lst = f : fs - where (f, fs) = breaker lst - - breaker [] = ([], []) - breaker [a@(ShapeAnchor _ AnchorMulti)] = ([a], []) - breaker (a@(ShapeAnchor _ AnchorMulti):xs) = ([a], (a:filamentRest):others) - where (filamentRest, others) = breaker xs - breaker (x:xs) = (x:filamentRest, others) - where (filamentRest, others) = breaker xs - - --- | Main call of the reconstruction function -reconstruct :: M.Map Point Anchor -> S.Set Segment - -> S.Set Shape -reconstruct anchors segments = - S.fromList $ fmap toShapes cycles - ++ concatMap toFilaments filaments - where - graph = toGraph anchors segments - (cycles, filaments) = extractAllPrimitives graph - - toElems = dedupEqual - . filter (/= ShapeSegment mempty) - . catMaybes - . fmap (`M.lookup` _vertices graph) - - toFilaments shapes = - [Shape piece False mempty mempty | piece <- breakFilaments $ toElems shapes] - - toShapes shapes = Shape (toElems shapes) True mempty mempty - +{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | This module will try to reconstruct closed shapes and+-- lines from -- the set of anchors and segments.+--+-- The output of this module may be duplicated, needing+-- deduplication as post processing.+--+-- This is mostly a depth first search in the set of anchors+-- and segments.+module Text.AsciiDiagram.Reconstructor( reconstruct ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( (<$>) )+#endif++import Control.Monad( when )+import Control.Monad.State.Strict( execState )+import Control.Monad.State.Class( get )+import Data.Function( on )+import Data.List( sortBy )+import Data.Maybe( catMaybes )+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V+import Linear( V2( .. ), (^+^), (^-^) )++import Text.AsciiDiagram.Geometry+import Text.AsciiDiagram.Graph+import Control.Lens++{-import Debug.Trace-}+{-import Text.Printf-}+{-import Text.Groom-}++data Direction+ = LeftToRight+ | RightToLeft+ | TopToBottom+ | BottomToTop+ | NoDirection+ deriving (Eq, Show)++++directionOfVector :: Vector -> Direction+directionOfVector (V2 0 n)+ | n > 0 = TopToBottom+ | otherwise = BottomToTop+directionOfVector (V2 n 0)+ | n > 0 = LeftToRight+ | otherwise = RightToLeft+directionOfVector _ = NoDirection++++--+-- ****|****+-- *** | ***+-- ** 1 **+-- * | *+-- -----0----+---2------+-- * ^ *+-- ** : **+-- *** : ***+-- ****:****+--+--+-- ****|****+-- *** | ***+-- ** 0 **+-- * | *+-- =========>+---1------+-- * | *+-- ** 2 **+-- *** | ***+-- ****|****+--+--+-- ****|****+-- *** | ***+-- ** 2 **+-- * | *+-- -----1----+<=========+-- * | *+-- ** 0 **+-- *** | ***+-- ****|****+--+--+-- ****:****+-- *** : ***+-- ** : **+-- * V *+-- -----2----+---0------+-- * | *+-- ** 1 **+-- *** | ***+-- ****|****+--+vectorsForAnchor :: Anchor -> Direction -> [Vector]+vectorsForAnchor anchor dir = case (anchor, dir) of+ (AnchorArrowUp, _) -> [down]+ (AnchorArrowDown, _) -> [up]+ (AnchorArrowLeft, _) -> [right]+ (AnchorArrowRight, _) -> [left]++ (_, LeftToRight) -> [up, right, down, left]+ (_, TopToBottom) -> [right, down, left, up]+ (_, NoDirection) -> [right, down, left, up]+ (_, RightToLeft) -> [down, left, up, right]+ (_, BottomToTop) -> [left, up, right, down]++ where+ left = V2 (-1) 0+ up = V2 0 (-1)+ right = V2 1 0+ down = V2 0 1++directionVectorOf :: Point -> Point -> Vector+directionVectorOf a b = signum <$> a ^-^ b++nextDirectionAfterAnchor :: Anchor -> Point -> Point -> [Point]+nextDirectionAfterAnchor anchor previousPoint anchorPosition =+ [delta | delta <- deltas+ , let nextPoint = anchorPosition ^+^ delta+ , nextPoint /= previousPoint]+ where+ directionVector = directionVectorOf anchorPosition previousPoint+ direction = directionOfVector directionVector+ deltas = vectorsForAnchor anchor direction++nextPointAfterAnchor :: Anchor -> Point -> Point -> [Point]+nextPointAfterAnchor anchor prev p =+ (^+^ p) <$> nextDirectionAfterAnchor anchor prev p++segmentManathanLength :: Segment -> Int+segmentManathanLength seg = x + y where+ V2 x y = abs <$> _segEnd seg ^-^ _segStart seg+++segmentDirectionMap :: S.Set Segment -> M.Map Point SegmentKind+segmentDirectionMap = S.fold go mempty where+ go seg = M.insert (_segEnd seg) k . M.insert (_segStart seg) k+ where+ k = _segKind seg++toGraph :: M.Map Point Anchor -> S.Set Segment+ -> Graph Point ShapeElement Segment+toGraph anchors segs = execState graphCreator baseGraph where+ baseGraph = graphOfVertices $ M.mapWithKey ShapeAnchor anchors++ segDirs = segmentDirectionMap segs++ graphCreator = do+ F.traverse_ linkSegments segs+ F.traverse_ linkAnchors $ M.assocs anchors++ linkOf p1 p2 | p1 < p2 = (p1, p2)+ | otherwise = (p2, p1)++ linkAnchors (p, a) = F.traverse_ createLinks nextPoints where+ nextPoints = nextPointAfterAnchor a (V2 (-1) (-1)) p+ createLinks nextPoint = do+ nextExists <- has (vertices . ix nextPoint) <$> get+ let dirNext = nextPoint ^-^ p+ nextP = M.lookup nextPoint anchors+ nextS = M.lookup nextPoint segDirs+ nextIsOk = case (nextP, nextS) of+ (Just AnchorArrowUp, _) -> V2 0 (-1) == dirNext+ (Just AnchorArrowDown, _) -> V2 0 1 == dirNext+ (Just AnchorArrowLeft, _) -> V2 (-1) 0 == dirNext+ (Just AnchorArrowRight, _) -> V2 1 0 == dirNext+ (Just _, _) -> True+ (Nothing, Nothing) -> True+ (Nothing, Just SegmentHorizontal) ->+ (abs <$> dirNext) == V2 1 0+ (Nothing, Just SegmentVertical) ->+ (abs <$> dirNext) == V2 0 1++ alreadyLinked <- has (edges . ix (linkOf p nextPoint)) <$> get+ when (nextExists && nextIsOk && not alreadyLinked) $+ edges . at (linkOf p nextPoint) ?= mempty++ linkSegments seg | segmentManathanLength seg == 0 = do+ vertices . at (_segStart seg ) ?= ShapeSegment seg+ linkSegments seg@(Segment { _segStart = p1, _segEnd = p2 }) = do+ vertices . at p1 ?= ShapeSegment seg+ vertices . at p2 ?= ShapeSegment seg+ edges . at (linkOf p1 p2) ?= seg++findClockwisePossible :: S.Set Point -> Maybe Point -> Point+ -> [Point]+findClockwisePossible adjacents Nothing p =+ findClockwisePossible adjacents (Just p) p+findClockwisePossible adjacents (Just prev) p =+ fmap snd $ sortBy (compare `on` fst) indexedAdjacents+ where+ -- don't care about specific direction, restrictions should have+ -- been made during the construction of the graph.+ dirArray = V.fromList $ nextDirectionAfterAnchor AnchorMulti prev p+ zipIndex k = (V.elemIndex dir dirArray, k)+ where dir = directionVectorOf k p+ indexedAdjacents =+ [(idx, nextPoint)+ | (Just idx, nextPoint) <- zipIndex <$> S.elems adjacents+ , nextPoint /= prev]++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x++instance PlanarVertice (V2 Int) where+ getClockwiseMost adj prev =+ safeHead . findClockwisePossible adj prev+ getCounterClockwiseMost adj prev =+ safeHead . reverse . findClockwisePossible adj prev++dedupEqual :: Eq a => [a] -> [a]+dedupEqual [] = []+dedupEqual (x:rest@(y:_)) | x == y = dedupEqual rest+dedupEqual (x:xs) = x : dedupEqual xs+++-- | Break filaments at multi anchor to ensure proper dashing+-- of the segments.+breakFilaments :: Filament ShapeElement -> [Filament ShapeElement]+breakFilaments = go where+ go lst = f : fs+ where (f, fs) = breaker lst++ breaker [] = ([], [])+ breaker [a@(ShapeAnchor _ AnchorMulti)] = ([a], [])+ breaker (a@(ShapeAnchor _ AnchorMulti):xs) = ([a], (a:filamentRest):others)+ where (filamentRest, others) = breaker xs+ breaker (x:xs) = (x:filamentRest, others)+ where (filamentRest, others) = breaker xs+++-- | Main call of the reconstruction function+reconstruct :: M.Map Point Anchor -> S.Set Segment+ -> S.Set Shape+reconstruct anchors segments =+ S.fromList $ fmap toShapes cycles + ++ concatMap toFilaments filaments+ where+ graph = toGraph anchors segments+ (cycles, filaments) = extractAllPrimitives graph++ toElems = dedupEqual+ . filter (/= ShapeSegment mempty)+ . catMaybes+ . fmap (`M.lookup` _vertices graph)++ toFilaments shapes =+ [Shape piece False mempty mempty | piece <- breakFilaments $ toElems shapes] ++ toShapes shapes = Shape (toElems shapes) True mempty mempty+
src/Text/AsciiDiagram/SvgRender.hs view
@@ -1,537 +1,537 @@-{-# 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 - -{-import Debug.Trace-} -{-import Text.Groom-} - --- | Simple type describing the grid size used during render. -data GridSize = GridSize - { _gridCellWidth :: !Float -- ^ Width of a cell (in pixel) - , _gridCellHeight :: !Float -- ^ Height of a cell (in pixel) - - -- | Coefficient used to space adjacent shapes, set to 0 - -- if you want to remove space between them. - , _gridShapeContraction :: !Float - } - deriving (Eq, Show) - --- | Default grid size used in the simple render functions -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 - - --- > --- > ^ 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 :: (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 - - --- | Transform an Ascii diagram to a SVG document which --- can be saved or converted to an image. -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] - --- | Transform an Ascii diagram to a SVG document which --- can be saved or converted to an image, with a customizable --- grid size. -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 = "" - } - +{-# 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++{-import Debug.Trace-}+{-import Text.Groom-}++-- | Simple type describing the grid size used during render.+data GridSize = GridSize+ { _gridCellWidth :: !Float -- ^ Width of a cell (in pixel)+ , _gridCellHeight :: !Float -- ^ Height of a cell (in pixel)++ -- | Coefficient used to space adjacent shapes, set to 0+ -- if you want to remove space between them.+ , _gridShapeContraction :: !Float+ }+ deriving (Eq, Show)++-- | Default grid size used in the simple render functions+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+++-- >+-- > ^ 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 :: (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+++-- | Transform an Ascii diagram to a SVG document which+-- can be saved or converted to an image.+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]++-- | Transform an Ascii diagram to a SVG document which+-- can be saved or converted to an image, with a customizable+-- grid size.+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 = ""+ }+