asciidiagram 1.3.2 → 1.3.3
raw patch · 12 files changed
+2853/−2849 lines, 12 files
Files
- asciidiagram.cabal +91/−91
- changelog.md +58/−54
- exec-src/asciidiagram.hs +178/−178
- src/Text/AsciiDiagram.hs +628/−628
- src/Text/AsciiDiagram/BoundingBoxEstimation.hs +124/−124
- src/Text/AsciiDiagram/DefaultContext.hs +151/−151
- src/Text/AsciiDiagram/DiagramCleaner.hs +131/−131
- src/Text/AsciiDiagram/Geometry.hs +132/−132
- src/Text/AsciiDiagram/Graph.hs +333/−333
- src/Text/AsciiDiagram/Parser.hs +224/−224
- src/Text/AsciiDiagram/Reconstructor.hs +266/−266
- src/Text/AsciiDiagram/SvgRender.hs +537/−537
asciidiagram.cabal view
@@ -1,91 +1,91 @@--- Initial hitaa.cabal generated by cabal init. For further documentation,--- see http://haskell.org/cabal/users-guide/-name: asciidiagram-version: 1.3.2-synopsis: Pretty rendering of Ascii diagram into svg or png.-description: - Transform Ascii art diagram like this:- .- @- , \/---------+- +---------+ | |- | ASCII +----\>| Diagram |- +---------+ | |- | | +--+------\/- \\---*-----\/\<=======\/- @- .- Into this:- .- <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAR0AAABnCAQAAACXrV7jAAAH+UlEQVR4Xu3cbZCVZRkH8N++srssirgqqIKKGK4WphWQMjJjilCUaASklgCZKr6RpgphlRWK0kiZVqmmY5ImyppbZiU1lglqUCqb4bsk5oq87sKyu3dfmWGneFzZPQ9evw87c87HM//538+e67qPnSyEEEIIIYQQQgghhBBCCCGEEEIIodguqMjOFIbudsmWUS3Vg159foC8Kequ6IQe1XdWjbms58n2kT/V/zcbpXaOUF79h08eeVNVufzqluiEqu+MGPLTKlI8wGUS9mubfkNPmUXrhNNOaesryShaJ+wx/rNVsovWCeuPHCrJLFontJX2kl20Tthrt82pQmbROmG3yq2yi9YJNm8pSbKLGVYgrZFvfSiKAyt06YGVolE7J71vo2OjfKsWuik6SXYhWgftdh0hWidaJ6ITIjphgekas7dORCdMcJxJFsssohP6etQ8szQD0ToyCDOMMU5DZ6KzxAO+qvf785/zla7S240AWOReL6swwFx9wD/dYrk2g0x3OG73CICxJmK2FwBc6GNyYrCnzTLP/3WfhSixr7GOAcDN6n3UuPdn6/zS4zY5x+GAH5pjsrFarLRVwmKTDfZp5ZZ5Si0OMtxrbvdlexsg4YP2tsQjZqKPJDcqXW+sSVZD0jFetNQFWjxjvEmuVQy4wkeMkt6v0Zns5+rUAuaaajaAZJ2zjHCLUkDCCCMsdbvPqUXCqSj3sHNB0glf19VG+ofpfuF/6uk8UG+qY4zDSs+gnyaVgEaP+bcyw3wQ0OhXmvRThLFK8FuD1aizzmj90eZxDZoNcrwyySInWeAQQ92jj9GFG50GrxmtUZ3LAKUatCoB8Ij1vqZE2qGwpl14EJHAaLXudzKWud1mz3pAH8AYPQy0ymzzTMQSnzfMvuZr8mFjFGOWT3nAnprN81v9fd+tjsD1jrBQmXNMs9zTpvuzJ/3eYYUanUVqHKnRAisNBN90sROdbbSe4O/KHSx1GJokbfcOKPTWucq2FptktR1Waxk41ale9nEA1NsTXOAaE3Gd4e7EaKe5VhngJ64xySZHqzPdF10IlvqMJxyLFyyyvz+pc7TnCjc6DxkrGarMQpeA8Qa7wQyzzHQ61usn0XF08t86zds+JicdIyEBKm2VOvwU+kg22uBAiyS85RgJB+BtCXCaiZIqX7CPZHcJb6nBWglTJMWmKdZDq1SY48/nrTRXuyonqDcDcLgfW2W+y202RZV3tNteQrv27d7JlQbjNMhotRod+54btdqqVCsY5U4n6usaexkCYE/AFeBJF3tRBQCq0aq6sAcR9RivFcXarbYPgH3N8bx6kw223vMGZTiw8iLrV4IJbPGkCR22Tr3r/NRJuNVsCS/r7wobHeVeFVIH3dzkdMd7WCX2lyS2+1uQ0fm1MSaBFlPd5xxJEaDFegMlJ/imK92mJ2hRDkiQ3+is3nYQseMH1jsu0+QLUgefwrOqjJK0WIKkTZ3rTAAkQJIkAGtscKIKST2StG0gJQozOq9b4QrHAkZa6Gyvm+hDettqqXXmS/bwPRcaYbgSy53pTCzwqLX4hl5OMg5zvOQVRc7CWY5W4H5hukaZrDHZJsvUuMMB4EcabMB8NUY4xTHmm+Ygv7IHKHG8S8zVS6VBzneI7e3nEN/1nL97UWl+BhFvu8hwCXCex7To40tesU4P04xTJeET/uAh/1JqqtES9nEYhoO9JByowmFOAr0kBW5i1tYeBiqda4RiCdQ4ALWgt2SYuz2oyTX2Vydp8ppRxtui0W1O9ziYqlYCwF3u8Jbj3eQOg7S7WD/JVxwkmeowqUtWv9ML8m0gRbpPetV76Xem+KODwPfN7YJe6U9R/sefsSXoQCWucrIqK93s80qk2E3eEWGghe6xwFb7m+NTsXQRrbPjhhgCIBV2dD4ghOzRoUinhBS/Ix5C3DnPIFpn96Z1+1kVd84zi+iUt6mItfbsgs1l1kd0sovWsaHCW/GVYGZho5LWNtE6mUXrPKnXsrURnexCfdPae0V0sorW+Y+HStwV0cksfG1T8c1WRXQyidbZ6sqmJcubr4yliwxCo9+4aVNTfdMZWuim1gkfkC8Hv/JS/7KNPR7ecJ0nOrlg+oZ860eRLEKx9s6PPx39XKrV9cIEG9TrHu3v0Vr7KvlW27TuUKvkzY3+4eY8L130KGlLJXKtR5sK+dPfw+Q5OlvaSpJ8ay6zXv5s8FzO16FKWp4pq5JnAygSurx1VL+8YtBRuZ/8doOITutjTw36sPxaus3kN0dGWWpNzqOz6b76z07tJbce7HjyW+MHJipUlX5mSO5bx0Mr2t+0t3x6s+PJ70h361vA0fmyv3oz/9HReu3My368m056xxwPYqzL7aGrzNx+8lvpajMUst1dagzkPzrXP3HaDYeeX6oT2kxxgjWYbYp7lHTX5Hew+w1W2Jqdbfmucldpr6q/DNvv0sqDvVuPuMcfAcf5nBO6bvK7BQAzXK0y7rV2ZXToUTqt54yNA6qbm8tbymXnSt8GzPSd7pj89nW3kVDA0RnpapO8FjcktzVu6J1/7QkM2/TEGe7v4snvBD9Qs13PjjQSLLaYbn41ybe0+roFcqfUzlS3YtVFB3+7lJmtK1aps3O1y5+/OdkzthOtQ03vmzaMo9f9a8/RqIvk7MAS0SkonX9MDvEjKfMcpUGI6GSnwVHmeZdCGOkNSXYhqLHALiqEEEIIIYQQQgghhBBCCCGE8F9DWMtlMskJNQAAAABJRU5ErkJggg==>>- .- See the documentation of the Text.AsciiDiagram module for the- description of the input format.--license: BSD3---license-file: -author: Vincent Berthoux-maintainer: vincent.berthoux@gmail.com--- copyright: -category: Text, Diagram-build-type: Simple-extra-source-files: changelog.md-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.3.2--library- ghc-options: -O2 -Wall- exposed-modules: Text.AsciiDiagram-- other-modules: Text.AsciiDiagram.DiagramCleaner- , Text.AsciiDiagram.DefaultContext- , Text.AsciiDiagram.Geometry- , Text.AsciiDiagram.Graph- , Text.AsciiDiagram.Parser- , Text.AsciiDiagram.Reconstructor- , Text.AsciiDiagram.BoundingBoxEstimation- , Text.AsciiDiagram.SvgRender-- -- containers >= 0.5.2.1 for Set.elemAt- build-depends: base >=4.6 && < 5- , vector >= 0.10- , bytestring- , text >= 1.2 && < 1.3- , linear >= 1.16- , containers >= 0.5- , mtl >= 2.1 && < 2.3- , lens >= 4.6 && < 5.0- , svg-tree >= 0.5.1.1 && < 0.7- , rasterific-svg >= 0.3.1.2 && < 0.4- , 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- , directory >= 1.0- , bytestring- , optparse-applicative- , rasterific-svg- , JuicyPixels- , filepath- , asciidiagram- , svg-tree- , text- , FontyFruity-+-- Initial hitaa.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ +name: asciidiagram +version: 1.3.3 +synopsis: Pretty rendering of Ascii diagram into svg or png. +description: + Transform Ascii art diagram like this: + . + @ + , \/---------+ + +---------+ | | + | ASCII +----\>| Diagram | + +---------+ | | + | | +--+------\/ + \\---*-----\/\<=======\/ + @ + . + Into this: + . + <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAR0AAABnCAQAAACXrV7jAAAH+UlEQVR4Xu3cbZCVZRkH8N++srssirgqqIKKGK4WphWQMjJjilCUaASklgCZKr6RpgphlRWK0kiZVqmmY5ImyppbZiU1lglqUCqb4bsk5oq87sKyu3dfmWGneFzZPQ9evw87c87HM//538+e67qPnSyEEEIIIYQQQgghhBBCCCGEEEIIodguqMjOFIbudsmWUS3Vg159foC8Kequ6IQe1XdWjbms58n2kT/V/zcbpXaOUF79h08eeVNVufzqluiEqu+MGPLTKlI8wGUS9mubfkNPmUXrhNNOaesryShaJ+wx/rNVsovWCeuPHCrJLFontJX2kl20Tthrt82pQmbROmG3yq2yi9YJNm8pSbKLGVYgrZFvfSiKAyt06YGVolE7J71vo2OjfKsWuik6SXYhWgftdh0hWidaJ6ITIjphgekas7dORCdMcJxJFsssohP6etQ8szQD0ToyCDOMMU5DZ6KzxAO+qvf785/zla7S240AWOReL6swwFx9wD/dYrk2g0x3OG73CICxJmK2FwBc6GNyYrCnzTLP/3WfhSixr7GOAcDN6n3UuPdn6/zS4zY5x+GAH5pjsrFarLRVwmKTDfZp5ZZ5Si0OMtxrbvdlexsg4YP2tsQjZqKPJDcqXW+sSVZD0jFetNQFWjxjvEmuVQy4wkeMkt6v0Zns5+rUAuaaajaAZJ2zjHCLUkDCCCMsdbvPqUXCqSj3sHNB0glf19VG+ofpfuF/6uk8UG+qY4zDSs+gnyaVgEaP+bcyw3wQ0OhXmvRThLFK8FuD1aizzmj90eZxDZoNcrwyySInWeAQQ92jj9GFG50GrxmtUZ3LAKUatCoB8Ij1vqZE2qGwpl14EJHAaLXudzKWud1mz3pAH8AYPQy0ymzzTMQSnzfMvuZr8mFjFGOWT3nAnprN81v9fd+tjsD1jrBQmXNMs9zTpvuzJ/3eYYUanUVqHKnRAisNBN90sROdbbSe4O/KHSx1GJokbfcOKPTWucq2FptktR1Waxk41ale9nEA1NsTXOAaE3Gd4e7EaKe5VhngJ64xySZHqzPdF10IlvqMJxyLFyyyvz+pc7TnCjc6DxkrGarMQpeA8Qa7wQyzzHQ61usn0XF08t86zds+JicdIyEBKm2VOvwU+kg22uBAiyS85RgJB+BtCXCaiZIqX7CPZHcJb6nBWglTJMWmKdZDq1SY48/nrTRXuyonqDcDcLgfW2W+y202RZV3tNteQrv27d7JlQbjNMhotRod+54btdqqVCsY5U4n6usaexkCYE/AFeBJF3tRBQCq0aq6sAcR9RivFcXarbYPgH3N8bx6kw223vMGZTiw8iLrV4IJbPGkCR22Tr3r/NRJuNVsCS/r7wobHeVeFVIH3dzkdMd7WCX2lyS2+1uQ0fm1MSaBFlPd5xxJEaDFegMlJ/imK92mJ2hRDkiQ3+is3nYQseMH1jsu0+QLUgefwrOqjJK0WIKkTZ3rTAAkQJIkAGtscKIKST2StG0gJQozOq9b4QrHAkZa6Gyvm+hDettqqXXmS/bwPRcaYbgSy53pTCzwqLX4hl5OMg5zvOQVRc7CWY5W4H5hukaZrDHZJsvUuMMB4EcabMB8NUY4xTHmm+Ygv7IHKHG8S8zVS6VBzneI7e3nEN/1nL97UWl+BhFvu8hwCXCex7To40tesU4P04xTJeET/uAh/1JqqtES9nEYhoO9JByowmFOAr0kBW5i1tYeBiqda4RiCdQ4ALWgt2SYuz2oyTX2Vydp8ppRxtui0W1O9ziYqlYCwF3u8Jbj3eQOg7S7WD/JVxwkmeowqUtWv9ML8m0gRbpPetV76Xem+KODwPfN7YJe6U9R/sefsSXoQCWucrIqK93s80qk2E3eEWGghe6xwFb7m+NTsXQRrbPjhhgCIBV2dD4ghOzRoUinhBS/Ix5C3DnPIFpn96Z1+1kVd84zi+iUt6mItfbsgs1l1kd0sovWsaHCW/GVYGZho5LWNtE6mUXrPKnXsrURnexCfdPae0V0sorW+Y+HStwV0cksfG1T8c1WRXQyidbZ6sqmJcubr4yliwxCo9+4aVNTfdMZWuim1gkfkC8Hv/JS/7KNPR7ecJ0nOrlg+oZ860eRLEKx9s6PPx39XKrV9cIEG9TrHu3v0Vr7KvlW27TuUKvkzY3+4eY8L130KGlLJXKtR5sK+dPfw+Q5OlvaSpJ8ay6zXv5s8FzO16FKWp4pq5JnAygSurx1VL+8YtBRuZ/8doOITutjTw36sPxaus3kN0dGWWpNzqOz6b76z07tJbce7HjyW+MHJipUlX5mSO5bx0Mr2t+0t3x6s+PJ70h361vA0fmyv3oz/9HReu3My368m056xxwPYqzL7aGrzNx+8lvpajMUst1dagzkPzrXP3HaDYeeX6oT2kxxgjWYbYp7lHTX5Hew+w1W2Jqdbfmucldpr6q/DNvv0sqDvVuPuMcfAcf5nBO6bvK7BQAzXK0y7rV2ZXToUTqt54yNA6qbm8tbymXnSt8GzPSd7pj89nW3kVDA0RnpapO8FjcktzVu6J1/7QkM2/TEGe7v4snvBD9Qs13PjjQSLLaYbn41ybe0+roFcqfUzlS3YtVFB3+7lJmtK1aps3O1y5+/OdkzthOtQ03vmzaMo9f9a8/RqIvk7MAS0SkonX9MDvEjKfMcpUGI6GSnwVHmeZdCGOkNSXYhqLHALiqEEEIIIYQQQgghhBBCCCGE8F9DWMtlMskJNQAAAABJRU5ErkJggg==>> + . + See the documentation of the Text.AsciiDiagram module for the + description of the input format. + +license: BSD3 +--license-file: +author: Vincent Berthoux +maintainer: vincent.berthoux@gmail.com +-- copyright: +category: Text, Diagram +build-type: Simple +extra-source-files: changelog.md +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.3.3 + +library + ghc-options: -O2 -Wall + exposed-modules: Text.AsciiDiagram + + other-modules: Text.AsciiDiagram.DiagramCleaner + , Text.AsciiDiagram.DefaultContext + , Text.AsciiDiagram.Geometry + , Text.AsciiDiagram.Graph + , Text.AsciiDiagram.Parser + , Text.AsciiDiagram.Reconstructor + , Text.AsciiDiagram.BoundingBoxEstimation + , Text.AsciiDiagram.SvgRender + + -- containers >= 0.5.2.1 for Set.elemAt + build-depends: base >=4.6 && < 5 + , vector >= 0.10 + , bytestring + , text >= 1.2 && < 1.3 + , linear >= 1.16 + , containers >= 0.5 + , mtl >= 2.1 && < 2.3 + , lens >= 4.6 && < 5.0 + , svg-tree >= 0.5.1.1 && < 0.7 + , rasterific-svg >= 0.3.1.2 && < 0.4 + , 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 + , directory >= 1.0 + , bytestring + , optparse-applicative + , rasterific-svg + , JuicyPixels + , filepath + , asciidiagram + , svg-tree + , text + , FontyFruity +
changelog.md view
@@ -1,54 +1,58 @@-Change log-==========--v1.3.2 October 2016--------------------- * Bumping svg-tree dependency--v1.3.1.2 August 2016---------------------- * Removing test suite from production pacakge--v1.3.1.1 May 2016------------------- * Fix: GHC 8.0.1 compilation--v1.3.1 March 2016------------------- * Fix: CSS problems in case of bullet on closed shapes.- * Fix: some documentation.--v1.3 March 2016----------------- * Added: Hierachisation of shapes in shapes and text.- * Added: shape transformation using CSS.--v1.2 February 2016-------------------- * Breaking change: DPI parameter on the rendering functions- * Fix: exposing grid size- * Fix: Bumped dependencies--v1.1.1.1 May 2015-------------------- * Fix: Bumping lens dependency--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--v1.0 February 2015--------------------- * Initial version-+Change log +========== + +v1.3.3 November 2017 +-------------------- + * Fixing compilation issue. + +v1.3.2 October 2016 +------------------- + * Bumping svg-tree dependency + +v1.3.1.2 August 2016 +-------------------- + * Removing test suite from production pacakge + +v1.3.1.1 May 2016 +----------------- + * Fix: GHC 8.0.1 compilation + +v1.3.1 March 2016 +----------------- + * Fix: CSS problems in case of bullet on closed shapes. + * Fix: some documentation. + +v1.3 March 2016 +--------------- + * Added: Hierachisation of shapes in shapes and text. + * Added: shape transformation using CSS. + +v1.2 February 2016 +------------------ + * Breaking change: DPI parameter on the rendering functions + * Fix: exposing grid size + * Fix: Bumped dependencies + +v1.1.1.1 May 2015 +----------------- + + * Fix: Bumping lens dependency + +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 + +v1.0 February 2015 +------------------ + + * Initial version +
exec-src/asciidiagram.hs view
@@ -1,178 +1,178 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), (<*>), pure )-#endif--import Control.Applicative( (<|>) )-import Control.Monad( when )-import Data.Monoid( (<>) )--import qualified Data.ByteString.Lazy as LB-import qualified Data.Text.IO as STIO-import System.Directory( getTemporaryDirectory )-import System.FilePath( (</>)- , replaceExtension- , takeExtension )--import Graphics.Svg( Document, loadSvgFile, saveXmlFile )-import Graphics.Rasterific.Svg( loadCreateFontCache )-import Graphics.Text.TrueType( FontCache )-import Codec.Picture( writePng )-import Options.Applicative( Parser- , ParserInfo- , argument- , execParser- , flag- , fullDesc- , header- , help- , helper- , info- , long- , metavar- , optional- , progDesc- , short- , str- , strOption- , switch- )-import Graphics.Rasterific.Svg( renderSvgDocument- , pdfOfSvgDocument )-import Text.AsciiDiagram--data Mode- = Convert !(FilePath, FilePath)- | DumpLibrary !FilePath--data Options = Options- { _workingMode :: !Mode- , _verbose :: !Bool- , _withLibrary :: !(Maybe FilePath)- , _format :: !(Maybe Format)- }--data Format = FormatSvg | FormatPng | FormatPdf--ioParser :: Parser (String, String)-ioParser = (,)- <$> argument str- (metavar "INPUTFILE"- <> help "Text file of the Ascii diagram to parse.")- <*> (argument str- (metavar "OUTPUTFILE"- <> help ("Output file name, same as input with"- <> " different extension if unspecified."))- <|> pure "")--modeParser :: Parser Mode-modeParser = (Convert <$> ioParser) <|> (DumpLibrary <$> dumpParser)- where - dumpParser = strOption - ( long "dump-library"- <> short 'd'- <> metavar "FILENAME"- <> help "Dump the default shape library & styles in an SVG document") --argParser :: Parser Options-argParser = Options- <$> modeParser- <*> ( switch (long "verbose" <> help "Display more information") )- <*> ( optional $ strOption- ( long "with-library"- <> short 'l'- <> metavar "LIBRARY_FILENAME"- <> help "Use a custom shape & style library instead of the default one") )- <*> ( flag Nothing (Just FormatSvg)- ( long "svg"- <> help "Force the use of the SVG format (deduced from extension otherwise)")- <|> flag Nothing (Just FormatPng)- ( long "png"- <> help "Force the use of the PNG format (deduced from extension otherwise) (by default)")- <|> flag Nothing (Just FormatPdf)- ( long "pdf"- <> help "Force the use of the PDF format (deduced from extension otherwise)")- )--progOptions :: ParserInfo Options-progOptions = info (helper <*> argParser)- ( fullDesc- <> progDesc "Convert INPUTFILE into a svg or png OUTPUTFILE"- <> header "asciidiagram - A pretty printer for ASCII art diagram to SVG." )--formatOfOuputFilename :: FilePath -> Format-formatOfOuputFilename f = case takeExtension f of- ".png" -> FormatPng- ".svg" -> FormatSvg- ".pdf" -> FormatPdf- _ -> FormatPng--getFontCache :: Bool -> IO FontCache-getFontCache verbose = do- when verbose $ putStrLn "Loading/Building font cache (can be long)"- tempDir <- getTemporaryDirectory - loadCreateFontCache $ tempDir </> "asciidiagram-fonty-fontcache"---loadLibrary :: Options -> IO Document-loadLibrary opt = case _withLibrary opt of- Nothing -> return defaultLib- Just p -> loadLib p- where- defaultLib = defaultLibrary defaultGridSize- loadLib p = do- f <- loadSvgFile p- case f of- Just doc -> return doc- Nothing -> do- putStrLn "Invalid library file, using default lib"- return defaultLib --runConversion :: Options -> FilePath -> FilePath -> IO ()-runConversion opt inputFile outputFile = do- verbose . putStrLn $ "Loading file " ++ inputFile- inputData <- STIO.readFile inputFile- lib <- loadLibrary opt- let diag = parseAsciiDiagram inputData- svg = svgOfDiagramAtSize defaultGridSize lib diag- format = _format opt <|> (pure $ formatOfOuputFilename outputFile)- case format of- Nothing -> saveDoc svg- Just FormatSvg -> saveDoc svg- Just FormatPng -> savePng svg- Just FormatPdf -> savePdf svg- where- verbose = when $ _verbose opt- saveDoc svg = do- verbose . putStrLn $ "Writing SVG file " ++ outputFile- saveXmlFile (savingPath "svg") svg-- savingPath ext = case outputFile of- "" -> replaceExtension inputFile ext- p -> p-- savePdf svg = do- cache <- getFontCache $ _verbose opt- verbose . putStrLn $ "Writing PDF file " ++ outputFile- (pdf, _) <- pdfOfSvgDocument cache Nothing 96 svg- LB.writeFile (savingPath "pdf") pdf-- savePng svg = do- cache <- getFontCache $ _verbose opt- verbose . putStrLn $ "Writing PNG file " ++ outputFile- (img, _) <- renderSvgDocument cache Nothing 96 svg- writePng (savingPath "png") img--dumpLibrary :: FilePath -> IO ()-dumpLibrary path =- saveXmlFile path $ defaultLibrary defaultGridSize--main :: IO ()-main = execParser progOptions >>= \opts ->- case _workingMode opts of- Convert (i, o) -> runConversion opts i o- DumpLibrary p -> dumpLibrary p-+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.Applicative( (<|>) ) +import Control.Monad( when ) +import Data.Monoid( (<>) ) + +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text.IO as STIO +import System.Directory( getTemporaryDirectory ) +import System.FilePath( (</>) + , replaceExtension + , takeExtension ) + +import Graphics.Svg( Document, loadSvgFile, saveXmlFile ) +import Graphics.Rasterific.Svg( loadCreateFontCache ) +import Graphics.Text.TrueType( FontCache ) +import Codec.Picture( writePng ) +import Options.Applicative( Parser + , ParserInfo + , argument + , execParser + , flag + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , optional + , progDesc + , short + , str + , strOption + , switch + ) +import Graphics.Rasterific.Svg( renderSvgDocument + , pdfOfSvgDocument ) +import Text.AsciiDiagram + +data Mode + = Convert !(FilePath, FilePath) + | DumpLibrary !FilePath + +data Options = Options + { _workingMode :: !Mode + , _verbose :: !Bool + , _withLibrary :: !(Maybe FilePath) + , _format :: !(Maybe Format) + } + +data Format = FormatSvg | FormatPng | FormatPdf + +ioParser :: Parser (String, String) +ioParser = (,) + <$> argument str + (metavar "INPUTFILE" + <> help "Text file of the Ascii diagram to parse.") + <*> (argument str + (metavar "OUTPUTFILE" + <> help ("Output file name, same as input with" + <> " different extension if unspecified.")) + <|> pure "") + +modeParser :: Parser Mode +modeParser = (Convert <$> ioParser) <|> (DumpLibrary <$> dumpParser) + where + dumpParser = strOption + ( long "dump-library" + <> short 'd' + <> metavar "FILENAME" + <> help "Dump the default shape library & styles in an SVG document") + +argParser :: Parser Options +argParser = Options + <$> modeParser + <*> ( switch (long "verbose" <> help "Display more information") ) + <*> ( optional $ strOption + ( long "with-library" + <> short 'l' + <> metavar "LIBRARY_FILENAME" + <> help "Use a custom shape & style library instead of the default one") ) + <*> ( flag Nothing (Just FormatSvg) + ( long "svg" + <> help "Force the use of the SVG format (deduced from extension otherwise)") + <|> flag Nothing (Just FormatPng) + ( long "png" + <> help "Force the use of the PNG format (deduced from extension otherwise) (by default)") + <|> flag Nothing (Just FormatPdf) + ( long "pdf" + <> help "Force the use of the PDF format (deduced from extension otherwise)") + ) + +progOptions :: ParserInfo Options +progOptions = info (helper <*> argParser) + ( fullDesc + <> progDesc "Convert INPUTFILE into a svg or png OUTPUTFILE" + <> header "asciidiagram - A pretty printer for ASCII art diagram to SVG." ) + +formatOfOuputFilename :: FilePath -> Format +formatOfOuputFilename f = case takeExtension f of + ".png" -> FormatPng + ".svg" -> FormatSvg + ".pdf" -> FormatPdf + _ -> FormatPng + +getFontCache :: Bool -> IO FontCache +getFontCache verbose = do + when verbose $ putStrLn "Loading/Building font cache (can be long)" + tempDir <- getTemporaryDirectory + loadCreateFontCache $ tempDir </> "asciidiagram-fonty-fontcache" + + +loadLibrary :: Options -> IO Document +loadLibrary opt = case _withLibrary opt of + Nothing -> return defaultLib + Just p -> loadLib p + where + defaultLib = defaultLibrary defaultGridSize + loadLib p = do + f <- loadSvgFile p + case f of + Just doc -> return doc + Nothing -> do + putStrLn "Invalid library file, using default lib" + return defaultLib + +runConversion :: Options -> FilePath -> FilePath -> IO () +runConversion opt inputFile outputFile = do + verbose . putStrLn $ "Loading file " ++ inputFile + inputData <- STIO.readFile inputFile + lib <- loadLibrary opt + let diag = parseAsciiDiagram inputData + svg = svgOfDiagramAtSize defaultGridSize lib diag + format = _format opt <|> (pure $ formatOfOuputFilename outputFile) + case format of + Nothing -> saveDoc svg + Just FormatSvg -> saveDoc svg + Just FormatPng -> savePng svg + Just FormatPdf -> savePdf svg + where + verbose = when $ _verbose opt + saveDoc svg = do + verbose . putStrLn $ "Writing SVG file " ++ outputFile + saveXmlFile (savingPath "svg") svg + + savingPath ext = case outputFile of + "" -> replaceExtension inputFile ext + p -> p + + savePdf svg = do + cache <- getFontCache $ _verbose opt + verbose . putStrLn $ "Writing PDF file " ++ outputFile + (pdf, _) <- pdfOfSvgDocument cache Nothing 96 svg + LB.writeFile (savingPath "pdf") pdf + + savePng svg = do + cache <- getFontCache $ _verbose opt + verbose . putStrLn $ "Writing PNG file " ++ outputFile + (img, _) <- renderSvgDocument cache Nothing 96 svg + writePng (savingPath "png") img + +dumpLibrary :: FilePath -> IO () +dumpLibrary path = + saveXmlFile path $ defaultLibrary defaultGridSize + +main :: IO () +main = execParser progOptions >>= \opts -> + case _workingMode opts of + Convert (i, o) -> runConversion opts i o + DumpLibrary p -> dumpLibrary p +
src/Text/AsciiDiagram.hs view
@@ -1,628 +1,628 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--- | This module gives access to the ascii diagram parser and--- SVG renderer.------ Ascii diagram, transform your ASCII art drawing to a nicer--- representation--- --- @--- \/---------+--- +---------+ | |--- | ASCII +----\>| Diagram |--- +---------+ | |--- |{flat} | +--+------\/--- \\---*-----\/\<=======\/--- ::: .flat .filled_shape { fill: #DDD; }--- @--- <<docimages/baseExample.svg>>--- --- To render the diagram as a PNG file, you have to use the--- library rasterific-svg and JuicyPixels.------ As a sample usage, to save a diagram to png, you can use--- the following snippet.------ > import Codec.Picture( writePng )--- > import Text.AsciiDiagram( imageOfDiagram )--- > import Graphics.Rasterific.Svg( loadCreateFontCache )--- >--- > saveDiagramToFile :: FilePath -> Diagram -> IO ()--- > saveDiagramToFile path diag = do--- > cache <- loadCreateFontCache "asciidiagram-fonty-fontcache"--- > imageOfDiagram cache 96 diag--- > writePng path img----module Text.AsciiDiagram- ( - -- $introDoc- -- * Diagram format-- -- ** Lines- -- $linesdoc-- -- ** Shapes- -- $shapesdoc-- -- ** Bullets- -- $bulletdoc-- -- ** Styles- -- $styledoc-- -- ** Hierarchical styles- -- $hierarchicalDoc-- -- ** Shapes- -- $shapeDoc-- -- * Functions- svgOfDiagram- , parseAsciiDiagram- , saveAsciiDiagramAsSvg- , imageOfDiagram- , pdfOfDiagram-- -- * Customized rendering- , svgOfDiagramAtSize - , GridSize( .. )- , defaultGridSize- , saveAsciiDiagramAsSvgAtSize- , imageOfDiagramAtSize- , pdfOfDiagramAtSize-- -- * Library- , defaultLibrary-- -- * Document description- , Diagram( .. ) - , TextZone( .. )- , Shape( .. )- , ShapeElement( .. )- , Anchor( .. )- , Segment( .. )- , SegmentKind( .. )- , SegmentDraw( .. )- , Point- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-#endif--import Data.Monoid( (<>))-import Control.Monad( forM_ )-import Control.Monad.ST( runST )-import Data.Function( on )-import Data.List( partition, sortBy )-import qualified Data.ByteString.Lazy as LB-import qualified Data.Foldable as F-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Vector.Unboxed as VU-import qualified Data.Vector.Unboxed.Mutable as VUM-import Linear( V2( V2 ) )--import Text.AsciiDiagram.Parser-import Text.AsciiDiagram.Reconstructor-import Text.AsciiDiagram.SvgRender-import Text.AsciiDiagram.Geometry-import Text.AsciiDiagram.DiagramCleaner--import Codec.Picture( Image, PixelRGBA8 )-import Graphics.Text.TrueType( FontCache )-import Graphics.Svg( saveXmlFile )-import Graphics.Rasterific.Svg( renderSvgDocument, pdfOfSvgDocument )--{-import Debug.Trace-}-{-import Text.Groom-}-{-import Text.Printf-}--data CharBoard = CharBoard- { _boardWidth :: !Int- , _boardHeight :: !Int- , _boardData :: !(VU.Vector Char)- }- deriving (Eq, Show)--textOfCharBoard :: CharBoard -> [T.Text]-textOfCharBoard board = fetch <$> zip [0 .. h - 1] [0, w..] where- w = _boardWidth board- h = _boardHeight board- charData = _boardData board-- fetch (_, startIdx) =- T.pack . VU.toList . VU.take w $ VU.drop startIdx charData--charBoardOfText :: [T.Text] -> CharBoard-charBoardOfText textLines = CharBoard- { _boardWidth = twidth- , _boardHeight = theight- , _boardData = charData- }- where- twidth = maximum $ fmap T.length textLines- theight = length textLines- - lineIndices = zip [0, twidth ..] textLines-- charData = runST $ do- emptyBoard <- VUM.replicate (twidth * theight) ' '-- forM_ lineIndices $ \(lineIndex, l) -> do- let chars = zip [lineIndex, lineIndex + 1 ..] $ T.unpack l- forM_ chars $ \(idx, c) -> do- VUM.unsafeWrite emptyBoard idx c-- VU.unsafeFreeze emptyBoard---pointsOfShape :: F.Foldable f => f Shape -> [Point]-pointsOfShape = F.concatMap (F.concatMap go . shapeElements) where- go (ShapeAnchor p _) = [p]- go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey })- | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]]- | sx == ex = [V2 sx yy | yy <- [sy .. ey]]- | sy == ey && sx >= ex = [V2 xx sy | xx <- [ex .. sx]]- | sy == ey = [V2 xx sy | xx <- [sx .. ex]]- | otherwise = []--cleanLines :: [Int] -> CharBoard -> CharBoard-cleanLines idxs board = board { _boardData = _boardData board VU.// toSet }- where- xMax = _boardWidth board - 1- toSet = [(lineIndex + column, ' ')- | lineNum <- idxs- , let lineIndex = lineNum * _boardWidth board- , column <- [0 .. xMax]- ]--cleanupShapes :: (F.Foldable f) => f Shape -> CharBoard -> CharBoard-cleanupShapes shapes board = board { _boardData = _boardData board VU.// toSet }- where- toSet = [(x + y * _boardWidth board, ' ') | V2 x y <- pointsOfShape shapes]---pointComp :: Point -> Point -> Ordering-pointComp (V2 x1 y1) (V2 x2 y2) = case compare y1 y2 of- EQ -> compare x1 x2- a -> a--featuresOfClosedShape :: Shape -> [Point]-featuresOfClosedShape = F.fold . go . shapeElements where- go [] = []- -- If we got something like +----+ we skip the first anchor and- -- the segment.- go ( ShapeAnchor (V2 _ ay1) _- : ShapeSegment Segment { _segStart = V2 _ sy, _segEnd = V2 _ ey }- : rest@(ShapeAnchor (V2 _ ay2) _ : _)- )- | ay1 == ay2 && sy == ey && ay1 == sy = go rest- go (ShapeAnchor p _: rest) = [p] : go rest- go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey } : rest)- | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]] : after- | sx == ex = [V2 sx yy | yy <- [sy .. ey]] : after- | otherwise = after- where after = go rest--rangesOfOpenedShape :: Shape -> [(Point, Point)]-rangesOfOpenedShape s = fmap dup . sortBy pointComp $ pointsOfShape [s]- where dup a = (a, a)--rangesOfClosedShape :: Shape -> [(Point, Point)]-rangesOfClosedShape shape = pairAssoc sortedPoints- where- pairAssoc [] = []- pairAssoc [_] = []- pairAssoc (p1@(V2 _ y1):lst@(p2@(V2 _ y2):rest))- | y1 == y2 = (p1, p2) : pairAssoc rest- | otherwise = pairAssoc lst-- sortedPoints = sortBy pointComp $ featuresOfClosedShape shape---class RangeDecomposable a where- rangesOf :: a -> [(Point, Point)]--instance RangeDecomposable Shape where- rangesOf s- | shapeIsClosed s = rangesOfClosedShape s- | otherwise = rangesOfOpenedShape s--instance RangeDecomposable TextZone where- rangesOf txt = [(orig, V2 (x + txtLength) y)] where- orig@(V2 x y) = _textZoneOrigin txt- txtLength = T.length $ _textZoneContent txt---contains :: (RangeDecomposable a, RangeDecomposable b) => a -> b -> Bool-contains sa sb = go (rangesOf sa) (rangesOf sb) where- go _ [] = True- go [] (_:_) = False- go ((V2 _ ya, _):rest1) rest2@((V2 _ yb, _):_)- -- A part of second shape is before potentially englobing shpae- -- so sa can't contain sb- | ya > yb = False - -- sa may be bigger, just skip- | ya < yb = go rest1 rest2- -- here ya == yb- go sal@((V2 xa1 _, V2 xa2 _):rest1)- sar@((V2 xb1 _, V2 xb2 _):rest2)- -- sb is before any range of sa, so we must have- -- missed something, sa not containing sb- | xb1 < xa1 = False- -- sb is in the range bounds- | xa1 <= xb1 && xb2 <= xa2 = go sal rest2- -- Maybe sa has another range on the same line- | xb1 > xa2 = go rest1 sar- | otherwise = False- -areaOfShape :: Shape -> Int-areaOfShape = F.sum . fmap dist . rangesOfClosedShape- where- -- we can use manathan distance here- dist (V2 x1 y1, V2 x2 y2) = abs (x1 - x2) + abs (y1 - y2)--sortByArea :: [Shape] -> [Shape]-sortByArea shapes = sorted <> opened- where- (closed, opened) = partition shapeIsClosed shapes- sorted =- fmap snd . reverse $ sortBy (compare `on` fst) [(areaOfShape s, s) | s <- closed]--hierarchise :: [Shape] -> [TextZone] -> [TextZone] -> [Element]-hierarchise shapes allTexts = finalize . go areaSortedShapes allTexts where- areaSortedShapes = sortByArea shapes-- finalize (topShapes, topText, _topTags) =- (ElemShape <$> topShapes) <> (ElemText <$> topText)-- go [] texts tags = ([], texts, tags)- go (x:xs) texts tags | not (shapeIsClosed x) = (x:outShapes, outTexts, outTags)- where- (outShapes, outTexts, outTags) = go xs texts tags- go (x:xs) texts tags = (newShape : restShapes, restText, restTags)- where- (shapeInShape, shapeOutShape) = partition (x `contains`) xs- (textInShape, textOutShape) = partition (x `contains`) texts- (tagsInShape, tagsOutShape) = partition (x `contains`) tags-- (innerShapes, innerText, innerTags) = go shapeInShape textInShape tagsInShape- (restShapes, restText, restTags) = go shapeOutShape textOutShape tagsOutShape-- newShape = x- { shapeChildren =- (ElemShape <$> innerShapes) <> (ElemText <$> innerText)- , shapeTags = S.fromList $ _textZoneContent <$> innerTags- }---- | Analyze an ascii diagram and extract all it's features.-parseAsciiDiagram :: T.Text -> Diagram-parseAsciiDiagram content = Diagram- { _diagramElements = S.fromList allElements- , _diagramCellWidth = maximum $ fmap T.length textLines- , _diagramCellHeight = length textLines - length styleLines- , _diagramStyles = reverse styleLines- }- where- textLines = T.lines content- allElements = hierarchise (S.toList validShapes) nonEmptyZones tags-- nonEmptyZones = [t | t <- zones, not . T.null $ _textZoneContent t]- (tags, zones) = detectTagFromTextZone $ extractTextZones shapeCleanedText - (styleLineNumber, styleLines) = unzip $ styleLine parsed-- shapeCleanedText =- textOfCharBoard . cleanLines styleLineNumber- . cleanupShapes validShapes- $ charBoardOfText textLines- - parsed = parseTextLines textLines- reconstructed =- reconstruct (anchorMap parsed) $ segmentSet parsed- validShapes = S.filter isShapePossible reconstructed---- | Helper function helping you save a diagram as--- a SVG file on disk.-saveAsciiDiagramAsSvg :: FilePath -> Diagram -> IO ()-saveAsciiDiagramAsSvg fileName diagram =- saveXmlFile fileName $ svgOfDiagram diagram---- | Helper function helping you save a diagram as--- a SVG file on disk with a customized grid size.-saveAsciiDiagramAsSvgAtSize :: FilePath -> GridSize -> Diagram -> IO ()-saveAsciiDiagramAsSvgAtSize fileName gridSize =- saveXmlFile fileName . svgOfDiagramAtSize gridSize (defaultLibrary gridSize)---- | Render a Diagram as an image. The Dpi--- is 96. The IO dependency is there to allow loading of the--- font files used in the document.-imageOfDiagram :: FontCache -> Diagram -> IO (Image PixelRGBA8)-imageOfDiagram cache = - fmap fst . renderSvgDocument cache Nothing 96 . svgOfDiagram---- | Render a Diagram as an image with a custom grid size. The Dpi--- is 96. The IO dependency is there to allow loading of the--- font files used in the document.-imageOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO (Image PixelRGBA8)-imageOfDiagramAtSize cache gridSize =- fmap fst . renderSvgDocument cache Nothing 96- . svgOfDiagramAtSize gridSize (defaultLibrary gridSize)---- | Render a Diagram into a PDF file. IO dependency to allow--- loading of the font files used in the document.-pdfOfDiagram :: FontCache -> Diagram -> IO LB.ByteString-pdfOfDiagram cache =- fmap fst . pdfOfSvgDocument cache Nothing 96 . svgOfDiagram---- | Render a Diagram into a PDF file with a custom grid size.--- IO dependency to allow loading of the font files used in the document.-pdfOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO LB.ByteString-pdfOfDiagramAtSize cache size =- fmap fst . pdfOfSvgDocument cache Nothing 96- . svgOfDiagramAtSize size (defaultLibrary size)---- $introDoc--- Ascii diagram, transform your ASCII art drawing to a nicer--- representation--- --- --- @--- \/---------+--- +---------+ | |--- | ASCII +----\>| Diagram |--- +---------+ | |--- |{flat} | +--+------\/--- \\---*-----\/\<=======\/--- ::: .flat .filled_shape { fill: #DED; }--- @--- <<docimages/baseExample.svg>>--- ---- $linesdoc--- The basic syntax of asciidiagrams is made of lines made out--- of \'-\' and \'|\' characters. They can be connected with anchors--- like \'+\' (direct connection) or \'\\\' and \'\/\' (smooth connections)--- --- --- @--- ----- --- ------- --- --- | | --- | | --- | \\---- --- | --- +----- --- @--- <<docimages/simple_lines.svg>>--- --- You can use dashed lines by using ':' for vertical lines or '=' for--- horizontal line--- --- --- @--- ----- --- -=----- --- --- | : --- | | --- | \\---- --- | --- +--=-- --- @--- <<docimages/dashed_lines.svg>>--- --- Arrows are made out of the \'\<\', \'\>\', \'^\' and \'v\'--- characters.--- If the arrows are not connected to any lines, the text is left as is.--- --- --- @--- ^--- |--- |--- \<----+----\>--- | \< \> v ^--- |--- v--- --- @--- <<docimages/arrows.svg>>--- ---- $shapesdoc--- If the lines are closed, then it is detected as such and rendered--- differently--- --- --- @--- +------+--- | |--- | +--+--- | | |--- +---+--+ |--- | |--- +-----+--- @--- <<docimages/complexClosed.svg>>--- --- If any of the segment posess one of the dashing markers (\':\' or \'=\')--- Then the full shape will be dashed.--- --- --- @--- +--+ +--+ +=-+ +=-+--- | | : | | | | :--- +--+ +--+ +--+ +-=+--- @--- <<docimages/dashingClosed.svg>>--- --- Any of the angle of a shape can curved one of the smooth corner anchor--- (\'\\\' or \'\/\')--- --- --- @--- \/--+ +--\\ +--+ \/--+--- | | | | | | | |--- +--+ +--+ \\--+ +--+--- --- \/--+ \/--\\ \/--+ \/--\\ .--- | | | | | | | |--- +--\/ +--+ \\--\/ +--\/--- --- \/--\\ .--- | |--- \\--\/--- .--- @--- <<docimages/curvedCorner.svg>>--- ---- $bulletdoc--- Adding a \'*\' on a line or on a shape add a little circle on it.--- If the bullet is not attached to any shape or lines, then it--- will be render like any other text.--- --- --- @--- *-*-*--- | | *----*--- +---\/ |--- * * *--- @--- <<docimages/bulletTest.svg>>--- --- When used at connection points, it behaves like the \'+\' anchor.--- ---- $styledoc--- The shapes can ba annotated with a tag like `{tagname}`.--- Tags will be inserted in the class attribute of the shape--- and can then be stylized with a CSS.--- --- --- @--- +--------+ +--------+--- | Source +--------\>| op1 |--- | {src} | \\---+----\/--- +--------+ |--- +-------*\<--\/--- +------+\<--| op2 |--- | Dest | +-------+--- |{dst} |--- +------+--- --- ::: .src .filled_shape { fill: #AAF; }--- ::: .dst .filled_shape { stroke: #FAA; stroke-width: 3px; }--- @--- <<docimages/styleExample.svg>>--- --- Inline css styles are introduced with the ":::" prefix--- at the beginning of the line. They are introduced in the--- style section of the generated CSS file--- --- The generated geometry also possess some predefined class--- which are overidable:--- --- * "dashed_elem" is applied on every dashed element.--- --- * "filled_shape" is applied on every closed shape.--- --- * "arrow_head" is applied on arrow head.--- --- * "bullet" on every bullet placed on a shape or line.--- --- * "line_element" on every line element, this include the arrow head.--- --- You can then customize the appearance of the diagram as you want.--- ---- $hierarchicalDoc--- Starting with version 1.3, all shapes, text and lines are--- hierachised, a shape within a shape will be integrated within--- the same group. This allows more complex styling: --- --- --- @--- \/------------------------------------------------------\\ .--- |s100 |--- | \/----------------------------\\ |--- | |s1 \/--------\\ | e1 \/--------\\ |--- | | *---\>| s2 | +-------\>| s10 | |--- | +----+ \\---+----\/ | \\--------\/ |--- | | i4 | | | ^ |--- | |{ii}+---------\\| e1 {lo} | | |--- | +----+ vv | ealarm | | e0 \/-------------\\ .--- | | \/--------\\ +-----------\/ +----------\>| s50 |--- | +----\\ | s3 {lu}| | | \\-------------\/--- | | o5 | e2 \\--+-----\/ | |--- | |{oo}|\<---------\/ |\<-\\ |--- | \\-+--+--------------------+--\/ | |--- | | | | eReset |--- | | \\-----\/ |--- | v |--- | \/--------\\ |--- | | s20 | {li} |--- | \\--------\/ |--- \\------------------------------------------------------\/--- --- ::: .li .line_element { stroke: purple; }--- ::: .li .arrow_head, .li text { fill: gray; }--- ::: .lo .line_element { stroke: blue; }--- ::: .lo .arrow_head, .lo text { fill: green; }--- ::: .lu .line_element { stroke: red; }--- ::: .lu .arrow_head, .lu text { fill: orange; }--- ::: .ii .filled_shape { fill: #DDF; }--- ::: .ii text { fill: blue; }--- ::: .oo .filled_shape { fill: #DFD; }--- ::: .oo text { fill: pink; }--- @--- <<docimages/deepStyleExample.svg>>--- --- In the previous example, we can see that the lines color are--- 'shape scoped' and the tag applied to the shape above them--- applies to them--- ---- $shapeDoc--- From version 1.3, you can substitute the shape of your element--- with one from a shape library. Right now the shape library is--- relatively small:--- --- --- @--- +---------+ +----------+--- | | | |--- | circle | | |--- | | | io |--- |{circle} | | {io} |--- +---------+ +----------+--- --- +----------+ +----------+--- |document | | |--- | | | |--- | | | storage |--- |{document}| | {storage}|--- +----------+ +----------+--- --- ::: .circle .filled_shape { shape: circle; }--- ::: .document .filled_shape { shape: document; }--- ::: .storage .filled_shape { shape: storage; }--- ::: .io .filled_shape { shape: io; }--- @--- <<docimages/shapeExample.svg>>--- --- The mechanism use CSS styling to change the shape, if a CSS rule--- possess a `shape` pseudo attribute, then the generated shape is replaced--- with a SVG `use` tag with the value of the shape attribute as `href`--- --- But, you can create your own style library and change the default--- stylesheet. You can retrieve the default one with the shell command--- `asciidiagram --dump-library default-lib.svg`--- --- You can then add your own symbols tag in it and use it by calling--- `asciidiagram --with-library your-lib.svg`.--- +{-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +-- | This module gives access to the ascii diagram parser and +-- SVG renderer. +-- +-- Ascii diagram, transform your ASCII art drawing to a nicer +-- representation +-- +-- @ +-- \/---------+ +-- +---------+ | | +-- | ASCII +----\>| Diagram | +-- +---------+ | | +-- |{flat} | +--+------\/ +-- \\---*-----\/\<=======\/ +-- ::: .flat .filled_shape { fill: #DDD; } +-- @ +-- <<docimages/baseExample.svg>> +-- +-- To render the diagram as a PNG file, you have to use the +-- library rasterific-svg and JuicyPixels. +-- +-- As a sample usage, to save a diagram to png, you can use +-- the following snippet. +-- +-- > import Codec.Picture( writePng ) +-- > import Text.AsciiDiagram( imageOfDiagram ) +-- > import Graphics.Rasterific.Svg( loadCreateFontCache ) +-- > +-- > saveDiagramToFile :: FilePath -> Diagram -> IO () +-- > saveDiagramToFile path diag = do +-- > cache <- loadCreateFontCache "asciidiagram-fonty-fontcache" +-- > imageOfDiagram cache 96 diag +-- > writePng path img +-- +module Text.AsciiDiagram + ( + -- $introDoc + -- * Diagram format + + -- ** Lines + -- $linesdoc + + -- ** Shapes + -- $shapesdoc + + -- ** Bullets + -- $bulletdoc + + -- ** Styles + -- $styledoc + + -- ** Hierarchical styles + -- $hierarchicalDoc + + -- ** Shapes + -- $shapeDoc + + -- * Functions + svgOfDiagram + , parseAsciiDiagram + , saveAsciiDiagramAsSvg + , imageOfDiagram + , pdfOfDiagram + + -- * Customized rendering + , svgOfDiagramAtSize + , GridSize( .. ) + , defaultGridSize + , saveAsciiDiagramAsSvgAtSize + , imageOfDiagramAtSize + , pdfOfDiagramAtSize + + -- * Library + , defaultLibrary + + -- * Document description + , Diagram( .. ) + , TextZone( .. ) + , Shape( .. ) + , ShapeElement( .. ) + , Anchor( .. ) + , Segment( .. ) + , SegmentKind( .. ) + , SegmentDraw( .. ) + , Point + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Monoid( (<>)) +import Control.Monad( forM_ ) +import Control.Monad.ST( runST ) +import Data.Function( on ) +import Data.List( partition, sortBy ) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Linear( V2( V2 ) ) + +import Text.AsciiDiagram.Parser +import Text.AsciiDiagram.Reconstructor +import Text.AsciiDiagram.SvgRender +import Text.AsciiDiagram.Geometry +import Text.AsciiDiagram.DiagramCleaner + +import Codec.Picture( Image, PixelRGBA8 ) +import Graphics.Text.TrueType( FontCache ) +import Graphics.Svg( saveXmlFile ) +import Graphics.Rasterific.Svg( renderSvgDocument, pdfOfSvgDocument ) + +{-import Debug.Trace-} +{-import Text.Groom-} +{-import Text.Printf-} + +data CharBoard = CharBoard + { _boardWidth :: !Int + , _boardHeight :: !Int + , _boardData :: !(VU.Vector Char) + } + deriving (Eq, Show) + +textOfCharBoard :: CharBoard -> [T.Text] +textOfCharBoard board = fetch <$> zip [0 .. h - 1] [0, w..] where + w = _boardWidth board + h = _boardHeight board + charData = _boardData board + + fetch (_, startIdx) = + T.pack . VU.toList . VU.take w $ VU.drop startIdx charData + +charBoardOfText :: [T.Text] -> CharBoard +charBoardOfText textLines = CharBoard + { _boardWidth = twidth + , _boardHeight = theight + , _boardData = charData + } + where + twidth = maximum $ fmap T.length textLines + theight = length textLines + + lineIndices = zip [0, twidth ..] textLines + + charData = runST $ do + emptyBoard <- VUM.replicate (twidth * theight) ' ' + + forM_ lineIndices $ \(lineIndex, l) -> do + let chars = zip [lineIndex, lineIndex + 1 ..] $ T.unpack l + forM_ chars $ \(idx, c) -> do + VUM.unsafeWrite emptyBoard idx c + + VU.unsafeFreeze emptyBoard + + +pointsOfShape :: F.Foldable f => f Shape -> [Point] +pointsOfShape = F.concatMap (F.concatMap go . shapeElements) where + go (ShapeAnchor p _) = [p] + go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey }) + | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]] + | sx == ex = [V2 sx yy | yy <- [sy .. ey]] + | sy == ey && sx >= ex = [V2 xx sy | xx <- [ex .. sx]] + | sy == ey = [V2 xx sy | xx <- [sx .. ex]] + | otherwise = [] + +cleanLines :: [Int] -> CharBoard -> CharBoard +cleanLines idxs board = board { _boardData = _boardData board VU.// toSet } + where + xMax = _boardWidth board - 1 + toSet = [(lineIndex + column, ' ') + | lineNum <- idxs + , let lineIndex = lineNum * _boardWidth board + , column <- [0 .. xMax] + ] + +cleanupShapes :: (F.Foldable f) => f Shape -> CharBoard -> CharBoard +cleanupShapes shapes board = board { _boardData = _boardData board VU.// toSet } + where + toSet = [(x + y * _boardWidth board, ' ') | V2 x y <- pointsOfShape shapes] + + +pointComp :: Point -> Point -> Ordering +pointComp (V2 x1 y1) (V2 x2 y2) = case compare y1 y2 of + EQ -> compare x1 x2 + a -> a + +featuresOfClosedShape :: Shape -> [Point] +featuresOfClosedShape = F.fold . go . shapeElements where + go [] = [] + -- If we got something like +----+ we skip the first anchor and + -- the segment. + go ( ShapeAnchor (V2 _ ay1) _ + : ShapeSegment Segment { _segStart = V2 _ sy, _segEnd = V2 _ ey } + : rest@(ShapeAnchor (V2 _ ay2) _ : _) + ) + | ay1 == ay2 && sy == ey && ay1 == sy = go rest + go (ShapeAnchor p _: rest) = [p] : go rest + go (ShapeSegment Segment { _segStart = V2 sx sy, _segEnd = V2 ex ey } : rest) + | sx == ex && sy >= ey = [V2 sx yy | yy <- [ey .. sy]] : after + | sx == ex = [V2 sx yy | yy <- [sy .. ey]] : after + | otherwise = after + where after = go rest + +rangesOfOpenedShape :: Shape -> [(Point, Point)] +rangesOfOpenedShape s = fmap dup . sortBy pointComp $ pointsOfShape [s] + where dup a = (a, a) + +rangesOfClosedShape :: Shape -> [(Point, Point)] +rangesOfClosedShape shape = pairAssoc sortedPoints + where + pairAssoc [] = [] + pairAssoc [_] = [] + pairAssoc (p1@(V2 _ y1):lst@(p2@(V2 _ y2):rest)) + | y1 == y2 = (p1, p2) : pairAssoc rest + | otherwise = pairAssoc lst + + sortedPoints = sortBy pointComp $ featuresOfClosedShape shape + + +class RangeDecomposable a where + rangesOf :: a -> [(Point, Point)] + +instance RangeDecomposable Shape where + rangesOf s + | shapeIsClosed s = rangesOfClosedShape s + | otherwise = rangesOfOpenedShape s + +instance RangeDecomposable TextZone where + rangesOf txt = [(orig, V2 (x + txtLength) y)] where + orig@(V2 x y) = _textZoneOrigin txt + txtLength = T.length $ _textZoneContent txt + + +contains :: (RangeDecomposable a, RangeDecomposable b) => a -> b -> Bool +contains sa sb = go (rangesOf sa) (rangesOf sb) where + go _ [] = True + go [] (_:_) = False + go ((V2 _ ya, _):rest1) rest2@((V2 _ yb, _):_) + -- A part of second shape is before potentially englobing shpae + -- so sa can't contain sb + | ya > yb = False + -- sa may be bigger, just skip + | ya < yb = go rest1 rest2 + -- here ya == yb + go sal@((V2 xa1 _, V2 xa2 _):rest1) + sar@((V2 xb1 _, V2 xb2 _):rest2) + -- sb is before any range of sa, so we must have + -- missed something, sa not containing sb + | xb1 < xa1 = False + -- sb is in the range bounds + | xa1 <= xb1 && xb2 <= xa2 = go sal rest2 + -- Maybe sa has another range on the same line + | xb1 > xa2 = go rest1 sar + | otherwise = False + +areaOfShape :: Shape -> Int +areaOfShape = F.sum . fmap dist . rangesOfClosedShape + where + -- we can use manathan distance here + dist (V2 x1 y1, V2 x2 y2) = abs (x1 - x2) + abs (y1 - y2) + +sortByArea :: [Shape] -> [Shape] +sortByArea shapes = sorted <> opened + where + (closed, opened) = partition shapeIsClosed shapes + sorted = + fmap snd . reverse $ sortBy (compare `on` fst) [(areaOfShape s, s) | s <- closed] + +hierarchise :: [Shape] -> [TextZone] -> [TextZone] -> [Element] +hierarchise shapes allTexts = finalize . go areaSortedShapes allTexts where + areaSortedShapes = sortByArea shapes + + finalize (topShapes, topText, _topTags) = + (ElemShape <$> topShapes) <> (ElemText <$> topText) + + go [] texts tags = ([], texts, tags) + go (x:xs) texts tags | not (shapeIsClosed x) = (x:outShapes, outTexts, outTags) + where + (outShapes, outTexts, outTags) = go xs texts tags + go (x:xs) texts tags = (newShape : restShapes, restText, restTags) + where + (shapeInShape, shapeOutShape) = partition (x `contains`) xs + (textInShape, textOutShape) = partition (x `contains`) texts + (tagsInShape, tagsOutShape) = partition (x `contains`) tags + + (innerShapes, innerText, innerTags) = go shapeInShape textInShape tagsInShape + (restShapes, restText, restTags) = go shapeOutShape textOutShape tagsOutShape + + newShape = x + { shapeChildren = + (ElemShape <$> innerShapes) <> (ElemText <$> innerText) + , shapeTags = S.fromList $ _textZoneContent <$> innerTags + } + +-- | Analyze an ascii diagram and extract all it's features. +parseAsciiDiagram :: T.Text -> Diagram +parseAsciiDiagram content = Diagram + { _diagramElements = S.fromList allElements + , _diagramCellWidth = maximum $ fmap T.length textLines + , _diagramCellHeight = length textLines - length styleLines + , _diagramStyles = reverse styleLines + } + where + textLines = T.lines content + allElements = hierarchise (S.toList validShapes) nonEmptyZones tags + + nonEmptyZones = [t | t <- zones, not . T.null $ _textZoneContent t] + (tags, zones) = detectTagFromTextZone $ extractTextZones shapeCleanedText + (styleLineNumber, styleLines) = unzip $ styleLine parsed + + shapeCleanedText = + textOfCharBoard . cleanLines styleLineNumber + . cleanupShapes validShapes + $ charBoardOfText textLines + + parsed = parseTextLines textLines + reconstructed = + reconstruct (anchorMap parsed) $ segmentSet parsed + validShapes = S.filter isShapePossible reconstructed + +-- | Helper function helping you save a diagram as +-- a SVG file on disk. +saveAsciiDiagramAsSvg :: FilePath -> Diagram -> IO () +saveAsciiDiagramAsSvg fileName diagram = + saveXmlFile fileName $ svgOfDiagram diagram + +-- | Helper function helping you save a diagram as +-- a SVG file on disk with a customized grid size. +saveAsciiDiagramAsSvgAtSize :: FilePath -> GridSize -> Diagram -> IO () +saveAsciiDiagramAsSvgAtSize fileName gridSize = + saveXmlFile fileName . svgOfDiagramAtSize gridSize (defaultLibrary gridSize) + +-- | Render a Diagram as an image. The Dpi +-- is 96. The IO dependency is there to allow loading of the +-- font files used in the document. +imageOfDiagram :: FontCache -> Diagram -> IO (Image PixelRGBA8) +imageOfDiagram cache = + fmap fst . renderSvgDocument cache Nothing 96 . svgOfDiagram + +-- | Render a Diagram as an image with a custom grid size. The Dpi +-- is 96. The IO dependency is there to allow loading of the +-- font files used in the document. +imageOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO (Image PixelRGBA8) +imageOfDiagramAtSize cache gridSize = + fmap fst . renderSvgDocument cache Nothing 96 + . svgOfDiagramAtSize gridSize (defaultLibrary gridSize) + +-- | Render a Diagram into a PDF file. IO dependency to allow +-- loading of the font files used in the document. +pdfOfDiagram :: FontCache -> Diagram -> IO LB.ByteString +pdfOfDiagram cache = + fmap fst . pdfOfSvgDocument cache Nothing 96 . svgOfDiagram + +-- | Render a Diagram into a PDF file with a custom grid size. +-- IO dependency to allow loading of the font files used in the document. +pdfOfDiagramAtSize :: FontCache -> GridSize -> Diagram -> IO LB.ByteString +pdfOfDiagramAtSize cache size = + fmap fst . pdfOfSvgDocument cache Nothing 96 + . svgOfDiagramAtSize size (defaultLibrary size) + +-- $introDoc +-- Ascii diagram, transform your ASCII art drawing to a nicer +-- representation +-- +-- +-- @ +-- \/---------+ +-- +---------+ | | +-- | ASCII +----\>| Diagram | +-- +---------+ | | +-- |{flat} | +--+------\/ +-- \\---*-----\/\<=======\/ +-- ::: .flat .filled_shape { fill: #DED; } +-- @ +-- <<docimages/baseExample.svg>> +-- + +-- $linesdoc +-- The basic syntax of asciidiagrams is made of lines made out +-- of \'-\' and \'|\' characters. They can be connected with anchors +-- like \'+\' (direct connection) or \'\\\' and \'\/\' (smooth connections) +-- +-- +-- @ +-- ----- +-- ------- +-- +-- | | +-- | | +-- | \\---- +-- | +-- +----- +-- @ +-- <<docimages/simple_lines.svg>> +-- +-- You can use dashed lines by using ':' for vertical lines or '=' for +-- horizontal line +-- +-- +-- @ +-- ----- +-- -=----- +-- +-- | : +-- | | +-- | \\---- +-- | +-- +--=-- +-- @ +-- <<docimages/dashed_lines.svg>> +-- +-- Arrows are made out of the \'\<\', \'\>\', \'^\' and \'v\' +-- characters. +-- If the arrows are not connected to any lines, the text is left as is. +-- +-- +-- @ +-- ^ +-- | +-- | +-- \<----+----\> +-- | \< \> v ^ +-- | +-- v +-- +-- @ +-- <<docimages/arrows.svg>> +-- + +-- $shapesdoc +-- If the lines are closed, then it is detected as such and rendered +-- differently +-- +-- +-- @ +-- +------+ +-- | | +-- | +--+ +-- | | | +-- +---+--+ | +-- | | +-- +-----+ +-- @ +-- <<docimages/complexClosed.svg>> +-- +-- If any of the segment posess one of the dashing markers (\':\' or \'=\') +-- Then the full shape will be dashed. +-- +-- +-- @ +-- +--+ +--+ +=-+ +=-+ +-- | | : | | | | : +-- +--+ +--+ +--+ +-=+ +-- @ +-- <<docimages/dashingClosed.svg>> +-- +-- Any of the angle of a shape can curved one of the smooth corner anchor +-- (\'\\\' or \'\/\') +-- +-- +-- @ +-- \/--+ +--\\ +--+ \/--+ +-- | | | | | | | | +-- +--+ +--+ \\--+ +--+ +-- +-- \/--+ \/--\\ \/--+ \/--\\ . +-- | | | | | | | | +-- +--\/ +--+ \\--\/ +--\/ +-- +-- \/--\\ . +-- | | +-- \\--\/ +-- . +-- @ +-- <<docimages/curvedCorner.svg>> +-- + +-- $bulletdoc +-- Adding a \'*\' on a line or on a shape add a little circle on it. +-- If the bullet is not attached to any shape or lines, then it +-- will be render like any other text. +-- +-- +-- @ +-- *-*-* +-- | | *----* +-- +---\/ | +-- * * * +-- @ +-- <<docimages/bulletTest.svg>> +-- +-- When used at connection points, it behaves like the \'+\' anchor. +-- + +-- $styledoc +-- The shapes can ba annotated with a tag like `{tagname}`. +-- Tags will be inserted in the class attribute of the shape +-- and can then be stylized with a CSS. +-- +-- +-- @ +-- +--------+ +--------+ +-- | Source +--------\>| op1 | +-- | {src} | \\---+----\/ +-- +--------+ | +-- +-------*\<--\/ +-- +------+\<--| op2 | +-- | Dest | +-------+ +-- |{dst} | +-- +------+ +-- +-- ::: .src .filled_shape { fill: #AAF; } +-- ::: .dst .filled_shape { stroke: #FAA; stroke-width: 3px; } +-- @ +-- <<docimages/styleExample.svg>> +-- +-- Inline css styles are introduced with the ":::" prefix +-- at the beginning of the line. They are introduced in the +-- style section of the generated CSS file +-- +-- The generated geometry also possess some predefined class +-- which are overidable: +-- +-- * "dashed_elem" is applied on every dashed element. +-- +-- * "filled_shape" is applied on every closed shape. +-- +-- * "arrow_head" is applied on arrow head. +-- +-- * "bullet" on every bullet placed on a shape or line. +-- +-- * "line_element" on every line element, this include the arrow head. +-- +-- You can then customize the appearance of the diagram as you want. +-- + +-- $hierarchicalDoc +-- Starting with version 1.3, all shapes, text and lines are +-- hierachised, a shape within a shape will be integrated within +-- the same group. This allows more complex styling: +-- +-- +-- @ +-- \/------------------------------------------------------\\ . +-- |s100 | +-- | \/----------------------------\\ | +-- | |s1 \/--------\\ | e1 \/--------\\ | +-- | | *---\>| s2 | +-------\>| s10 | | +-- | +----+ \\---+----\/ | \\--------\/ | +-- | | i4 | | | ^ | +-- | |{ii}+---------\\| e1 {lo} | | | +-- | +----+ vv | ealarm | | e0 \/-------------\\ . +-- | | \/--------\\ +-----------\/ +----------\>| s50 | +-- | +----\\ | s3 {lu}| | | \\-------------\/ +-- | | o5 | e2 \\--+-----\/ | | +-- | |{oo}|\<---------\/ |\<-\\ | +-- | \\-+--+--------------------+--\/ | | +-- | | | | eReset | +-- | | \\-----\/ | +-- | v | +-- | \/--------\\ | +-- | | s20 | {li} | +-- | \\--------\/ | +-- \\------------------------------------------------------\/ +-- +-- ::: .li .line_element { stroke: purple; } +-- ::: .li .arrow_head, .li text { fill: gray; } +-- ::: .lo .line_element { stroke: blue; } +-- ::: .lo .arrow_head, .lo text { fill: green; } +-- ::: .lu .line_element { stroke: red; } +-- ::: .lu .arrow_head, .lu text { fill: orange; } +-- ::: .ii .filled_shape { fill: #DDF; } +-- ::: .ii text { fill: blue; } +-- ::: .oo .filled_shape { fill: #DFD; } +-- ::: .oo text { fill: pink; } +-- @ +-- <<docimages/deepStyleExample.svg>> +-- +-- In the previous example, we can see that the lines color are +-- 'shape scoped' and the tag applied to the shape above them +-- applies to them +-- + +-- $shapeDoc +-- From version 1.3, you can substitute the shape of your element +-- with one from a shape library. Right now the shape library is +-- relatively small: +-- +-- +-- @ +-- +---------+ +----------+ +-- | | | | +-- | circle | | | +-- | | | io | +-- |{circle} | | {io} | +-- +---------+ +----------+ +-- +-- +----------+ +----------+ +-- |document | | | +-- | | | | +-- | | | storage | +-- |{document}| | {storage}| +-- +----------+ +----------+ +-- +-- ::: .circle .filled_shape { shape: circle; } +-- ::: .document .filled_shape { shape: document; } +-- ::: .storage .filled_shape { shape: storage; } +-- ::: .io .filled_shape { shape: io; } +-- @ +-- <<docimages/shapeExample.svg>> +-- +-- The mechanism use CSS styling to change the shape, if a CSS rule +-- possess a `shape` pseudo attribute, then the generated shape is replaced +-- with a SVG `use` tag with the value of the shape attribute as `href` +-- +-- But, you can create your own style library and change the default +-- stylesheet. You can retrieve the default one with the shell command +-- `asciidiagram --dump-library default-lib.svg` +-- +-- You can then add your own symbols tag in it and use it by calling +-- `asciidiagram --with-library your-lib.svg`. +--
src/Text/AsciiDiagram/BoundingBoxEstimation.hs view
@@ -1,124 +1,124 @@-{-# LANGUAGE CPP #-}-module Text.AsciiDiagram.BoundingBoxEstimation where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), (<*>)- , pure- )-import Data.Foldable( foldMap )-import Data.Monoid( Monoid( mappend, mempty )- , mconcat- )-#endif--import Data.Monoid( (<>) )-import Linear( V2( .. )- , (^+^)- , (^-^)- )--import Graphics.Svg.Types--data BoundingBox = BoundingBox- { _boundingLow :: !RPoint- , _boundingHight :: !RPoint- }- deriving (Eq, Show)--instance Monoid BoundingBox where- mempty = BoundingBox (V2 0 0) (V2 0 0)- mappend (BoundingBox min1 max1) (BoundingBox min2 max2) =- BoundingBox (min <$> min1 <*> min2) (max <$> max1 <*> max2)--toEstimatedLength :: Number -> Coord-toEstimatedLength n = case toUserUnit 96 n of- Num p -> p- _ -> 0--toEstimatedPoint :: (Number, Number) -> RPoint-toEstimatedPoint (a, b) = V2 a' b' where- a' = toEstimatedLength a- b' = toEstimatedLength b--toB :: RPoint -> BoundingBox-toB p = BoundingBox p p--class WithBoundingBox a where- boundingBoxOf :: a -> BoundingBox--instance WithBoundingBox PolyLine where- boundingBoxOf = foldMap toB . _polyLinePoints--instance WithBoundingBox Polygon where- boundingBoxOf = foldMap toB . _polygonPoints--instance WithBoundingBox Line where- boundingBoxOf (Line _ p1 p2) =- toB (toEstimatedPoint p1) <> toB (toEstimatedPoint p2)--instance WithBoundingBox Rectangle where- boundingBoxOf (Rectangle _ base w h _) =- toB base' <> toB (base' ^+^ toEstimatedPoint (w, h))- where base' = toEstimatedPoint base--pointOfPath :: PathCommand -> [RPoint]-pointOfPath c = case c of- MoveTo _ l -> l- LineTo _ l -> l- HorizontalTo _ _ -> mempty- VerticalTo _ _ -> mempty- CurveTo _ l -> mconcat [[a, b, cc] | (a, b, cc) <- l]- SmoothCurveTo _ l -> mconcat [[a, b] | (a, b) <- l]- QuadraticBezier _ l -> mconcat [[a, b] | (a, b) <- l]- SmoothQuadraticBezierCurveTo _ l -> l- EllipticalArc _ _ -> mempty- EndPath -> mempty--instance WithBoundingBox Path where- boundingBoxOf (Path _ p) = foldMap (foldMap toB . pointOfPath) p--instance WithBoundingBox a => WithBoundingBox (Group a) where- boundingBoxOf (Group _ child _ _) = foldMap boundingBoxOf child--instance WithBoundingBox a => WithBoundingBox (Symbol a) where- boundingBoxOf (Symbol g) = boundingBoxOf g--instance WithBoundingBox Text where- boundingBoxOf = boundingBoxOf . _textRoot--instance WithBoundingBox TextSpan where- boundingBoxOf = boundingBoxOf . _spanInfo--instance WithBoundingBox TextInfo where- boundingBoxOf t = case (_textInfoX t, _textInfoY t) of- (x1:_, y1:_) -> toB (toEstimatedPoint (x1, y1))- _ -> mempty--instance WithBoundingBox Circle where- boundingBoxOf (Circle _ center rad) = BoundingBox (c ^-^ r) (c ^+^ r)- where- c = toEstimatedPoint center- r = pure $ toEstimatedLength rad--instance WithBoundingBox Ellipse where- boundingBoxOf (Ellipse _ center xrad yrad) = BoundingBox (c ^-^ r) (c ^+^ r)- where- c = toEstimatedPoint center- r = V2 (toEstimatedLength xrad) (toEstimatedLength yrad)--instance WithBoundingBox Tree where- boundingBoxOf t = case t of- None -> mempty- UseTree _ _ -> mempty- PathTree p -> boundingBoxOf p- CircleTree c -> boundingBoxOf c- PolyLineTree pl -> boundingBoxOf pl- PolygonTree po -> boundingBoxOf po- EllipseTree e -> boundingBoxOf e- LineTree l -> boundingBoxOf l- RectangleTree r -> boundingBoxOf r- TextTree _ txt -> boundingBoxOf txt- ImageTree _ -> mempty- GroupTree g -> boundingBoxOf g- SymbolTree s -> boundingBoxOf s-+{-# LANGUAGE CPP #-} +module Text.AsciiDiagram.BoundingBoxEstimation where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>) + , pure + ) +import Data.Foldable( foldMap ) +import Data.Monoid( Monoid( mappend, mempty ) + , mconcat + ) +#endif + +import Data.Monoid( (<>) ) +import Linear( V2( .. ) + , (^+^) + , (^-^) + ) + +import Graphics.Svg.Types + +data BoundingBox = BoundingBox + { _boundingLow :: !RPoint + , _boundingHight :: !RPoint + } + deriving (Eq, Show) + +instance Monoid BoundingBox where + mempty = BoundingBox (V2 0 0) (V2 0 0) + mappend (BoundingBox min1 max1) (BoundingBox min2 max2) = + BoundingBox (min <$> min1 <*> min2) (max <$> max1 <*> max2) + +toEstimatedLength :: Number -> Coord +toEstimatedLength n = case toUserUnit 96 n of + Num p -> p + _ -> 0 + +toEstimatedPoint :: (Number, Number) -> RPoint +toEstimatedPoint (a, b) = V2 a' b' where + a' = toEstimatedLength a + b' = toEstimatedLength b + +toB :: RPoint -> BoundingBox +toB p = BoundingBox p p + +class WithBoundingBox a where + boundingBoxOf :: a -> BoundingBox + +instance WithBoundingBox PolyLine where + boundingBoxOf = foldMap toB . _polyLinePoints + +instance WithBoundingBox Polygon where + boundingBoxOf = foldMap toB . _polygonPoints + +instance WithBoundingBox Line where + boundingBoxOf (Line _ p1 p2) = + toB (toEstimatedPoint p1) <> toB (toEstimatedPoint p2) + +instance WithBoundingBox Rectangle where + boundingBoxOf (Rectangle _ base w h _) = + toB base' <> toB (base' ^+^ toEstimatedPoint (w, h)) + where base' = toEstimatedPoint base + +pointOfPath :: PathCommand -> [RPoint] +pointOfPath c = case c of + MoveTo _ l -> l + LineTo _ l -> l + HorizontalTo _ _ -> mempty + VerticalTo _ _ -> mempty + CurveTo _ l -> mconcat [[a, b, cc] | (a, b, cc) <- l] + SmoothCurveTo _ l -> mconcat [[a, b] | (a, b) <- l] + QuadraticBezier _ l -> mconcat [[a, b] | (a, b) <- l] + SmoothQuadraticBezierCurveTo _ l -> l + EllipticalArc _ _ -> mempty + EndPath -> mempty + +instance WithBoundingBox Path where + boundingBoxOf (Path _ p) = foldMap (foldMap toB . pointOfPath) p + +instance WithBoundingBox a => WithBoundingBox (Group a) where + boundingBoxOf (Group _ child _ _) = foldMap boundingBoxOf child + +instance WithBoundingBox a => WithBoundingBox (Symbol a) where + boundingBoxOf (Symbol g) = boundingBoxOf g + +instance WithBoundingBox Text where + boundingBoxOf = boundingBoxOf . _textRoot + +instance WithBoundingBox TextSpan where + boundingBoxOf = boundingBoxOf . _spanInfo + +instance WithBoundingBox TextInfo where + boundingBoxOf t = case (_textInfoX t, _textInfoY t) of + (x1:_, y1:_) -> toB (toEstimatedPoint (x1, y1)) + _ -> mempty + +instance WithBoundingBox Circle where + boundingBoxOf (Circle _ center rad) = BoundingBox (c ^-^ r) (c ^+^ r) + where + c = toEstimatedPoint center + r = pure $ toEstimatedLength rad + +instance WithBoundingBox Ellipse where + boundingBoxOf (Ellipse _ center xrad yrad) = BoundingBox (c ^-^ r) (c ^+^ r) + where + c = toEstimatedPoint center + r = V2 (toEstimatedLength xrad) (toEstimatedLength yrad) + +instance WithBoundingBox Tree where + boundingBoxOf t = case t of + None -> mempty + UseTree _ _ -> mempty + PathTree p -> boundingBoxOf p + CircleTree c -> boundingBoxOf c + PolyLineTree pl -> boundingBoxOf pl + PolygonTree po -> boundingBoxOf po + EllipseTree e -> boundingBoxOf e + LineTree l -> boundingBoxOf l + RectangleTree r -> boundingBoxOf r + TextTree _ txt -> boundingBoxOf txt + ImageTree _ -> mempty + GroupTree g -> boundingBoxOf g + SymbolTree s -> boundingBoxOf s +
src/Text/AsciiDiagram/DefaultContext.hs view
@@ -1,151 +1,151 @@-{-# LANGUAGE OverloadedStrings #-}-module Text.AsciiDiagram.DefaultContext- ( defaultCss- , defaultCssRules- , defaultDefinitions- ) where--import Control.Monad.State.Strict( execState )-import Data.Monoid( (<>) )--import Graphics.Svg.Types ( HasDrawAttributes( .. ), drawAttr )-import Graphics.Svg( cssRulesOfText )--import Codec.Picture( PixelRGBA8( PixelRGBA8 ) )-import qualified Graphics.Svg.Types as Svg-import qualified Graphics.Svg.CssTypes as Css-import qualified Data.Map as M-import qualified Data.Text as T-import Text.Printf-import Linear( V2( .. ) )-import Control.Lens( (.=), (.~), (&) )---defaultCss :: Float -> T.Text-defaultCss textSize = T.pack $ printf- ("\n" <>- "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <>- ".dashed_elem { stroke-dasharray: 4, 3 }\n" <>- ".filled_shape { fill: url(#shape_light); stroke: black; stroke-width: 1px; }\n" <>- ".line_element { fill: none; stroke: black; stroke-width: 1px; }\n" <>- ".bullet { stroke-width: 1px; fill: white; stroke: black }\n" <>- ".arrow_head { fill: black; stroke: none; }\n"- )- (2 + floor textSize :: Int)--defaultCssRules :: Float -> [Css.CssRule]-defaultCssRules = cssRulesOfText . defaultCss--lightShapeGradient :: Svg.Element-lightShapeGradient = Svg.ElementLinearGradient $- Svg.defaultSvg- { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0)- , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1)- , Svg._linearGradientStops =- [ Svg.GradientStop 0 $ PixelRGBA8 245 245 245 255- , Svg.GradientStop 1 $ PixelRGBA8 216 216 216 255- ]- }--toSymbol :: Double -> Double -> [Svg.Tree] -> Svg.Element-toSymbol width height geom = element where- element = Svg.ElementGeometry $ Svg.SymbolTree tree- tree = Svg.Symbol $ execState build Svg.defaultSvg-- build = do- Svg.groupChildren .= geom- Svg.groupViewBox .= Just (0, 0, width, height)- Svg.groupAspectRatio . Svg.aspectRatioAlign .= Svg.AlignNone--asFilled :: (Svg.WithDrawAttributes a) => a -> a-asFilled el = el & drawAttr.attrClass .~ ["filled_shape"]--defaultCircle :: Svg.Element-defaultCircle = toSymbol 50 50 [Svg.CircleTree $ asFilled circle] where- circle = Svg.defaultSvg- { Svg._circleCenter = (Css.Num 25, Css.Num 25)- , Svg._circleRadius = Css.Num 24.5- }--h, v :: [Svg.Coord] -> Svg.PathCommand-h = Svg.HorizontalTo Svg.OriginRelative-v = Svg.VerticalTo Svg.OriginRelative--m :: [Svg.RPoint] -> Svg.PathCommand-m = Svg.MoveTo Svg.OriginRelative--c :: [(Svg.RPoint, Svg.RPoint, Svg.RPoint)] -> Svg.PathCommand-c = Svg.CurveTo Svg.OriginRelative--l :: [Svg.RPoint] -> Svg.PathCommand-l = Svg.LineTo Svg.OriginRelative--z :: Svg.PathCommand-z = Svg.EndPath--defaultDocument :: Svg.Element-defaultDocument = toSymbol 51 51 [Svg.PathTree $ asFilled path] where- path = Svg.defaultSvg- { Svg._pathDefinition =- [ m [V2 49.98 0.79, V2 (-49.166) 0, V2 0 45.402]- , c [(V2 15.92 12.45, V2 30.40 (-13.44), V2 49.17 0)]- , z- ]- }--ioShape :: Svg.Element-ioShape = toSymbol 100 100 [Svg.PathTree $ asFilled path] where- path = Svg.defaultSvg- { Svg._pathDefinition =- [ m [V2 19.207 1.6]- , h [79.414]- , l [V2 (-17.192) 97.297]- , h [-79.414]- , z- ]- }--storageShape :: Svg.Element-storageShape = toSymbol 80 80 geometry where- geometry = Svg.PathTree . asFilled <$> [path1, path2]- path1 = Svg.defaultSvg- { Svg._pathDefinition =- [ m [V2 4.8122 67.74]- , v [-53.769]- , c [ (V2 0.0 (-3.2991) , V2 16.067 (-5.9743), V2 35.845 (-5.9743))- , (V2 19.78 0.0, V2 35.848 2.6752, V2 35.848 5.9743)- ]- , v [53.769]- , c [(V2 0.0 3.2925, V2 (-16.068) 5.9743, V2 (-35.848) 5.9743)- , (V2 (-19.779) 0.0, V2 (-35.845) (-2.6818), V2 (-35.845) (-5.9743))- ]- , z- ]- }- path2 = Svg.defaultSvg- { Svg._pathDefinition =- [ m [ V2 4.8122 13.97, V2 4.779e-2 0.30672, V2 0.13807 0.30272- , V2 0.22834 0.29872, V2 0.31464 0.29344, V2 0.40094 0.28944- , V2 0.48325 0.2828, V2 0.56423 0.27744, V2 0.64256 0.2708- , V2 0.71823 0.26416, V2 0.79258 0.25752, V2 0.86294 0.25096- , V2 0.9333 0.2416, V2 0.99968 0.23496, V2 1.0647 0.22568- , V2 1.1271 0.2164, V2 1.1869 0.2084, V2 1.2453 0.19784- , V2 1.301 0.1872, V2 1.3555 0.17792, V2 1.4046 0.16728- , V2 1.455 0.15536, V2 1.5002 0.14336, V2 1.5466 0.1328- , V2 1.5865 0.11952, V2 1.6276 0.10752, V2 1.6648 9.42e-2- , V2 1.7007 8.1e-2, V2 1.7338 6.64e-2, V2 1.7644 5.31e-2- , V2 1.7923 3.72e-2, V2 1.8188 2.39e-2, V2 1.8427 8.0e-3- ]- , c [(V2 19.78 0.0, V2 35.848 (-2.6818), V2 35.848 (-5.9743))]- ]- }--defaultDefinitions :: M.Map String Svg.Element-defaultDefinitions = M.fromList- [ ("shape_light", lightShapeGradient)- , ("circle", defaultCircle)- , ("document", defaultDocument)- , ("io", ioShape)- , ("storage", storageShape)- ]-+{-# LANGUAGE OverloadedStrings #-} +module Text.AsciiDiagram.DefaultContext + ( defaultCss + , defaultCssRules + , defaultDefinitions + ) where + +import Control.Monad.State.Strict( execState ) +import Data.Monoid( (<>) ) + +import Graphics.Svg.Types ( HasDrawAttributes( .. ), drawAttr ) +import Graphics.Svg( cssRulesOfText ) + +import Codec.Picture( PixelRGBA8( PixelRGBA8 ) ) +import qualified Graphics.Svg.Types as Svg +import qualified Graphics.Svg.CssTypes as Css +import qualified Data.Map as M +import qualified Data.Text as T +import Text.Printf +import Linear( V2( .. ) ) +import Control.Lens( (.=), (.~), (&) ) + + +defaultCss :: Float -> T.Text +defaultCss textSize = T.pack $ printf + ("\n" <> + "text { font-family: Consolas, \"DejaVu Sans Mono\", monospace; font-size: %dpx }\n" <> + ".dashed_elem { stroke-dasharray: 4, 3 }\n" <> + ".filled_shape { fill: url(#shape_light); stroke: black; stroke-width: 1px; }\n" <> + ".line_element { fill: none; stroke: black; stroke-width: 1px; }\n" <> + ".bullet { stroke-width: 1px; fill: white; stroke: black }\n" <> + ".arrow_head { fill: black; stroke: none; }\n" + ) + (2 + floor textSize :: Int) + +defaultCssRules :: Float -> [Css.CssRule] +defaultCssRules = cssRulesOfText . defaultCss + +lightShapeGradient :: Svg.Element +lightShapeGradient = Svg.ElementLinearGradient $ + Svg.defaultSvg + { Svg._linearGradientStart = (Svg.Percent 0, Svg.Percent 0) + , Svg._linearGradientStop = (Svg.Percent 0, Svg.Percent 1) + , Svg._linearGradientStops = + [ Svg.defaultSvg { Svg._gradientOffset = 0, Svg._gradientColor = PixelRGBA8 245 245 245 255 } + , Svg.defaultSvg { Svg._gradientOffset = 1, Svg._gradientColor = PixelRGBA8 216 216 216 255 } + ] + } + +toSymbol :: Double -> Double -> [Svg.Tree] -> Svg.Element +toSymbol width height geom = element where + element = Svg.ElementGeometry $ Svg.SymbolTree tree + tree = Svg.Symbol $ execState build Svg.defaultSvg + + build = do + Svg.groupChildren .= geom + Svg.groupViewBox .= Just (0, 0, width, height) + Svg.groupAspectRatio . Svg.aspectRatioAlign .= Svg.AlignNone + +asFilled :: (Svg.WithDrawAttributes a) => a -> a +asFilled el = el & drawAttr.attrClass .~ ["filled_shape"] + +defaultCircle :: Svg.Element +defaultCircle = toSymbol 50 50 [Svg.CircleTree $ asFilled circle] where + circle = Svg.defaultSvg + { Svg._circleCenter = (Css.Num 25, Css.Num 25) + , Svg._circleRadius = Css.Num 24.5 + } + +h, v :: [Svg.Coord] -> Svg.PathCommand +h = Svg.HorizontalTo Svg.OriginRelative +v = Svg.VerticalTo Svg.OriginRelative + +m :: [Svg.RPoint] -> Svg.PathCommand +m = Svg.MoveTo Svg.OriginRelative + +c :: [(Svg.RPoint, Svg.RPoint, Svg.RPoint)] -> Svg.PathCommand +c = Svg.CurveTo Svg.OriginRelative + +l :: [Svg.RPoint] -> Svg.PathCommand +l = Svg.LineTo Svg.OriginRelative + +z :: Svg.PathCommand +z = Svg.EndPath + +defaultDocument :: Svg.Element +defaultDocument = toSymbol 51 51 [Svg.PathTree $ asFilled path] where + path = Svg.defaultSvg + { Svg._pathDefinition = + [ m [V2 49.98 0.79, V2 (-49.166) 0, V2 0 45.402] + , c [(V2 15.92 12.45, V2 30.40 (-13.44), V2 49.17 0)] + , z + ] + } + +ioShape :: Svg.Element +ioShape = toSymbol 100 100 [Svg.PathTree $ asFilled path] where + path = Svg.defaultSvg + { Svg._pathDefinition = + [ m [V2 19.207 1.6] + , h [79.414] + , l [V2 (-17.192) 97.297] + , h [-79.414] + , z + ] + } + +storageShape :: Svg.Element +storageShape = toSymbol 80 80 geometry where + geometry = Svg.PathTree . asFilled <$> [path1, path2] + path1 = Svg.defaultSvg + { Svg._pathDefinition = + [ m [V2 4.8122 67.74] + , v [-53.769] + , c [ (V2 0.0 (-3.2991) , V2 16.067 (-5.9743), V2 35.845 (-5.9743)) + , (V2 19.78 0.0, V2 35.848 2.6752, V2 35.848 5.9743) + ] + , v [53.769] + , c [(V2 0.0 3.2925, V2 (-16.068) 5.9743, V2 (-35.848) 5.9743) + , (V2 (-19.779) 0.0, V2 (-35.845) (-2.6818), V2 (-35.845) (-5.9743)) + ] + , z + ] + } + path2 = Svg.defaultSvg + { Svg._pathDefinition = + [ m [ V2 4.8122 13.97, V2 4.779e-2 0.30672, V2 0.13807 0.30272 + , V2 0.22834 0.29872, V2 0.31464 0.29344, V2 0.40094 0.28944 + , V2 0.48325 0.2828, V2 0.56423 0.27744, V2 0.64256 0.2708 + , V2 0.71823 0.26416, V2 0.79258 0.25752, V2 0.86294 0.25096 + , V2 0.9333 0.2416, V2 0.99968 0.23496, V2 1.0647 0.22568 + , V2 1.1271 0.2164, V2 1.1869 0.2084, V2 1.2453 0.19784 + , V2 1.301 0.1872, V2 1.3555 0.17792, V2 1.4046 0.16728 + , V2 1.455 0.15536, V2 1.5002 0.14336, V2 1.5466 0.1328 + , V2 1.5865 0.11952, V2 1.6276 0.10752, V2 1.6648 9.42e-2 + , V2 1.7007 8.1e-2, V2 1.7338 6.64e-2, V2 1.7644 5.31e-2 + , V2 1.7923 3.72e-2, V2 1.8188 2.39e-2, V2 1.8427 8.0e-3 + ] + , c [(V2 19.78 0.0, V2 35.848 (-2.6818), V2 35.848 (-5.9743))] + ] + } + +defaultDefinitions :: M.Map String Svg.Element +defaultDefinitions = M.fromList + [ ("shape_light", lightShapeGradient) + , ("circle", defaultCircle) + , ("document", defaultDocument) + , ("io", ioShape) + , ("storage", storageShape) + ] +
src/Text/AsciiDiagram/DiagramCleaner.hs view
@@ -1,131 +1,131 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE CPP #-}-module Text.AsciiDiagram.DiagramCleaner- ( isShapePossible- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( Applicative, (<*>), (<$>) )-#endif--import Control.Applicative( liftA2 )-import Data.List( tails )-import Text.AsciiDiagram.Geometry-import Linear( V2( V2 )- , (^-^)- )--compareDirections :: Applicative f- => (Int -> Int -> Bool) -> f Int -> f Int -> f Bool-compareDirections f = liftA2 diffSign- where- diffSign 0 0 = True- diffSign aa bb = f aa bb--checkRoundedCorners :: (Int -> Int -> Bool)- -> Segment -> Point -> Point -> Segment- -> Bool-checkRoundedCorners f s1 ap1 ap2 s2 = okX && okY- where- V2 dirX dirY = ap2 ^-^ ap1- fromS1 = _segEnd s1 ^-^ ap1- fromS2 = _segStart s2 ^-^ ap2 -- signDirs = signum <$> V2 dirY dirX-- V2 okX okY = (&&)- <$> (compareDirections f signDirs (signum <$> fromS1))- <*> (compareDirections f signDirs (signum <$> fromS2))--checkClosedShape :: Shape -> Bool-checkClosedShape shape = all checkClosed elements where- elements =- (++ shapeElements shape) <$> tails (shapeElements shape) ----checkClosed :: [ShapeElement] -> Bool--- dir fromS1 fromS1--- ---> -----> <---- ^ 2 \--- 3--- /\ | 1 /---- 0 0 ----/ 1 | | \--- 1/ \2 dir | / / | dir dir | /--- | | | \ \ | | 1 /--- 0--- 0| |3 v 2 \---- 3 3 ----\ 2 v--- -----> <------- fromS2 fromS2--- --- OK OK BAD BAD-checkClosed- ( ShapeSegment s1- : ShapeAnchor ap1 AnchorFirstDiag -- '/'- : ShapeAnchor ap2 AnchorSecondDiag -- '\'- : ShapeSegment s2- : _) = checkRoundedCorners (==) s1 ap1 ap2 s2---- dir fromS1 fromS1--- ---> -----> <---- ^ 1 \--- 0--- /\ | 2 /---- 3 3 ----/ 2 | | \--- 2/ \1 dir | / / | dir dir | /--- | | | \ \ | | 2 /--- 3--- 3| |0 v 1 \---- 0 0 ----\ 1 v--- -----> <------- fromS2 fromS2--- --- OK OK BAD BAD-checkClosed- ( ShapeSegment s1- : ShapeAnchor ap1 AnchorSecondDiag -- '\'- : ShapeAnchor ap2 AnchorFirstDiag -- '/'- : ShapeSegment s2- : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2--checkClosed- ( ShapeAnchor _ AnchorFirstDiag- : ShapeAnchor _ AnchorSecondDiag- : ShapeAnchor _ AnchorFirstDiag- : ShapeAnchor _ AnchorSecondDiag- : _) = False--checkClosed- ( ShapeAnchor _ AnchorSecondDiag- : ShapeAnchor _ AnchorFirstDiag- : ShapeAnchor _ AnchorSecondDiag- : ShapeAnchor _ AnchorFirstDiag- : _) = False--checkClosed _ = True--isBullet :: ShapeElement -> Bool-isBullet (ShapeAnchor _ AnchorBullet) = True-isBullet _ = False--checkOpened :: [ShapeElement] -> Bool-checkOpened- [ ShapeAnchor _ AnchorFirstDiag- , ShapeAnchor _ AnchorSecondDiag] = False-checkOpened [ ShapeAnchor _ AnchorSecondDiag- , ShapeAnchor _ AnchorFirstDiag] = False-checkOpened (all isBullet -> True) = False-checkOpened- ( ShapeAnchor ap1 AnchorFirstDiag -- '/'- : ShapeAnchor ap2 AnchorSecondDiag -- '\'- : ShapeSegment s2- : _) = checkRoundedCorners (==) s1 ap1 ap2 s2- where s1 = mempty { _segEnd = ap1 }-checkOpened- ( ShapeAnchor ap1 AnchorSecondDiag -- '\'- : ShapeAnchor ap2 AnchorFirstDiag -- '/'- : ShapeSegment s2- : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2- where s1 = mempty { _segEnd = ap1 }-checkOpened _ = True--checkOpenedShape :: Shape -> Bool-checkOpenedShape = checkOpened . shapeElements--isShapePossible :: Shape -> Bool-isShapePossible shape- | shapeIsClosed shape = checkClosedShape shape- | otherwise = checkOpenedShape shape-+{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +module Text.AsciiDiagram.DiagramCleaner + ( isShapePossible + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( Applicative, (<*>), (<$>) ) +#endif + +import Control.Applicative( liftA2 ) +import Data.List( tails ) +import Text.AsciiDiagram.Geometry +import Linear( V2( V2 ) + , (^-^) + ) + +compareDirections :: Applicative f + => (Int -> Int -> Bool) -> f Int -> f Int -> f Bool +compareDirections f = liftA2 diffSign + where + diffSign 0 0 = True + diffSign aa bb = f aa bb + +checkRoundedCorners :: (Int -> Int -> Bool) + -> Segment -> Point -> Point -> Segment + -> Bool +checkRoundedCorners f s1 ap1 ap2 s2 = okX && okY + where + V2 dirX dirY = ap2 ^-^ ap1 + fromS1 = _segEnd s1 ^-^ ap1 + fromS2 = _segStart s2 ^-^ ap2 + + signDirs = signum <$> V2 dirY dirX + + V2 okX okY = (&&) + <$> (compareDirections f signDirs (signum <$> fromS1)) + <*> (compareDirections f signDirs (signum <$> fromS2)) + +checkClosedShape :: Shape -> Bool +checkClosedShape shape = all checkClosed elements where + elements = + (++ shapeElements shape) <$> tails (shapeElements shape) + + + +checkClosed :: [ShapeElement] -> Bool +-- dir fromS1 fromS1 +-- ---> -----> <---- ^ 2 \--- 3 +-- /\ | 1 /---- 0 0 ----/ 1 | | \ +-- 1/ \2 dir | / / | dir dir | / +-- | | | \ \ | | 1 /--- 0 +-- 0| |3 v 2 \---- 3 3 ----\ 2 v +-- -----> <---- +-- fromS2 fromS2 +-- +-- OK OK BAD BAD +checkClosed + ( ShapeSegment s1 + : ShapeAnchor ap1 AnchorFirstDiag -- '/' + : ShapeAnchor ap2 AnchorSecondDiag -- '\' + : ShapeSegment s2 + : _) = checkRoundedCorners (==) s1 ap1 ap2 s2 + +-- dir fromS1 fromS1 +-- ---> -----> <---- ^ 1 \--- 0 +-- /\ | 2 /---- 3 3 ----/ 2 | | \ +-- 2/ \1 dir | / / | dir dir | / +-- | | | \ \ | | 2 /--- 3 +-- 3| |0 v 1 \---- 0 0 ----\ 1 v +-- -----> <---- +-- fromS2 fromS2 +-- +-- OK OK BAD BAD +checkClosed + ( ShapeSegment s1 + : ShapeAnchor ap1 AnchorSecondDiag -- '\' + : ShapeAnchor ap2 AnchorFirstDiag -- '/' + : ShapeSegment s2 + : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2 + +checkClosed + ( ShapeAnchor _ AnchorFirstDiag + : ShapeAnchor _ AnchorSecondDiag + : ShapeAnchor _ AnchorFirstDiag + : ShapeAnchor _ AnchorSecondDiag + : _) = False + +checkClosed + ( ShapeAnchor _ AnchorSecondDiag + : ShapeAnchor _ AnchorFirstDiag + : ShapeAnchor _ AnchorSecondDiag + : ShapeAnchor _ AnchorFirstDiag + : _) = False + +checkClosed _ = True + +isBullet :: ShapeElement -> Bool +isBullet (ShapeAnchor _ AnchorBullet) = True +isBullet _ = False + +checkOpened :: [ShapeElement] -> Bool +checkOpened + [ ShapeAnchor _ AnchorFirstDiag + , ShapeAnchor _ AnchorSecondDiag] = False +checkOpened [ ShapeAnchor _ AnchorSecondDiag + , ShapeAnchor _ AnchorFirstDiag] = False +checkOpened (all isBullet -> True) = False +checkOpened + ( ShapeAnchor ap1 AnchorFirstDiag -- '/' + : ShapeAnchor ap2 AnchorSecondDiag -- '\' + : ShapeSegment s2 + : _) = checkRoundedCorners (==) s1 ap1 ap2 s2 + where s1 = mempty { _segEnd = ap1 } +checkOpened + ( ShapeAnchor ap1 AnchorSecondDiag -- '\' + : ShapeAnchor ap2 AnchorFirstDiag -- '/' + : ShapeSegment s2 + : _) = checkRoundedCorners (/=) s1 ap1 ap2 s2 + where s1 = mempty { _segEnd = ap1 } +checkOpened _ = True + +checkOpenedShape :: Shape -> Bool +checkOpenedShape = checkOpened . shapeElements + +isShapePossible :: Shape -> Bool +isShapePossible shape + | shapeIsClosed shape = checkClosedShape shape + | otherwise = checkOpenedShape shape +
src/Text/AsciiDiagram/Geometry.hs view
@@ -1,132 +1,132 @@-{-# LANGUAGE CPP #-}--- | Defines the geometry extracted from the asciidiagram.-module Text.AsciiDiagram.Geometry( Point- , Vector- , Anchor( .. )- , Shape( .. )- , Element( .. )- , Segment( .. )- , SegmentDraw( .. )- , SegmentKind( .. )- , ShapeElement( .. )- , Diagram( .. )- , TextZone( .. )- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( Monoid( mappend, mempty ))-#endif--import qualified Data.Set as S-import qualified Data.Text as T-import Linear( V2( .. ) )---- | Position of a an element in the character grids-type Point = V2 Int---- | Direction in the character grid.-type Vector = V2 Int---- | Describe the geomtry of a full Ascii Diagram--- document-data Diagram = Diagram- { -- | All the extracted tshapes- _diagramElements :: S.Set Element- -- | Width in characters of the document- , _diagramCellWidth :: !Int- -- | Height in characters of the document- , _diagramCellHeight :: !Int- -- | CSS styles associated to the document.- , _diagramStyles :: [T.Text]- }- deriving (Eq, Show)---- | Describe where to place a text snippet.-data TextZone = TextZone- { _textZoneOrigin :: Point- , _textZoneContent :: T.Text- }- deriving (Eq, Ord, Show)---- | Define the different connection points--- between the segments.-data Anchor- = AnchorMulti -- ^ Associated to '+'- | AnchorFirstDiag -- ^ Associated to '/'- | AnchorSecondDiag -- ^ Associated to '\'-- | AnchorPoint -- ^ Kind of "end anchor", without continuation.- | AnchorBullet -- ^ Used as a '*'-- | AnchorArrowUp -- ^ Associated to '^'- | AnchorArrowDown -- ^ Associated to 'V'- | AnchorArrowLeft -- ^ Associated to '<'- | AnchorArrowRight -- ^ Associated to '>'- deriving (Eq, Ord, Show)---- | Helper data for segment composed of only--- one character-data SegmentKind- = SegmentHorizontal- | SegmentVertical- deriving (Eq, Ord, Show)---- | Differentiate between elements drawn with a--- solid line or with dashed lines.-data SegmentDraw- = SegmentSolid- | SegmentDashed- deriving (Eq, Ord, Show)---- | Define an horizontal or vertical segment.-data Segment = Segment- { _segStart :: {-# UNPACK #-} !Point- , _segEnd :: {-# UNPACK #-} !Point- , _segKind :: !SegmentKind- , _segDraw :: !SegmentDraw- }- deriving (Eq, Ord)--instance Show Segment where- showsPrec d (Segment s e k dr) =- showParen (d >= 10) $- showString "Segment " . start . end . kind . (' ':) . draw- where- start = showParen True $ shows s- end = showParen True $ shows e- kind = shows k- draw = shows dr--instance Monoid Segment where- mempty = Segment 0 0 SegmentVertical SegmentSolid- mappend (Segment a _ _ _) (Segment _ b k d) =- Segment a b k d---- | Describe a composant of shapes. Can--- be composed of anchors like "+*/\\" or--- segments.-data ShapeElement- = ShapeAnchor !Point !Anchor- | ShapeSegment !Segment- deriving (Eq, Ord, Show)---- | Shape extracted from the text-data Shape = Shape- { -- | Elements composing the shape.- shapeElements :: ![ShapeElement]- -- | When False it's just lines possibly with- -- an arrow, when True it's a polygon.- , shapeIsClosed :: !Bool- -- | Tags "{tagname}" placed inside the shape.- , shapeTags :: !(S.Set T.Text)- -- | List of eleents contained in this shape- , shapeChildren :: ![Element]- }- deriving (Eq, Ord, Show)---- | Define an element to be drawn.-data Element- = ElemText !TextZone- | ElemShape !Shape- deriving (Eq, Show, Ord)-+{-# LANGUAGE CPP #-} +-- | Defines the geometry extracted from the asciidiagram. +module Text.AsciiDiagram.Geometry( Point + , Vector + , Anchor( .. ) + , Shape( .. ) + , Element( .. ) + , Segment( .. ) + , SegmentDraw( .. ) + , SegmentKind( .. ) + , ShapeElement( .. ) + , Diagram( .. ) + , TextZone( .. ) + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( mappend, mempty )) +#endif + +import qualified Data.Set as S +import qualified Data.Text as T +import Linear( V2( .. ) ) + +-- | Position of a an element in the character grids +type Point = V2 Int + +-- | Direction in the character grid. +type Vector = V2 Int + +-- | Describe the geomtry of a full Ascii Diagram +-- document +data Diagram = Diagram + { -- | All the extracted tshapes + _diagramElements :: S.Set Element + -- | Width in characters of the document + , _diagramCellWidth :: !Int + -- | Height in characters of the document + , _diagramCellHeight :: !Int + -- | CSS styles associated to the document. + , _diagramStyles :: [T.Text] + } + deriving (Eq, Show) + +-- | Describe where to place a text snippet. +data TextZone = TextZone + { _textZoneOrigin :: Point + , _textZoneContent :: T.Text + } + deriving (Eq, Ord, Show) + +-- | Define the different connection points +-- between the segments. +data Anchor + = AnchorMulti -- ^ Associated to '+' + | AnchorFirstDiag -- ^ Associated to '/' + | AnchorSecondDiag -- ^ Associated to '\' + + | AnchorPoint -- ^ Kind of "end anchor", without continuation. + | AnchorBullet -- ^ Used as a '*' + + | AnchorArrowUp -- ^ Associated to '^' + | AnchorArrowDown -- ^ Associated to 'V' + | AnchorArrowLeft -- ^ Associated to '<' + | AnchorArrowRight -- ^ Associated to '>' + deriving (Eq, Ord, Show) + +-- | Helper data for segment composed of only +-- one character +data SegmentKind + = SegmentHorizontal + | SegmentVertical + deriving (Eq, Ord, Show) + +-- | Differentiate between elements drawn with a +-- solid line or with dashed lines. +data SegmentDraw + = SegmentSolid + | SegmentDashed + deriving (Eq, Ord, Show) + +-- | Define an horizontal or vertical segment. +data Segment = Segment + { _segStart :: {-# UNPACK #-} !Point + , _segEnd :: {-# UNPACK #-} !Point + , _segKind :: !SegmentKind + , _segDraw :: !SegmentDraw + } + deriving (Eq, Ord) + +instance Show Segment where + showsPrec d (Segment s e k dr) = + showParen (d >= 10) $ + showString "Segment " . start . end . kind . (' ':) . draw + where + start = showParen True $ shows s + end = showParen True $ shows e + kind = shows k + draw = shows dr + +instance Monoid Segment where + mempty = Segment 0 0 SegmentVertical SegmentSolid + mappend (Segment a _ _ _) (Segment _ b k d) = + Segment a b k d + +-- | Describe a composant of shapes. Can +-- be composed of anchors like "+*/\\" or +-- segments. +data ShapeElement + = ShapeAnchor !Point !Anchor + | ShapeSegment !Segment + deriving (Eq, Ord, Show) + +-- | Shape extracted from the text +data Shape = Shape + { -- | Elements composing the shape. + shapeElements :: ![ShapeElement] + -- | When False it's just lines possibly with + -- an arrow, when True it's a polygon. + , shapeIsClosed :: !Bool + -- | Tags "{tagname}" placed inside the shape. + , shapeTags :: !(S.Set T.Text) + -- | List of eleents contained in this shape + , shapeChildren :: ![Element] + } + deriving (Eq, Ord, Show) + +-- | Define an element to be drawn. +data Element + = ElemText !TextZone + | ElemShape !Shape + deriving (Eq, Show, Ord) +
src/Text/AsciiDiagram/Graph.hs view
@@ -1,333 +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 )-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-+{-# 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 )-import Control.Applicative( (<$>) )-#endif--import Control.Monad( foldM, when )-import Control.Monad.State.Strict( State- , execState- , modify )-import qualified Data.Foldable as F-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Text as T-import qualified Data.Traversable as TT-import qualified Data.Vector.Unboxed as VU-import Linear( V2( .. ) )--import Text.AsciiDiagram.Geometry--isAnchor :: Char -> Bool-isAnchor c = c `VU.elem` anchors- where- anchors = VU.fromList "<>^vV+/\\*"- -anchorOfChar :: Char -> Anchor-anchorOfChar '+' = AnchorMulti-anchorOfChar '/' = AnchorFirstDiag-anchorOfChar '\\' = AnchorSecondDiag-anchorOfChar '>' = AnchorArrowRight-anchorOfChar '<' = AnchorArrowLeft-anchorOfChar '^' = AnchorArrowUp-anchorOfChar 'V' = AnchorArrowDown-anchorOfChar 'v' = AnchorArrowDown-anchorOfChar '*' = AnchorBullet-anchorOfChar _ = AnchorMulti--isHorizontalLine :: Char -> Bool-isHorizontalLine c = c `VU.elem` horizontalLineElements- where- horizontalLineElements = VU.fromList "-="--isVerticalLine :: Char -> Bool-isVerticalLine c = c `VU.elem` verticalLineElements- where- verticalLineElements = VU.fromList ":|"--isDashed :: Char -> Bool-isDashed c = case c of- ':' -> True- '=' -> True- _ -> False---data ParsingState = ParsingState- { anchorMap :: !(M.Map Point Anchor)- , segmentSet :: !(S.Set Segment)- , currentSegment :: !(Maybe Segment)- , styleLine :: [(Int, T.Text)]- }- deriving Show--emptyParsingState :: ParsingState-emptyParsingState = ParsingState- { anchorMap = mempty- , segmentSet = mempty- , currentSegment = Nothing- , styleLine = mempty- }--type Parsing = State ParsingState--type LineNumber = Int--addAnchor :: Point -> Char -> Parsing ()-addAnchor p c = modify $ \s ->- s { anchorMap = M.insert p (anchorOfChar c) $ anchorMap s }--addSegment :: Segment -> Parsing ()-addSegment seg = modify $ \s ->- s { segmentSet = S.insert seg $ segmentSet s }--addStyleLine :: (Int, T.Text) -> Parsing ()-addStyleLine l = modify $ \s ->- s { styleLine = l : styleLine s }--continueHorizontalSegment :: Point -> Parsing ()-continueHorizontalSegment p = modify $ \s ->- s { currentSegment = Just . update $ currentSegment s }- where update Nothing = mempty { _segStart = p- , _segEnd = p- , _segKind = SegmentHorizontal- }- update (Just seg) = seg { _segEnd = p- , _segKind = SegmentHorizontal- }--setHorizontaDashing :: Parsing ()-setHorizontaDashing = modify $ \s ->- s { currentSegment = setDashed <$> currentSegment s }- where- setDashed seg = seg { _segDraw = SegmentDashed }--stopHorizontalSegment :: Parsing ()-stopHorizontalSegment = modify $ \s ->- s { segmentSet = inserter (currentSegment s) $ segmentSet s- , currentSegment = Nothing- }- where- inserter Nothing s = s- inserter (Just seg) s = S.insert seg s--continueVerticalSegment :: Maybe Segment -> Point -> Parsing (Maybe Segment)-continueVerticalSegment Nothing p = return $ Just seg where- seg = mempty { _segStart = p- , _segEnd = p- , _segKind = SegmentVertical }-continueVerticalSegment (Just seg) p =- return $ Just seg { _segEnd = p, _segKind = SegmentVertical }--stopVerticalSegment :: Maybe Segment -> Parsing (Maybe a)-stopVerticalSegment Nothing = return Nothing-stopVerticalSegment (Just seg) = do- addSegment seg- return Nothing--parseLine :: [Maybe Segment] -> (LineNumber, T.Text)- -> Parsing [Maybe Segment]-parseLine prevSegments (n, T.stripPrefix ":::" -> Just txt) = do- addStyleLine (n, txt)- return prevSegments-parseLine prevSegments (lineNumber, txt) = do- ret <- TT.mapM go $ zip3 [0 ..] prevSegments stringLine- stopHorizontalSegment- return ret- where- stringLine = T.unpack txt ++ repeat ' '-- go (columnNumber, vertical, c) | isHorizontalLine c = do- let point = V2 columnNumber lineNumber- continueHorizontalSegment point- when (isDashed c) $ setHorizontaDashing- stopVerticalSegment vertical-- go (columnNumber, vertical, c) | isVerticalLine c = do- let point = V2 columnNumber lineNumber- dashingSet seg- | isDashed c = seg { _segDraw = SegmentDashed }- | otherwise = seg- stopHorizontalSegment- fmap dashingSet <$> continueVerticalSegment vertical point-- go (columnNumber, vertical, c) | isAnchor c = do- let point = V2 columnNumber lineNumber- addAnchor point c- stopHorizontalSegment- stopVerticalSegment vertical-- go (_, vertical, _) = do- stopHorizontalSegment- stopVerticalSegment vertical--maximumLineLength :: [T.Text] -> Int-maximumLineLength [] = 0-maximumLineLength lst = maximum $ T.length <$> lst--parseTextLines :: [T.Text] -> ParsingState-parseTextLines lst = flip execState emptyParsingState $ do- let initialLine = replicate (maximumLineLength lst) Nothing- lastVerticalLine <- foldM parseLine initialLine $ zip [0 ..] lst- mapM_ stopVerticalSegment lastVerticalLine - ---- | Extract the segment information of a given text.-parseText :: T.Text -> ParsingState-parseText = parseTextLines . T.lines--zoneFromLine :: (Int, T.Text) -> [TextZone]-zoneFromLine (lineIndex, line) = eatSpaces 0 $ T.split (== ' ') line where- eatSpaces ix lst = case lst of- [] -> []- ("":rest) -> eatSpaces (ix + 1) rest- _ -> createZoneFrom ix lst-- createZoneFrom ix = go ix where- go endIdx [] | ix == endIdx = []- go _ [] = [TextZone (V2 ix lineIndex) $ T.drop ix line]- go endIdx ("":rest) = zone : eatSpaces (endIdx + 1) rest- where origin = V2 ix lineIndex- zone = TextZone origin . T.drop ix $ T.take endIdx line- go endIdx (x:xs) = go (endIdx + T.length x + 1) xs--extractTextZones :: [T.Text] -> [TextZone]-extractTextZones = F.concatMap zoneFromLine . zip [0 ..]--detectTagFromTextZone :: [TextZone] -> ([TextZone], [TextZone])-detectTagFromTextZone zones = (concat foundTags, concat normalZones) where- (foundTags, normalZones) = unzip $ fmap findTag zones-- findTag zone@(TextZone (V2 x y) txt) =- case splitTags y x $ T.split (== ' ') txt of- ([], _) -> ([], [zone])- tagsAndText -> tagsAndText-- splitTags _ _ [] = ([], [])- splitTags y ix (thisTxt : rest)- | tlength >= 3 && T.head thisTxt == '{' && T.last thisTxt == '}' = - (TextZone (V2 ix y) tagText: afterTags, normalTexts)- | otherwise = (afterTags, TextZone (V2 ix y) thisTxt : normalTexts)- where tlength = T.length thisTxt- tagText = T.init $ T.drop 1 thisTxt- (afterTags, normalTexts) = splitTags y (ix + tlength + 1) rest-+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +-- | Module in charge of finding the various segment +-- in an ASCII text and the various anchors. +module Text.AsciiDiagram.Parser( ParsingState( .. ) + , parseText + , parseTextLines + , extractTextZones + , detectTagFromTextZone + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>) ) +#endif + +import Control.Monad( foldM, when ) +import Control.Monad.State.Strict( State + , execState + , modify ) +import qualified Data.Foldable as F +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Traversable as TT +import qualified Data.Vector.Unboxed as VU +import Linear( V2( .. ) ) + +import Text.AsciiDiagram.Geometry + +isAnchor :: Char -> Bool +isAnchor c = c `VU.elem` anchors + where + anchors = VU.fromList "<>^vV+/\\*" + +anchorOfChar :: Char -> Anchor +anchorOfChar '+' = AnchorMulti +anchorOfChar '/' = AnchorFirstDiag +anchorOfChar '\\' = AnchorSecondDiag +anchorOfChar '>' = AnchorArrowRight +anchorOfChar '<' = AnchorArrowLeft +anchorOfChar '^' = AnchorArrowUp +anchorOfChar 'V' = AnchorArrowDown +anchorOfChar 'v' = AnchorArrowDown +anchorOfChar '*' = AnchorBullet +anchorOfChar _ = AnchorMulti + +isHorizontalLine :: Char -> Bool +isHorizontalLine c = c `VU.elem` horizontalLineElements + where + horizontalLineElements = VU.fromList "-=" + +isVerticalLine :: Char -> Bool +isVerticalLine c = c `VU.elem` verticalLineElements + where + verticalLineElements = VU.fromList ":|" + +isDashed :: Char -> Bool +isDashed c = case c of + ':' -> True + '=' -> True + _ -> False + + +data ParsingState = ParsingState + { anchorMap :: !(M.Map Point Anchor) + , segmentSet :: !(S.Set Segment) + , currentSegment :: !(Maybe Segment) + , styleLine :: [(Int, T.Text)] + } + deriving Show + +emptyParsingState :: ParsingState +emptyParsingState = ParsingState + { anchorMap = mempty + , segmentSet = mempty + , currentSegment = Nothing + , styleLine = mempty + } + +type Parsing = State ParsingState + +type LineNumber = Int + +addAnchor :: Point -> Char -> Parsing () +addAnchor p c = modify $ \s -> + s { anchorMap = M.insert p (anchorOfChar c) $ anchorMap s } + +addSegment :: Segment -> Parsing () +addSegment seg = modify $ \s -> + s { segmentSet = S.insert seg $ segmentSet s } + +addStyleLine :: (Int, T.Text) -> Parsing () +addStyleLine l = modify $ \s -> + s { styleLine = l : styleLine s } + +continueHorizontalSegment :: Point -> Parsing () +continueHorizontalSegment p = modify $ \s -> + s { currentSegment = Just . update $ currentSegment s } + where update Nothing = mempty { _segStart = p + , _segEnd = p + , _segKind = SegmentHorizontal + } + update (Just seg) = seg { _segEnd = p + , _segKind = SegmentHorizontal + } + +setHorizontaDashing :: Parsing () +setHorizontaDashing = modify $ \s -> + s { currentSegment = setDashed <$> currentSegment s } + where + setDashed seg = seg { _segDraw = SegmentDashed } + +stopHorizontalSegment :: Parsing () +stopHorizontalSegment = modify $ \s -> + s { segmentSet = inserter (currentSegment s) $ segmentSet s + , currentSegment = Nothing + } + where + inserter Nothing s = s + inserter (Just seg) s = S.insert seg s + +continueVerticalSegment :: Maybe Segment -> Point -> Parsing (Maybe Segment) +continueVerticalSegment Nothing p = return $ Just seg where + seg = mempty { _segStart = p + , _segEnd = p + , _segKind = SegmentVertical } +continueVerticalSegment (Just seg) p = + return $ Just seg { _segEnd = p, _segKind = SegmentVertical } + +stopVerticalSegment :: Maybe Segment -> Parsing (Maybe a) +stopVerticalSegment Nothing = return Nothing +stopVerticalSegment (Just seg) = do + addSegment seg + return Nothing + +parseLine :: [Maybe Segment] -> (LineNumber, T.Text) + -> Parsing [Maybe Segment] +parseLine prevSegments (n, T.stripPrefix ":::" -> Just txt) = do + addStyleLine (n, txt) + return prevSegments +parseLine prevSegments (lineNumber, txt) = do + ret <- TT.mapM go $ zip3 [0 ..] prevSegments stringLine + stopHorizontalSegment + return ret + where + stringLine = T.unpack txt ++ repeat ' ' + + go (columnNumber, vertical, c) | isHorizontalLine c = do + let point = V2 columnNumber lineNumber + continueHorizontalSegment point + when (isDashed c) $ setHorizontaDashing + stopVerticalSegment vertical + + go (columnNumber, vertical, c) | isVerticalLine c = do + let point = V2 columnNumber lineNumber + dashingSet seg + | isDashed c = seg { _segDraw = SegmentDashed } + | otherwise = seg + stopHorizontalSegment + fmap dashingSet <$> continueVerticalSegment vertical point + + go (columnNumber, vertical, c) | isAnchor c = do + let point = V2 columnNumber lineNumber + addAnchor point c + stopHorizontalSegment + stopVerticalSegment vertical + + go (_, vertical, _) = do + stopHorizontalSegment + stopVerticalSegment vertical + +maximumLineLength :: [T.Text] -> Int +maximumLineLength [] = 0 +maximumLineLength lst = maximum $ T.length <$> lst + +parseTextLines :: [T.Text] -> ParsingState +parseTextLines lst = flip execState emptyParsingState $ do + let initialLine = replicate (maximumLineLength lst) Nothing + lastVerticalLine <- foldM parseLine initialLine $ zip [0 ..] lst + mapM_ stopVerticalSegment lastVerticalLine + + +-- | Extract the segment information of a given text. +parseText :: T.Text -> ParsingState +parseText = parseTextLines . T.lines + +zoneFromLine :: (Int, T.Text) -> [TextZone] +zoneFromLine (lineIndex, line) = eatSpaces 0 $ T.split (== ' ') line where + eatSpaces ix lst = case lst of + [] -> [] + ("":rest) -> eatSpaces (ix + 1) rest + _ -> createZoneFrom ix lst + + createZoneFrom ix = go ix where + go endIdx [] | ix == endIdx = [] + go _ [] = [TextZone (V2 ix lineIndex) $ T.drop ix line] + go endIdx ("":rest) = zone : eatSpaces (endIdx + 1) rest + where origin = V2 ix lineIndex + zone = TextZone origin . T.drop ix $ T.take endIdx line + go endIdx (x:xs) = go (endIdx + T.length x + 1) xs + +extractTextZones :: [T.Text] -> [TextZone] +extractTextZones = F.concatMap zoneFromLine . zip [0 ..] + +detectTagFromTextZone :: [TextZone] -> ([TextZone], [TextZone]) +detectTagFromTextZone zones = (concat foundTags, concat normalZones) where + (foundTags, normalZones) = unzip $ fmap findTag zones + + findTag zone@(TextZone (V2 x y) txt) = + case splitTags y x $ T.split (== ' ') txt of + ([], _) -> ([], [zone]) + tagsAndText -> tagsAndText + + splitTags _ _ [] = ([], []) + splitTags y ix (thisTxt : rest) + | tlength >= 3 && T.head thisTxt == '{' && T.last thisTxt == '}' = + (TextZone (V2 ix y) tagText: afterTags, normalTexts) + | otherwise = (afterTags, TextZone (V2 ix y) thisTxt : normalTexts) + where tlength = T.length thisTxt + tagText = T.init $ T.drop 1 thisTxt + (afterTags, normalTexts) = splitTags y (ix + tlength + 1) rest +
src/Text/AsciiDiagram/Reconstructor.hs view
@@ -1,266 +1,266 @@-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | This module will try to reconstruct closed shapes and--- lines from -- the set of anchors and segments.------ The output of this module may be duplicated, needing--- deduplication as post processing.------ This is mostly a depth first search in the set of anchors--- and segments.-module Text.AsciiDiagram.Reconstructor( reconstruct ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( (<$>) )-#endif--import Control.Monad( when )-import Control.Monad.State.Strict( execState )-import Control.Monad.State.Class( get )-import Data.Function( on )-import Data.List( sortBy )-import Data.Maybe( catMaybes )-import qualified Data.Foldable as F-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Vector as V-import Linear( V2( .. ), (^+^), (^-^) )--import Text.AsciiDiagram.Geometry-import Text.AsciiDiagram.Graph-import Control.Lens--{-import Debug.Trace-}-{-import Text.Printf-}-{-import Text.Groom-}--data Direction- = LeftToRight- | RightToLeft- | TopToBottom- | BottomToTop- | NoDirection- deriving (Eq, Show)----directionOfVector :: Vector -> Direction-directionOfVector (V2 0 n)- | n > 0 = TopToBottom- | otherwise = BottomToTop-directionOfVector (V2 n 0)- | n > 0 = LeftToRight- | otherwise = RightToLeft-directionOfVector _ = NoDirection--------- ****|****--- *** | ***--- ** 1 **--- * | *--- -----0----+---2--------- * ^ *--- ** : **--- *** : ***--- ****:****--------- ****|****--- *** | ***--- ** 0 **--- * | *--- =========>+---1--------- * | *--- ** 2 **--- *** | ***--- ****|****--------- ****|****--- *** | ***--- ** 2 **--- * | *--- -----1----+<=========--- * | *--- ** 0 **--- *** | ***--- ****|****--------- ****:****--- *** : ***--- ** : **--- * V *--- -----2----+---0--------- * | *--- ** 1 **--- *** | ***--- ****|****----vectorsForAnchor :: Anchor -> Direction -> [Vector]-vectorsForAnchor anchor dir = case (anchor, dir) of- (AnchorArrowUp, _) -> [down]- (AnchorArrowDown, _) -> [up]- (AnchorArrowLeft, _) -> [right]- (AnchorArrowRight, _) -> [left]-- (_, LeftToRight) -> [up, right, down, left]- (_, TopToBottom) -> [right, down, left, up]- (_, NoDirection) -> [right, down, left, up]- (_, RightToLeft) -> [down, left, up, right]- (_, BottomToTop) -> [left, up, right, down]-- where- left = V2 (-1) 0- up = V2 0 (-1)- right = V2 1 0- down = V2 0 1--directionVectorOf :: Point -> Point -> Vector-directionVectorOf a b = signum <$> a ^-^ b--nextDirectionAfterAnchor :: Anchor -> Point -> Point -> [Point]-nextDirectionAfterAnchor anchor previousPoint anchorPosition =- [delta | delta <- deltas- , let nextPoint = anchorPosition ^+^ delta- , nextPoint /= previousPoint]- where- directionVector = directionVectorOf anchorPosition previousPoint- direction = directionOfVector directionVector- deltas = vectorsForAnchor anchor direction--nextPointAfterAnchor :: Anchor -> Point -> Point -> [Point]-nextPointAfterAnchor anchor prev p =- (^+^ p) <$> nextDirectionAfterAnchor anchor prev p--segmentManathanLength :: Segment -> Int-segmentManathanLength seg = x + y where- V2 x y = abs <$> _segEnd seg ^-^ _segStart seg---segmentDirectionMap :: S.Set Segment -> M.Map Point SegmentKind-segmentDirectionMap = S.fold go mempty where- go seg = M.insert (_segEnd seg) k . M.insert (_segStart seg) k- where- k = _segKind seg--toGraph :: M.Map Point Anchor -> S.Set Segment- -> Graph Point ShapeElement Segment-toGraph anchors segs = execState graphCreator baseGraph where- baseGraph = graphOfVertices $ M.mapWithKey ShapeAnchor anchors-- segDirs = segmentDirectionMap segs-- graphCreator = do- F.traverse_ linkSegments segs- F.traverse_ linkAnchors $ M.assocs anchors-- linkOf p1 p2 | p1 < p2 = (p1, p2)- | otherwise = (p2, p1)-- linkAnchors (p, a) = F.traverse_ createLinks nextPoints where- nextPoints = nextPointAfterAnchor a (V2 (-1) (-1)) p- createLinks nextPoint = do- nextExists <- has (vertices . ix nextPoint) <$> get- let dirNext = nextPoint ^-^ p- nextP = M.lookup nextPoint anchors- nextS = M.lookup nextPoint segDirs- nextIsOk = case (nextP, nextS) of- (Just AnchorArrowUp, _) -> V2 0 (-1) == dirNext- (Just AnchorArrowDown, _) -> V2 0 1 == dirNext- (Just AnchorArrowLeft, _) -> V2 (-1) 0 == dirNext- (Just AnchorArrowRight, _) -> V2 1 0 == dirNext- (Just _, _) -> True- (Nothing, Nothing) -> True- (Nothing, Just SegmentHorizontal) ->- (abs <$> dirNext) == V2 1 0- (Nothing, Just SegmentVertical) ->- (abs <$> dirNext) == V2 0 1-- alreadyLinked <- has (edges . ix (linkOf p nextPoint)) <$> get- when (nextExists && nextIsOk && not alreadyLinked) $- edges . at (linkOf p nextPoint) ?= mempty-- linkSegments seg | segmentManathanLength seg == 0 = do- vertices . at (_segStart seg ) ?= ShapeSegment seg- linkSegments seg@(Segment { _segStart = p1, _segEnd = p2 }) = do- vertices . at p1 ?= ShapeSegment seg- vertices . at p2 ?= ShapeSegment seg- edges . at (linkOf p1 p2) ?= seg--findClockwisePossible :: S.Set Point -> Maybe Point -> Point- -> [Point]-findClockwisePossible adjacents Nothing p =- findClockwisePossible adjacents (Just p) p-findClockwisePossible adjacents (Just prev) p =- fmap snd $ sortBy (compare `on` fst) indexedAdjacents- where- -- don't care about specific direction, restrictions should have- -- been made during the construction of the graph.- dirArray = V.fromList $ nextDirectionAfterAnchor AnchorMulti prev p- zipIndex k = (V.elemIndex dir dirArray, k)- where dir = directionVectorOf k p- indexedAdjacents =- [(idx, nextPoint)- | (Just idx, nextPoint) <- zipIndex <$> S.elems adjacents- , nextPoint /= prev]--safeHead :: [a] -> Maybe a-safeHead [] = Nothing-safeHead (x:_) = Just x--instance PlanarVertice (V2 Int) where- getClockwiseMost adj prev =- safeHead . findClockwisePossible adj prev- getCounterClockwiseMost adj prev =- safeHead . reverse . findClockwisePossible adj prev--dedupEqual :: Eq a => [a] -> [a]-dedupEqual [] = []-dedupEqual (x:rest@(y:_)) | x == y = dedupEqual rest-dedupEqual (x:xs) = x : dedupEqual xs----- | Break filaments at multi anchor to ensure proper dashing--- of the segments.-breakFilaments :: Filament ShapeElement -> [Filament ShapeElement]-breakFilaments = go where- go lst = f : fs- where (f, fs) = breaker lst-- breaker [] = ([], [])- breaker [a@(ShapeAnchor _ AnchorMulti)] = ([a], [])- breaker (a@(ShapeAnchor _ AnchorMulti):xs) = ([a], (a:filamentRest):others)- where (filamentRest, others) = breaker xs- breaker (x:xs) = (x:filamentRest, others)- where (filamentRest, others) = breaker xs----- | Main call of the reconstruction function-reconstruct :: M.Map Point Anchor -> S.Set Segment- -> S.Set Shape-reconstruct anchors segments =- S.fromList $ fmap toShapes cycles - ++ concatMap toFilaments filaments- where- graph = toGraph anchors segments- (cycles, filaments) = extractAllPrimitives graph-- toElems = dedupEqual- . filter (/= ShapeSegment mempty)- . catMaybes- . fmap (`M.lookup` _vertices graph)-- toFilaments shapes =- [Shape piece False mempty mempty | piece <- breakFilaments $ toElems shapes] -- toShapes shapes = Shape (toElems shapes) True mempty mempty-+{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This module will try to reconstruct closed shapes and +-- lines from -- the set of anchors and segments. +-- +-- The output of this module may be duplicated, needing +-- deduplication as post processing. +-- +-- This is mostly a depth first search in the set of anchors +-- and segments. +module Text.AsciiDiagram.Reconstructor( reconstruct ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>) ) +#endif + +import Control.Monad( when ) +import Control.Monad.State.Strict( execState ) +import Control.Monad.State.Class( get ) +import Data.Function( on ) +import Data.List( sortBy ) +import Data.Maybe( catMaybes ) +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Vector as V +import Linear( V2( .. ), (^+^), (^-^) ) + +import Text.AsciiDiagram.Geometry +import Text.AsciiDiagram.Graph +import Control.Lens + +{-import Debug.Trace-} +{-import Text.Printf-} +{-import Text.Groom-} + +data Direction + = LeftToRight + | RightToLeft + | TopToBottom + | BottomToTop + | NoDirection + deriving (Eq, Show) + + + +directionOfVector :: Vector -> Direction +directionOfVector (V2 0 n) + | n > 0 = TopToBottom + | otherwise = BottomToTop +directionOfVector (V2 n 0) + | n > 0 = LeftToRight + | otherwise = RightToLeft +directionOfVector _ = NoDirection + + + +-- +-- ****|**** +-- *** | *** +-- ** 1 ** +-- * | * +-- -----0----+---2------ +-- * ^ * +-- ** : ** +-- *** : *** +-- ****:**** +-- +-- +-- ****|**** +-- *** | *** +-- ** 0 ** +-- * | * +-- =========>+---1------ +-- * | * +-- ** 2 ** +-- *** | *** +-- ****|**** +-- +-- +-- ****|**** +-- *** | *** +-- ** 2 ** +-- * | * +-- -----1----+<========= +-- * | * +-- ** 0 ** +-- *** | *** +-- ****|**** +-- +-- +-- ****:**** +-- *** : *** +-- ** : ** +-- * V * +-- -----2----+---0------ +-- * | * +-- ** 1 ** +-- *** | *** +-- ****|**** +-- +vectorsForAnchor :: Anchor -> Direction -> [Vector] +vectorsForAnchor anchor dir = case (anchor, dir) of + (AnchorArrowUp, _) -> [down] + (AnchorArrowDown, _) -> [up] + (AnchorArrowLeft, _) -> [right] + (AnchorArrowRight, _) -> [left] + + (_, LeftToRight) -> [up, right, down, left] + (_, TopToBottom) -> [right, down, left, up] + (_, NoDirection) -> [right, down, left, up] + (_, RightToLeft) -> [down, left, up, right] + (_, BottomToTop) -> [left, up, right, down] + + where + left = V2 (-1) 0 + up = V2 0 (-1) + right = V2 1 0 + down = V2 0 1 + +directionVectorOf :: Point -> Point -> Vector +directionVectorOf a b = signum <$> a ^-^ b + +nextDirectionAfterAnchor :: Anchor -> Point -> Point -> [Point] +nextDirectionAfterAnchor anchor previousPoint anchorPosition = + [delta | delta <- deltas + , let nextPoint = anchorPosition ^+^ delta + , nextPoint /= previousPoint] + where + directionVector = directionVectorOf anchorPosition previousPoint + direction = directionOfVector directionVector + deltas = vectorsForAnchor anchor direction + +nextPointAfterAnchor :: Anchor -> Point -> Point -> [Point] +nextPointAfterAnchor anchor prev p = + (^+^ p) <$> nextDirectionAfterAnchor anchor prev p + +segmentManathanLength :: Segment -> Int +segmentManathanLength seg = x + y where + V2 x y = abs <$> _segEnd seg ^-^ _segStart seg + + +segmentDirectionMap :: S.Set Segment -> M.Map Point SegmentKind +segmentDirectionMap = S.fold go mempty where + go seg = M.insert (_segEnd seg) k . M.insert (_segStart seg) k + where + k = _segKind seg + +toGraph :: M.Map Point Anchor -> S.Set Segment + -> Graph Point ShapeElement Segment +toGraph anchors segs = execState graphCreator baseGraph where + baseGraph = graphOfVertices $ M.mapWithKey ShapeAnchor anchors + + segDirs = segmentDirectionMap segs + + graphCreator = do + F.traverse_ linkSegments segs + F.traverse_ linkAnchors $ M.assocs anchors + + linkOf p1 p2 | p1 < p2 = (p1, p2) + | otherwise = (p2, p1) + + linkAnchors (p, a) = F.traverse_ createLinks nextPoints where + nextPoints = nextPointAfterAnchor a (V2 (-1) (-1)) p + createLinks nextPoint = do + nextExists <- has (vertices . ix nextPoint) <$> get + let dirNext = nextPoint ^-^ p + nextP = M.lookup nextPoint anchors + nextS = M.lookup nextPoint segDirs + nextIsOk = case (nextP, nextS) of + (Just AnchorArrowUp, _) -> V2 0 (-1) == dirNext + (Just AnchorArrowDown, _) -> V2 0 1 == dirNext + (Just AnchorArrowLeft, _) -> V2 (-1) 0 == dirNext + (Just AnchorArrowRight, _) -> V2 1 0 == dirNext + (Just _, _) -> True + (Nothing, Nothing) -> True + (Nothing, Just SegmentHorizontal) -> + (abs <$> dirNext) == V2 1 0 + (Nothing, Just SegmentVertical) -> + (abs <$> dirNext) == V2 0 1 + + alreadyLinked <- has (edges . ix (linkOf p nextPoint)) <$> get + when (nextExists && nextIsOk && not alreadyLinked) $ + edges . at (linkOf p nextPoint) ?= mempty + + linkSegments seg | segmentManathanLength seg == 0 = do + vertices . at (_segStart seg ) ?= ShapeSegment seg + linkSegments seg@(Segment { _segStart = p1, _segEnd = p2 }) = do + vertices . at p1 ?= ShapeSegment seg + vertices . at p2 ?= ShapeSegment seg + edges . at (linkOf p1 p2) ?= seg + +findClockwisePossible :: S.Set Point -> Maybe Point -> Point + -> [Point] +findClockwisePossible adjacents Nothing p = + findClockwisePossible adjacents (Just p) p +findClockwisePossible adjacents (Just prev) p = + fmap snd $ sortBy (compare `on` fst) indexedAdjacents + where + -- don't care about specific direction, restrictions should have + -- been made during the construction of the graph. + dirArray = V.fromList $ nextDirectionAfterAnchor AnchorMulti prev p + zipIndex k = (V.elemIndex dir dirArray, k) + where dir = directionVectorOf k p + indexedAdjacents = + [(idx, nextPoint) + | (Just idx, nextPoint) <- zipIndex <$> S.elems adjacents + , nextPoint /= prev] + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +instance PlanarVertice (V2 Int) where + getClockwiseMost adj prev = + safeHead . findClockwisePossible adj prev + getCounterClockwiseMost adj prev = + safeHead . reverse . findClockwisePossible adj prev + +dedupEqual :: Eq a => [a] -> [a] +dedupEqual [] = [] +dedupEqual (x:rest@(y:_)) | x == y = dedupEqual rest +dedupEqual (x:xs) = x : dedupEqual xs + + +-- | Break filaments at multi anchor to ensure proper dashing +-- of the segments. +breakFilaments :: Filament ShapeElement -> [Filament ShapeElement] +breakFilaments = go where + go lst = f : fs + where (f, fs) = breaker lst + + breaker [] = ([], []) + breaker [a@(ShapeAnchor _ AnchorMulti)] = ([a], []) + breaker (a@(ShapeAnchor _ AnchorMulti):xs) = ([a], (a:filamentRest):others) + where (filamentRest, others) = breaker xs + breaker (x:xs) = (x:filamentRest, others) + where (filamentRest, others) = breaker xs + + +-- | Main call of the reconstruction function +reconstruct :: M.Map Point Anchor -> S.Set Segment + -> S.Set Shape +reconstruct anchors segments = + S.fromList $ fmap toShapes cycles + ++ concatMap toFilaments filaments + where + graph = toGraph anchors segments + (cycles, filaments) = extractAllPrimitives graph + + toElems = dedupEqual + . filter (/= ShapeSegment mempty) + . catMaybes + . fmap (`M.lookup` _vertices graph) + + toFilaments shapes = + [Shape piece False mempty mempty | piece <- breakFilaments $ toElems shapes] + + toShapes shapes = Shape (toElems shapes) True mempty mempty +
src/Text/AsciiDiagram/SvgRender.hs view
@@ -1,537 +1,537 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-module Text.AsciiDiagram.SvgRender- ( GridSize( .. )- , defaultGridSize- , svgOfDiagram- , svgOfDiagramAtSize- , defaultLibrary- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( (<$>) )-#endif--import Data.Monoid( (<>) )-import Control.Monad.State.Strict( execState )--import Graphics.Svg.Types- ( HasDrawAttributes( .. )- , Document( .. )- , drawAttr )-import Graphics.Svg( cssRulesOfText )--import qualified Graphics.Svg.Types as Svg-import qualified Graphics.Svg.CssTypes as Css-import qualified Data.Set as S-import qualified Data.Text as T-import Linear( V2( .. )- , (^+^)- , (^-^)- , (^*)- , perp- , normalize- )-import Control.Lens( zoom, (^.), (.=), (%=), (%~), (&) )--import Text.AsciiDiagram.BoundingBoxEstimation-import Text.AsciiDiagram.DefaultContext-import Text.AsciiDiagram.DiagramCleaner-import Text.AsciiDiagram.Geometry--{-import Debug.Trace-}-{-import Text.Groom-}---- | Simple type describing the grid size used during render.-data GridSize = GridSize- { _gridCellWidth :: !Float -- ^ Width of a cell (in pixel)- , _gridCellHeight :: !Float -- ^ Height of a cell (in pixel)-- -- | Coefficient used to space adjacent shapes, set to 0- -- if you want to remove space between them.- , _gridShapeContraction :: !Float- }- deriving (Eq, Show)---- | Default grid size used in the simple render functions-defaultGridSize :: GridSize-defaultGridSize = GridSize- { _gridCellWidth = 10- , _gridCellHeight = 14- , _gridShapeContraction = 1.5- }--toSvg :: GridSize -> Point -> Svg.RPoint-toSvg s (V2 x y) =- V2 (realToFrac $ _gridCellWidth s * fromIntegral (x + 1))- (realToFrac $ _gridCellHeight s * fromIntegral (y + 1))---setDashingInformation :: (Svg.WithDrawAttributes a) => a -> a-setDashingInformation = execState $ do- drawAttr . attrClass %= ("dashed_elem":)--isShapeDashed :: Shape -> Bool-isShapeDashed = any isDashed . shapeElements where- isDashed (ShapeAnchor _ _) = False- isDashed (ShapeSegment Segment { _segDraw = SegmentSolid }) = False- isDashed (ShapeSegment Segment { _segDraw = SegmentDashed }) = True--applyDefaultShapeDrawAttr :: (Svg.WithDrawAttributes a) => a -> a-applyDefaultShapeDrawAttr el =- el & drawAttr.attrClass %~ ("filled_shape":) --applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a-applyLineArrowDrawAttr el =- el & drawAttr.attrClass %~ ("arrow_head":)--applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a-applyBulletDrawAttr el =- el & drawAttr.attrClass %~ ("bullet":)--cleanupUseAttributes :: (Svg.WithDrawAttributes a) => a -> a-cleanupUseAttributes = execState . zoom drawAttr $ do- attrClass .= []--applyDefaultLineDrawAttr :: (Svg.WithDrawAttributes a) => a -> a-applyDefaultLineDrawAttr el =- el & drawAttr.attrClass %~ ("line_element":)---startPointOf :: ShapeElement -> Point-startPointOf (ShapeAnchor p _) = p-startPointOf (ShapeSegment seg) = _segStart seg---manathanDistance :: Point -> Point -> Int-manathanDistance a b = x + y where- V2 x y = abs <$> a ^-^ b---isNearBy :: Point -> Point -> Bool-isNearBy a b = manathanDistance a b <= 1---initialPrevious :: Bool -> [ShapeElement] -> Maybe Point-initialPrevious False _ = Nothing-initialPrevious True [] = Nothing-initialPrevious True lst@(x:_) = Just point- where- sp = startPointOf x-- point = case last lst of- ShapeAnchor pp _ -> pp- ShapeSegment seg- | manathanDistance sp (_segStart seg) <- manathanDistance sp (_segEnd seg) -> _segStart seg- ShapeSegment seg -> _segEnd seg---swapSegment :: Segment -> Segment-swapSegment seg =- seg { _segStart = _segEnd seg, _segEnd = _segStart seg }---rollToSegment :: Shape -> Shape-rollToSegment shape | not $ shapeIsClosed shape = shape-rollToSegment shape = shape { shapeElements = segments ++ anchorPrefix } where- (anchorPrefix, segments) = span isAnchor $ shapeElements shape-- isAnchor (ShapeSegment _) = False- isAnchor (ShapeAnchor _ _) = True---reorderShapePoints :: Shape -> [(Maybe Point, ShapeElement)]-reorderShapePoints shape = outList where- outList = go initialPrev elements- elements = shapeElements shape- initialPrev = initialPrevious (shapeIsClosed shape) elements-- go _ [] = []- go prev (a@(ShapeAnchor p _):rest) =- (prev, a) : go (Just p) rest- go prev (s@(ShapeSegment seg):rest)- | start == _segEnd seg = (prev, s) : go (Just start) rest- where start = _segStart seg- go prev@(Just prevPoint) (s@(ShapeSegment seg):rest)- | prevPoint `isNearBy` start =- (prev, s) : go (Just end) rest- | otherwise =- (prev, ShapeSegment $ swapSegment seg) : go (Just start) rest- where start = _segStart seg- end = _segEnd seg- go Nothing (s@(ShapeSegment seg):rest@(nextShape:_)) =- case nextShape of- ShapeAnchor p _ | p `isNearBy` start ->- (Nothing, ShapeSegment $ swapSegment seg) : go (Just start) rest- ShapeAnchor _ _ ->- (Nothing, s) : go (Just $ _segEnd seg) rest- ShapeSegment _ -> (Nothing, s) : go (Just $ _segEnd seg) rest- where start = _segStart seg- go Nothing [e@(ShapeSegment _)] = [(Nothing, e)]---associateNextPoint :: Bool -> [(a, ShapeElement)]- -> [(a, ShapeElement, Maybe Point)]-associateNextPoint isClosed elements = go elements where- startingPoint =- Just . startPointOf . head $ map snd elements-- go [] = []- go [(p, s)]- | isClosed = [(p, s, startingPoint)]- | otherwise = [(p, s, Nothing)]- go ((p, s):xs@((_, y):_)) =- (p, s, Just $ startPointOf y) : go xs----- >--- > ^ perp:(0, -n)--- > |--- > (x, y)| (x + n, y)--- > +-------------------+ b--- > a|--- > v correction----correctionVectorOf :: Integral a => GridSize -> V2 a -> V2 a -> V2 Float-correctionVectorOf size a b = normalize dir ^* _gridShapeContraction size- where- dir = fromIntegral . negate <$> perp (b ^-^ a)---startPoint :: GridSize -> [(Maybe Point, ShapeElement, Maybe Point)]- -> Svg.RPoint-startPoint gscale shapeElems = case shapeElems of- [] -> V2 0 0- (Just before, ShapeAnchor p _, Just after):_ -> toS p ^+^ combined- where v1 = realToFrac <$> correctionVector before p- v2 = realToFrac <$> correctionVector p after- combined | v1 == v2 = v1- | otherwise = v1 ^+^ v2- (before, ShapeSegment seg, _):_ -> pp ^+^ vc where- vc = segmentCorrectionVector gscale before seg- pp = toS $ _segStart seg- (_, ShapeAnchor p _, _):_ -> toS p- where- correctionVector = correctionVectorOf gscale- toS = toSvg gscale---anchorCorrection :: GridSize -> Point -> Point -> Point- -> Svg.RPoint-anchorCorrection scale before p after- | v1 == v2 = realToFrac <$> v1- | otherwise = v1 ^+^ v2- where v1 = realToFrac <$> correctionVectorOf scale before p- v2 = realToFrac <$> correctionVectorOf scale p after---moveTo, lineTo :: Svg.RPoint -> Svg.PathCommand-moveTo p = Svg.MoveTo Svg.OriginAbsolute [p]-lineTo p = Svg.LineTo Svg.OriginAbsolute [p]---smoothCurveTo :: Svg.RPoint -> Svg.RPoint -> Svg.PathCommand-smoothCurveTo p1 p =- Svg.SmoothCurveTo Svg.OriginAbsolute [(p1, p)]---shapeClosing :: Shape -> [Svg.PathCommand]-shapeClosing Shape { shapeIsClosed = True } = [Svg.EndPath]-shapeClosing _ = []---segmentCorrectionVector :: GridSize -> Maybe Point -> Segment -> Svg.RPoint-segmentCorrectionVector gscale before seg | _segStart seg == _segEnd seg =- realToFrac <$> case (before, _segKind seg) of- (Just v1, _) -> correctionVectorOf gscale v1 (_segEnd seg)- (Nothing, SegmentHorizontal) -> V2 0 $ _gridShapeContraction gscale- (Nothing, SegmentVertical) -> V2 (negate $ _gridShapeContraction gscale) 0-segmentCorrectionVector gscale _ seg =- realToFrac <$> correctionVectorOf gscale (_segStart seg) (_segEnd seg)---straightCorner :: GridSize -> Bool -> Maybe Point -> Point -> Maybe Point- -> ([Svg.PathCommand], [Svg.Tree])-straightCorner gscale isBullet pBefore p pAfter- | isBullet = ([lineTo finalPoint], [renderBullet gscale finalPoint])- | otherwise = ([lineTo finalPoint], [])- where- pSvg = toSvg gscale p- finalPoint = case (pBefore, pAfter) of- (Just before, Just after) ->- anchorCorrection gscale before p after ^+^ pSvg- (Just before, _) -> - (realToFrac <$> correctionVectorOf gscale before p) ^+^ pSvg- _ -> pSvg--curveCorner :: GridSize -> Maybe Point -> Point -> Maybe Point -> Svg.PathCommand-curveCorner gscale _ p (Just after) =- smoothCurveTo (toS p) $ toS after ^+^ correction- where correction = realToFrac <$> correctionVectorOf gscale p after- toS = toSvg gscale-curveCorner gscale (Just before) p Nothing =- smoothCurveTo (toS p) $ toS p ^+^ vec- where vec = realToFrac <$> correctionVectorOf gscale before p- toS = toSvg gscale-curveCorner gscale _ p _ = lineTo $ toSvg gscale p---roundedCorner :: GridSize -> Point -> Point -> Maybe Point -> Svg.PathCommand-roundedCorner gscale p1 p2 (Just lastPoint) =- Svg.CurveTo Svg.OriginAbsolute [(toS p1, toS p2, toS lastPoint ^+^ vec)]- where toS = toSvg gscale- vec = realToFrac <$> correctionVectorOf gscale p2 lastPoint-roundedCorner gscale p1 p2 after =- curveCorner gscale (Just p1) p2 after--toPathRooted :: [Svg.RPoint] -> GridSize -> Point -> Svg.Tree-toPathRooted pts gscale p =- applyLineArrowDrawAttr . Svg.PathTree $ Svg.Path mempty pathCommands- where- pt = fromIntegral <$> p- sizes =- realToFrac <$> V2 (_gridCellWidth gscale) (_gridCellHeight gscale)-- toGrid pp = lineTo $ (pt ^+^ pp) * sizes- pathCommands = case pts of- [] -> []- x:xs -> moveTo ((pt ^+^ x) * sizes)- : fmap toGrid xs ++ [Svg.EndPath]--toRightArrow :: GridSize -> Point -> Svg.Tree-toRightArrow =- toPathRooted [ V2 1 0.5- , V2 2 1- , V2 1 1.5- ]--toLeftArrow :: GridSize -> Point -> Svg.Tree-toLeftArrow =- toPathRooted [ V2 1 0.5- , V2 0 1- , V2 1 1.5- ]--toTopArrow :: GridSize -> Point -> Svg.Tree-toTopArrow =- toPathRooted [ V2 0.5 1- , V2 1.5 1- , V2 1 0- ]--toBottomArrow :: GridSize -> Point -> Svg.Tree-toBottomArrow =- toPathRooted [ V2 0.5 1- , V2 1.5 1- , V2 1 2- ]--renderBullet :: GridSize -> Svg.RPoint -> Svg.Tree-renderBullet gscale (V2 x y) = applyBulletDrawAttr $ Svg.CircleTree Svg.defaultSvg- { Svg._circleCenter = (Svg.Num $ realToFrac x, Svg.Num $ realToFrac y)- , Svg._circleRadius = Svg.Num . realToFrac $ halfWidth - 2- }- where halfWidth = _gridCellWidth gscale / 2--dashingSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a-dashingSet shape- | isShapeDashed shape = setDashingInformation- | otherwise = id--classSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a-classSet shape e =- e & drawAttr . attrClass %~ (++ S.toList (shapeTags shape))--shapeToTree :: (forall a. (Svg.WithDrawAttributes a) => a -> a)- -> GridSize -> Shape -> Svg.Tree-shapeToTree classSetter gscale shape@Shape- { shapeIsClosed = True- , shapeElements =- [ ShapeSegment _- , ShapeAnchor p0 AnchorMulti- , ShapeSegment _- , ShapeAnchor p1 AnchorMulti- , ShapeSegment _- , ShapeAnchor p2 AnchorMulti- , ShapeSegment _- , ShapeAnchor p3 AnchorMulti ]- } = classSet shape- . dashingSet shape- . Svg.RectangleTree- . classSetter- $ Svg.defaultSvg- { Svg._rectWidth = Svg.Num sWidth- , Svg._rectHeight = Svg.Num sHeight- , Svg._rectUpperLeftCorner = (Svg.Num px, Svg.Num py) }- where- pts = [p0, p1, p2, p3]- mini = minimum pts- maxi = maximum pts- contraction = _gridShapeContraction gscale- contractionVector = realToFrac <$> V2 contraction contraction-- maxiPoint = toSvg gscale maxi ^-^ contractionVector- pt@(V2 px py) = toSvg gscale mini ^+^ contractionVector - V2 sWidth sHeight = maxiPoint ^-^ pt--shapeToTree classSetter gscale shape =- case concat arrows of- [] -> svgPath- lst -> Svg.GroupTree . classSet shape- $ Svg.defaultSvg { Svg._groupChildren = svgPath : lst }- where- toS = toSvg gscale- shapeElems = associateNextPoint (shapeIsClosed shape)- . reorderShapePoints- $ rollToSegment shape-- svgPath = classSet shape . dashingSet shape . Svg.PathTree- . classSetter- $ Svg.Path mempty pathCommands-- pathCommands =- moveTo (startPoint gscale shapeElems)- : concat pathes ++ shapeClosing shape- (pathes, arrows) = unzip $ toPath shapeElems-- toPath [] = []- toPath ((before, ShapeSegment seg, Just _):rest) =- ([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest- where vc = segmentCorrectionVector gscale before seg- toPath ((before, ShapeSegment seg, Nothing):rest) =- ([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest- where vc = segmentCorrectionVector gscale before seg'- extension = signum <$> (_segEnd seg ^-^ _segStart seg)- seg' = seg { _segEnd = _segEnd seg ^+^ extension }- toPath ((_, ShapeAnchor p1 AnchorFirstDiag, _)- :(_, ShapeAnchor p2 AnchorSecondDiag, after)- :rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest- toPath ((_, ShapeAnchor p1 AnchorSecondDiag, _)- :(_, ShapeAnchor p2 AnchorFirstDiag, after)- :rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest- toPath ((before, ShapeAnchor p a, after):rest) = anchorJoin : toPath rest- where- anchorJoin = case a of- AnchorPoint -> straightCorner gscale False before p after- AnchorMulti -> straightCorner gscale False before p after- AnchorBullet -> straightCorner gscale True before p after- - AnchorFirstDiag -> ([curveCorner gscale before p after], [])- AnchorSecondDiag -> ([curveCorner gscale before p after], [])-- AnchorArrowUp -> ([lineTo $ toS p], [toTopArrow gscale p])- AnchorArrowDown -> ([lineTo $ toS p], [toBottomArrow gscale p])- AnchorArrowLeft -> ([lineTo $ toS p], [toLeftArrow gscale p])- AnchorArrowRight -> ([lineTo $ toS p], [toRightArrow gscale p])---textToTree :: GridSize -> TextZone -> Svg.Tree-textToTree gscale zone = Svg.TextTree Nothing txt- where- correction = realToFrac <$>- V2 (negate $ _gridCellWidth gscale)- (_gridCellHeight gscale) ^* 0.5- V2 x y = toSvg gscale (_textZoneOrigin zone) ^+^ correction- txt = Svg.textAt (Svg.Num (x+0.5), Svg.Num (y+0.5)) $ _textZoneContent zone----- | Transform an Ascii diagram to a SVG document which--- can be saved or converted to an image.-svgOfDiagram :: Diagram -> Svg.Document-svgOfDiagram =- svgOfDiagramAtSize defaultGridSize (defaultLibrary defaultGridSize)--svgOfShape :: GridSize -> Shape -> Svg.Tree-svgOfShape scale shape- | shapeIsClosed shape =- shapeToTree applyDefaultShapeDrawAttr scale shape- | otherwise =- shapeToTree applyDefaultLineDrawAttr strokeScale shape- where- strokeScale = scale { _gridShapeContraction = 0 }---svgOfElement :: GridSize -> Element -> Svg.Tree-svgOfElement scale (ElemText txt) = textToTree scale txt-svgOfElement scale (ElemShape shape) = - case shapeChildren shape of- [] -> svgOfShape scale shape- _:_ -> Svg.GroupTree $ group- where- thisShape = svgOfShape scale shape- group = Svg.defaultSvg- { Svg._groupDrawAttributes =- mempty { Svg._attrClass = S.toList $ shapeTags shape }- , Svg._groupChildren =- thisShape : fmap (svgOfElement scale) (shapeChildren shape)- , Svg._groupViewBox = Nothing- }--shapeRewriter :: [Css.CssRule] -> Svg.Tree -> Svg.Tree-shapeRewriter rules = Svg.zipTree go where- go [] = Svg.None- go ([]:_) = Svg.None- go context@((t:_):_) = case reverse shapeDeclarations of- [] -> t- (([Css.CssIdent i]:_): _) -> Svg.UseTree (useInfo i) Nothing- _ -> t- where- useInfo name = cleanupUseAttributes $ Svg.Use- { Svg._useDrawAttributes = t ^. Svg.drawAttr- , Svg._useBase = (Css.Num x, Css.Num y)- , Svg._useName = T.unpack name- , Svg._useWidth = Just (Css.Num w)- , Svg._useHeight = Just (Css.Num h)- }-- BoundingBox pMin@(V2 x y) pMax = boundingBoxOf t- V2 w h = pMax ^-^ pMin-- shapeDeclarations = - [el | Css.CssDeclaration "shape" el <- Css.findMatchingDeclarations rules context]---- | Transform an Ascii diagram to a SVG document which--- can be saved or converted to an image, with a customizable--- grid size.-svgOfDiagramAtSize :: GridSize -> Svg.Document -> Diagram -> Svg.Document-svgOfDiagramAtSize scale style diagram = Document- { _viewBox = Nothing- , _width =- toSvgSize _gridCellWidth $ _diagramCellWidth diagram + 1- , _height =- toSvgSize _gridCellHeight $ _diagramCellHeight diagram + 1- , _elements =- shapeRewriter allRules . svgOfElement scale <$> shapes- , _definitions = _definitions style- , _description = ""- , _styleRules = allRules- , _documentLocation = ""- }- where- allRules = _styleRules style <> customCssRules- customCssRules = - cssRulesOfText . T.unlines $ _diagramStyles diagram-- isDrawable (ElemText _) = True- isDrawable (ElemShape shape) =- not (shapeIsClosed shape) || isShapePossible shape- shapes = filter isDrawable . S.toList $ _diagramElements diagram-- toSvgSize accessor var =- Just . Svg.Num . realToFrac $ fromIntegral var * accessor scale + 5--defaultLibrary :: GridSize -> Svg.Document-defaultLibrary size = Document- { _viewBox = Nothing- , _width = Nothing- , _height = Nothing- , _elements = []- , _definitions = defaultDefinitions- , _description = ""- , _styleRules = defaultCssRules $ _gridCellHeight size- , _documentLocation = ""- }-+{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Text.AsciiDiagram.SvgRender + ( GridSize( .. ) + , defaultGridSize + , svgOfDiagram + , svgOfDiagramAtSize + , defaultLibrary + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>) ) +#endif + +import Data.Monoid( (<>) ) +import Control.Monad.State.Strict( execState ) + +import Graphics.Svg.Types + ( HasDrawAttributes( .. ) + , Document( .. ) + , drawAttr ) +import Graphics.Svg( cssRulesOfText ) + +import qualified Graphics.Svg.Types as Svg +import qualified Graphics.Svg.CssTypes as Css +import qualified Data.Set as S +import qualified Data.Text as T +import Linear( V2( .. ) + , (^+^) + , (^-^) + , (^*) + , perp + , normalize + ) +import Control.Lens( zoom, (^.), (.=), (%=), (%~), (&) ) + +import Text.AsciiDiagram.BoundingBoxEstimation +import Text.AsciiDiagram.DefaultContext +import Text.AsciiDiagram.DiagramCleaner +import Text.AsciiDiagram.Geometry + +{-import Debug.Trace-} +{-import Text.Groom-} + +-- | Simple type describing the grid size used during render. +data GridSize = GridSize + { _gridCellWidth :: !Float -- ^ Width of a cell (in pixel) + , _gridCellHeight :: !Float -- ^ Height of a cell (in pixel) + + -- | Coefficient used to space adjacent shapes, set to 0 + -- if you want to remove space between them. + , _gridShapeContraction :: !Float + } + deriving (Eq, Show) + +-- | Default grid size used in the simple render functions +defaultGridSize :: GridSize +defaultGridSize = GridSize + { _gridCellWidth = 10 + , _gridCellHeight = 14 + , _gridShapeContraction = 1.5 + } + +toSvg :: GridSize -> Point -> Svg.RPoint +toSvg s (V2 x y) = + V2 (realToFrac $ _gridCellWidth s * fromIntegral (x + 1)) + (realToFrac $ _gridCellHeight s * fromIntegral (y + 1)) + + +setDashingInformation :: (Svg.WithDrawAttributes a) => a -> a +setDashingInformation = execState $ do + drawAttr . attrClass %= ("dashed_elem":) + +isShapeDashed :: Shape -> Bool +isShapeDashed = any isDashed . shapeElements where + isDashed (ShapeAnchor _ _) = False + isDashed (ShapeSegment Segment { _segDraw = SegmentSolid }) = False + isDashed (ShapeSegment Segment { _segDraw = SegmentDashed }) = True + +applyDefaultShapeDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyDefaultShapeDrawAttr el = + el & drawAttr.attrClass %~ ("filled_shape":) + +applyLineArrowDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyLineArrowDrawAttr el = + el & drawAttr.attrClass %~ ("arrow_head":) + +applyBulletDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyBulletDrawAttr el = + el & drawAttr.attrClass %~ ("bullet":) + +cleanupUseAttributes :: (Svg.WithDrawAttributes a) => a -> a +cleanupUseAttributes = execState . zoom drawAttr $ do + attrClass .= [] + +applyDefaultLineDrawAttr :: (Svg.WithDrawAttributes a) => a -> a +applyDefaultLineDrawAttr el = + el & drawAttr.attrClass %~ ("line_element":) + + +startPointOf :: ShapeElement -> Point +startPointOf (ShapeAnchor p _) = p +startPointOf (ShapeSegment seg) = _segStart seg + + +manathanDistance :: Point -> Point -> Int +manathanDistance a b = x + y where + V2 x y = abs <$> a ^-^ b + + +isNearBy :: Point -> Point -> Bool +isNearBy a b = manathanDistance a b <= 1 + + +initialPrevious :: Bool -> [ShapeElement] -> Maybe Point +initialPrevious False _ = Nothing +initialPrevious True [] = Nothing +initialPrevious True lst@(x:_) = Just point + where + sp = startPointOf x + + point = case last lst of + ShapeAnchor pp _ -> pp + ShapeSegment seg + | manathanDistance sp (_segStart seg) < + manathanDistance sp (_segEnd seg) -> _segStart seg + ShapeSegment seg -> _segEnd seg + + +swapSegment :: Segment -> Segment +swapSegment seg = + seg { _segStart = _segEnd seg, _segEnd = _segStart seg } + + +rollToSegment :: Shape -> Shape +rollToSegment shape | not $ shapeIsClosed shape = shape +rollToSegment shape = shape { shapeElements = segments ++ anchorPrefix } where + (anchorPrefix, segments) = span isAnchor $ shapeElements shape + + isAnchor (ShapeSegment _) = False + isAnchor (ShapeAnchor _ _) = True + + +reorderShapePoints :: Shape -> [(Maybe Point, ShapeElement)] +reorderShapePoints shape = outList where + outList = go initialPrev elements + elements = shapeElements shape + initialPrev = initialPrevious (shapeIsClosed shape) elements + + go _ [] = [] + go prev (a@(ShapeAnchor p _):rest) = + (prev, a) : go (Just p) rest + go prev (s@(ShapeSegment seg):rest) + | start == _segEnd seg = (prev, s) : go (Just start) rest + where start = _segStart seg + go prev@(Just prevPoint) (s@(ShapeSegment seg):rest) + | prevPoint `isNearBy` start = + (prev, s) : go (Just end) rest + | otherwise = + (prev, ShapeSegment $ swapSegment seg) : go (Just start) rest + where start = _segStart seg + end = _segEnd seg + go Nothing (s@(ShapeSegment seg):rest@(nextShape:_)) = + case nextShape of + ShapeAnchor p _ | p `isNearBy` start -> + (Nothing, ShapeSegment $ swapSegment seg) : go (Just start) rest + ShapeAnchor _ _ -> + (Nothing, s) : go (Just $ _segEnd seg) rest + ShapeSegment _ -> (Nothing, s) : go (Just $ _segEnd seg) rest + where start = _segStart seg + go Nothing [e@(ShapeSegment _)] = [(Nothing, e)] + + +associateNextPoint :: Bool -> [(a, ShapeElement)] + -> [(a, ShapeElement, Maybe Point)] +associateNextPoint isClosed elements = go elements where + startingPoint = + Just . startPointOf . head $ map snd elements + + go [] = [] + go [(p, s)] + | isClosed = [(p, s, startingPoint)] + | otherwise = [(p, s, Nothing)] + go ((p, s):xs@((_, y):_)) = + (p, s, Just $ startPointOf y) : go xs + + +-- > +-- > ^ perp:(0, -n) +-- > | +-- > (x, y)| (x + n, y) +-- > +-------------------+ b +-- > a| +-- > v correction +-- +correctionVectorOf :: Integral a => GridSize -> V2 a -> V2 a -> V2 Float +correctionVectorOf size a b = normalize dir ^* _gridShapeContraction size + where + dir = fromIntegral . negate <$> perp (b ^-^ a) + + +startPoint :: GridSize -> [(Maybe Point, ShapeElement, Maybe Point)] + -> Svg.RPoint +startPoint gscale shapeElems = case shapeElems of + [] -> V2 0 0 + (Just before, ShapeAnchor p _, Just after):_ -> toS p ^+^ combined + where v1 = realToFrac <$> correctionVector before p + v2 = realToFrac <$> correctionVector p after + combined | v1 == v2 = v1 + | otherwise = v1 ^+^ v2 + (before, ShapeSegment seg, _):_ -> pp ^+^ vc where + vc = segmentCorrectionVector gscale before seg + pp = toS $ _segStart seg + (_, ShapeAnchor p _, _):_ -> toS p + where + correctionVector = correctionVectorOf gscale + toS = toSvg gscale + + +anchorCorrection :: GridSize -> Point -> Point -> Point + -> Svg.RPoint +anchorCorrection scale before p after + | v1 == v2 = realToFrac <$> v1 + | otherwise = v1 ^+^ v2 + where v1 = realToFrac <$> correctionVectorOf scale before p + v2 = realToFrac <$> correctionVectorOf scale p after + + +moveTo, lineTo :: Svg.RPoint -> Svg.PathCommand +moveTo p = Svg.MoveTo Svg.OriginAbsolute [p] +lineTo p = Svg.LineTo Svg.OriginAbsolute [p] + + +smoothCurveTo :: Svg.RPoint -> Svg.RPoint -> Svg.PathCommand +smoothCurveTo p1 p = + Svg.SmoothCurveTo Svg.OriginAbsolute [(p1, p)] + + +shapeClosing :: Shape -> [Svg.PathCommand] +shapeClosing Shape { shapeIsClosed = True } = [Svg.EndPath] +shapeClosing _ = [] + + +segmentCorrectionVector :: GridSize -> Maybe Point -> Segment -> Svg.RPoint +segmentCorrectionVector gscale before seg | _segStart seg == _segEnd seg = + realToFrac <$> case (before, _segKind seg) of + (Just v1, _) -> correctionVectorOf gscale v1 (_segEnd seg) + (Nothing, SegmentHorizontal) -> V2 0 $ _gridShapeContraction gscale + (Nothing, SegmentVertical) -> V2 (negate $ _gridShapeContraction gscale) 0 +segmentCorrectionVector gscale _ seg = + realToFrac <$> correctionVectorOf gscale (_segStart seg) (_segEnd seg) + + +straightCorner :: GridSize -> Bool -> Maybe Point -> Point -> Maybe Point + -> ([Svg.PathCommand], [Svg.Tree]) +straightCorner gscale isBullet pBefore p pAfter + | isBullet = ([lineTo finalPoint], [renderBullet gscale finalPoint]) + | otherwise = ([lineTo finalPoint], []) + where + pSvg = toSvg gscale p + finalPoint = case (pBefore, pAfter) of + (Just before, Just after) -> + anchorCorrection gscale before p after ^+^ pSvg + (Just before, _) -> + (realToFrac <$> correctionVectorOf gscale before p) ^+^ pSvg + _ -> pSvg + +curveCorner :: GridSize -> Maybe Point -> Point -> Maybe Point -> Svg.PathCommand +curveCorner gscale _ p (Just after) = + smoothCurveTo (toS p) $ toS after ^+^ correction + where correction = realToFrac <$> correctionVectorOf gscale p after + toS = toSvg gscale +curveCorner gscale (Just before) p Nothing = + smoothCurveTo (toS p) $ toS p ^+^ vec + where vec = realToFrac <$> correctionVectorOf gscale before p + toS = toSvg gscale +curveCorner gscale _ p _ = lineTo $ toSvg gscale p + + +roundedCorner :: GridSize -> Point -> Point -> Maybe Point -> Svg.PathCommand +roundedCorner gscale p1 p2 (Just lastPoint) = + Svg.CurveTo Svg.OriginAbsolute [(toS p1, toS p2, toS lastPoint ^+^ vec)] + where toS = toSvg gscale + vec = realToFrac <$> correctionVectorOf gscale p2 lastPoint +roundedCorner gscale p1 p2 after = + curveCorner gscale (Just p1) p2 after + +toPathRooted :: [Svg.RPoint] -> GridSize -> Point -> Svg.Tree +toPathRooted pts gscale p = + applyLineArrowDrawAttr . Svg.PathTree $ Svg.Path mempty pathCommands + where + pt = fromIntegral <$> p + sizes = + realToFrac <$> V2 (_gridCellWidth gscale) (_gridCellHeight gscale) + + toGrid pp = lineTo $ (pt ^+^ pp) * sizes + pathCommands = case pts of + [] -> [] + x:xs -> moveTo ((pt ^+^ x) * sizes) + : fmap toGrid xs ++ [Svg.EndPath] + +toRightArrow :: GridSize -> Point -> Svg.Tree +toRightArrow = + toPathRooted [ V2 1 0.5 + , V2 2 1 + , V2 1 1.5 + ] + +toLeftArrow :: GridSize -> Point -> Svg.Tree +toLeftArrow = + toPathRooted [ V2 1 0.5 + , V2 0 1 + , V2 1 1.5 + ] + +toTopArrow :: GridSize -> Point -> Svg.Tree +toTopArrow = + toPathRooted [ V2 0.5 1 + , V2 1.5 1 + , V2 1 0 + ] + +toBottomArrow :: GridSize -> Point -> Svg.Tree +toBottomArrow = + toPathRooted [ V2 0.5 1 + , V2 1.5 1 + , V2 1 2 + ] + +renderBullet :: GridSize -> Svg.RPoint -> Svg.Tree +renderBullet gscale (V2 x y) = applyBulletDrawAttr $ Svg.CircleTree Svg.defaultSvg + { Svg._circleCenter = (Svg.Num $ realToFrac x, Svg.Num $ realToFrac y) + , Svg._circleRadius = Svg.Num . realToFrac $ halfWidth - 2 + } + where halfWidth = _gridCellWidth gscale / 2 + +dashingSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a +dashingSet shape + | isShapeDashed shape = setDashingInformation + | otherwise = id + +classSet :: (Svg.WithDrawAttributes a) => Shape -> a -> a +classSet shape e = + e & drawAttr . attrClass %~ (++ S.toList (shapeTags shape)) + +shapeToTree :: (forall a. (Svg.WithDrawAttributes a) => a -> a) + -> GridSize -> Shape -> Svg.Tree +shapeToTree classSetter gscale shape@Shape + { shapeIsClosed = True + , shapeElements = + [ ShapeSegment _ + , ShapeAnchor p0 AnchorMulti + , ShapeSegment _ + , ShapeAnchor p1 AnchorMulti + , ShapeSegment _ + , ShapeAnchor p2 AnchorMulti + , ShapeSegment _ + , ShapeAnchor p3 AnchorMulti ] + } = classSet shape + . dashingSet shape + . Svg.RectangleTree + . classSetter + $ Svg.defaultSvg + { Svg._rectWidth = Svg.Num sWidth + , Svg._rectHeight = Svg.Num sHeight + , Svg._rectUpperLeftCorner = (Svg.Num px, Svg.Num py) } + where + pts = [p0, p1, p2, p3] + mini = minimum pts + maxi = maximum pts + contraction = _gridShapeContraction gscale + contractionVector = realToFrac <$> V2 contraction contraction + + maxiPoint = toSvg gscale maxi ^-^ contractionVector + pt@(V2 px py) = toSvg gscale mini ^+^ contractionVector + V2 sWidth sHeight = maxiPoint ^-^ pt + +shapeToTree classSetter gscale shape = + case concat arrows of + [] -> svgPath + lst -> Svg.GroupTree . classSet shape + $ Svg.defaultSvg { Svg._groupChildren = svgPath : lst } + where + toS = toSvg gscale + shapeElems = associateNextPoint (shapeIsClosed shape) + . reorderShapePoints + $ rollToSegment shape + + svgPath = classSet shape . dashingSet shape . Svg.PathTree + . classSetter + $ Svg.Path mempty pathCommands + + pathCommands = + moveTo (startPoint gscale shapeElems) + : concat pathes ++ shapeClosing shape + (pathes, arrows) = unzip $ toPath shapeElems + + toPath [] = [] + toPath ((before, ShapeSegment seg, Just _):rest) = + ([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest + where vc = segmentCorrectionVector gscale before seg + toPath ((before, ShapeSegment seg, Nothing):rest) = + ([lineTo (vc ^+^ toS (_segEnd seg))], []) : toPath rest + where vc = segmentCorrectionVector gscale before seg' + extension = signum <$> (_segEnd seg ^-^ _segStart seg) + seg' = seg { _segEnd = _segEnd seg ^+^ extension } + toPath ((_, ShapeAnchor p1 AnchorFirstDiag, _) + :(_, ShapeAnchor p2 AnchorSecondDiag, after) + :rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest + toPath ((_, ShapeAnchor p1 AnchorSecondDiag, _) + :(_, ShapeAnchor p2 AnchorFirstDiag, after) + :rest) = ([roundedCorner gscale p1 p2 after], []) : toPath rest + toPath ((before, ShapeAnchor p a, after):rest) = anchorJoin : toPath rest + where + anchorJoin = case a of + AnchorPoint -> straightCorner gscale False before p after + AnchorMulti -> straightCorner gscale False before p after + AnchorBullet -> straightCorner gscale True before p after + + AnchorFirstDiag -> ([curveCorner gscale before p after], []) + AnchorSecondDiag -> ([curveCorner gscale before p after], []) + + AnchorArrowUp -> ([lineTo $ toS p], [toTopArrow gscale p]) + AnchorArrowDown -> ([lineTo $ toS p], [toBottomArrow gscale p]) + AnchorArrowLeft -> ([lineTo $ toS p], [toLeftArrow gscale p]) + AnchorArrowRight -> ([lineTo $ toS p], [toRightArrow gscale p]) + + +textToTree :: GridSize -> TextZone -> Svg.Tree +textToTree gscale zone = Svg.TextTree Nothing txt + where + correction = realToFrac <$> + V2 (negate $ _gridCellWidth gscale) + (_gridCellHeight gscale) ^* 0.5 + V2 x y = toSvg gscale (_textZoneOrigin zone) ^+^ correction + txt = Svg.textAt (Svg.Num (x+0.5), Svg.Num (y+0.5)) $ _textZoneContent zone + + +-- | Transform an Ascii diagram to a SVG document which +-- can be saved or converted to an image. +svgOfDiagram :: Diagram -> Svg.Document +svgOfDiagram = + svgOfDiagramAtSize defaultGridSize (defaultLibrary defaultGridSize) + +svgOfShape :: GridSize -> Shape -> Svg.Tree +svgOfShape scale shape + | shapeIsClosed shape = + shapeToTree applyDefaultShapeDrawAttr scale shape + | otherwise = + shapeToTree applyDefaultLineDrawAttr strokeScale shape + where + strokeScale = scale { _gridShapeContraction = 0 } + + +svgOfElement :: GridSize -> Element -> Svg.Tree +svgOfElement scale (ElemText txt) = textToTree scale txt +svgOfElement scale (ElemShape shape) = + case shapeChildren shape of + [] -> svgOfShape scale shape + _:_ -> Svg.GroupTree $ group + where + thisShape = svgOfShape scale shape + group = Svg.defaultSvg + { Svg._groupDrawAttributes = + mempty { Svg._attrClass = S.toList $ shapeTags shape } + , Svg._groupChildren = + thisShape : fmap (svgOfElement scale) (shapeChildren shape) + , Svg._groupViewBox = Nothing + } + +shapeRewriter :: [Css.CssRule] -> Svg.Tree -> Svg.Tree +shapeRewriter rules = Svg.zipTree go where + go [] = Svg.None + go ([]:_) = Svg.None + go context@((t:_):_) = case reverse shapeDeclarations of + [] -> t + (([Css.CssIdent i]:_): _) -> Svg.UseTree (useInfo i) Nothing + _ -> t + where + useInfo name = cleanupUseAttributes $ Svg.Use + { Svg._useDrawAttributes = t ^. Svg.drawAttr + , Svg._useBase = (Css.Num x, Css.Num y) + , Svg._useName = T.unpack name + , Svg._useWidth = Just (Css.Num w) + , Svg._useHeight = Just (Css.Num h) + } + + BoundingBox pMin@(V2 x y) pMax = boundingBoxOf t + V2 w h = pMax ^-^ pMin + + shapeDeclarations = + [el | Css.CssDeclaration "shape" el <- Css.findMatchingDeclarations rules context] + +-- | Transform an Ascii diagram to a SVG document which +-- can be saved or converted to an image, with a customizable +-- grid size. +svgOfDiagramAtSize :: GridSize -> Svg.Document -> Diagram -> Svg.Document +svgOfDiagramAtSize scale style diagram = Document + { _viewBox = Nothing + , _width = + toSvgSize _gridCellWidth $ _diagramCellWidth diagram + 1 + , _height = + toSvgSize _gridCellHeight $ _diagramCellHeight diagram + 1 + , _elements = + shapeRewriter allRules . svgOfElement scale <$> shapes + , _definitions = _definitions style + , _description = "" + , _styleRules = allRules + , _documentLocation = "" + } + where + allRules = _styleRules style <> customCssRules + customCssRules = + cssRulesOfText . T.unlines $ _diagramStyles diagram + + isDrawable (ElemText _) = True + isDrawable (ElemShape shape) = + not (shapeIsClosed shape) || isShapePossible shape + shapes = filter isDrawable . S.toList $ _diagramElements diagram + + toSvgSize accessor var = + Just . Svg.Num . realToFrac $ fromIntegral var * accessor scale + 5 + +defaultLibrary :: GridSize -> Svg.Document +defaultLibrary size = Document + { _viewBox = Nothing + , _width = Nothing + , _height = Nothing + , _elements = [] + , _definitions = defaultDefinitions + , _description = "" + , _styleRules = defaultCssRules $ _gridCellHeight size + , _documentLocation = "" + } +