asciidiagram 1.1 → 1.1.1
raw patch · 9 files changed
+1534/−1491 lines, 9 filesdep +bytestringdep +directorydep ~FontyFruitydep ~lensdep ~rasterific-svgPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, directory
Dependency ranges changed: FontyFruity, lens, rasterific-svg
API changes (from Hackage documentation)
+ Text.AsciiDiagram: pdfOfDiagram :: FontCache -> Dpi -> Diagram -> IO ByteString
Files
- asciidiagram.cabal +8/−4
- changelog +16/−3
- exec-src/asciidiagram.hs +126/−109
- src/Text/AsciiDiagram.hs +429/−417
- src/Text/AsciiDiagram/DiagramCleaner.hs +131/−131
- src/Text/AsciiDiagram/Graph.hs +333/−336
- src/Text/AsciiDiagram/Parser.hs +224/−224
- src/Text/AsciiDiagram/Reconstructor.hs +266/−266
- src/Text/AsciiDiagram/SvgRender.hs +1/−1
asciidiagram.cabal view
@@ -1,7 +1,7 @@ -- Initial hitaa.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: asciidiagram-version: 1.1+version: 1.1.1 synopsis: Pretty rendering of Ascii diagram into svg or png. description: Asciidiagram Ascii art diagram like this:@@ -40,7 +40,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/asciidiagram.git- Tag: v1.1+ Tag: v1.1.1 library ghc-options: -O2 -Wall@@ -56,13 +56,14 @@ -- containers >= 0.5.2.1 for Set.elemAt build-depends: base >=4.6 && <4.9 , vector >= 0.10+ , bytestring , text >= 1.2 && < 1.3 , linear >= 1.16 , containers >= 0.5 , mtl >= 2.1 && < 2.3- , lens >= 4.6 && < 4.8+ , lens >= 4.6 && < 4.10 , svg-tree >= 0.3 && < 0.4- , rasterific-svg >= 0.2 && < 0.3+ , rasterific-svg >= 0.2.3 && < 0.3 , FontyFruity >= 0.5 && < 0.6 , JuicyPixels >= 3.2 @@ -75,6 +76,8 @@ ghc-options: -O2 -Wall Hs-Source-Dirs: exec-src Build-Depends: base >= 4.6+ , directory >= 1.0+ , bytestring , optparse-applicative , rasterific-svg , JuicyPixels@@ -82,4 +85,5 @@ , asciidiagram , svg-tree , text+ , FontyFruity
changelog view
@@ -1,8 +1,21 @@--*-change-log-*-+Change log+========== -v1.1+v1.1.1 May 2015+---------------++ * Fix: Removing some bad reconstructed shapes in presence of lines.+ * Fix: Bumping rasterific-svg dependency.+ * Fix: creating font cache in a temporary directory.+ * Adding: PDF output.++v1.1 April 2015+---------------+ * Bump: svg-tree & rasterific-svg dependencies -v0.1+v1.0 February 2015+------------------+ * Initial version
exec-src/asciidiagram.hs view
@@ -1,109 +1,126 @@-{-# 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 - +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-}++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>), (<*>), pure )+#endif++import Control.Applicative( (<|>) )+import Control.Monad( when )+import Data.Monoid( (<>) )++import qualified Data.ByteString.Lazy as LB+import qualified Data.Text.IO as STIO+import System.Directory( getTemporaryDirectory )+import System.FilePath( (</>)+ , replaceExtension+ , takeExtension )++import Graphics.Rasterific.Svg( loadCreateFontCache )+import Graphics.Text.TrueType( FontCache )+import Codec.Picture( writePng )+import Options.Applicative( Parser+ , ParserInfo+ , argument+ , execParser+ , flag+ , fullDesc+ , header+ , help+ , helper+ , info+ , long+ , metavar+ , progDesc+ , str+ , switch+ )+import Text.AsciiDiagram++data Options = Options+ { _inputFile :: !FilePath+ , _outputFile :: !FilePath+ , _verbose :: !Bool+ , _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+ (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)")+ <|> flag Nothing (Just FormatPdf)+ ( long "pdf"+ <> help "Force the use of the PDF format (deduced from extension otherwise)")+ )++progOptions :: ParserInfo Options+progOptions = info (helper <*> argParser)+ ( fullDesc+ <> progDesc "Convert INPUTFILE into a svg or png OUTPUTFILE"+ <> header "asciidiagram - A pretty printer for ASCII art diagram to SVG." )++formatOfOuputFilename :: FilePath -> Format+formatOfOuputFilename f = case takeExtension f of+ ".png" -> FormatPng+ ".svg" -> FormatSvg+ ".pdf" -> FormatPdf+ _ -> FormatPng++getFontCache :: Bool -> IO FontCache+getFontCache verbose = do+ when verbose $ putStrLn "Loading/Building font cache (can be long)"+ tempDir <- getTemporaryDirectory + loadCreateFontCache $ tempDir </> "asciidiagram-fonty-fontcache"++runConversion :: Options -> IO ()+runConversion opt = do+ verbose . putStrLn $ "Loading file " ++ _inputFile opt+ inputData <- STIO.readFile $ _inputFile opt+ let diag = parseAsciiDiagram inputData+ format = _format opt <|> (pure . formatOfOuputFilename $ _outputFile opt)+ case format of+ Nothing -> saveDoc diag+ Just FormatSvg -> saveDoc diag+ Just FormatPng -> savePng diag+ Just FormatPdf -> savePdf diag+ where+ verbose = when $ _verbose opt+ saveDoc diag = do+ verbose . putStrLn $ "Writing SVG file " ++ _outputFile opt+ saveAsciiDiagramAsSvg (savingPath "svg") diag++ savingPath ext = case _outputFile opt of+ "" -> replaceExtension (_inputFile opt) ext+ p -> p++ savePdf diag = do+ cache <- getFontCache $ _verbose opt+ verbose . putStrLn $ "Writing PDF file " ++ _outputFile opt+ pdf <- pdfOfDiagram cache 96 diag+ LB.writeFile (savingPath "pdf") pdf++ savePng diag = do+ cache <- getFontCache $ _verbose opt+ verbose . putStrLn $ "Writing PNG file " ++ _outputFile opt+ img <- imageOfDiagram cache 96 diag+ writePng (savingPath "png") img++main :: IO ()+main = execParser progOptions >>= runConversion+
src/Text/AsciiDiagram.hs view
@@ -1,417 +1,429 @@-{-# 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; } --- @ --- <<docimages/baseExample.svg>> --- --- To render the diagram as a PNG file, you have to use the --- library rasterific-svg and JuicyPixels. --- --- As a sample usage, to save a diagram to png, you can use --- the following snippet. --- --- > import Codec.Picture( writePng ) --- > import Text.AsciiDiagram( imageOfDiagram ) --- > import Graphics.Rasterific.Svg( loadCreateFontCache ) --- > --- > saveDiagramToFile :: FilePath -> Diagram -> IO () --- > saveDiagramToFile path diag = do --- > cache <- loadCreateFontCache "asciidiagram-fonty-fontcache" --- > imageOfDiagram cache 96 diag --- > writePng path img --- -module Text.AsciiDiagram - ( - -- $introDoc - -- * Diagram format - - -- ** Lines - -- $linesdoc - - -- ** Shapes - -- $shapesdoc - - -- ** Bullets - -- $bulletdoc - - -- ** Styles - -- $styledoc - - -- * 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 --- --- >----- --- > ------- --- > --- >| | --- >| | --- >| \---- --- >| --- >+----- --- --- <<docimages/simple_lines.svg>> --- --- You can use dashed lines by using ':' for vertical lines or '=' for\nhorizontal lines. --- --- --- @ --- ----- --- -=----- --- --- | : --- | | --- | \\---- --- | --- +--=-- --- @ --- <<docimages/dashed_lines.svg>> --- --- 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 --- @ --- <<docimages/arrows.svg>> --- - --- $shapesdoc --- If the lines are closed, then it is detected as such and rendered --- differently --- --- --- @ --- +------+ --- | | --- | +--+ --- | | | --- +---+--+ | --- | | --- +-----+ --- @ --- <<docimages/complexClosed.svg>> --- --- If any of the segment posess one of the dashing markers (\':\' or \'=\') --- Then the full shape will be dashed. --- --- --- @ --- +--+ +--+ +=-+ +=-+ --- | | : | | | | : --- +--+ +--+ +--+ +-=+ --- @ --- <<docimages/dashingClosed.svg>> --- --- Any of the angle of a shape can curved one of the smooth corner anchor --- (\'\\\' or \'\/\') --- --- --- @ --- \/--+ +--\\ +--+ \/--+ --- | | | | | | | | --- +--+ +--+ \\--+ +--+ --- --- \/--+ \/--\\ \/--+ \/--\\ . --- | | | | | | | | --- +--\/ +--+ \\--\/ +--\/ --- --- \/--\\ . --- | | --- \\--\/ --- . --- @ --- <<docimages/curvedCorner.svg>> --- - --- $bulletdoc --- Adding a \'*\' on a line or on a shape add a little circle on it. --- If the bullet is not attached to any shape or lines, then it --- will be render like any other text. --- --- --- @ --- *-*-* --- | | *----* --- +---\/ | --- * * * --- @ --- <<docimages/bulletTest.svg>> --- --- When used at connection points, it behaves like the \'+\' anchor. --- - --- $styledoc --- The shapes can ba annotated with a tag like `{tagname}`. --- Tags will be inserted in the class attribute of the shape --- and can then be stylized with a CSS. --- --- --- @ --- +--------+ +--------+ --- | Source +--------\>| op1 | --- | {src} | \\---+----\/ --- +--------+ | --- +-------*\<--\/ --- +------+\<--| op2 | --- | Dest | +-------+ --- |{dst} | --- +------+ --- --- ::: .src { fill: #AAF; } --- ::: .dst { stroke: #FAA; stroke-width: 3px; } --- @ --- <<docimages/styleExample.svg>> --- --- Inline css styles are introduced with the ":::" prefix --- at the beginning of the line. They are introduced in the --- style section of the generated CSS file --- --- The generated geometry also possess some predefined class --- which are overidable: --- --- * `dashed_elem` is 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. --- +{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+-- | This module gives access to the ascii diagram parser and+-- SVG renderer.+--+-- Ascii diagram, transform your ASCII art drawing to a nicer+-- representation+-- +-- @+-- \/---------++-- +---------+ | |+-- | ASCII +----\>| Diagram |+-- +---------+ | |+-- |{flat} | +--+------\/+-- \\---*-----\/\<=======\/+-- ::: .flat { fill: #DDD; }+-- @+-- <<docimages/baseExample.svg>>+-- +-- To render the diagram as a PNG file, you have to use the+-- library rasterific-svg and JuicyPixels.+--+-- As a sample usage, to save a diagram to png, you can use+-- the following snippet.+--+-- > import Codec.Picture( writePng )+-- > import Text.AsciiDiagram( imageOfDiagram )+-- > import Graphics.Rasterific.Svg( loadCreateFontCache )+-- >+-- > saveDiagramToFile :: FilePath -> Diagram -> IO ()+-- > saveDiagramToFile path diag = do+-- > cache <- loadCreateFontCache "asciidiagram-fonty-fontcache"+-- > imageOfDiagram cache 96 diag+-- > writePng path img+--+module Text.AsciiDiagram+ ( + -- $introDoc+ -- * Diagram format++ -- ** Lines+ -- $linesdoc++ -- ** Shapes+ -- $shapesdoc++ -- ** Bullets+ -- $bulletdoc++ -- ** Styles+ -- $styledoc++ -- * Usage example+ -- $example++ -- * Functions+ svgOfDiagram+ , parseAsciiDiagram+ , saveAsciiDiagramAsSvg+ , imageOfDiagram+ , pdfOfDiagram++ -- * Document description+ , Diagram( .. ) + , TextZone( .. )+ , Shape( .. )+ , ShapeElement( .. )+ , Anchor( .. )+ , Segment( .. )+ , SegmentKind( .. )+ , SegmentDraw( .. )+ , Point+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+#endif++import Data.Monoid( (<>))+import Control.Monad( forM_ )+import Control.Monad.ST( runST )+import Control.Monad.State.Strict( runState, put, get )+import Data.Function( on )+import Data.List( partition, sortBy )+import qualified Data.ByteString.Lazy as LB+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import Linear( V2( V2 ) )++import Text.AsciiDiagram.Parser+import Text.AsciiDiagram.Reconstructor+import Text.AsciiDiagram.SvgRender+import Text.AsciiDiagram.Geometry+import Text.AsciiDiagram.DiagramCleaner++import Codec.Picture( Image, PixelRGBA8 )+import Graphics.Text.TrueType( FontCache )+import Graphics.Svg( Dpi, saveXmlFile )+import Graphics.Rasterific.Svg( renderSvgDocument, pdfOfSvgDocument )++{-import Debug.Trace-}+{-import Text.Groom-}+{-import Text.Printf-}++data CharBoard = CharBoard+ { _boardWidth :: !Int+ , _boardHeight :: !Int+ , _boardData :: !(VU.Vector Char)+ }+ deriving (Eq, Show)++textOfCharBoard :: CharBoard -> [T.Text]+textOfCharBoard board = fetch <$> zip [0 .. h - 1] [0, w..] where+ w = _boardWidth board+ h = _boardHeight board+ charData = _boardData board++ fetch (_, startIdx) =+ T.pack . VU.toList . VU.take w $ VU.drop startIdx charData++charBoardOfText :: [T.Text] -> CharBoard+charBoardOfText textLines = CharBoard+ { _boardWidth = twidth+ , _boardHeight = theight+ , _boardData = charData+ }+ where+ twidth = maximum $ fmap T.length textLines+ theight = length textLines+ + lineIndices = zip [0, twidth ..] textLines++ charData = runST $ do+ emptyBoard <- VUM.replicate (twidth * theight) ' '++ forM_ lineIndices $ \(lineIndex, l) -> do+ let chars = zip [lineIndex, lineIndex + 1 ..] $ T.unpack l+ forM_ chars $ \(idx, c) -> do+ VUM.unsafeWrite emptyBoard idx c++ VU.unsafeFreeze emptyBoard++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++-- | Render a Diagram into a PDF file. IO dependency to allow+-- loading of the font files used in the document.+pdfOfDiagram :: FontCache -> Dpi -> Diagram -> IO LB.ByteString+pdfOfDiagram cache dpi =+ fmap fst . pdfOfSvgDocument 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+-- +-- >----- +-- > ------- +-- > +-- >| | +-- >| | +-- >| \---- +-- >| +-- >+----- +--+-- <<docimages/simple_lines.svg>>+-- +-- You can use dashed lines by using ':' for vertical lines or '=' for\nhorizontal lines.+-- +-- +-- @+-- ----- +-- -=----- +-- +-- | : +-- | | +-- | \\---- +-- | +-- +--=-- +-- @+-- <<docimages/dashed_lines.svg>>+-- +-- 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+-- @+-- <<docimages/arrows.svg>>+-- ++-- $shapesdoc+-- If the lines are closed, then it is detected as such and rendered+-- differently+-- +-- +-- @+-- +------++-- | |+-- | +--++-- | | |+-- +---+--+ |+-- | |+-- +-----++-- @+-- <<docimages/complexClosed.svg>>+-- +-- If any of the segment posess one of the dashing markers (\':\' or \'=\')+-- Then the full shape will be dashed.+-- +-- +-- @+-- +--+ +--+ +=-+ +=-++-- | | : | | | | :+-- +--+ +--+ +--+ +-=++-- @+-- <<docimages/dashingClosed.svg>>+-- +-- Any of the angle of a shape can curved one of the smooth corner anchor+-- (\'\\\' or \'\/\')+-- +-- +-- @+-- \/--+ +--\\ +--+ \/--++-- | | | | | | | |+-- +--+ +--+ \\--+ +--++-- +-- \/--+ \/--\\ \/--+ \/--\\ .+-- | | | | | | | |+-- +--\/ +--+ \\--\/ +--\/+-- +-- \/--\\ .+-- | |+-- \\--\/+-- .+-- @+-- <<docimages/curvedCorner.svg>>+-- ++-- $bulletdoc+-- Adding a \'*\' on a line or on a shape add a little circle on it.+-- If the bullet is not attached to any shape or lines, then it+-- will be render like any other text.+-- +-- +-- @+-- *-*-*+-- | | *----*+-- +---\/ |+-- * * *+-- @+-- <<docimages/bulletTest.svg>>+-- +-- When used at connection points, it behaves like the \'+\' anchor.+-- ++-- $styledoc+-- The shapes can ba annotated with a tag like `{tagname}`.+-- Tags will be inserted in the class attribute of the shape+-- and can then be stylized with a CSS.+-- +-- +-- @+-- +--------+ +--------++-- | Source +--------\>| op1 |+-- | {src} | \\---+----\/+-- +--------+ |+-- +-------*\<--\/+-- +------+\<--| op2 |+-- | Dest | +-------++-- |{dst} |+-- +------++-- +-- ::: .src { fill: #AAF; }+-- ::: .dst { stroke: #FAA; stroke-width: 3px; }+-- @+-- <<docimages/styleExample.svg>>+-- +-- Inline css styles are introduced with the ":::" prefix+-- at the beginning of the line. They are introduced in the+-- style section of the generated CSS file+-- +-- The generated geometry also possess some predefined class+-- which are overidable:+-- +-- * `dashed_elem` is 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.+--
src/Text/AsciiDiagram/DiagramCleaner.hs view
@@ -1,131 +1,131 @@-{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} -module Text.AsciiDiagram.DiagramCleaner - ( isShapePossible - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -import Control.Applicative( Applicative, (<*>) ) -#endif - -import Control.Applicative( (<$>), liftA2 ) -import Data.List( tails ) -import Text.AsciiDiagram.Geometry -import Linear( V2( V2 ) - , (^-^) - ) - -compareDirections :: Applicative f - => (Int -> Int -> Bool) -> f Int -> f Int -> f Bool -compareDirections f = liftA2 diffSign - where - diffSign 0 0 = True - diffSign aa bb = f aa bb - -checkRoundedCorners :: (Int -> Int -> Bool) - -> Segment -> Point -> Point -> Segment - -> Bool -checkRoundedCorners f s1 ap1 ap2 s2 = okX && okY - where - V2 dirX dirY = ap2 ^-^ ap1 - fromS1 = _segEnd s1 ^-^ ap1 - fromS2 = _segStart s2 ^-^ ap2 - - signDirs = signum <$> V2 dirY dirX - - V2 okX okY = (&&) - <$> (compareDirections f signDirs (signum <$> fromS1)) - <*> (compareDirections f signDirs (signum <$> fromS2)) - -checkClosedShape :: Shape -> Bool -checkClosedShape shape = all checkClosed elements where - elements = - (++ shapeElements shape) <$> tails (shapeElements shape) - - - -checkClosed :: [ShapeElement] -> Bool --- dir fromS1 fromS1 --- ---> -----> <---- ^ 2 \--- 3 --- /\ | 1 /---- 0 0 ----/ 1 | | \ --- 1/ \2 dir | / / | dir dir | / --- | | | \ \ | | 1 /--- 0 --- 0| |3 v 2 \---- 3 3 ----\ 2 v --- -----> <---- --- fromS2 fromS2 --- --- OK OK BAD BAD -checkClosed - ( ShapeSegment s1 - : ShapeAnchor ap1 AnchorFirstDiag -- '/' - : ShapeAnchor ap2 AnchorSecondDiag -- '\' - : ShapeSegment s2 - : _) = checkRoundedCorners (==) s1 ap1 ap2 s2 - --- dir fromS1 fromS1 --- ---> -----> <---- ^ 1 \--- 0 --- /\ | 2 /---- 3 3 ----/ 2 | | \ --- 2/ \1 dir | / / | dir dir | / --- | | | \ \ | | 2 /--- 3 --- 3| |0 v 1 \---- 0 0 ----\ 1 v --- -----> <---- --- fromS2 fromS2 --- --- OK OK BAD BAD -checkClosed - ( ShapeSegment s1 - : ShapeAnchor ap1 AnchorSecondDiag -- '\' - : ShapeAnchor ap2 AnchorFirstDiag -- '/' - : ShapeSegment s2 - : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2 - -checkClosed - ( ShapeAnchor _ AnchorFirstDiag - : ShapeAnchor _ AnchorSecondDiag - : ShapeAnchor _ AnchorFirstDiag - : ShapeAnchor _ AnchorSecondDiag - : _) = False - -checkClosed - ( ShapeAnchor _ AnchorSecondDiag - : ShapeAnchor _ AnchorFirstDiag - : ShapeAnchor _ AnchorSecondDiag - : ShapeAnchor _ AnchorFirstDiag - : _) = False - -checkClosed _ = True - -isBullet :: ShapeElement -> Bool -isBullet (ShapeAnchor _ AnchorBullet) = True -isBullet _ = False - -checkOpened :: [ShapeElement] -> Bool -checkOpened - [ ShapeAnchor _ AnchorFirstDiag - , ShapeAnchor _ AnchorSecondDiag] = False -checkOpened [ ShapeAnchor _ AnchorSecondDiag - , ShapeAnchor _ AnchorFirstDiag] = False -checkOpened (all isBullet -> True) = False -checkOpened - ( ShapeAnchor ap1 AnchorFirstDiag -- '/' - : ShapeAnchor ap2 AnchorSecondDiag -- '\' - : ShapeSegment s2 - : _) = checkRoundedCorners (==) s1 ap1 ap2 s2 - where s1 = mempty { _segEnd = ap1 } -checkOpened - ( ShapeAnchor ap1 AnchorSecondDiag -- '\' - : ShapeAnchor ap2 AnchorFirstDiag -- '/' - : ShapeSegment s2 - : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2 - where s1 = mempty { _segEnd = ap1 } -checkOpened _ = True - -checkOpenedShape :: Shape -> Bool -checkOpenedShape = checkOpened . shapeElements - -isShapePossible :: Shape -> Bool -isShapePossible shape - | shapeIsClosed shape = checkClosedShape shape - | otherwise = checkOpenedShape shape - +{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+module Text.AsciiDiagram.DiagramCleaner+ ( isShapePossible+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( Applicative, (<*>), (<$>) )+#endif++import Control.Applicative( liftA2 )+import Data.List( tails )+import Text.AsciiDiagram.Geometry+import Linear( V2( V2 )+ , (^-^)+ )++compareDirections :: Applicative f+ => (Int -> Int -> Bool) -> f Int -> f Int -> f Bool+compareDirections f = liftA2 diffSign+ where+ diffSign 0 0 = True+ diffSign aa bb = f aa bb++checkRoundedCorners :: (Int -> Int -> Bool)+ -> Segment -> Point -> Point -> Segment+ -> Bool+checkRoundedCorners f s1 ap1 ap2 s2 = okX && okY+ where+ V2 dirX dirY = ap2 ^-^ ap1+ fromS1 = _segEnd s1 ^-^ ap1+ fromS2 = _segStart s2 ^-^ ap2 ++ signDirs = signum <$> V2 dirY dirX++ V2 okX okY = (&&)+ <$> (compareDirections f signDirs (signum <$> fromS1))+ <*> (compareDirections f signDirs (signum <$> fromS2))++checkClosedShape :: Shape -> Bool+checkClosedShape shape = all checkClosed elements where+ elements =+ (++ shapeElements shape) <$> tails (shapeElements shape) ++++checkClosed :: [ShapeElement] -> Bool+-- dir fromS1 fromS1+-- ---> -----> <---- ^ 2 \--- 3+-- /\ | 1 /---- 0 0 ----/ 1 | | \+-- 1/ \2 dir | / / | dir dir | /+-- | | | \ \ | | 1 /--- 0+-- 0| |3 v 2 \---- 3 3 ----\ 2 v+-- -----> <----+-- fromS2 fromS2+-- +-- OK OK BAD BAD+checkClosed+ ( ShapeSegment s1+ : ShapeAnchor ap1 AnchorFirstDiag -- '/'+ : ShapeAnchor ap2 AnchorSecondDiag -- '\'+ : ShapeSegment s2+ : _) = checkRoundedCorners (==) s1 ap1 ap2 s2++-- dir fromS1 fromS1+-- ---> -----> <---- ^ 1 \--- 0+-- /\ | 2 /---- 3 3 ----/ 2 | | \+-- 2/ \1 dir | / / | dir dir | /+-- | | | \ \ | | 2 /--- 3+-- 3| |0 v 1 \---- 0 0 ----\ 1 v+-- -----> <----+-- fromS2 fromS2+-- +-- OK OK BAD BAD+checkClosed+ ( ShapeSegment s1+ : ShapeAnchor ap1 AnchorSecondDiag -- '\'+ : ShapeAnchor ap2 AnchorFirstDiag -- '/'+ : ShapeSegment s2+ : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2++checkClosed+ ( ShapeAnchor _ AnchorFirstDiag+ : ShapeAnchor _ AnchorSecondDiag+ : ShapeAnchor _ AnchorFirstDiag+ : ShapeAnchor _ AnchorSecondDiag+ : _) = False++checkClosed+ ( ShapeAnchor _ AnchorSecondDiag+ : ShapeAnchor _ AnchorFirstDiag+ : ShapeAnchor _ AnchorSecondDiag+ : ShapeAnchor _ AnchorFirstDiag+ : _) = False++checkClosed _ = True++isBullet :: ShapeElement -> Bool+isBullet (ShapeAnchor _ AnchorBullet) = True+isBullet _ = False++checkOpened :: [ShapeElement] -> Bool+checkOpened+ [ ShapeAnchor _ AnchorFirstDiag+ , ShapeAnchor _ AnchorSecondDiag] = False+checkOpened [ ShapeAnchor _ AnchorSecondDiag+ , ShapeAnchor _ AnchorFirstDiag] = False+checkOpened (all isBullet -> True) = False+checkOpened+ ( ShapeAnchor ap1 AnchorFirstDiag -- '/'+ : ShapeAnchor ap2 AnchorSecondDiag -- '\'+ : ShapeSegment s2+ : _) = checkRoundedCorners (==) s1 ap1 ap2 s2+ where s1 = mempty { _segEnd = ap1 }+checkOpened+ ( ShapeAnchor ap1 AnchorSecondDiag -- '\'+ : ShapeAnchor ap2 AnchorFirstDiag -- '/'+ : ShapeSegment s2+ : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2+ where s1 = mempty { _segEnd = ap1 }+checkOpened _ = True++checkOpenedShape :: Shape -> Bool+checkOpenedShape = checkOpened . shapeElements++isShapePossible :: Shape -> Bool+isShapePossible shape+ | shapeIsClosed shape = checkClosedShape shape+ | otherwise = checkOpenedShape shape+
src/Text/AsciiDiagram/Graph.hs view
@@ -1,336 +1,333 @@-{-# 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 +{-# 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 )+import Control.Applicative( (<$>) )+#endif++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+ }++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)+ => 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 )+ => 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 )+ => 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 )+ => 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 )+ => 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+ => 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+ visited . at v ?= ()+ nextVertice <-+ findCounterClockwiseMost (Just prevVertice) v+ follow (v:history) v nextVertice++ follow [rootNode] rootNode startNode+ visited .= mempty+ where+ extractIfAlone node = do+ (startCount, adjs) <- adjacencyInfoOfVertice node+ when (startCount == 1) $ do+ filament <- extractFilament node $ S.findMin adjs+ addFilament filament++extractAllPrimitives :: PlanarVertice v+ => 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+
src/Text/AsciiDiagram/Parser.hs view
@@ -1,224 +1,224 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} --- | Module in charge of finding the various segment --- in an ASCII text and the various anchors. -module Text.AsciiDiagram.Parser( ParsingState( .. ) - , parseText - , parseTextLines - , extractTextZones - , detectTagFromTextZone - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -#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 - +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+-- | Module in charge of finding the various segment+-- in an ASCII text and the various anchors.+module Text.AsciiDiagram.Parser( ParsingState( .. )+ , parseText+ , parseTextLines+ , extractTextZones+ , detectTagFromTextZone+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( (<$>) )+#endif++import Control.Monad( foldM, when )+import Control.Monad.State.Strict( State+ , execState+ , modify )+import qualified Data.Foldable as F+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Traversable as TT+import qualified Data.Vector.Unboxed as VU+import Linear( V2( .. ) )++import Text.AsciiDiagram.Geometry++isAnchor :: Char -> Bool+isAnchor c = c `VU.elem` anchors+ where+ anchors = VU.fromList "<>^vV+/\\*"+ +anchorOfChar :: Char -> Anchor+anchorOfChar '+' = AnchorMulti+anchorOfChar '/' = AnchorFirstDiag+anchorOfChar '\\' = AnchorSecondDiag+anchorOfChar '>' = AnchorArrowRight+anchorOfChar '<' = AnchorArrowLeft+anchorOfChar '^' = AnchorArrowUp+anchorOfChar 'V' = AnchorArrowDown+anchorOfChar 'v' = AnchorArrowDown+anchorOfChar '*' = AnchorBullet+anchorOfChar _ = AnchorMulti++isHorizontalLine :: Char -> Bool+isHorizontalLine c = c `VU.elem` horizontalLineElements+ where+ horizontalLineElements = VU.fromList "-="++isVerticalLine :: Char -> Bool+isVerticalLine c = c `VU.elem` verticalLineElements+ where+ verticalLineElements = VU.fromList ":|"++isDashed :: Char -> Bool+isDashed c = case c of+ ':' -> True+ '=' -> True+ _ -> False+++data ParsingState = ParsingState+ { anchorMap :: !(M.Map Point Anchor)+ , segmentSet :: !(S.Set Segment)+ , currentSegment :: !(Maybe Segment)+ , styleLine :: [(Int, T.Text)]+ }+ deriving Show++emptyParsingState :: ParsingState+emptyParsingState = ParsingState+ { anchorMap = mempty+ , segmentSet = mempty+ , currentSegment = Nothing+ , styleLine = mempty+ }++type Parsing = State ParsingState++type LineNumber = Int++addAnchor :: Point -> Char -> Parsing ()+addAnchor p c = modify $ \s ->+ s { anchorMap = M.insert p (anchorOfChar c) $ anchorMap s }++addSegment :: Segment -> Parsing ()+addSegment seg = modify $ \s ->+ s { segmentSet = S.insert seg $ segmentSet s }++addStyleLine :: (Int, T.Text) -> Parsing ()+addStyleLine l = modify $ \s ->+ s { styleLine = l : styleLine s }++continueHorizontalSegment :: Point -> Parsing ()+continueHorizontalSegment p = modify $ \s ->+ s { currentSegment = Just . update $ currentSegment s }+ where update Nothing = mempty { _segStart = p+ , _segEnd = p+ , _segKind = SegmentHorizontal+ }+ update (Just seg) = seg { _segEnd = p+ , _segKind = SegmentHorizontal+ }++setHorizontaDashing :: Parsing ()+setHorizontaDashing = modify $ \s ->+ s { currentSegment = setDashed <$> currentSegment s }+ where+ setDashed seg = seg { _segDraw = SegmentDashed }++stopHorizontalSegment :: Parsing ()+stopHorizontalSegment = modify $ \s ->+ s { segmentSet = inserter (currentSegment s) $ segmentSet s+ , currentSegment = Nothing+ }+ where+ inserter Nothing s = s+ inserter (Just seg) s = S.insert seg s++continueVerticalSegment :: Maybe Segment -> Point -> Parsing (Maybe Segment)+continueVerticalSegment Nothing p = return $ Just seg where+ seg = mempty { _segStart = p+ , _segEnd = p+ , _segKind = SegmentVertical }+continueVerticalSegment (Just seg) p =+ return $ Just seg { _segEnd = p, _segKind = SegmentVertical }++stopVerticalSegment :: Maybe Segment -> Parsing (Maybe a)+stopVerticalSegment Nothing = return Nothing+stopVerticalSegment (Just seg) = do+ addSegment seg+ return Nothing++parseLine :: [Maybe Segment] -> (LineNumber, T.Text)+ -> Parsing [Maybe Segment]+parseLine prevSegments (n, T.stripPrefix ":::" -> Just txt) = do+ addStyleLine (n, txt)+ return prevSegments+parseLine prevSegments (lineNumber, txt) = do+ ret <- TT.mapM go $ zip3 [0 ..] prevSegments stringLine+ stopHorizontalSegment+ return ret+ where+ stringLine = T.unpack txt ++ repeat ' '++ go (columnNumber, vertical, c) | isHorizontalLine c = do+ let point = V2 columnNumber lineNumber+ continueHorizontalSegment point+ when (isDashed c) $ setHorizontaDashing+ stopVerticalSegment vertical++ go (columnNumber, vertical, c) | isVerticalLine c = do+ let point = V2 columnNumber lineNumber+ dashingSet seg+ | isDashed c = seg { _segDraw = SegmentDashed }+ | otherwise = seg+ stopHorizontalSegment+ fmap dashingSet <$> continueVerticalSegment vertical point++ go (columnNumber, vertical, c) | isAnchor c = do+ let point = V2 columnNumber lineNumber+ addAnchor point c+ stopHorizontalSegment+ stopVerticalSegment vertical++ go (_, vertical, _) = do+ stopHorizontalSegment+ stopVerticalSegment vertical++maximumLineLength :: [T.Text] -> Int+maximumLineLength [] = 0+maximumLineLength lst = maximum $ T.length <$> lst++parseTextLines :: [T.Text] -> ParsingState+parseTextLines lst = flip execState emptyParsingState $ do+ let initialLine = replicate (maximumLineLength lst) Nothing+ lastVerticalLine <- foldM parseLine initialLine $ zip [0 ..] lst+ mapM_ stopVerticalSegment lastVerticalLine + ++-- | Extract the segment information of a given text.+parseText :: T.Text -> ParsingState+parseText = parseTextLines . T.lines++zoneFromLine :: (Int, T.Text) -> [TextZone]+zoneFromLine (lineIndex, line) = eatSpaces 0 $ T.split (== ' ') line where+ eatSpaces ix lst = case lst of+ [] -> []+ ("":rest) -> eatSpaces (ix + 1) rest+ _ -> createZoneFrom ix lst++ createZoneFrom ix = go ix where+ go endIdx [] | ix == endIdx = []+ go _ [] = [TextZone (V2 ix lineIndex) $ T.drop ix line]+ go endIdx ("":rest) = zone : eatSpaces (endIdx + 1) rest+ where origin = V2 ix lineIndex+ zone = TextZone origin . T.drop ix $ T.take endIdx line+ go endIdx (x:xs) = go (endIdx + T.length x + 1) xs++extractTextZones :: [T.Text] -> [TextZone]+extractTextZones = F.concatMap zoneFromLine . zip [0 ..]++detectTagFromTextZone :: [TextZone] -> ([TextZone], [TextZone])+detectTagFromTextZone zones = (concat foundTags, concat normalZones) where+ (foundTags, normalZones) = unzip $ fmap findTag zones++ findTag zone@(TextZone (V2 x y) txt) =+ case splitTags y x $ T.split (== ' ') txt of+ ([], _) -> ([], [zone])+ tagsAndText -> tagsAndText++ splitTags _ _ [] = ([], [])+ splitTags y ix (thisTxt : rest)+ | tlength >= 3 && T.head thisTxt == '{' && T.last thisTxt == '}' = + (TextZone (V2 ix y) tagText: afterTags, normalTexts)+ | otherwise = (afterTags, TextZone (V2 ix y) thisTxt : normalTexts)+ where tlength = T.length thisTxt+ tagText = T.init $ T.drop 1 thisTxt+ (afterTags, normalTexts) = splitTags y (ix + tlength + 1) rest+
src/Text/AsciiDiagram/Reconstructor.hs view
@@ -1,266 +1,266 @@-{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | This module will try to reconstruct closed shapes and --- lines from -- the set of anchors and segments. --- --- The output of this module may be duplicated, needing --- deduplication as post processing. --- --- This is mostly a depth first search in the set of anchors --- and segments. -module Text.AsciiDiagram.Reconstructor( reconstruct ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -#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 - +{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | This module will try to reconstruct closed shapes and+-- lines from -- the set of anchors and segments.+--+-- The output of this module may be duplicated, needing+-- deduplication as post processing.+--+-- This is mostly a depth first search in the set of anchors+-- and segments.+module Text.AsciiDiagram.Reconstructor( reconstruct ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( (<$>) )+#endif++import Control.Monad( when )+import Control.Monad.State.Strict( execState )+import Control.Monad.State.Class( get )+import Data.Function( on )+import Data.List( sortBy )+import Data.Maybe( catMaybes )+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V+import Linear( V2( .. ), (^+^), (^-^) )++import Text.AsciiDiagram.Geometry+import Text.AsciiDiagram.Graph+import Control.Lens++{-import Debug.Trace-}+{-import Text.Printf-}+{-import Text.Groom-}++data Direction+ = LeftToRight+ | RightToLeft+ | TopToBottom+ | BottomToTop+ | NoDirection+ deriving (Eq, Show)++++directionOfVector :: Vector -> Direction+directionOfVector (V2 0 n)+ | n > 0 = TopToBottom+ | otherwise = BottomToTop+directionOfVector (V2 n 0)+ | n > 0 = LeftToRight+ | otherwise = RightToLeft+directionOfVector _ = NoDirection++++--+-- ****|****+-- *** | ***+-- ** 1 **+-- * | *+-- -----0----+---2------+-- * ^ *+-- ** : **+-- *** : ***+-- ****:****+--+--+-- ****|****+-- *** | ***+-- ** 0 **+-- * | *+-- =========>+---1------+-- * | *+-- ** 2 **+-- *** | ***+-- ****|****+--+--+-- ****|****+-- *** | ***+-- ** 2 **+-- * | *+-- -----1----+<=========+-- * | *+-- ** 0 **+-- *** | ***+-- ****|****+--+--+-- ****:****+-- *** : ***+-- ** : **+-- * V *+-- -----2----+---0------+-- * | *+-- ** 1 **+-- *** | ***+-- ****|****+--+vectorsForAnchor :: Anchor -> Direction -> [Vector]+vectorsForAnchor anchor dir = case (anchor, dir) of+ (AnchorArrowUp, _) -> [down]+ (AnchorArrowDown, _) -> [up]+ (AnchorArrowLeft, _) -> [right]+ (AnchorArrowRight, _) -> [left]++ (_, LeftToRight) -> [up, right, down, left]+ (_, TopToBottom) -> [right, down, left, up]+ (_, NoDirection) -> [right, down, left, up]+ (_, RightToLeft) -> [down, left, up, right]+ (_, BottomToTop) -> [left, up, right, down]++ where+ left = V2 (-1) 0+ up = V2 0 (-1)+ right = V2 1 0+ down = V2 0 1++directionVectorOf :: Point -> Point -> Vector+directionVectorOf a b = signum <$> a ^-^ b++nextDirectionAfterAnchor :: Anchor -> Point -> Point -> [Point]+nextDirectionAfterAnchor anchor previousPoint anchorPosition =+ [delta | delta <- deltas+ , let nextPoint = anchorPosition ^+^ delta+ , nextPoint /= previousPoint]+ where+ directionVector = directionVectorOf anchorPosition previousPoint+ direction = directionOfVector directionVector+ deltas = vectorsForAnchor anchor direction++nextPointAfterAnchor :: Anchor -> Point -> Point -> [Point]+nextPointAfterAnchor anchor prev p =+ (^+^ p) <$> nextDirectionAfterAnchor anchor prev p++segmentManathanLength :: Segment -> Int+segmentManathanLength seg = x + y where+ V2 x y = abs <$> _segEnd seg ^-^ _segStart seg+++segmentDirectionMap :: S.Set Segment -> M.Map Point SegmentKind+segmentDirectionMap = S.fold go mempty where+ go seg = M.insert (_segEnd seg) k . M.insert (_segStart seg) k+ where+ k = _segKind seg++toGraph :: M.Map Point Anchor -> S.Set Segment+ -> Graph Point ShapeElement Segment+toGraph anchors segs = execState graphCreator baseGraph where+ baseGraph = graphOfVertices $ M.mapWithKey ShapeAnchor anchors++ segDirs = segmentDirectionMap segs++ graphCreator = do+ F.traverse_ linkSegments segs+ F.traverse_ linkAnchors $ M.assocs anchors++ linkOf p1 p2 | p1 < p2 = (p1, p2)+ | otherwise = (p2, p1)++ linkAnchors (p, a) = F.traverse_ createLinks nextPoints where+ nextPoints = nextPointAfterAnchor a (V2 (-1) (-1)) p+ createLinks nextPoint = do+ nextExists <- has (vertices . ix nextPoint) <$> get+ let dirNext = nextPoint ^-^ p+ nextP = M.lookup nextPoint anchors+ nextS = M.lookup nextPoint segDirs+ nextIsOk = case (nextP, nextS) of+ (Just AnchorArrowUp, _) -> V2 0 (-1) == dirNext+ (Just AnchorArrowDown, _) -> V2 0 1 == dirNext+ (Just AnchorArrowLeft, _) -> V2 (-1) 0 == dirNext+ (Just AnchorArrowRight, _) -> V2 1 0 == dirNext+ (Just _, _) -> True+ (Nothing, Nothing) -> True+ (Nothing, Just SegmentHorizontal) ->+ (abs <$> dirNext) == V2 1 0+ (Nothing, Just SegmentVertical) ->+ (abs <$> dirNext) == V2 0 1++ alreadyLinked <- has (edges . ix (linkOf p nextPoint)) <$> get+ when (nextExists && nextIsOk && not alreadyLinked) $+ edges . at (linkOf p nextPoint) ?= mempty++ linkSegments seg | segmentManathanLength seg == 0 = do+ vertices . at (_segStart seg ) ?= ShapeSegment seg+ linkSegments seg@(Segment { _segStart = p1, _segEnd = p2 }) = do+ vertices . at p1 ?= ShapeSegment seg+ vertices . at p2 ?= ShapeSegment seg+ edges . at (linkOf p1 p2) ?= seg++findClockwisePossible :: S.Set Point -> Maybe Point -> Point+ -> [Point]+findClockwisePossible adjacents Nothing p =+ findClockwisePossible adjacents (Just p) p+findClockwisePossible adjacents (Just prev) p =+ fmap snd $ sortBy (compare `on` fst) indexedAdjacents+ where+ -- don't care about specific direction, restrictions should have+ -- been made during the construction of the graph.+ dirArray = V.fromList $ nextDirectionAfterAnchor AnchorMulti prev p+ zipIndex k = (V.elemIndex dir dirArray, k)+ where dir = directionVectorOf k p+ indexedAdjacents =+ [(idx, nextPoint)+ | (Just idx, nextPoint) <- zipIndex <$> S.elems adjacents+ , nextPoint /= prev]++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x++instance PlanarVertice (V2 Int) where+ getClockwiseMost adj prev =+ safeHead . findClockwisePossible adj prev+ getCounterClockwiseMost adj prev =+ safeHead . reverse . findClockwisePossible adj prev++dedupEqual :: Eq a => [a] -> [a]+dedupEqual [] = []+dedupEqual (x:rest@(y:_)) | x == y = dedupEqual rest+dedupEqual (x:xs) = x : dedupEqual xs+++-- | Break filaments at multi anchor to ensure proper dashing+-- of the segments.+breakFilaments :: Filament ShapeElement -> [Filament ShapeElement]+breakFilaments = go where+ go lst = f : fs+ where (f, fs) = breaker lst++ breaker [] = ([], [])+ breaker [a@(ShapeAnchor _ AnchorMulti)] = ([a], [])+ breaker (a@(ShapeAnchor _ AnchorMulti):xs) = ([a], (a:filamentRest):others)+ where (filamentRest, others) = breaker xs+ breaker (x:xs) = (x:filamentRest, others)+ where (filamentRest, others) = breaker xs+++-- | Main call of the reconstruction function+reconstruct :: M.Map Point Anchor -> S.Set Segment+ -> S.Set Shape+reconstruct anchors segments =+ S.fromList $ fmap toShapes cycles + ++ concatMap toFilaments filaments+ where+ graph = toGraph anchors segments+ (cycles, filaments) = extractAllPrimitives graph++ toElems = dedupEqual+ . filter (/= ShapeSegment mempty)+ . catMaybes+ . fmap (`M.lookup` _vertices graph)++ toFilaments shapes =+ [Shape piece False mempty | piece <- breakFilaments $ toElems shapes] ++ toShapes shapes = Shape (toElems shapes) True mempty+
src/Text/AsciiDiagram/SvgRender.hs view
@@ -4,9 +4,9 @@ #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty )+import Control.Applicative( (<$>) ) #endif -import Control.Applicative( (<$>) ) import Control.Monad.State.Strict( execState ) import Data.Monoid( Last( .. ), (<>) )