diff --git a/asciidiagram.cabal b/asciidiagram.cabal --- a/asciidiagram.cabal +++ b/asciidiagram.cabal @@ -1,10 +1,10 @@ -- Initial hitaa.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: asciidiagram -version: 1.2 +version: 1.3 synopsis: Pretty rendering of Ascii diagram into svg or png. description: - Asciidiagram Ascii art diagram like this: + Transform Ascii art diagram like this: . @ , \/---------+ @@ -40,17 +40,19 @@ Source-Repository this Type: git Location: git://github.com/Twinside/asciidiagram.git - Tag: v1.2 + Tag: v1.3 library ghc-options: -O2 -Wall exposed-modules: Text.AsciiDiagram other-modules: Text.AsciiDiagram.DiagramCleaner + , Text.AsciiDiagram.DefaultContext , Text.AsciiDiagram.Geometry , Text.AsciiDiagram.Graph , Text.AsciiDiagram.Parser , Text.AsciiDiagram.Reconstructor + , Text.AsciiDiagram.BoundingBoxEstimation , Text.AsciiDiagram.SvgRender -- containers >= 0.5.2.1 for Set.elemAt @@ -62,7 +64,7 @@ , containers >= 0.5 , mtl >= 2.1 && < 2.3 , lens >= 4.6 && < 5.0 - , svg-tree >= 0.4.1 && < 0.5 + , svg-tree >= 0.5 && < 0.6 , rasterific-svg >= 0.3 && < 0.4 , FontyFruity >= 0.5 && < 0.6 , JuicyPixels >= 3.2 diff --git a/docimages/arrows.svg b/docimages/arrows.svg --- a/docimages/arrows.svg +++ b/docimages/arrows.svg @@ -1,5 +1,5 @@ - + + + + + + + + + + + + + + - - - - + < > v ^ + + + + - - - + + + - - - + + + - - - + + + - < > v ^ diff --git a/docimages/baseExample.svg b/docimages/baseExample.svg --- a/docimages/baseExample.svg +++ b/docimages/baseExample.svg @@ -1,5 +1,5 @@ - + + + + + + + + + + + + + + - - + + + + + + + + + + + + ASCII + + - - - - - - - - - + + + Diagram - ASCII - Diagram - diff --git a/docimages/bulletTest.svg b/docimages/bulletTest.svg --- a/docimages/bulletTest.svg +++ b/docimages/bulletTest.svg @@ -9,30 +9,54 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - - - - - - - + * * + + - * * + + + + + + diff --git a/docimages/cabalSchema.svg b/docimages/cabalSchema.svg --- a/docimages/cabalSchema.svg +++ b/docimages/cabalSchema.svg @@ -9,34 +9,62 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - - - - - - - - + + + - - + + - + - ASCII - Diagram + + + ASCII + + + + + + + + Diagram + diff --git a/docimages/complexClosed.svg b/docimages/complexClosed.svg --- a/docimages/complexClosed.svg +++ b/docimages/complexClosed.svg @@ -9,19 +9,43 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - + + diff --git a/docimages/curvedCorner.svg b/docimages/curvedCorner.svg --- a/docimages/curvedCorner.svg +++ b/docimages/curvedCorner.svg @@ -9,29 +9,53 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - - - - - - - - - . - . - . + . + . + . + + + + + + + + + diff --git a/docimages/dashed_lines.svg b/docimages/dashed_lines.svg --- a/docimages/dashed_lines.svg +++ b/docimages/dashed_lines.svg @@ -9,22 +9,46 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - - - - + + + + + diff --git a/docimages/dashingClosed.svg b/docimages/dashingClosed.svg --- a/docimages/dashingClosed.svg +++ b/docimages/dashingClosed.svg @@ -9,21 +9,45 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - - - + + + + diff --git a/docimages/deepStyleExample.svg b/docimages/deepStyleExample.svg new file mode 100644 --- /dev/null +++ b/docimages/deepStyleExample.svg @@ -0,0 +1,171 @@ + + + + + + + + + + + + + + + + + + + + + + + . + e0 + . + + + + + + + + + + + s3 + + + + s2 + + + + + + + + + + + + + + + + + + + + + + + s1 + e1 + e2 + + + + o5 + + + + i4 + + + + s10 + + + + s20 + + + + + + + + + + + + + + + + + + + + + + s100 + e1 + ealarm + eReset + + + + s50 + + diff --git a/docimages/shapeExample.svg b/docimages/shapeExample.svg new file mode 100644 --- /dev/null +++ b/docimages/shapeExample.svg @@ -0,0 +1,77 @@ + + + + + + + + + + + + + + + + + + + + + + + + + circle + + + + document + + + + io + + + + storage + + diff --git a/docimages/simple_lines.svg b/docimages/simple_lines.svg --- a/docimages/simple_lines.svg +++ b/docimages/simple_lines.svg @@ -9,22 +9,46 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } +.arrow_head { + fill: #000000; + stroke: none; +} + + + + + + + + + + + + + - - - - - + + + + + diff --git a/docimages/styleExample.svg b/docimages/styleExample.svg --- a/docimages/styleExample.svg +++ b/docimages/styleExample.svg @@ -9,50 +9,80 @@ } .filled_shape { fill: url(#shape_light); + stroke: #000000; + stroke-width: 1.0px; } +.line_element { + fill: none; + stroke: #000000; + stroke-width: 1.0px; +} .bullet { stroke-width: 1.0px; fill: #FFFFFF; stroke: #000000; } -.dst { - stroke: #FFAAAA; - stroke-width: 3.0px; +.arrow_head { + fill: #000000; + stroke: none; } .src { fill: #AAAAFF; } +.dst { + stroke: #FFAAAA; + stroke-width: 3.0px; +} + + + + + + + + + + + + + - - - - - + + + - - - - + + + + - - - - + + + Source - - - + + + Dest - Source - op1 - - op2 - Dest - + + + + + + + + + + op2 + + + + op1 + diff --git a/exec-src/asciidiagram.hs b/exec-src/asciidiagram.hs --- a/exec-src/asciidiagram.hs +++ b/exec-src/asciidiagram.hs @@ -17,6 +17,7 @@ , replaceExtension , takeExtension ) +import Graphics.Svg( Document, loadSvgFile, saveXmlFile ) import Graphics.Rasterific.Svg( loadCreateFontCache ) import Graphics.Text.TrueType( FontCache ) import Codec.Picture( writePng ) @@ -32,32 +33,59 @@ , 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 - { _inputFile :: !FilePath - , _outputFile :: !FilePath - , _verbose :: !Bool - , _format :: !(Maybe Format) + { _workingMode :: !Mode + , _verbose :: !Bool + , _withLibrary :: !(Maybe FilePath) + , _format :: !(Maybe Format) } data Format = FormatSvg | FormatPng | FormatPdf -argParser :: Parser Options -argParser = Options - <$> ( argument str - (metavar "INPUTFILE" - <> help "Text file of the Ascii diagram to parse.")) - <*> ( argument str +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 "" ) + <|> 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)") @@ -88,39 +116,63 @@ tempDir <- getTemporaryDirectory loadCreateFontCache $ tempDir "asciidiagram-fonty-fontcache" -runConversion :: Options -> IO () -runConversion opt = do - verbose . putStrLn $ "Loading file " ++ _inputFile opt - inputData <- STIO.readFile $ _inputFile opt + +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 - format = _format opt <|> (pure . formatOfOuputFilename $ _outputFile opt) + svg = svgOfDiagramAtSize defaultGridSize lib diag + format = _format opt <|> (pure $ formatOfOuputFilename outputFile) case format of - Nothing -> saveDoc diag - Just FormatSvg -> saveDoc diag - Just FormatPng -> savePng diag - Just FormatPdf -> savePdf diag + Nothing -> saveDoc svg + Just FormatSvg -> saveDoc svg + Just FormatPng -> savePng svg + Just FormatPdf -> savePdf svg where verbose = when $ _verbose opt - saveDoc diag = do - verbose . putStrLn $ "Writing SVG file " ++ _outputFile opt - saveAsciiDiagramAsSvg (savingPath "svg") diag + saveDoc svg = do + verbose . putStrLn $ "Writing SVG file " ++ outputFile + saveXmlFile (savingPath "svg") svg - savingPath ext = case _outputFile opt of - "" -> replaceExtension (_inputFile opt) ext + savingPath ext = case outputFile of + "" -> replaceExtension inputFile ext p -> p - savePdf diag = do + savePdf svg = do cache <- getFontCache $ _verbose opt - verbose . putStrLn $ "Writing PDF file " ++ _outputFile opt - pdf <- pdfOfDiagram cache diag + verbose . putStrLn $ "Writing PDF file " ++ outputFile + (pdf, _) <- pdfOfSvgDocument cache Nothing 96 svg LB.writeFile (savingPath "pdf") pdf - savePng diag = do + savePng svg = do cache <- getFontCache $ _verbose opt - verbose . putStrLn $ "Writing PNG file " ++ _outputFile opt - img <- imageOfDiagram cache diag + 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 >>= runConversion +main = execParser progOptions >>= \opts -> + case _workingMode opts of + Convert (i, o) -> runConversion opts i o + DumpLibrary p -> dumpLibrary p diff --git a/src/Text/AsciiDiagram.hs b/src/Text/AsciiDiagram.hs --- a/src/Text/AsciiDiagram.hs +++ b/src/Text/AsciiDiagram.hs @@ -15,7 +15,7 @@ -- +---------+ | | -- |{flat} | +--+------\/ -- \\---*-----\/\<=======\/ --- ::: .flat { fill: #DDD; } +-- ::: .flat .filled_shape { fill: #DDD; } -- @ -- <> -- @@ -52,9 +52,12 @@ -- ** Styles -- $styledoc - -- * Usage example - -- $example + -- ** Hierarchical styles + -- $hierarchicalDoc + -- ** Shapes + -- $shapeDoc + -- * Functions svgOfDiagram , parseAsciiDiagram @@ -70,6 +73,8 @@ , imageOfDiagramAtSize , pdfOfDiagramAtSize + -- * Library + , defaultLibrary -- * Document description , Diagram( .. ) @@ -90,7 +95,6 @@ import Data.Monoid( (<>)) import Control.Monad( forM_ ) import Control.Monad.ST( runST ) -import Control.Monad.State.Strict( runState, put, get ) import Data.Function( on ) import Data.List( partition, sortBy ) import qualified Data.ByteString.Lazy as LB @@ -154,27 +158,15 @@ VU.unsafeFreeze emptyBoard -data HorizontalPoints - = WithHorizontalSegments - | WithoutHorizontalSegments - deriving Eq -allowsHorizontal :: HorizontalPoints -> Bool -allowsHorizontal WithHorizontalSegments = True -allowsHorizontal WithoutHorizontalSegments = False - -pointsOfShape :: F.Foldable f => HorizontalPoints -> f Shape -> [Point] -pointsOfShape horizInfo = F.concatMap (F.concatMap go . shapeElements) where - withHorizontal = allowsHorizontal horizInfo - +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]] - | withHorizontal && sy == ey && sx >= ex = - [V2 xx sy | xx <- [ex .. sx]] - | withHorizontal && sy == ey = - [V2 xx sy | xx <- [sx .. ex]] + | sy == ey && sx >= ex = [V2 xx sy | xx <- [ex .. sx]] + | sy == ey = [V2 xx sy | xx <- [sx .. ex]] | otherwise = [] cleanLines :: [Int] -> CharBoard -> CharBoard @@ -189,8 +181,8 @@ 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 WithHorizontalSegments shapes] + where + toSet = [(x + y * _boardWidth board, ' ') | V2 x y <- pointsOfShape shapes] pointComp :: Point -> Point -> Ordering @@ -198,8 +190,29 @@ EQ -> compare x1 x2 a -> a -rangesOfShapes :: Shape -> [(Point, Point)] -rangesOfShapes shape = pairAssoc sortedPoints +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 [_] = [] @@ -207,56 +220,98 @@ | y1 == y2 = (p1, p2) : pairAssoc rest | otherwise = pairAssoc lst - sortedPoints = sortBy pointComp - $ pointsOfShape WithoutHorizontalSegments [shape] + sortedPoints = sortBy pointComp $ featuresOfClosedShape shape -associateTags :: [Shape] -> [TextZone] -> ([Shape], [TextZone]) -associateTags shapes tagZones = - expandTag $ runState (mapM go shapes) sortedZones where +class RangeDecomposable a where + rangesOf :: a -> [(Point, Point)] - sortedZones = - sortBy (pointComp `on` _textZoneOrigin) tagZones +instance RangeDecomposable Shape where + rangesOf s + | shapeIsClosed s = rangesOfClosedShape s + | otherwise = rangesOfOpenedShape s - isInRange (V2 px py) (V2 x1 y1, V2 x2 y2) = - py == y1 && py == y2 && x1 < px && px < x2 +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 - expandTag (s, zones) = (s, fmap expander zones) where - expander t = t { _textZoneContent = "{" <> _textZoneContent t <> "}" } +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) - insertAlls shape = - foldr S.insert (shapeTags shape) . fmap _textZoneContent +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] - go shape | not $ shapeIsClosed shape = return shape - go shape = do - zones <- get +hierarchise :: [Shape] -> [TextZone] -> [TextZone] -> [Element] +hierarchise shapes allTexts = finalize . go areaSortedShapes allTexts where + areaSortedShapes = sortByArea shapes - let ranges = rangesOfShapes shape - isInShape TextZone { _textZoneOrigin = orig } = - any (isInRange orig) ranges - (inRanges, other) = partition isInShape zones + finalize (topShapes, topText, _topTags) = + (ElemShape <$> topShapes) <> (ElemText <$> topText) - put other + 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 - return shape { shapeTags = insertAlls shape inRanges } + (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 - { _diagramShapes = S.fromList taggedShape - , _diagramTexts = zones ++ unusedTags + { _diagramElements = S.fromList allElements , _diagramCellWidth = maximum $ fmap T.length textLines , _diagramCellHeight = length textLines - length styleLines - , _diagramStyles = styleLines + , _diagramStyles = reverse styleLines } where textLines = T.lines content - (taggedShape, unusedTags) = associateTags (S.toList validShapes) tags - - (tags, zones) = detectTagFromTextZone - $ extractTextZones shapeCleanedText + 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 = @@ -279,7 +334,7 @@ -- a SVG file on disk with a customized grid size. saveAsciiDiagramAsSvgAtSize :: FilePath -> GridSize -> Diagram -> IO () saveAsciiDiagramAsSvgAtSize fileName gridSize = - saveXmlFile fileName . svgOfDiagramAtSize 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 @@ -293,7 +348,8 @@ -- font files used in the document. imageOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO (Image PixelRGBA8) imageOfDiagramAtSize cache gridSize = - fmap fst . renderSvgDocument cache Nothing 96 . svgOfDiagramAtSize 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. @@ -305,20 +361,40 @@ -- 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 + 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; } +-- @ +-- <> +-- + -- $linesdoc -- The basic syntax of asciidiagrams is made of lines made out\nof \'-\' and \'|\' characters. They can be connected with anchors\nlike \'+\' (direct connection) or \'\\\' and \'\/\' (smooth connections)\n -- --- >----- --- > ------- --- > --- >| | --- >| | --- >| \---- --- >| --- >+----- --- +-- +-- @ +-- ----- +-- ------- +-- +-- | | +-- | | +-- | \\---- +-- | +-- +----- +-- @ -- <> -- -- You can use dashed lines by using ':' for vertical lines or '=' for\nhorizontal lines. @@ -445,13 +521,102 @@ -- The generated geometry also possess some predefined class -- which are overidable: -- --- * `dashed_elem` is applyied on every dashed element. +-- * "dashed_elem" is applied on every dashed element. -- --- * `filled_shape` is applyied on every closed shape. +-- * "filled_shape" is applied on every closed shape. -- --- * `bullet` on every bullet placed on a shape or line. +-- * "arrow_head" is applied on arrow head. -- --- * `line_element` on every line element, this include the 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; } +-- @ +-- <> +-- +-- 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; } +-- @ +-- <> +-- +-- 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`. -- diff --git a/src/Text/AsciiDiagram/BoundingBoxEstimation.hs b/src/Text/AsciiDiagram/BoundingBoxEstimation.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/BoundingBoxEstimation.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE CPP #-} +module Text.AsciiDiagram.BoundingBoxEstimation where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>) + , pure + ) +import Data.Foldable( foldMap ) +import Data.Monoid( Monoid( mappend, mempty ) + , mconcat + ) +#endif + +import Data.Monoid( (<>) ) +import Linear( V2( .. ) + , (^+^) + , (^-^) + ) + +import Graphics.Svg.Types + +data BoundingBox = BoundingBox + { _boundingLow :: !RPoint + , _boundingHight :: !RPoint + } + deriving (Eq, Show) + +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) + +toEstimatedLength :: Number -> Coord +toEstimatedLength n = case toUserUnit 96 n of + Num p -> p + _ -> 0 + +toEstimatedPoint :: (Number, Number) -> RPoint +toEstimatedPoint (a, b) = V2 a' b' where + a' = toEstimatedLength a + b' = toEstimatedLength b + +toB :: RPoint -> BoundingBox +toB p = BoundingBox p p + +class WithBoundingBox a where + boundingBoxOf :: a -> BoundingBox + +instance WithBoundingBox PolyLine where + boundingBoxOf = foldMap toB . _polyLinePoints + +instance WithBoundingBox Polygon where + boundingBoxOf = foldMap toB . _polygonPoints + +instance WithBoundingBox Line where + boundingBoxOf (Line _ p1 p2) = + toB (toEstimatedPoint p1) <> toB (toEstimatedPoint p2) + +instance WithBoundingBox Rectangle where + boundingBoxOf (Rectangle _ base w h _) = + toB base' <> toB (base' ^+^ toEstimatedPoint (w, h)) + where base' = toEstimatedPoint base + +pointOfPath :: PathCommand -> [RPoint] +pointOfPath c = case c of + MoveTo _ l -> l + LineTo _ l -> l + HorizontalTo _ _ -> mempty + VerticalTo _ _ -> mempty + CurveTo _ l -> mconcat [[a, b, cc] | (a, b, cc) <- l] + SmoothCurveTo _ l -> mconcat [[a, b] | (a, b) <- l] + QuadraticBezier _ l -> mconcat [[a, b] | (a, b) <- l] + SmoothQuadraticBezierCurveTo _ l -> l + EllipticalArc _ _ -> mempty + EndPath -> mempty + +instance WithBoundingBox Path where + boundingBoxOf (Path _ p) = foldMap (foldMap toB . pointOfPath) p + +instance WithBoundingBox a => WithBoundingBox (Group a) where + boundingBoxOf (Group _ child _ _) = foldMap boundingBoxOf child + +instance WithBoundingBox a => WithBoundingBox (Symbol a) where + boundingBoxOf (Symbol g) = boundingBoxOf g + +instance WithBoundingBox Text where + boundingBoxOf = boundingBoxOf . _textRoot + +instance WithBoundingBox TextSpan where + boundingBoxOf = boundingBoxOf . _spanInfo + +instance WithBoundingBox TextInfo where + boundingBoxOf t = case (_textInfoX t, _textInfoY t) of + (x1:_, y1:_) -> toB (toEstimatedPoint (x1, y1)) + _ -> mempty + +instance WithBoundingBox Circle where + boundingBoxOf (Circle _ center rad) = BoundingBox (c ^-^ r) (c ^+^ r) + where + c = toEstimatedPoint center + r = pure $ toEstimatedLength rad + +instance WithBoundingBox Ellipse where + boundingBoxOf (Ellipse _ center xrad yrad) = BoundingBox (c ^-^ r) (c ^+^ r) + where + c = toEstimatedPoint center + r = V2 (toEstimatedLength xrad) (toEstimatedLength yrad) + +instance WithBoundingBox Tree where + boundingBoxOf t = case t of + None -> mempty + UseTree _ _ -> mempty + PathTree p -> boundingBoxOf p + CircleTree c -> boundingBoxOf c + PolyLineTree pl -> boundingBoxOf pl + PolygonTree po -> boundingBoxOf po + EllipseTree e -> boundingBoxOf e + LineTree l -> boundingBoxOf l + RectangleTree r -> boundingBoxOf r + TextTree _ txt -> boundingBoxOf txt + ImageTree _ -> mempty + GroupTree g -> boundingBoxOf g + SymbolTree s -> boundingBoxOf s + diff --git a/src/Text/AsciiDiagram/DefaultContext.hs b/src/Text/AsciiDiagram/DefaultContext.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/DefaultContext.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.AsciiDiagram.DefaultContext + ( defaultCss + , defaultCssRules + , defaultDefinitions + ) where + +import Control.Monad.State.Strict( execState ) +import Data.Monoid( (<>) ) + +import Graphics.Svg.Types ( HasDrawAttributes( .. ), drawAttr ) +import Graphics.Svg( cssRulesOfText ) + +import Codec.Picture( PixelRGBA8( PixelRGBA8 ) ) +import qualified Graphics.Svg.Types as Svg +import qualified Graphics.Svg.CssTypes as Css +import qualified Data.Map as M +import qualified Data.Text as T +import Text.Printf +import Linear( V2( .. ) ) +import Control.Lens( (.=), (.~), (&) ) + + +defaultCss :: Float -> T.Text +defaultCss textSize = T.pack $ printf + ("\n" <> + "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <> + ".dashed_elem { stroke-dasharray: 4, 3 }\n" <> + ".filled_shape { fill: url(#shape_light); stroke: black; stroke-width: 1px; }\n" <> + ".line_element { fill: none; stroke: black; stroke-width: 1px; }\n" <> + ".bullet { stroke-width: 1px; fill: white; stroke: black }\n" <> + ".arrow_head { fill: black; stroke: none; }\n" + ) + (2 + floor textSize :: Int) + +defaultCssRules :: Float -> [Css.CssRule] +defaultCssRules = cssRulesOfText . defaultCss + +lightShapeGradient :: Svg.Element +lightShapeGradient = Svg.ElementLinearGradient $ + Svg.defaultSvg + { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0) + , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1) + , Svg._linearGradientStops = + [ Svg.GradientStop 0 $ PixelRGBA8 245 245 245 255 + , Svg.GradientStop 1 $ PixelRGBA8 216 216 216 255 + ] + } + +toSymbol :: Double -> Double -> [Svg.Tree] -> Svg.Element +toSymbol width height geom = element where + element = Svg.ElementGeometry $ Svg.SymbolTree tree + tree = Svg.Symbol $ execState build Svg.defaultSvg + + build = do + Svg.groupChildren .= geom + Svg.groupViewBox .= Just (0, 0, width, height) + Svg.groupAspectRatio . Svg.aspectRatioAlign .= Svg.AlignNone + +asFilled :: (Svg.WithDrawAttributes a) => a -> a +asFilled el = el & drawAttr.attrClass .~ ["filled_shape"] + +defaultCircle :: Svg.Element +defaultCircle = toSymbol 50 50 [Svg.CircleTree $ asFilled circle] where + circle = Svg.defaultSvg + { Svg._circleCenter = (Css.Num 25, Css.Num 25) + , Svg._circleRadius = Css.Num 24.5 + } + +h, v :: [Svg.Coord] -> Svg.PathCommand +h = Svg.HorizontalTo Svg.OriginRelative +v = Svg.VerticalTo Svg.OriginRelative + +m :: [Svg.RPoint] -> Svg.PathCommand +m = Svg.MoveTo Svg.OriginRelative + +c :: [(Svg.RPoint, Svg.RPoint, Svg.RPoint)] -> Svg.PathCommand +c = Svg.CurveTo Svg.OriginRelative + +l :: [Svg.RPoint] -> Svg.PathCommand +l = Svg.LineTo Svg.OriginRelative + +z :: Svg.PathCommand +z = Svg.EndPath + +defaultDocument :: Svg.Element +defaultDocument = toSymbol 51 51 [Svg.PathTree $ asFilled path] where + path = Svg.defaultSvg + { Svg._pathDefinition = + [ m [V2 49.98 0.79, V2 (-49.166) 0, V2 0 45.402] + , c [(V2 15.92 12.45, V2 30.40 (-13.44), V2 49.17 0)] + , z + ] + } + +ioShape :: Svg.Element +ioShape = toSymbol 100 100 [Svg.PathTree $ asFilled path] where + path = Svg.defaultSvg + { Svg._pathDefinition = + [ m [V2 19.207 1.6] + , h [79.414] + , l [V2 (-17.192) 97.297] + , h [-79.414] + , z + ] + } + +storageShape :: Svg.Element +storageShape = toSymbol 80 80 geometry where + geometry = Svg.PathTree . asFilled <$> [path1, path2] + path1 = Svg.defaultSvg + { Svg._pathDefinition = + [ m [V2 4.8122 67.74] + , v [-53.769] + , c [ (V2 0.0 (-3.2991) , V2 16.067 (-5.9743), V2 35.845 (-5.9743)) + , (V2 19.78 0.0, V2 35.848 2.6752, V2 35.848 5.9743) + ] + , v [53.769] + , c [(V2 0.0 3.2925, V2 (-16.068) 5.9743, V2 (-35.848) 5.9743) + , (V2 (-19.779) 0.0, V2 (-35.845) (-2.6818), V2 (-35.845) (-5.9743)) + ] + , z + ] + } + path2 = Svg.defaultSvg + { Svg._pathDefinition = + [ m [ V2 4.8122 13.97, V2 4.779e-2 0.30672, V2 0.13807 0.30272 + , V2 0.22834 0.29872, V2 0.31464 0.29344, V2 0.40094 0.28944 + , V2 0.48325 0.2828, V2 0.56423 0.27744, V2 0.64256 0.2708 + , V2 0.71823 0.26416, V2 0.79258 0.25752, V2 0.86294 0.25096 + , V2 0.9333 0.2416, V2 0.99968 0.23496, V2 1.0647 0.22568 + , V2 1.1271 0.2164, V2 1.1869 0.2084, V2 1.2453 0.19784 + , V2 1.301 0.1872, V2 1.3555 0.17792, V2 1.4046 0.16728 + , V2 1.455 0.15536, V2 1.5002 0.14336, V2 1.5466 0.1328 + , V2 1.5865 0.11952, V2 1.6276 0.10752, V2 1.6648 9.42e-2 + , V2 1.7007 8.1e-2, V2 1.7338 6.64e-2, V2 1.7644 5.31e-2 + , V2 1.7923 3.72e-2, V2 1.8188 2.39e-2, V2 1.8427 8.0e-3 + ] + , c [(V2 19.78 0.0, V2 35.848 (-2.6818), V2 35.848 (-5.9743))] + ] + } + +defaultDefinitions :: M.Map String Svg.Element +defaultDefinitions = M.fromList + [ ("shape_light", lightShapeGradient) + , ("circle", defaultCircle) + , ("document", defaultDocument) + , ("io", ioShape) + , ("storage", storageShape) + ] + diff --git a/src/Text/AsciiDiagram/Geometry.hs b/src/Text/AsciiDiagram/Geometry.hs --- a/src/Text/AsciiDiagram/Geometry.hs +++ b/src/Text/AsciiDiagram/Geometry.hs @@ -1,125 +1,132 @@ -{-# LANGUAGE CPP #-} --- | Defines the geometry extracted from the asciidiagram. -module Text.AsciiDiagram.Geometry( Point - , Vector - , Anchor( .. ) - , Shape( .. ) - , Segment( .. ) - , SegmentDraw( .. ) - , SegmentKind( .. ) - , ShapeElement( .. ) - , Diagram( .. ) - , TextZone( .. ) - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( mappend, mempty )) -#endif - -import qualified Data.Set as S -import qualified Data.Text as T -import Linear( V2( .. ) ) - --- | Position of a an element in the character grids -type Point = V2 Int - --- | Direction in the character grid. -type Vector = V2 Int - --- | Describe the geomtry of a full Ascii Diagram --- document -data Diagram = Diagram - { -- | All the extracted tshapes - _diagramShapes :: S.Set Shape - -- | All the extracted text zones - , _diagramTexts :: [TextZone] - -- | Width in characters of the document - , _diagramCellWidth :: !Int - -- | Height in characters of the document - , _diagramCellHeight :: !Int - -- | CSS styles associated to the document. - , _diagramStyles :: [T.Text] - } - deriving (Eq, Show) - --- | Describe where to place a text snippet. -data TextZone = TextZone - { _textZoneOrigin :: Point - , _textZoneContent :: T.Text - } - deriving (Eq, Show) - --- | Define the different connection points --- between the segments. -data Anchor - = AnchorMulti -- ^ Associated to '+' - | AnchorFirstDiag -- ^ Associated to '/' - | AnchorSecondDiag -- ^ Associated to '\' - - | AnchorPoint -- ^ Kind of "end anchor", without continuation. - | AnchorBullet -- ^ Used as a '*' - - | AnchorArrowUp -- ^ Associated to '^' - | AnchorArrowDown -- ^ Associated to 'V' - | AnchorArrowLeft -- ^ Associated to '<' - | AnchorArrowRight -- ^ Associated to '>' - deriving (Eq, Ord, Show) - --- | Helper data for segment composed of only --- one character -data SegmentKind - = SegmentHorizontal - | SegmentVertical - deriving (Eq, Ord, Show) - --- | Differentiate between elements drawn with a --- solid line or with dashed lines. -data SegmentDraw - = SegmentSolid - | SegmentDashed - deriving (Eq, Ord, Show) - --- | Define an horizontal or vertical segment. -data Segment = Segment - { _segStart :: {-# UNPACK #-} !Point - , _segEnd :: {-# UNPACK #-} !Point - , _segKind :: !SegmentKind - , _segDraw :: !SegmentDraw - } - deriving (Eq, Ord) - -instance Show Segment where - showsPrec d (Segment s e k dr) = - showParen (d >= 10) $ - showString "Segment " . start . end . kind . (' ':) . draw - where - start = showParen True $ shows s - end = showParen True $ shows e - kind = shows k - draw = shows dr - -instance Monoid Segment where - mempty = Segment 0 0 SegmentVertical SegmentSolid - mappend (Segment a _ _ _) (Segment _ b k d) = - Segment a b k d - --- | Describe a composant of shapes. Can --- be composed of anchors like "+*/\\" or --- segments. -data ShapeElement - = ShapeAnchor !Point !Anchor - | ShapeSegment !Segment - deriving (Eq, Ord, Show) - --- | Shape extracted from the text -data Shape = Shape - { -- | Elements composing the shape. - shapeElements :: [ShapeElement] - -- | When False it's just lines possibly with - -- an arrow, when True it's a polygon. - , shapeIsClosed :: Bool - -- | Tags "{tagname}" placed inside the shape. - , shapeTags :: S.Set T.Text - } - deriving (Eq, Ord, Show) - +{-# LANGUAGE CPP #-} +-- | Defines the geometry extracted from the asciidiagram. +module Text.AsciiDiagram.Geometry( Point + , Vector + , Anchor( .. ) + , Shape( .. ) + , Element( .. ) + , Segment( .. ) + , SegmentDraw( .. ) + , SegmentKind( .. ) + , ShapeElement( .. ) + , Diagram( .. ) + , TextZone( .. ) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( mappend, mempty )) +#endif + +import qualified Data.Set as S +import qualified Data.Text as T +import Linear( V2( .. ) ) + +-- | Position of a an element in the character grids +type Point = V2 Int + +-- | Direction in the character grid. +type Vector = V2 Int + +-- | Describe the geomtry of a full Ascii Diagram +-- document +data Diagram = Diagram + { -- | All the extracted tshapes + _diagramElements :: S.Set Element + -- | Width in characters of the document + , _diagramCellWidth :: !Int + -- | Height in characters of the document + , _diagramCellHeight :: !Int + -- | CSS styles associated to the document. + , _diagramStyles :: [T.Text] + } + deriving (Eq, Show) + +-- | Describe where to place a text snippet. +data TextZone = TextZone + { _textZoneOrigin :: Point + , _textZoneContent :: T.Text + } + deriving (Eq, Ord, Show) + +-- | Define the different connection points +-- between the segments. +data Anchor + = AnchorMulti -- ^ Associated to '+' + | AnchorFirstDiag -- ^ Associated to '/' + | AnchorSecondDiag -- ^ Associated to '\' + + | AnchorPoint -- ^ Kind of "end anchor", without continuation. + | AnchorBullet -- ^ Used as a '*' + + | AnchorArrowUp -- ^ Associated to '^' + | AnchorArrowDown -- ^ Associated to 'V' + | AnchorArrowLeft -- ^ Associated to '<' + | AnchorArrowRight -- ^ Associated to '>' + deriving (Eq, Ord, Show) + +-- | Helper data for segment composed of only +-- one character +data SegmentKind + = SegmentHorizontal + | SegmentVertical + deriving (Eq, Ord, Show) + +-- | Differentiate between elements drawn with a +-- solid line or with dashed lines. +data SegmentDraw + = SegmentSolid + | SegmentDashed + deriving (Eq, Ord, Show) + +-- | Define an horizontal or vertical segment. +data Segment = Segment + { _segStart :: {-# UNPACK #-} !Point + , _segEnd :: {-# UNPACK #-} !Point + , _segKind :: !SegmentKind + , _segDraw :: !SegmentDraw + } + deriving (Eq, Ord) + +instance Show Segment where + showsPrec d (Segment s e k dr) = + showParen (d >= 10) $ + showString "Segment " . start . end . kind . (' ':) . draw + where + start = showParen True $ shows s + end = showParen True $ shows e + kind = shows k + draw = shows dr + +instance Monoid Segment where + mempty = Segment 0 0 SegmentVertical SegmentSolid + mappend (Segment a _ _ _) (Segment _ b k d) = + Segment a b k d + +-- | Describe a composant of shapes. Can +-- be composed of anchors like "+*/\\" or +-- segments. +data ShapeElement + = ShapeAnchor !Point !Anchor + | ShapeSegment !Segment + deriving (Eq, Ord, Show) + +-- | Shape extracted from the text +data Shape = Shape + { -- | Elements composing the shape. + shapeElements :: ![ShapeElement] + -- | When False it's just lines possibly with + -- an arrow, when True it's a polygon. + , shapeIsClosed :: !Bool + -- | Tags "{tagname}" placed inside the shape. + , shapeTags :: !(S.Set T.Text) + + , shapeChildren :: ![Element] + } + deriving (Eq, Ord, Show) + +-- | Define an element to be drawn. +data Element + = ElemText !TextZone + | ElemShape !Shape + deriving (Eq, Show, Ord) + diff --git a/src/Text/AsciiDiagram/Reconstructor.hs b/src/Text/AsciiDiagram/Reconstructor.hs --- a/src/Text/AsciiDiagram/Reconstructor.hs +++ b/src/Text/AsciiDiagram/Reconstructor.hs @@ -260,7 +260,7 @@ . fmap (`M.lookup` _vertices graph) toFilaments shapes = - [Shape piece False mempty | piece <- breakFilaments $ toElems shapes] + [Shape piece False mempty mempty | piece <- breakFilaments $ toElems shapes] - toShapes shapes = Shape (toElems shapes) True mempty + toShapes shapes = Shape (toElems shapes) True mempty mempty diff --git a/src/Text/AsciiDiagram/SvgRender.hs b/src/Text/AsciiDiagram/SvgRender.hs --- a/src/Text/AsciiDiagram/SvgRender.hs +++ b/src/Text/AsciiDiagram/SvgRender.hs @@ -1,32 +1,31 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Text.AsciiDiagram.SvgRender( GridSize( .. ) - , defaultGridSize - , svgOfDiagram - , svgOfDiagramAtSize - ) where +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 Data.Monoid( Last( .. ), (<>) ) import Graphics.Svg.Types ( HasDrawAttributes( .. ) - , Texture( ColorRef ) , Document( .. ) , drawAttr ) import Graphics.Svg( cssRulesOfText ) -import Codec.Picture( PixelRGBA8( PixelRGBA8 ) ) import qualified Graphics.Svg.Types as Svg -import qualified Data.Map as M +import qualified Graphics.Svg.CssTypes as Css import qualified Data.Set as S import qualified Data.Text as T -import Text.Printf import Linear( V2( .. ) , (^+^) , (^-^) @@ -34,10 +33,12 @@ , perp , normalize ) -import Control.Lens( zoom, (.=), (%=), (%~), (&) ) +import Control.Lens( zoom, (^.), (.=), (%=), (%~), (&) ) -import Text.AsciiDiagram.Geometry +import Text.AsciiDiagram.BoundingBoxEstimation +import Text.AsciiDiagram.DefaultContext import Text.AsciiDiagram.DiagramCleaner +import Text.AsciiDiagram.Geometry {-import Debug.Trace-} {-import Text.Groom-} @@ -78,39 +79,24 @@ isDashed (ShapeSegment Segment { _segDraw = SegmentDashed }) = True applyDefaultShapeDrawAttr :: (Svg.WithDrawAttributes a) => a -> a -applyDefaultShapeDrawAttr = execState . zoom drawAttr $ do - strokeColor .= toLC 0 0 0 255 - attrClass %= ("filled_shape":) - strokeWidth .= toL (Svg.Num 1) - where - toL = Last . Just - toLC r g b a = - toL . ColorRef $ PixelRGBA8 r g b a +applyDefaultShapeDrawAttr el = + el & drawAttr.attrClass %~ ("filled_shape":) applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a -applyLineArrowDrawAttr = execState . zoom drawAttr $ do - fillColor .= toLC 0 0 0 255 - strokeColor .= toL Svg.FillNone - strokeWidth .= toL (Svg.Num 0) - where - toL = Last . Just - toLC r g b a = - toL . ColorRef $ PixelRGBA8 r g b a +applyLineArrowDrawAttr el = + el & drawAttr.attrClass %~ ("arrow_head":) applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a -applyBulletDrawAttr = execState . zoom drawAttr $ do - attrClass %= ("bullet":) +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 = execState . zoom drawAttr $ do - attrClass %= ("line_element":) - fillColor .= toL Svg.FillNone - strokeColor .= toLC 0 0 0 255 - strokeWidth .= toL (Svg.Num 1) - where - toL = Last . Just - toLC r g b a = - toL . ColorRef $ PixelRGBA8 r g b a +applyDefaultLineDrawAttr el = + el & drawAttr.attrClass %~ ("line_element":) startPointOf :: ShapeElement -> Point @@ -448,70 +434,101 @@ V2 x y = toSvg gscale (_textZoneOrigin zone) ^+^ correction txt = Svg.textAt (Svg.Num (x+0.5), Svg.Num (y+0.5)) $ _textZoneContent zone -defaultCss :: Float -> T.Text -defaultCss textSize = T.pack $ printf - ("\n" <> - "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <> - ".dashed_elem { stroke-dasharray: 4, 3 }\n" <> - ".filled_shape { fill: url(#shape_light) }\n" <> - ".bullet { stroke-width: 1px; fill: white; stroke: black }\n" - ) - (2 + floor textSize :: Int) -lightShapeGradient :: Svg.Element -lightShapeGradient = Svg.ElementLinearGradient $ - Svg.defaultSvg - { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0) - , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1) - , Svg._linearGradientStops = - [ Svg.GradientStop 0 $ PixelRGBA8 245 245 245 255 - , Svg.GradientStop 1 $ PixelRGBA8 216 216 216 255 - ] - } - -- | Transform an Ascii diagram to a SVG document which -- can be saved or converted to an image. svgOfDiagram :: Diagram -> Svg.Document -svgOfDiagram = svgOfDiagramAtSize defaultGridSize where +svgOfDiagram = + svgOfDiagramAtSize defaultGridSize (defaultLibrary defaultGridSize) +svgOfShape :: GridSize -> Shape -> Svg.Tree +svgOfShape scale shape + | shapeIsClosed shape = + applyDefaultShapeDrawAttr $ shapeToTree scale shape + | otherwise = + applyDefaultLineDrawAttr $ shapeToTree 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 -> Diagram -> Svg.Document -svgOfDiagramAtSize scale diagram = Document +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 = closedSvg ++ lineSvg ++ textSvg - , _definitions = M.fromList - [("shape_light", lightShapeGradient)] + , _elements = + shapeRewriter allRules . svgOfElement scale <$> shapes + , _definitions = _definitions style , _description = "" - , _styleRules = defaultCssRules ++ customCssRules + , _styleRules = allRules , _documentLocation = "" } where - (closed, opened) = S.partition shapeIsClosed shapes - - defaultCssRules = - cssRulesOfText . defaultCss $ _gridCellHeight scale - + allRules = _styleRules style <> customCssRules customCssRules = cssRulesOfText . T.unlines $ _diagramStyles diagram - shapes = _diagramShapes diagram - - closedSvg = - applyDefaultShapeDrawAttr . shapeToTree scale <$> filter isShapePossible - (S.toList closed) - lineSvg = - applyDefaultLineDrawAttr . shapeToTree strokeScale <$> S.toList opened + 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 - textSvg = textToTree scale <$> _diagramTexts diagram - - strokeScale = scale { _gridShapeContraction = 0 } +defaultLibrary :: GridSize -> Svg.Document +defaultLibrary size = Document + { _viewBox = Nothing + , _width = Nothing + , _height = Nothing + , _elements = [] + , _definitions = defaultDefinitions + , _description = "" + , _styleRules = defaultCssRules $ _gridCellHeight size + , _documentLocation = "" + }