diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/asciidiagram.cabal b/asciidiagram.cabal new file mode 100644 --- /dev/null +++ b/asciidiagram.cabal @@ -0,0 +1,85 @@ +-- Initial hitaa.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ +name: asciidiagram +version: 1.0 +synopsis: Pretty rendering of Ascii diagram into svg or png. +description: + Asciidiagram Ascii art diagram like this: + . + @ + , \/---------+ + +---------+ | | + | ASCII +----\>| Diagram | + +---------+ | | + | | +--+------\/ + \\---*-----\/\<=======\/ + @ + . + Into this: + . + <> + . + See the documentation of the Text.AsciiDiagram module for the + description of the input format. + +license: BSD3 +--license-file: +author: Vincent Berthoux +maintainer: vincent.berthoux@gmail.com +-- copyright: +category: Text, Diagram +build-type: Simple +extra-source-files: changelog +extra-doc-files: docimages/*.svg +cabal-version: >=1.10 + +Source-Repository head + Type: git + Location: git://github.com/Twinside/asciidiagram.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/asciidiagram.git + Tag: v1.0 + +library + ghc-options: -O2 -Wall + exposed-modules: Text.AsciiDiagram + + other-modules: Text.AsciiDiagram.DiagramCleaner + , Text.AsciiDiagram.Geometry + , Text.AsciiDiagram.Graph + , Text.AsciiDiagram.Parser + , Text.AsciiDiagram.Reconstructor + , Text.AsciiDiagram.SvgRender + + -- containers >= 0.5.2.1 for Set.elemAt + build-depends: base >=4.6 && <4.9 + , vector >= 0.10 + , text >= 1.2 && < 1.3 + , linear >= 1.16 + , containers >= 0.5 + , mtl >= 2.1 && < 2.3 + , lens >= 4.6 && < 4.8 + , svg-tree >= 0.1 && < 0.2 + , rasterific-svg >= 0.1 && < 0.2 + , FontyFruity >= 0.5 && < 0.6 + , JuicyPixels >= 3.2 + + hs-source-dirs: src + default-language: Haskell2010 + +Executable asciidiagram + Main-Is: asciidiagram.hs + default-language: Haskell2010 + ghc-options: -O2 -Wall + Hs-Source-Dirs: exec-src + Build-Depends: base >= 4.6 + , optparse-applicative + , rasterific-svg + , JuicyPixels + , filepath + , asciidiagram + , svg-tree + , text + diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,5 @@ +-*-change-log-*- + +v0.1 + * Initial version + diff --git a/docimages/arrows.svg b/docimages/arrows.svg new file mode 100644 --- /dev/null +++ b/docimages/arrows.svg @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + < > v ^ + diff --git a/docimages/baseExample.svg b/docimages/baseExample.svg new file mode 100644 --- /dev/null +++ b/docimages/baseExample.svg @@ -0,0 +1,46 @@ + + + + + + + + + + + + + + + + + + + + + + + + + ASCII + Diagram + + diff --git a/docimages/bulletTest.svg b/docimages/bulletTest.svg new file mode 100644 --- /dev/null +++ b/docimages/bulletTest.svg @@ -0,0 +1,38 @@ + + + + + + + + + + + + + + + + + + + + + + * * + diff --git a/docimages/cabalSchema.svg b/docimages/cabalSchema.svg new file mode 100644 --- /dev/null +++ b/docimages/cabalSchema.svg @@ -0,0 +1,42 @@ + + + + + + + + + + + + + + + + + + + + + + + + + ASCII + Diagram + diff --git a/docimages/complexClosed.svg b/docimages/complexClosed.svg new file mode 100644 --- /dev/null +++ b/docimages/complexClosed.svg @@ -0,0 +1,27 @@ + + + + + + + + + + + + diff --git a/docimages/curvedCorner.svg b/docimages/curvedCorner.svg new file mode 100644 --- /dev/null +++ b/docimages/curvedCorner.svg @@ -0,0 +1,37 @@ + + + + + + + + + + + + + + + + + + + . + . + . + diff --git a/docimages/dashed_lines.svg b/docimages/dashed_lines.svg new file mode 100644 --- /dev/null +++ b/docimages/dashed_lines.svg @@ -0,0 +1,30 @@ + + + + + + + + + + + + + + + diff --git a/docimages/dashingClosed.svg b/docimages/dashingClosed.svg new file mode 100644 --- /dev/null +++ b/docimages/dashingClosed.svg @@ -0,0 +1,29 @@ + + + + + + + + + + + + + + diff --git a/docimages/simple_lines.svg b/docimages/simple_lines.svg new file mode 100644 --- /dev/null +++ b/docimages/simple_lines.svg @@ -0,0 +1,30 @@ + + + + + + + + + + + + + + + diff --git a/docimages/styleExample.svg b/docimages/styleExample.svg new file mode 100644 --- /dev/null +++ b/docimages/styleExample.svg @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Source + op1 + + op2 + Dest + + diff --git a/exec-src/asciidiagram.hs b/exec-src/asciidiagram.hs new file mode 100644 --- /dev/null +++ b/exec-src/asciidiagram.hs @@ -0,0 +1,109 @@ +{-# 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.Text.IO as STIO +import System.FilePath( replaceExtension + , takeExtension ) + +import Graphics.Rasterific.Svg( renderSvgDocument + , loadCreateFontCache ) + +import Codec.Picture( writePng ) +import Options.Applicative( Parser + , ParserInfo + , argument + , execParser + , flag + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , progDesc + , str + , switch + ) +import Text.AsciiDiagram +import Graphics.Svg + +data Options = Options + { _inputFile :: !FilePath + , _outputFile :: !FilePath + , _verbose :: !Bool + , _format :: !(Maybe Format) + } + +data Format = FormatSvg | FormatPng + +argParser :: Parser Options +argParser = Options + <$> ( 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 "" ) + <*> ( switch (long "verbose" <> help "Display more information") ) + <*> ( 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)") + ) + +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 + _ -> FormatPng + +runConversion :: Options -> IO () +runConversion opt = do + verbose . putStrLn $ "Loading file " ++ _inputFile opt + inputData <- STIO.readFile $ _inputFile opt + let svgDoc = svgOfDiagram $ parseAsciiDiagram inputData + case (_format opt, formatOfOuputFilename $ _outputFile opt) of + (Nothing, FormatSvg) -> saveDoc svgDoc + (Just FormatSvg, _) -> saveDoc svgDoc + (Nothing, FormatPng) -> savePng svgDoc + (Just FormatPng, _) -> savePng svgDoc + where + verbose = when $ _verbose opt + saveDoc doc = do + verbose . putStrLn $ "Writing SVG file " ++ _outputFile opt + saveXmlFile (savingPath "svg") doc + + savingPath ext = case _outputFile opt of + "" -> replaceExtension (_inputFile opt) ext + p -> p + + savePng doc = do + verbose . putStrLn $ "Loading/Building font cache (can be long)" + cache <- loadCreateFontCache "asciidiagram-fonty-fontcache" + verbose . putStrLn $ "Writing PNG file " ++ _outputFile opt + (img, _) <- renderSvgDocument cache Nothing 96 doc + writePng (savingPath "png") img + +main :: IO () +main = execParser progOptions >>= runConversion + diff --git a/src/Text/AsciiDiagram.hs b/src/Text/AsciiDiagram.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram.hs @@ -0,0 +1,417 @@ +{-# 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 { fill: #DDD; } +-- @ +-- <> +-- +-- 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 + + -- * Usage example + -- $example + + -- * Functions + svgOfDiagram + , parseAsciiDiagram + , saveAsciiDiagramAsSvg + , imageOfDiagram + + -- * Document description + , Diagram( .. ) + , TextZone( .. ) + , Shape( .. ) + , ShapeElement( .. ) + , Anchor( .. ) + , Segment( .. ) + , SegmentKind( .. ) + , SegmentDraw( .. ) + , Point + ) where + +import Data.Monoid( (<>)) +import Control.Applicative( (<$>) ) +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.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( Dpi, saveXmlFile ) +import Graphics.Rasterific.Svg( renderSvgDocument ) + +{-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 + +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 + + 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]] + | 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 WithHorizontalSegments shapes] + + +pointComp :: Point -> Point -> Ordering +pointComp (V2 x1 y1) (V2 x2 y2) = case compare y1 y2 of + EQ -> compare x1 x2 + a -> a + +rangesOfShapes :: Shape -> [(Point, Point)] +rangesOfShapes 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 + $ pointsOfShape WithoutHorizontalSegments [shape] + + +associateTags :: [Shape] -> [TextZone] -> ([Shape], [TextZone]) +associateTags shapes tagZones = + expandTag $ runState (mapM go shapes) sortedZones where + + sortedZones = + sortBy (pointComp `on` _textZoneOrigin) tagZones + + isInRange (V2 px py) (V2 x1 y1, V2 x2 y2) = + py == y1 && py == y2 && x1 < px && px < x2 + + expandTag (s, zones) = (s, fmap expander zones) where + expander t = t { _textZoneContent = "{" <> _textZoneContent t <> "}" } + + insertAlls shape = + foldr S.insert (shapeTags shape) . fmap _textZoneContent + + go shape | not $ shapeIsClosed shape = return shape + go shape = do + zones <- get + + let ranges = rangesOfShapes shape + isInShape TextZone { _textZoneOrigin = orig } = + any (isInRange orig) ranges + (inRanges, other) = partition isInShape zones + + put other + + return shape { shapeTags = insertAlls shape inRanges } + + +-- | Analyze an ascii diagram and extract all it's features. +parseAsciiDiagram :: T.Text -> Diagram +parseAsciiDiagram content = Diagram + { _diagramShapes = S.fromList taggedShape + , _diagramTexts = zones ++ unusedTags + , _diagramCellWidth = maximum $ fmap T.length textLines + , _diagramCellHeight = length textLines - length styleLines + , _diagramStyles = styleLines + } + where + textLines = T.lines content + (taggedShape, unusedTags) = associateTags (S.toList validShapes) tags + + (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 + +-- | Render a Diagram as an image. a good value for the Dpi +-- is 96. The IO dependency is there to allow loading of the +-- font files used in the document. +imageOfDiagram :: FontCache -> Dpi -> Diagram -> IO (Image PixelRGBA8) +imageOfDiagram cache dpi = + fmap fst . renderSvgDocument cache Nothing dpi . svgOfDiagram + +-- $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. +-- +-- +-- @ +-- ----- +-- -=----- +-- +-- | : +-- | | +-- | \\---- +-- | +-- +--=-- +-- @ +-- <> +-- +-- Arrows are made out of the \'\<\', \'\>\', \'^\' and \'v\'\ncharacters.\nIf the arrows are not connected to any lines, the text is left as is.\n +-- +-- +-- @ +-- ^ +-- | +-- | +-- \<----+----\> +-- | \< \> v ^ +-- | +-- v +-- @ +-- <> +-- + +-- $shapesdoc +-- If the lines are closed, then it is detected as such and rendered +-- differently +-- +-- +-- @ +-- +------+ +-- | | +-- | +--+ +-- | | | +-- +---+--+ | +-- | | +-- +-----+ +-- @ +-- <> +-- +-- If any of the segment posess one of the dashing markers (\':\' or \'=\') +-- Then the full shape will be dashed. +-- +-- +-- @ +-- +--+ +--+ +=-+ +=-+ +-- | | : | | | | : +-- +--+ +--+ +--+ +-=+ +-- @ +-- <> +-- +-- Any of the angle of a shape can curved one of the smooth corner anchor +-- (\'\\\' or \'\/\') +-- +-- +-- @ +-- \/--+ +--\\ +--+ \/--+ +-- | | | | | | | | +-- +--+ +--+ \\--+ +--+ +-- +-- \/--+ \/--\\ \/--+ \/--\\ . +-- | | | | | | | | +-- +--\/ +--+ \\--\/ +--\/ +-- +-- \/--\\ . +-- | | +-- \\--\/ +-- . +-- @ +-- <> +-- + +-- $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. +-- +-- +-- @ +-- *-*-* +-- | | *----* +-- +---\/ | +-- * * * +-- @ +-- <> +-- +-- 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 { fill: #AAF; } +-- ::: .dst { stroke: #FAA; stroke-width: 3px; } +-- @ +-- <> +-- +-- 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 applyied on every dashed element. +-- +-- * `filled_shape` is applyied on every closed shape. +-- +-- * `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. +-- diff --git a/src/Text/AsciiDiagram/DiagramCleaner.hs b/src/Text/AsciiDiagram/DiagramCleaner.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/DiagramCleaner.hs @@ -0,0 +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 + diff --git a/src/Text/AsciiDiagram/Geometry.hs b/src/Text/AsciiDiagram/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/Geometry.hs @@ -0,0 +1,125 @@ +{-# 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) + diff --git a/src/Text/AsciiDiagram/Graph.hs b/src/Text/AsciiDiagram/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/Graph.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Text.AsciiDiagram.Graph + ( Graph( .. ) + , PlanarVertice( .. ) + , Filament + , Cycle + , graphOfVertices + , extractAllPrimitives + , addVertice + , connect + , vertices + , edges + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( .. ), mempty ) +#endif + +import Control.Applicative( (<$>) ) +import Control.Monad( forM_, when ) +import Control.Monad.State.Strict( execState ) +import Control.Monad.State.Class( MonadState ) +import Data.Function( on ) +import Data.Maybe( fromMaybe ) +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Lens( Lens' + , lens + , (&) + , (.~) + , (?~) + , (%=) + , (.=) + , itraverse_ + , contains + , at + , use + ) + +{-import Debug.Trace-} +{-import Text.Printf-} +{-import Text.Groom-} + +data Graph vertex vinfo edgeInfo = Graph + { _vertices :: M.Map vertex vinfo + , _edges :: M.Map (vertex, vertex) edgeInfo + } + deriving (Eq, Ord, Show) + +vertices :: Lens' (Graph vertex vinfo edgeInfo) (M.Map vertex vinfo) +vertices = lens _vertices setVertices where + setVertices g v = g { _vertices = v } + +edges :: Lens' (Graph vertex vinfo edgeInfo) + (M.Map (vertex, vertex) edgeInfo) +edges = lens _edges setEdge where + setEdge g e = g { _edges = e } + +graphOfVertices :: (Ord vertex) => M.Map vertex vinfo -> Graph vertex vinfo a +graphOfVertices vertMap = emptyGraph & vertices .~ vertMap + +emptyGraph :: (Ord v) => Graph v vi e +emptyGraph = Graph + { _vertices = mempty + , _edges = mempty + } + +instance (Ord v) => Monoid (Graph v vi e) where + mempty = emptyGraph + mappend a b = Graph + { _vertices = (mappend `on` _vertices) a b + , _edges = (mappend `on` _edges) a b + } + +addVertice :: Ord v + => v -> vinfo -> Graph v vinfo edgeInfo + -> Graph v vinfo edgeInfo +addVertice v info g = g & vertices . at v ?~ info + + +connect :: Ord v + => v -> v -> edgeInfo -> Graph v vinfo edgeInfo + -> Graph v vinfo edgeInfo +connect a b info g = g & edges . at (linkOf a b) ?~ info + +adjacencyMapOfGraph :: (Ord v) => Graph v vi ei -> M.Map v (Int, S.Set v) +adjacencyMapOfGraph = flip execState mempty . itraverse_ go . _edges where + inserter p Nothing = Just (1, S.singleton p) + inserter p (Just (n, s)) = Just (n + 1, S.insert p s) + + go (k1, k2) _ = do + at k1 %= inserter k2 + at k2 %= inserter k1 + +type Filament v = [v] +type Cycle v = [v] + +data MinimalCycleFinderState v vi ei = MinimalCycleFinderState + { _adjacency :: M.Map v (Int, S.Set v) + , _graph :: Graph v vi ei + , _visited :: S.Set v + , _cycleEdges :: S.Set (v, v) + , _foundFilaments :: [Filament v] + , _foundCycles :: [Cycle v] + } + +emptyCycleFinderState :: (Ord v, Show v, Show vi, Show ei) + => Graph v vi ei -> MinimalCycleFinderState v vi ei +emptyCycleFinderState g = MinimalCycleFinderState + { _adjacency = adjacencyMapOfGraph g + , _graph = g + , _visited = mempty + , _cycleEdges = mempty + , _foundFilaments = mempty + , _foundCycles = mempty + } + + +visited :: Lens' (MinimalCycleFinderState v vi ei) + (S.Set v) +visited = lens _visited setter where + setter a b = a { _visited = b } + +foundFilaments :: Lens' (MinimalCycleFinderState v vi ei) + [Filament v] +foundFilaments = lens _foundFilaments setter where + setter a b = a { _foundFilaments = b } + +foundCycles :: Lens' (MinimalCycleFinderState v vi ei) + [Cycle v] +foundCycles = lens _foundCycles setter where + setter a b = a { _foundCycles = b } + +cycleEdges :: Lens' (MinimalCycleFinderState v vi ei) + (S.Set (v, v)) +cycleEdges = lens _cycleEdges setter where + setter a b = a { _cycleEdges = b } + +adjacency :: Lens' (MinimalCycleFinderState v vi ei) + (M.Map v (Int, S.Set v)) +adjacency = lens _adjacency setter where + setter a b = a { _adjacency = b } + +graph :: Lens' (MinimalCycleFinderState v vi ei) + (Graph v vi ei) +graph = lens _graph setter where + setter a b = a { _graph = b } + +linkOf :: (Ord v) => v -> v -> (v, v) +linkOf p1 p2 | p1 < p2 = (p1, p2) + | otherwise = (p2, p1) + + +isInCycle :: (Ord v, MonadState (MinimalCycleFinderState v vi ei) m) + => v -> v -> m Bool +isInCycle a b = use $ cycleEdges . contains (linkOf a b) + +removeEdge :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Ord v, Show v ) + => v -> v -> m () +removeEdge a b = do + let remEdge p (n, s) = (n - 1, S.delete p s) + adjacency . at a %= fmap (remEdge b) + adjacency . at b %= fmap (remEdge a) + graph . edges . at (linkOf a b) .= Nothing + + +removeVertice :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Ord v + , Show v ) + => v -> m () +removeVertice v = graph . vertices . at v .= Nothing + +adjacencyInfoOfVertice :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Ord v + , Functor m ) + => v -> m (Int, S.Set v) +adjacencyInfoOfVertice v = + fromMaybe (0, mempty) <$> use (adjacency . at v) + +extractFilament :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Ord v + , Functor m + , Show v) + => v -> v -> m [v] +extractFilament fromVertice toVertice = do + mustCycle <- isInCycle fromVertice toVertice + (fromCount, _) <- adjacencyInfoOfVertice fromVertice + (toCount, toAdjacents) <- adjacencyInfoOfVertice toVertice + if fromCount >= 3 then do + removeEdge fromVertice toVertice + let startVertice + | toCount == 1 = S.findMin toAdjacents + | otherwise = toVertice + retIfNoCycle mustCycle $ + follow mustCycle [fromVertice] startVertice + else + retIfNoCycle mustCycle $ + follow mustCycle [] fromVertice + where + retIfNoCycle False act = act + retIfNoCycle True act = do + _ <- act + return [] + + follow mustCycle history currentVertice = do + (count, adjacent) <- adjacencyInfoOfVertice currentVertice + case count of + 0 -> do + removeVertice currentVertice + return $ currentVertice : history + + 1 -> do + let nextVertice = S.findMin adjacent + inCycle <- isInCycle currentVertice nextVertice + if mustCycle && not inCycle then + return $ currentVertice : history + else do + removeEdge currentVertice nextVertice + removeVertice currentVertice + follow mustCycle (currentVertice : history) nextVertice + + _ -> + return $ currentVertice : history + +class (Ord v, Show v) => PlanarVertice v where + getClockwiseMost :: S.Set v -> Maybe v -> v + -> Maybe v + getCounterClockwiseMost :: S.Set v -> Maybe v -> v + -> Maybe v + +findClockwiseMost :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Functor m + , PlanarVertice v ) + => Maybe v -> v -> m (Maybe v) +findClockwiseMost mv v = do + adj <- maybe mempty snd <$> use (adjacency . at v) + return $ getClockwiseMost adj mv v + +findCounterClockwiseMost + :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Functor m + , PlanarVertice v ) + => Maybe v -> v -> m (Maybe v) +findCounterClockwiseMost mv v = do + adj <- maybe mempty snd <$> use (adjacency . at v) + return $ getCounterClockwiseMost adj mv v + +setElemAtOne :: S.Set a -> a +-- S.elemAt requires containers >= 0.5 +setElemAtOne = extract . S.toList where + extract (_:v:_) = v + extract _ = error "Bad set size." + +extractFilamentFromMiddle + :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Functor m + , Ord v + , Show v ) + => v -> v -> m [v] +extractFilamentFromMiddle = go where + go prev curr = do + (adjCount, adjs) <- adjacencyInfoOfVertice curr + let nextVertice = S.findMin adjs + if adjCount /= 2 then + extractFilament curr prev + else if prev /= nextVertice then + go curr nextVertice + else + go curr $ setElemAtOne adjs + +addFilament :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Show v ) + => Filament v -> m () +addFilament [] = return () +addFilament filament = foundFilaments %= (filament:) + +extractCycle :: ( MonadState (MinimalCycleFinderState v vi ei) m + , Functor m + , PlanarVertice v ) + => v -> m () +extractCycle rootNode = do + startNode <- findClockwiseMost Nothing rootNode + let starting = fromMaybe rootNode startNode + + follow _history prevVertice Nothing = do + filament <- extractFilament prevVertice prevVertice + addFilament filament + follow history prevVertice (Just v) | v == rootNode = do + foundCycles %= (history:) + let edgesOfCycle = (prevVertice, v) : zip history (tail history) + forM_ edgesOfCycle $ \(a, b) -> + cycleEdges . contains (linkOf a b) .= True + removeEdge rootNode starting + extractIfAlone rootNode + extractIfAlone starting + follow history prevVertice (Just v) = do + wasVisited <- use $ visited . contains v + if wasVisited then do + filament <- extractFilamentFromMiddle starting rootNode + addFilament filament + else do + nextVertice <- + findCounterClockwiseMost (Just prevVertice) v + follow (v:history) v nextVertice + + follow [rootNode] rootNode startNode + where + extractIfAlone node = do + (startCount, adjs) <- adjacencyInfoOfVertice node + when (startCount == 1) $ do + filament <- extractFilament node $ S.findMin adjs + addFilament filament + +extractAllPrimitives :: (PlanarVertice v, Show ei, Show vi) + => Graph v vi ei -> ([Cycle v], [Filament v]) +extractAllPrimitives initGraph = extract $ execState go initialState where + initialState = emptyCycleFinderState initGraph + extract s = (_foundCycles s, _foundFilaments s) + + go = do + vs <- use $ graph . vertices + if M.null vs then return () + else do + let (toFollow, _) = M.findMin vs + (adjCount, _) <- adjacencyInfoOfVertice toFollow + case adjCount of + 0 -> removeVertice toFollow + 1 -> do + filament <- extractFilament toFollow toFollow + addFilament filament + _ -> extractCycle toFollow + go diff --git a/src/Text/AsciiDiagram/Parser.hs b/src/Text/AsciiDiagram/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/Parser.hs @@ -0,0 +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 ) +#endif + +import Control.Applicative( (<$>) ) +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 + diff --git a/src/Text/AsciiDiagram/Reconstructor.hs b/src/Text/AsciiDiagram/Reconstructor.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/Reconstructor.hs @@ -0,0 +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 ) +#endif + +import Control.Applicative( (<$>) ) +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 | piece <- breakFilaments $ toElems shapes] + + toShapes shapes = Shape (toElems shapes) True mempty + diff --git a/src/Text/AsciiDiagram/SvgRender.hs b/src/Text/AsciiDiagram/SvgRender.hs new file mode 100644 --- /dev/null +++ b/src/Text/AsciiDiagram/SvgRender.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Text.AsciiDiagram.SvgRender( svgOfDiagram ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +#endif + +import Control.Applicative( (<$>) ) +import Control.Monad.State.Strict( execState ) +import Data.Monoid( Last( .. ), (<>) ) + +import Graphics.Svg.Types + ( HasDrawAttributes( .. ) + , Texture( ColorRef ) + , Document( .. ) + , drawAttr ) +import Graphics.Svg( cssRulesOfText ) + +import Codec.Picture( PixelRGBA8( PixelRGBA8 ) ) +import qualified Graphics.Svg.Types as Svg +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import Text.Printf +import Linear( V2( .. ) + , (^+^) + , (^-^) + , (^*) + , perp + , normalize + ) +import Control.Lens( zoom, (.=), (%=), (%~), (&) ) + +import Text.AsciiDiagram.Geometry +import Text.AsciiDiagram.DiagramCleaner + +{-import Debug.Trace-} +{-import Text.Groom-} + +data GridSize = GridSize + { _gridCellWidth :: !Float + , _gridCellHeight :: !Float + , _gridShapeContraction :: !Float + } + deriving (Eq, Show) + + +toSvg :: GridSize -> Point -> Svg.RPoint +toSvg s (V2 x y) = + V2 (_gridCellWidth s * fromIntegral (x + 1)) + (_gridCellHeight s * fromIntegral (y + 1)) + + +setDashingInformation :: (Svg.WithDrawAttributes a) => a -> a +setDashingInformation = execState $ do + drawAttr . attrClass %= ("dashed_elem":) + +isShapeDashed :: Shape -> Bool +isShapeDashed = any isDashed . shapeElements where + isDashed (ShapeAnchor _ _) = False + isDashed (ShapeSegment Segment { _segDraw = SegmentSolid }) = False + isDashed (ShapeSegment Segment { _segDraw = SegmentDashed }) = True + +applyDefaultShapeDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyDefaultShapeDrawAttr = execState . zoom drawAttr $ do + strokeColor .= toLC 0 0 0 255 + attrClass %= ("filled_shape":) + strokeWidth .= toL (Svg.Num 1) + where + toL = Last . Just + toLC r g b a = + toL . ColorRef $ PixelRGBA8 r g b a + +applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyLineArrowDrawAttr = execState . zoom drawAttr $ do + fillColor .= toLC 0 0 0 255 + strokeColor .= toL Svg.FillNone + strokeWidth .= toL (Svg.Num 0) + where + toL = Last . Just + toLC r g b a = + toL . ColorRef $ PixelRGBA8 r g b a + +applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyBulletDrawAttr = execState . zoom drawAttr $ do + attrClass %= ("bullet":) + +applyDefaultLineDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyDefaultLineDrawAttr = execState . zoom drawAttr $ do + attrClass %= ("line_element":) + fillColor .= toL Svg.FillNone + strokeColor .= toLC 0 0 0 255 + strokeWidth .= toL (Svg.Num 1) + where + toL = Last . Just + toLC r g b a = + toL . ColorRef $ PixelRGBA8 r g b a + + +startPointOf :: ShapeElement -> Point +startPointOf (ShapeAnchor p _) = p +startPointOf (ShapeSegment seg) = _segStart seg + + +manathanDistance :: Point -> Point -> Int +manathanDistance a b = x + y where + V2 x y = abs <$> a ^-^ b + + +isNearBy :: Point -> Point -> Bool +isNearBy a b = manathanDistance a b <= 1 + + +initialPrevious :: Bool -> [ShapeElement] -> Maybe Point +initialPrevious False _ = Nothing +initialPrevious True [] = Nothing +initialPrevious True lst@(x:_) = Just point + where + sp = startPointOf x + + point = case last lst of + ShapeAnchor pp _ -> pp + ShapeSegment seg + | manathanDistance sp (_segStart seg) < + manathanDistance sp (_segEnd seg) -> _segStart seg + ShapeSegment seg -> _segEnd seg + + +swapSegment :: Segment -> Segment +swapSegment seg = + seg { _segStart = _segEnd seg, _segEnd = _segStart seg } + + +rollToSegment :: Shape -> Shape +rollToSegment shape | not $ shapeIsClosed shape = shape +rollToSegment shape = shape { shapeElements = segments ++ anchorPrefix } where + (anchorPrefix, segments) = span isAnchor $ shapeElements shape + + isAnchor (ShapeSegment _) = False + isAnchor (ShapeAnchor _ _) = True + + +reorderShapePoints :: Shape -> [(Maybe Point, ShapeElement)] +reorderShapePoints shape = outList where + outList = go initialPrev elements + elements = shapeElements shape + initialPrev = initialPrevious (shapeIsClosed shape) elements + + go _ [] = [] + go prev (a@(ShapeAnchor p _):rest) = + (prev, a) : go (Just p) rest + go prev (s@(ShapeSegment seg):rest) + | start == _segEnd seg = (prev, s) : go (Just start) rest + where start = _segStart seg + go prev@(Just prevPoint) (s@(ShapeSegment seg):rest) + | prevPoint `isNearBy` start = + (prev, s) : go (Just end) rest + | otherwise = + (prev, ShapeSegment $ swapSegment seg) : go (Just start) rest + where start = _segStart seg + end = _segEnd seg + go Nothing (s@(ShapeSegment seg):rest@(nextShape:_)) = + case nextShape of + ShapeAnchor p _ | p `isNearBy` start -> + (Nothing, ShapeSegment $ swapSegment seg) : go (Just start) rest + ShapeAnchor _ _ -> + (Nothing, s) : go (Just $ _segEnd seg) rest + ShapeSegment _ -> (Nothing, s) : go (Just $ _segEnd seg) rest + where start = _segStart seg + go Nothing [e@(ShapeSegment _)] = [(Nothing, e)] + + +associateNextPoint :: Bool -> [(a, ShapeElement)] + -> [(a, ShapeElement, Maybe Point)] +associateNextPoint isClosed elements = go elements where + startingPoint = + Just . startPointOf . head $ map snd elements + + go [] = [] + go [(p, s)] + | isClosed = [(p, s, startingPoint)] + | otherwise = [(p, s, Nothing)] + go ((p, s):xs@((_, y):_)) = + (p, s, Just $ startPointOf y) : go xs + + +-- > +-- > ^ perp:(0, -n) +-- > | +-- > (x, y)| (x + n, y) +-- > +-------------------+ b +-- > a| +-- > v correction +-- +correctionVectorOf :: Integral a => GridSize -> V2 a -> V2 a -> V2 Float +correctionVectorOf size a b = normalize dir ^* _gridShapeContraction size + where + dir = fromIntegral . negate <$> perp (b ^-^ a) + + +startPoint :: GridSize -> [(Maybe Point, ShapeElement, Maybe Point)] + -> Svg.RPoint +startPoint gscale shapeElems = case shapeElems of + [] -> V2 0 0 + (Just before, ShapeAnchor p _, Just after):_ -> toS p ^+^ combined + where v1 = correctionVector before p + v2 = correctionVector p after + combined | v1 == v2 = v1 + | otherwise = v1 ^+^ v2 + (before, ShapeSegment seg, _):_ -> pp ^+^ vc where + vc = segmentCorrectionVector gscale before seg + pp = toS $ _segStart seg + (_, ShapeAnchor p _, _):_ -> toS p + where + correctionVector = correctionVectorOf gscale + toS = toSvg gscale + + +anchorCorrection :: GridSize -> Point -> Point -> Point + -> Svg.RPoint +anchorCorrection scale before p after + | v1 == v2 = v1 + | otherwise = v1 ^+^ v2 + where v1 = correctionVectorOf scale before p + v2 = correctionVectorOf scale p after + + +moveTo, lineTo :: Svg.RPoint -> Svg.PathCommand +moveTo p = Svg.MoveTo Svg.OriginAbsolute [p] +lineTo p = Svg.LineTo Svg.OriginAbsolute [p] + + +smoothCurveTo :: Svg.RPoint -> Svg.RPoint -> Svg.PathCommand +smoothCurveTo p1 p = + Svg.SmoothCurveTo Svg.OriginAbsolute [(p1, p)] + + +shapeClosing :: Shape -> [Svg.PathCommand] +shapeClosing Shape { shapeIsClosed = True } = [Svg.EndPath] +shapeClosing _ = [] + + +segmentCorrectionVector :: GridSize -> Maybe Point -> Segment -> Svg.RPoint +segmentCorrectionVector gscale before seg | _segStart seg == _segEnd seg = + case (before, _segKind seg) of + (Just v1, _) -> correctionVectorOf gscale v1 (_segEnd seg) + (Nothing, SegmentHorizontal) -> V2 0 $ _gridShapeContraction gscale + (Nothing, SegmentVertical) -> V2 (negate $ _gridShapeContraction gscale) 0 +segmentCorrectionVector gscale _ seg = + correctionVectorOf gscale (_segStart seg) (_segEnd seg) + + +straightCorner :: GridSize -> Bool -> Maybe Point -> Point -> Maybe Point + -> ([Svg.PathCommand], [Svg.Tree]) +straightCorner gscale isBullet pBefore p pAfter + | isBullet = ([lineTo finalPoint], [renderBullet gscale finalPoint]) + | otherwise = ([lineTo finalPoint], []) + where + pSvg = toSvg gscale p + finalPoint = case (pBefore, pAfter) of + (Just before, Just after) -> + anchorCorrection gscale before p after ^+^ pSvg + (Just before, _) -> + correctionVectorOf gscale before p ^+^ pSvg + _ -> pSvg + +curveCorner :: GridSize -> Maybe Point -> Point -> Maybe Point -> Svg.PathCommand +curveCorner gscale _ p (Just after) = + smoothCurveTo (toS p) $ toS after ^+^ correction + where correction = correctionVectorOf gscale p after + toS = toSvg gscale +curveCorner gscale (Just before) p Nothing = + smoothCurveTo (toS p) $ toS p ^+^ vec + where vec = correctionVectorOf gscale before p + toS = toSvg gscale +curveCorner gscale _ p _ = lineTo $ toSvg gscale p + + +roundedCorner :: GridSize -> Point -> Point -> Maybe Point -> Svg.PathCommand +roundedCorner gscale p1 p2 (Just lastPoint) = + Svg.CurveTo Svg.OriginAbsolute [(toS p1, toS p2, toS lastPoint ^+^ vec)] + where toS = toSvg gscale + vec = correctionVectorOf gscale p2 lastPoint +roundedCorner gscale p1 p2 after = + curveCorner gscale (Just p1) p2 after + +toPathRooted :: [Svg.RPoint] -> GridSize -> Point -> Svg.Tree +toPathRooted pts gscale p = + applyLineArrowDrawAttr . Svg.PathTree $ Svg.Path mempty pathCommands + where + pt = fromIntegral <$> p + sizes = V2 (_gridCellWidth gscale) (_gridCellHeight gscale) + + toGrid pp = lineTo $ (pt ^+^ pp) * sizes + pathCommands = case pts of + [] -> [] + x:xs -> moveTo ((pt ^+^ x) * sizes) + : fmap toGrid xs ++ [Svg.EndPath] + +toRightArrow :: GridSize -> Point -> Svg.Tree +toRightArrow = + toPathRooted [ V2 1 0.5 + , V2 2 1 + , V2 1 1.5 + ] + +toLeftArrow :: GridSize -> Point -> Svg.Tree +toLeftArrow = + toPathRooted [ V2 1 0.5 + , V2 0 1 + , V2 1 1.5 + ] + +toTopArrow :: GridSize -> Point -> Svg.Tree +toTopArrow = + toPathRooted [ V2 0.5 1 + , V2 1.5 1 + , V2 1 0 + ] + +toBottomArrow :: GridSize -> Point -> Svg.Tree +toBottomArrow = + toPathRooted [ V2 0.5 1 + , V2 1.5 1 + , V2 1 2 + ] + +renderBullet :: GridSize -> Svg.RPoint -> Svg.Tree +renderBullet gscale (V2 x y) = applyBulletDrawAttr $ Svg.CircleTree Svg.defaultSvg + { Svg._circleCenter = (Svg.Num x, Svg.Num y) + , Svg._circleRadius = Svg.Num $ halfWidth - 2 + } + where halfWidth = _gridCellWidth gscale / 2 + +dashingSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a +dashingSet shape + | isShapeDashed shape = setDashingInformation + | otherwise = id + +classSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a +classSet shape e = + e & drawAttr . attrClass %~ (++ S.toList (shapeTags shape)) + +shapeToTree :: GridSize -> Shape -> Svg.Tree +shapeToTree gscale shape@Shape + { shapeIsClosed = True + , shapeElements = + [ ShapeSegment _ + , ShapeAnchor p0 AnchorMulti + , ShapeSegment _ + , ShapeAnchor p1 AnchorMulti + , ShapeSegment _ + , ShapeAnchor p2 AnchorMulti + , ShapeSegment _ + , ShapeAnchor p3 AnchorMulti ] + } = classSet shape + . dashingSet shape + . Svg.RectangleTree + $ Svg.defaultSvg + { Svg._rectWidth = Svg.Num sWidth + , Svg._rectHeight = Svg.Num sHeight + , Svg._rectUpperLeftCorner = (Svg.Num px, Svg.Num py) } + where + pts = [p0, p1, p2, p3] + mini = minimum pts + maxi = maximum pts + contraction = _gridShapeContraction gscale + contractionVector = V2 contraction contraction + + maxiPoint = toSvg gscale maxi ^-^ contractionVector + pt@(V2 px py) = toSvg gscale mini ^+^ contractionVector + V2 sWidth sHeight = maxiPoint ^-^ pt + + + +shapeToTree gscale shape = + case concat arrows of + [] -> svgPath + lst -> Svg.GroupTree $ Svg.defaultSvg { Svg._groupChildren = svgPath : lst } + where + toS = toSvg gscale + shapeElems = associateNextPoint (shapeIsClosed shape) + . reorderShapePoints + $ rollToSegment shape + + svgPath = classSet shape . dashingSet shape . Svg.PathTree + $ Svg.Path mempty pathCommands + + pathCommands = + moveTo (startPoint gscale shapeElems) + : concat pathes ++ shapeClosing shape + (pathes, arrows) = unzip $ toPath shapeElems + + toPath [] = [] + toPath ((before, ShapeSegment seg, Just _):rest) = + ([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest + where vc = segmentCorrectionVector gscale before seg + toPath ((before, ShapeSegment seg, Nothing):rest) = + ([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest + where vc = segmentCorrectionVector gscale before seg' + extension = signum <$> (_segEnd seg ^-^ _segStart seg) + seg' = seg { _segEnd = _segEnd seg ^+^ extension } + toPath ((_, ShapeAnchor p1 AnchorFirstDiag, _) + :(_, ShapeAnchor p2 AnchorSecondDiag, after) + :rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest + toPath ((_, ShapeAnchor p1 AnchorSecondDiag, _) + :(_, ShapeAnchor p2 AnchorFirstDiag, after) + :rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest + toPath ((before, ShapeAnchor p a, after):rest) = anchorJoin : toPath rest + where + anchorJoin = case a of + AnchorPoint -> straightCorner gscale False before p after + AnchorMulti -> straightCorner gscale False before p after + AnchorBullet -> straightCorner gscale True before p after + + AnchorFirstDiag -> ([curveCorner gscale before p after], []) + AnchorSecondDiag -> ([curveCorner gscale before p after], []) + + AnchorArrowUp -> ([lineTo $ toS p], [toTopArrow gscale p]) + AnchorArrowDown -> ([lineTo $ toS p], [toBottomArrow gscale p]) + AnchorArrowLeft -> ([lineTo $ toS p], [toLeftArrow gscale p]) + AnchorArrowRight -> ([lineTo $ toS p], [toRightArrow gscale p]) + + +textToTree :: GridSize -> TextZone -> Svg.Tree +textToTree gscale zone = Svg.TextTree Nothing txt + where + correction = + V2 (negate $ _gridCellWidth gscale) + (_gridCellHeight gscale) ^* 0.5 + V2 x y = toSvg gscale (_textZoneOrigin zone) ^+^ correction + txt = Svg.textAt (Svg.Num (x+0.5), Svg.Num (y+0.5)) $ _textZoneContent zone + +defaultCss :: Float -> T.Text +defaultCss textSize = T.pack $ printf + ("\n" <> + "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <> + ".dashed_elem { stroke-dasharray: 4, 3 }\n" <> + ".filled_shape { fill: url(#shape_light) }\n" <> + ".bullet { stroke-width: 1px; fill: white; stroke: black }\n" + ) + (2 + floor textSize :: Int) + +lightShapeGradient :: Svg.Element +lightShapeGradient = Svg.ElementLinearGradient $ + Svg.defaultSvg + { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0) + , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1) + , Svg._linearGradientStops = + [ Svg.GradientStop 0 $ PixelRGBA8 245 245 245 255 + , Svg.GradientStop 1 $ PixelRGBA8 216 216 216 255 + ] + } + +-- | Transform an Ascii diagram to a SVG document which +-- can be saved or converted to an image. +svgOfDiagram :: Diagram -> Svg.Document +svgOfDiagram diagram = Document + { _viewBox = Nothing + , _width = + toSvgSize _gridCellWidth $ _diagramCellWidth diagram + 1 + , _height = + toSvgSize _gridCellHeight $ _diagramCellHeight diagram + 1 + , _elements = closedSvg ++ lineSvg ++ textSvg + , _definitions = M.fromList + [("shape_light", lightShapeGradient)] + , _description = "" + , _styleRules = defaultCssRules ++ customCssRules + , _documentLocation = "" + } + where + (closed, opened) = S.partition shapeIsClosed shapes + + defaultCssRules = + cssRulesOfText . defaultCss $ _gridCellHeight scale + + customCssRules = + cssRulesOfText . T.unlines $ _diagramStyles diagram + + shapes = _diagramShapes diagram + + closedSvg = + applyDefaultShapeDrawAttr . shapeToTree scale <$> filter isShapePossible + (S.toList closed) + lineSvg = + applyDefaultLineDrawAttr . shapeToTree strokeScale <$> S.toList opened + + toSvgSize accessor var = + Just . Svg.Num $ fromIntegral var * accessor scale + 5 + + textSvg = textToTree scale <$> _diagramTexts diagram + + strokeScale = scale { _gridShapeContraction = 0 } + scale = GridSize + { _gridCellWidth = 10 + , _gridCellHeight = 14 + , _gridShapeContraction = 1.5 + } +