diff --git a/app/reanimate-example.hs b/app/reanimate-example.hs deleted file mode 100644 --- a/app/reanimate-example.hs +++ /dev/null @@ -1,55 +0,0 @@ -#!/usr/bin/env stack --- stack runghc --package reanimate - -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} - --- | reanimate example --- --- To run this example: --- --- stack runghc --package reanimate app/reanimate-example.hs --- --- and wait for the browser to open ... -module Main where - -import Chart -import Chart.Examples -import Chart.Reanimate -import Control.Lens hiding (transform) -import Data.Foldable -import Reanimate as Re - -main :: IO () -main = - reanimate $ - foldl' seqA (pause 0) $ (applyE (overBeginning 1 fadeInE) . applyE (overEnding 1 fadeOutE)) . mapA pathify . (\cs -> animChartSvg defaultReanimateConfig (const cs)) . (#hudOptions %~ colourHudOptions light) <$> examples - -examples :: [ChartSvg] -examples = - [ unitExample, - svgOptionsExample, - hudOptionsExample, - rectExample, - textExample, - glyphsExample, - lineExample, - barExample, - waveExample, - lglyphExample, - glinesExample, - compoundExample, - textLocalExample, - labelExample, - legendExample, - surfaceExample, - arcExample, - arcFlagsExample, - ellipseExample, - quadExample, - cubicExample, - pathExample, - vennExample, - arrowExample - ] diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,23 +1,25 @@ cabal-version: 2.4 name: chart-svg -version: 0.2.3 +version: 0.3.0 synopsis: Charting library targetting SVGs. description: This package provides a charting library targetting SVG as the rendered output. . == Usage . - >>> import Chart >>> :set -XOverloadedLabels - >>>let xs = fmap (fmap (uncurry Point)) [[(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)], [(0.0, 0.0), (3.2, 3.0)], [(0.5, 4.0), (0.5, 0)]] :: [[Point Double]] - >>> let anns = zipWith (\w c -> LineA (LineStyle w c Nothing Nothing Nothing Nothing)) [0.015, 0.03, 0.01] palette1_ - >>> let lineExample = mempty & (#chartList .~ zipWith Chart anns (fmap (fmap PointXY) xs)) & #hudOptions .~ defaultHudOptions & #svgOptions .~ defaultSvgOptions :: ChartSvg - . - > writeChartSvg "other/line.svg" lineExample + >>> :set -XOverloadedStrings + >>> import Chart + >>> import Optics.Core + >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] + >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] + >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines + >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartSvg + >>> writeChartSvg "other/usage.svg" lineExample . - ![main example](docs/other/lines.svg) + ![usage example](docs/other/usage.svg) . - See "Chart" for a broad overview of concepts, and "Chart.Examples" for a variety of practical examples. + See "Chart" for a broad overview of concepts, and "Chart.Examples" for practical examples. category: charts homepage: https://github.com/tonyday567/chart-svg#readme @@ -29,7 +31,7 @@ license-file: LICENSE build-type: Simple extra-doc-files: other/*.svg -tested-with: GHC ==8.8.4 || ==8.10.4 || ==9.0.1 || ==9.2.0.20210821 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.1 source-repository head type: git @@ -39,61 +41,44 @@ exposed-modules: Chart Chart.Bar + Chart.Data Chart.Examples - Chart.Reanimate - Chart.Render + Chart.Hud + Chart.Primitive + Chart.Style Chart.Surface - Chart.Types - Chart.Various + Chart.Svg Data.Colour - Data.FormatN Data.Path + Data.Path.Parser hs-source-dirs: src build-depends: - , attoparsec ^>=0.14 - , base >=4.7 && <5 - , Color ^>=0.3 - , containers ^>=0.6 - , cubicbezier ^>=0.6 - , foldl ^>=1.4 - , generic-lens >=1.2 && <3.0 - , JuicyPixels ^>=3.3 - , lens ^>=5.0 - , linear ^>=1.21 - , lucid ^>=2.9 - , mtl ^>=2.2.2 - , numhask ^>=0.8 - , numhask-space ^>=0.8 - , reanimate ^>=1.1.1.0 - , reanimate-svg ^>=0.13 - , scientific ^>=0.3 - , tagsoup ^>=0.14 - , text ^>=1.2 - , time ^>=1.9 - , transformers ^>=0.5 - , unordered-containers ^>=0.2 + , adjunctions ^>=4.4 + , attoparsec >=0.13.2 && <0.15 + , base >=4.7 && <5 + , Color ^>=0.3 + , containers ^>=0.6 + , cubicbezier ^>=0.6 + , foldl ^>=1.4 + , formatn ^>=0.2 + , lucid ^>=2.9 + , mtl ^>=2.2.2 + , neat-interpolation ^>=0.5.1 + , numhask ^>=0.10 + , numhask-array ^>=0.10 + , numhask-space ^>=0.10 + , optics-core ^>=0.4 + , random ^>=1.2.1 + , scientific ^>=0.3 + , tagsoup ^>=0.14 + , text ^>=1.2 + , time ^>=1.9 + , transformers ^>=0.5 default-language: Haskell2010 default-extensions: StrictData ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info - -hiedir=.hie -Wunused-packages - -executable reanimate-example - main-is: reanimate-example.hs - hs-source-dirs: app - build-depends: - , base >=4.7 && <5 - , chart-svg - , lens ^>=5.0 - , reanimate ^>=1.1.1.0 - - default-language: Haskell2010 - default-extensions: - ghc-options: - -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints - -funbox-strict-fields -fwrite-ide-info -hiedir=.hie - -Wunused-packages + -hiedir=.hie diff --git a/other/arc.svg b/other/arc.svg deleted file mode 100644 --- a/other/arc.svg +++ /dev/null @@ -1,145 +0,0 @@ --0.100.10.20.30.40.50.60.70.80.91-0.8-0.6-0.4-0.200.20.40.60.81 diff --git a/other/arcflags.svg b/other/arcflags.svg --- a/other/arcflags.svg +++ b/other/arcflags.svg @@ -1,1201 +1,1240 @@ -SweepTrueFalseFalseTrueLarge +SweepTrueFalseFalseTrueLarge diff --git a/other/arrow.svg b/other/arrow.svg --- a/other/arrow.svg +++ b/other/arrow.svg @@ -1,23 +1,58 @@ --0.5-0.4-0.3-0.2-0.100.10.20.30.40.5-0.5-0.4-0.3-0.2-0.100.10.20.30.40.5 +-0.50-0.40-0.30-0.20-0.10 0.00 0.10 0.20 0.30 0.40 0.50-0.50-0.40-0.30-0.20-0.10 0.00 0.10 0.20 0.30 0.40 0.50 diff --git a/other/bar.svg b/other/bar.svg --- a/other/bar.svg +++ b/other/bar.svg @@ -1,29 +1,53 @@ --4-2024681012row 1row 2row 3row 4row 5row 6row 7row 8row 9row 10123580-2112112345678910column 2column 1 +1.02.03.05.08.00.0-2.0112.01.01.02.03.04.05.06.07.08.09.010-4.0-2.0 0.0 2.0 4.0 6.0 8.010.012.0row 1row 2row 3row 4row 5row 6row 7row 8row 9row 10column 2column 1 diff --git a/other/compound.svg b/other/compound.svg deleted file mode 100644 --- a/other/compound.svg +++ /dev/null @@ -1,5 +0,0 @@ -0,00,10,20,30,40,51,01,11,21,31,41,52,02,12,22,32,42,53,03,13,23,33,43,54,04,14,24,34,44,55,05,15,25,35,45,5 diff --git a/other/cubic.svg b/other/cubic.svg --- a/other/cubic.svg +++ b/other/cubic.svg @@ -1,101 +1,126 @@ - +Bounding BoxPath Control PointPath EndpointsPath ChordPath FillCubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1) diff --git a/other/date.svg b/other/date.svg new file mode 100644 --- /dev/null +++ b/other/date.svg @@ -0,0 +1,53 @@ +06 Dec31 Dec31 Jan28 Feb13 Mar00:0003:0006:0009:0012:0015:0018:0021:0000:00 diff --git a/other/debug.svg b/other/debug.svg new file mode 100644 --- /dev/null +++ b/other/debug.svg @@ -0,0 +1,68 @@ +0.000.501.001.502.002.503.003.504.004.505.000.000.501.001.502.002.503.00Line ChartMade with love and chart-svgpalette1 2palette1 1palette1 00.000.501.001.502.002.503.003.504.004.505.000.000.501.001.502.002.503.00Line ChartMade with love and chart-svgpalette1 2palette1 1palette1 0 diff --git a/other/ellipse.svg b/other/ellipse.svg --- a/other/ellipse.svg +++ b/other/ellipse.svg @@ -1,233 +1,261 @@ --2-1.5-1-0.500.511.5-1.5-1-0.500.511.5 +-2.00-1.50-1.00-0.50 0.00 0.50 1.00 1.50-1.50-1.00-0.50 0.00 0.50 1.00 1.50Bounding BoxEndpointsCentroidArcFull EllipseMinor AxisMajor AxisArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) diff --git a/other/ellipse2.svg b/other/ellipse2.svg new file mode 100644 --- /dev/null +++ b/other/ellipse2.svg @@ -0,0 +1,261 @@ +-2.00-1.50-1.00-0.50 0.00 0.50 1.00 1.50-1.50-1.00-0.50 0.00 0.50 1.00 1.50Bounding BoxEndpointsCentroidArcFull EllipseMinor AxisMajor AxisArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) diff --git a/other/glines.svg b/other/glines.svg deleted file mode 100644 --- a/other/glines.svg +++ /dev/null @@ -1,5 +0,0 @@ - diff --git a/other/glyphs.svg b/other/glyphs.svg --- a/other/glyphs.svg +++ b/other/glyphs.svg @@ -1,3 +1,27 @@ - + diff --git a/other/gradient.svg b/other/gradient.svg new file mode 100644 --- /dev/null +++ b/other/gradient.svg @@ -0,0 +1,25 @@ + diff --git a/other/hudoptions.svg b/other/hudoptions.svg --- a/other/hudoptions.svg +++ b/other/hudoptions.svg @@ -1,45 +1,69 @@ --0.5-0.4-0.3-0.2-0.100.10.20.30.40.5-0.5-0.4-0.3-0.2-0.100.10.20.30.40.5 +-0.50-0.40-0.30-0.20-0.10 0.00 0.10 0.20 0.30 0.40 0.50-0.50-0.40-0.30-0.20-0.10 0.00 0.10 0.20 0.30 0.40 0.50 diff --git a/other/label.svg b/other/label.svg deleted file mode 100644 --- a/other/label.svg +++ /dev/null @@ -1,1 +0,0 @@ -text at (1,1) rotated by -(pi/4) radians diff --git a/other/legend.svg b/other/legend.svg deleted file mode 100644 --- a/other/legend.svg +++ /dev/null @@ -1,46 +0,0 @@ --0.5-0.4-0.3-0.2-0.100.10.20.30.40.5-0.5-0.4-0.3-0.2-0.100.10.20.30.40.5blankabcdefghijklmnopqrstlinetextcontentrectglyph diff --git a/other/lglyph.svg b/other/lglyph.svg deleted file mode 100644 --- a/other/lglyph.svg +++ /dev/null @@ -1,1 +0,0 @@ -0,00,10,20,30,40,51,01,11,21,31,41,52,02,12,22,32,42,53,03,13,23,33,43,54,04,14,24,34,44,55,05,15,25,35,45,5 diff --git a/other/line.svg b/other/line.svg --- a/other/line.svg +++ b/other/line.svg @@ -1,44 +1,65 @@ -An example from chart-svgLine Chart0.00.51.01.52.02.53.03.54.04.55.00.00.51.01.52.02.53.0verticallinehockey +0.000.501.001.502.002.503.003.504.004.505.000.000.501.001.502.002.503.00 diff --git a/other/path.svg b/other/path.svg --- a/other/path.svg +++ b/other/path.svg @@ -1,35 +1,68 @@ -00.20.40.60.811.21.41.6-0.4-0.200.20.40.60.81 +StartP (Point 0 0)LineP (Point 1 0)CubicP (Point 0.2 0) (Point 0.25 1) (Point 1 1)QuadP (Point (-1) 2) (Point 0 1)ArcP (ArcInfo (Point 1 1) (-pi / 6) False False) (Point 0 0)0.000.200.400.600.801.001.201.401.60-0.40-0.20 0.00 0.20 0.40 0.60 0.80 1.00 diff --git a/other/quad.svg b/other/quad.svg --- a/other/quad.svg +++ b/other/quad.svg @@ -1,145 +1,170 @@ --1-0.8-0.6-0.4-0.200.20.40.60.8100.20.40.60.811.21.41.61.82 +-1.00-0.80-0.60-0.40-0.20 0.00 0.20 0.40 0.60 0.80 1.000.000.200.400.600.801.001.201.401.601.802.00Bounding BoxPath Control PointPath EndpointsPath ChordPath FillQuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1)) diff --git a/other/rect.svg b/other/rect.svg --- a/other/rect.svg +++ b/other/rect.svg @@ -1,23 +1,36 @@ --5-4-3-2-1012345 +-5.0-4.0-3.0-2.0-1.0 0.0 1.0 2.0 3.0 4.0 5.0 diff --git a/other/surface.svg b/other/surface.svg # file too large to diff: other/surface.svg diff --git a/other/svgoptions.svg b/other/svgoptions.svg deleted file mode 100644 --- a/other/svgoptions.svg +++ /dev/null @@ -1,5 +0,0 @@ - diff --git a/other/text.svg b/other/text.svg --- a/other/text.svg +++ b/other/text.svg @@ -1,1 +1,68 @@ -abcdefghijklmnopqrstuvwxy +abcdefghijklmnopqrstuvwxyz 0.0 5.010.015.020.025.00.000.100.200.300.400.500.600.700.800.901.00 diff --git a/other/textlocal.svg b/other/textlocal.svg deleted file mode 100644 --- a/other/textlocal.svg +++ /dev/null @@ -1,1 +0,0 @@ -a pretty long piece of textanother pretty long piece of text diff --git a/other/unit.svg b/other/unit.svg --- a/other/unit.svg +++ b/other/unit.svg @@ -1,1 +1,69 @@ - +-0.50-0.40-0.30-0.20-0.10 0.00 0.10 0.20 0.30 0.40 0.50-0.50-0.40-0.30-0.20-0.10 0.00 0.10 0.20 0.30 0.40 0.50 diff --git a/other/usage.svg b/other/usage.svg new file mode 100644 --- /dev/null +++ b/other/usage.svg @@ -0,0 +1,65 @@ +0.000.501.001.502.002.503.003.504.004.505.000.000.501.001.502.002.503.00 diff --git a/other/venn.svg b/other/venn.svg --- a/other/venn.svg +++ b/other/venn.svg @@ -1,29 +1,53 @@ --1.5-1-0.500.511.5-1.5-1-0.500.511.5 +-1.50-1.00-0.50 0.00 0.50 1.00 1.50-1.50-1.00-0.50 0.00 0.50 1.00 1.50 diff --git a/other/wave.svg b/other/wave.svg --- a/other/wave.svg +++ b/other/wave.svg @@ -1,1 +1,63 @@ - +-1.00-0.80-0.60-0.40-0.20 0.00 0.20 0.40 0.60 0.80 1.000.01.02.03.04.05.06.07.0 diff --git a/other/wheel.svg b/other/wheel.svg new file mode 100644 --- /dev/null +++ b/other/wheel.svg @@ -0,0 +1,63 @@ +-0.300-0.250-0.200-0.150-0.100-0.050 0.000 0.050 0.100 0.150-0.150-0.100-0.050 0.000 0.050 0.100 0.150 0.200 0.250 diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK prune #-} --- | A haskell Charting library targetting SVGs +-- | A haskell Charting library targetting SVG. module Chart ( -- * Usage @@ -13,206 +13,122 @@ -- -- $overview - -- * Chart - Chart (..), - moveChart, - projectXYs, - projectXYsWith, - projectArcPosition, - - -- * Annotation - Annotation (..), - annotationText, - scaleAnn, - scaleOpacAnn, - colourAnn, - padRect, - - -- * Styles - RectStyle (..), - defaultRectStyle, - blob, - clear, - border, - TextStyle (..), - defaultTextStyle, - GlyphStyle (..), - defaultGlyphStyle, - GlyphShape (..), - glyphText, - LineStyle (..), - defaultLineStyle, - LineCap (..), - fromLineCap, - toLineCap, - LineJoin (..), - fromLineJoin, - toLineJoin, - fromDashArray, - Anchor (..), - fromAnchor, - toAnchor, - PathStyle (..), - toPathChart, - defaultPathStyle, - - -- * Hud types - ChartDims (..), - HudT (..), - Hud, - simulHud, - HudOptions (..), - defaultHudOptions, - scaleOpacHudOptions, - colourHudOptions, - defaultCanvas, - runHudWith, - runHud, - makeHud, - ChartAspect (..), - toChartAspect, - fromChartAspect, - initialCanvas, - chartAspectHud, - canvas, - title, - tick, - - -- * Hud primitives - AxisOptions (..), - defaultAxisOptions, - flipAxis, - Place (..), - placeText, - AxisBar (..), - defaultAxisBar, - Title (..), - defaultTitle, - Tick (..), - defaultGlyphTick, - defaultTextTick, - defaultLineTick, - defaultTick, - TickStyle (..), - defaultTickStyle, - tickStyleText, - TickExtend (..), - adjustTick, - makeTickDates, - makeTickDatesContinuous, - Adjustments (..), - defaultAdjustments, - LegendOptions (..), - defaultLegendOptions, - legendHud, - Orientation (..), - fromOrientation, - toOrientation, + -- * Hud - -- * SVG primitives - CssOptions (..), - SvgOptions (..), - defaultSvgOptions, - defaultSvgFrame, + -- + -- $hud - -- * Chart manipulation - padChart, - frameChart, - hori, - vert, - stack, + -- * Optics Usage - -- * Bounding box calculation - padBox, - dataBox, - dataBoxes, - dataBoxesS, - styleBox, - styleBoxes, - styleBoxesS, - styleBoxText, - styleBoxGlyph, + -- + -- $optics -- * Re-exports - module Chart.Render, + module Chart.Primitive, + module Chart.Data, + module Chart.Hud, + module Chart.Style, + module Chart.Svg, module Chart.Bar, module Chart.Surface, module Data.Colour, module Data.FormatN, module Data.Path, - module NumHask.Space, + module Data.Path.Parser, ) where import Chart.Bar -import Chart.Render +import Chart.Data +import Chart.Hud +import Chart.Primitive +import Chart.Style import Chart.Surface -import Chart.Types +import Chart.Svg import Data.Colour import Data.FormatN import Data.Path -import NumHask.Space +import Data.Path.Parser -- $setup -- -- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings -- >>> import Chart --- >>> import Control.Lens +-- >>> import Optics.Core +-- $usage +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core +-- >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] +-- >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] +-- >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines +-- >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartSvg +-- >>> writeChartSvg "other/usage.svg" lineExample + -- $overview -- --- Charting consists of three highly-coupled conceptual layers: +-- Charting consists of three tightly-coupled domains: -- --- 1. the data to be represented. --- 2. how the data will be represented on a screen, and. --- 3. the creation of visual aids that help interpret the data; such as axes, gridlines and titles. +-- 1. /data domain/: the data to be represented. +-- 2. /screen syntax/: the syntactics of the data. How and where data is to be represented on a screen (or page), and. +-- 3. /the hud/: visual aids that help interpret the screened data; such as axes, gridlines and titles. -- -- == What is a 'Chart'? -- --- A 'Chart' in this library consists of a specification of the first two items in the above list; data and data annotation. --- --- - 'XY': a list of values, specified as either 2D points or rectangles. --- --- - 'Annotation': a description of how the data should be represented on the screen. --- --- >>> :t Chart --- Chart :: Annotation -> [XY a] -> Chart a --- --- What exactly is annotation and what is data is highly variant within charting practice. This construction treats position on the XY plane differently from other quantitative manifests such as color and size. The chief advantage of priveliging XY position is that scaling and integrating data with other chart elements becomes much easier. The disadvantage is that, to use quantitative tools such as size, data needs to be consciously separated into that which is position-orientated, and that which is defined as 'Annotation'. --- +-- A 'Chart' in this library consists of a specification of the first two items in the above list; data and its syntax. -- --- Here's some data; three lists of points that will form a line: +-- Here's some data; three lists of points that form lines to be charted: -- --- >>> let xs = fmap (fmap (uncurry Point)) [[(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)], [(0.0, 0.0), (3.2, 3.0)], [(0.5, 4.0), (0.5, 0)]] :: [[Point Double]] +-- >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] -- --- and an Annotation to describe representation of this data; three line styles with different colors and widths: +-- and some line styles with different colors in order to distinguish the data: -- --- >>> let anns = zipWith (\w c -> LineA (LineStyle w c Nothing Nothing Nothing Nothing)) [0.015, 0.03, 0.01] palette1_ +-- >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] +-- >>> styles +-- [LineStyle {size = 1.5e-2, color = Colour 0.02 0.73 0.80 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},LineStyle {size = 1.5e-2, color = Colour 0.02 0.29 0.48 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},LineStyle {size = 1.5e-2, color = Colour 0.66 0.07 0.55 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing}] -- --- and this is enough to create a Chart. +-- This is enough to create the charts. -- --- >>> let lineExample = mempty & (#chartList .~ zipWith Chart anns (fmap (fmap PointXY) xs)) & #hudOptions .~ defaultHudOptions & #svgOptions .~ defaultSvgOptions :: ChartSvg +-- >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines +-- >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartSvg -- >>> :t lineExample -- lineExample :: ChartSvg -- --- > writeChartSvg "other/line.svg" lineExample +-- > writeChartSvg "other/usage.svg" lineExample -- --- ![lines example](other/line.svg) +-- ![usage example](other/usage.svg) -- $hud -- --- Axes, titles, tick marks, grid lines and legends are chart elements that exist to provide references for the viewer that helps explain the data that is being represented by the chart. They can be clearly distinguished from data representations such as a mark where a value is. +-- Axes, titles, tick marks, grid lines and legends are chart elements that exist to provide references to help explain the data being represented. The collective noun used by the library for these elements is /hud/. Hud elements can usually be distinguished from data syntax, but need information from the chart domain (data domain and style domain) to function. A tick mark and tick value on an axis need to know the range of the data to be placed properly on the screen. A chart border needs to know the syntactic range of the entire data representation inclusive of representational artifacts that might extend beyond the data domain (A circle glyph representing a point has dimension). -- --- Apart from this, hud elements are pretty much the same as data elements. They simulateously have two reference frames: a data domain (tick values reference the data value range) and a page domain (a title needs to be placed on the left say, and has a size of 0.1 versus the page size). They are also typically composed of the same sorts of primitives as data elements, such as rectangles and lines and text and colors. +-- Apart from this functional usage, however, hud elements are pretty much the same as data elements. They are typically composed of the same stuff; rectangles and lines and text and colors. -- --- Given this similarity, an efficient process for chart creation is roughly: +-- Given this similarity, the library process for chart creation is roughly: -- --- - collect the chart data and data annotations into a [Chart Double] +-- - collect the chart data and syntax (or style) into a collection of charts (a list or a tree). See 'Chart' and 'ChartTree' -- -- - measure the range of the data values -- --- - begin a process of folding a [Hud Double] in with the charts, supplying the the data values to the hud elements if needed, and keeping track of the overall page size of the chart. +-- - fold hud elements into a chart, /creating new 'ChartTree' from the hud/, keeping track of chart dimensions across three domains: -- --- This process is encapsulated in 'runHud'. +-- - The domain of the underlying data -- --- An important quality of 'runHud' (and conversion of charts to svg in general)is that this is the point at which the 'XY's of the chart are converted from the data domain to the page domain. Once the hud and the chart has been integrated there is no going back and the original data is forgotten. This is an opinionated aspect of chart-svg. A counter-example is d3 which stores the raw data in the svg element it represents. +-- - The domain of the canvas where the data is being represented +-- +-- - The domain of the chart, inclusive of Hud or decorative elements. +-- +-- This process is reified in 'runHudWith'. The most common Hud concepts, such as axes and titles, have been collected into the 'HudOptions' type. +-- +-- An important quality of 'runHud' (and conversion of charts to svg in general) is that this is the point at which chart data is converted from the data domain to the page domain. +-- + +-- $optics +-- +-- Usage suggests the use of optics-core and OverloadedLabels, but this is not required. 'Chart', 'HudOptions' and associated chart configuration types are big and sometimes deep syntax trees, and simple optics getting, setting and modding makes manipulation more pleasant. Lens works as well, and the library is perfectly capable of being used with records. +-- +-- Lenses are supplied, for the optics-core library, but can be easily modified for lens. The chart-svg convention is that lenses are either OverloadedLabels, or suffixed with a single quote /'/. diff --git a/src/Chart/Bar.hs b/src/Chart/Bar.hs --- a/src/Chart/Bar.hs +++ b/src/Chart/Bar.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} --- | bar charts +-- | Bar charts module Chart.Bar ( BarOptions (..), defaultBarOptions, @@ -19,34 +17,33 @@ ) where -import Chart.Render -import Chart.Types -import Control.Lens -import Data.Bifunctor +import Chart.Data +import Chart.Hud +import Chart.Primitive +import Chart.Style +import Chart.Svg import Data.Bool import Data.Colour +import Data.Foldable import Data.FormatN -import Data.Generics.Labels () import Data.List (scanl', transpose) -import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import Data.Text (Text, pack) import GHC.Generics -import GHC.OverloadedLabels -import NumHask.Prelude -import NumHask.Space +import Optics.Core +import Prelude hiding (abs) -- $setup -- -- >>> :set -XOverloadedLabels -- >>> :set -XOverloadedStrings -- >>> import Chart --- >>> import Control.Lens +-- >>> import Optics.Core -- >>> import Data.Text (pack) -- | Typical bar chart options. -- --- >>> let barDataExample = BarData [[1, 2, 3, 5, 8, 0, -2, 11, 2, 1], [1 .. 10]] (Just (("row " <>) . pack . show <$> [1 .. 11])) (Just (("column " <>) . pack . show <$> [1 .. 2])) +-- >>> let barDataExample = BarData [[1, 2, 3, 5, 8, 0, -2, 11, 2, 1], [1 .. 10]] (("row " <>) . pack . show <$> [1 .. 11]) (("column " <>) . pack . show <$> [1 .. 2]) -- >>> let barExample = barChart defaultBarOptions barDataExample -- -- > writeChartSvg "other/bar.svg" barExample @@ -63,10 +60,43 @@ valueFormatN :: FormatN, accumulateValues :: Bool, barOrientation :: Orientation, - barHudOptions :: HudOptions + barLegendOptions :: LegendOptions } deriving (Show, Eq, Generic) +-- | A bar chart. +-- +-- >>> emptyBar = barChart defaultBarOptions (BarData [] [] []) +-- >>> foldOf (#charts % charts') emptyBar +-- [] +barChart :: BarOptions -> BarData -> ChartSvg +barChart bo bd = + mempty + & set #hudOptions (barHudOptions bo bd) + & set + #charts + ( named + "barchart" + ( bars bo bd + <> bool [] (barTextCharts bo bd) (view #displayValues bo) + ) + ) + +barHudOptions :: BarOptions -> BarData -> HudOptions +barHudOptions bo bd = + mempty + & #axes + .~ [ (1, axis1), + (1, axis2) + ] + & #legends + .~ [ (10, o & #content .~ barLegendContent bo bd) + ] + where + o = view #barLegendOptions bo + axis1 = bool id flipAxis (barOrientation bo == Vert) (defaultAxisOptions & #ticks % #ltick .~ Nothing & #ticks % #style .~ barTicks bd) + axis2 = bool id flipAxis (barOrientation bo == Hori) defaultAxisOptions + -- | The official bar options. defaultBarOptions :: BarOptions defaultBarOptions = @@ -78,49 +108,30 @@ 0.04 0.1 True - (FormatComma (Just 2)) + (FormatN FSCommaPrec (Just 2) True) False Hori - ( defaultHudOptions - & #hudAxes - .~ [ defaultAxisOptions - & #axisTick . #ltick .~ Nothing, - defaultAxisOptions & #place .~ PlaceLeft - ] - & #hudTitles .~ [] - & #hudLegend - ?~ ( defaultLegendOptions - & #lplace .~ PlaceRight - & #lsize .~ 0.12 - & #vgap .~ 0.4 - & #hgap .~ 0.14 - & #ltext . #size .~ 0.12 - & #lscale .~ 0.4, - [] - ) - ) + defaultLegendOptions where - gs = (\x -> RectStyle 0.002 x x) <$> palette1_ - ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04) <$> palette1_ + gs = (\x -> RectStyle 0.005 (palette1 x) (palette1a x 0.7)) <$> [1, 2, 6, 7, 5, 3, 4, 0] + ts = (\x -> defaultTextStyle & #color .~ palette1 x & #size .~ 0.24) <$> [1, 2, 6, 7, 5, 3, 4, 0] --- | imagine a dataframe you get in other languages: --- --- - definitely some [[Double]] --- --- - maybe some row names +-- | Two dimensional data, maybe with row and column labels. -- --- - maybe some column names data BarData = BarData { barData :: [[Double]], - barRowLabels :: Maybe [Text], - barColumnLabels :: Maybe [Text] + barRowLabels :: [Text], + barColumnLabels :: [Text] } deriving (Show, Eq, Generic) --- | Convert BarData to rectangles +-- | Convert BarData to Rects -- -- >>> barRects defaultBarOptions [[1,2],[2,3]] -- [[Rect 5.0e-2 0.45 0.0 1.0,Rect 1.05 1.4500000000000002 0.0 2.0],[Rect 0.45 0.8500000000000001 0.0 2.0,Rect 1.4500000000000002 1.85 0.0 3.0]] +-- +-- >>> barRects defaultBarOptions [[]] +-- [[]] barRects :: BarOptions -> [[Double]] -> @@ -148,83 +159,77 @@ bstep = (1 - (1 + 1) * ogap + (n - 1) * igap') / n igap' = igap * (1 - (1 + 1) * ogap) --- | convert data to a range assuming a zero bound --- a very common but implicit assumption in a lot of bar charts +-- | Convert data to a range assuming a zero bound (a very common but implicit assumption in a lot of bar charts) -- -- >>> barDataLowerUpper False [[1,2],[2,3]] -- [[(0.0,1.0),(0.0,2.0)],[(0.0,2.0),(0.0,3.0)]] barDataLowerUpper :: Bool -> [[Double]] -> [[(Double, Double)]] barDataLowerUpper add bs = case add of - False -> fmap (0,) <$> bs - True -> fmap (0,) <$> accRows bs + False -> fmap (fmap (0,)) bs + True -> fmap (fmap (0,)) (accRows bs) --- | calculate the Rect range of a bar data set. +-- | Calculate the Rect range of a bar data set. -- -- >>> barRange [[1,2],[2,3]] -- Rect 0.0 2.0 0.0 3.0 +-- +-- >>> barRange [[]] +-- Rect -0.5 0.5 -0.5 0.5 barRange :: [[Double]] -> Rect Double -barRange [] = Rect 0 0 0 0 -barRange ys'@(y : ys) = Rect 0 (fromIntegral $ maximum (length <$> ys')) (min 0 l) u +barRange ys = singletonGuard $ Just $ Rect 0 (fromIntegral $ maximum (length <$> ys)) (min 0 l) u where - (Range l u) = sconcat $ space1 <$> (y NonEmpty.:| ys) + (Range l u) = fromMaybe one $ space1 $ mconcat ys -- | A bar chart without hud trimmings. -- --- >>> bars defaultBarOptions (BarData [[1,2],[2,3]] Nothing Nothing) --- [Chart {annotation = RectA (RectStyle {borderSize = 2.0e-3, borderColor = Colour 0.69 0.35 0.16 1.00, color = Colour 0.69 0.35 0.16 1.00}), xys = [R 5.0e-2 0.45 0.0 1.0,R 1.05 1.4500000000000002 0.0 2.0]},Chart {annotation = RectA (RectStyle {borderSize = 2.0e-3, borderColor = Colour 0.65 0.81 0.89 1.00, color = Colour 0.65 0.81 0.89 1.00}), xys = [R 0.45 0.8500000000000001 0.0 2.0,R 1.4500000000000002 1.85 0.0 3.0]},Chart {annotation = BlankA, xys = [R -5.0e-2 1.9500000000000002 0.0 3.0]}] -bars :: BarOptions -> BarData -> [Chart Double] -bars bo bd = - zipWith (\o d -> Chart (RectA o) d) (bo ^. #barRectStyles) (fmap RectXY <$> barRects bo (bd ^. #barData)) <> [Chart BlankA [RectXY (Rect (x - (bo ^. #outerGap)) (z + (bo ^. #outerGap)) y w)]] +-- >>> bars defaultBarOptions (BarData [[1,2],[2,3]] [] []) +-- [RectChart (RectStyle {borderSize = 5.0e-3, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.29 0.48 0.70}) [Rect 5.0e-2 0.45 0.0 1.0,Rect 1.05 1.4500000000000002 0.0 2.0],RectChart (RectStyle {borderSize = 5.0e-3, borderColor = Colour 0.66 0.07 0.55 1.00, color = Colour 0.66 0.07 0.55 0.70}) [Rect 0.45 0.8500000000000001 0.0 2.0,Rect 1.4500000000000002 1.85 0.0 3.0],BlankChart [Rect -5.0e-2 1.9500000000000002 0.0 3.0]] +-- +-- >>> bars defaultBarOptions (BarData [[]] [] []) +-- [] +bars :: BarOptions -> BarData -> [Chart] +bars bo bd = bool cs [] (null $ mconcat $ view #barData bd) where - (Rect x z y w) = fromMaybe one $ foldRect $ catMaybes $ foldRect <$> barRects bo (bd ^. #barData) + cs = zipWith (\o d -> RectChart o d) (bo ^. #barRectStyles <> repeat defaultRectStyle) (barRects bo (bd ^. #barData)) <> [BlankChart [Rect (x - (bo ^. #outerGap)) (z + (bo ^. #outerGap)) y w]] + (Rect x z y w) = fromMaybe one $ foldRect $ mconcat $ barRects bo (bd ^. #barData) maxRows :: [[Double]] -> Int -maxRows [] = 0 maxRows xs = maximum $ length <$> xs appendZero :: [[Double]] -> [[Double]] -appendZero xs = (\x -> take (maxRows xs) (x <> repeat 0)) <$> xs +appendZero xs = + ( \x -> + take + (maxRows xs) + (x <> repeat 0) + ) + <$> xs accRows :: [[Double]] -> [[Double]] -accRows xs = transpose $ drop 1 . scanl' (+) 0 <$> transpose xs +accRows xs = transpose $ drop 1 . scanl' (+) 0 <$> transpose (fmap toList $ toList xs) --- | sensible ticks +-- | Sensible ticks for a bar chart. barTicks :: BarData -> TickStyle barTicks bd | null (bd ^. #barData) = TickNone - | isNothing (bd ^. #barRowLabels) = + | null (bd ^. #barRowLabels) = TickLabels $ pack . show <$> [0 .. (maxRows (bd ^. #barData) - 1)] | otherwise = TickLabels $ take (maxRows (bd ^. #barData)) $ - fromMaybe [] (bd ^. #barRowLabels) <> repeat "" - -tickFirstAxis :: BarData -> [AxisOptions] -> [AxisOptions] -tickFirstAxis _ [] = [] -tickFirstAxis bd (x : xs) = (x & #axisTick . #tstyle .~ barTicks bd) : xs + (bd ^. #barRowLabels) <> repeat "" --- | bar legend -barLegend :: BarData -> BarOptions -> [(Annotation, Text)] -barLegend bd bo +-- | A bar legend +barLegendContent :: BarOptions -> BarData -> [(Text, Chart)] +barLegendContent bo bd | null (bd ^. #barData) = [] - | isNothing (bd ^. #barColumnLabels) = [] - | otherwise = zip (RectA <$> bo ^. #barRectStyles) $ take (length (bd ^. #barData)) $ fromMaybe [] (bd ^. #barColumnLabels) <> repeat "" - --- | A bar chart. --- --- By convention only, the first axis (if any) is the bar axis. -barChart :: BarOptions -> BarData -> ChartSvg -barChart bo bd = - mempty - & #hudOptions .~ bo ^. #barHudOptions - & #hudOptions . #hudLegend %~ fmap (second (const (barLegend bd bo))) - & #hudOptions . #hudAxes %~ tickFirstAxis bd . flipAllAxes (barOrientation bo) - & #chartList .~ bars bo bd <> bool [] (barTextCharts bo bd) (bo ^. #displayValues) - -flipAllAxes :: Orientation -> [AxisOptions] -> [AxisOptions] -flipAllAxes o = fmap (bool id flipAxis (o == Vert)) + | null (bd ^. #barColumnLabels) = [] + | otherwise = + zip + (view #barColumnLabels bd <> repeat "") + ((\s -> RectChart s [one]) <$> take (length (view #barData bd)) (bo ^. #barRectStyles)) barDataTP :: Bool -> FormatN -> Double -> Double -> [[Double]] -> [[(Text, Double)]] barDataTP add fn d negd bs = @@ -234,12 +239,13 @@ bs' = appendZero bs (Rect _ _ y w) = barRange bs' --- | Convert BarData to text +-- | Convert BarData to text placed above (or below) the bars. barTexts :: BarOptions -> [[Double]] -> [[(Text, Point Double)]] -barTexts (BarOptions _ _ ogap igap tgap tgapneg _ fn add orient _) bs = zipWith zip (fmap fst <$> barDataTP add fn tgap tgapneg bs') (txs'' orient) +barTexts (BarOptions _ _ ogap igap tgap tgapneg _ fn add orient _) bs = + zipWith zip (fmap fst <$> barDataTP add fn tgap tgapneg bs') (txs'' orient) where bs' = bool bs (appendZero bs) add txs'' Hori = txs' @@ -258,7 +264,7 @@ bstep = (1 - (1 + 1) * ogap + (n - 1) * igap') / n igap' = igap * (1 - (1 + 1) * ogap) --- | text, hold the bars -barTextCharts :: BarOptions -> BarData -> [Chart Double] +-- | Placed text, hold the bars. +barTextCharts :: BarOptions -> BarData -> [Chart] barTextCharts bo bd = - zipWith (\o d -> Chart (TextA o (fst <$> d)) (PointXY . snd <$> d)) (bo ^. #barTextStyles) (barTexts bo (bd ^. #barData)) + zipWith TextChart (bo ^. #barTextStyles <> repeat defaultTextStyle) (barTexts bo (bd ^. #barData)) diff --git a/src/Chart/Data.hs b/src/Chart/Data.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Data.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK prune #-} + +-- | Data primitives and utilities +-- +-- Whilst the library makes use of , it does not re-export, to avoid clashes with Prelude, with the exception of 'zero', 'one', 'angle', 'norm' & 'abs'. +-- +-- 'Rect' and 'Point', from , make up the base elements of many chart primitives, and all of numhask-space is re-exported. +-- +module Chart.Data + ( -- * Data Primitives + Rect (..), + padRect, + padSingletons, + singletonGuard, + Point (..), + addp, + + -- * NumHask Exports + -- + -- | Note that (+) and (*) from numhask are not actually re-exported. + Multiplicative (one), + Additive (zero), + Direction (..), + Norm (..), + Signed (..), + + -- * Re-exports + module NumHask.Space, + ) +where + +import NumHask.Prelude +import NumHask.Space + +-- | Additive pad (or frame or buffer) a Rect. +-- +-- >>> padRect 1 one +-- Rect -1.5 1.5 -1.5 1.5 +padRect :: (Subtractive a) => a -> Rect a -> Rect a +padRect p (Rect x z y w) = Rect (x - p) (z + p) (y - p) (w + p) + +-- | Pad a Rect to remove singleton dimensions. +-- +-- Attempting to scale a singleton dimension of a Rect is a common bug. +-- +-- Due to the use of scaling, and thus zero dividing, this is a common exception to guard against. +-- +-- >>> project (Rect 0 0 0 1) one (Point 0 0) +-- Point NaN -0.5 +-- +-- >>> project (padSingletons (Rect 0 0 0 1)) one (Point 0 0) +-- Point 0.0 -0.5 +padSingletons :: Rect Double -> Rect Double +padSingletons (Rect x z y w) + | x == z && y == w = Rect (x - 0.5) (x + 0.5) (y - 0.5) (y + 0.5) + | x == z = Rect (x - 0.5) (x + 0.5) y w + | y == w = Rect x z (y - 0.5) (y + 0.5) + | otherwise = Rect x z y w + +-- | Guard against an upstream Nothing or a singleton dimension +singletonGuard :: Maybe (Rect Double) -> Rect Double +singletonGuard = maybe one padSingletons + +-- | add Points, dimension-wise +-- +-- >>> Point 1 1 `addp` Point 0 2 +-- Point 1.0 3.0 +addp :: Point Double -> Point Double -> Point Double +addp = (+) diff --git a/src/Chart/Examples.hs b/src/Chart/Examples.hs --- a/src/Chart/Examples.hs +++ b/src/Chart/Examples.hs @@ -1,76 +1,72 @@ -{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Examples of chart construction. module Chart.Examples - ( unitExample, - svgOptionsExample, + ( + -- * Unit & Hud + unitExample, hudOptionsExample, + + -- * Iconic primitives. + lineExample, rectExample, textExample, glyphsExample, - lineExample, + pathExample, + + -- * Compounds barExample, waveExample, - lglyphExample, - glinesExample, - compoundExample, - textLocalExample, - labelExample, - legendExample, surfaceExample, rosenbrock, - arcExample, arcFlagsExample, ellipseExample, quadExample, cubicExample, - pathExample, vennExample, arrowExample, + dateExample, + + -- * Colour + gradientExample, + wheelExample, + + -- * Debugging + debugExample, writeAllExamples, + writeAllExamplesDark, ) where import Chart -import Control.Lens +import Data.Bifunctor +import Data.Bool +import Data.Function import Data.Text (Text, pack) import qualified Data.Text as Text -import GHC.OverloadedLabels -import NumHask.Prelude hiding (lines) - --- $setup --- >>> import Chart --- >>> import Control.Lens +import Data.Time +import NeatInterpolation +import Optics.Core +import Prelude hiding (abs) -- | unit example -- -- ![unit example](other/unit.svg) unitExample :: ChartSvg -unitExample = mempty & #chartList .~ [Chart (RectA defaultRectStyle) [one]] +unitExample = mempty & #charts .~ named "unit" [RectChart defaultRectStyle [one]] & #hudOptions .~ defaultHudOptions --- | 'HudOptions' example +-- | A 'BlankChart', 'defaultHudOptions' example. -- -- ![hudoptions example](other/hudoptions.svg) hudOptionsExample :: ChartSvg hudOptionsExample = mempty - & #hudOptions .~ colourHudOptions dark defaultHudOptions - & #chartList .~ [Chart BlankA [one]] - --- | 'SvgOptions' example. --- --- ![svgoptions example](other/svgoptions.svg) -svgOptionsExample :: ChartSvg -svgOptionsExample = - mempty - & #svgOptions %~ #chartAspect .~ FixedAspect 0.7 - & #chartList .~ zipWith (\s d -> Chart (LineA s) (fmap PointXY d)) lopts ls + & #hudOptions .~ colourHudOptions (rgb dark) defaultHudOptions + & #charts .~ blank one -- | rect example -- @@ -78,151 +74,155 @@ rectExample :: ChartSvg rectExample = mempty - & #hudOptions .~ (defaultHudOptions & #hudAxes .~ [defaultAxisOptions]) - & #chartList .~ zipWith Chart (RectA <$> ropts) (fmap RectXY <$> rss) + & #hudOptions + .~ ( mempty + & set + #axes + [(1, defaultAxisOptions & #ticks % #ltick .~ Nothing)] + ) + & #charts .~ named "rect" (zipWith RectChart ropts rss) rss :: [[Rect Double]] rss = - [ gridR (\x -> exp (-(x ** 2) / 2)) (Range -5 5) 50, - gridR (\x -> 0.5 * exp (-(x ** 2) / 8)) (Range -5 5) 50 + [ gridR (\x -> exp (-x ** 2 / 2)) (Range (-5) 5) 50, + gridR (\x -> 0.5 * exp (-x ** 2 / 8)) (Range (-5) 5) 50 ] ropts :: [RectStyle] ropts = - [ blob (palette1 1), - blob (palette1 2) + [ blob (palette1a 1 0.4), + blob (palette1a 2 0.4) ] -- | line example -- --- Example in cabal file --- --- This 'lineExample' provides a bit more detail for testing huds. --- --- Simplified example: --- --- >>> :set -XOverloadedLabels --- >>> import Chart --- >>> let xs = fmap (fmap (uncurry Point)) [[(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)], [(0.0, 0.0), (3.2, 3.0)], [(0.5, 4.0), (0.5, 0)]] :: [[Point Double]] --- >>> xs --- [[Point 0.0 1.0,Point 1.0 1.0,Point 2.0 5.0],[Point 0.0 0.0,Point 3.2 3.0],[Point 0.5 4.0,Point 0.5 0.0]] --- --- >>> let anns = zipWith (\w c -> LineA (defaultLineStyle & #width .~ w & #color .~ c)) [0.015, 0.03, 0.01] palette1_ --- >>> anns --- [LineA (LineStyle {width = 1.5e-2, color = Colour 0.69 0.35 0.16 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing}),LineA (LineStyle {width = 3.0e-2, color = Colour 0.65 0.81 0.89 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing}),LineA (LineStyle {width = 1.0e-2, color = Colour 0.12 0.47 0.71 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing})] --- --- >>> let lineExample = mempty & (#chartList .~ zipWith Chart anns (fmap (fmap PointXY) xs)) & #hudOptions .~ defaultHudOptions & #svgOptions .~ defaultSvgOptions :: ChartSvg --- >>> :t lineExample --- lineExample :: ChartSvg --- --- > writeChartSvg "other/line.svg" lineExample --- -- ![line example](other/line.svg) lineExample :: ChartSvg lineExample = - mempty - & #svgOptions . #chartAspect - .~ CanvasAspect 1.5 - & #hudOptions - .~ exampleLineHudOptions - "Line Chart" - (Just "An example from chart-svg") - (Just (defaultLegendOptions, zip (LineA <$> lopts) ["hockey", "line", "vertical"])) - & #chartList - .~ zipWith (\s d -> Chart (LineA s) (fmap PointXY d)) lopts ls - -ls :: [[Point Double]] -ls = - fmap (uncurry Point) - <$> [ [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)], - [(0.0, 0.0), (2.8, 3.0)], - [(0.5, 4.0), (0.5, 0)] - ] - -lopts :: [LineStyle] -lopts = - [ defaultLineStyle & #color .~ palette1 0 & #width .~ 0.015, - defaultLineStyle & #color .~ palette1 1 & #width .~ 0.03, - defaultLineStyle & #color .~ palette1 2 & #width .~ 0.01 - ] - -exampleLineHudOptions :: Text -> Maybe Text -> Maybe (LegendOptions, [(Annotation, Text)]) -> HudOptions -exampleLineHudOptions t1 t2 legends' = - defaultHudOptions - & #hudTitles - .~ ( [ defaultTitle t1 - & #style . #size .~ 0.08 - ] - <> foldMap - ( \x -> - [ defaultTitle x - & #style . #size .~ 0.05 - & #place .~ PlaceBottom - & #anchor .~ AnchorEnd - ] - ) - t2 - ) - & #hudLegend .~ legends' - & #hudAxes %~ fmap (#axisTick . #tstyle .~ TickRound (FormatFixed (Just 1)) 8 TickExtend) + mempty & set #hudOptions ho & #charts .~ named "line" cs + where + ho = + defaultHudOptions + & set + #titles + [ (6, defaultTitle "Line Chart" & set (#style % #size) 0.1), + ( 11, + defaultTitle "Made with love and chart-svg" + & set (#style % #size) 0.06 + & set #place PlaceBottom + & set #anchor AnchorEnd + ) + ] + & over #frames (<> [(20, defaultFrameOptions & #buffer .~ 0.04)]) + & set + #legends + [ ( 12, + defaultLegendOptions + & over #frame (fmap (set #color white)) + & set #place (PlaceAbsolute (Point 0.45 (-0.35))) + & set (#textStyle % #size) 0.20 + & set #content (zip ["palette1 0", "palette1 1", "palette1 2"] cs) + ) + ] + cs = + zipWith + ( \c l -> + LineChart + ( defaultLineStyle + & set #color (palette1 c) + & set #size 0.015 + ) + [l] + ) + [0 ..] + ls + ls = + [ [Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0], + [Point 0.0 0.0, Point 2.8 3.0], + [Point 0.5 4.0, Point 0.5 0] + ] -- | text example -- -- ![text example](other/text.svg) textExample :: ChartSvg textExample = - mempty & #chartList - .~ zipWith - Chart - (TextA (defaultTextStyle & (#color .~ dark) & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) - ((: []) . PointXY . snd <$> ts) + mempty + & #charts + .~ named + "text" + [ TextChart + (defaultTextStyle & #color .~ dark & #size .~ 0.05 & #vshift .~ 0) + ts + ] + & #hudOptions .~ defaultHudOptions + & #svgOptions % #cssOptions % #preferColorScheme .~ PreferHud + & #svgOptions % #cssOptions % #cssExtra .~ textSwitch (light, dark) where ts :: [(Text, Point Double)] ts = zip - (fmap Text.singleton ['a' .. 'y']) - [Point (sin (x * 0.1)) x | x <- [0 .. 25]] + (fmap Text.singleton ['a' .. 'z']) + ((\x -> Point (sin (x * 0.1)) x) <$> [0 .. 25]) + textSwitch :: (Colour, Colour) -> Text + textSwitch (cl, cd) = + [trimming| +{ + .text g { + fill: $hexDark; + } +} +@media (prefers-color-scheme:dark) { + .text g { + fill: $hexLight; + } +} +|] + where + hexLight = hex cl + hexDark = hex cd + -- | glyphs example -- -- ![glyphs example](other/glyphs.svg) glyphsExample :: ChartSvg glyphsExample = mempty - & #svgOptions . #svgHeight - .~ 50 - & #chartList - .~ zipWith - ( \(sh, bs) p -> - Chart - ( GlyphA - ( defaultGlyphStyle - & #size .~ (0.1 :: Double) - & #borderSize .~ bs - & #shape .~ sh - ) + & set (#svgOptions % #svgHeight) 400 + & set + #charts + ( named "glyphs" $ + zipWith + ( \(sh, bs) p -> + GlyphChart + ( defaultGlyphStyle + & #size .~ (0.1 :: Double) + & #borderSize .~ bs + & #shape .~ sh + ) + [p] ) - [p] + [ (CircleGlyph, 0.01 :: Double), + (SquareGlyph, 0.01), + (RectSharpGlyph 0.75, 0.01), + (RectRoundedGlyph 0.75 0.01 0.01, 0.01), + (EllipseGlyph 0.75, 0.01), + (VLineGlyph, 0.01), + (HLineGlyph, 0.01), + (TriangleGlyph (Point 0.0 (0.5 * sqrt 2)) (Point (-cos (pi / 3)) (-sin (pi / 3) / 2)) (Point (cos (pi / 3)) (-sin (pi / 3) / 2)), 0.01), + (PathGlyph "M 0.5,-0.3660 A 1.0 1.0 -0.0 0 1 0,0.5 A 1.0 1.0 -0.0 0 1 -0.5,-0.3660 A 1.0 1.0 -0.0 0 1 0.5,-0.3660 L 0.5,-0.3660 Z" ScaleBorder, 0.01) + ] + [Point x 0 | x <- [0 .. (8 :: Double)]] ) - [ (CircleGlyph, 0.01 :: Double), - (SquareGlyph, 0.01), - (RectSharpGlyph 0.75, 0.01), - (RectRoundedGlyph 0.75 0.01 0.01, 0.01), - (EllipseGlyph 0.75, 0), - (VLineGlyph 0.005, 0.01), - (HLineGlyph 0.005, 0.01), - (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01), - (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01) - ] - [P x 0 | x <- [0 .. (8 :: Double)]] -- | Example data for Bar chart barDataExample :: BarData barDataExample = BarData [[1, 2, 3, 5, 8, 0, -2, 11, 2, 1], [1 .. 10]] - (Just (("row " <>) . pack . show <$> ([1 .. 11] :: [Int]))) - (Just (("column " <>) . pack . show <$> ([1 .. 2] :: [Int]))) + (("row " <>) . pack . show <$> [1 .. 11 :: Int]) + (("column " <>) . pack . show <$> [1 .. 2 :: Int]) -- | Bar chart example. -- @@ -230,140 +230,11 @@ barExample :: ChartSvg barExample = barChart defaultBarOptions barDataExample --- | A reminder that Text scale is at representation level, and so doesn't scale compared with other chart elements, such as a rectangle. --- --- ![text local example](other/textlocal.svg) -textLocalExample :: ChartSvg -textLocalExample = - mempty & #chartList - .~ [ t1, - t2, - Chart (RectA rs) [RectXY (padBox $ styleBox t1)], - Chart (RectA rs) [RectXY (padBox $ styleBox t2)] - ] - where - rs = defaultRectStyle & #color %~ setOpac 0.1 - t1 = - Chart - ( TextA - (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.5 & #size .~ 0.08) - ["a pretty long piece of text"] - ) - [zero] - t2 = - Chart - ( TextA - (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.5 & #size .~ 0.08) - ["another pretty long piece of text"] - ) - [P 1 1] - --- | compound chart -gopts3 :: [GlyphStyle] -gopts3 = - zipWith - ( \x y -> - (#color .~ x) - . (#borderColor .~ x) - . (#borderSize .~ 0.005) - . (#shape .~ y) - . (#size .~ 0.08) - $ defaultGlyphStyle - ) - palette1_ - [EllipseGlyph 1.5, SquareGlyph, CircleGlyph] - --- | Glyph + Lines --- --- ![glines example](other/glines.svg) -glinesExample :: ChartSvg -glinesExample = mempty & #chartList .~ (cs <> gs) - where - cs = zipWith (\d s -> Chart (LineA s) (PointXY <$> d)) ls lopts - gs = zipWith (\d s -> Chart (GlyphA s) (PointXY <$> d)) ls gopts3 - -lgdata :: [(Text, Point Double)] -lgdata = - (\p@(Point x y) -> (pack (show x <> "," <> show y), fromIntegral <$> p)) - <$> (Point <$> [0 .. 5] <*> [0 .. 5] :: [Point Int]) - --- | Labelled Glyphs --- --- ![lglyph example](other/lglyph.svg) -lglyphExample :: ChartSvg -lglyphExample = mempty & #chartList .~ (txt <> gly) - where - txt = - ( \(t, p) -> - Chart - ( TextA - ( defaultTextStyle - & #color %~ setOpac 0.2 - ) - [t] - ) - (PointXY <$> [p + Point 0 0.2]) - ) - <$> lgdata - gly = - ( \d -> - Chart - ( GlyphA - ( defaultGlyphStyle - & #size .~ 0.01 - & #borderSize .~ 0 - & #color .~ palette1 2 - ) - ) - (PointXY <$> [d]) - ) - <$> (snd <$> lgdata) - --- | mappend of lglyph and glines examples --- --- ![compound example](other/compound.svg) -compoundExample :: ChartSvg -compoundExample = lglyphExample <> glinesExample - --- | label example. --- --- ![label example](other/label.svg) -labelExample :: ChartSvg -labelExample = - mempty & #chartList - .~ [Chart (TextA (defaultTextStyle & #rotation ?~ -pi / 4) ["text at (1,1) rotated by -(pi/4) radians"]) [PointXY (Point 1.0 1.0)]] - --- | legend test --- --- ![legend example](other/legend.svg) -legendExample :: ChartSvg -legendExample = - mempty & #hudOptions - .~ ( defaultHudOptions - & #hudLegend - ?~ ( defaultLegendOptions - & #lscale .~ 0.3 - & #lplace .~ PlaceAbsolute (Point 0.0 0.0) - & #lsize .~ 0.12 - & #ltext . #size .~ 0.16, - l1 - ) - ) - where - l1 = - [ (GlyphA defaultGlyphStyle, "glyph"), - (RectA defaultRectStyle, "rect"), - (TextA (defaultTextStyle & #anchor .~ AnchorStart) ["content"], "text"), - (LineA defaultLineStyle, "line"), - (GlyphA defaultGlyphStyle, "abcdefghijklmnopqrst"), - (BlankA, "blank") - ] - -- | wave example -- -- ![wave example](other/wave.svg) waveExample :: ChartSvg -waveExample = mempty & #chartList .~ [Chart (GlyphA defaultGlyphStyle) (PointXY <$> gridP sin (Range 0 (2 * pi)) 30)] +waveExample = mempty & #charts .~ named "wave" [GlyphChart defaultGlyphStyle $ gridP sin (Range 0 (2 * pi)) 30] & #hudOptions .~ defaultHudOptions -- | venn diagram -- @@ -371,9 +242,9 @@ vennExample :: ChartSvg vennExample = mempty - & #chartList .~ zipWith (\c x -> Chart (PathA (defaultPathStyle & #color .~ setOpac 0.2 c) (fst <$> x)) (PointXY . snd <$> x)) palette1_ (toPathXYs . parsePath <$> vennSegs) - & #svgOptions .~ (defaultSvgOptions & #chartAspect .~ FixedAspect 1) + & #charts .~ named "venn" (zipWith (\c x -> PathChart (defaultPathStyle & #borderSize .~ 0.005 & #color .~ palette1a c 0.2 & over #borderColor (set opac' 1)) x) [0 ..] (svgToPathData <$> vennSegs)) & #hudOptions .~ defaultHudOptions + & #hudOptions % #chartAspect .~ FixedAspect 1 {- These were originally based on: @@ -404,61 +275,93 @@ pathExample :: ChartSvg pathExample = mempty - & #chartList .~ [path', c0] + & #charts .~ named "path" [path', c0] <> named "pathtext" [t0] & #hudOptions .~ defaultHudOptions - & #svgOptions - %~ ( (#outerPad ?~ 0.1) - . (#chartAspect .~ ChartAspect) - ) + & #hudOptions % #chartAspect .~ ChartAspect + & #svgOptions % #cssOptions % #preferColorScheme .~ PreferHud + & #svgOptions % #cssOptions % #cssExtra .~ classSwitch (light, dark) "pathtext" where ps = - [ (StartI, Point 0 0), - (LineI, Point 1 0), - (CubicI (Point 0.2 0) (Point 0.25 1), Point 1 1), - (QuadI (Point -1 2), Point 0 1), - (ArcI (ArcInfo (Point 1 1) (-pi / 6) False False), Point 0 0) + [ StartP (Point 0 0), + LineP (Point 1 0), + CubicP (Point 0.2 0) (Point 0.25 1) (Point 1 1), + QuadP (Point (-1) 2) (Point 0 1), + ArcP (ArcInfo (Point 1 1) (-pi / 6) False False) (Point 0 0) ] - path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 2) & #borderColor .~ Colour 0.2 0.8 0.4 0.3) (fst <$> ps)) (PointXY . snd <$> ps) - c0 = Chart (GlyphA defaultGlyphStyle) (PointXY . snd <$> ps) + ts = + [ "StartP (Point 0 0)", + "LineP (Point 1 0)", + "CubicP (Point 0.2 0) (Point 0.25 1) (Point 1 1)", + "QuadP (Point (-1) 2) (Point 0 1)", + "ArcP (ArcInfo (Point 1 1) (-pi / 6) False False) (Point 0 0)" + ] + path' = PathChart (defaultPathStyle & #color .~ palette1a 0 0.1 & #borderColor .~ palette1a 1 1) ps + c0 = GlyphChart defaultGlyphStyle (pointPath <$> ps) + midp = Point 0 0 : zipWith (\(Point x y) (Point x' y') -> Point ((x + x') / 2) ((y + y') / 2)) (drop 1 (pointPath <$> ps)) (pointPath <$> ps) + offp = [Point 0 0.05, Point 0 0, Point (-0.2) 0, Point (-0.1) 0.1, Point 0 (-0.1)] + t0 = TextChart (defaultTextStyle & set #size 0.05) (zip ts (zipWith addp offp midp)) +classSwitch :: (Colour, Colour) -> Text -> Text +classSwitch (cl, cd) class' = + [trimming| +{ + .$class' g { + fill: $hexDark; + } +} +@media (prefers-color-scheme:dark) { + .$class' g { + fill: $hexLight; + } +} +|] + where + hexLight = hex cl + hexDark = hex cd + -- | ellipse example -- --- (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) 0 True True)) +-- Under scaling, angles are not invariant, and this effects the shape of ellipses and thus SVG arc paths. Compare the effect of aspect changes to the axes of this ellipse: -- -- ![ellipse example](other/ellipse.svg) -ellipseExample :: ChartSvg -ellipseExample = - mempty - & #chartList .~ [ell, ellFull, c0, bbox, xradii, yradii] - & #hudOptions .~ defaultHudOptions - & #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect)) - where - p@(ArcPosition p1 p2 _) = ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) - (ArcCentroid c r phi' ang0 angd) = arcCentroid p - ellFull = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ palette1 1) (PointXY . ellipse c r phi' . (\x -> 2 * pi * x / 100.0) <$> [0 .. 100]) - ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ palette1 1) (PointXY . ellipse c r phi' . (\x -> ang0 + angd * x / 100.0) <$> [0 .. 100]) - c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [c, p1, p2]) - bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (arcBox p)] - xradii = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.9 0.2 0.02 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [ellipse c r phi' 0, ellipse c r phi' pi]) - yradii = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.9 0.9 0.02 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [ellipse c r phi' (pi / 2), ellipse c r phi' (3 / 2 * pi)]) - --- | arc example -- --- ![arc example](other/arc.svg) -arcExample :: ChartSvg -arcExample = +-- Below is the same ellipse with FixedAspect 2. Points scale exactly, but the original points that represent the end points of the axes are no longer on the new axes of the ellipse. +-- +-- ![ellipse2 example](other/ellipse2.svg) +ellipseExample :: ChartAspect -> ChartSvg +ellipseExample a = mempty - & #chartList .~ [arc, ell, c0, bbox] + & #charts .~ named "ellipse" [ell, ellFull, c0, c1, bbox, xradii, yradii] & #hudOptions .~ defaultHudOptions - & #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ FixedAspect 1)) + & #hudOptions % #chartAspect .~ a + & #hudOptions % #legends .~ [(10, defaultLegendOptions & #content .~ lrows & #textStyle % #size .~ 0.2 & #size .~ 0.1)] + & #hudOptions % #titles .~ [(11, defaultTitle "ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True)" & #style % #size .~ 0.08)] where - p1 = ArcPosition (Point 1.0 0.0) (Point 0.0 1.0) (ArcInfo (Point 1.0 0.5) 0 False True) - ps = singletonArc p1 - (ArcCentroid c r phi' ang0 angd) = arcCentroid p1 - arc = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) - ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ palette1 1) (PointXY . ellipse c r phi' . (\x -> ang0 + angd * x / 100.0) <$> [0 .. 100]) - c0 = Chart (GlyphA defaultGlyphStyle) [PointXY c] - bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (arcBox p1)] + p@(ArcPosition p1 p2 _) = ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) + (ArcCentroid c r phi' ang0' angd) = arcCentroid p + ellFull = LineChart fullels [ellipse c r phi' . (\x -> 2 * pi * x / 100.0) <$> [0 .. 100]] + ell = LineChart els [ellipse c r phi' . (\x -> ang0' + angd * x / 100.0) <$> [0 .. 100]] + g0 = defaultGlyphStyle & #shape .~ CircleGlyph + c0 = GlyphChart g0 [c] + g1 = defaultGlyphStyle & #color .~ palette1a 4 0.2 + c1 = GlyphChart g1 [p1, p2] + bbox = RectChart bbs [arcBox p] + bbs = defaultRectStyle & #borderSize .~ 0.002 & #color .~ palette1a 7 0.005 & #borderColor .~ grey 0.5 1 + xradii = LineChart xals [[ellipse c r phi' 0, ellipse c r phi' pi]] + yradii = LineChart yals [[ellipse c r phi' (pi / 2), ellipse c r phi' (3 / 2 * pi)]] + xals = defaultLineStyle & #color .~ palette1 6 & #size .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound + yals = defaultLineStyle & #color .~ palette1 5 & #size .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound + fullels = defaultLineStyle & #size .~ 0.002 & #color .~ palette1 1 + els = defaultLineStyle & #size .~ 0.005 & #color .~ palette1 2 + lrows = + [ ("Major Axis", LineChart xals [[zero]]), + ("Minor Axis", LineChart yals [[zero]]), + ("Full Ellipse", LineChart fullels [[zero]]), + ("Arc", LineChart els [[zero]]), + ("Centroid", GlyphChart (g0 & #size .~ 0.01) [zero]), + ("Endpoints", GlyphChart (g1 & #size .~ 0.01) [zero]), + ("Bounding Box", RectChart (bbs & #borderSize .~ 0.01) [fmap (2 *) one]) + ] -- | Reproduction of the flag explanation chart in -- @@ -466,63 +369,98 @@ arcFlagsExample :: ChartSvg arcFlagsExample = mempty - & #chartList - .~ vert - 0.02 - [ hori + & set + #charts + ( vert 0.02 - [ [ Chart BlankA [R -0.4 0.4 -1 5], - Chart (TextA (defaultTextStyle & #size .~ 0.6 & #rotation .~ Just (pi / 2)) ["Sweep"]) [P 0.1 2] + [ hori 0.02 [colSweep, colSweep2, colLargeFalse, colLargeTrue], + rowLarge + ] + ) + & #hudOptions % #chartAspect .~ ChartAspect + & #svgOptions % #cssOptions % #preferColorScheme .~ PreferHud + & #svgOptions % #cssOptions % #cssExtra + .~ [trimming| +{ + .chart g { + stroke: $hexDark; + } + .chart g text { + fill: $hexDark; + } +} +@media (prefers-color-scheme:dark) { + .chart g { + stroke: $hexLight; + } + .chart g text { + fill: $hexLight; + } +} +|] + where + hexDark = hex dark + hexLight = hex light + rowLarge = + unnamed + [ BlankChart [Rect 0 9 (-2.75) (-3.25)], + TextChart (defaultTextStyle & #size .~ 0.6) [("Large", Point 5.5 (-3.0))] + ] + colLargeFalse = + vert + 0.02 + [ unnamed (checkFlags False True (set opac' 0.3 dark)), + unnamed (checkFlags False False (set opac' 0.3 dark)), + unnamed + [ BlankChart [Rect (-1) 2 (-0.25) 0.25], + TextChart (defaultTextStyle & #size .~ 0.4) [("False", Point 0.5 (-0.1))] + ] + ] + colLargeTrue = + vert + 0.02 + [ unnamed (checkFlags True True (set opac' 0.3 dark)), + unnamed (checkFlags True False (set opac' 0.3 dark)), + unnamed + [ BlankChart [Rect (-1) 2 (-0.25) 0.25], + TextChart (defaultTextStyle & #size .~ 0.4) [("True", Point 0.5 (-0.1))] + ] + ] + colSweep = + unnamed + [ BlankChart [Rect (-0.4) 0.4 (-1) 5], + TextChart + (defaultTextStyle & #size .~ 0.6 & #rotation .~ Just (pi / 2)) + [("Sweep", Point 0.1 2)] + ] + colSweep2 = + vert + 0.02 + [ unnamed + [ BlankChart [Rect (-0.25) 0.25 (-1) 2], + TextChart + (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi / 2)) + [("True", Point 0.1 0.5)] ], - vert - 0.02 - [ [ Chart BlankA [R -0.25 0.25 -1 2], - Chart (TextA (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi / 2)) ["True"]) [P 0.1 0.5] - ], - [ Chart BlankA [R -0.25 0.25 -1 2], - Chart (TextA (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi / 2)) ["False"]) [P 0.1 0.5] - ] - ], - vert - 0.02 - [ checkFlags False True (setOpac 0.3 dark) & view #chartList, - checkFlags False False (setOpac 0.3 dark) & view #chartList, - [ Chart BlankA [R -1 2 -0.25 0.25], - Chart (TextA (defaultTextStyle & #size .~ 0.4) ["False"]) [P 0.5 -0.1] - ] - ], - vert - 0.02 - [ checkFlags True True (setOpac 0.3 dark) & view #chartList, - checkFlags True False (setOpac 0.3 dark) & view #chartList, - [ Chart BlankA [R -1 2 -0.25 0.25], - Chart (TextA (defaultTextStyle & #size .~ 0.4) ["True"]) [P 0.5 -0.1] - ] - ] - ], - [ Chart BlankA [R 0 9 -2.75 -3.25], - Chart (TextA (defaultTextStyle & #size .~ 0.6) ["Large"]) [P 5.5 -3.0] + unnamed + [ BlankChart [Rect (-0.25) 0.25 (-1) 2], + TextChart + (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi / 2)) + [("False", Point 0.1 0.5)] + ] ] - ] - & #hudOptions - .~ mempty - & #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect)) -checkFlags :: Bool -> Bool -> Colour -> ChartSvg -checkFlags large sweep co = - mempty - & #hudOptions .~ defaultHudOptions - & #svgOptions . #chartAspect .~ UnadjustedAspect - & #chartList .~ [c1, c2, ell, arc1] +checkFlags :: Bool -> Bool -> Colour -> [Chart] +checkFlags large' sweep co = [c1, c2, ell, arc1] where c = Point 1.0 1.0 - p1 = ArcPosition (Point 0.0 1.0) (Point 1.0 0.0) (ArcInfo (Point 1.0 1.0) 0 large sweep) - ps1 = singletonPie' c p1 - (ArcCentroid c' r phi' ang0 angd) = arcCentroid p1 - arc1 = Chart (PathA (defaultPathStyle & #color .~ co & #borderColor .~ setOpac 0.5 dark) (fst <$> ps1)) (PointXY . snd <$> ps1) - c1 = Chart (LineA $ defaultLineStyle & #width .~ 0.02 & #color .~ setOpac 0.2 dark) (PointXY . ellipse (Point 1.0 1.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]) - c2 = Chart (LineA $ defaultLineStyle & #width .~ 0.02 & #color .~ setOpac 0.2 dark) (PointXY . ellipse (Point 0.0 0.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]) - ell = Chart (LineA $ defaultLineStyle & #width .~ 0.05 & #color .~ setOpac 0.5 co) (PointXY . ellipse c' r phi' . (\x -> ang0 + angd * x / 100.0) <$> [0 .. 100]) + p1 = ArcPosition (Point 0.0 1.0) (Point 1.0 0.0) (ArcInfo (Point 1.0 1.0) 0 large' sweep) + ps1 = singletonPie c p1 + (ArcCentroid c' r phi' ang0' angd) = arcCentroid p1 + arc1 = PathChart (defaultPathStyle & #color .~ co & #borderColor .~ set opac' 0.5 dark) ps1 + c1 = LineChart (defaultLineStyle & #size .~ 0.02 & #color .~ set opac' 0.2 dark) [ellipse (Point 1.0 1.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]] + c2 = LineChart (defaultLineStyle & #size .~ 0.02 & #color .~ set opac' 0.2 dark) [ellipse (Point 0.0 0.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]] + ell = LineChart (defaultLineStyle & #size .~ 0.05 & #color .~ set opac' 0.5 co) [ellipse c' r phi' . (\x -> ang0' + angd * x / 100.0) <$> [0 .. 100]] -- | quad example -- @@ -530,16 +468,30 @@ quadExample :: ChartSvg quadExample = mempty - & #chartList .~ [path', curve, c0, bbox] + & #charts .~ named "quad" [path', curve, c0, c1, bbox] & #hudOptions .~ defaultHudOptions - & #svgOptions %~ ((#outerPad ?~ 0.05) . (#chartAspect .~ ChartAspect)) + & #hudOptions % #chartAspect .~ FixedAspect 1.5 + & #hudOptions % #legends .~ [(10, defaultLegendOptions & #content .~ lrows & #textStyle % #size .~ 0.2 & #size .~ 0.2)] + & #hudOptions % #titles .~ [(11, defaultTitle "QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))" & #style % #size .~ 0.08)] where - p@(QuadPosition start end control) = QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1) + p@(QuadPosition start end control) = QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1)) ps = singletonQuad p - path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) - curve = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ palette1 1) (PointXY . quadBezier p . (/ 100.0) <$> [0 .. 100]) - c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [start, end, control]) - bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (quadBox p)] + path' = PathChart pathStyle ps + curve = LineChart curveStyle [quadBezier p . (/ 100.0) <$> [0 .. 100]] + curveStyle = defaultLineStyle & #size .~ 0.002 & #color .~ palette1 1 + c0 = GlyphChart defaultGlyphStyle [start, end] + c1 = GlyphChart controlStyle [control] + bbox = RectChart bbs [quadBox p] + bbs = defaultRectStyle & #borderSize .~ 0.002 & #color .~ palette1a 0 0.05 & #borderColor .~ grey 0.4 1 + pathStyle = defaultPathStyle & #color .~ palette1a 2 0.2 & #borderColor .~ transparent + controlStyle = defaultGlyphStyle & #shape .~ CircleGlyph + lrows = + [ ("Path Fill", PathChart pathStyle [StartP zero]), + ("Path Chord", LineChart curveStyle [[zero]]), + ("Path Endpoints", GlyphChart defaultGlyphStyle [zero]), + ("Path Control Point", GlyphChart controlStyle [zero]), + ("Bounding Box", RectChart (bbs & #borderSize .~ 0.01) [one]) + ] -- | cubic example -- @@ -547,41 +499,61 @@ cubicExample :: ChartSvg cubicExample = mempty - & #chartList .~ [path', curve, c0, bbox] + & #charts .~ named "cubic" [path', curve, c0, c1, bbox] & #hudOptions .~ mempty - & #svgOptions %~ ((#outerPad ?~ 0.02) . (#chartAspect .~ ChartAspect)) + & #hudOptions % #chartAspect .~ FixedAspect 1.5 + & #hudOptions % #legends .~ [(10, defaultLegendOptions & #content .~ lrows & #textStyle % #size .~ 0.2 & #size .~ 0.2)] + & #hudOptions % #titles .~ [(11, defaultTitle "CubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1)" & #style % #size .~ 0.08)] where p@(CubicPosition start end control1 control2) = CubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1) ps = singletonCubic p - path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) - curve = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ palette1 1) (PointXY . cubicBezier p . (/ 100.0) <$> [0 .. 100]) - c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [start, end, control1, control2, cubicBezier p 0.8]) - bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (cubicBox p)] + path' = PathChart pathStyle ps + curve = LineChart curveStyle [cubicBezier p . (/ 100.0) <$> [0 .. 100]] + c0 = GlyphChart defaultGlyphStyle [start, end] + c1 = GlyphChart controlStyle [control1, control2] + bbox = RectChart bbs [cubicBox p] + bbs = defaultRectStyle & #borderSize .~ 0.002 & #color .~ palette1a 0 0.05 & #borderColor .~ grey 0.4 1 + pathStyle = defaultPathStyle & #color .~ palette1a 3 0.2 & #borderColor .~ transparent + controlStyle = defaultGlyphStyle & #shape .~ CircleGlyph + curveStyle = defaultLineStyle & #size .~ 0.002 & #color .~ palette1 7 + lrows = + [ ("Path Fill", PathChart pathStyle [StartP zero]), + ("Path Chord", LineChart curveStyle [[zero]]), + ("Path Endpoints", GlyphChart defaultGlyphStyle [zero]), + ("Path Control Point", GlyphChart controlStyle [zero]), + ("Bounding Box", RectChart (bbs & #borderSize .~ 0.01) [one]) + ] --- | The common way to create a surface chart is usually a grid over a function. +-- | The common way to create a surface chart (or contour chart or heat map) is usually a grid over a function, a process reified in 'surfacef'. -- +-- This is also an example of 'mix' and 'mixes'. In this example, colors with the same lightness have been chosen in the gradient and the result should appear a fairly uniform lightness across the surface. +-- -- ![surface example](other/surface.svg) surfaceExample :: ChartSvg surfaceExample = mempty - & #hudList .~ hs - & #chartList .~ cs - & #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp) + & #extraHuds .~ h + & #charts .~ named "surface" cs + & #svgOptions .~ (defaultSvgOptions & #cssOptions % #shapeRendering .~ UseCssCrisp) where t = "rosenbrock" - grain = Point 20 20 + grain = Point 100 100 r = one - f = fst . bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10 - (cs, hs) = + f = fst . bimap ((-1.0) *) (fmap ((-1.0) *)) . rosenbrock 1 10 + evenColors = trimColour . over lightness' (const 0.55) . palette1 <$> [0 .. 5] + (cs, h) = surfacefl f ( defaultSurfaceOptions & #soGrain .~ grain & #soRange .~ r - & #soStyle . #surfaceColors .~ (palette1 <$> [0 .. 5]) + & #soStyle % #surfaceColors .~ evenColors ) - ( defaultSurfaceLegendOptions t - & #sloStyle . #surfaceColors .~ (palette1 <$> [0 .. 5]) + ( defaultSurfaceLegendOptions dark t + & #sloStyle % #surfaceColors .~ evenColors + & #sloLegendOptions % #textStyle % #color .~ dark + & #sloAxisOptions .~ surfaceAxisOptions dark + & #sloLegendOptions % #frame %~ fmap (#borderColor .~ dark) ) -- | arrow example @@ -592,13 +564,30 @@ arrowExample :: ChartSvg arrowExample = mempty - & #hudOptions .~ (defaultHudOptions & #hudAxes %~ fmap (#axisTick . #ltick .~ Nothing)) - & #chartList .~ ((\p -> chart (tail . f $ p) (angle . f $ p) p) <$> ps) - & #svgOptions .~ defaultSvgOptions + & #hudOptions .~ (defaultHudOptions & #axes %~ fmap (second (#ticks % #ltick .~ Nothing))) + & #charts .~ named "arrow" ((\p -> gchart (tail' . f $ p) (angle . f $ p) p) <$> ps) + & #svgOptions % #cssOptions % #preferColorScheme .~ PreferHud + & #svgOptions % #cssOptions % #cssExtra + .~ [trimming| +{ + .arrow g { + fill: $hexDark; + stroke: $hexDark; + } +} +@media (prefers-color-scheme:dark) { + .arrow g { + fill: $hexLight; + stroke: $hexLight; + } +} +|] where - f = snd . bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10 + hexLight = hex light + hexDark = hex dark + f = snd . bimap ((-1.0) *) (fmap ((-1.0) *)) . rosenbrock 1 10 ps = grid MidPos (one :: Rect Double) (Point 10 10 :: Point Int) :: [Point Double] - arrow = PathGlyph "M -1 0 L 1 0 M 1 0 L 0.4 0.3 M 1 0 L 0.4 -0.3" + arrow = PathGlyph "M -1 0 L 1 0 M 1 0 L 0.4 0.3 M 1 0 L 0.4 -0.3" NoScaleBorder gs s r' = defaultGlyphStyle & #borderSize .~ 0.05 @@ -606,10 +595,10 @@ & #borderColor .~ dark & #rotation .~ Just r' & #shape .~ arrow - chart s r' p = Chart (GlyphA (gs s r')) [PointXY p] + gchart s r' p = GlyphChart (gs s r') [p] - tail :: Point Double -> Double - tail = max 0.05 . min 0.02 . (* 0.01) . (/ avmag) . norm + tail' :: Point Double -> Double + tail' = max 0.05 . min 0.02 . (* 0.01) . (/ avmag) . norm avmag = sum (norm . f <$> ps) / fromIntegral (length ps) @@ -621,38 +610,167 @@ -- > f'y = 2 * b * y - 2 * b * x^2 -- > f a b (Point x y) = (a^2 - 2ax + x^2 + b * y^2 - b * 2 * y * x^2 + b * x^4, Point (-2a + 2 * x - b * 4 * y * x + 4 * b * x ^ 3), 2 * b * y - 2 * b * x^2) rosenbrock :: Double -> Double -> Point Double -> (Double, Point Double) -rosenbrock a b (Point x y) = (a ^ 2 - 2 * a * x + x ^ 2 + b * y ^ 2 - b * 2 * y * x ^ 2 + b * x ^ 4, Point (-2 * a + 2 * x - b * 4 * y * x + 4 * b * x ^ 3) (2 * b * y - 2 * b * x ^ 2)) +rosenbrock a b (Point x y) = (a ** 2 - 2 * a * x + x ** 2 + b * y ** 2 - b * 2 * y * x ** 2 + b * x ** 4, Point (-2 * a + 2 * x - b * 4 * y * x + 4 * b * x ** 3) (2 * b * y - 2 * b * x ** 2)) --- | Run this to refresh haddock example SVGs. +-- | date example +-- +-- A hud that has date as the x-axis, and time as the y-axis. See 'placedTimeLabelContinuous'. +-- +-- ![date example](other/date.svg) +dateExample :: ChartSvg +dateExample = + mempty + & #charts .~ blank (Rect 0 1 0 1) + & #hudOptions + .~ ( mempty & #chartAspect .~ FixedAspect 1.5 & #axes + .~ [ (1, defaultAxisOptions & #place .~ PlaceLeft & #ticks % #style .~ TickPlaced tsTime), + (1, defaultAxisOptions & #ticks % #style .~ TickPlaced tsDate) + ] + ) + where + tsTime = placedTimeLabelContinuous PosIncludeBoundaries Nothing 12 (Range (UTCTime (fromGregorian 2021 12 6) (toDiffTime 0)) (UTCTime (fromGregorian 2021 12 7) (toDiffTime 0))) + tsDate = placedTimeLabelContinuous PosIncludeBoundaries (Just (pack "%d %b")) 2 (Range (UTCTime (fromGregorian 2021 12 6) (toDiffTime 0)) (UTCTime (fromGregorian 2022 3 13) (toDiffTime 0))) + +-- | gradient example +-- +-- Mixing Colours using the color model. +-- +-- ![gradient example](other/gradient.svg) +gradientExample :: ChartSvg +gradientExample = gradient (Just (orig / 360)) 100 6 100 c0 c1 + where + ok = LCHA 0.5 0.12 127 1 + c0 = ok & lch' % hLCH' .~ 0.001 + c1 = ok & lch' % hLCH' .~ 360 + orig = view (lch' % hLCH') ok + +gradientChart_ :: Int -> LCHA -> LCHA -> [Chart] +gradientChart_ grain c0 c1 = + (\(r, c) -> RectChart (defaultRectStyle & #color .~ c & #borderSize .~ 0) [r]) + . (\x -> (Rect x (x + d) 0 1, view lcha2colour' (mixLCHA x c0 c1))) + <$> grid LowerPos (Range 0 1) grain + where + d = 1 / fromIntegral grain + +gradient :: Maybe Double -> Double -> Double -> Int -> LCHA -> LCHA -> ChartSvg +gradient marker h fa grain ok0 ok1 = + mempty + & #svgOptions % #svgHeight + .~ h + & #svgOptions % #cssOptions % #shapeRendering + .~ UseCssCrisp + & #hudOptions + .~ ( mempty + & #chartAspect .~ FixedAspect fa + & #frames .~ [(20, FrameOptions (Just (border 0.004 white)) 0.1)] + ) + & #charts + .~ named "gradient" (gradientChart_ grain ok0 ok1) <> strip + where + strip = case marker of + Nothing -> mempty + Just marker' -> + named + "border" + [borderStrip 0.02 light (Rect (marker' - 0.02) (marker' + 0.02) (-0.1) 1.1)] + +borderStrip :: Double -> Colour -> Rect Double -> Chart +borderStrip w c r = RectChart (defaultRectStyle & #color .~ transparent & #borderSize .~ w & #borderColor .~ c) [r] + +-- | Color wheel displaying palette1 choices +-- +-- -- ![wheel example](other/wheel.svg) +wheelExample :: ChartSvg +wheelExample = dotMap 0.01 50 0.5 0.5 (palette1 <$> [0 .. 7]) + +-- | The dotMap +-- +-- > dotMap 0.01 20 0.8 0.3 +dotMap :: Double -> Int -> Double -> Double -> [Colour] -> ChartSvg +dotMap s grain l maxchroma cs = + mempty + & #hudOptions + .~ defaultHudOptions + & #charts + .~ named "dots" (dot_ <$> cs) + <> named + "wheel" + ( ( \(p, c) -> + GlyphChart + ( defaultGlyphStyle + & #size .~ s + & #color .~ c + & #borderSize .~ 0 + ) + [p] + ) + <$> filter (validColour . snd) (wheelPoints grain l maxchroma) + ) + +dot_ :: Colour -> Chart +dot_ x = (\(p, c) -> GlyphChart (defaultGlyphStyle & #size .~ 0.08 & #color .~ c & #borderColor .~ Colour 0.5 0.5 0.5 1 & #shape .~ CircleGlyph) [p]) (colour2Point x, x) + where + colour2Point c = review lcha2colour' c & (\(LCHA _ ch h _) -> uncurry Point (review xy2ch' (ch, h))) + +wheelPoints :: Int -> Double -> Double -> [(Point Double, Colour)] +wheelPoints grain l maxchroma = + (\(Point c h) -> (uncurry Point $ view (re xy2ch') (c, h), view lcha2colour' (LCHA l c h 1))) + <$> grid LowerPos (Rect 0 maxchroma 0 360) (Point grain grain) + +-- | Adding reference points and bounding boxes to visualize chart alignment for use in debugging charts. +-- +-- -- ![debug example](other/debug.svg) +debugExample :: ChartSvg -> ChartSvg +debugExample cs = + mempty + & set #charts (e1 <> e2 <> e3) + where + e1 = toChartTree cs + e2 = glyphize (defaultGlyphStyle & #size .~ 0.01 & #shape .~ CircleGlyph) e1 + e3 = rectangularize (defaultRectStyle & #borderColor .~ dark & #borderSize .~ 0.001 & #color % opac' .~ 0.05) e1 + +pathChartSvg :: [(FilePath, ChartSvg)] +pathChartSvg = + [ ("other/unit.svg", unitExample), + ("other/rect.svg", rectExample), + ("other/text.svg", textExample), + ("other/glyphs.svg", glyphsExample), + ("other/line.svg", lineExample), + ("other/hudoptions.svg", hudOptionsExample), + ("other/bar.svg", barExample), + ("other/surface.svg", surfaceExample), + ("other/wave.svg", waveExample), + ("other/venn.svg", vennExample), + ("other/path.svg", pathExample), + ("other/arcflags.svg", arcFlagsExample), + ("other/ellipse.svg", ellipseExample (FixedAspect 1.7)), + ("other/ellipse2.svg", ellipseExample (FixedAspect 2)), + ("other/quad.svg", quadExample), + ("other/cubic.svg", cubicExample), + ("other/arrow.svg", arrowExample), + ("other/date.svg", dateExample), + ("other/gradient.svg", gradientExample), + ("other/wheel.svg", wheelExample), + ("other/debug.svg", debugExample lineExample) + ] + +-- | Run this to refresh example SVG's. writeAllExamples :: IO () writeAllExamples = do - -- charts in Chart docs - writeChartSvg "other/unit.svg" unitExample - writeChartSvg "other/rect.svg" rectExample - writeChartSvg "other/text.svg" textExample - writeChartSvg "other/glyphs.svg" glyphsExample - writeChartSvg "other/line.svg" lineExample - writeChartSvg "other/svgoptions.svg" svgOptionsExample - writeChartSvg "other/hudoptions.svg" hudOptionsExample - writeChartSvg "other/legend.svg" legendExample - -- charts in Chart.Bar docs - writeChartSvg "other/bar.svg" barExample - -- charts in Chart.Surface docs - writeChartSvg "other/surface.svg" surfaceExample - -- extra Charts - writeChartSvg "other/wave.svg" waveExample - writeChartSvg "other/lglyph.svg" lglyphExample - writeChartSvg "other/glines.svg" glinesExample - writeChartSvg "other/compound.svg" compoundExample - writeChartSvg "other/textlocal.svg" textLocalExample - writeChartSvg "other/label.svg" labelExample - writeChartSvg "other/venn.svg" vennExample - writeChartSvg "other/path.svg" pathExample - writeChartSvg "other/arc.svg" arcExample - writeChartSvg "other/arcflags.svg" arcFlagsExample - writeChartSvg "other/ellipse.svg" ellipseExample - writeChartSvg "other/quad.svg" quadExample - writeChartSvg "other/cubic.svg" cubicExample - writeChartSvg "other/arrow.svg" arrowExample - + sequence_ $ uncurry writeChartSvg <$> pathChartSvg putStrLn "ok" + +-- | Version of charts with a dark-friendly hud +writeAllExamplesDark :: IO () +writeAllExamplesDark = do + sequence_ $ + uncurry writeChartSvg + . bimap + ((<> "d.svg") . reverse . drop 4 . reverse) + ( \x -> + x + & #hudOptions %~ colourHudOptions (rgb light) + & #svgOptions % #cssOptions % #preferColorScheme .~ PreferDark + ) + <$> pathChartSvg + putStrLn "dark version, ok" diff --git a/src/Chart/Hud.hs b/src/Chart/Hud.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Hud.hs @@ -0,0 +1,1071 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wall #-} + +-- | A hud stands for , and is a collective noun used to name chart elements that assist in data interpretation or otherwise annotate and decorate data. +-- +-- This includes axes, titles, borders, frames, background canvaii, tick marks and tick value labels. +-- +module Chart.Hud + ( -- * Hud + Hud (..), + Priority, + HudBox, + CanvasBox, + DataBox, + HudChart (..), + canvasBox', + canvasStyleBox', + hudBox', + hudStyleBox', + + -- * Hud Processing + runHudWith, + runHud, + + -- * HudOptions + HudOptions (..), + defaultHudOptions, + colourHudOptions, + toHuds, + + -- * Hud Effects + closes, + fromEffect, + applyChartAspect, + getHudBox, + + -- * Hud primitives + AxisOptions (..), + defaultAxisOptions, + flipAxis, + FrameOptions (..), + defaultFrameOptions, + Place (..), + placeText, + AxisBar (..), + defaultAxisBar, + Title (..), + defaultTitle, + Ticks (..), + defaultGlyphTick, + defaultTextTick, + defaultLineTick, + defaultTicks, + TickStyle (..), + defaultTickStyle, + tickStyleText, + TickExtend (..), + adjustTicks, + Adjustments (..), + defaultAdjustments, + LegendOptions (..), + defaultLegendOptions, + + -- * Option to Hud + frameHud, + legend, + legendHud, + legendFrame, + ) +where + +import Chart.Data +import Chart.Primitive +import Chart.Style +import Control.Monad.State.Lazy +import Data.Bifunctor +import Data.Bool +import Data.Colour +import Data.Foldable hiding (sum) +import Data.FormatN +import qualified Data.List as List +import Data.Maybe +import Data.Path +import Data.Text (Text) +import Data.Tuple +import GHC.Generics hiding (to) +import qualified NumHask.Prelude as NH +import Optics.Core +import Prelude + +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core + +-- * Hud + +-- | The priority of a Hud element or transformation, lower value means higher priority. +-- +-- Lower priority (higher values) huds will tend to be placed on the outside of a chart. +-- +-- Equal priority values will be placed in the same process step. +type Priority = Double + +-- | Heads-up display additions to charts +-- +-- A Hud is composed of: +-- +-- - A priority for the hud element in the chart folding process. +-- +-- - A chart tree with a state dependency on the chart being created. +data Hud = Hud + { -- | priority for ordering of transformations + priority :: Priority, + -- | additional charts + hud :: State HudChart ChartTree + } + deriving (Generic) + +-- | Type to track the split of Chart elements into Hud and Canvas +-- +-- - charts: charts that form the canvas or data elements of the chart; the rectangular dimension which is considered to be the data representation space. +-- +-- - hud: charts that form the Hud. +-- +-- - dataBox: The bounding box of the underlying data domain. +-- +-- This is done to support functionality where we can choose whether to normalise the chart aspect based on the entire chart (FixedAspect) or on just the data visualisation space (CanvasAspect). +data HudChart = HudChart + { chart :: ChartTree, + hud :: ChartTree, + dataBox :: DataBox + } + deriving (Eq, Show, Generic) + +-- | A type for Rect to represent the entire bounding box of a chart, including the Hud +type HudBox = Rect Double + +-- | A type for Rect to represent the bounding box of the canvas portion of a chart, excluding Hud elements +type CanvasBox = Rect Double + +-- | A type for Rect to represent the bounding box of the data elements a chart, which can be a different metric to Canvas and Hud Rects +type DataBox = Rect Double + +canvasBox_ :: HudChart -> Maybe CanvasBox +canvasBox_ = boxes . foldOf (#chart % charts') + +canvasRebox_ :: HudChart -> Maybe (Rect Double) -> HudChart +canvasRebox_ cs r = + cs + & over (#chart % chart') (maybeProjectWith r (canvasBox_ cs)) + & over (#hud % chart') (maybeProjectWith r (canvasBox_ cs)) + +-- | A lens between a HudChart and the bounding box of the canvas +canvasBox' :: Lens' HudChart (Maybe CanvasBox) +canvasBox' = + lens canvasBox_ canvasRebox_ + +-- | A lens between a HudChart and the bounding box of the canvas, including style extensions. +canvasStyleBox' :: Getter HudChart (Maybe CanvasBox) +canvasStyleBox' = to (styleBoxes . foldOf (#chart % charts')) + +hudStyleBox_ :: HudChart -> Maybe HudBox +hudStyleBox_ = styleBoxes . (\x -> foldOf (#chart % charts') x <> foldOf (#hud % charts') x) + +-- | a lens between a HudChart and the bounding box of the hud. +hudStyleBox' :: Getter HudChart (Maybe HudBox) +hudStyleBox' = to hudStyleBox_ + +hudBox_ :: HudChart -> Maybe HudBox +hudBox_ = boxes . (\x -> foldOf (#chart % charts') x <> foldOf (#hud % charts') x) + +hudRebox_ :: HudChart -> Maybe HudBox -> HudChart +hudRebox_ cs r = + cs + & over #chart (over chart' (maybeProjectWith r' (hudBox_ cs))) + & over #hud (over chart' (maybeProjectWith r' (hudBox_ cs))) + where + r' = (NH.-) <$> r <*> ((NH.-) <$> hudStyleBox_ cs <*> hudBox_ cs) + +-- | lens between a HudChart and its hud bounding box, not including style. +hudBox' :: Lens' HudChart (Maybe HudBox) +hudBox' = + lens hudBox_ hudRebox_ + +appendHud :: ChartTree -> HudChart -> HudChart +appendHud cs x = + x & over #hud (<> cs) + +-- | Absorb a series of state-dependent tress into state. +closes :: (Traversable f) => f (State HudChart ChartTree) -> State HudChart () +closes xs = do + xs' <- fmap (mconcat . toList) $ sequence xs + modify (appendHud xs') + +-- | Wrap a state effect into a Hud +fromEffect :: Priority -> State HudChart () -> Hud +fromEffect p s = Hud p (s >> pure mempty) + +-- | Apply a ChartAspect +applyChartAspect :: ChartAspect -> State HudChart () +applyChartAspect fa = do + hc <- get + case fa of + ChartAspect -> pure () + _ -> modify (set hudBox' (getHudBox fa hc)) + +-- | Supply the bounding box of the HudChart given a ChartAspect. +getHudBox :: ChartAspect -> HudChart -> Maybe HudBox +getHudBox fa c = + case fa of + FixedAspect a -> Just (aspect a) + CanvasAspect a -> + case (view hudBox' c, view canvasBox' c) of + (Nothing, _) -> Nothing + (_, Nothing) -> Nothing + (Just hb, Just cb) -> Just (aspect (a * ratio hb / ratio cb)) + ChartAspect -> view hudBox' c + +-- | Combine huds and charts to form a new Chart using the supplied initial canvas and data dimensions. Note that chart data is transformed by this computation (a linear type might be useful here). +runHudWith :: + -- | initial canvas + CanvasBox -> + -- | initial data space + DataBox -> + -- | huds to add + [Hud] -> + -- | underlying chart + ChartTree -> + -- | integrated chart tree + ChartTree +runHudWith cb db hs cs = + hs + & List.sortOn (view #priority) + & List.groupBy (\a b -> view #priority a == view #priority b) + & mapM_ (closes . fmap (view #hud)) + & flip + execState + ( HudChart + (cs & over chart' (projectWith cb db)) + mempty + db + ) + & (\x -> group (Just "chart") [view #chart x] <> group (Just "hud") [view #hud x]) + +-- | Combine huds and charts to form a new ChartTree with a supplied initial canvas dimension. +-- +-- Note that the original chart data are transformed and irrevocably forgotten by this computation. +runHud :: + -- | initial canvas dimension + CanvasBox -> + -- | huds + [Hud] -> + -- | underlying charts + ChartTree -> + -- | integrated chart list + ChartTree +runHud ca hs cs = runHudWith ca (singletonGuard $ boxes (foldOf charts' cs)) hs cs + +-- | Typical, configurable hud elements. Anything else can be hand-coded as a 'Hud'. +-- +-- ![hud example](other/hudoptions.svg) +data HudOptions = HudOptions + { chartAspect :: ChartAspect, + axes :: [(Priority, AxisOptions)], + frames :: [(Priority, FrameOptions)], + legends :: [(Priority, LegendOptions)], + titles :: [(Priority, Title)] + } + deriving (Eq, Show, Generic) + +instance Semigroup HudOptions where + (<>) (HudOptions _ a c l t) (HudOptions asp a' c' l' t') = + HudOptions asp (a <> a') (c <> c') (l <> l') (t <> t') + +instance Monoid HudOptions where + mempty = HudOptions (FixedAspect 1.5) [] [] [] [] + +-- | The official hud options. +defaultHudOptions :: HudOptions +defaultHudOptions = + HudOptions + (FixedAspect 1.5) + [ (5, defaultAxisOptions), + (5, defaultAxisOptions & set #place PlaceLeft) + ] + [(1, defaultFrameOptions)] + [] + [] + +priorities :: HudOptions -> [Priority] +priorities o = + (fst <$> view #axes o) + <> (fst <$> view #frames o) + <> (fst <$> view #legends o) + <> (fst <$> view #titles o) + +lastPriority :: HudOptions -> Priority +lastPriority o = case priorities o of + [] -> 0 + xs -> maximum xs + +-- | Make Huds and potential data box extension; from a HudOption and an initial data box. +toHuds :: HudOptions -> DataBox -> ([Hud], DataBox) +toHuds o db = + (,db''') $ + (as' & fmap (uncurry Hud . second axis)) + <> (view #frames o & fmap (uncurry Hud . second frameHud)) + <> (view #legends o & fmap (uncurry Hud . second legend)) + <> (view #titles o & fmap (uncurry Hud . second title)) + <> [ fromEffect (lastPriority o + 1) $ + applyChartAspect (view #chartAspect o) + ] + where + (as', db''') = + foldr + ( \a (as, db') -> + let (db'', a') = freezeTicks db' (snd a) + in (as <> [(fst a, a')], db'') + ) + ([], db) + (view #axes o) + +freezeTicks :: DataBox -> AxisOptions -> (DataBox, AxisOptions) +freezeTicks db a = + bimap + (\x -> placeRect (view #place a) x db) + (\x -> a & set (#ticks % #style) x) + (toTickPlaced (placeRange (view #place a) db) (view (#ticks % #style) a)) + +-- | compute tick components given style, ranges and formatting +makePlacedTicks :: TickStyle -> Range Double -> ([(Double, Text)], Maybe (Range Double)) +makePlacedTicks s r = + case s of + TickNone -> ([], Nothing) + TickRound f n e -> + ( zip + ticks0 + (formatNs 4 f ticks0), + bool (space1 ticks0) Nothing (e == NoTickExtend) + ) + where + ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) + TickExact f n -> (zip ticks0 (formatNs 4 f ticks0), Nothing) + where + ticks0 = grid OuterPos r n + TickLabels ls -> + ( zip + ( project (Range 0 (fromIntegral $ length ls)) r + <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) + ) + ls, + Nothing + ) + TickPlaced xs -> (xs, Nothing) + +toTickPlaced :: Range Double -> TickStyle -> (Range Double, TickStyle) +toTickPlaced r t@TickRound {} = (fromMaybe r ext, TickPlaced ts) + where + (ts, ext) = makePlacedTicks t r +toTickPlaced r t = (r, t) + +placeRect :: Place -> Range Double -> Rect Double -> Rect Double +placeRect pl' (Range a0 a1) (Rect x z y w) = case pl' of + PlaceRight -> Rect x z a0 a1 + PlaceLeft -> Rect x z a0 a1 + _ -> Rect a0 a1 y w + +placeRange :: Place -> HudBox -> Range Double +placeRange pl (Rect x z y w) = case pl of + PlaceRight -> Range y w + PlaceLeft -> Range y w + _ -> Range x z + +placeOrigin :: Place -> Double -> Point Double +placeOrigin pl x + | pl == PlaceTop || pl == PlaceBottom = Point x 0 + | otherwise = Point 0 x + +axis :: AxisOptions -> State HudChart ChartTree +axis a = do + t <- makeTick a + b <- maybe (pure mempty) (makeAxisBar (view #place a)) (view #bar a) + pure (group (Just "axis") [t, b]) + +-- | alter a colour with a function +colourHudOptions :: (Colour -> Colour) -> HudOptions -> HudOptions +colourHudOptions f o = + o + & over #frames (fmap (second fFrame)) + & over #titles (fmap (second (over (#style % #color) f))) + & over #axes (fmap (second fAxis)) + & over #legends (fmap (second fLegend)) + where + fAxis :: AxisOptions -> AxisOptions + fAxis a = + a + & over #bar (fmap (over (#style % #color) f)) + & over + (#ticks % #gtick) + (fmap (first (over #color f . over #borderColor f))) + & over + (#ticks % #ttick) + (fmap (first (over #color f))) + & over + (#ticks % #ltick) + (fmap (first (over #color f))) + fLegend :: LegendOptions -> LegendOptions + fLegend a = + a + & over #textStyle (over #color f) + & over #frame (fmap (over #color f . over #borderColor f)) + fFrame :: FrameOptions -> FrameOptions + fFrame a = + a + & over #frame (fmap (over #color f . over #borderColor f)) + +-- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas +data Place + = PlaceLeft + | PlaceRight + | PlaceTop + | PlaceBottom + | PlaceAbsolute (Point Double) + deriving (Show, Eq, Generic) + +-- | textifier +placeText :: Place -> Text +placeText p = + case p of + PlaceTop -> "Top" + PlaceBottom -> "Bottom" + PlaceLeft -> "Left" + PlaceRight -> "Right" + PlaceAbsolute _ -> "Absolute" + +-- | axis options +data AxisOptions = AxisOptions + { bar :: Maybe AxisBar, + adjust :: Maybe Adjustments, + ticks :: Ticks, + place :: Place + } + deriving (Eq, Show, Generic) + +-- | The official axis +defaultAxisOptions :: AxisOptions +defaultAxisOptions = AxisOptions (Just defaultAxisBar) (Just defaultAdjustments) defaultTicks PlaceBottom + +-- | The bar on an axis representing the x or y plane. +-- +-- >>> defaultAxisBar +-- AxisBar {style = RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.05 0.05 0.05 0.40}, size = 4.0e-3, buffer = 1.0e-2, overhang = 2.0e-3} +data AxisBar = AxisBar + { style :: RectStyle, + size :: Double, + buffer :: Double, + -- | extension over the edges of the axis range + overhang :: Double + } + deriving (Show, Eq, Generic) + +-- | The official axis bar +defaultAxisBar :: AxisBar +defaultAxisBar = AxisBar (RectStyle 0 transparent (set opac' 0.4 dark)) 0.004 0.01 0.002 + +-- | Options for titles. Defaults to center aligned, and placed at Top of the hud +-- +-- >>> defaultTitle "title" +-- Title {text = "title", style = TextStyle {size = 0.12, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing}, place = PlaceTop, anchor = AnchorMiddle, buffer = 4.0e-2} +data Title = Title + { text :: Text, + style :: TextStyle, + place :: Place, + anchor :: Anchor, + buffer :: Double + } + deriving (Show, Eq, Generic) + +-- | The official hud title +defaultTitle :: Text -> Title +defaultTitle txt = + Title + txt + ( defaultTextStyle + & #size .~ 0.12 + ) + PlaceTop + AnchorMiddle + 0.04 + +-- | xy coordinate markings +-- +-- >>> defaultTicks +-- Ticks {style = TickRound (FormatN {fstyle = FSCommaPrec, sigFigs = Just 2, addLPad = True}) 8 TickExtend, gtick = Just (GlyphStyle {size = 3.0e-2, color = Colour 0.05 0.05 0.05 0.40, borderColor = Colour 0.05 0.05 0.05 0.40, borderSize = 4.0e-3, shape = VLineGlyph, rotation = Nothing, translate = Nothing},3.0e-2), ttick = Just (TextStyle {size = 5.0e-2, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing},3.3e-2), ltick = Just (LineStyle {size = 5.0e-3, color = Colour 0.05 0.05 0.05 0.05, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},0.0)} +data Ticks = Ticks + { style :: TickStyle, + gtick :: Maybe (GlyphStyle, Double), + ttick :: Maybe (TextStyle, Double), + ltick :: Maybe (LineStyle, Double) + } + deriving (Show, Eq, Generic) + +-- | The official glyph tick +defaultGlyphTick :: GlyphStyle +defaultGlyphTick = + defaultGlyphStyle + & #borderSize .~ 0.004 + & #shape .~ VLineGlyph + & #color .~ set opac' 0.4 dark + & #borderColor .~ set opac' 0.4 dark + +-- | The official text tick +defaultTextTick :: TextStyle +defaultTextTick = + defaultTextStyle & #size .~ 0.05 + +-- | The official line tick +defaultLineTick :: LineStyle +defaultLineTick = + defaultLineStyle + & #size .~ 5.0e-3 + & #color %~ set opac' 0.05 + +-- | The official tick +defaultTicks :: Ticks +defaultTicks = + Ticks + defaultTickStyle + (Just (defaultGlyphTick, 0.03)) + (Just (defaultTextTick, 0.033)) + (Just (defaultLineTick, 0)) + +-- | Style of tick marks on an axis. +data TickStyle + = -- | no ticks on axis + TickNone + | -- | specific labels (equidistant placement) + TickLabels [Text] + | -- | sensibly rounded ticks, a guide to how many, and whether to extend beyond the data bounding box + TickRound FormatN Int TickExtend + | -- | exactly n equally spaced ticks + TickExact FormatN Int + | -- | specific labels and placement + TickPlaced [(Double, Text)] + deriving (Show, Eq, Generic) + +-- | The official tick style +defaultTickStyle :: TickStyle +defaultTickStyle = TickRound defaultFormatN 8 TickExtend + +-- | textifier +tickStyleText :: TickStyle -> Text +tickStyleText TickNone = "TickNone" +tickStyleText TickLabels {} = "TickLabels" +tickStyleText TickRound {} = "TickRound" +tickStyleText TickExact {} = "TickExact" +tickStyleText TickPlaced {} = "TickPlaced" + +-- | Whether Ticks are allowed to extend the data range +data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) + +-- | options for prettifying axis decorations +-- +-- >>> defaultAdjustments +-- Adjustments {maxXRatio = 8.0e-2, maxYRatio = 6.0e-2, angledRatio = 0.12, allowDiagonal = True} +data Adjustments = Adjustments + { maxXRatio :: Double, + maxYRatio :: Double, + angledRatio :: Double, + allowDiagonal :: Bool + } + deriving (Show, Eq, Generic) + +-- | The official hud adjustments. +defaultAdjustments :: Adjustments +defaultAdjustments = Adjustments 0.08 0.06 0.12 True + +-- | Legend options +-- +-- >>> defaultLegendOptions +-- LegendOptions {size = 0.3, buffer = 0.1, vgap = 0.2, hgap = 0.1, textStyle = TextStyle {size = 0.18, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing}, innerPad = 0.1, outerPad = 2.0e-2, frame = Just (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.05 0.05 0.05 1.00, color = Colour 0.05 0.05 0.05 0.00}), place = PlaceRight, overallScale = 0.25, content = []} +-- +data LegendOptions = LegendOptions + { size :: Double, + buffer :: Double, + vgap :: Double, + hgap :: Double, + textStyle :: TextStyle, + innerPad :: Double, + outerPad :: Double, + frame :: Maybe RectStyle, + place :: Place, + overallScale :: Double, + content :: [(Text, Chart)] + } + deriving (Show, Eq, Generic) + +-- | The official legend options +defaultLegendOptions :: LegendOptions +defaultLegendOptions = + LegendOptions + 0.3 + 0.1 + 0.2 + 0.1 + ( defaultTextStyle + & #size .~ 0.18 + ) + 0.1 + 0.02 + (Just (RectStyle 0.01 (set opac' 1 dark) (set opac' 0 dark))) + PlaceRight + 0.25 + [] + +-- | flip an axis from being an X dimension to a Y one or vice-versa. +flipAxis :: AxisOptions -> AxisOptions +flipAxis ac = case ac ^. #place of + PlaceBottom -> ac & #place .~ PlaceLeft + PlaceTop -> ac & #place .~ PlaceRight + PlaceLeft -> ac & #place .~ PlaceBottom + PlaceRight -> ac & #place .~ PlaceTop + PlaceAbsolute _ -> ac + +-- | Options for hud frames +-- +-- >>> defaultFrameOptions +-- FrameOptions {frame = Just (RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 1.00 1.00 1.00 0.02}), buffer = 0.0} +data FrameOptions = FrameOptions + { frame :: Maybe RectStyle, + buffer :: Double + } + deriving (Eq, Show, Generic) + +-- | The official hud frame +defaultFrameOptions :: FrameOptions +defaultFrameOptions = FrameOptions (Just (blob (grey 1 0.02))) 0 + +-- | Make a frame hud transformation. +frameHud :: FrameOptions -> State HudChart ChartTree +frameHud o = do + hc <- get + let r = padRect (view #buffer o) <$> view hudStyleBox' hc + case r of + Nothing -> pure (unnamed []) + Just r' -> pure $ case view #frame o of + Nothing -> blank r' + Just rs -> named "frame" [RectChart rs [r']] + +bar_ :: Place -> AxisBar -> CanvasBox -> HudBox -> Chart +bar_ pl b (Rect x z y w) (Rect x' z' y' w') = + RectChart (view #style b) $ + case pl of + PlaceTop -> + [ Rect + (x - b ^. #overhang) + (z + b ^. #overhang) + (w' + b ^. #buffer) + (w' + b ^. #buffer + b ^. #size) + ] + PlaceBottom -> + [ Rect + (x - b ^. #overhang) + (z + b ^. #overhang) + (y' - b ^. #size - b ^. #buffer) + (y' - b ^. #buffer) + ] + PlaceLeft -> + [ Rect + (x' - b ^. #size - b ^. #buffer) + (x' - b ^. #buffer) + (y - b ^. #overhang) + (w + b ^. #overhang) + ] + PlaceRight -> + [ Rect + (z' + (b ^. #buffer)) + (z' + (b ^. #buffer) + (b ^. #size)) + (y - b ^. #overhang) + (w + b ^. #overhang) + ] + PlaceAbsolute (Point x'' _) -> + [ Rect + (x'' + (b ^. #buffer)) + (x'' + (b ^. #buffer) + (b ^. #size)) + (y - b ^. #overhang) + (w + b ^. #overhang) + ] + +makeAxisBar :: Place -> AxisBar -> State HudChart ChartTree +makeAxisBar pl b = do + cb <- gets (view canvasBox') + hb <- gets (view hudStyleBox') + let c = bar_ pl b <$> cb <*> hb + pure $ named "axisbar" (maybeToList c) + +title_ :: Title -> HudBox -> Chart +title_ t hb = + TextChart + (style' & #rotation .~ bool (Just rot) Nothing (rot == 0)) + [(t ^. #text, addp (placePosTitle t hb) (alignPosTitle t hb))] + where + style' + | t ^. #anchor == AnchorStart = + #anchor .~ AnchorStart $ t ^. #style + | t ^. #anchor == AnchorEnd = + #anchor .~ AnchorEnd $ t ^. #style + | otherwise = t ^. #style + rot' = fromMaybe 0 (t ^. #style % #rotation) + rot + | t ^. #place == PlaceRight = pi / 2 + rot' + | t ^. #place == PlaceLeft = pi / 2 + rot' + | otherwise = rot' + +placePosTitle :: Title -> HudBox -> Point Double +placePosTitle t (Rect x z y w) = + case t ^. #place of + PlaceTop -> Point ((x + z) / 2.0) (w - y' + (t ^. #buffer)) + PlaceBottom -> Point ((x + z) / 2.0) (y - w' - (t ^. #buffer)) + PlaceLeft -> Point (x + y' - (t ^. #buffer)) ((y + w) / 2.0) + PlaceRight -> Point (z + w' + (t ^. #buffer)) ((y + w) / 2.0) + PlaceAbsolute p -> p + where + (Rect _ _ y' w') = styleBoxText (view #style t) (view #text t) zero + +alignPosTitle :: Title -> HudBox -> Point Double +alignPosTitle t (Rect x z y w) + | t ^. #anchor == AnchorStart + && (t ^. #place == PlaceTop || t ^. #place == PlaceBottom) = + Point ((x - z) / 2.0) 0.0 + | t ^. #anchor == AnchorStart + && t ^. #place == PlaceLeft = + Point 0.0 ((y - w) / 2.0) + | t ^. #anchor == AnchorStart + && t ^. #place == PlaceRight = + Point 0.0 ((y - w) / 2.0) + | t ^. #anchor == AnchorEnd + && (t ^. #place == PlaceTop || t ^. #place == PlaceBottom) = + Point ((-x + z) / 2.0) 0.0 + | t ^. #anchor == AnchorEnd + && t ^. #place == PlaceLeft = + Point 0.0 ((-y + w) / 2.0) + | t ^. #anchor == AnchorEnd + && t ^. #place == PlaceRight = + Point 0.0 ((-y + w) / 2.0) + | otherwise = Point 0.0 0.0 + +-- | title append transformation. +title :: Title -> State HudChart ChartTree +title t = do + hb <- gets (view hudStyleBox') + pure $ named "title" (maybeToList $ title_ t <$> hb) + +placePos :: Place -> Double -> HudBox -> Point Double +placePos pl b (Rect x z y w) = case pl of + PlaceTop -> Point 0 (w + b) + PlaceBottom -> Point 0 (y - b) + PlaceLeft -> Point (x - b) 0 + PlaceRight -> Point (z + b) 0 + PlaceAbsolute p -> p + +placeRot :: Place -> Maybe Double +placeRot pl = case pl of + PlaceRight -> Just (pi / 2) + PlaceLeft -> Just (pi / 2) + _ -> Nothing + +textPos :: Place -> TextStyle -> Double -> Point Double +textPos pl tt b = case pl of + PlaceTop -> Point 0 b + PlaceBottom -> Point 0 (-b - 0.5 * (tt ^. #vsize) * (tt ^. #size)) + PlaceLeft -> + Point + (-b) + ((tt ^. #vshift) * (tt ^. #vsize) * (tt ^. #size)) + PlaceRight -> + Point + b + ((tt ^. #vshift) * (tt ^. #vsize) * (tt ^. #size)) + PlaceAbsolute p -> p + +placeTextAnchor :: Place -> (TextStyle -> TextStyle) +placeTextAnchor pl + | pl == PlaceLeft = #anchor .~ AnchorEnd + | pl == PlaceRight = #anchor .~ AnchorStart + | otherwise = id + +placeGridLines :: Place -> HudBox -> Double -> Double -> [Point Double] +placeGridLines pl (Rect x z y w) a b + | pl == PlaceTop || pl == PlaceBottom = [Point a (y - b), Point a (w + b)] + | otherwise = [Point (x - b) a, Point (z + b) a] + +-- | compute tick values and labels given options, ranges and formatting +ticksR :: TickStyle -> Range Double -> Range Double -> [(Double, Text)] +ticksR s d r = + case s of + TickNone -> [] + TickRound f n e -> zip (project r d <$> ticks0) (formatNs 4 f ticks0) + where + ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) + TickExact f n -> zip (project r d <$> ticks0) (formatNs 4 f ticks0) + where + ticks0 = grid OuterPos r n + TickLabels ls -> + zip + ( project (Range 0 (fromIntegral $ length ls)) d + <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) + ) + ls + TickPlaced xs -> zip (project r d . fst <$> xs) (snd <$> xs) + +-- | compute tick values in canvas space given placement, canvas box & data box +ticksPlacedCanvas :: TickStyle -> Place -> CanvasBox -> DataBox -> [(Double, Text)] +ticksPlacedCanvas ts pl cb db = + first (project (placeRange pl db) (placeRange pl cb)) + <$> fst (makePlacedTicks ts (placeRange pl db)) + +tickGlyph_ :: Place -> (GlyphStyle, Double) -> TickStyle -> CanvasBox -> CanvasBox -> DataBox -> Maybe Chart +tickGlyph_ pl (g, b) ts sb cb db = + case l of + [] -> Nothing + l' -> Just $ GlyphChart (g & #rotation .~ placeRot pl) l' + where + l = + addp (placePos pl b sb) . placeOrigin pl + <$> fmap fst (ticksPlacedCanvas ts pl cb db) + +-- | aka marks +tickGlyph :: + Place -> + (GlyphStyle, Double) -> + TickStyle -> + State HudChart ChartTree +tickGlyph pl (g, b) ts = do + sb <- gets (view canvasStyleBox') + cb <- gets (view canvasBox') + db <- gets (view #dataBox) + let c = tickGlyph_ pl (g, b) ts <$> sb <*> cb <*> pure db + pure $ named "tickglyph" (catMaybes $ maybeToList c) + +tickText_ :: + Place -> + (TextStyle, Double) -> + TickStyle -> + CanvasBox -> + CanvasBox -> + DataBox -> + Maybe Chart +tickText_ pl (txts, b) ts sb cb db = + case l of + [] -> Nothing + _ -> Just $ TextChart (placeTextAnchor pl txts) l + where + l = + swap . first (addp (addp (placePos pl b sb) (textPos pl txts b)) . placeOrigin pl) + <$> ticksPlacedCanvas ts pl cb db + +-- | aka tick labels +tickText :: + Place -> + (TextStyle, Double) -> + TickStyle -> + State HudChart ChartTree +tickText pl (txts, b) ts = do + sb <- gets (view canvasStyleBox') + cb <- gets (view canvasBox') + db <- gets (view #dataBox) + let c = tickText_ pl (txts, b) ts <$> sb <*> cb <*> pure db + pure $ named "ticktext" (catMaybes $ maybeToList c) + +-- | aka grid lines +tickLine :: + Place -> + (LineStyle, Double) -> + TickStyle -> + State HudChart ChartTree +tickLine pl (ls, b) ts = do + cb <- gets (view canvasBox') + db <- gets (view #dataBox) + case cb of + Nothing -> pure $ named "ticklines" [] + Just cb' -> do + let l = (\x -> placeGridLines pl cb' x b) <$> fmap fst (ticksPlacedCanvas ts pl cb' db) + pure $ named "ticklines" (bool [LineChart ls l] [] (null l)) + +-- | Create tick glyphs (marks), lines (grid) and text (labels) +applyTicks :: + Place -> + Ticks -> + State HudChart ChartTree +applyTicks pl t = do + g <- maybe (pure mempty) (\x -> tickGlyph pl x (t ^. #style)) (t ^. #gtick) + l <- maybe (pure mempty) (\x -> tickText pl x (t ^. #style)) (t ^. #ttick) + t' <- maybe (pure mempty) (\x -> tickLine pl x (t ^. #style)) (t ^. #ltick) + pure $ group (Just "ticks") [g, l, t'] + +-- | adjust Tick for sane font sizes etc +adjustTicks :: + Adjustments -> + HudBox -> + DataBox -> + Place -> + Ticks -> + Ticks +adjustTicks (Adjustments mrx ma mry ad) vb cs pl t + | pl == PlaceBottom || pl == PlaceTop = + if ad + then + ( case adjustSizeX > 1 of + True -> + ( case pl of + PlaceBottom -> #ttick % _Just % _1 % #anchor .~ AnchorEnd + PlaceTop -> #ttick % _Just % _1 % #anchor .~ AnchorStart + _ -> #ttick % _Just % _1 % #anchor .~ AnchorEnd + ) + . (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) + $ (#ttick % _Just % _1 % #rotation ?~ pi / 4) t + False -> (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) t + ) + else t & #ttick % _Just % _1 % #size %~ (/ adjustSizeX) + | otherwise -- pl `elem` [PlaceLeft, PlaceRight] + = + (#ttick % _Just % _1 % #size %~ (/ adjustSizeY)) t + where + max' [] = 1 + max' xs = maximum xs + ra (Rect x z y w) + | pl == PlaceTop || pl == PlaceBottom = Range x z + | otherwise = Range y w + asp = ra vb + r = ra cs + tickl = snd <$> ticksR (t ^. #style) asp r + maxWidth :: Double + maxWidth = + maybe + 1 + ( \tt -> + max' $ + (\(Rect x z _ _) -> z - x) + . (\x -> styleBoxText (fst tt) x (Point 0 0)) + <$> tickl + ) + (t ^. #ttick) + maxHeight = + maybe + 1 + ( \tt -> + max' $ + (\(Rect _ _ y w) -> w - y) + . (\x -> styleBoxText (fst tt) x (Point 0 0)) + <$> tickl + ) + (t ^. #ttick) + adjustSizeX :: Double + adjustSizeX = max ((maxWidth / (upper asp - lower asp)) / mrx) 1 + adjustSizeY = max ((maxHeight / (upper asp - lower asp)) / mry) 1 + adjustSizeA = max ((maxHeight / (upper asp - lower asp)) / ma) 1 + +makeTick :: AxisOptions -> State HudChart ChartTree +makeTick c = do + hb <- gets (view hudBox') + db <- gets (view #dataBox) + case hb of + Nothing -> pure (named "ticks" []) + Just hb' -> do + let adjTick = maybe (c ^. #ticks) (\x -> adjustTicks x hb' db (c ^. #place) (c ^. #ticks)) (c ^. #adjust) + applyTicks (c ^. #place) adjTick + +-- | Make a legend from 'LegendOptions' +legend :: LegendOptions -> State HudChart ChartTree +legend o = legendHud o (legendChart o) + +-- | Make a legend hud element, from a bespoke ChartTree. +legendHud :: LegendOptions -> ChartTree -> State HudChart ChartTree +legendHud o lcs = do + sb <- gets (view hudStyleBox') + case sb of + Nothing -> pure (named "legend" []) + Just sb' -> pure $ placeLegend o sb' (over chart' (scaleChart (o ^. #overallScale)) lcs) + +placeLegend :: LegendOptions -> HudBox -> ChartTree -> ChartTree +placeLegend o hb t = + case view styleBox' t of + Nothing -> named "legend" [] + Just sb -> t & over chart' (moveChart (placeBeside_ (o ^. #place) (view #buffer o) hb sb)) + +placeBeside_ :: Place -> Double -> Rect Double -> Rect Double -> Point Double +placeBeside_ pl buff (Rect x z y w) (Rect x' z' y' w') = + case pl of + PlaceTop -> Point ((x + z) / 2.0) (buff + w + (w' - y') / 2.0) + PlaceBottom -> Point ((x + z) / 2.0) (y - buff - (w' - y')) + PlaceLeft -> Point (x - buff - (z' - x')) ((y + w) / 2.0) + PlaceRight -> Point (z + buff) ((y + w) / 2.0) + PlaceAbsolute p -> p + +-- | frame a legend +legendFrame :: LegendOptions -> ChartTree -> ChartTree +legendFrame l content' = + group (Just "legend") [named "legendBorder" borders, rename (Just "legendContent") content'] + where + borders = [outer, inner] <> frame' + outer = padChart (view #outerPad l) [inner] + frame' = foldMap (\r -> [frameChart r 0 [inner]]) (view #frame l) + inner = padChart (view #innerPad l) (foldOf charts' content') + +-- | Make the contents portion of a legend +legendChart :: LegendOptions -> ChartTree +legendChart l = legendFrame l content' + where + content' = + vert + (l ^. #hgap) + ( ( \(a, t) -> + hori + ((l ^. #vgap) + twidth - gapwidth t) + (fmap unnamed [[t], [a]]) + ) + <$> es + ) + es = reverse $ uncurry (legendEntry l) <$> view #content l + twidth = maybe zero (\(Rect _ z _ _) -> z) (styleBoxes (snd <$> es)) + gapwidth t = maybe 0 (\(Rect _ z _ _) -> z) (sbox t) + +legendText :: + LegendOptions -> + Text -> + Chart +legendText l t = + TextChart (l ^. #textStyle & #anchor .~ AnchorStart) [(t, zero)] + +legendizeChart :: + LegendOptions -> + Chart -> + Chart +legendizeChart l c = + case c of + (RectChart rs _) -> RectChart rs [Rect 0 (l ^. #size) 0 (l ^. #size)] + (TextChart ts _) -> TextChart (ts & #size .~ (l ^. #size)) [("text", zero)] + (GlyphChart gs _) -> GlyphChart (gs & #size .~ (l ^. #size)) [Point (0.5 * l ^. #size) (0.33 * l ^. #size)] + (LineChart ls _) -> + LineChart + (ls & #size %~ (/ (l ^. #overallScale))) + [[Point 0 (1 * l ^. #size), Point (2 * l ^. #size) (1 * l ^. #size)]] + (PathChart ps _) -> + ( let cs = + singletonQuad + ( QuadPosition + (Point 0 0) + (Point (l ^. #size) (l ^. #size)) + (Point (2 * l ^. #size) ((-1) * l ^. #size)) + ) + in PathChart (ps & #borderSize .~ (l ^. #size)) cs + ) + (BlankChart _) -> BlankChart [Rect 0 (l ^. #size) 0 (l ^. #size)] + +legendEntry :: + LegendOptions -> + Text -> + Chart -> + (Chart, Chart) +legendEntry l t c = + ( legendizeChart l c, + legendText l t + ) diff --git a/src/Chart/Primitive.hs b/src/Chart/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Primitive.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Base 'Chart' and 'ChartTree' types and support +module Chart.Primitive + ( -- * Charts + + Chart (..), + ChartTree (..), + tree', + chart', + charts', + named, + unnamed, + rename, + blank, + group, + filterChartTree, + Orientation (..), + ChartAspect (..), + + -- * Boxes + + -- $boxes + box, + sbox, + projectWith, + maybeProjectWith, + moveChart, + scaleChart, + scaleStyle, + colourChart, + projectChartTree, + boxes, + box', + styleBoxes, + styleBox', + + -- * Combinators + vert, + hori, + stack, + frameChart, + isEmptyChart, + padChart, + rectangularize, + glyphize, + overText, + ) +where + +import Chart.Data +import Chart.Style +import Data.Bifunctor +import Data.Bool +import Data.Colour +import Data.Foldable +import Data.Maybe +import Data.Path +import Data.Text (Text) +import Data.Tree +import GHC.Generics +import qualified NumHask.Prelude as NH +import Optics.Core +import Prelude + +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core +-- >>> let r = RectChart defaultRectStyle [one] + +-- | There are 6 Chart primitives, unified as the Chart type. +-- +-- - 'RectChart': a rectangle in the XY-domain. For example, a @Rect 0 1 0 1@ is the set of points on the XY Plane bounded by (0,0), (0,1), (1,0) & (1,1). Much of the library is built on Rect Double's but the base types are polymorphic. +-- - 'LineChart': a list of points which represent connected straight lines. [Point 0 0, Point 1 1, Point 2 2, Point 3 3] is an example; three lines connected up to form a line from (0,0) to (3,3). +-- - 'GlyphChart': a 'GlyphShape' which is a predefined shaped centered at a 'Point' in XY space. +-- - 'TextChart': text centered at a 'Point' in XY space. +-- - 'PathChart': specification of curvilinear paths using the SVG standards. +-- - 'BlankChart': a rectangular space that has no visual representation. +-- +-- What is a Chart is usually a combination of these primitives into a tree or list of charts. +-- +-- Each Chart primitive is a product of a style (the syntactic representation of the data) and a list of data. +-- +-- A simple example is: +-- +-- >>> let r = RectChart defaultRectStyle [one] +-- >>> r +-- RectChart (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10}) [Rect -0.5 0.5 -0.5 0.5] +-- +-- Using the defaults, this chart is rendered as: +-- +-- > writeChartSvg "other/unit.hs" $ mempty & #hudOptions .~ defaultHudOptions & #charts .~ unnamed [r] +-- +-- ![unit example](other/unit.svg) +data Chart where + RectChart :: RectStyle -> [Rect Double] -> Chart + LineChart :: LineStyle -> [[Point Double]] -> Chart + GlyphChart :: GlyphStyle -> [Point Double] -> Chart + TextChart :: TextStyle -> [(Text, Point Double)] -> Chart + PathChart :: PathStyle -> [PathData Double] -> Chart + BlankChart :: [Rect Double] -> Chart + deriving (Eq, Show) + +-- | A group of charts represented by a 'Tree' of chart lists with labelled branches. The labelling is particularly useful downstream, when groupings become grouped SVG elements with classes or ids. +newtype ChartTree = ChartTree {tree :: Tree (Maybe Text, [Chart])} deriving (Eq, Show, Generic) + +-- | Apply a filter to ChartTree +filterChartTree :: (Chart -> Bool) -> ChartTree -> ChartTree +filterChartTree p (ChartTree (Node (a, cs) xs)) = + ChartTree (Node (a, catMaybes (rem' <$> cs)) (tree . filterChartTree p . ChartTree <$> xs)) + where + rem' x = bool Nothing (Just x) (p x) + +-- | Lens between ChartTree and the underlying Tree representation +tree' :: Iso' ChartTree (Tree (Maybe Text, [Chart])) +tree' = iso tree ChartTree + +-- | A traversal of each chart list in a tree. +charts' :: Traversal' ChartTree [Chart] +charts' = tree' % traversed % _2 + +-- | A traversal of each chart in a tree. +chart' :: Traversal' ChartTree Chart +chart' = tree' % traversed % _2 % traversed + +-- | Convert a chart list to a tree, adding a specific text label. +named :: Text -> [Chart] -> ChartTree +named l cs = ChartTree $ Node (Just l, cs) [] + +-- | Convert a chart list to a tree, with no text label. +unnamed :: [Chart] -> ChartTree +unnamed cs = ChartTree $ Node (Nothing, cs) [] + +-- | Rename a top-level label in a tree. +rename :: Maybe Text -> ChartTree -> ChartTree +rename l (ChartTree (Node (_, cs) xs)) = ChartTree (Node (l, cs) xs) + +-- | A tree with no charts and no label. +blank :: Rect Double -> ChartTree +blank r = unnamed [BlankChart [r]] + +-- | Group a list of trees into a new tree. +group :: Maybe Text -> [ChartTree] -> ChartTree +group name cs = ChartTree $ Node (name, []) (tree <$> cs) + +instance Semigroup ChartTree where + (<>) (ChartTree x@(Node (n, cs) xs)) (ChartTree x'@(Node (n', cs') xs')) = + case (n, n') of + (Nothing, Nothing) -> ChartTree $ Node (Nothing, cs <> cs') (xs <> xs') + _ -> ChartTree $ Node (Nothing, []) [x, x'] + +instance Monoid ChartTree where + mempty = ChartTree $ Node (Nothing, []) [] + +-- $boxes +-- +-- Library functionality (rescaling, combining charts, working out axes and generally putting charts together) is driven by a box model. A box is a rectangular space that bounds chart elements. + +-- | The 'Rect' which encloses the data elements of the chart. /Bounding box/ is a synonym. +-- +-- >>> box r +-- Just Rect -0.5 0.5 -0.5 0.5 +box :: Chart -> Maybe (Rect Double) +box (RectChart _ a) = foldRect a +box (TextChart _ a) = space1 $ snd <$> a +box (LineChart _ a) = space1 $ mconcat a +box (GlyphChart _ a) = space1 a +box (PathChart _ a) = pathBoxes a +box (BlankChart a) = foldRect a + +-- | The bounding box for a chart including both data and style elements. +-- +-- >>> sbox r +-- Just Rect -0.505 0.505 -0.505 0.505 +-- +-- In the above example, the border of the rectangle adds an extra 0.1 to the height and width of the bounding box enclosing the chart. +sbox :: Chart -> Maybe (Rect Double) +sbox (RectChart s a) = foldRect $ padRect (0.5 * view #borderSize s) <$> a +sbox (TextChart s a) = foldRect $ uncurry (styleBoxText s) <$> a +sbox (LineChart s a) = padRect (0.5 * s ^. #size) <$> (space1 $ mconcat a) +sbox (GlyphChart s a) = foldRect $ (\p -> addPoint p (styleBoxGlyph s)) <$> a +sbox (PathChart s a) = padRect (0.5 * view #borderSize s) <$> pathBoxes a +sbox (BlankChart a) = foldRect a + +-- | projects a Chart to a new space from an old rectangular space, preserving linear metric structure. +-- +-- >>> projectWith (fmap (2*) one) one r +-- RectChart (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10}) [Rect -1.0 1.0 -1.0 1.0] +projectWith :: Rect Double -> Rect Double -> Chart -> Chart +projectWith new old (RectChart s a) = RectChart s (projectOnR new old <$> a) +projectWith new old (TextChart s a) = TextChart (projectX s) (second (projectOnP new old) <$> a) + where + projectX :: TextStyle -> TextStyle + projectX s' = case view #scalex s' of + NoScaleX -> s' & over #hsize (* (width ox / width nx)) & over #vsize (* (width ox / width nx)) + ScaleX -> s' & over #size (* (width nx / width ox)) + (Ranges nx _) = new + (Ranges ox _) = old +projectWith new old (LineChart s a) = LineChart s (fmap (projectOnP new old) <$> a) +projectWith new old (GlyphChart s a) = GlyphChart s (projectOnP new old <$> a) +projectWith new old (BlankChart a) = BlankChart (projectOnR new old <$> a) +projectWith new old (PathChart s a) = PathChart s (projectPaths new old a) + +-- | Maybe project a Chart to a new rectangular space from an old rectangular space, if both Rects exist. +maybeProjectWith :: Maybe (Rect Double) -> Maybe (Rect Double) -> Chart -> Chart +maybeProjectWith new old = fromMaybe id (projectWith <$> new <*> old) + +-- | Move a chart. +moveChart :: Point Double -> Chart -> Chart +moveChart p (RectChart s a) = RectChart s (addPoint p <$> a) +moveChart p (TextChart s a) = TextChart s (second (addp p) <$> a) +moveChart p (LineChart s a) = LineChart s (fmap (addp p) <$> a) +moveChart p (GlyphChart s a) = GlyphChart s (addp p <$> a) +moveChart p (PathChart s a) = PathChart s (movePath p <$> a) +moveChart p (BlankChart a) = BlankChart (addPoint p <$> a) + +-- | Scale a chart (effecting both the chart data and the style). +scaleChart :: Double -> Chart -> Chart +scaleChart p (RectChart s a) = + RectChart (s & #borderSize %~ (* p)) (fmap (fmap (* p)) a) +scaleChart p (LineChart s a) = + LineChart (s & #size %~ (* p)) (fmap (fmap (fmap (* p))) a) +scaleChart p (TextChart s a) = + TextChart (s & #size %~ (* p)) (fmap (second (fmap (* p))) a) +scaleChart p (GlyphChart s a) = + GlyphChart (s & #size %~ (* p)) (fmap (fmap (* p)) a) +scaleChart p (PathChart s a) = + PathChart (s & #borderSize %~ (* p)) (scalePath p <$> a) +scaleChart p (BlankChart a) = + BlankChart (fmap (fmap (* p)) a) + +-- | Scale just the chart style. +scaleStyle :: Double -> Chart -> Chart +scaleStyle x (LineChart a d) = LineChart (a & #size %~ (* x)) d +scaleStyle x (RectChart a d) = RectChart (a & #borderSize %~ (* x)) d +scaleStyle x (TextChart a d) = TextChart (a & #size %~ (* x)) d +scaleStyle x (GlyphChart a d) = GlyphChart (a & #size %~ (* x)) d +scaleStyle x (PathChart a d) = PathChart (a & #borderSize %~ (* x)) d +scaleStyle _ (BlankChart d) = BlankChart d + +-- | Modify chart colors, applying to both border and main colors. +colourChart :: (Colour -> Colour) -> Chart -> Chart +colourChart f (RectChart s d) = RectChart s' d + where + s' = s & #color %~ f & #borderColor %~ f +colourChart f (TextChart s d) = TextChart s' d + where + s' = s & #color %~ f +colourChart f (LineChart s d) = LineChart s' d + where + s' = s & #color %~ f +colourChart f (GlyphChart s d) = GlyphChart s' d + where + s' = s & #color %~ f & #borderColor %~ f +colourChart f (PathChart s d) = PathChart s' d + where + s' = s & #color %~ f & #borderColor %~ f +colourChart _ (BlankChart d) = BlankChart d + +-- | Project a chart tree to a new bounding box, guarding against singleton bounds. +projectChartTree :: Rect Double -> [Chart] -> [Chart] +projectChartTree new cs = case styleBoxes cs of + Nothing -> cs + Just b -> projectWith new b <$> cs + +-- | Compute the bounding box of a list of charts. +boxes :: [Chart] -> Maybe (Rect Double) +boxes cs = foldRect $ mconcat $ maybeToList . box <$> cs + +box_ :: ChartTree -> Maybe (Rect Double) +box_ = boxes . foldOf charts' + +rebox_ :: ChartTree -> Maybe (Rect Double) -> ChartTree +rebox_ cs r = + cs + & over chart' (fromMaybe id $ projectWith <$> r <*> box_ cs) + +-- | Lens between a ChartTree and its bounding box. +box' :: Lens' ChartTree (Maybe (Rect Double)) +box' = + lens box_ rebox_ + +-- | Compute the bounding box of the data and style elements contained in a list of charts. +styleBoxes :: [Chart] -> Maybe (Rect Double) +styleBoxes cs = foldRect $ mconcat $ maybeToList . sbox <$> cs + +styleBox_ :: ChartTree -> Maybe (Rect Double) +styleBox_ = styleBoxes . foldOf charts' + +styleRebox_ :: ChartTree -> Maybe (Rect Double) -> ChartTree +styleRebox_ cs r = + cs + & over chart' (fromMaybe id $ projectWith <$> r' <*> box_ cs) + where + r' = (NH.-) <$> r <*> ((NH.-) <$> styleBox_ cs <*> box_ cs) + +-- | Lens between a style bounding box and a ChartTree tree. +-- +-- Note that a round trip may be only approximately isomorphic ie +-- +-- > forall c r. \c -> view styleBox' . set styleBox r c ~= r +-- +-- - SVG is, in general, an additive model eg a border adds a constant amount no matter the scale or aspect. Text charts, in particular, can have small data boxes but large style additions to the box. +-- +-- - rescaling of style here is, in juxtaposition, a multiplicative model. +-- +-- In practice, this can lead to weird corner cases and unrequited distortion. +-- +-- The example below starts with the unit chart, and a simple axis bar, with a dynamic overhang, so that the axis bar represents the x-axis extremity. +-- +-- >>> t1 = unnamed [RectChart defaultRectStyle [one]] +-- >>> x1 h = toChartTree $ mempty & set #charts t1 & set (#hudOptions % #chartAspect) (ChartAspect) & set (#hudOptions % #axes) [(1,defaultAxisOptions & over #bar (fmap (set #overhang h)) & set (#ticks % #ttick) Nothing & set (#ticks % #gtick) Nothing & set (#ticks % #ltick) Nothing)] +-- +-- With a significant overhang, the axis bar dominates the extrema: +-- +-- >>> view styleBox' $ set styleBox' (Just one) (x1 0.1) +-- Just Rect -0.5 0.5 -0.5 0.5 +-- +-- With no overhang, the style additions caused by the chart dominates: +-- +-- >>> view styleBox' $ set styleBox' (Just one) (x1 0) +-- Just Rect -0.5 0.5 -0.5 0.5 +-- +-- In between: +-- +-- >>> view styleBox' $ set styleBox' (Just one) (x1 0.002) +-- Just Rect -0.5000199203187251 0.5000199203187251 -0.5 0.5 +-- +-- +-- If having an exact box is important, try running set styleBox' multiple times eg +-- +-- >>> view styleBox' $ foldr ($) (x1 0.002) (replicate 10 (set styleBox' (Just one))) +-- Just Rect -0.5 0.5000000000000001 -0.5 0.4999999999999999 +styleBox' :: Lens' ChartTree (Maybe (Rect Double)) +styleBox' = + lens styleBox_ styleRebox_ + +-- | Create a frame over some charts with (additive) padding. +-- +-- >>> frameChart defaultRectStyle 0.1 [BlankChart []] +-- RectChart (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10}) [] +frameChart :: RectStyle -> Double -> [Chart] -> Chart +frameChart rs p cs = RectChart rs (maybeToList (padRect p <$> styleBoxes cs)) + +-- | Additive padding, framing or buffering for a chart list. +padChart :: Double -> [Chart] -> Chart +padChart p cs = BlankChart (maybeToList (padRect p <$> styleBoxes cs)) + +-- | Whether a chart is empty of data to be represented. +isEmptyChart :: Chart -> Bool +isEmptyChart (RectChart _ []) = True +isEmptyChart (LineChart _ []) = True +isEmptyChart (GlyphChart _ []) = True +isEmptyChart (TextChart _ []) = True +isEmptyChart (PathChart _ []) = True +isEmptyChart (BlankChart _) = True +isEmptyChart _ = False + +-- | Horizontally stack a list of trees (proceeding to the right) with a gap between +hori :: Double -> [ChartTree] -> ChartTree +hori _ [] = mempty +hori gap cs = foldl' step mempty cs + where + step x c = x <> over chart' (moveChart (Point (widthx x) (aligny x - aligny c))) c + widthx x = case foldOf charts' x of + [] -> zero + xs -> maybe zero (\(Rect x' z' _ _) -> z' - x' + gap) (styleBoxes xs) + aligny x = case foldOf charts' x of + [] -> zero + xs -> maybe zero (\(Rect _ _ y' w') -> (y' + w') / 2) (styleBoxes xs) + +-- | Vertically stack a list of trees (proceeding upwards), aligning them to the left +vert :: Double -> [ChartTree] -> ChartTree +vert _ [] = mempty +vert gap cs = foldl' step mempty cs + where + step x c = x <> over chart' (moveChart (Point (alignx x - alignx c) (widthy x))) c + widthy x = case foldOf charts' x of + [] -> zero + xs -> maybe zero (\(Rect _ _ y' w') -> w' - y' + gap) (styleBoxes xs) + alignx x = case foldOf charts' x of + [] -> zero + xs -> maybe zero (\(Rect x' _ _ _) -> x') (styleBoxes xs) + +-- | Stack a list of tree charts horizontally, then vertically +stack :: Int -> Double -> [ChartTree] -> ChartTree +stack _ _ [] = mempty +stack n gap cs = vert gap (hori gap <$> group' cs []) + where + group' [] acc = reverse acc + group' x acc = group' (drop n x) (take n x : acc) + +-- | Make a new chart tree out of the bounding boxes of a chart tree. +rectangularize :: RectStyle -> ChartTree -> ChartTree +rectangularize r c = group (Just "rectangularize") [over chart' (rectangularize_ r) c] + +rectangularize_ :: RectStyle -> Chart -> Chart +rectangularize_ rs (TextChart s xs) = TextChart (s & #frame .~ Just rs) xs +rectangularize_ rs c = RectChart rs (maybeToList $ sbox c) + +-- | Make a new chart tree out of the data points of a chart tree, using the supplied glyphs. +glyphize :: GlyphStyle -> ChartTree -> ChartTree +glyphize g c = + group (Just "glyphize") [over chart' (glyphize_ g) c] + +glyphize_ :: GlyphStyle -> Chart -> Chart +glyphize_ g (TextChart _ xs) = GlyphChart g (snd <$> xs) +glyphize_ g (PathChart _ xs) = GlyphChart g (pointPath <$> xs) +glyphize_ g (LineChart _ xs) = GlyphChart g (mconcat xs) +glyphize_ g (BlankChart xs) = GlyphChart g (mid <$> xs) +glyphize_ g (RectChart _ xs) = GlyphChart g (mid <$> xs) +glyphize_ g (GlyphChart _ xs) = GlyphChart g xs + +-- | Modify the text in a text chart. +overText :: (TextStyle -> TextStyle) -> Chart -> Chart +overText f (TextChart s xs) = TextChart (f s) xs +overText _ x = x + +-- | Verticle or Horizontal +data Orientation = Vert | Hori deriving (Eq, Show, Generic) + +-- | The basis for the x-y ratio of a chart +-- +-- Default style features tend towards assuming that the usual height of the overall svg image is around 1, and ChartAspect is based on this assumption, so that a ChartAspect of @FixedAspect 1.5@, say, means a height of 1 and a width of 1.5. +data ChartAspect + = -- | Rescale charts to a fixed x-y ratio, inclusive of hud and style features + FixedAspect Double + | -- | Rescale charts to an overall height of 1, preserving the x-y ratio of the data canvas. + CanvasAspect Double + | -- | Rescale charts to a height of 1, preserving the existing x-y ratio of the underlying charts, inclusive of hud and style. + ChartAspect + deriving (Show, Eq, Generic) diff --git a/src/Chart/Reanimate.hs b/src/Chart/Reanimate.hs deleted file mode 100644 --- a/src/Chart/Reanimate.hs +++ /dev/null @@ -1,355 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - --- | Integration of reanimate and chart-svg -module Chart.Reanimate - ( ReanimateConfig (..), - defaultReanimateConfig, - animChartSvg, - ChartReanimate (..), - chartReanimate, - toTreeA, - tree, - treeFromFile, - ) -where - -import Chart as C hiding (Line, renderChartsWith, transform) -import Codec.Picture.Types -import Control.Lens hiding (transform) -import qualified Data.Attoparsec.Text as A -import Data.Maybe -import Data.Text (Text, unpack) -import GHC.Generics -import Graphics.SvgTree as Svg hiding (Text) -import qualified Graphics.SvgTree.PathParser as Svg -import Linear.V2 -import NumHask.Prelude (one) -import Reanimate as Re - --- | global reanimate configuration. --- --- >>> defaultReanimateConfig --- ReanimateConfig {duration = 5.0, background = Just "black", globalFontFamily = Just ["Arial","Helvetica","sans-serif"], globalFontStyle = Just FontStyleNormal, globalAlignment = AlignxMinYMin} -data ReanimateConfig = ReanimateConfig - { duration :: Double, - background :: Maybe Text, - globalFontFamily :: Maybe [Text], - globalFontStyle :: Maybe Svg.FontStyle, - globalAlignment :: Svg.Alignment - } - deriving (Eq, Show, Generic) - --- | -defaultReanimateConfig :: ReanimateConfig -defaultReanimateConfig = ReanimateConfig 5 (Just "black") (Just ["Arial", "Helvetica", "sans-serif"]) (Just FontStyleNormal) AlignxMinYMin - --- | Animate a ChartSvg animation. -animChartSvg :: ReanimateConfig -> (Double -> ChartSvg) -> Animation -animChartSvg cfg cs = - mkAnimation (view #duration cfg) $ toTreeA cfg cs - -globalAtts :: ReanimateConfig -> Svg.DrawAttributes -globalAtts cfg = - mempty - & maybe - id - (\x -> fontFamily .~ Just (fmap unpack x)) - (view #globalFontFamily cfg) - . maybe - id - (\x -> fontStyle .~ Just x) - (view #globalFontStyle cfg) - --- | The output of the raw translation of ChartSvg to a reanimate svg tree. -data ChartReanimate = ChartReanimate - { trees :: [Tree], - box :: Rect Double, - size :: C.Point Double - } - deriving (Eq, Show, Generic) - --- | Render a 'ChartSvg' to 'Tree's, the fitted chart viewbox, and the suggested SVG dimensions -chartReanimate :: ChartSvg -> ChartReanimate -chartReanimate cs = ChartReanimate ts rect' size' - where - (cl'', rect', size') = renderToCRS so cl' - so = view #svgOptions cs - cl' = renderToCharts cs - ts = tree <$> cl'' - --- | convert a ChartSvg animation to a Tree animation. -toTreeA :: ReanimateConfig -> (Double -> ChartSvg) -> Double -> Tree -toTreeA cfg cs x = - reCss (cs x & view (#svgOptions . #cssOptions)) $ - mkGroup $ - (mkBackground . unpack <$> maybeToList (view #background cfg)) - <> [ ( \cr -> - let (Rect x z y w) = - view #box cr - in withViewBox' - (x, y, z - x, w - y) - (PreserveAspectRatio False (view #globalAlignment cfg) Nothing) - $ flipYAxis $ - groupTrees (globalAtts cfg) $ view #trees cr - ) - $ chartReanimate - (cs x) - ] - -reCss :: CssOptions -> (Tree -> Tree) -reCss NoCssOptions = id -reCss UseCssCrisp = Svg.cssApply (Svg.cssRulesOfText "* { shape-rendering: crispEdges; }") -reCss UseGeometricPrecision = Svg.cssApply (Svg.cssRulesOfText "* { shape-rendering: geometricPrecision; }") - -withViewBox' :: (Double, Double, Double, Double) -> Svg.PreserveAspectRatio -> Tree -> Tree -withViewBox' vbox par child = - Re.translate (-screenWidth / 2) (-screenHeight / 2) $ - svgTree - Document - { _documentViewBox = Just vbox, - _documentWidth = Just (Num screenWidth), - _documentHeight = Just (Num screenHeight), - _documentElements = [child], - _documentDescription = "", - _documentLocation = "", - _documentAspectRatio = par - } - --- | Rectange svg -treeRect :: Rect Double -> Tree -treeRect a = - RectangleTree $ rectSvg a defaultSvg - --- | Text svg -treeText :: TextStyle -> Text -> C.Point Double -> Tree -treeText s t p = - TextTree Nothing (textAt (pointSvg p) t) - & maybe id (\x -> drawAttributes %~ rotatePDA x p) (s ^. #rotation) - --- | GlyphShape to svg Tree -treeShape :: GlyphShape -> Double -> C.Point Double -> Tree -treeShape CircleGlyph s p = - CircleTree $ Circle mempty (pointSvg p) (Num (s / 2)) -treeShape SquareGlyph s p = treeRect (move p ((s *) <$> one)) -treeShape (RectSharpGlyph x') s p = - treeRect (move p (C.scale (C.Point s (x' * s)) one)) -treeShape (RectRoundedGlyph x'' rx ry) s p = - RectangleTree - . rectSvg (addPoint p $ C.scale (C.Point s (x'' * s)) one) - . (rectCornerRadius .~ (Just $ Num rx, Just $ Num ry)) - $ defaultSvg -treeShape (TriangleGlyph (C.Point xa ya) (C.Point xb yb) (C.Point xc yc)) s p = - PolygonTree - . (polygonPoints .~ rps) - $ (drawAttributes %~ translateDA p) defaultSvg - where - rps = - [ V2 (s * xa) (-s * ya), - V2 (s * xb) (-s * yb), - V2 (s * xc) (-s * yc) - ] -treeShape (EllipseGlyph x') s p = - EllipseTree $ - Ellipse - mempty - (pointSvg p) - (Num $ s / 2) - (Num $ (x' * s) / 2) -treeShape (VLineGlyph x') s (C.Point x y) = - LineTree $ - Line - (mempty & strokeWidth .~ Just (Num x')) - (pointSvg (C.Point x (y - s / 2))) - (pointSvg (C.Point x (y + s / 2))) -treeShape (HLineGlyph x') s (C.Point x y) = - LineTree $ - Line - (mempty & strokeWidth .~ Just (Num x')) - (pointSvg (C.Point (x - s / 2) y)) - (pointSvg (C.Point (x + s / 2) y)) -treeShape (PathGlyph path) s p = - Svg.PathTree - ( Svg.Path - ( Svg.defaultSvg - & (Svg.drawAttributes %~ scaleDA (C.Point s s) . translateDA p) - ) - (either mempty id $ A.parseOnly Svg.pathParser path) - ) - --- | GlyphStyle to svg Tree -treeGlyph :: GlyphStyle -> C.Point Double -> Tree -treeGlyph s p = - treeShape (s ^. #shape) (s ^. #size) p - & maybe id (\x -> drawAttributes %~ rotatePDA x p) (s ^. #rotation) - --- | line svg -treeLine :: [C.Point Double] -> Tree -treeLine xs = - PolyLineTree - . (polyLinePoints .~ ((\(C.Point x y) -> V2 x (-y)) <$> xs)) - $ defaultSvg - --- | GlyphStyle to svg Tree -treePath :: [PathInfo Double] -> [C.Point Double] -> Tree -treePath s p = - PathTree $ - Path - mempty - ( zipWith - (curry toPathCommand) - s - (fmap (\(C.Point x y) -> C.Point x (-y)) p) - ) - --- | convert a 'Chart' to a 'Tree' -tree :: Chart Double -> Tree -tree (Chart (TextA s ts) xs) = - groupTrees (daText s) (zipWith (treeText s) ts (toPoint <$> xs)) -tree (Chart (GlyphA s) xs) = - groupTrees (daGlyph s) (treeGlyph s . toPoint <$> xs) -tree (Chart (LineA s) xs) = - groupTrees (daLine s) [treeLine (toPoint <$> xs)] -tree (Chart (RectA s) xs) = - groupTrees (daRect s) (treeRect <$> (toRect <$> xs)) -tree (Chart (PathA s pis) xs) = - groupTrees (daPath s) [treePath pis (toPoint <$> xs)] -tree (Chart BlankA _) = - groupTrees mempty [] - --- | add drawing attributes as a group svg wrapping a [Tree] -groupTrees :: DrawAttributes -> [Tree] -> Tree -groupTrees da' tree' = - GroupTree (drawAttributes %~ (<> da') $ groupChildren .~ tree' $ defaultSvg) - --- * DrawAttribute computations - -daRect :: RectStyle -> DrawAttributes -daRect o = - mempty - & (strokeWidth .~ Just (Num (o ^. #borderSize))) - & (strokeColor .~ Just (ColorRef (toPixelRGBA8 $ o ^. #borderColor))) - & (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) - & (fillColor .~ Just (ColorRef (toPixelRGBA8 $ o ^. #color))) - & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) - -daText :: () => TextStyle -> DrawAttributes -daText o = - mempty - & (fontSize .~ Just (Num (o ^. #size))) - & (strokeWidth .~ Just (Num 0)) - & (strokeColor .~ Just FillNone) - & (fillColor .~ Just (ColorRef (toPixelRGBA8 $ o ^. #color))) - & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) - & (textAnchor .~ Just (toTextAnchor $ o ^. #anchor)) - where - toTextAnchor :: Anchor -> Svg.TextAnchor - toTextAnchor AnchorMiddle = TextAnchorMiddle - toTextAnchor AnchorStart = TextAnchorStart - toTextAnchor AnchorEnd = TextAnchorEnd - -daGlyph :: GlyphStyle -> DrawAttributes -daGlyph o = - mempty - & (strokeWidth .~ Just (Num (o ^. #borderSize))) - & ( strokeColor - .~ Just (ColorRef (toPixelRGBA8 $ o ^. #borderColor)) - ) - & (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) - & (fillColor .~ Just (ColorRef (toPixelRGBA8 $ o ^. #color))) - & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) - & maybe id (\(C.Point x y) -> transform ?~ [Translate x (-y)]) (o ^. #translate) - -daLine :: LineStyle -> DrawAttributes -daLine o = - mempty - & (strokeWidth .~ Just (Num (o ^. #width))) - & (strokeColor .~ Just (ColorRef (toPixelRGBA8 $ o ^. #color))) - & (strokeOpacity ?~ realToFrac (opac $ o ^. #color)) - & (fillColor .~ Just FillNone) - & maybe - id - (\x -> strokeLineCap .~ Just (fromLineCap' x)) - (o ^. #linecap) - & maybe - id - (\x -> strokeLineJoin .~ Just (fromLineJoin' x)) - (o ^. #linejoin) - & maybe - id - (\x -> strokeOffset .~ Just (Num x)) - (o ^. #dashoffset) - & maybe - id - (\xs -> strokeDashArray .~ Just (Num <$> xs)) - (o ^. #dasharray) - -fromLineCap' :: LineCap -> Svg.Cap -fromLineCap' LineCapButt = CapButt -fromLineCap' LineCapRound = CapRound -fromLineCap' LineCapSquare = CapSquare - -fromLineJoin' :: C.LineJoin -> Svg.LineJoin -fromLineJoin' LineJoinMiter = JoinMiter -fromLineJoin' LineJoinBevel = JoinBevel -fromLineJoin' LineJoinRound = JoinRound - -daPath :: PathStyle -> DrawAttributes -daPath o = - mempty - & (strokeWidth .~ Just (Num (o ^. #borderSize))) - & ( strokeColor - .~ Just (ColorRef (toPixelRGBA8 $ o ^. #borderColor)) - ) - & (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) - & (fillColor .~ Just (ColorRef (toPixelRGBA8 $ o ^. #color))) - & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) - --- * svg primitives - --- | Convert to reanimate color primitive. -toPixelRGBA8 :: Colour -> PixelRGBA8 -toPixelRGBA8 (Colour r g b o) = - PixelRGBA8 - (fromIntegral (floor $ r * 256 :: Int)) - (fromIntegral (floor $ g * 256 :: Int)) - (fromIntegral (floor $ b * 256 :: Int)) - (fromIntegral (floor $ o * 256 :: Int)) - --- | convert a point to the svg co-ordinate system --- The svg coordinate system has the y-axis going from top to bottom. -pointSvg :: C.Point Double -> (Svg.Number, Svg.Number) -pointSvg (C.Point x y) = (Num x, Num (-y)) - --- | A DrawAttributes to rotate around a point by x degrees. -rotatePDA :: (HasDrawAttributes s) => Double -> C.Point Double -> s -> s -rotatePDA a (C.Point x y) s = s & transform %~ (Just . maybe r (<> r)) - where - r = [Rotate (-a * 180 / pi) (Just (x, -y))] - --- | A DrawAttributes to translate by a Point. -translateDA :: (HasDrawAttributes s) => C.Point Double -> s -> s -translateDA (C.Point x' y') = - transform - %~ (\x -> Just $ maybe [Translate x' (-y')] (<> [Translate x' (-y')]) x) - --- | A DrawAttributes to translate by a Point. -scaleDA :: (HasDrawAttributes s) => C.Point Double -> s -> s -scaleDA (C.Point x' y') = - transform - %~ (\x -> Just $ maybe [Scale x' (Just y')] (<> [Scale x' (Just y')]) x) - --- | convert a Rect to the svg co-ordinate system -rectSvg :: Rect Double -> Svg.Rectangle -> Svg.Rectangle -rectSvg (Rect x z y w) = - (rectUpperLeftCorner .~ (Num x, Num (-w))) - . (rectWidth .~ Just (Num (z - x))) - . (rectHeight .~ Just (Num (w - y))) - --- | import a Tree from a file -treeFromFile :: FilePath -> IO Tree -treeFromFile fp = do - t <- Svg.loadSvgFile fp - pure $ maybe Svg.None Re.unbox t diff --git a/src/Chart/Render.hs b/src/Chart/Render.hs deleted file mode 100644 --- a/src/Chart/Render.hs +++ /dev/null @@ -1,411 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - --- | Rendering charts to SVG. --- --- Note that type signatures are tightened to Double as sane SVG rendering suggests. -module Chart.Render - ( ChartSvg (..), - renderToCharts, - renderToCRS, - chartSvg, - chartSvgDefault, - chartSvgHud, - renderChartsWith, - renderHudChart, - writeChartSvg, - writeChartSvgDefault, - writeChartSvgHud, - svg2Tag, - cssCrisp, - geometricPrecision, - svg, - terms, - makeAttribute, - - -- * low-level conversions - attsRect, - attsText, - attsGlyph, - attsLine, - attsPath, - svgShape, - ) -where - -import Chart.Types -import Control.Lens hiding (transform) -import Data.Colour -import Data.Generics.Labels () -import Data.Path -import Data.Text (Text, pack, unpack) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy -import Lucid -import Lucid.Base -import qualified Lucid.Base as Lucid -import NumHask.Prelude -import NumHask.Space as NH hiding (Element) - --- $setup --- >>> import Control.Lens --- >>> import Chart - --- | Specification of a chart for rendering to SVG -data ChartSvg = ChartSvg - { svgOptions :: SvgOptions, - hudOptions :: HudOptions, - hudList :: [Hud Double], - chartList :: [Chart Double] - } - deriving (Generic) - -instance Semigroup ChartSvg where - (<>) (ChartSvg _ o h c) (ChartSvg s' o' h' c') = - ChartSvg s' (o <> o') (h <> h') (c <> c') - -instance Monoid ChartSvg where - mempty = ChartSvg defaultSvgOptions mempty [] [] - --- * rendering - --- | @svg@ element + svg 2 attributes -svg2Tag :: Term [Attribute] (s -> t) => s -> t -svg2Tag m = - svg_ - [ Lucid.makeAttribute "xmlns" "http://www.w3.org/2000/svg", - Lucid.makeAttribute "xmlns:xlink" "http://www.w3.org/1999/xlink" - ] - m - -renderToSvg :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Html () -renderToSvg csso (Point w' h') (Rect x z y w) cs = - with - ( svg2Tag - ( cssText csso - <> mconcat (svg <$> cs) - ) - ) - [ width_ (pack $ show w'), - height_ (pack $ show h'), - makeAttribute "viewBox" (pack $ show x <> " " <> show (-w) <> " " <> show (z - x) <> " " <> show (w - y)) - ] - -cssText :: CssOptions -> Html () -cssText UseCssCrisp = cssCrisp -cssText UseGeometricPrecision = geometricPrecision -cssText NoCssOptions = mempty - --- | crisp edges css -cssCrisp :: Html () -cssCrisp = style_ [type_ "text/css"] ("* { shape-rendering: crispEdges; }" :: Text) - --- | crisp edges css -geometricPrecision :: Html () -geometricPrecision = style_ [type_ "text/css"] ("* { shape-rendering: geometricPrecision; }" :: Text) - -makeCharts :: ChartAspect -> HudOptions -> [Chart Double] -> [Chart Double] -makeCharts asp ho cs = - let (hs', hc') = makeHud (padBox $ dataBoxes cs) ho - in runHud (initialCanvas asp (cs <> hc')) hs' (cs <> hc') - -renderToCRS :: SvgOptions -> [Chart Double] -> ([Chart Double], Rect Double, Point Double) -renderToCRS so cs = (cs', rect', size') - where - rect' = styleBoxesS cs' & maybe id padRect (so ^. #outerPad) - cs' = - cs - & runHud penult [chartAspectHud (so ^. #chartAspect)] - & maybe - id - (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad))) - (so ^. #chartFrame) - Point w h = NH.width rect' - size' = Point ((so ^. #svgHeight) / h * w) (so ^. #svgHeight) - penult = case so ^. #chartAspect of - FixedAspect _ -> styleBoxesS cs - CanvasAspect _ -> dataBoxesS cs - ChartAspect -> styleBoxesS cs - UnadjustedAspect -> dataBoxesS cs - --- | Consume the ChartSvg and produce the combined huds and charts as a chart list. -renderToCharts :: ChartSvg -> [Chart Double] -renderToCharts cs = makeCharts (view (#svgOptions . #chartAspect) cs) (view #hudOptions cs) (view #chartList cs) - --- | render Charts with the supplied options. -renderChartsWith :: SvgOptions -> [Chart Double] -> Text -renderChartsWith so cs = - Lazy.toStrict $ renderText (renderToSvg (so ^. #cssOptions) size' rect' cs'') - where - rect' = styleBoxesS cs' & maybe id padRect (so ^. #outerPad) - cs' = - cs - & runHud penult [chartAspectHud (so ^. #chartAspect)] - & maybe - id - (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad))) - (so ^. #chartFrame) - cs'' = - foldMap (\c -> [Chart (RectA (blob c)) [RectXY rect']]) (so ^. #background) <> cs' - Point w h = NH.width rect' - size' = Point ((so ^. #svgHeight) / h * w) (so ^. #svgHeight) - penult = case so ^. #chartAspect of - FixedAspect _ -> styleBoxesS cs - CanvasAspect _ -> dataBoxesS cs - ChartAspect -> styleBoxesS cs - UnadjustedAspect -> dataBoxesS cs - --- | render charts with the supplied svg options and huds -renderHudChart :: SvgOptions -> [Hud Double] -> [Chart Double] -> Text -renderHudChart so hs cs = renderChartsWith so (runHud (initialCanvas (so ^. #chartAspect) cs) hs cs) - --- | Render a chart using the supplied svg and hud config. --- --- >>> chartSvg mempty --- "" -chartSvg :: ChartSvg -> Text -chartSvg (ChartSvg so ho hs cs) = renderHudChart so (hs <> hs') (cs <> cs') - where - (hs', cs') = makeHud (padBox $ dataBoxes cs) ho - --- | Render a chart using the default svg options and no hud. --- --- >>> chartSvgDefault [] == chartSvg mempty --- True -chartSvgDefault :: [Chart Double] -> Text -chartSvgDefault cs = chartSvg $ mempty & #chartList .~ cs - --- | Render a chart using default svg and hud options. --- --- >>> chartSvgHud [] == (chartSvg $ mempty & #hudOptions .~ defaultHudOptions) --- True -chartSvgHud :: [Chart Double] -> Text -chartSvgHud cs = - chartSvg $ - mempty - & #hudOptions .~ defaultHudOptions - & #chartList .~ cs - --- | Write to a file. -writeChartSvg :: FilePath -> ChartSvg -> IO () -writeChartSvg fp cs = - writeFile fp (unpack $ chartSvg cs) - --- | Write a chart to a file with default svg options and no hud. -writeChartSvgDefault :: FilePath -> [Chart Double] -> IO () -writeChartSvgDefault fp cs = writeChartSvg fp (mempty & #chartList .~ cs) - --- | Write a chart to a file with default svg and hud options. -writeChartSvgHud :: FilePath -> [Chart Double] -> IO () -writeChartSvgHud fp cs = - writeChartSvg - fp - ( mempty - & #chartList .~ cs - & #hudOptions .~ defaultHudOptions - ) - --- | Rectangle svg -svgRect :: Rect Double -> Lucid.Html () -svgRect (Rect x z y w) = - terms - "rect" - [ width_ (pack $ show $ z - x), - height_ (pack $ show $ w - y), - term "x" (pack $ show x), - term "y" (pack $ show $ -w) - ] - --- | Text svg -svgText :: TextStyle -> Text -> Point Double -> Lucid.Html () -svgText s t p@(Point x y) = - term - "text" - ( [ term "x" (pack $ show x), - term "y" (pack $ show $ -y) - ] - <> foldMap (\x' -> [term "transform" (toRotateText x' p)]) (s ^. #rotation) - ) - (toHtmlRaw t) - --- | line svg -svgLine :: [Point Double] -> Lucid.Html () -svgLine [] = mempty -svgLine xs = terms "polyline" [term "points" (toPointsText xs)] - where - toPointsText xs' = Text.intercalate "\n" $ (\(Point x y) -> pack (show x <> "," <> show (-y))) <$> xs' - --- | GlyphShape to svg Tree -svgShape :: GlyphShape -> Double -> Point Double -> Lucid.Html () -svgShape CircleGlyph s (Point x y) = - terms - "circle" - [ term "cx" (pack $ show x), - term "cy" (pack $ show $ -y), - term "r" (pack $ show $ 0.5 * s) - ] -svgShape SquareGlyph s p = - svgRect (move p ((s *) <$> one)) -svgShape (RectSharpGlyph x') s p = - svgRect (move p (NH.scale (Point s (x' * s)) one)) -svgShape (RectRoundedGlyph x' rx ry) s p = - terms - "rect" - [ term "width" (pack $ show $ z - x), - term "height" (pack $ show $ w - y), - term "x" (pack $ show x), - term "y" (pack $ show $ -w), - term "rx" (pack $ show rx), - term "ry" (pack $ show ry) - ] - where - (Rect x z y w) = move p (NH.scale (Point s (x' * s)) one) -svgShape (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = - terms - "polygon" - [ term "transform" (toTranslateText p), - term "points" (pack $ show (s * xa) <> "," <> show (-(s * ya)) <> " " <> show (s * xb) <> "," <> show (-(s * yb)) <> " " <> show (s * xc) <> "," <> show (-(s * yc))) - ] -svgShape (EllipseGlyph x') s (Point x y) = - terms - "ellipse" - [ term "cx" ((pack . show) x), - term "cy" ((pack . show) $ -y), - term "rx" ((pack . show) $ 0.5 * s), - term "ry" ((pack . show) $ 0.5 * s * x') - ] -svgShape (VLineGlyph _) s (Point x y) = - terms "polyline" [term "points" (pack $ show x <> "," <> show (-(y - s / 2)) <> "\n" <> show x <> "," <> show (-(y + s / 2)))] -svgShape (HLineGlyph _) s (Point x y) = - terms "polyline" [term "points" (pack $ show (x - s / 2) <> "," <> show (-y) <> "\n" <> show (x + s / 2) <> "," <> show (-y))] -svgShape (PathGlyph path) s p = - terms "path" [term "d" path, term "transform" (toTranslateText p <> " " <> toScaleText s)] - --- | GlyphStyle to svg Tree -svgGlyph :: GlyphStyle -> Point Double -> Lucid.Html () -svgGlyph s p = - svgShape (s ^. #shape) (s ^. #size) p - & maybe id (\r -> term "g" [term "transform" (toRotateText r p)]) (s ^. #rotation) - --- | Path svg -svgPath :: [PathInfo Double] -> [Point Double] -> Lucid.Html () -svgPath _ [] = mempty -svgPath _ [_] = mempty -svgPath infos ps = - terms "path" [term "d" (toPathAbsolutes (zip infos ps))] - -svgAtts :: Annotation -> [Attribute] -svgAtts (TextA s _) = attsText s -svgAtts (GlyphA s) = attsGlyph s -svgAtts (LineA s) = attsLine s -svgAtts (RectA s) = attsRect s -svgAtts (PathA s _) = attsPath s -svgAtts BlankA = mempty - -svgHtml :: Chart Double -> Lucid.Html () -svgHtml (Chart (TextA s ts) xs) = - mconcat $ zipWith (\t p -> svgText s t (toPoint p)) ts xs -svgHtml (Chart (GlyphA s) xs) = - mconcat $ svgGlyph s . toPoint <$> xs -svgHtml (Chart (LineA _) xs) = - svgLine $ toPoint <$> xs -svgHtml (Chart (RectA _) xs) = - mconcat $ svgRect . toRect <$> xs -svgHtml (Chart (PathA _ infos) xs) = - svgPath infos $ toPoint <$> xs -svgHtml (Chart BlankA _) = mempty - --- | Low-level conversion of a Chart to svg -svg :: Chart Double -> Lucid.Html () -svg c = term "g" (svgAtts $ c ^. #annotation) (svgHtml c) - --- | Make Lucid Html given term and attributes -terms :: Text -> [Lucid.Attribute] -> Lucid.Html () -terms t = with $ makeXmlElementNoEnd t - --- | RectStyle to Attributes -attsRect :: RectStyle -> [Lucid.Attribute] -attsRect o = - [ term "stroke-width" (pack $ show $ o ^. #borderSize), - term "stroke" (hex $ o ^. #borderColor), - term "stroke-opacity" (pack $ show $ opac $ o ^. #borderColor), - term "fill" (hex $ o ^. #color), - term "fill-opacity" (pack $ show $ opac $ o ^. #color) - ] - --- | TextStyle to Attributes -attsText :: TextStyle -> [Lucid.Attribute] -attsText o = - [ term "stroke-width" "0.0", - term "stroke" "none", - term "fill" (toHex $ o ^. #color), - term "fill-opacity" (pack $ show $ opac $ o ^. #color), - term "font-size" (pack $ show $ o ^. #size), - term "text-anchor" (toTextAnchor $ o ^. #anchor) - ] - where - toTextAnchor :: Anchor -> Text - toTextAnchor AnchorMiddle = "middle" - toTextAnchor AnchorStart = "start" - toTextAnchor AnchorEnd = "end" - --- | GlyphStyle to Attributes -attsGlyph :: GlyphStyle -> [Lucid.Attribute] -attsGlyph o = - [ term "stroke-width" (pack $ show $ o ^. #borderSize), - term "stroke" (toHex $ o ^. #borderColor), - term "stroke-opacity" (pack $ show $ opac $ o ^. #borderColor), - term "fill" (toHex $ o ^. #color), - term "fill-opacity" (pack $ show $ opac $ o ^. #color) - ] - <> foldMap ((: []) . term "transform" . toTranslateText) (o ^. #translate) - --- | LineStyle to Attributes -attsLine :: LineStyle -> [Lucid.Attribute] -attsLine o = - [ term "stroke-width" (pack $ show $ o ^. #width), - term "stroke" (toHex $ o ^. #color), - term "stroke-opacity" (pack $ show $ opac $ o ^. #color), - term "fill" "none" - ] - <> foldMap (\x -> [term "stroke-linecap" (fromLineCap x)]) (o ^. #linecap) - <> foldMap (\x -> [term "stroke-linejoin" (fromLineJoin x)]) (o ^. #linejoin) - <> foldMap (\x -> [term "stroke-dasharray" (fromDashArray x)]) (o ^. #dasharray) - <> foldMap (\x -> [term "stroke-dashoffset" (pack $ show x)]) (o ^. #dashoffset) - --- | PathStyle to Attributes -attsPath :: PathStyle -> [Lucid.Attribute] -attsPath o = - [ term "stroke-width" (pack $ show $ o ^. #borderSize), - term "stroke" (hex $ o ^. #borderColor), - term "stroke-opacity" (pack $ show $ opac $ o ^. #borderColor), - term "fill" (hex $ o ^. #color), - term "fill-opacity" (pack $ show $ opac $ o ^. #color) - ] - --- | includes a flip of the y dimension. -toTranslateText :: Point Double -> Text -toTranslateText (Point x y) = - pack $ - "translate(" <> show x <> ", " <> show (-y) <> ")" - --- | includes reference changes: --- --- - from radians to degrees --- --- - from counter-clockwise is a positive rotation to clockwise is positive --- --- - flip y dimension -toRotateText :: Double -> Point Double -> Text -toRotateText r (Point x y) = - pack $ - "rotate(" <> show (-r * 180 / pi) <> ", " <> show x <> ", " <> show (-y) <> ")" - -toScaleText :: Double -> Text -toScaleText x = - pack $ - "scale(" <> show x <> ")" diff --git a/src/Chart/Style.hs b/src/Chart/Style.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Style.hs @@ -0,0 +1,354 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Stylistic or syntactical options for chart elements. +-- +module Chart.Style + ( -- * RectStyle + RectStyle (..), + defaultRectStyle, + blob, + clear, + border, + + -- * TextStyle + TextStyle (..), + defaultTextStyle, + styleBoxText, + ScaleX (..), + + -- * GlyphStyle + GlyphStyle (..), + defaultGlyphStyle, + styleBoxGlyph, + gpalette1, + ScaleBorder (..), + GlyphShape (..), + glyphText, + + -- * LineStyle + LineStyle (..), + defaultLineStyle, + LineCap (..), + fromLineCap, + toLineCap, + LineJoin (..), + fromLineJoin, + toLineJoin, + fromDashArray, + Anchor (..), + fromAnchor, + toAnchor, + + -- * PathStyle + PathStyle (..), + defaultPathStyle, + ) +where + +import Chart.Data +import Data.Colour +import qualified Data.List as List +import Data.Maybe +import Data.Path +import Data.Path.Parser +import Data.String +import Data.Text (Text, pack) +import qualified Data.Text as Text +import GHC.Generics +import Optics.Core +import Text.HTML.TagSoup (maybeTagText, parseTags) +import Prelude + +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core + +-- | Rectangle styling +-- +-- >>> defaultRectStyle +-- RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10} +-- +-- ![unit example](other/unit.svg) +data RectStyle = RectStyle + { borderSize :: Double, + borderColor :: Colour, + color :: Colour + } + deriving (Show, Eq, Generic) + +-- | the style +defaultRectStyle :: RectStyle +defaultRectStyle = RectStyle 0.01 (palette1a 1 1) (palette1a 0 0.1) + +-- | solid rectangle, no border +-- +-- >>> blob black +-- RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 1.00} +blob :: Colour -> RectStyle +blob = RectStyle 0 transparent + +-- | transparent rect +-- +-- >>> clear +-- RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 0.00} +clear :: RectStyle +clear = RectStyle 0 transparent transparent + +-- | transparent rectangle, with border +-- +-- >>> border 0.01 transparent +-- RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 0.00} +border :: Double -> Colour -> RectStyle +border s c = RectStyle s c transparent + +-- | Text styling +-- +-- >>> defaultTextStyle +-- TextStyle {size = 0.12, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing} +data TextStyle = TextStyle + { size :: Double, + color :: Colour, + anchor :: Anchor, + hsize :: Double, + vsize :: Double, + vshift :: Double, + rotation :: Maybe Double, + scalex :: ScaleX, + frame :: Maybe RectStyle + } + deriving (Show, Eq, Generic) + +-- | Whether to scale text given X-axis scaling +data ScaleX = ScaleX | NoScaleX deriving (Eq, Show, Generic) + +-- | position anchor +data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic) + +-- | text +fromAnchor :: (IsString s) => Anchor -> s +fromAnchor AnchorMiddle = "Middle" +fromAnchor AnchorStart = "Start" +fromAnchor AnchorEnd = "End" + +-- | from text +toAnchor :: (Eq s, IsString s) => s -> Anchor +toAnchor "Middle" = AnchorMiddle +toAnchor "Start" = AnchorStart +toAnchor "End" = AnchorEnd +toAnchor _ = AnchorMiddle + +-- | the offical text style +defaultTextStyle :: TextStyle +defaultTextStyle = + TextStyle 0.12 dark AnchorMiddle 0.45 1.1 (-0.25) Nothing ScaleX Nothing + +-- | the extra area from text styling +styleBoxText :: + TextStyle -> + Text -> + Point Double -> + Rect Double +styleBoxText o t p = mpad $ move p $ maybe flat (`rotationBound` flat) (o ^. #rotation) + where + flat = Rect ((-x' / 2.0) + x' * a') (x' / 2 + x' * a') (-y' / 2 + n1') (y' / 2 + n1') + s = o ^. #size + h = o ^. #hsize + v = o ^. #vsize + n1 = o ^. #vshift + x' = s * h * fromIntegral (sum $ maybe 0 Text.length . maybeTagText <$> parseTags t) + y' = s * v + n1' = -s * n1 + a' = case o ^. #anchor of + AnchorStart -> 0.5 + AnchorEnd -> -0.5 + AnchorMiddle -> 0.0 + mpad = case view #frame o of + Nothing -> id + Just f -> padRect (0.5 * view #borderSize f * view #size o) + +-- | Glyph styling +-- +-- >>> defaultGlyphStyle +-- GlyphStyle {size = 3.0e-2, color = Colour 0.02 0.73 0.80 0.20, borderColor = Colour 0.02 0.29 0.48 1.00, borderSize = 3.0e-3, shape = SquareGlyph, rotation = Nothing, translate = Nothing} +-- +-- ![glyph example](other/glyphs.svg) +data GlyphStyle = GlyphStyle + { -- | glyph radius + size :: Double, + -- | fill color + color :: Colour, + -- | stroke color + borderColor :: Colour, + -- | stroke width (adds a bit to the bounding box) + borderSize :: Double, + shape :: GlyphShape, + rotation :: Maybe Double, + translate :: Maybe (Point Double) + } + deriving (Show, Eq, Generic) + +-- | the offical glyph style +defaultGlyphStyle :: GlyphStyle +defaultGlyphStyle = + GlyphStyle + 0.03 + (palette1a 0 0.2) + (set lightness' 0.4 $ palette1a 1 1) + 0.003 + SquareGlyph + Nothing + Nothing + +-- | Should glyph borders be scaled? +data ScaleBorder = ScaleBorder | NoScaleBorder deriving (Show, Eq, Generic) + +-- | glyph shapes +data GlyphShape + = CircleGlyph + | SquareGlyph + | EllipseGlyph Double + | RectSharpGlyph Double + | RectRoundedGlyph Double Double Double + | -- | line width is determined by borderSize + TriangleGlyph (Point Double) (Point Double) (Point Double) + | VLineGlyph + | HLineGlyph + | PathGlyph Text ScaleBorder + deriving (Show, Eq, Generic) + +-- | textifier +glyphText :: GlyphShape -> Text +glyphText sh = + case sh of + CircleGlyph -> "Circle" + SquareGlyph -> "Square" + TriangleGlyph {} -> "Triangle" + EllipseGlyph _ -> "Ellipse" + RectSharpGlyph _ -> "RectSharp" + RectRoundedGlyph {} -> "RectRounded" + VLineGlyph -> "VLine" + HLineGlyph -> "HLine" + PathGlyph _ _ -> "Path" + +-- | the extra area from glyph styling +styleBoxGlyph :: GlyphStyle -> Rect Double +styleBoxGlyph s = move p' $ + rot' $ + sw $ case sh of + CircleGlyph -> (sz *) <$> one + SquareGlyph -> (sz *) <$> one + EllipseGlyph a -> scale (Point sz (a * sz)) one + RectSharpGlyph a -> scale (Point sz (a * sz)) one + RectRoundedGlyph a _ _ -> scale (Point sz (a * sz)) one + VLineGlyph -> scale (Point (s ^. #borderSize) sz) one + HLineGlyph -> scale (Point sz (s ^. #borderSize)) one + TriangleGlyph a b c -> (sz *) <$> unsafeSpace1 ([a, b, c] :: [Point Double]) + PathGlyph path' _ -> maybe zero (fmap (sz *)) (pathBoxes . svgToPathData $ path') + where + sh = s ^. #shape + sz = s ^. #size + sw = padRect (0.5 * s ^. #borderSize) + p' = fromMaybe (Point 0.0 0.0) (s ^. #translate) + rot' = maybe id rotationBound (view #rotation s) + +-- | Infinite list of glyph shapes +-- +-- >>> gpalette1 0 +-- CircleGlyph +gpalette1 :: Int -> GlyphShape +gpalette1 x = cycle gpalette1_ List.!! x + +-- | finite list of glyphs +gpalette1_ :: [GlyphShape] +gpalette1_ = + [ CircleGlyph, + SquareGlyph, + RectSharpGlyph 0.75, + RectRoundedGlyph 0.75 0.01 0.01, + EllipseGlyph 0.75, + VLineGlyph, + HLineGlyph, + TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), + PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z" ScaleBorder + ] + +-- | line cap style +data LineCap = LineCapButt | LineCapRound | LineCapSquare deriving (Eq, Show, Generic) + +-- | textifier +fromLineCap :: (IsString s) => LineCap -> s +fromLineCap LineCapButt = "butt" +fromLineCap LineCapRound = "round" +fromLineCap LineCapSquare = "square" + +-- | readifier +toLineCap :: (Eq s, IsString s) => s -> LineCap +toLineCap "butt" = LineCapButt +toLineCap "round" = LineCapRound +toLineCap "square" = LineCapSquare +toLineCap _ = LineCapButt + +-- | line cap style +data LineJoin = LineJoinMiter | LineJoinBevel | LineJoinRound deriving (Eq, Show, Generic) + +-- | textifier +fromLineJoin :: (IsString s) => LineJoin -> s +fromLineJoin LineJoinMiter = "miter" +fromLineJoin LineJoinBevel = "bevel" +fromLineJoin LineJoinRound = "round" + +-- | readifier +toLineJoin :: (Eq s, IsString s) => s -> LineJoin +toLineJoin "miter" = LineJoinMiter +toLineJoin "bevel" = LineJoinBevel +toLineJoin "round" = LineJoinRound +toLineJoin _ = LineJoinMiter + +-- | Convert a dash representation from a list to text +fromDashArray :: [Double] -> Text +fromDashArray xs = Text.intercalate " " $ pack . show <$> xs + +-- | line style +-- +-- >>> defaultLineStyle +-- LineStyle {size = 1.2e-2, color = Colour 0.05 0.05 0.05 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing} +-- +-- ![line example](other/line.svg) +-- +-- See also +data LineStyle = LineStyle + { size :: Double, + color :: Colour, + linecap :: Maybe LineCap, + linejoin :: Maybe LineJoin, + dasharray :: Maybe [Double], + dashoffset :: Maybe Double + } + deriving (Show, Eq, Generic) + +-- | the official default line style +defaultLineStyle :: LineStyle +defaultLineStyle = LineStyle 0.012 dark Nothing Nothing Nothing Nothing + +-- | Path styling +-- +-- >>> defaultPathStyle +-- PathStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.66 0.07 0.55 1.00} +data PathStyle = PathStyle + { borderSize :: Double, + borderColor :: Colour, + color :: Colour + } + deriving (Show, Eq, Generic) + +-- | the style +defaultPathStyle :: PathStyle +defaultPathStyle = + PathStyle 0.01 (palette1 1) (palette1 2) diff --git a/src/Chart/Surface.hs b/src/Chart/Surface.hs --- a/src/Chart/Surface.hs +++ b/src/Chart/Surface.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} -- | Surface chart combinators. -- --- A common chart is to present a set of rectangles on the XY plane with colour representing values of the underlying data; a surface chart (often called a heatmap). +-- A common chart is to present a set of rectangles on the XY plane with colour representing values of the underlying data. This library uses the term /surface/ chart but it is often referred to as a heatmap. -- --- 'SurfaceData', the rectangle and the color value, is a different shape to the usual data elements of a chart, so there is a bit more wrangling to do compared with other chart types. module Chart.Surface ( SurfaceData (..), SurfaceOptions (..), @@ -21,20 +19,23 @@ surfacefl, SurfaceLegendOptions (..), defaultSurfaceLegendOptions, + surfaceAxisOptions, ) where -import Chart.Types -import Control.Lens +import Chart.Data +import Chart.Hud +import Chart.Primitive +import Chart.Style import Data.Bifunctor +import Data.Bool import Data.Colour +import Data.Foldable import Data.FormatN -import Data.Generics.Labels () import Data.Text (Text) import GHC.Generics -import GHC.OverloadedLabels -import NumHask.Prelude -import NumHask.Space +import Optics.Core +import Prelude -- | Options for a Surface chart. data SurfaceOptions = SurfaceOptions @@ -52,10 +53,10 @@ defaultSurfaceOptions = SurfaceOptions defaultSurfaceStyle (Point 10 10) one --- | A surface chart is a specialization of a 'RectA' chart +-- | A surface chart is a specialization of a 'RectChart' -- -- >>> defaultSurfaceStyle --- SurfaceStyle {surfaceColors = [Colour 0.69 0.35 0.16 1.00,Colour 0.65 0.81 0.89 1.00], surfaceRectStyle = RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.05 0.05 0.05 1.00}} +-- SurfaceStyle {surfaceColors = [Colour 0.02 0.73 0.80 1.00,Colour 0.02 0.29 0.48 1.00], surfaceRectStyle = RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.05 0.05 0.05 1.00}} -- -- ![surface example](other/surface.svg) data SurfaceStyle = SurfaceStyle @@ -68,7 +69,7 @@ -- | The official surface style. defaultSurfaceStyle :: SurfaceStyle defaultSurfaceStyle = - SurfaceStyle (take 2 palette1_) (blob dark) + SurfaceStyle (palette1 <$> [0 .. 1]) (blob dark) -- | Main surface data elements data SurfaceData = SurfaceData @@ -80,42 +81,45 @@ deriving (Show, Eq, Generic) -- | surface chart without any hud trimmings -surfaces :: RectStyle -> [SurfaceData] -> [Chart Double] +surfaces :: RectStyle -> [SurfaceData] -> [Chart] surfaces rs ps = ( \(SurfaceData r c) -> - Chart - (RectA (rs & #color .~ c)) - [RectXY r] + RectChart + (rs & #color .~ c) + [r] ) <$> ps --- | create surface data from a function on a Point +-- | Create surface data from a function on a Point mkSurfaceData :: (Point Double -> Double) -> Rect Double -> Grid (Rect Double) -> [Colour] -> ([SurfaceData], Range Double) -mkSurfaceData f r g cs = ((\(x, y) -> SurfaceData x (blends y cs)) <$> ps', space1 rs) +mkSurfaceData f r g cs = ((\(x, y) -> SurfaceData x (mixes y cs)) <$> ps', unsafeSpace1 rs) where ps = gridF f r g rs = snd <$> ps - rs' = project (space1 rs :: Range Double) (Range 0 1) <$> rs + rs' = project (unsafeSpace1 rs :: Range Double) (Range 0 1) <$> rs ps' = zip (fst <$> ps) rs' --- | create a surface chart from a function. -surfacef :: (Point Double -> Double) -> SurfaceOptions -> ([Chart Double], Range Double) +-- | Create a surface chart from a function. +surfacef :: (Point Double -> Double) -> SurfaceOptions -> ([Chart], Range Double) surfacef f cfg = - first (surfaces (cfg ^. #soStyle . #surfaceRectStyle)) $ + first (surfaces (cfg ^. #soStyle % #surfaceRectStyle)) $ mkSurfaceData f (cfg ^. #soRange) (cfg ^. #soGrain) - (cfg ^. #soStyle . #surfaceColors) + (toList $ cfg ^. #soStyle % #surfaceColors) -- | Create a surface chart and accompanying legend from a function. -surfacefl :: (Point Double -> Double) -> SurfaceOptions -> SurfaceLegendOptions -> ([Chart Double], [Hud Double]) -surfacefl f po slo = (cs, [legendHud (slo ^. #sloLegendOptions) (surfaceLegendChart dr slo)]) +surfacefl :: (Point Double -> Double) -> SurfaceOptions -> SurfaceLegendOptions -> ([Chart], [Hud]) +surfacefl f po slo = + ( cs, + [Hud 10 (legendHud (slo ^. #sloLegendOptions) (surfaceLegendChart dr slo))] + ) where (cs, dr) = surfacef f po @@ -132,93 +136,87 @@ } deriving (Eq, Show, Generic) -surfaceAxisOptions :: AxisOptions -surfaceAxisOptions = +-- | 'AxisOptions' for a surface chart. +surfaceAxisOptions :: Colour -> AxisOptions +surfaceAxisOptions c = AxisOptions Nothing Nothing - ( Tick - (TickRound (FormatPrec (Just 3)) 4 NoTickExtend) - (Just (defaultGlyphTick & #color .~ dark & #shape .~ VLineGlyph 0.005, 0.01)) - (Just (defaultTextTick, 0.03)) + ( Ticks + (TickRound (FormatN FSPrec (Just 3) True) 4 NoTickExtend) + (Just (defaultGlyphTick & #borderColor .~ c & #color .~ c & #shape .~ VLineGlyph, 0.01)) + (Just (defaultTextTick & #color .~ c, 0.03)) Nothing ) PlaceRight -- | official surface legend options -defaultSurfaceLegendOptions :: Text -> SurfaceLegendOptions -defaultSurfaceLegendOptions t = - SurfaceLegendOptions defaultSurfaceStyle t 0.05 100 surfaceAxisOptions surfaceLegendOptions +defaultSurfaceLegendOptions :: Colour -> Text -> SurfaceLegendOptions +defaultSurfaceLegendOptions c t = + SurfaceLegendOptions defaultSurfaceStyle t 0.05 100 (surfaceAxisOptions c) surfaceLegendOptions surfaceLegendOptions :: LegendOptions surfaceLegendOptions = defaultLegendOptions - & #lplace .~ PlaceRight - & #lscale .~ 0.7 - & #lsize .~ 0.5 + & #place .~ PlaceRight + & #overallScale .~ 0.9 + & #size .~ 0.5 & #vgap .~ 0.05 & #hgap .~ 0.01 & #innerPad .~ 0.05 & #outerPad .~ 0.02 - & #ltext . #hsize .~ 0.5 - & #legendFrame .~ Nothing + & #textStyle % #hsize .~ 0.5 + & #textStyle % #size .~ 0.1 + & #frame .~ Nothing -- | Creation of the classical heatmap glyph within a legend context. -surfaceLegendChart :: Range Double -> SurfaceLegendOptions -> [Chart Double] +surfaceLegendChart :: Range Double -> SurfaceLegendOptions -> ChartTree surfaceLegendChart dataRange l = - padChart (l ^. #sloLegendOptions . #outerPad) - . maybe id (\x -> frameChart x (l ^. #sloLegendOptions . #innerPad)) (l ^. #sloLegendOptions . #legendFrame) - $ hs + legendFrame (view #sloLegendOptions l) hs where - a = makeSurfaceTick l pchart + a = makeSurfaceTick l (named "pchart" pchart) pchart - | l ^. #sloLegendOptions . #lplace == PlaceBottom - || l ^. #sloLegendOptions . #lplace == PlaceTop = + | l ^. #sloLegendOptions % #place == PlaceBottom + || l ^. #sloLegendOptions % #place == PlaceTop = vertGlyph | otherwise = horiGlyph - t = Chart (TextA (l ^. #sloLegendOptions . #ltext & #anchor .~ AnchorStart) [l ^. #sloTitle]) [zero] - hs = vert (l ^. #sloLegendOptions . #vgap) [a, [t]] - vertGlyph :: [Chart Double] + t = TextChart (l ^. #sloLegendOptions % #textStyle & #anchor .~ AnchorStart) [(l ^. #sloTitle, zero)] + hs = vert (l ^. #sloLegendOptions % #vgap) [a, unnamed [t]] + vertGlyph :: [Chart] vertGlyph = zipWith - (\r c -> Chart (RectA $ blob c) [RectXY r]) + (\r c -> RectChart (blob c) [r]) ( (\xr -> Ranges xr (Range 0 (l ^. #sloWidth))) <$> gridSpace dataRange (l ^. #sloResolution) ) - ( (\x -> blends x (l ^. #sloStyle . #surfaceColors)) + ( (\x -> mixes x (toList $ l ^. #sloStyle % #surfaceColors)) <$> grid MidPos (Range 0 1) (l ^. #sloResolution) ) - horiGlyph :: [Chart Double] + horiGlyph :: [Chart] horiGlyph = zipWith - (\r c -> Chart (RectA $ blob c) [RectXY r]) + (\r c -> RectChart (blob c) [r]) ( (\yr -> Ranges (Range 0 (l ^. #sloWidth)) yr) <$> gridSpace dataRange (l ^. #sloResolution) ) - ( (\x -> blends x (l ^. #sloStyle . #surfaceColors)) + ( (\x -> mixes x (toList $ l ^. #sloStyle % #surfaceColors)) <$> grid MidPos (Range 0 1) (l ^. #sloResolution) ) isHori :: SurfaceLegendOptions -> Bool isHori l = - l ^. #sloLegendOptions . #lplace == PlaceBottom - || l ^. #sloLegendOptions . #lplace == PlaceTop + l ^. #sloLegendOptions % #place == PlaceBottom + || l ^. #sloLegendOptions % #place == PlaceTop -makeSurfaceTick :: SurfaceLegendOptions -> [Chart Double] -> [Chart Double] -makeSurfaceTick l pchart = phud - where - r = fromMaybe one (styleBoxes pchart) - r' = bool (Rect 0 (l ^. #sloWidth) 0 (l ^. #sloLegendOptions . #lsize)) (Rect 0 (l ^. #sloLegendOptions . #lsize) 0 (l ^. #sloWidth)) (isHori l) - (hs, _) = - makeHud - r - ( mempty & #hudAxes - .~ [ l ^. #sloAxisOptions - & #place .~ bool PlaceRight PlaceBottom (isHori l) - ] - ) - phud = runHudWith r' r hs pchart +makeSurfaceTick :: SurfaceLegendOptions -> ChartTree -> ChartTree +makeSurfaceTick l pchart = case view styleBox' pchart of + Nothing -> pchart + Just r' -> phud + where + r'' = bool (Rect 0 (l ^. #sloWidth) 0 (l ^. #sloLegendOptions % #size)) (Rect 0 (l ^. #sloLegendOptions % #size) 0 (l ^. #sloWidth)) (isHori l) + (hs, db) = toHuds (mempty & set #chartAspect ChartAspect & set #axes [(9, l ^. #sloAxisOptions & #place .~ bool PlaceRight PlaceBottom (isHori l))]) r' + phud = runHudWith r'' db hs pchart diff --git a/src/Chart/Svg.hs b/src/Chart/Svg.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Svg.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Conversion from a chart to SVG. +-- +module Chart.Svg + ( -- * ChartSvg + ChartSvg (..), + toChartTree, + writeChartSvg, + chartSvg, + initialCanvas, + + -- * SVG Options + SvgOptions (..), + defaultSvgOptions, + + -- * SVG Style primitives + CssOptions (..), + defaultCssOptions, + CssShapeRendering (..), + CssPreferColorScheme (..), + cssShapeRendering, + cssPreferColorScheme, + ) +where + +import Chart.Data +import Chart.Hud +import Chart.Primitive +import Chart.Style +import Data.Colour +import Data.Maybe +import Data.Path +import Data.Path.Parser +import Data.Text (Text, pack, unpack) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import Data.Tree +import GHC.Generics +import Lucid +import Lucid.Base +import NeatInterpolation +import Optics.Core +import Prelude + +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core + +-- helpers +-- +draw :: Chart -> Html () +draw (RectChart _ a) = mconcat $ svgRect_ <$> a +draw (TextChart s a) = mconcat $ uncurry (svgText_ s) <$> a +draw (LineChart _ as) = svgLine_ as +draw (GlyphChart s a) = mconcat $ svgGlyph_ s <$> a +draw (PathChart _ a) = svgPath_ a +draw (BlankChart _) = mempty + +atts :: Chart -> [Attribute] +atts (RectChart s _) = attsRect s +atts (TextChart s _) = attsText s +atts (LineChart s _) = attsLine s +atts (GlyphChart s _) = attsGlyph s +atts (PathChart s _) = attsPath s +atts (BlankChart _) = mempty + +svgChartTree :: ChartTree -> Lucid.Html () +svgChartTree cs + | isNothing label && null cs' = mconcat $ svgChartTree . ChartTree <$> xs + | otherwise = term "g" (foldMap (\x -> [term "class" x]) label) content' + where + (ChartTree (Node (label, cs') xs)) = filterChartTree (not . isEmptyChart) cs + content' = (mconcat $ svg <$> cs') <> (mconcat $ svgChartTree . ChartTree <$> xs) + +-- ** ChartSvg + +-- | Specification of a chart ready to be rendered to SVG includes: +-- +-- - svg options +-- +-- - hud options +-- +-- - any extra hud elements beyond the usual options +-- +-- - an underlying chart tree. +-- +-- See Data.Examples for usage. +data ChartSvg = ChartSvg + { svgOptions :: SvgOptions, + hudOptions :: HudOptions, + extraHuds :: [Hud], + charts :: ChartTree + } + deriving (Generic) + +instance Semigroup ChartSvg where + (<>) (ChartSvg _ o h c) (ChartSvg s' o' h' c') = + ChartSvg s' (o <> o') (h <> h') (c <> c') + +instance Monoid ChartSvg where + mempty = ChartSvg defaultSvgOptions mempty mempty mempty + +-- * rendering + +-- | @svg@ element + svg 2 attributes +svg2Tag :: Term [Attribute] (s -> t) => s -> t +svg2Tag m = + svg_ + [ makeAttribute "xmlns" "http://www.w3.org/2000/svg", + makeAttribute "xmlns:xlink" "http://www.w3.org/1999/xlink" + ] + m + +renderToText :: Html () -> Text +renderToText = Lazy.toStrict . renderText + +renderToSvg :: SvgOptions -> ChartTree -> Html () +renderToSvg so cs = + with + (svg2Tag (cssText (view #cssOptions so) <> svgChartTree cs)) + [ width_ (pack $ show w''), + height_ (pack $ show h''), + makeAttribute "viewBox" (pack $ show x <> " " <> show (-w) <> " " <> show (z - x) <> " " <> show (w - y)) + ] + where + r@(Rect x z y w) = singletonGuard (view styleBox' cs) + Point w' h' = width r + Point w'' h'' = Point ((so ^. #svgHeight) / h' * w') (so ^. #svgHeight) + +-- | Low-level conversion of a Chart to svg +svg :: Chart -> Lucid.Html () +svg (BlankChart _) = mempty +svg c = term "g" (atts c) (draw c) + +cssText :: CssOptions -> Html () +cssText csso = + style_ [] $ + cssShapeRendering (csso ^. #shapeRendering) + <> cssPreferColorScheme (light, dark) (csso ^. #preferColorScheme) + <> csso ^. #cssExtra + +-- | CSS shape rendering text snippet +cssShapeRendering :: CssShapeRendering -> Text +cssShapeRendering UseGeometricPrecision = "svg { shape-rendering: geometricPrecision; }" +cssShapeRendering UseCssCrisp = "svg { shape-rendering: crispEdges; }" +cssShapeRendering NoShapeRendering = mempty + +-- | CSS prefer-color-scheme text snippet +cssPreferColorScheme :: (Colour, Colour) -> CssPreferColorScheme -> Text +cssPreferColorScheme (cl, cd) PreferHud = + [trimming| +svg { + color-scheme: light dark; +} +{ + .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text { + fill: $hexDark; + } + .ticklines g, .tickglyph g, .legendBorder g { + stroke: $hexDark; + } + .legendBorder g { + fill: $hexLight; + } +} +@media (prefers-color-scheme:dark) { + .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text { + fill: $hexLight; + } + .ticklines g, .tickglyph g, .legendBorder g { + stroke: $hexLight; + } + .legendBorder g { + fill: $hexDark; + } +} +|] + where + hexLight = hex cl + hexDark = hex cd +cssPreferColorScheme (bglight, _) PreferLight = + [trimming| + svg { + color-scheme: light dark; + } + @media (prefers-color-scheme:dark) { + svg { + background-color: $c; + } + } + |] + where + c = hex bglight +cssPreferColorScheme (_, bgdark) PreferDark = + [trimming| + svg { + color-scheme: light dark; + } + @media (prefers-color-scheme:light) { + svg { + background-color: $c; + } + } + |] + where + c = hex bgdark +cssPreferColorScheme _ PreferNormal = mempty + +-- | consume the huds transforming a 'ChartSvg' to a 'ChartTree' +toChartTree :: ChartSvg -> ChartTree +toChartTree cs = + runHudWith + (initialCanvas (view (#hudOptions % #chartAspect) cs) (view #charts cs)) + db' + hs' + (view #charts cs <> blank db') + where + (hs, db') = toHuds (view #hudOptions cs) (singletonGuard $ view (#charts % box') cs) + hs' = + hs + <> view #extraHuds cs + +-- | The initial canvas before applying Huds +-- +-- >>> initialCanvas (FixedAspect 1.5) (unnamed [RectChart defaultRectStyle [one]]) +-- Rect -0.75 0.75 -0.5 0.5 +initialCanvas :: ChartAspect -> ChartTree -> CanvasBox +initialCanvas (FixedAspect a) _ = aspect a +initialCanvas (CanvasAspect a) _ = aspect a +initialCanvas ChartAspect cs = singletonGuard $ view box' cs + +-- | Render a chart using the supplied svg and hud config. +-- +-- >>> chartSvg mempty +-- "" +chartSvg :: ChartSvg -> Text +chartSvg cs = renderToText (renderToSvg (view #svgOptions cs) (toChartTree cs)) + +-- | Write to a file. +writeChartSvg :: FilePath -> ChartSvg -> IO () +writeChartSvg fp cs = + writeFile fp (unpack $ chartSvg cs) + +-- | Make Lucid Html given term and attributes +terms :: Text -> [Lucid.Attribute] -> Lucid.Html () +terms t = with $ makeXmlElementNoEnd t + +-- | Rectangle svg +svgRect_ :: Rect Double -> Lucid.Html () +svgRect_ (Rect x z y w) = + terms + "rect" + [ width_ (pack $ show $ z - x), + height_ (pack $ show $ w - y), + term "x" (pack $ show x), + term "y" (pack $ show $ -w) + ] + +-- | Text svg +svgText_ :: TextStyle -> Text -> Point Double -> Lucid.Html () +svgText_ s t p@(Point x y) = + term + "text" + ( [ term "x" (pack $ show x), + term "y" (pack $ show $ -y) + ] + <> foldMap (\x' -> [term "transform" (toRotateText x' p)]) (s ^. #rotation) + ) + (toHtmlRaw t) + <> case view #frame s of + Nothing -> mempty + Just f -> svg (RectChart (f & over #borderSize (* view #size s)) [styleBoxText s t p]) + +-- | line svg +svgLine_ :: [[Point Double]] -> Lucid.Html () +svgLine_ xss = + mconcat $ + (\xs -> terms "polyline" [term "points" (toPointsText xs)]) <$> xss + where + toPointsText xs' = Text.intercalate "\n" $ (\(Point x y) -> pack (show x <> "," <> show (-y))) <$> xs' + +-- | GlyphShape to svg Tree +svgShape_ :: GlyphShape -> Double -> Point Double -> Lucid.Html () +svgShape_ CircleGlyph s (Point x y) = + terms + "circle" + [ term "cx" (pack $ show x), + term "cy" (pack $ show $ -y), + term "r" (pack $ show $ 0.5 * s) + ] +svgShape_ SquareGlyph s p = + svgRect_ (move p ((s *) <$> one)) +svgShape_ (RectSharpGlyph x') s p = + svgRect_ (move p (scale (Point s (x' * s)) one)) +svgShape_ (RectRoundedGlyph x' rx ry) s p = + terms + "rect" + [ term "width" (pack $ show $ z - x), + term "height" (pack $ show $ w - y), + term "x" (pack $ show x), + term "y" (pack $ show $ -w), + term "rx" (pack $ show rx), + term "ry" (pack $ show ry) + ] + where + (Rect x z y w) = move p (scale (Point s (x' * s)) one) +svgShape_ (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = + terms + "polygon" + [ term "transform" (toTranslateText p), + term "points" (pack $ show (s * xa) <> "," <> show (-(s * ya)) <> " " <> show (s * xb) <> "," <> show (-(s * yb)) <> " " <> show (s * xc) <> "," <> show (-(s * yc))) + ] +svgShape_ (EllipseGlyph x') s (Point x y) = + terms + "ellipse" + [ term "cx" ((pack . show) x), + term "cy" ((pack . show) $ -y), + term "rx" ((pack . show) $ 0.5 * s), + term "ry" ((pack . show) $ 0.5 * s * x') + ] +svgShape_ VLineGlyph s (Point x y) = + terms "polyline" [term "points" (pack $ show x <> "," <> show (-(y - s / 2)) <> "\n" <> show x <> "," <> show (-(y + s / 2)))] +svgShape_ HLineGlyph s (Point x y) = + terms "polyline" [term "points" (pack $ show (x - s / 2) <> "," <> show (-y) <> "\n" <> show (x + s / 2) <> "," <> show (-y))] +svgShape_ (PathGlyph path _) s p = + terms "path" [term "d" path, term "transform" (toTranslateText p <> " " <> toScaleText s)] + +-- | GlyphStyle to svg Tree +svgGlyph_ :: GlyphStyle -> Point Double -> Lucid.Html () +svgGlyph_ s p = + svgShape_ (s ^. #shape) (s ^. #size) p + & maybe id (\r -> term "g" [term "transform" (toRotateText r p)]) (s ^. #rotation) + +-- | Path svg +svgPath_ :: [PathData Double] -> Lucid.Html () +svgPath_ ps = + terms "path" [term "d" (pathDataToSvg ps)] + +-- | RectStyle to Attributes +attsRect :: RectStyle -> [Lucid.Attribute] +attsRect o = + [ term "stroke-width" (pack $ show $ o ^. #borderSize), + term "stroke" (showRGB $ o ^. #borderColor), + term "stroke-opacity" (pack $ show $ opac $ o ^. #borderColor), + term "fill" (showRGB $ o ^. #color), + term "fill-opacity" (pack $ show $ opac $ o ^. #color) + ] + +-- | TextStyle to Attributes +attsText :: TextStyle -> [Lucid.Attribute] +attsText o = + [ term "stroke-width" "0.0", + term "stroke" "none", + term "fill" (showRGB $ o ^. #color), + term "fill-opacity" (pack $ show $ opac $ o ^. #color), + term "font-size" (pack $ show $ o ^. #size), + term "text-anchor" (toTextAnchor $ o ^. #anchor) + ] + where + toTextAnchor :: Anchor -> Text + toTextAnchor AnchorMiddle = "middle" + toTextAnchor AnchorStart = "start" + toTextAnchor AnchorEnd = "end" + +-- | GlyphStyle to Attributes +attsGlyph :: GlyphStyle -> [Lucid.Attribute] +attsGlyph o = + [ term "stroke-width" (pack $ show sw), + term "stroke" (showRGB $ o ^. #borderColor), + term "stroke-opacity" (pack $ show $ opac $ o ^. #borderColor), + term "fill" (showRGB $ o ^. #color), + term "fill-opacity" (pack $ show $ opac $ o ^. #color) + ] + <> foldMap ((: []) . term "transform" . toTranslateText) (o ^. #translate) + where + sw = case o ^. #shape of + PathGlyph _ NoScaleBorder -> o ^. #borderSize + PathGlyph _ ScaleBorder -> min 0.2 (o ^. #borderSize / o ^. #size) + _ -> o ^. #borderSize + +-- | LineStyle to Attributes +attsLine :: LineStyle -> [Lucid.Attribute] +attsLine o = + [ term "stroke-width" (pack $ show $ o ^. #size), + term "stroke" (showRGB $ o ^. #color), + term "stroke-opacity" (pack $ show $ opac $ o ^. #color), + term "fill" "none" + ] + <> foldMap (\x -> [term "stroke-linecap" (fromLineCap x)]) (o ^. #linecap) + <> foldMap (\x -> [term "stroke-linejoin" (fromLineJoin x)]) (o ^. #linejoin) + <> foldMap (\x -> [term "stroke-dasharray" (fromDashArray x)]) (o ^. #dasharray) + <> foldMap (\x -> [term "stroke-dashoffset" (pack $ show x)]) (o ^. #dashoffset) + +-- | PathStyle to Attributes +attsPath :: PathStyle -> [Lucid.Attribute] +attsPath o = + [ term "stroke-width" (pack $ show $ o ^. #borderSize), + term "stroke" (showRGB $ o ^. #borderColor), + term "stroke-opacity" (pack $ show $ opac $ o ^. #borderColor), + term "fill" (showRGB $ o ^. #color), + term "fill-opacity" (pack $ show $ opac $ o ^. #color) + ] + +-- | includes a flip of the y dimension. +toTranslateText :: Point Double -> Text +toTranslateText (Point x y) = + pack $ + "translate(" <> show x <> ", " <> show (-y) <> ")" + +-- | includes reference changes: +-- +-- - from radians to degrees +-- +-- - from counter-clockwise is a positive rotation to clockwise is positive +-- +-- - flip y dimension +toRotateText :: Double -> Point Double -> Text +toRotateText r (Point x y) = + pack $ + "rotate(" <> show (-r * 180 / pi) <> ", " <> show x <> ", " <> show (-y) <> ")" + +toScaleText :: Double -> Text +toScaleText x = + pack $ + "scale(" <> show x <> ")" + +-- | SVG tag options. +-- +-- >>> defaultSvgOptions +-- SvgOptions {svgHeight = 300.0, cssOptions = CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, cssExtra = ""}} +data SvgOptions = SvgOptions + { svgHeight :: Double, + cssOptions :: CssOptions + } + deriving (Eq, Show, Generic) + +-- | The official svg options +defaultSvgOptions :: SvgOptions +defaultSvgOptions = SvgOptions 300 defaultCssOptions + +-- | CSS shape rendering options +data CssShapeRendering = UseGeometricPrecision | UseCssCrisp | NoShapeRendering deriving (Show, Eq, Generic) + +-- | CSS prefer-color-scheme options +data CssPreferColorScheme + = -- | includes css that switches approriate hud elements between light and dark. + PreferHud + | PreferDark + | PreferLight + | PreferNormal + deriving (Show, Eq, Generic) + +-- | css options +-- +-- >>> defaultCssOptions +-- CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, cssExtra = ""} +data CssOptions = CssOptions {shapeRendering :: CssShapeRendering, preferColorScheme :: CssPreferColorScheme, cssExtra :: Text} deriving (Show, Eq, Generic) + +-- | No special shape rendering and default hud responds to user color scheme preferences. +defaultCssOptions :: CssOptions +defaultCssOptions = CssOptions NoShapeRendering PreferHud mempty diff --git a/src/Chart/Types.hs b/src/Chart/Types.hs deleted file mode 100644 --- a/src/Chart/Types.hs +++ /dev/null @@ -1,1685 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - --- | Chart API -module Chart.Types - ( -- * Chart - Chart (..), - moveChart, - projectXYs, - projectXYsWith, - projectArcPosition, - - -- * Annotation - Annotation (..), - annotationText, - scaleAnn, - scaleOpacAnn, - colourAnn, - padRect, - - -- * Styles - RectStyle (..), - defaultRectStyle, - blob, - clear, - border, - TextStyle (..), - defaultTextStyle, - GlyphStyle (..), - defaultGlyphStyle, - GlyphShape (..), - glyphText, - LineStyle (..), - defaultLineStyle, - LineCap (..), - fromLineCap, - toLineCap, - LineJoin (..), - fromLineJoin, - toLineJoin, - fromDashArray, - Anchor (..), - fromAnchor, - toAnchor, - PathStyle (..), - toPathChart, - defaultPathStyle, - - -- * Hud types - ChartDims (..), - HudT (..), - Hud, - simulHud, - HudOptions (..), - defaultHudOptions, - colourHudOptions, - scaleOpacHudOptions, - defaultCanvas, - runHudWith, - runHud, - makeHud, - ChartAspect (..), - toChartAspect, - fromChartAspect, - initialCanvas, - chartAspectHud, - canvas, - title, - tick, - - -- * Hud primitives - AxisOptions (..), - defaultAxisOptions, - flipAxis, - Place (..), - placeText, - AxisBar (..), - defaultAxisBar, - Title (..), - defaultTitle, - Tick (..), - defaultGlyphTick, - defaultTextTick, - defaultLineTick, - defaultTick, - TickStyle (..), - defaultTickStyle, - tickStyleText, - TickExtend (..), - adjustTick, - makeTickDates, - makeTickDatesContinuous, - Adjustments (..), - defaultAdjustments, - LegendOptions (..), - defaultLegendOptions, - legendHud, - Orientation (..), - fromOrientation, - toOrientation, - - -- * SVG primitives - CssOptions (..), - SvgOptions (..), - defaultSvgOptions, - defaultSvgFrame, - - -- * Chart manipulation - padChart, - frameChart, - frameAllCharts, - hori, - vert, - stack, - - -- * Bounding box calculation - padBox, - dataBox, - dataBoxes, - dataBoxesS, - styleBox, - styleBoxes, - styleBoxesS, - styleBoxText, - styleBoxGlyph, - ) -where - -import Control.Lens -import Control.Monad.State.Lazy -import Data.Bifunctor -import Data.Bool -import Data.Colour -import Data.Foldable hiding (sum) -import Data.FormatN -import Data.Generics.Labels () -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe -import Data.Path -import Data.String -import Data.Text (Text, pack) -import qualified Data.Text as Text -import Data.Time -import GHC.Generics -import GHC.OverloadedLabels -import NumHask.Prelude -import NumHask.Space as NH hiding (Element) -import Text.HTML.TagSoup hiding (Attribute) - --- $setup --- --- >>> :set -XOverloadedLabels --- >>> import Control.Lens --- >>> import Chart --- >>> import Chart.Render --- >>> import Data.Colour - --- * Chart - --- | A `Chart` is annotated xy-data. -data Chart a = Chart - { -- | annotation style for the data - annotation :: Annotation, - -- | list of data elements, either points or rectangles. - xys :: [XY a] - } - deriving (Eq, Show, Generic) - --- | How data will be represented onscreen. --- --- The definition of what might be an Annotation type is opinionated. --- --- More complex combinations across Annotations can be constructed from combining charts. See 'Chart.Example.glinesExample', 'Chart.Examples.lglyphExample' and "Chart.Bar" for examples. --- --- There may be exceptions, but the approximate magnitude of annotation values are in reference to the size of the screen. For example, a size of 0.01 (say), will means about 1% of the height and/or width of the screen height or width. -data Annotation - = RectA RectStyle - | TextA TextStyle [Text] - | GlyphA GlyphStyle - | LineA LineStyle - | PathA PathStyle [PathInfo Double] - | BlankA - deriving (Eq, Show, Generic) - --- | textifier -annotationText :: Annotation -> Text -annotationText (RectA _) = "RectA" -annotationText TextA {} = "TextA" -annotationText (GlyphA _) = "GlyphA" -annotationText (LineA _) = "LineA" -annotationText PathA {} = "PathA" -annotationText BlankA = "BlankA" - --- | dim (or brighten) the opacity of an Annotation by a scale -scaleOpacAnn :: Double -> Annotation -> Annotation -scaleOpacAnn x (RectA s) = RectA s' - where - s' = s & #color %~ scaleOpac x & #borderColor %~ scaleOpac x -scaleOpacAnn x (TextA s ts) = TextA s' ts - where - s' = s & #color %~ scaleOpac x -scaleOpacAnn x (LineA s) = LineA s' - where - s' = s & #color %~ scaleOpac x -scaleOpacAnn x (GlyphA s) = GlyphA s' - where - s' = s & #color %~ scaleOpac x & #borderColor %~ scaleOpac x -scaleOpacAnn x (PathA s pis) = PathA s' pis - where - s' = s & #color %~ scaleOpac x & #borderColor %~ scaleOpac x -scaleOpacAnn _ BlankA = BlankA - -scaleOpac :: Double -> Colour -> Colour -scaleOpac x (Colour r g b o') = Colour r g b (o' * x) - --- | select a main colour -colourAnn :: Colour -> Annotation -> Annotation -colourAnn c (RectA s) = RectA s' - where - s' = s & #color %~ mix c & #borderColor %~ mix c -colourAnn c (TextA s ts) = TextA s' ts - where - s' = s & #color %~ mix c -colourAnn c (LineA s) = LineA s' - where - s' = s & #color %~ mix c -colourAnn c (GlyphA s) = GlyphA s' - where - s' = s & #color %~ mix c & #borderColor %~ mix c -colourAnn c (PathA s pis) = PathA s' pis - where - s' = s & #color %~ mix c & #borderColor %~ mix c -colourAnn _ BlankA = BlankA - --- | Rectangle styling --- --- >>> defaultRectStyle --- RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.65 0.81 0.89 1.00, color = Colour 0.12 0.47 0.71 1.00} --- --- ![unit example](other/unit.svg) -data RectStyle = RectStyle - { borderSize :: Double, - borderColor :: Colour, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the style -defaultRectStyle :: RectStyle -defaultRectStyle = RectStyle 0.01 (palette1 1) (palette1 2) - --- | solid rectangle, no border --- --- >>> blob black --- RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 1.00} -blob :: Colour -> RectStyle -blob = RectStyle 0 transparent - --- | transparent rect --- --- >>> clear --- RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 0.00} -clear :: RectStyle -clear = RectStyle 0 transparent transparent - --- | transparent rectangle, with border --- --- >>> border 0.01 transparent --- RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 0.00} -border :: Double -> Colour -> RectStyle -border s c = RectStyle s c transparent - --- | Text styling --- --- >>> defaultTextStyle --- TextStyle {size = 8.0e-2, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing} --- --- >>> import qualified Data.Text as Text --- >>> let t = zipWith (\x y -> Chart (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) [x]) [PointXY y]) (fmap Text.singleton ['a' .. 'y']) [Point (sin (x * 0.1)) x | x <- [0 .. 25]] --- --- ![text example](other/text.svg) -data TextStyle = TextStyle - { size :: Double, - color :: Colour, - anchor :: Anchor, - hsize :: Double, - vsize :: Double, - nudge1 :: Double, - rotation :: Maybe Double - } - deriving (Show, Eq, Generic) - --- | position anchor -data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic) - --- | text -fromAnchor :: (IsString s) => Anchor -> s -fromAnchor AnchorMiddle = "Middle" -fromAnchor AnchorStart = "Start" -fromAnchor AnchorEnd = "End" - --- | from text -toAnchor :: (Eq s, IsString s) => s -> Anchor -toAnchor "Middle" = AnchorMiddle -toAnchor "Start" = AnchorStart -toAnchor "End" = AnchorEnd -toAnchor _ = AnchorMiddle - --- | the offical text style -defaultTextStyle :: TextStyle -defaultTextStyle = - TextStyle 0.08 dark AnchorMiddle 0.5 1.45 -0.2 Nothing - --- | Glyph styling --- --- >>> defaultGlyphStyle --- GlyphStyle {size = 3.0e-2, color = Colour 0.65 0.81 0.89 1.00, borderColor = Colour 0.12 0.47 0.71 1.00, borderSize = 3.0e-3, shape = SquareGlyph, rotation = Nothing, translate = Nothing} --- --- ![glyph example](other/glyphs.svg) -data GlyphStyle = GlyphStyle - { -- | glyph radius - size :: Double, - -- | fill color - color :: Colour, - -- | stroke color - borderColor :: Colour, - -- | stroke width (adds a bit to the bounding box) - borderSize :: Double, - shape :: GlyphShape, - rotation :: Maybe Double, - translate :: Maybe (Point Double) - } - deriving (Show, Eq, Generic) - --- | the offical glyph style -defaultGlyphStyle :: GlyphStyle -defaultGlyphStyle = - GlyphStyle - 0.03 - (palette1 1) - (palette1 2) - 0.003 - SquareGlyph - Nothing - Nothing - --- | glyph shapes -data GlyphShape - = CircleGlyph - | SquareGlyph - | EllipseGlyph Double - | RectSharpGlyph Double - | RectRoundedGlyph Double Double Double - | TriangleGlyph (Point Double) (Point Double) (Point Double) - | VLineGlyph Double - | HLineGlyph Double - | PathGlyph Text - deriving (Show, Eq, Generic) - --- | textifier -glyphText :: GlyphShape -> Text -glyphText sh = - case sh of - CircleGlyph -> "Circle" - SquareGlyph -> "Square" - TriangleGlyph {} -> "Triangle" - EllipseGlyph _ -> "Ellipse" - RectSharpGlyph _ -> "RectSharp" - RectRoundedGlyph {} -> "RectRounded" - VLineGlyph _ -> "VLine" - HLineGlyph _ -> "HLine" - PathGlyph _ -> "Path" - --- | line cap style -data LineCap = LineCapButt | LineCapRound | LineCapSquare deriving (Eq, Show, Generic) - --- | textifier -fromLineCap :: (IsString s) => LineCap -> s -fromLineCap LineCapButt = "butt" -fromLineCap LineCapRound = "round" -fromLineCap LineCapSquare = "square" - --- | readifier -toLineCap :: (Eq s, IsString s) => s -> LineCap -toLineCap "butt" = LineCapButt -toLineCap "round" = LineCapRound -toLineCap "square" = LineCapSquare -toLineCap _ = LineCapButt - --- | line cap style -data LineJoin = LineJoinMiter | LineJoinBevel | LineJoinRound deriving (Eq, Show, Generic) - --- | textifier -fromLineJoin :: (IsString s) => LineJoin -> s -fromLineJoin LineJoinMiter = "miter" -fromLineJoin LineJoinBevel = "bevel" -fromLineJoin LineJoinRound = "round" - --- | readifier -toLineJoin :: (Eq s, IsString s) => s -> LineJoin -toLineJoin "miter" = LineJoinMiter -toLineJoin "bevel" = LineJoinBevel -toLineJoin "round" = LineJoinRound -toLineJoin _ = LineJoinMiter - --- | Convert a dash representation from a list to text -fromDashArray :: [Double] -> Text -fromDashArray xs = Text.intercalate " " $ pack . show <$> xs - --- | line style --- --- >>> defaultLineStyle --- LineStyle {width = 1.2e-2, color = Colour 0.05 0.05 0.05 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing} --- --- ![line example](other/line.svg) --- --- See also -data LineStyle = LineStyle - { width :: Double, - color :: Colour, - linecap :: Maybe LineCap, - linejoin :: Maybe LineJoin, - dasharray :: Maybe [Double], - dashoffset :: Maybe Double - } - deriving (Show, Eq, Generic) - --- | the official default line style -defaultLineStyle :: LineStyle -defaultLineStyle = LineStyle 0.012 dark Nothing Nothing Nothing Nothing - --- | Path styling --- --- >>> defaultPathStyle --- PathStyle {borderSize = 1.0e-2, borderColor = Colour 0.65 0.81 0.89 1.00, color = Colour 0.12 0.47 0.71 1.00} -data PathStyle = PathStyle - { borderSize :: Double, - borderColor :: Colour, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the style -defaultPathStyle :: PathStyle -defaultPathStyle = - PathStyle 0.01 (palette1 1) (palette1 2) - --- | Convert from a path command list to a PathA chart -toPathChart :: PathStyle -> [(PathInfo Double, Point Double)] -> Chart Double -toPathChart ps xs = Chart (PathA ps (fst <$> xs)) (PointXY . snd <$> xs) - --- | Verticle or Horizontal -data Orientation = Vert | Hori deriving (Eq, Show, Generic) - --- | textifier -fromOrientation :: (IsString s) => Orientation -> s -fromOrientation Hori = "Hori" -fromOrientation Vert = "Vert" - --- | readifier -toOrientation :: (Eq s, IsString s) => s -> Orientation -toOrientation "Hori" = Hori -toOrientation "Vert" = Vert -toOrientation _ = Hori - --- | additive padding -padRect :: (Subtractive a) => a -> Rect a -> Rect a -padRect p (Rect x z y w) = Rect (x - p) (z + p) (y - p) (w + p) - --- | -data CssOptions = UseGeometricPrecision | UseCssCrisp | NoCssOptions deriving (Show, Eq, Generic) - --- | The basis for the x-y ratio of the final chart --- --- Default style features tend towards assuming that the usual height of the overall svg image is around 1, and ChartAspect is based on this assumption, so that a ChartAspect of "FixedAspect 1.5", say, means a height of 1 and a width of 1.5. -data ChartAspect - = -- | Rescale charts to a fixed x-y ratio, inclusive of hud and style features - FixedAspect Double - | -- | Rescale charts to an overall height of 1, preserving the x-y ratio of the data canvas. - CanvasAspect Double - | -- | Rescale charts to a height of 1, preserving the existing x-y ratio of the underlying charts, inclusive of hud and style. - ChartAspect - | -- | Do not rescale. - UnadjustedAspect - deriving (Show, Eq, Generic) - --- | textifier -fromChartAspect :: (IsString s) => ChartAspect -> s -fromChartAspect (FixedAspect _) = "FixedAspect" -fromChartAspect (CanvasAspect _) = "CanvasAspect" -fromChartAspect ChartAspect = "ChartAspect" -fromChartAspect UnadjustedAspect = "UnadjustedAspect" - --- | readifier -toChartAspect :: (Eq s, IsString s) => s -> Double -> ChartAspect -toChartAspect "FixedAspect" a = FixedAspect a -toChartAspect "CanvasAspect" a = CanvasAspect a -toChartAspect "ChartAspect" _ = ChartAspect -toChartAspect "UnadjustedAspect" _ = UnadjustedAspect -toChartAspect _ _ = ChartAspect - --- | calculation of the canvas given the 'ChartAspect' -initialCanvas :: ChartAspect -> [Chart Double] -> Rect Double -initialCanvas (FixedAspect a) _ = aspect a -initialCanvas (CanvasAspect a) _ = aspect a -initialCanvas ChartAspect cs = aspect $ ratio $ styleBoxesS cs -initialCanvas UnadjustedAspect cs = dataBoxesS cs - --- | SVG tag options. --- --- >>> defaultSvgOptions --- SvgOptions {svgHeight = 300.0, outerPad = Just 2.0e-2, innerPad = Nothing, chartFrame = Nothing, cssOptions = NoCssOptions, chartAspect = FixedAspect 1.5, background = Nothing} --- --- --- ![svgoptions example](other/svgoptions.svg) -data SvgOptions = SvgOptions - { svgHeight :: Double, - outerPad :: Maybe Double, - innerPad :: Maybe Double, - chartFrame :: Maybe RectStyle, - cssOptions :: CssOptions, - chartAspect :: ChartAspect, - background :: Maybe Colour - } - deriving (Eq, Show, Generic) - --- | The official svg options -defaultSvgOptions :: SvgOptions -defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoCssOptions (FixedAspect 1.5) Nothing - --- | frame style -defaultSvgFrame :: RectStyle -defaultSvgFrame = border 0.01 dark - --- | Dimensions that are tracked in the 'HudT': --- --- - chartDim: the rectangular dimension of the physical representation of a chart on the screen so that new hud elements can be appended. Adding a hud piece tends to expand the chart dimension. --- --- - canvasDim: the rectangular dimension of the canvas on which data will be represented. At times appending a hud element will cause the canvas dimension to shift. --- --- - dataDim: the rectangular dimension of the data being represented. Adding hud elements can cause this to change. -data ChartDims a = ChartDims - { chartDim :: Rect a, - canvasDim :: Rect a, - dataDim :: Rect a - } - deriving (Eq, Show, Generic) - --- | Hud monad transformer -newtype HudT m a = Hud {unhud :: [Chart a] -> StateT (ChartDims a) m [Chart a]} - --- | Heads-Up-Display for a 'Chart' -type Hud = HudT Identity - -instance (Monad m) => Semigroup (HudT m a) where - (<>) (Hud h1) (Hud h2) = Hud $ h1 >=> h2 - -instance (Monad m) => Monoid (HudT m a) where - mempty = Hud pure - --- | run two hud's simultaneously (using the same original ChartDims state) rather than sequentially (which is the <> operation). -simulHud :: (Ord a, Monad m) => HudT m a -> HudT m a -> HudT m a -simulHud (Hud fa) (Hud fb) = Hud $ \cs -> do - s <- get - (cs', ChartDims ch ca d) <- lift $ runStateT (fa cs) s - (cs'', ChartDims ch' ca' d') <- lift $ runStateT (fb cs') s - put (ChartDims (ch <> ch') (ca <> ca') (d <> d')) - pure cs'' - --- | Project the chart data given the ChartAspect -chartAspectHud :: (Monad m) => ChartAspect -> HudT m Double -chartAspectHud fa = Hud $ \cs -> do - canvasd <- use #canvasDim - chartd <- use #chartDim - case fa of - FixedAspect a -> pure $ projectXYs (aspect a) cs - CanvasAspect a -> - pure $ - projectXYs (aspect (a * ratio canvasd / ratio chartd)) cs - ChartAspect -> pure $ projectXYs (aspect $ ratio chartd) cs - UnadjustedAspect -> pure cs - --- | Combine huds and charts to form a new Chart using the supplied initial canvas and data dimensions. Note that chart data is transformed by this computation (and the use of a linear type is an open question). -runHudWith :: - -- | initial canvas dimension - Rect Double -> - -- | initial data dimension - Rect Double -> - -- | huds to add - [Hud Double] -> - -- | underlying chart - [Chart Double] -> - -- | integrated chart list - [Chart Double] -runHudWith ca xs hs cs = - evalState - ((unhud $ mconcat hs) cs') - (ChartDims ca' da' xs) - where - da' = fromMaybe one $ dataBoxes cs' - ca' = fromMaybe one $ styleBoxes cs' - cs' = projectXYsWith ca xs cs - --- | Combine huds and charts to form a new [Chart] using the supplied canvas and the actual data dimension. --- --- Note that the original chart data are transformed and irrevocably lost by this computation. -runHud :: - -- | initial canvas dimension - Rect Double -> - -- | huds - [Hud Double] -> - -- | underlying charts - [Chart Double] -> - -- | integrated chart list - [Chart Double] -runHud ca hs cs = runHudWith ca (padBox $ dataBoxes cs) hs cs - --- | Typical configurable hud elements. Anything else can be hand-coded as a 'HudT'. --- --- ![hud example](other/hudoptions.svg) -data HudOptions = HudOptions - { hudCanvas :: Maybe RectStyle, - hudTitles :: [Title], - hudAxes :: [AxisOptions], - hudLegend :: Maybe (LegendOptions, [(Annotation, Text)]) - } - deriving (Eq, Show, Generic) - -instance Semigroup HudOptions where - (<>) (HudOptions c t a l) (HudOptions c' t' a' l') = - HudOptions (listToMaybe $ catMaybes [c, c']) (t <> t') (a <> a') (listToMaybe $ catMaybes [l, l']) - -instance Monoid HudOptions where - mempty = HudOptions Nothing [] [] Nothing - --- | The official hud options. -defaultHudOptions :: HudOptions -defaultHudOptions = - HudOptions - (Just defaultCanvas) - [] - [ defaultAxisOptions, - defaultAxisOptions & #place .~ PlaceLeft - ] - Nothing - --- | alter the colour -colourHudOptions :: Colour -> HudOptions -> HudOptions -colourHudOptions c ho = - ho - & #hudCanvas %~ fmap (#color %~ mix c) - & #hudTitles %~ fmap (#style . #color %~ mix c) - & #hudAxes %~ fmap (#axisBar %~ fmap (#rstyle . #color %~ mix c)) - & #hudAxes %~ fmap (#axisTick . #gtick %~ fmap (first ((#color %~ mix c) . (#borderColor %~ mix c)))) - & #hudAxes %~ fmap (#axisTick . #ttick %~ fmap (first (#color %~ mix c))) - & #hudAxes %~ fmap (#axisTick . #ltick %~ fmap (first (#color %~ mix c))) - & #hudLegend %~ fmap (first (#ltext %~ (#color %~ mix c))) - & #hudLegend %~ fmap (first (#legendFrame %~ fmap ((#color %~ mix c) . (#borderColor %~ mix c)))) - --- | adjust the opacity of HudOptions up or down geometrically (scaling by (*o)) -scaleOpacHudOptions :: HudOptions -> Double -> HudOptions -scaleOpacHudOptions ho o = - ho - & #hudCanvas %~ fmap (#color %~ scaleOpac o) - & #hudTitles %~ fmap (#style . #color %~ scaleOpac o) - & #hudAxes %~ fmap (#axisBar %~ fmap (#rstyle . #color %~ scaleOpac o)) - & #hudAxes %~ fmap (#axisTick . #gtick %~ fmap (first ((#color %~ scaleOpac o) . (#borderColor %~ scaleOpac o)))) - & #hudAxes %~ fmap (#axisTick . #ttick %~ fmap (first (#color %~ scaleOpac o))) - & #hudAxes %~ fmap (#axisTick . #ltick %~ fmap (first (#color %~ scaleOpac o))) - & #hudLegend %~ fmap (first (#ltext %~ (#color %~ scaleOpac o))) - & #hudLegend %~ fmap (first (#legendFrame %~ fmap ((#color %~ scaleOpac o) . (#borderColor %~ scaleOpac o)))) - & #hudLegend %~ fmap (second (fmap (first (scaleOpacAnn o)))) - --- | colour reset but scaling opacity -mix :: Colour -> Colour -> Colour -mix (Colour r g b o') (Colour _ _ _ o) = Colour r g b (o' * o) - --- | The official hud canvas -defaultCanvas :: RectStyle -defaultCanvas = blob (setOpac 0.05 dark) - --- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas -data Place - = PlaceLeft - | PlaceRight - | PlaceTop - | PlaceBottom - | PlaceAbsolute (Point Double) - deriving (Show, Eq, Generic) - --- | textifier -placeText :: Place -> Text -placeText p = - case p of - PlaceTop -> "Top" - PlaceBottom -> "Bottom" - PlaceLeft -> "Left" - PlaceRight -> "Right" - PlaceAbsolute _ -> "Absolute" - --- | axis options -data AxisOptions = AxisOptions - { axisBar :: Maybe AxisBar, - adjust :: Maybe Adjustments, - axisTick :: Tick, - place :: Place - } - deriving (Eq, Show, Generic) - --- | The official axis -defaultAxisOptions :: AxisOptions -defaultAxisOptions = AxisOptions (Just defaultAxisBar) (Just defaultAdjustments) defaultTick PlaceBottom - --- | The bar on an axis representing the x or y plane. --- --- >>> defaultAxisBar --- AxisBar {rstyle = RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.05 0.05 0.05 0.40}, wid = 4.0e-3, buff = 1.0e-2} -data AxisBar = AxisBar - { rstyle :: RectStyle, - wid :: Double, - buff :: Double - } - deriving (Show, Eq, Generic) - --- | The official axis bar -defaultAxisBar :: AxisBar -defaultAxisBar = AxisBar (RectStyle 0 transparent (setOpac 0.4 dark)) 0.004 0.01 - --- | Options for titles. Defaults to center aligned, and placed at Top of the hud --- --- >>> defaultTitle "title" --- Title {text = "title", style = TextStyle {size = 0.12, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing}, place = PlaceTop, anchor = AnchorMiddle, buff = 4.0e-2} -data Title = Title - { text :: Text, - style :: TextStyle, - place :: Place, - anchor :: Anchor, - buff :: Double - } - deriving (Show, Eq, Generic) - --- | The official hud title -defaultTitle :: Text -> Title -defaultTitle txt = - Title - txt - ( defaultTextStyle - & #size .~ 0.12 - ) - PlaceTop - AnchorMiddle - 0.04 - --- | xy coordinate markings --- --- >>> defaultTick --- Tick {tstyle = TickRound (FormatComma (Just 2)) 8 TickExtend, gtick = Just (GlyphStyle {size = 3.0e-2, color = Colour 0.05 0.05 0.05 0.40, borderColor = Colour 0.05 0.05 0.05 0.40, borderSize = 2.0e-3, shape = VLineGlyph 5.0e-3, rotation = Nothing, translate = Nothing},1.25e-2), ttick = Just (TextStyle {size = 5.0e-2, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing},1.5e-2), ltick = Just (LineStyle {width = 5.0e-3, color = Colour 0.05 0.05 0.05 0.05, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},0.0)} -data Tick = Tick - { tstyle :: TickStyle, - gtick :: Maybe (GlyphStyle, Double), - ttick :: Maybe (TextStyle, Double), - ltick :: Maybe (LineStyle, Double) - } - deriving (Show, Eq, Generic) - --- | The official glyph tick -defaultGlyphTick :: GlyphStyle -defaultGlyphTick = - defaultGlyphStyle - & #borderSize .~ 0.002 - & #shape .~ VLineGlyph 0.005 - & #color .~ setOpac 0.4 dark - & #borderColor .~ setOpac 0.4 dark - --- | The official text tick -defaultTextTick :: TextStyle -defaultTextTick = - defaultTextStyle & #size .~ 0.05 - --- | The official line tick -defaultLineTick :: LineStyle -defaultLineTick = - defaultLineStyle - & #width .~ 5.0e-3 - & #color %~ setOpac 0.05 - --- | The official tick -defaultTick :: Tick -defaultTick = - Tick - defaultTickStyle - (Just (defaultGlyphTick, 0.0125)) - (Just (defaultTextTick, 0.015)) - (Just (defaultLineTick, 0)) - --- | Style of tick marks on an axis. -data TickStyle - = -- | no ticks on axis - TickNone - | -- | specific labels (equidistant placement) - TickLabels [Text] - | -- | sensibly rounded ticks, a guide to how many, and whether to extend beyond the data bounding box - TickRound FormatN Int TickExtend - | -- | exactly n equally spaced ticks - TickExact FormatN Int - | -- | specific labels and placement - TickPlaced [(Double, Text)] - deriving (Show, Eq, Generic) - --- | The official tick style -defaultTickStyle :: TickStyle -defaultTickStyle = TickRound (FormatComma (Just 2)) 8 TickExtend - --- | textifier -tickStyleText :: TickStyle -> Text -tickStyleText TickNone = "TickNone" -tickStyleText TickLabels {} = "TickLabels" -tickStyleText TickRound {} = "TickRound" -tickStyleText TickExact {} = "TickExact" -tickStyleText TickPlaced {} = "TickPlaced" - --- | Whether Ticks are allowed to extend the data range -data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) - --- | options for prettifying axis decorations --- --- >>> defaultAdjustments --- Adjustments {maxXRatio = 8.0e-2, maxYRatio = 6.0e-2, angledRatio = 0.12, allowDiagonal = True} -data Adjustments = Adjustments - { maxXRatio :: Double, - maxYRatio :: Double, - angledRatio :: Double, - allowDiagonal :: Bool - } - deriving (Show, Eq, Generic) - --- | The official hud adjustments. -defaultAdjustments :: Adjustments -defaultAdjustments = Adjustments 0.08 0.06 0.12 True - --- | Legend options --- --- >>> defaultLegendOptions --- LegendOptions {lsize = 0.3, vgap = 0.2, hgap = 0.1, ltext = TextStyle {size = 0.12, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing}, lmax = 10, innerPad = 0.1, outerPad = 2.0e-2, legendFrame = Just (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.05 0.05 0.05 1.00, color = Colour 0.05 0.05 0.05 0.00}), lplace = PlaceRight, lscale = 0.25} --- --- ![legend example](other/legend.svg) -data LegendOptions = LegendOptions - { lsize :: Double, - vgap :: Double, - hgap :: Double, - ltext :: TextStyle, - lmax :: Int, - innerPad :: Double, - outerPad :: Double, - legendFrame :: Maybe RectStyle, - lplace :: Place, - lscale :: Double - } - deriving (Show, Eq, Generic) - --- | The official legend options -defaultLegendOptions :: LegendOptions -defaultLegendOptions = - LegendOptions - 0.3 - 0.2 - 0.1 - ( defaultTextStyle - & #size .~ 0.12 - ) - 10 - 0.1 - 0.02 - (Just (RectStyle 0.01 (setOpac 1 dark) (setOpac 0 dark))) - PlaceRight - 0.25 - --- | Generically scale an Annotation. -scaleAnn :: Double -> Annotation -> Annotation -scaleAnn x (LineA a) = LineA $ a & #width %~ (* x) -scaleAnn x (RectA a) = RectA $ a & #borderSize %~ (* x) -scaleAnn x (TextA a txs) = TextA (a & #size %~ (* x)) txs -scaleAnn x (GlyphA a) = GlyphA (a & #size %~ (* x)) -scaleAnn x (PathA a pxs) = PathA (a & #borderSize %~ (* x)) pxs -scaleAnn _ BlankA = BlankA - --- | Translate the data in a chart. -moveChart :: (Additive a) => XY a -> [Chart a] -> [Chart a] -moveChart sp = fmap (#xys %~ fmap (sp +)) - --- | Make huds from a HudOptions. --- --- Some huds, such as the creation of tick values, can extend the data dimension of a chart, so we return a blank chart with the new data dimension. --- The complexity internally to this function is due to the creation of ticks and, specifically, 'gridSensible', which is not idempotent. As a result, a tick calculation that does extends the data area, can then lead to new tick values when applying TickRound etc. -makeHud :: Rect Double -> HudOptions -> ([Hud Double], [Chart Double]) -makeHud xs cfg = - ([axes] <> can <> titles <> l, xsext) - where - xs' = padBox (Just xs) - can = foldMap (\x -> [canvas x]) (cfg ^. #hudCanvas) - titles = title <$> (cfg ^. #hudTitles) - ticks = - (\a -> freezeTicks (a ^. #place) xs' (a ^. #axisTick . #tstyle)) - <$> (cfg ^. #hudAxes) - hudaxes = - zipWith - (\c t -> c & #axisTick . #tstyle .~ fst t) - (cfg ^. #hudAxes) - ticks - tickRects = catMaybes (snd <$> ticks) - xsext = bool [Chart BlankA (RectXY <$> tickRects)] [] (null tickRects) - axes = - foldr simulHud mempty $ - ( \x -> - maybe mempty (makeAxisBar (x ^. #place)) (x ^. #axisBar) - <> makeTick x - ) - <$> hudaxes - l = - foldMap - (\(lo, ats) -> [legendHud lo (legendChart ats lo)]) - (cfg ^. #hudLegend) - --- | convert TickRound to TickPlaced -freezeTicks :: Place -> Rect Double -> TickStyle -> (TickStyle, Maybe (Rect Double)) -freezeTicks pl xs' ts@TickRound {} = maybe (ts, Nothing) (\x -> (TickPlaced (zip ps ls), Just x)) ((\x -> replaceRange pl x xs') <$> ext) - where - (TickComponents ps ls ext) = makeTicks ts (placeRange pl xs') - replaceRange :: Place -> Range Double -> Rect Double -> Rect Double - replaceRange pl' (Range a0 a1) (Rect x z y w) = case pl' of - PlaceRight -> Rect x z a0 a1 - PlaceLeft -> Rect x z a0 a1 - _ -> Rect a0 a1 y w -freezeTicks _ _ ts = (ts, Nothing) - --- | flip an axis from being an X dimension to a Y one or vice-versa. -flipAxis :: AxisOptions -> AxisOptions -flipAxis ac = case ac ^. #place of - PlaceBottom -> ac & #place .~ PlaceLeft - PlaceTop -> ac & #place .~ PlaceRight - PlaceLeft -> ac & #place .~ PlaceBottom - PlaceRight -> ac & #place .~ PlaceTop - PlaceAbsolute _ -> ac - -addToRect :: (Ord a) => Rect a -> Maybe (Rect a) -> Rect a -addToRect r r' = sconcat $ r :| maybeToList r' - --- | Make a canvas hud element. -canvas :: (Monad m) => RectStyle -> HudT m Double -canvas s = Hud $ \cs -> do - a <- use #canvasDim - let c = Chart (RectA s) [RectXY a] - #canvasDim .= addToRect a (styleBox c) - pure $ c : cs - -axisBar_ :: Place -> AxisBar -> Rect Double -> Rect Double -> Chart Double -axisBar_ pl b (Rect x z y w) (Rect x' z' y' w') = - case pl of - PlaceTop -> - Chart - (RectA (rstyle b)) - [ R - x - z - (w' + b ^. #buff) - (w' + b ^. #buff + b ^. #wid) - ] - PlaceBottom -> - Chart - (RectA (rstyle b)) - [ R - x - z - (y' - b ^. #wid - b ^. #buff) - (y' - b ^. #buff) - ] - PlaceLeft -> - Chart - (RectA (rstyle b)) - [ R - (x' - b ^. #wid - b ^. #buff) - (x' - b ^. #buff) - y - w - ] - PlaceRight -> - Chart - (RectA (rstyle b)) - [ R - (z' + (b ^. #buff)) - (z' + (b ^. #buff) + (b ^. #wid)) - y - w - ] - PlaceAbsolute (Point x'' _) -> - Chart - (RectA (rstyle b)) - [ R - (x'' + (b ^. #buff)) - (x'' + (b ^. #buff) + (b ^. #wid)) - y - w - ] - -makeAxisBar :: (Monad m) => Place -> AxisBar -> HudT m Double -makeAxisBar pl b = Hud $ \cs -> do - da <- use #chartDim - ca <- use #canvasDim - let c = axisBar_ pl b ca da - #chartDim .= addChartBox c da - pure $ c : cs - -title_ :: Title -> Rect Double -> Chart Double -title_ t a = - Chart - ( TextA - ( style' - & #rotation ?~ rot - ) - [t ^. #text] - ) - [PointXY (placePos' a + alignPos a)] - where - style' - | t ^. #anchor == AnchorStart = - #anchor .~ AnchorStart $ t ^. #style - | t ^. #anchor == AnchorEnd = - #anchor .~ AnchorEnd $ t ^. #style - | otherwise = t ^. #style - rot - | t ^. #place == PlaceRight = pi / 2 - | t ^. #place == PlaceLeft = -pi / 2 - | otherwise = 0 - placePos' (Rect x z y w) = case t ^. #place of - PlaceTop -> Point ((x + z) / 2.0) (w + (t ^. #buff)) - PlaceBottom -> - Point - ((x + z) / 2.0) - ( y - (t ^. #buff) - - 0.5 - * (t ^. #style . #vsize) - * (t ^. #style . #size) - ) - PlaceLeft -> Point (x - (t ^. #buff)) ((y + w) / 2.0) - PlaceRight -> Point (z + (t ^. #buff)) ((y + w) / 2.0) - PlaceAbsolute p -> p - alignPos (Rect x z y w) - | t ^. #anchor == AnchorStart - && t ^. #place `elem` [PlaceTop, PlaceBottom] = - Point ((x - z) / 2.0) 0.0 - | t ^. #anchor == AnchorStart - && t ^. #place == PlaceLeft = - Point 0.0 ((y - w) / 2.0) - | t ^. #anchor == AnchorStart - && t ^. #place == PlaceRight = - Point 0.0 ((w - y) / 2.0) - | t ^. #anchor == AnchorEnd - && t ^. #place `elem` [PlaceTop, PlaceBottom] = - Point ((-x + z) / 2.0) 0.0 - | t ^. #anchor == AnchorEnd - && t ^. #place == PlaceLeft = - Point 0.0 ((-y + w) / 2.0) - | t ^. #anchor == AnchorEnd - && t ^. #place == PlaceRight = - Point 0.0 ((y - w) / 2.0) - | otherwise = Point 0.0 0.0 - --- | Add a title to a chart. The logic used to work out placement is flawed due to being able to freely specify text rotation. It works for specific rotations (Top, Bottom at 0, Left at 90, Right @ 270) -title :: (Monad m) => Title -> HudT m Double -title t = Hud $ \cs -> do - ca <- use #chartDim - let c = title_ t ca - #chartDim .= addChartBox c ca - pure $ c : cs - -placePos :: Place -> Double -> Rect Double -> Point Double -placePos pl b (Rect x z y w) = case pl of - PlaceTop -> Point 0 (w + b) - PlaceBottom -> Point 0 (y - b) - PlaceLeft -> Point (x - b) 0 - PlaceRight -> Point (z + b) 0 - PlaceAbsolute p -> p - -placeRot :: Place -> Maybe Double -placeRot pl = case pl of - PlaceRight -> Just (pi / 2) - PlaceLeft -> Just (pi / 2) - _ -> Nothing - -textPos :: Place -> TextStyle -> Double -> Point Double -textPos pl tt b = case pl of - PlaceTop -> Point 0 b - PlaceBottom -> Point 0 (-b - 0.5 * (tt ^. #vsize) * (tt ^. #size)) - PlaceLeft -> - Point - (-b) - ((tt ^. #nudge1) * (tt ^. #vsize) * (tt ^. #size)) - PlaceRight -> - Point - b - ((tt ^. #nudge1) * (tt ^. #vsize) * (tt ^. #size)) - PlaceAbsolute p -> p - -placeRange :: Place -> Rect Double -> Range Double -placeRange pl (Rect x z y w) = case pl of - PlaceRight -> Range y w - PlaceLeft -> Range y w - _ -> Range x z - -placeOrigin :: Place -> Double -> Point Double -placeOrigin pl x - | pl `elem` [PlaceTop, PlaceBottom] = Point x 0 - | otherwise = Point 0 x - -placeTextAnchor :: Place -> (TextStyle -> TextStyle) -placeTextAnchor pl - | pl == PlaceLeft = #anchor .~ AnchorEnd - | pl == PlaceRight = #anchor .~ AnchorStart - | otherwise = id - -placeGridLines :: Place -> Rect Double -> Double -> Double -> [XY Double] -placeGridLines pl (Rect x z y w) a b - | pl `elem` [PlaceTop, PlaceBottom] = [P a (y - b), P a (w + b)] - | otherwise = [P (x - b) a, P (z + b) a] - --- | compute tick values and labels given options, ranges and formatting -ticksR :: TickStyle -> Range Double -> Range Double -> [(Double, Text)] -ticksR s d r = - case s of - TickNone -> [] - TickRound f n e -> zip (project r d <$> ticks0) (formatNs f ticks0) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) - TickExact f n -> zip (project r d <$> ticks0) (formatNs f ticks0) - where - ticks0 = grid OuterPos r n - TickLabels ls -> - zip - ( project (Range 0 (fromIntegral $ length ls)) d - <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) - ) - ls - TickPlaced xs -> zip (project r d . fst <$> xs) (snd <$> xs) - -data TickComponents = TickComponents - { positions :: [Double], - labels :: [Text], - extension :: Maybe (Range Double) - } - deriving (Eq, Show, Generic) - --- | compute tick components given style, ranges and formatting -makeTicks :: TickStyle -> Range Double -> TickComponents -makeTicks s r = - case s of - TickNone -> TickComponents [] [] Nothing - TickRound f n e -> - TickComponents - ticks0 - (formatNs f ticks0) - (bool (Just $ space1 ticks0) Nothing (e == NoTickExtend)) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) - TickExact f n -> TickComponents ticks0 (formatNs f ticks0) Nothing - where - ticks0 = grid OuterPos r n - TickLabels ls -> - TickComponents - ( project (Range 0 (fromIntegral $ length ls)) r - <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) - ) - ls - Nothing - TickPlaced xs -> TickComponents (fst <$> xs) (snd <$> xs) Nothing - --- | compute tick values given placement, canvas dimension & data range -ticksPlaced :: TickStyle -> Place -> Rect Double -> Rect Double -> TickComponents -ticksPlaced ts pl d xs = TickComponents (project (placeRange pl xs) (placeRange pl d) <$> ps) ls ext - where - (TickComponents ps ls ext) = makeTicks ts (placeRange pl xs) - -tickGlyph_ :: Place -> (GlyphStyle, Double) -> TickStyle -> Rect Double -> Rect Double -> Rect Double -> Chart Double -tickGlyph_ pl (g, b) ts ca da xs = - Chart - (GlyphA (g & #rotation .~ placeRot pl)) - ( PointXY . (placePos pl b ca +) . placeOrigin pl - <$> positions - (ticksPlaced ts pl da xs) - ) - --- | aka marks -tickGlyph :: - (Monad m) => - Place -> - (GlyphStyle, Double) -> - TickStyle -> - HudT m Double -tickGlyph pl (g, b) ts = Hud $ \cs -> do - a <- use #chartDim - d <- use #canvasDim - xs <- use #dataDim - let c = tickGlyph_ pl (g, b) ts a d xs - #chartDim .= addToRect a (styleBox c) - pure $ c : cs - -tickText_ :: - Place -> - (TextStyle, Double) -> - TickStyle -> - Rect Double -> - Rect Double -> - Rect Double -> - [Chart Double] -tickText_ pl (txts, b) ts ca da xs = - zipWith - ( \txt sp -> - Chart - ( TextA - (placeTextAnchor pl txts) - [txt] - ) - [PointXY sp] - ) - (labels $ ticksPlaced ts pl da xs) - ( (placePos pl b ca + textPos pl txts b +) . placeOrigin pl - <$> positions (ticksPlaced ts pl da xs) - ) - --- | aka tick labels -tickText :: - (Monad m) => - Place -> - (TextStyle, Double) -> - TickStyle -> - HudT m Double -tickText pl (txts, b) ts = Hud $ \cs -> do - ca <- use #chartDim - da <- use #canvasDim - xs <- use #dataDim - let c = tickText_ pl (txts, b) ts ca da xs - #chartDim .= addChartBoxes c ca - pure $ c <> cs - --- | aka grid lines -tickLine :: - (Monad m) => - Place -> - (LineStyle, Double) -> - TickStyle -> - HudT m Double -tickLine pl (ls, b) ts = Hud $ \cs -> do - da <- use #canvasDim - xs <- use #dataDim - let c = - Chart (LineA ls) . (\x -> placeGridLines pl da x b) - <$> positions (ticksPlaced ts pl da xs) - #chartDim %= addChartBoxes c - pure $ c <> cs - --- | Create tick glyphs (marks), lines (grid) and text (labels) -tick :: - (Monad m) => - Place -> - Tick -> - HudT m Double -tick pl t = - maybe mempty (\x -> tickGlyph pl x (t ^. #tstyle)) (t ^. #gtick) - <> maybe mempty (\x -> tickText pl x (t ^. #tstyle)) (t ^. #ttick) - <> maybe mempty (\x -> tickLine pl x (t ^. #tstyle)) (t ^. #ltick) - <> extendData pl t - --- | compute an extension to the Range if a tick went over the data bounding box -computeTickExtension :: TickStyle -> Range Double -> Maybe (Range Double) -computeTickExtension s r = - case s of - TickNone -> Nothing - TickRound _ n e -> bool Nothing (Just (space1 ticks0 <> r)) (e == TickExtend) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) - TickExact _ _ -> Nothing - TickLabels _ -> Nothing - TickPlaced xs -> Just $ r <> space1 (fst <$> xs) - --- | Create a style extension for the data, if ticks extend beyond the existing range -tickExtended :: - Place -> - Tick -> - Rect Double -> - Rect Double -tickExtended pl t xs = - maybe - xs - (rangeext xs) - (computeTickExtension (t ^. #tstyle) (ranged xs)) - where - ranged xs' = case pl of - PlaceTop -> rangex xs' - PlaceBottom -> rangex xs' - PlaceLeft -> rangey xs' - PlaceRight -> rangey xs' - PlaceAbsolute _ -> rangex xs' - rangex (Rect x z _ _) = Range x z - rangey (Rect _ _ y w) = Range y w - rangeext (Rect x z y w) (Range a0 a1) = case pl of - PlaceTop -> Rect a0 a1 y w - PlaceBottom -> Rect a0 a1 y w - PlaceLeft -> Rect x z a0 a1 - PlaceRight -> Rect x z a0 a1 - PlaceAbsolute _ -> Rect a0 a1 y w - -extendData :: (Monad m) => Place -> Tick -> HudT m Double -extendData pl t = Hud $ \cs -> do - #dataDim %= tickExtended pl t - pure cs - --- | adjust Tick for sane font sizes etc -adjustTick :: - Adjustments -> - Rect Double -> - Rect Double -> - Place -> - Tick -> - Tick -adjustTick (Adjustments mrx ma mry ad) vb cs pl t - | pl `elem` [PlaceBottom, PlaceTop] = - if ad - then - ( case adjustSizeX > 1 of - True -> - ( case pl of - PlaceBottom -> #ttick . _Just . _1 . #anchor .~ AnchorEnd - PlaceTop -> #ttick . _Just . _1 . #anchor .~ AnchorStart - _ -> #ttick . _Just . _1 . #anchor .~ AnchorEnd - ) - . (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) - $ (#ttick . _Just . _1 . #rotation ?~ pi / 4) t - False -> (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) t - ) - else t & #ttick . _Just . _1 . #size %~ (/ adjustSizeX) - | otherwise -- pl `elem` [PlaceLeft, PlaceRight] - = - (#ttick . _Just . _1 . #size %~ (/ adjustSizeY)) t - where - max' [] = 1 - max' xs = maximum xs - ra (Rect x z y w) - | pl `elem` [PlaceTop, PlaceBottom] = Range x z - | otherwise = Range y w - asp = ra vb - r = ra cs - tickl = snd <$> ticksR (t ^. #tstyle) asp r - maxWidth :: Double - maxWidth = - maybe - 1 - ( \tt -> - max' $ - (\(Rect x z _ _) -> z - x) - . (\x -> styleBoxText (fst tt) x (Point 0 0)) - <$> tickl - ) - (t ^. #ttick) - maxHeight = - maybe - 1 - ( \tt -> - max' $ - (\(Rect _ _ y w) -> w - y) - . (\x -> styleBoxText (fst tt) x (Point 0 0)) - <$> tickl - ) - (t ^. #ttick) - adjustSizeX :: Double - adjustSizeX = max' [(maxWidth / (upper asp - lower asp)) / mrx, 1] - adjustSizeY = max' [(maxHeight / (upper asp - lower asp)) / mry, 1] - adjustSizeA = max' [(maxHeight / (upper asp - lower asp)) / ma, 1] - -makeTick :: (Monad m) => AxisOptions -> HudT m Double -makeTick c = Hud $ \cs -> do - vb <- use #chartDim - xs <- use #dataDim - let adjTick = - maybe - (c ^. #axisTick) - (\x -> adjustTick x vb xs (c ^. #place) (c ^. #axisTick)) - (c ^. #adjust) - unhud (tick (c ^. #place) adjTick) cs - --- | Convert a UTCTime list into sensible ticks, placed exactly -makeTickDates :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Int, Text)] -makeTickDates pc fmt n dates = - lastOnes (\(_, x0) (_, x1) -> x0 == x1) . fst $ placedTimeLabelDiscontinuous pc fmt n dates - where - lastOnes :: (a -> a -> Bool) -> [a] -> [a] - lastOnes _ [] = [] - lastOnes _ [x] = [x] - lastOnes f (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x, []) xs - where - step (a0, rs) a1 = if f a0 a1 then (a1, rs) else (a1, a0 : rs) - --- | Convert a UTCTime list into sensible ticks, placed on the (0,1) space -makeTickDatesContinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Double, Text)] -makeTickDatesContinuous pc fmt n dates = - placedTimeLabelContinuous pc fmt n (space1 dates) - --- | Make a legend hud element taking into account the chart. -legendHud :: LegendOptions -> [Chart Double] -> Hud Double -legendHud l lcs = Hud $ \cs -> do - ca <- use #chartDim - let cs' = cs <> movedleg ca scaledleg - #chartDim .= fromMaybe one (styleBoxes cs') - pure cs' - where - scaledleg = - (#annotation %~ scaleAnn (l ^. #lscale)) - . (#xys %~ fmap (fmap (* l ^. #lscale))) - <$> lcs - movedleg ca' leg = - maybe id (moveChart . PointXY . placel (l ^. #lplace) ca') (styleBoxes leg) leg - placel pl (Rect x z y w) (Rect x' z' y' w') = - case pl of - PlaceTop -> Point ((x + z) / 2.0) (w + (w' - y') / 2.0) - PlaceBottom -> Point ((x + z) / 2.0) (y - (w' - y' / 2.0)) - PlaceLeft -> Point (x - (z' - x') / 2.0) ((y + w) / 2.0) - PlaceRight -> Point (z + (z' - x') / 2.0) ((y + w) / 2.0) - PlaceAbsolute p -> p - -legendEntry :: - LegendOptions -> - Annotation -> - Text -> - (Chart Double, Chart Double) -legendEntry l a t = - ( Chart ann sps, - Chart (TextA (l ^. #ltext & #anchor .~ AnchorStart) [t]) [zero] - ) - where - (ann, sps) = case a of - RectA rs -> - ( RectA rs, - [R 0 (l ^. #lsize) 0 (l ^. #lsize)] - ) - TextA ts txts -> - ( TextA (ts & #size .~ (l ^. #lsize)) (take 1 txts), - [zero] - ) - GlyphA gs -> - ( GlyphA (gs & #size .~ (l ^. #lsize)), - [P (0.5 * l ^. #lsize) (0.33 * l ^. #lsize)] - ) - LineA ls -> - ( LineA (ls & #width %~ (/ (l ^. #lscale))), - [P 0 (1 * l ^. #lsize), P (2 * l ^. #lsize) (1 * l ^. #lsize)] - ) - PathA ps _ -> - ( let cs = - singletonCubic - ( CubicPosition - (Point 0 0) - (Point (0.33 * l ^. #lsize) (0.33 * l ^. #lsize)) - (Point 0 (0.33 * l ^. #lsize)) - (Point (0.33 * l ^. #lsize) 0) - ) - in (PathA (ps & #borderSize .~ (l ^. #lsize)) (fst <$> cs), PointXY . snd <$> cs) - ) - BlankA -> - ( BlankA, - [zero] - ) - -legendChart :: [(Annotation, Text)] -> LegendOptions -> [Chart Double] -legendChart lrs l = - padChart (l ^. #outerPad) - . maybe id (\x -> frameChart x (l ^. #innerPad)) (l ^. #legendFrame) - . vert (l ^. #hgap) - $ (\(a, t) -> hori ((l ^. #vgap) + twidth - gapwidth t) [[t], [a]]) - <$> es - where - es = reverse $ uncurry (legendEntry l) <$> lrs - twidth = maybe 0 (\(Rect _ z _ _) -> z) . foldRect $ catMaybes (styleBox . snd <$> es) - gapwidth t = maybe 0 (\(Rect _ z _ _) -> z) (styleBox t) - --- | Project the xys of a chart to a new XY Space. --- --- > projectXYs (dataBox cs) cs == cs if cs is non-empty -projectXYs :: Rect Double -> [Chart Double] -> [Chart Double] -projectXYs _ [] = [] -projectXYs new cs = projectXYsWith new old cs - where - old = fromMaybe one (dataBoxes cs) - --- | Project chart xys to a new XY Space from an old XY Space --- --- The projections needed are: --- --- - project the 'xys' --- --- - project the control points of bezier curves --- --- - project aspect changes only to radii of ellipticals. --- --- > projectXYsWith x x == id -projectXYsWith :: Rect Double -> Rect Double -> [Chart Double] -> [Chart Double] -projectXYsWith new old cs = cs' - where - xss = fmap (projectOn new old) . xys <$> cs - ss = projectAnn <$> cs - cs' = zipWith Chart ss xss - projectAnn (Chart (PathA ps ips) xys) = - PathA ps (projectControls ips xys) - projectAnn x = annotation x - - projectControls pis xys = - (reverse . snd) (foldl' (\(prevp, l) (i, xy) -> (xy, projectControl prevp xy i : l)) (zero, []) (zip pis xys)) - - projectControl _ _ (CubicI c1 c2) = - CubicI (projectOnP new old c1) (projectOnP new old c2) - projectControl _ _ (QuadI c) = - QuadI (projectOnP new old c) - projectControl p1 p2 (ArcI ai) = ArcI $ projectArcPosition new old (ArcPosition (toPoint p1) (toPoint p2) ai) - projectControl _ _ x = x - --- | project an ArcPosition given new and old Rects --- --- The radii of the ellipse can be represented as: --- --- Point rx 0 & Point 0 ry --- --- These two points are firstly rotated by p and then undergo scaling... -projectArcPosition :: Rect Double -> Rect Double -> ArcPosition Double -> ArcInfo Double -projectArcPosition new old (ArcPosition _ _ (ArcInfo (Point rx ry) phi l cl)) = ArcInfo (Point rx'' ry'') phi l cl - where - rx' = rotateP phi (Point rx zero) - rx'' = norm $ rx' * NH.width new / NH.width old - ry' = rotateP phi (Point zero ry) - ry'' = norm $ ry' * NH.width new / NH.width old - --- | pad a Rect to remove singleton dimensions -padBox :: Maybe (Rect Double) -> Rect Double -padBox = maybe one singletonUnit - where - singletonUnit (Rect x z y w) - | x == z && y == w = Rect (x - 0.5) (x + 0.5) (y - 0.5) (y + 0.5) - | x == z = Rect (x - 0.5) (x + 0.5) y w - | y == w = Rect x z (y - 0.5) (y + 0.5) - | otherwise = Rect x z y w - --- | 'Rect' of a 'Chart', not including style -dataBox :: Chart Double -> Maybe (Rect Double) -dataBox c = - case c ^. #annotation of - PathA _ path' -> pathBoxes $ zip path' (toPoint <$> c ^. #xys) - _ -> foldRect $ fmap toRect (c ^. #xys) - --- | 'Rect' of charts, not including style -dataBoxes :: [Chart Double] -> Maybe (Rect Double) -dataBoxes cs = foldRect $ catMaybes $ dataBox <$> cs - --- | 'Rect' of charts, not including style, with defaults for Nothing and singleton dimensions if any. -dataBoxesS :: [Chart Double] -> Rect Double -dataBoxesS cs = padBox $ foldRect $ catMaybes $ dataBox <$> cs - --- | the extra area from text styling -styleBoxText :: - TextStyle -> - Text -> - Point Double -> - Rect Double -styleBoxText o t p = move p $ maybe flat (`rotationBound` flat) (o ^. #rotation) - where - flat = Rect ((-x' / 2.0) + x' * a') (x' / 2 + x' * a') ((-y' / 2) - n1') (y' / 2 - n1') - s = o ^. #size - h = o ^. #hsize - v = o ^. #vsize - n1 = o ^. #nudge1 - x' = s * h * fromIntegral (sum $ maybe 0 Text.length . maybeTagText <$> parseTags t) - y' = s * v - n1' = s * n1 - a' = case o ^. #anchor of - AnchorStart -> 0.5 - AnchorEnd -> -0.5 - AnchorMiddle -> 0.0 - --- | the extra area from glyph styling -styleBoxGlyph :: GlyphStyle -> Rect Double -styleBoxGlyph s = move p' $ - sw $ case sh of - CircleGlyph -> (sz *) <$> one - SquareGlyph -> (sz *) <$> one - EllipseGlyph a -> NH.scale (Point sz (a * sz)) one - RectSharpGlyph a -> NH.scale (Point sz (a * sz)) one - RectRoundedGlyph a _ _ -> NH.scale (Point sz (a * sz)) one - VLineGlyph _ -> NH.scale (Point ((s ^. #borderSize) * sz) sz) one - HLineGlyph _ -> NH.scale (Point sz ((s ^. #borderSize) * sz)) one - TriangleGlyph a b c -> (sz *) <$> sconcat (toRect . PointXY <$> (a :| [b, c]) :: NonEmpty (Rect Double)) - PathGlyph path' -> (sz *) <$> fromMaybe one (pathBoxes . toPathXYs . parsePath $ path') - where - sh = s ^. #shape - sz = s ^. #size - sw = padRect (0.5 * s ^. #borderSize) - p' = fromMaybe (Point 0.0 0.0) (s ^. #translate) - --- | the geometric dimensions of a Chart inclusive of style geometry, but excluding PathA effects -styleBox :: Chart Double -> Maybe (Rect Double) -styleBox (Chart (TextA s ts) xs) = foldRect $ zipWith (\t x -> styleBoxText s t (toPoint x)) ts xs -styleBox (Chart (GlyphA s) xs) = foldRect $ (\x -> move (toPoint x) (styleBoxGlyph s)) <$> xs -styleBox (Chart (RectA s) xs) = foldRect (padRect (0.5 * s ^. #borderSize) . toRect <$> xs) -styleBox (Chart (LineA s) xs) = foldRect (padRect (0.5 * s ^. #width) . toRect <$> xs) -styleBox c@(Chart (PathA s _) _) = padRect (0.5 * s ^. #borderSize) <$> dataBox c -styleBox (Chart BlankA xs) = foldRect (toRect <$> xs) - --- | the extra geometric dimensions of a [Chart] -styleBoxes :: [Chart Double] -> Maybe (Rect Double) -styleBoxes xss = foldRect $ catMaybes (styleBox <$> xss) - --- | the extra geometric dimensions of a [Chart], adjusted for Nothing or singleton dimensions. -styleBoxesS :: [Chart Double] -> Rect Double -styleBoxesS xss = padBox $ foldRect $ catMaybes (styleBox <$> xss) - --- | additively pad a [Chart] --- --- >>> import NumHask.Prelude (one) --- >>> padChart 0.1 [Chart (RectA defaultRectStyle) [RectXY one]] --- [Chart {annotation = RectA (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.65 0.81 0.89 1.00, color = Colour 0.12 0.47 0.71 1.00}), xys = [R -0.5 0.5 -0.5 0.5]},Chart {annotation = BlankA, xys = [R -0.605 0.605 -0.605 0.605]}] -padChart :: Double -> [Chart Double] -> [Chart Double] -padChart p cs = cs <> [Chart BlankA (maybeToList (RectXY . padRect p <$> styleBoxes cs))] - --- | overlay a frame on some charts with some additive padding between --- --- >>> frameChart defaultRectStyle 0.1 [Chart BlankA []] --- [Chart {annotation = RectA (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.65 0.81 0.89 1.00, color = Colour 0.12 0.47 0.71 1.00}), xys = []},Chart {annotation = BlankA, xys = []}] -frameChart :: RectStyle -> Double -> [Chart Double] -> [Chart Double] -frameChart rs p cs = [Chart (RectA rs) (maybeToList (RectXY . padRect p <$> styleBoxes cs))] <> cs - --- | useful for testing bounding boxes -frameAllCharts :: [Chart Double] -> [Chart Double] -frameAllCharts cs = mconcat $ frameChart (border 0.004 light) 0.004 . (: []) <$> cs - --- | horizontally stack a list of list of charts (proceeding to the right) with a gap between -hori :: Double -> [[Chart Double]] -> [Chart Double] -hori _ [] = [] -hori gap cs = foldl' step [] cs - where - step x a = x <> (a & fmap (#xys %~ fmap (\s -> P (widthx x) (aligny x - aligny a) + s))) - widthx xs = maybe 0 (\(Rect x' z' _ _) -> z' - x' + gap) (styleBoxes xs) - aligny xs = maybe 0 (\(Rect _ _ y' w') -> (y' + w') / 2) (styleBoxes xs) - --- | vertically stack a list of charts (proceeding upwards), aligning them to the left -vert :: Double -> [[Chart Double]] -> [Chart Double] -vert _ [] = [] -vert gap cs = foldl' step [] cs - where - step x a = x <> (a & fmap (#xys %~ fmap (\s -> P (alignx x - alignx a) (widthy x) + s))) - widthy xs = maybe 0 (\(Rect _ _ y' w') -> w' - y' + gap) (styleBoxes xs) - alignx xs = maybe 0 (\(Rect x' _ _ _) -> x') (styleBoxes xs) - --- | stack a list of charts horizontally, then vertically -stack :: Int -> Double -> [[Chart Double]] -> [Chart Double] -stack _ _ [] = [] -stack n gap cs = vert gap (hori gap <$> group' cs []) - where - group' [] acc = reverse acc - group' x acc = group' (drop n x) (take n x : acc) - -addChartBox :: Chart Double -> Rect Double -> Rect Double -addChartBox c r = sconcat (r :| maybeToList (styleBox c)) - -addChartBoxes :: [Chart Double] -> Rect Double -> Rect Double -addChartBoxes c r = sconcat (r :| maybeToList (styleBoxes c)) diff --git a/src/Chart/Various.hs b/src/Chart/Various.hs deleted file mode 100644 --- a/src/Chart/Various.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - --- | Various common chart patterns. -module Chart.Various - ( -- * sub-chart patterns - xify, - xify', - yify, - yify', - addLineX, - addLineY, - stdLineChart, - stdLines, - lineLegend, - tsAxes, - titlesHud, - gpalette, - gpaletteStyle, - blendMidLineStyles, - - -- * chart patterns - quantileChart, - digitChart, - scatterChart, - histChart, - quantileHistChart, - digitSurfaceChart, - tableChart, - ) -where - -import Chart -import Control.Lens -import Data.Bifunctor -import Data.Foldable -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe -import Data.Text (Text) -import Data.Time (UTCTime (..)) -import NumHask.Prelude (one) -import NumHask.Space - --- | convert from [a] to [Point a], by adding the index as the x axis -xify :: [Double] -> [Point Double] -xify ys = - zipWith Point [0 ..] ys - --- | convert from [a] to [XY a], by adding the index as the x axis -xify' :: [Double] -> [XY Double] -xify' ys = - zipWith P [0 ..] ys - --- | convert from [a] to [Point a], by adding the index as the y axis -yify :: [Double] -> [Point Double] -yify xs = - zipWith Point xs [0 ..] - --- | convert from [a] to [XY a], by adding the index as the y axis -yify' :: [Double] -> [XY Double] -yify' xs = - zipWith P xs [0 ..] - --- | add a horizontal line at y -addLineX :: Double -> LineStyle -> [Chart Double] -> [Chart Double] -addLineX y ls cs = cs <> [l] - where - l = Chart (LineA ls) (PointXY <$> [Point lx y, Point ux y]) - (Rect lx ux _ _) = fromMaybe one $ foldRect $ mconcat $ fmap toRect . xys <$> cs - --- | add a verticle line at x -addLineY :: Double -> LineStyle -> [Chart Double] -> [Chart Double] -addLineY x ls cs = cs <> [zeroLine] - where - zeroLine = Chart (LineA ls) (PointXY <$> [Point x ly, Point x uy]) - (Rect _ _ ly uy) = fromMaybe one $ foldRect $ mconcat $ fmap toRect . xys <$> cs - --- | interpret a [[Double]] as a series of lines with x coordinates of [0..] -stdLineChart :: Double -> [Colour] -> [[Double]] -> [Chart Double] -stdLineChart w p xss = - zipWith - ( \c xs -> - Chart - (LineA (defaultLineStyle & #color .~ c & #width .~ w)) - (xify' xs) - ) - p - xss - --- | Can of the main palette -stdLines :: Double -> [LineStyle] -stdLines w = (\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> palette1_ - --- | Legend template for a line chart. -lineLegend :: Double -> [Text] -> [Colour] -> (LegendOptions, [(Annotation, Text)]) -lineLegend w rs cs = - ( defaultLegendOptions - & #ltext . #size .~ 0.3 - & #lplace .~ PlaceBottom - & #legendFrame .~ Just (RectStyle 0.02 (palette1 5) (palette1 4)), - zipWith - (\a r -> (LineA a, r)) - ((\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> cs) - rs - ) - --- | Create a hud that has time as the x-axis, based on supplied days, and a rounded yaxis. -tsAxes :: [UTCTime] -> [AxisOptions] -tsAxes ds = - [ defaultAxisOptions - & #axisTick . #tstyle .~ TickRound (FormatPrec (Just 3)) 6 TickExtend - & #place .~ PlaceLeft, - defaultAxisOptions & #axisTick . #tstyle - .~ TickPlaced - ( first fromIntegral - <$> makeTickDates PosIncludeBoundaries Nothing 8 ds - ) - ] - --- | common pattern of chart title, x-axis title and y-axis title -titlesHud :: Text -> Text -> Text -> HudOptions -titlesHud t x y = - defaultHudOptions - & #hudTitles - .~ [ defaultTitle t, - defaultTitle x & #place .~ PlaceBottom & #style . #size .~ 0.08, - defaultTitle y & #place .~ PlaceLeft & #style . #size .~ 0.08 - ] - --- | GlyphStyle palette -gpaletteStyle :: Double -> [GlyphStyle] -gpaletteStyle s = zipWith (\c g -> defaultGlyphStyle & #size .~ s & #color .~ c & #shape .~ fst g & #borderSize .~ snd g) palette1_ gpalette - --- | Glyph palette -gpalette :: [(GlyphShape, Double)] -gpalette = - [ (CircleGlyph, 0.01 :: Double), - (SquareGlyph, 0.01), - (RectSharpGlyph 0.75, 0.01), - (RectRoundedGlyph 0.75 0.01 0.01, 0.01), - (EllipseGlyph 0.75, 0), - (VLineGlyph 0.005, 0.01), - (HLineGlyph 0.005, 0.01), - (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01), - (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01) - ] - --- * charts - --- | Chart template for quantiles. -quantileChart :: - Text -> - [Text] -> - [LineStyle] -> - [AxisOptions] -> - [[Double]] -> - ChartSvg -quantileChart title names ls as xs = - mempty & #hudOptions .~ hudOptions & #chartList .~ chart' - where - hudOptions = - defaultHudOptions - & #hudTitles .~ [defaultTitle title] - & ( #hudLegend - .~ Just - ( defaultLegendOptions - & #ltext . #size .~ 0.1 - & #vgap .~ 0.05 - & #innerPad .~ 0.2 - & #lplace .~ PlaceRight, - extractAnns names chart' - ) - ) - & #hudAxes .~ as - extractAnns = zipWith (\t c -> (c ^. #annotation, t)) - - chart' = - zipWith - (\l c -> Chart (LineA l) c) - ls - (zipWith P [0 ..] <$> xs) - --- | /blendMidLineStyle n w/ produces n lines of width w interpolated between two colors. -blendMidLineStyles :: Int -> Double -> (Colour, Colour) -> [LineStyle] -blendMidLineStyles l w (c1, c2) = lo - where - m = (fromIntegral l - 1) / 2 :: Double - cs = (\x -> 1 - abs (fromIntegral x - m) / m) <$> [0 .. (l - 1)] - bs = (\x -> blend x c1 c2) <$> cs - lo = (\c -> defaultLineStyle & #width .~ w & #color .~ c) <$> bs - --- | No idea what this is really. -digitChart :: - Text -> - [UTCTime] -> - [Double] -> - ChartSvg -digitChart title utcs xs = - mempty & #hudOptions .~ hudOptions & #chartList .~ [c] - where - hudOptions = - defaultHudOptions - & #hudTitles .~ [defaultTitle title] - & #hudAxes .~ tsAxes utcs - c = - Chart - ( GlyphA - ( defaultGlyphStyle - & #color .~ Colour 0 0 1 1 - & #shape .~ CircleGlyph - & #size .~ 0.01 - ) - ) - (xify' xs) - --- | scatter chart -scatterChart :: - [[Point Double]] -> - [Chart Double] -scatterChart xss = zipWith (\gs xs -> Chart (GlyphA gs) (PointXY <$> xs)) (gpaletteStyle 0.02) xss - --- | histogram chart -histChart :: - Text -> - Maybe [Text] -> - Range Double -> - Int -> - [Double] -> - ChartSvg -histChart title names r g xs = - barChart defaultBarOptions barData - & (#hudOptions . #hudTitles .~ [defaultTitle title]) - where - barData = BarData [hr] names Nothing - hcuts = grid OuterPos r g - h = fill hcuts xs - hr = - (\(Rect x x' _ _) -> (x + x') / 2) - <$> makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) h - --- | a chart drawing a histogram based on quantile information -quantileHistChart :: - Text -> - Maybe [Text] -> - -- | quantiles - [Double] -> - -- | quantile values - [Double] -> - ChartSvg -quantileHistChart title names qs vs = - mempty & #hudOptions .~ hudOptions & #chartList .~ [chart'] - where - hudOptions = - defaultHudOptions - & #hudTitles - .~ [defaultTitle title] - & #hudAxes - .~ [ maybe - ( defaultAxisOptions & #axisTick . #tstyle - .~ TickRound (FormatPrec (Just 3)) 8 TickExtend - ) - ( \x -> - defaultAxisOptions & #axisTick . #tstyle - .~ TickPlaced (zip vs x) - ) - names - ] - chart' = Chart (RectA defaultRectStyle) (RectXY <$> hr) - hr = - zipWith - (\(y, w) (x, z) -> Rect x z 0 ((w - y) / (z - x))) - (zip qs (drop 1 qs)) - (zip vs (drop 1 vs)) - --- | pixel chart of digitized vs digitized counts -digitSurfaceChart :: - SurfaceStyle -> - SurfaceLegendOptions -> - (Text, Text, Text) -> - [Text] -> - [(Int, Int)] -> - [Chart Double] -digitSurfaceChart pixelStyle plo ts names ps = - runHud (aspect 1) (hs0 <> hs1) (cs0 <> cs1) - where - l = length names - pts = Point l l - gr :: Rect Double - gr = fromIntegral <$> Rect 0 l 0 l - mapCount = foldl' (\m x -> HashMap.insertWith (+) x 1.0 m) HashMap.empty ps - f :: Point Double -> Double - f (Point x y) = fromMaybe 0 $ HashMap.lookup (floor x, floor y) mapCount - (hs0, cs0) = makeHud gr (qvqHud ts names) - (cs1, hs1) = - surfacefl - f - (SurfaceOptions pixelStyle pts gr) - plo - --- style helpers -qvqHud :: (Text, Text, Text) -> [Text] -> HudOptions -qvqHud ts labels = - defaultHudOptions - & #hudTitles .~ makeTitles ts - & #hudAxes - .~ [ defaultAxisOptions - & #axisTick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labels) - & #place .~ PlaceLeft, - defaultAxisOptions - & #axisTick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labels) - & #place .~ PlaceBottom - ] - -makeTitles :: (Text, Text, Text) -> [Title] -makeTitles (t, xt, yt) = - reverse - [ defaultTitle t, - defaultTitle xt & #place .~ PlaceBottom & #style . #size .~ 0.06, - defaultTitle yt & #place .~ PlaceLeft & #style . #size .~ 0.06 - ] - --- | Chart for double list of Text. -tableChart :: [[Text]] -> [Chart Double] -tableChart tss = zipWith (\ts x -> Chart (TextA defaultTextStyle ts) (P x <$> take (length ts) [0 ..])) tss [0 ..] diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs --- a/src/Data/Colour.hs +++ b/src/Data/Colour.hs @@ -1,61 +1,120 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} --- | Colour representations and combinations, based on +-- | Colour representations and combinations. +-- module Data.Colour - ( Colour, + ( -- * Colour + Colour, pattern Colour, + validColour, + validate, + trimColour, + showRGBA, + showRGB, + opac', opac, - setOpac, hex, - blend, - blends, + rgb, toHex, fromHex, unsafeFromHex, + + -- * Palette colours palette1, - palette1_, + palette1a, transparent, black, white, light, dark, + grey, + + -- * LCH model + LCH (..), + pattern LCH, + lLCH', + cLCH', + hLCH', + LCHA (..), + pattern LCHA, + lch', + alpha', + RGB3 (..), + pattern RGB3, + rgbd', + rgb32colour', + LAB (..), + pattern LAB, + lcha2colour', + xy2ch', + + -- * mixins + mix, + mixTrim, + mixLCHA, + mixes, + greyed, + lightness', + chroma', + hue', + showSwatch, + showSwatches, + rvRGB3, + rvColour, + paletteR, ) where +import Chart.Data import qualified Data.Attoparsec.Text as A import Data.Bifunctor +import Data.Bool (bool) import Data.Char import Data.Either import Data.FormatN -import Data.Generics.Labels () +import Data.Functor.Rep import qualified Data.List as List import Data.Text (Text, pack) import qualified Data.Text as Text +import GHC.Exts import GHC.Generics hiding (prec) -import Graphics.Color.Model +import Graphics.Color.Model as M hiding (LCH) +import qualified Graphics.Color.Space as S +import NeatInterpolation +import NumHask.Algebra.Metric +import NumHask.Array.Fixed +import Optics.Core +import System.Random +import System.Random.Stateful --- | Wrapper for 'Color'. +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core + +-- | Colour type for the library, wrapping 'Color'. +-- newtype Colour = Colour' { color' :: Color (Alpha RGB) Double } deriving (Eq, Generic) -- | Constructor pattern. +-- +-- > Colour red green blue alpha +-- pattern Colour :: Double -> Double -> Double -> Double -> Colour pattern Colour r g b a = Colour' (ColorRGBA r g b a) @@ -73,48 +132,65 @@ <> " " <> fixed (Just 2) a --- | opac +-- | CSS-style representation +showRGBA :: Colour -> Text +showRGBA (Colour r' g' b' a') = + [trimming|rgba($r, $g, $b, $a)|] + where + r = percent (fixedSF (Just 0)) (Just 2) r' + g = percent (fixedSF (Just 0)) (Just 2) g' + b = percent (fixedSF (Just 0)) (Just 2) b' + a = fixed (Just 2) a' + +-- | CSS-style representation +showRGB :: Colour -> Text +showRGB (Colour r' g' b' _) = + [trimming|rgb($r, $g, $b)|] + where + r = percent (fixedSF (Just 0)) (Just 2) r' + g = percent (fixedSF (Just 0)) (Just 2) g' + b = percent (fixedSF (Just 0)) (Just 2) b' + +-- | Is Colour in-gamut? +-- +-- >>> validColour (Colour 1 1 1.01 1) +-- False +validColour :: Colour -> Bool +validColour (Colour r g b o) = r >= 0 && r <= 1 && g >= 0 && g <= 1 && b >= 0 && b <= 1 && o >= 0 && o <= 1 + +-- | Trim colour back to gamut. +-- +-- >>> trimColour (Colour 1 1 1.01 1) +-- Colour 1.00 1.00 1.00 1.00 +trimColour :: Colour -> Colour +trimColour (Colour r g b a) = Colour (trim r) (trim g) (trim b) (trim a) + where + trim x = max 0 $ min 1 x + +-- | Validate that the Colout is in-gamut. +-- +-- >>> validate (Colour 1 1 1.01 1) +-- Nothing +validate :: Colour -> Maybe Colour +validate c = bool Nothing (Just c) (validColour c) + +-- | Opacity or alpha opac :: Colour -> Double opac (Colour _ _ _ o) = o --- | set opacity -setOpac :: Double -> Colour -> Colour -setOpac o (Colour r g b _) = Colour r g b o +-- | lens for opacity (or alpha channel) +opac' :: Lens' Colour Double +opac' = lens opac (\(Colour r g b _) o -> Colour r g b o) --- | +-- | Convert to CSS hex representation. hex :: Colour -> Text hex c = toHex c --- | interpolate between 2 colors -blend :: Double -> Colour -> Colour -> Colour -blend c (Colour r g b a) (Colour r' g' b' a') = Colour r'' g'' b'' a'' - where - r'' = r + c * (r' - r) - g'' = g + c * (g' - g) - b'' = b + c * (b' - b) - a'' = a + c * (a' - a) - --- | interpolate across a list of Colours, with input being in Range 0 1 --- --- >>> blends 0 [black, (Colour 0.2 0.6 0.8 0.5), white] == black --- True --- --- >>> blends 1 [black, (Colour 0.2 0.6 0.8 0.5), white] == white --- True --- --- >>> blends 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white] --- Colour 0.36 0.68 0.84 0.60 -blends :: Double -> [Colour] -> Colour -blends _ [] = light -blends _ [c] = c -blends x cs = blend r (cs List.!! i) (cs List.!! (i + 1)) - where - l = length cs - 1 - x' = x * fromIntegral l - i = max 0 (min (floor x') (l - 1)) - r = x' - fromIntegral i +-- | Sets RGB color but not opacity +rgb :: Colour -> Colour -> Colour +rgb (Colour r g b _) (Colour _ _ _ o) = Colour r g b o --- | +-- | Parse CSS hex text. parseHex :: A.Parser (Color RGB Double) parseHex = fmap toDouble @@ -125,15 +201,15 @@ . (`divMod` 256) <$> (A.string "#" *> A.hexadecimal) --- | +-- | Convert CSS hex to Colour fromHex :: Text -> Either Text (Color RGB Double) fromHex = first pack . A.parseOnly parseHex --- | +-- | Convert CSS hex to Colour, unsafely. unsafeFromHex :: Text -> Color RGB Double unsafeFromHex t = fromRight (ColorRGB 0 0 0) $ A.parseOnly parseHex t --- | convert from 'Colour' to #xxxxxx +-- | Convert from 'Colour' to CSS hex (#xxxxxx) toHex :: Colour -> Text toHex c = "#" @@ -163,46 +239,48 @@ i2d :: Int -> Char i2d i = chr (ord '0' + i) --- | select a Colour from the palette +-- | Select a Colour from the palette -- -- >>> palette1 0 --- Colour 0.69 0.35 0.16 1.00 +-- Colour 0.02 0.73 0.80 1.00 +-- +-- ![wheel](other/wheel.svg) palette1 :: Int -> Colour palette1 x = cycle palette1_ List.!! x --- | finite list of Colours +palette1LCHA_ :: [LCHA] +palette1LCHA_ = [LCHA 0.72 0.123 207 1, LCHA 0.40 0.10 246 1, LCHA 0.50 0.21 338 1, LCHA 0.8 0.15 331 1, LCHA 0.83 0.14 69 1, LCHA 0.57 0.15 50 1, LCHA 0.38 0.085 128 1, LCHA 0.60 0.08 104 1] + +-- | Finite list of Colours +-- +-- Swatched to the oklab color model: +-- +-- ![palette1](other/palette1.svg) palette1_ :: [Colour] -palette1_ = - [ Colour 0.69 0.35 0.16 1.00, - Colour 0.65 0.81 0.89 1.00, - Colour 0.12 0.47 0.71 1.00, - Colour 0.89 0.10 0.11 1.00, - Colour 0.70 0.87 0.54 1.00, - Colour 0.20 0.63 0.17 1.00, - Colour 0.98 0.60 0.60 1.00, - Colour 0.99 0.75 0.44 1.00, - Colour 1.00 0.50 0.00 1.00, - Colour 0.99 0.99 0.99 1.00, - Colour 0.00 0.00 0.00 1.00, - Colour 1.00 1.00 0.60 1.00, - Colour 0.69 0.35 0.16 1.00 - ] +palette1_ = trimColour . view lcha2colour' <$> palette1LCHA_ --- | +-- | Select a Colour from the palette with a specified opacity -- +-- >>> palette1a 0 0.5 +-- Colour 0.02 0.73 0.80 0.50 +palette1a :: Int -> Double -> Colour +palette1a x a = set opac' a $ cycle palette1_ List.!! x + +-- | black +-- -- >>> black -- Colour 0.00 0.00 0.00 1.00 black :: Colour black = Colour 0 0 0 1 --- | +-- | white -- -- >>> white -- Colour 0.99 0.99 0.99 1.00 white :: Colour white = Colour 0.99 0.99 0.99 1 --- | +-- | light -- -- For lighter huds against a dark background ... -- @@ -213,7 +291,7 @@ light :: Colour light = Colour 0.94 0.94 0.94 1 --- | +-- | dark -- -- dark is hardcoded in most of the default options. -- @@ -222,9 +300,409 @@ dark :: Colour dark = Colour 0.05 0.05 0.05 1 --- | zero opacity black +-- | Grey(scale) colour inputting lightness and opacity. -- +-- >>> grey 0.5 0.4 +-- Colour 0.50 0.50 0.50 0.40 +grey :: Double -> Double -> Colour +grey g a = Colour g g g a + +-- | Zero-opacity black +-- -- >>> transparent -- Colour 0.00 0.00 0.00 0.00 transparent :: Colour transparent = Colour 0 0 0 0 + +-- | LCH colour representation +-- +-- oklab is a colour space being written into CSS specifications, that attempts to be ok at human-consistent colour representation. See: +-- +-- - +-- - +-- - +-- +-- The type is represented by three elements: +-- +-- L: Lightness ranging from 0 (@LCH 0 _ _@ is black) to 1 (@LCH 1 _ _@ is white) +-- +-- C: Chromacity, which ranges from 0 to around 0.32 or so. +-- +-- H: Hue, which ranges from 0 to 360 +newtype LCH a = LCH' {lchArray :: Array '[3] a} deriving (Eq, Show, IsList, Functor) + +-- | LCH colour pattern +pattern LCH :: a -> a -> a -> LCH a +pattern LCH l c h <- + LCH' [l, c, h] + where + LCH l c h = LCH' [l, c, h] + +{-# COMPLETE LCH #-} + +-- | Lightness lens for LCH +lLCH' :: Lens' (LCH Double) Double +lLCH' = lens (\(LCH l _ _) -> l) (\(LCH _ c h) l -> LCH l c h) + +-- | Chromacity lens for LCH +cLCH' :: Lens' (LCH Double) Double +cLCH' = lens (\(LCH _ c _) -> c) (\(LCH l _ h) c -> LCH l c h) + +-- | Hue lens for LCH +hLCH' :: Lens' (LCH Double) Double +hLCH' = lens (\(LCH _ _ h) -> h) (\(LCH l c _) h -> LCH l c h) + +-- | LCHA representation, including an alpha channel. +data LCHA = LCHA' {_lch :: LCH Double, _alpha :: Double} deriving (Eq, Show) + +-- | LCH lens for LCHA +lch' :: Lens' LCHA (LCH Double) +lch' = lens (\(LCHA' lch _) -> lch) (\(LCHA' _ a) lch -> LCHA' lch a) + +-- | Alpha lens for LCHA +alpha' :: Lens' LCHA Double +alpha' = lens (\(LCHA' _ a) -> a) (\(LCHA' lch _) a -> LCHA' lch a) + +-- | LCHA pattern +pattern LCHA :: Double -> Double -> Double -> Double -> LCHA +pattern LCHA l c h a <- + LCHA' (LCH' [l, c, h]) a + where + LCHA l c h a = LCHA' (LCH' [l, c, h]) a + +{-# COMPLETE LCHA #-} + +-- * RGB colour representation + +-- | A type to represent the RGB triple, useful as an intermediary between 'Colour' and 'LCHA' +newtype RGB3 a = RGB3' {rgb3Array :: Array '[3] a} deriving (Eq, Show, IsList, Functor) + +-- | The RGB3 pattern +pattern RGB3 :: a -> a -> a -> RGB3 a +pattern RGB3 r g b <- + RGB3' [r, g, b] + where + RGB3 r g b = RGB3' [r, g, b] + +{-# COMPLETE RGB3 #-} + +-- | Lens for conversion between Double and Word8 RGB triples. +rgbd' :: Iso' (RGB3 Double) (RGB3 Word8) +rgbd' = iso (fmap (floor . (* 256))) (fmap (\x -> fromIntegral x / 256.0)) + +-- | Lens for conversion between an (RGB3, alpha) pair and Colour +rgb32colour' :: Iso' (RGB3 Double, Double) Colour +rgb32colour' = iso (\(RGB3 r g b, a) -> Colour r g b a) (\(Colour r g b a) -> (RGB3 r g b, a)) + +-- * LAB colour representation + +-- | LAB colour representation. a is green-red and b is blue-yellow +newtype LAB a = LAB' {labArray :: Array '[3] a} deriving (Eq, Show, IsList, Functor) + +-- | LAB pattern +pattern LAB :: a -> a -> a -> LAB a +pattern LAB l a b <- + LAB' [l, a, b] + where + LAB l a b = LAB' [l, a, b] + +{-# COMPLETE LAB #-} + +-- * Colour conversions + +-- * lcha to colour + +-- | LCHA to Colour lens +-- +-- >>> c0 = Colour 0.78 0.36 0.02 1.00 +-- >>> view (re lcha2colour') c0 +-- LCHA' {_lch = LCH' {lchArray = [0.5969891006896103, 0.15793931531669247, 49.191113810479784]}, _alpha = 1.0} +-- +-- >>> view (re lcha2colour' % lcha2colour') c0 +-- Colour 0.78 0.36 0.02 1.00 +-- +-- >>> c1 = Colour 0.49 0.14 0.16 1 +-- >>> view (re lcha2colour') c1 +-- LCHA' {_lch = LCH' {lchArray = [0.40115567099848914, 0.12279066817938503, 21.51476756026837]}, _alpha = 1.0} +-- +-- >>> view (re lcha2colour' % lcha2colour') c1 +-- Colour 0.49 0.14 0.16 1.00 +lcha2colour' :: Iso' LCHA Colour +lcha2colour' = + iso + (\(LCHA' lch a) -> let (RGB3 r g b) = view (re lab2lch' % re rgb2lab') lch in Colour r g b a) + (\c@(Colour _ _ _ a) -> LCHA' (view (re rgb32colour' % _1 % rgb2lab' % lab2lch') c) a) + +-- * lab to lch + +-- | Lens between generic XY color representations and CH ones, which are polar version of the XY. +xy2ch' :: Iso' (Double, Double) (Double, Double) +xy2ch' = + iso + (\(x, y) -> (norm (Point x y), 180 / pi * mod_ (angle (Point x y)) (2 * pi))) + (\(c, h) -> let (Point x y) = coord (Polar c (pi / 180 * h)) in (x, y)) + +mod_ :: Double -> Double -> Double +mod_ x d = x - fromIntegral (floor (x / d) :: Integer) * d + +-- | Lens between LAB and LCH +lab2lch' :: Iso' (LAB Double) (LCH Double) +lab2lch' = + iso + (\(LAB l a b) -> let (c, h) = view xy2ch' (a, b) in LCH l c h) + (\(LCH l c h) -> let (a, b) = view (re xy2ch') (c, h) in LAB l a b) + +-- * rgb to lab + +-- | Lens between RGB3 and LAB +rgb2lab' :: Iso' (RGB3 Double) (LAB Double) +rgb2lab' = + iso + (\(RGB3' a) -> LAB' . xyz2lab_ . rgb2xyz_ $ a) + (\(LAB' a) -> RGB3' . xyz2rgb_ . lab2xyz_ $ a) + +-- * rgb to xyz + +xyz2rgb_ :: Array '[3] Double -> Array '[3] Double +xyz2rgb_ a = fromList [r, g, b] + where + (S.ColorSRGB r g b) = S.xyz2rgb (S.ColorXYZ (a `index` [0]) (a `index` [1]) (a `index` [2])) :: Color (S.SRGB 'S.NonLinear) Double + +-- >>> rgb2xyz_ [1,1,1] +-- [0.9505, 1.0, 1.089] +rgb2xyz_ :: Array '[3] Double -> Array '[3] Double +rgb2xyz_ a = fromList [x, y, z] + where + (S.ColorXYZ x y z) = S.rgb2xyz (S.ColorSRGB (a `index` [0]) (a `index` [1]) (a `index` [2])) :: Color (S.XYZ S.D65) Double + +-- * xyz to lab + +m1 :: Array '[3, 3] Double +m1 = + [ 0.8189330101, + 0.3618667424, + -0.1288597137, + 0.0329845436, + 0.9293118715, + 0.0361456387, + 0.0482003018, + 0.2643662691, + 0.6338517070 + ] + +m2 :: Array '[3, 3] Double +m2 = + [ 0.2104542553, + 0.7936177850, + -0.0040720468, + 1.9779984951, + -2.4285922050, + 0.4505937099, + 0.0259040371, + 0.7827717662, + -0.8086757660 + ] + +cubicroot :: (Floating a, Ord a) => a -> a +cubicroot x = bool (-1 * (-x) ** (1 / 3.0)) (x ** (1 / 3.0)) (x >= 0) + +-- >>> xyz2lab_ [0.95, 1, 1.089] +-- [0.9999686754143632, -2.580058168537569e-4, -1.1499756458199784e-4] +-- +-- >>> xyz2lab_ [1,0,0] +-- [0.4499315814860224, 1.2357102101076207, -1.9027581087245393e-2] +-- +-- >>> xyz2lab_ [0,1,0] +-- [0.921816758286376, -0.6712376131199635, 0.2633235500611929] +-- +-- >>> xyz2lab_ [1,0,1] +-- [0.5081033967278659, 1.147837087146462, -0.36768466477695416] +-- +-- >>> xyz2lab_ [0,0,1] +-- [0.15260258004008057, -1.4149965510120839, -0.4489272035597538] +xyz2lab_ :: Array '[3] Double -> Array '[3] Double +xyz2lab_ xyz = + dot sum (*) m2 (cubicroot <$> dot sum (*) m1 xyz) + +m1' :: Array '[3, 3] Double +m1' = + [ 1.227013851103521026, + -0.5577999806518222383, + 0.28125614896646780758, + -0.040580178423280593977, + 1.1122568696168301049, + -0.071676678665601200577, + -0.076381284505706892869, + -0.42148197841801273055, + 1.5861632204407947575 + ] + +m2' :: Array '[3, 3] Double +m2' = + [ 0.99999999845051981432, + 0.39633779217376785678, + 0.21580375806075880339, + 1.0000000088817607767, + -0.1055613423236563494, + -0.063854174771705903402, + 1.0000000546724109177, + -0.089484182094965759684, + -1.2914855378640917399 + ] + +lab2xyz_ :: Array '[3] Double -> Array '[3] Double +lab2xyz_ lab = + dot sum (*) m1' ((** 3.0) <$> dot sum (*) m2' lab) + +-- * mixins + +-- | Mix 2 colours, using the oklch model. +-- +-- This may not always be what you expect. One example is mixing black and another colour: +-- +-- >>> mix 0.8 (Colour 0 0 0 1) (Colour 0.2 0.6 0.8 0.5) +-- Colour -0.09 0.48 0.45 0.60 +-- +-- The mix has gone out of gamut because we are swishing through hue mixes. +-- +-- In this case, settting the hue on the black colour within the LCH contruct helps: +-- >>> betterblack = set (lch' % hLCH') (view hue' (Colour 0.2 0.6 0.8 0.5)) (review lcha2colour' black) +-- >>> view lcha2colour' $ mixLCHA 0.8 betterblack (review lcha2colour' $ Colour 0.2 0.6 0.8 0.5) +-- Colour 0.14 0.44 0.59 0.60 +mix :: Double -> Colour -> Colour -> Colour +mix x c0 c1 = view lcha2colour' (mixLCHA x (review lcha2colour' c0) (review lcha2colour' c1)) + +-- | Mix 2 colours, using the oklch model, trimming the reult back to in-gamut. +-- +-- >>> mixTrim 0.8 (Colour 0 0 0 1) (Colour 0.2 0.6 0.8 0.5) +-- Colour 0.00 0.48 0.45 0.60 +mixTrim :: Double -> Colour -> Colour -> Colour +mixTrim x c0 c1 = trimColour (mix x c0 c1) + +-- | Mix two LCHA specified colours. +mixLCHA :: Double -> LCHA -> LCHA -> LCHA +mixLCHA x (LCHA l c h a) (LCHA l' c' h' a') = LCHA l'' c'' h'' a'' + where + l'' = l + x * (l' - l) + c'' = c + x * (c' - c) + h'' = h + x * (h' - h) + a'' = a + x * (a' - a) + +-- | Interpolate across a list of Colours, with input being in Range 0 1 +-- +-- >>> mixes 0 [black, (Colour 0.2 0.6 0.8 0.5), white] +-- Colour 0.00 0.00 0.00 1.00 +-- +-- >>> mixes 1 [black, (Colour 0.2 0.6 0.8 0.5), white] +-- Colour 0.99 0.99 0.99 1.00 +-- +-- >>> mixes 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white] +-- Colour 0.42 0.67 0.86 0.60 +mixes :: Double -> [Colour] -> Colour +mixes _ [] = light +mixes _ [c] = c +mixes x cs = mix r (cs List.!! i) (cs List.!! (i + 1)) + where + l = length cs - 1 + x' = x * fromIntegral l + i = max 0 (min (floor x') (l - 1)) + r = x' - fromIntegral i + +-- * Colour manipulation + +-- | Convert a colour to grayscale with the same lightness. +-- +-- >>> greyed (Colour 0.4 0.7 0.8 0.4) +-- Colour 0.65 0.65 0.65 0.40 +greyed :: Colour -> Colour +greyed = over chroma' (const 0) + +-- | Lightness lens +-- +-- >>> over lightness' (*0.8) (Colour 0.4 0.7 0.8 0.4) +-- Colour 0.22 0.52 0.62 0.40 +lightness' :: Lens' Colour Double +lightness' = re lcha2colour' % lch' % lLCH' + +-- | Chromacity lens +-- +-- >>> over chroma' (*0.8) (Colour 0.4 0.7 0.8 0.4) +-- Colour 0.46 0.69 0.77 0.40 +chroma' :: Lens' Colour Double +chroma' = re lcha2colour' % lch' % cLCH' + +-- | Hue lens +-- +-- >>> over hue' (+180) (Colour 0.4 0.7 0.8 0.4) +-- Colour 0.83 0.58 0.49 0.40 +hue' :: Lens' Colour Double +hue' = re lcha2colour' % lch' % hLCH' + +-- | Html element to display colours +-- +-- >>> showSwatch "swatch" dark +-- "
swatch
" +showSwatch :: Text -> Colour -> Text +showSwatch label c = + [trimming|
$label
|] + where + rgba = showRGBA c + +-- | Show multiple colors with embedded text. +showSwatches :: Text -> Text -> [(Text, Colour)] -> Text +showSwatches pref suff hs = + [trimming|
+$pref +$divs +$suff +
+|] + where + divs = Text.intercalate "\n" (uncurry showSwatch <$> hs) + +-- * random colors + +instance Uniform (RGB3 Double) where + uniformM gen = do + r <- uniformRM (0, 1) gen + g <- uniformRM (0, 1) gen + b <- uniformRM (0, 1) gen + pure (RGB3 r g b) + +instance Uniform Colour where + uniformM gen = do + r <- uniformRM (0, 1) gen + g <- uniformRM (0, 1) gen + b <- uniformRM (0, 1) gen + a <- uniformRM (0, 1) gen + pure (Colour r g b a) + +-- | Random variates of a uniform +rvs :: (Uniform a) => [a] +rvs = go g0 + where + g0 = mkStdGen 42 + go g = let (x, g') = uniform g in x : go g' + +-- | Random list of RGB3s +rvRGB3 :: [RGB3 Double] +rvRGB3 = rvs + +-- | Random list of Colours +rvColour :: [Colour] +rvColour = rvs + +-- | Random Colours with an opacity of 1 that are not too extreme in terms of lightness or chromacity. +paletteR :: [Colour] +paletteR = go g0 + where + g0 = mkStdGen 42 + go g = let (x, g') = runStateGen g rvSensible in x : go g' + +-- | A random Colour generator that provides a (hopefully) pleasant colour not too light, dark, over-saturated or dull. +rvSensible :: StatefulGen g m => g -> m Colour +rvSensible gen = do + l <- uniformRM (0.3, 0.75) gen + c <- uniformRM (0.05, 0.24) gen + h <- uniformRM (0, 360) gen + pure ((trimColour . view lcha2colour') (LCHA l c h 1)) diff --git a/src/Data/FormatN.hs b/src/Data/FormatN.hs deleted file mode 100644 --- a/src/Data/FormatN.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - --- | Formatting of numeric values. -module Data.FormatN - ( FormatN (..), - defaultFormatN, - fromFormatN, - toFormatN, - fixed, - decimal, - prec, - comma, - expt, - dollar, - percent, - formatN, - precision, - formatNs, - showOr, - roundSig, - ) -where - -import Data.Bifunctor -import Data.Bool -import Data.Containers.ListUtils (nubOrd) -import Data.Foldable -import Data.Generics.Labels () -import Data.Scientific -import Data.String -import Data.Text (Text, pack) -import qualified Data.Text as Text -import GHC.Generics hiding (prec) -import Prelude - --- $setup - --- | Number formatting options. --- --- >>> defaultFormatN --- FormatComma (Just 2) -data FormatN - = FormatFixed (Maybe Int) - | FormatDecimal (Maybe Int) - | FormatComma (Maybe Int) - | FormatExpt (Maybe Int) - | FormatPrec (Maybe Int) - | FormatDollar (Maybe Int) - | FormatPercent (Maybe Int) - | FormatNone - deriving (Eq, Show, Generic) - --- | The official format -defaultFormatN :: FormatN -defaultFormatN = FormatComma (Just 2) - --- | textifier -fromFormatN :: (IsString s) => FormatN -> s -fromFormatN (FormatFixed _) = "Fixed" -fromFormatN (FormatDecimal _) = "Decimal" -fromFormatN (FormatComma _) = "Comma" -fromFormatN (FormatExpt _) = "Expt" -fromFormatN (FormatPrec _) = "Prec" -fromFormatN (FormatDollar _) = "Dollar" -fromFormatN (FormatPercent _) = "Percent" -fromFormatN FormatNone = "None" - --- | readifier -toFormatN :: (Eq s, IsString s) => s -> Maybe Int -> FormatN -toFormatN "Fixed" n = FormatFixed n -toFormatN "Decimal" n = FormatDecimal n -toFormatN "Comma" n = FormatComma n -toFormatN "Expt" n = FormatExpt n -toFormatN "Prec" n = FormatPrec n -toFormatN "Dollar" n = FormatDollar n -toFormatN "Percent" n = FormatPercent n -toFormatN "None" _ = FormatNone -toFormatN _ _ = FormatNone - --- | to x decimal places --- --- >>> fixed (Just 2) 1 --- "1.00" --- --- >>> fixed (Just 2) 0.001 --- "0.00" -fixed :: Maybe Int -> Double -> Text -fixed x n = pack $ formatScientific Fixed x (fromFloatDigits n) - --- | scientific exponential --- --- >>> expt (Just 2) 1234 --- "1.23e3" -expt :: Maybe Int -> Double -> Text -expt x n = pack $ formatScientific Exponent x (fromFloatDigits n) - --- | round to n significant figures --- --- >>> roundSig 2 1234 --- 1230.0 --- --- >>> roundSig 2 0.001234 --- 1.23e-3 -roundSig :: Int -> Double -> Scientific -roundSig n x = scientific r' (e - length ds0) - where - (ds, e) = toDecimalDigits $ fromFloatDigits x - (ds0, ds1) = splitAt (n + 1) ds - r = - (fromIntegral $ foldl' (\x a -> x * 10 + a) 0 ds0 :: Double) - + fromIntegral (foldl' (\x a -> x * 10 + a) 0 ds1) / (10.0 ^ length ds1) - r' = round r :: Integer - --- | format numbers between 0.001 and 1,000,000 using digit and comma notation and exponential outside this range, with x significant figures. --- > prec (Just 1) 0.00234 --- "0.0023" --- --- > prec (Just 1) 0.000023 --- "2.3e-5" --- --- > prec (Just 1) 123 --- "120" --- --- > prec (Just 1) 123456 --- "120,000" --- --- >>> prec (Just 1) 1234567 --- "1.2e6" -prec :: Maybe Int -> Double -> Text -prec n x - | x < 0 = "-" <> prec n (-x) - | x == 0 = decimal n (toRealFloat x') - | x < 0.001 = expt n x - | x > 1e6 = expt n x - | otherwise = decimal n (toRealFloat x') - where - x' = maybe fromFloatDigits roundSig n x - --- | round to n significant figures and always use decimal notation --- >>> decimal (Just 2) 0.000001234 --- "0.00000123" --- --- >>> decimal (Just 2) 1234567 --- "1230000" -decimal :: Maybe Int -> Double -> Text -decimal n x = x'' - where - x' = pack $ formatScientific Fixed Nothing $ maybe fromFloatDigits roundSig n x - x'' = (\x -> bool x' (fst x) (snd x == ".0")) $ Text.breakOn "." x' - --- | add commas format for numbers above 1,000 but below 1 million, otherwise use prec. --- --- >>> comma Nothing 1234.567 --- "1,234.567" --- --- >>> comma (Just 2) 1234 --- "1,230" -comma :: Maybe Int -> Double -> Text -comma n x - | x < 0 = "-" <> comma n (-x) - | x < 1000 || x > 1e6 = prec n x - | otherwise = case n of - Nothing -> addcomma (pack $ show x) - Just _ -> addcomma (prec n x) - where - addcomma :: Text -> Text - addcomma x = uncurry (<>) . first (Text.reverse . Text.intercalate "," . Text.chunksOf 3 . Text.reverse) $ Text.breakOn "." x - --- | dollars and cents, always decimal notation --- --- >>> dollar (Just 2) 1234 --- "$1,230" --- --- >>> dollar (Just 2) 0.01234 --- "$0.0123" -dollar :: Maybe Int -> Double -> Text -dollar n x - | x < 0 = "-" <> dollar n (-x) - | otherwise = "$" <> comma n x - --- | fixed percent, always decimal notation --- --- >>> percent (Just 2) 0.001234 --- "0.123%" -percent :: Maybe Int -> Double -> Text -percent n x = (<> "%") $ decimal n (100 * x) - --- | make text -formatN :: FormatN -> Double -> Text -formatN (FormatFixed n) x = fixed n x -formatN (FormatDecimal n) x = decimal n x -formatN (FormatPrec n) x = prec n x -formatN (FormatComma n) x = comma n x -formatN (FormatExpt n) x = expt n x -formatN (FormatDollar n) x = dollar n x -formatN (FormatPercent n) x = percent n x -formatN FormatNone x = pack (show x) - --- | Provide formatted text for a list of numbers so that they are just distinguished. 'precision commas (Just 2) ticks' means use as much precision as is needed for them to be distinguished, but with at least 2 significant figures. -precision :: (Maybe Int -> Double -> Text) -> Maybe Int -> [Double] -> [Text] -precision f Nothing xs = f Nothing <$> xs -precision f (Just n0) xs = - precLoop f n0 xs - where - precLoop f' n xs' = - let s = f' (Just n) <$> xs' - in if s == nubOrd s || n > 4 - then s - else precLoop f' (n + 1) xs' - --- | Consistently format a list of doubles. -formatNs :: FormatN -> [Double] -> [Text] -formatNs (FormatFixed n) xs = precision fixed n xs -formatNs (FormatDecimal n) xs = precision decimal n xs -formatNs (FormatPrec n) xs = precision prec n xs -formatNs (FormatComma n) xs = precision comma n xs -formatNs (FormatExpt n) xs = precision expt n xs -formatNs (FormatDollar n) xs = precision dollar n xs -formatNs (FormatPercent n) xs = precision percent n xs -formatNs FormatNone xs = pack . show <$> xs - --- | Format with the shorter of show and formatN. -showOr :: FormatN -> Double -> Text -showOr f x = bool (bool f' (pack s') (Text.length (pack s') < Text.length f')) "0" (x < 1e-6 && x > -1e-6) - where - f' = formatN f x - s' = show x diff --git a/src/Data/Path.hs b/src/Data/Path.hs --- a/src/Data/Path.hs +++ b/src/Data/Path.hs @@ -1,25 +1,24 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- | SVG path manipulation module Data.Path - ( -- * Path fundamental + ( -- * Svg Paths -- $path - PathInfo (..), + PathData (..), + pointPath, + movePath, + scalePath, + projectPaths, + pathBoxes, + pathBox, + + -- * Path maths ArcInfo (..), ArcPosition (..), - parsePath, - toPathAbsolute, - toPathCommand, - toPathAbsolutes, - toPathXYs, ArcCentroid (..), arcCentroid, arcPosition, @@ -44,42 +43,25 @@ singletonQuad, singletonArc, singletonPie, - singletonPie', - toSingletonArc, - pathBoxes, - pathBox, ) where +import Chart.Data import qualified Control.Foldl as L -import Control.Lens hiding ((...)) -import qualified Data.Attoparsec.Text as A -import Data.Bifunctor -import Data.Either -import Data.FormatN -import Data.Generics.Labels () -import Data.Text (Text, pack) -import qualified Data.Text as Text +import Control.Monad.State.Lazy import GHC.Generics -import GHC.OverloadedLabels import qualified Geom2D.CubicBezier as B -import Graphics.SvgTree (Origin (..), PathCommand (..)) -import qualified Graphics.SvgTree as SvgTree -import Graphics.SvgTree.PathParser -import qualified Linear import NumHask.Prelude -import NumHask.Space -- $setup --- FIXME: --- :set -XRebindableSyntax gets timed out by cabal-docspec here, but NoImplicitPrelude works. --- >>> :set -XNoImplicitPrelude --- >>> :set -XNegativeLiterals +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings -- >>> import Chart --- >>> import NumHask.Prelude +-- >>> import Optics.Core -- $path --- Every element of an svg path can be thought of as exactly two points in space, with instructions of how to draw a curve between them. From this point of view, one which this library adopts, a path chart is thus very similar to a line chart. There's just a lot more information about the style of this line to deal with. +-- Every element of an SVG path can be thought of as exactly two points in space, with instructions of how to draw a curve between them. From this point of view, one which this library adopts, a path chart is thus very similar to a line chart. There's just a lot more information about the style to deal with. -- -- References: -- @@ -87,284 +69,87 @@ -- -- [SVG path](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths) --- | parse a raw path string --- --- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z" --- >>> parsePath outerseg1 --- [MoveTo OriginAbsolute [V2 (-1.0) 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,V2 0.0 (-1.2320508075688774)),(1.0,1.0,0.0,False,False,V2 (-0.5) (-0.3660254037844387)),(1.0,1.0,0.0,False,False,V2 (-1.0) 0.5)],EndPath] --- --- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d -parsePath :: Text -> [PathCommand] -parsePath t = fromRight [] $ A.parseOnly pathParser t - --- | To fit in with the requirements of the library design, specifically the separation of what a chart is into XY data Points from representation of these points, path instructions need to be decontructed into: --- --- - define a single chart element as a line. --- --- - split a single path element into the start and end points of the line, which become the 'Chart.Types.xys' of a 'Chart.Types.Chart', and the rest of the information, which is called 'PathInfo' and incorporated into the 'Chart.Types.Chart' 'Chart.Types.annotation'. --- --- An arc path is variant to affine transformations of the 'Chart.Types.xys' points: angles are not presevred in the new reference frame. -data PathInfo a - = StartI - | LineI - | CubicI (Point a) (Point a) - | QuadI (Point a) - | ArcI (ArcInfo a) +-- | Representation of a single SVG path data point +data PathData a + = -- | Starting position + StartP (Point a) + | -- | line (from previous position) + LineP (Point a) + | -- | cubic bezier curve + CubicP (Point a) (Point a) (Point a) + | -- | quad bezier curve + QuadP (Point a) (Point a) + | -- arc + ArcP (ArcInfo a) (Point a) deriving (Show, Eq, Generic) --- | convert from a path info, start point, end point triple to a path text clause. --- --- Note that morally, --- --- > toPathsAbsolute . toInfos . parsePath == id --- --- but the round trip destroys much information, including: --- --- - path text spacing --- --- - "Z", which is replaced by a LineI instruction from the end point back to the original start of the path. --- --- - Sequences of the same instruction type are uncompressed --- --- - As the name suggests, relative paths are translated to absolute ones. --- --- - implicit L's in multiple M instructions are separated. --- --- In converting between chart-svg and SVG there are two changes in reference: --- --- - arc rotation is expressed as positive degrees for a clockwise rotation in SVG, and counter-clockwise in radians for chart-svg --- --- - A positive y-direction is down for SVG and up for chart-svg -toPathAbsolute :: - -- | (info, start, end) - (PathInfo Double, Point Double) -> - -- | path text - Text -toPathAbsolute (StartI, p) = "M " <> pp p -toPathAbsolute (LineI, p) = "L " <> pp p -toPathAbsolute (CubicI c1 c2, next) = - "C " - <> pp c1 - <> " " - <> pp c2 - <> " " - <> pp next -toPathAbsolute (QuadI control, next) = - "Q " - <> pp control - <> " " - <> pp next -toPathAbsolute (ArcI (ArcInfo (Point x y) phi' l sw), x2) = - "A " - <> (pack . show) x - <> " " - <> (pack . show) y - <> " " - <> (pack . show) (-phi' * 180 / pi) - <> " " - <> bool "0" "1" l - <> " " - <> bool "0" "1" sw - <> " " - <> pp x2 - --- | render a point (including a flip of the y dimension). -pp :: Point Double -> Text -pp (Point x y) = - showOr (FormatFixed (Just 4)) x <> "," - <> showOr (FormatFixed (Just 4)) (bool (-y) y (y == zero)) - --- | convert an (info, point) list to an svg d path text. -toPathAbsolutes :: [(PathInfo Double, Point Double)] -> Text -toPathAbsolutes = L.fold (L.Fold step begin done) - where - done = Text.intercalate " " . reverse - begin = [] - step ts (info, next) = toPathAbsolute (info, next) : ts - --- | Convert from PathInfo to PathCommand -toPathCommand :: - (PathInfo Double, Point Double) -> - -- | path text - PathCommand -toPathCommand (StartI, p) = MoveTo OriginAbsolute [toV2 p] -toPathCommand (LineI, p) = LineTo OriginAbsolute [toV2 p] -toPathCommand (CubicI c1 c2, p) = CurveTo OriginAbsolute [(toV2 c1, toV2 c2, toV2 p)] -toPathCommand (QuadI c, p) = QuadraticBezier OriginAbsolute [(toV2 c, toV2 p)] -toPathCommand (ArcI (ArcInfo (Point rx ry) phi' l sw), p) = - EllipticalArc OriginAbsolute [(rx, ry, phi', l, sw, toV2 p)] - -toV2 :: Point a -> Linear.V2 a -toV2 (Point x y) = Linear.V2 x y +-- | View the Point part of a PathData +pointPath :: PathData a -> Point a +pointPath (StartP p) = p +pointPath (LineP p) = p +pointPath (CubicP _ _ p) = p +pointPath (QuadP _ p) = p +pointPath (ArcP _ p) = p -data StateInfo = StateInfo - { -- | previous position - cur :: Point Double, - -- | start point (to close out the path) - start :: Point Double, - -- | last control point - infoControl :: Point Double - } - deriving (Eq, Show, Generic) +-- | Move the Point part of a PathData +movePath :: (Additive a) => Point a -> PathData a -> PathData a +movePath x (StartP p) = StartP (p + x) +movePath x (LineP p) = LineP (p + x) +movePath x (CubicP c1 c2 p) = CubicP (c1 + x) (c2 + x) (p + x) +movePath x (QuadP c p) = QuadP (c + x) (p + x) +movePath x (ArcP i p) = ArcP i (p + x) -stateInfo0 :: StateInfo -stateInfo0 = StateInfo zero zero zero +-- | Multiplicatively scale a PathData +scalePath :: (Multiplicative a) => a -> PathData a -> PathData a +scalePath x (StartP p) = StartP (fmap (x *) p) +scalePath x (LineP p) = LineP (fmap (x *) p) +scalePath x (CubicP c1 c2 p) = CubicP (fmap (x *) c1) (fmap (x *) c2) (fmap (x *) p) +scalePath x (QuadP c p) = QuadP (fmap (x *) c) (fmap (x *) p) +scalePath x (ArcP i p) = ArcP i (fmap (x *) p) --- | Convert a path command fragment to an instruction + point. --- --- flips the y-dimension of points. -toInfo :: StateInfo -> SvgTree.PathCommand -> (StateInfo, [(PathInfo Double, Point Double)]) -toInfo s (MoveTo _ []) = (s, []) -toInfo _ (MoveTo OriginAbsolute (x : xs)) = L.fold (L.Fold step begin (second reverse)) (fromV2 <$> xs) - where - x0 = fromV2 x - begin = (StateInfo x0 x0 zero, [(StartI, x0)]) - step (s, p) a = (s & #cur .~ a, (LineI, a) : p) -toInfo s (MoveTo OriginRelative (x : xs)) = L.fold (L.Fold step begin (second reverse)) (fromV2 <$> xs) - where - x0 = s ^. #cur + fromV2 x - begin = (StateInfo x0 x0 zero, [(StartI, x0)]) - step (s, p) a = let a' = a + s ^. #cur in (s & #cur .~ a', (LineI, a') : p) -toInfo s EndPath = (s, [(LineI, s ^. #start)]) -toInfo s (LineTo OriginAbsolute xs) = L.fold (L.Fold step (s, []) (second reverse)) (fromV2 <$> xs) - where - step (s, p) a = (s & #cur .~ a, (LineI, a) : p) -toInfo s (LineTo OriginRelative xs) = L.fold (L.Fold step (s, []) (second reverse)) (fromV2 <$> xs) - where - step (s, p) a = let a' = a + s ^. #cur in (s & #cur .~ a', (LineI, a') : p) -toInfo s (HorizontalTo OriginAbsolute xs) = L.fold (L.Fold step (s, []) (second reverse)) xs - where - step (s@(StateInfo (Point _ cy) _ _), p) a = - let a' = Point a cy in (s & #cur .~ a', (LineI, a') : p) -toInfo s (HorizontalTo OriginRelative xs) = L.fold (L.Fold step (s, []) (second reverse)) xs - where - step (s@(StateInfo (Point cx cy) _ _), p) a = - let a' = Point (a + cx) cy in (s & #cur .~ a', (LineI, a') : p) -toInfo s (VerticalTo OriginAbsolute xs) = L.fold (L.Fold step (s, []) (second reverse)) xs - where - step (s@(StateInfo (Point cx _) _ _), p) a = - let a' = Point cx a in (s & #cur .~ a', (LineI, a') : p) -toInfo s (VerticalTo OriginRelative xs) = L.fold (L.Fold step (s, []) (second reverse)) xs - where - step (s@(StateInfo (Point cx cy) _ _), p) a = - let a' = Point cx (a + cy) in (s & #cur .~ a', (LineI, a') : p) -toInfo s (CurveTo OriginAbsolute xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = (\(c1, c2, x2) -> (fromV2 c1, fromV2 c2, fromV2 x2)) <$> xs - step (s, p) (c1, c2, x2) = - (s & #cur .~ x2 & #infoControl .~ c2, (CubicI c1 c2, x2) : p) -toInfo s (CurveTo OriginRelative xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = (\(c1, c2, x2) -> (fromV2 c1, fromV2 c2, fromV2 x2)) <$> xs - step (s, p) (c1, c2, x2) = - (s & #cur .~ (x2 + s ^. #cur) & #infoControl .~ (c2 + s ^. #cur), (CubicI (c1 + s ^. #cur) (c2 + s ^. #cur), x2 + s ^. #cur) : p) -toInfo s (SmoothCurveTo OriginAbsolute xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = bimap fromV2 fromV2 <$> xs - step (s, p) (c2, x2) = - (s & #cur .~ x2, (CubicI (s ^. #cur - (s ^. #infoControl - s ^. #cur)) c2, x2) : p) -toInfo s (SmoothCurveTo OriginRelative xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = bimap fromV2 fromV2 <$> xs - step (s, p) (c2, x2) = - ( s - & #cur .~ (x2 + s ^. #cur) - & #infoControl .~ (c2 + s ^. #cur), - (CubicI (s ^. #cur - (s ^. #infoControl - s ^. #cur)) (c2 + s ^. #cur), x2 + s ^. #cur) : p - ) -toInfo s (QuadraticBezier OriginAbsolute xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = bimap fromV2 fromV2 <$> xs - step (s, p) (c1, x2) = - ( s - & #cur .~ x2 - & #infoControl .~ c1, - (QuadI c1, x2) : p - ) -toInfo s (QuadraticBezier OriginRelative xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = bimap fromV2 fromV2 <$> xs - step (s, p) (c1, x2) = - (s & #cur .~ x2 & #infoControl .~ (c1 + s ^. #cur), (QuadI (c1 + s ^. #cur), x2 + s ^. #cur) : p) -toInfo s (SmoothQuadraticBezierCurveTo OriginAbsolute xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = fromV2 <$> xs - step (s, p) x2 = - ( s - & #cur .~ x2 - & #infoControl .~ (s ^. #cur - (s ^. #infoControl - s ^. #cur)), - (QuadI (s ^. #cur - (s ^. #infoControl - s ^. #cur)), x2) : p - ) -toInfo s (SmoothQuadraticBezierCurveTo OriginRelative xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = fromV2 <$> xs - step (s, p) x2 = - ( s - & #cur .~ (x2 + s ^. #cur) - & #infoControl .~ (s ^. #cur - (s ^. #infoControl - s ^. #cur)), - (QuadI (s ^. #cur - (s ^. #infoControl - s ^. #cur)), x2 + s ^. #cur) : p +-- | Project a list of connected PathDatas from one Rect (XY plave) to a new one. +projectPaths :: Rect Double -> Rect Double -> [PathData Double] -> [PathData Double] +projectPaths new old ps = + flip evalState zero $ + sequence $ + ( \p -> do + x <- get + let d = projectPath new old x p + put (pointPath d) + pure d ) -toInfo s (EllipticalArc OriginAbsolute xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = (\(x, y, r, l, sw, x2) -> (x, y, r, l, sw, fromV2 x2)) <$> xs - step (s, p) a@(_, _, _, _, _, x2) = - (s & #cur .~ x2, (fromPathEllipticalArc (s ^. #cur) a, x2) : p) -toInfo s (EllipticalArc OriginRelative xs) = - L.fold (L.Fold step (s, []) (second reverse)) xs' - where - xs' = (\(x, y, r, l, sw, x2) -> (x, y, r, l, sw, fromV2 x2)) <$> xs - step (s, p) a@(_, _, _, _, _, x2) = - let x2' = x2 + s ^. #cur - in (s & #cur .~ x2', (fromPathEllipticalArc (s ^. #cur) a, x2') : p) - -fromPathEllipticalArc :: Point a -> (a, a, a, Bool, Bool, Point a) -> PathInfo a -fromPathEllipticalArc _ (x, y, r, l, s, _) = ArcI (ArcInfo (Point x y) r l s) - -fromV2 :: (Subtractive a) => Linear.V2 a -> Point a -fromV2 (Linear.V2 x y) = Point x (-y) - --- | Convert from a path command list to a PathA specification -toPathXYs :: [SvgTree.PathCommand] -> [(PathInfo Double, Point Double)] -toPathXYs [] = [] -toPathXYs xs = - snd (foldl' (\(x, l) a -> second (l <>) $ toInfo x a) (stateInfo0, []) xs) - --- | convert cubic position to path info. -singletonCubic :: CubicPosition Double -> [(PathInfo Double, Point Double)] -singletonCubic (CubicPosition s e c1 c2) = [(StartI, s), (CubicI c1 c2, e)] + <$> ps --- | convert quad position to path info. -singletonQuad :: QuadPosition Double -> [(PathInfo Double, Point Double)] -singletonQuad (QuadPosition s e c) = [(StartI, s), (QuadI c, e)] +-- | Project a PathData from one Rect (XY plave) to a new one. +projectPath :: + Rect Double -> + Rect Double -> + Point Double -> + PathData Double -> + PathData Double +projectPath new old _ (CubicP c1 c2 p) = + CubicP (projectOnP new old c1) (projectOnP new old c2) (projectOnP new old p) +projectPath new old _ (QuadP c p) = + QuadP (projectOnP new old c) (projectOnP new old p) +projectPath new old p1 (ArcP ai p2) = ArcP (projectArcPosition new old (ArcPosition p1 p2 ai)) (projectOnP new old p2) +projectPath new old _ (LineP p) = LineP (projectOnP new old p) +projectPath new old _ (StartP p) = StartP (projectOnP new old p) --- | convert arc position to path info. -singletonArc :: ArcPosition Double -> [(PathInfo Double, Point Double)] -singletonArc (ArcPosition s e i) = [(StartI, s), (ArcI i, e)] +-- | Convert cubic position to path data. +singletonCubic :: CubicPosition Double -> [PathData Double] +singletonCubic (CubicPosition s e c1 c2) = [StartP s, CubicP c1 c2 e] --- | convert arc position to a pie slice. -singletonPie :: ArcPosition Double -> [(PathInfo Double, Point Double)] -singletonPie p@(ArcPosition s e i) = [(StartI, c), (LineI, s), (ArcI i, e), (LineI, c)] - where - ac = arcCentroid p - c = ac ^. #centroid +-- | Convert quad position to path data. +singletonQuad :: QuadPosition Double -> [PathData Double] +singletonQuad (QuadPosition s e c) = [StartP s, QuadP c e] --- | convert arc position to a pie slice, with a specific center. -singletonPie' :: Point Double -> ArcPosition Double -> [(PathInfo Double, Point Double)] -singletonPie' c (ArcPosition s e i) = [(StartI, c), (LineI, s), (ArcI i, e), (LineI, c)] +-- | Convert arc position to path data. +singletonArc :: ArcPosition Double -> [PathData Double] +singletonArc (ArcPosition s e i) = [StartP s, ArcP i e] --- | convert path info to an ArcPosition. -toSingletonArc :: [(PathInfo Double, Point Double)] -> Maybe (ArcPosition Double) -toSingletonArc ((StartI, s) : (ArcI i, e) : _) = Just $ ArcPosition s e i -toSingletonArc _ = Nothing +-- | Convert arc position to a pie slice, with a specific center. +singletonPie :: Point Double -> ArcPosition Double -> [PathData Double] +singletonPie c (ArcPosition s e i) = [StartP c, LineP s, ArcP i e, LineP c] -- * Arc types @@ -412,32 +197,32 @@ -- >>> let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) -- >>> arcCentroid p -- ArcCentroid {centroid = Point 0.20952624903444356 -0.48412291827592724, radius = Point 1.0 0.5, cphi = 0.7853981633974483, ang0 = 1.3753858999692936, angdiff = -1.823476581936975} -arcCentroid :: (FromInteger a, Ord a, TrigField a, ExpField a) => ArcPosition a -> ArcCentroid a -arcCentroid (ArcPosition p1@(Point x1 y1) p2@(Point x2 y2) (ArcInfo rad phi large clockwise)) = ArcCentroid c (Point rx ry) phi ang1 angd +arcCentroid :: (Ord a, FromInteger a, TrigField a, ExpField a) => ArcPosition a -> ArcCentroid a +arcCentroid (ArcPosition p1@(Point x1 y1) p2@(Point x2 y2) (ArcInfo rad phi' large' clockwise')) = ArcCentroid c (Point rx ry) phi' ang1 angd where - (Point x1' y1') = rotateP (-phi) ((p1 - p2) /. two) + (Point x1' y1') = rotateP (-phi') ((p1 - p2) /. two) (Point rx' ry') = rad l = x1' ** 2 / rx' ** 2 + y1' ** 2 / ry' ** 2 (rx, ry) = bool (rx', ry') (rx' * sqrt l, ry' * sqrt l) (l > 1) snumer = max 0 $ (rx * rx * ry * ry) - (rx * rx * y1' * y1') - (ry * ry * x1' * x1') s = - bool -1 1 (large == clockwise) + bool (-1) 1 (large' == clockwise') * sqrt (snumer / (rx * rx * y1' * y1' + ry * ry * x1' * x1')) cx' = s * rx * y1' / ry cy' = s * (-ry) * x1' / rx - cx = (x1 + x2) / 2 + cos phi * cx' - sin phi * cy' - cy = (y1 + y2) / 2 + sin phi * cx' + cos phi * cy' + cx = (x1 + x2) / 2 + cos phi' * cx' - sin phi' * cy' + cy = (y1 + y2) / 2 + sin phi' * cx' + cos phi' * cy' c = Point cx cy ang1 = angle (Point (-(cx' - x1') / rx) (-(cy' - y1') / ry)) ang2 = angle (Point (-(cx' + x1') / rx) (-(cy' + y1') / ry)) angd' = ang2 - ang1 angd = - bool 0 (2 * pi) (not clockwise && angd' < 0) - + bool 0 (-2 * pi) (clockwise && angd' > 0) + bool 0 (2 * pi) (not clockwise' && angd' < 0) + + bool 0 (-2 * pi) (clockwise' && angd' > 0) + angd' --- | convert from an ArcCentroid to an ArcPosition specification. +-- | Convert from an ArcCentroid to an ArcPosition specification. -- -- Morally, -- > arcPosition . arcCentroid == id @@ -448,15 +233,15 @@ -- -- - radii are less than they should be and thus get scaled up. arcPosition :: (Ord a, Signed a, TrigField a) => ArcCentroid a -> ArcPosition a -arcPosition (ArcCentroid c r phi ang1 angd) = - ArcPosition p1 p2 (ArcInfo r phi large clockwise) +arcPosition (ArcCentroid c r phi' ang1 angd) = + ArcPosition p1 p2 (ArcInfo r phi' large' clockwise') where - p1 = ellipse c r phi ang1 - p2 = ellipse c r phi (ang1 + angd) - large = abs angd > pi - clockwise = angd < zero + p1 = ellipse c r phi' ang1 + p2 = ellipse c r phi' (ang1 + angd) + large' = abs angd > pi + clockwise' = angd < zero --- | ellipse formulae +-- | Ellipse formulae -- -- >>> ellipse zero (Point 1 2) (pi/6) pi -- Point -0.8660254037844388 -0.4999999999999997 @@ -471,19 +256,20 @@ -- -- See also: [wolfram](https://mathworld.wolfram.com/Ellipse.html) ellipse :: (Direction b a, Affinity b a, TrigField a) => b -> b -> a -> a -> b -ellipse c r phi theta = c + (rotate phi |. (r * ray theta)) +ellipse c r phi' theta = c + (rotate phi' |. (r * ray theta)) -- | compute the bounding box for an arcBox -- --- > let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) --- > arcBox p --- Rect -8.326672684688674e-17 0.9999999999999998 -5.551115123125783e-17 0.30644649676616753 +-- >>> let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) +-- >>> import Data.FormatN +-- >>> fmap (fixed (Just 3)) (arcBox p) +-- Rect "-0.000" "1.000" "-0.000" "0.306" arcBox :: ArcPosition Double -> Rect Double -arcBox p = space1 pts +arcBox p = unsafeSpace1 pts where - (ArcCentroid c r phi ang0 angd) = arcCentroid p - (x', y') = arcDerivs r phi - angr = ang0 ... (ang0 + angd) :: Range Double + (ArcCentroid c r phi' ang0' angd) = arcCentroid p + (x', y') = arcDerivs r phi' + angr = ang0' ... (ang0' + angd) :: Range Double angs = filter (|.| angr) @@ -495,22 +281,20 @@ y' - 2 * pi, y' + pi, y' - pi, - ang0, - ang0 + angd + ang0', + ang0' + angd ] - pts = ellipse c r phi <$> angs + pts = ellipse c r phi' <$> angs --- | potential arc turning points. +-- | Potential arc turning points. -- -- >>> arcDerivs (Point 1 0.5) (pi/4) -- (-0.4636476090008061,0.4636476090008062) arcDerivs :: Point Double -> Double -> (Double, Double) -arcDerivs (Point rx ry) phi = (thetax1, thetay1) +arcDerivs (Point rx ry) phi' = (thetax1, thetay1) where - thetax1 = atan2 (-sin phi * ry) (cos phi * rx) - thetay1 = atan2 (cos phi * ry) (sin phi * rx) - --- * bezier + thetax1 = atan2 (-sin phi' * ry) (cos phi' * rx) + thetay1 = atan2 (cos phi' * ry) (sin phi' * rx) -- | Quadratic bezier curve expressed in positional terms. data QuadPosition a = QuadPosition @@ -536,12 +320,12 @@ -- | Convert from a positional to a polar representation of a cubic bezier. -- --- >>> quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- >>> quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) -- QuadPolar {qpolStart = Point 0.0 0.0, qpolEnd = Point 1.0 1.0, qpolControl = Polar {magnitude = 2.1213203435596424, direction = -0.7853981633974483}} -quadPolar :: (Eq a, ExpField a, TrigField a) => QuadPosition a -> QuadPolar a -quadPolar (QuadPosition start end control) = QuadPolar start end control' +quadPolar :: (Eq a, TrigField a, ExpField a) => QuadPosition a -> QuadPolar a +quadPolar (QuadPosition start' end control) = QuadPolar start' end control' where - mp = (start + end) /. two + mp = (start' + end) /. two control' = polar (control - mp) -- | Convert from a polar to a positional representation of a quadratic bezier. @@ -549,45 +333,45 @@ -- > quadPosition . quadPolar == id -- > quadPolar . quadPosition == id -- --- >>> quadPosition $ quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- >>> quadPosition $ quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) -- QuadPosition {qposStart = Point 0.0 0.0, qposEnd = Point 1.0 1.0, qposControl = Point 2.0 -0.9999999999999998} -quadPosition :: (ExpField a, TrigField a) => QuadPolar a -> QuadPosition a -quadPosition (QuadPolar start end control) = QuadPosition start end control' +quadPosition :: (TrigField a) => QuadPolar a -> QuadPosition a +quadPosition (QuadPolar start' end control) = QuadPosition start' end control' where - control' = coord control + (start + end) /. two + control' = coord control + (start' + end) /. two -- | The quadratic bezier equation -- --- >>> quadBezier (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) 0.33333333 +-- >>> quadBezier (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) 0.33333333 -- Point 0.9999999933333332 -0.33333333333333326 -quadBezier :: (ExpField a, FromInteger a) => QuadPosition a -> a -> Point a -quadBezier (QuadPosition start end control) theta = - (1 - theta) ^ 2 .* start +quadBezier :: (FromInteger a, ExpField a) => QuadPosition a -> a -> Point a +quadBezier (QuadPosition start' end control) theta = + (1 - theta) ^ 2 .* start' + 2 * (1 - theta) * theta .* control + theta ^ 2 .* end -- | QuadPosition turning points. -- --- >>> quadDerivs (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- >>> quadDerivs (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) -- [0.6666666666666666,0.3333333333333333] quadDerivs :: QuadPosition Double -> [Double] -quadDerivs (QuadPosition start end control) = [x', y'] +quadDerivs (QuadPosition start' end control) = [x', y'] where - (Point detx dety) = start - 2 .* control + end - x' = bool ((_x start - _x control) / detx) (2 * (_x control - _x start)) (detx == 0) - y' = bool ((_y start - _y control) / dety) (2 * (_y control - _y start)) (dety == 0) + (Point detx dety) = start' - 2 .* control + end + x' = bool ((_x start' - _x control) / detx) (2 * (_x control - _x start')) (detx == 0) + y' = bool ((_y start' - _y control) / dety) (2 * (_y control - _y start')) (dety == 0) -- | Bounding box for a QuadPosition -- --- >>> quadBox (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- >>> quadBox (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) -- Rect 0.0 1.3333333333333335 -0.33333333333333337 1.0 quadBox :: QuadPosition Double -> Rect Double -quadBox p = space1 pts +quadBox p = unsafeSpace1 pts where ts = quadDerivs p pts = quadBezier p <$> ([0, 1] <> ts) --- | cubic bezier curve +-- | Cubic bezier curve -- -- Note that the ordering is different to the svg standard. data CubicPosition a = CubicPosition @@ -620,42 +404,42 @@ -- > cubicPosition . cubicPolar == id -- > cubicPolar . cubicPosition == id -- --- >>> cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) +-- >>> cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) -- CubicPolar {cpolStart = Point 0.0 0.0, cpolEnd = Point 1.0 1.0, cpolControl1 = Polar {magnitude = 1.1180339887498947, direction = -1.2490457723982544}, cpolControl2 = Polar {magnitude = 1.1180339887498947, direction = 1.8925468811915387}} cubicPolar :: (Eq a, ExpField a, TrigField a) => CubicPosition a -> CubicPolar a -cubicPolar (CubicPosition start end control1 control2) = CubicPolar start end control1' control2' +cubicPolar (CubicPosition start' end control1 control2) = CubicPolar start' end control1' control2' where - mp = (start + end) /. two - control1' = polar $ (control1 - mp) /. norm (end - start) - control2' = polar $ (control2 - mp) /. norm (end - start) + mp = (start' + end) /. two + control1' = polar $ (control1 - mp) /. norm (end - start') + control2' = polar $ (control2 - mp) /. norm (end - start') -- | Convert from a polar to a positional representation of a cubic bezier. -- -- > cubicPosition . cubicPolar == id -- > cubicPolar . cubicPosition == id -- --- >>> cubicPosition $ cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) +-- >>> cubicPosition $ cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) -- CubicPosition {cposStart = Point 0.0 0.0, cposEnd = Point 1.0 1.0, cposControl1 = Point 1.0 -1.0, cposControl2 = Point 1.6653345369377348e-16 2.0} -cubicPosition :: (Eq a, ExpField a, TrigField a) => CubicPolar a -> CubicPosition a -cubicPosition (CubicPolar start end control1 control2) = CubicPosition start end control1' control2' +cubicPosition :: (Eq a, TrigField a, ExpField a) => CubicPolar a -> CubicPosition a +cubicPosition (CubicPolar start' end control1 control2) = CubicPosition start' end control1' control2' where - control1' = norm (end - start) .* coord control1 + (start + end) /. two - control2' = norm (end - start) .* coord control2 + (start + end) /. two + control1' = norm (end - start') .* coord control1 + (start' + end) /. two + control2' = norm (end - start') .* coord control2 + (start' + end) /. two -- | The cubic bezier equation -- --- >>> cubicBezier (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) 0.8535533905932737 +-- >>> cubicBezier (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) 0.8535533905932737 -- Point 0.6767766952966369 1.2071067811865475 -cubicBezier :: (ExpField a, FromInteger a) => CubicPosition a -> a -> Point a -cubicBezier (CubicPosition start end control1 control2) theta = - (1 - theta) ^ 3 .* start +cubicBezier :: (FromInteger a, TrigField a) => CubicPosition a -> a -> Point a +cubicBezier (CubicPosition start' end control1 control2) theta = + (1 - theta) ^ 3 .* start' + 3 * (1 - theta) ^ 2 * theta .* control1 + 3 * (1 - theta) * theta ^ 2 .* control2 + theta ^ 3 .* end -- | Turning point positions for a CubicPosition (0,1 or 2) -- --- >>> cubicDerivs (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) +-- >>> cubicDerivs (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) -- [0.8535533905932737,0.14644660940672624,0.5] cubicDerivs :: CubicPosition Double -> [Double] cubicDerivs @@ -676,10 +460,10 @@ -- | Bounding box for a CubicPosition -- --- >>> cubicBox (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) +-- >>> cubicBox (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) -- Rect 0.0 1.0 -0.20710678118654752 1.2071067811865475 cubicBox :: CubicPosition Double -> Rect Double -cubicBox p = space1 pts +cubicBox p = unsafeSpace1 pts where ts = cubicDerivs p pts = @@ -689,25 +473,37 @@ ([0, 1] <> ts) -- | Bounding box for a list of path XYs. -pathBoxes :: [(PathInfo Double, Point Double)] -> Maybe (Rect Double) +pathBoxes :: [PathData Double] -> Maybe (Rect Double) pathBoxes [] = Nothing pathBoxes (x : xs) = - L.fold (L.Fold step begin (Just . snd)) xs + Just $ + L.fold (L.Fold step begin snd) xs where begin :: (Point Double, Rect Double) - begin = (snd x, singleton (snd x)) - step :: - (Point Double, Rect Double) -> - (PathInfo Double, Point Double) -> - (Point Double, Rect Double) - step (start, r) a = (snd a, pathBox start a <> r) + begin = (pointPath x, singleton (pointPath x)) + step (start', r) a = (pointPath a, pathBox start' a <> r) -- | Bounding box for a path info, start and end Points. -pathBox :: Point Double -> (PathInfo Double, Point Double) -> Rect Double -pathBox start (info, end) = +pathBox :: Point Double -> PathData Double -> Rect Double +pathBox start' info = case info of - StartI -> singleton end - LineI -> space1 [start, end] - CubicI c1 c2 -> cubicBox (CubicPosition start end c1 c2) - QuadI c -> quadBox (QuadPosition start end c) - ArcI i -> arcBox (ArcPosition start end i) + StartP p -> singleton p + LineP p -> unsafeSpace1 [start', p] + CubicP c1 c2 p -> cubicBox (CubicPosition start' p c1 c2) + QuadP c p -> quadBox (QuadPosition start' p c) + ArcP i p -> arcBox (ArcPosition start' p i) + +-- | project an ArcPosition given new and old Rects +-- +-- The radii of the ellipse can be represented as: +-- +-- Point rx 0 & Point 0 ry +-- +-- These two points are firstly rotated by p and then undergo scaling... +projectArcPosition :: Rect Double -> Rect Double -> ArcPosition Double -> ArcInfo Double +projectArcPosition new old (ArcPosition _ _ (ArcInfo (Point rx ry) phi' l cl)) = ArcInfo (Point rx'' ry'') phi' l cl + where + rx' = rotateP phi' (Point rx zero) + rx'' = norm $ rx' * width new / width old + ry' = rotateP phi' (Point zero ry) + ry'' = norm $ ry' * width new / width old diff --git a/src/Data/Path/Parser.hs b/src/Data/Path/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Path/Parser.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# OPTIONS_GHC -Wall #-} + +-- | SVG path manipulation +module Data.Path.Parser + ( -- * Parsing + -- $parsing + parsePath, + svgToPathData, + pathDataToSvg, + PathCommand (..), + Origin (..), + ) +where + +import Chart.Data +import Control.Applicative +import Control.Monad.State.Lazy +import qualified Data.Attoparsec.Text as A +import Data.Either +import Data.FormatN +import Data.Functor +import Data.Path +import Data.Scientific (toRealFloat) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import GHC.Generics +import GHC.OverloadedLabels +import NumHask.Prelude +import Optics.Core hiding ((<|)) + +-- import qualified Data.List as List + +-- $parsing +-- Every element of an svg path can be thought of as exactly two points in space, with instructions of how to draw a curve between them. From this point of view, one which this library adopts, a path chart is thus very similar to a line chart. There's just a lot more information about the style of this line to deal with. +-- +-- References: +-- +-- [SVG d](https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d) +-- +-- [SVG path](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths) + +-- | Parse a raw path string. +-- +-- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z" +-- >>> parsePath outerseg1 +-- Right [MoveTo OriginAbsolute [Point -1.0 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 -1.2320508075688774),(1.0,1.0,0.0,False,False,Point -0.5 -0.3660254037844387),(1.0,1.0,0.0,False,False,Point -1.0 0.5)],EndPath] +-- +-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d +parsePath :: Text -> Either String [PathCommand] +parsePath = A.parseOnly pathParser + +commaWsp :: A.Parser () +commaWsp = A.skipSpace *> A.option () (A.string "," $> ()) <* A.skipSpace + +point :: A.Parser (Point Double) +point = Point <$> num <* commaWsp <*> num + +points :: A.Parser [Point Double] +points = fromList <$> point `A.sepBy1` commaWsp + +pointPair :: A.Parser (Point Double, Point Double) +pointPair = (,) <$> point <* commaWsp <*> point + +pointPairs :: A.Parser [(Point Double, Point Double)] +pointPairs = fromList <$> pointPair `A.sepBy1` commaWsp + +pathParser :: A.Parser [PathCommand] +pathParser = fromList <$> (A.skipSpace *> A.many1 command) + +num :: A.Parser Double +num = realToFrac <$> (A.skipSpace *> plusMinus <* A.skipSpace) + where + doubleNumber :: A.Parser Double + doubleNumber = toRealFloat <$> A.scientific <|> shorthand + + plusMinus = + negate <$ A.string "-" <*> doubleNumber + <|> A.string "+" *> doubleNumber + <|> doubleNumber + + shorthand = process' <$> (A.string "." *> A.many1 A.digit) + process' = fromRight 0 . A.parseOnly doubleNumber . pack . (++) "0." + +nums :: A.Parser [Double] +nums = num `A.sepBy1` commaWsp + +flag :: A.Parser Bool +flag = fmap (/= '0') A.digit + +command :: A.Parser PathCommand +command = + MoveTo OriginAbsolute <$ A.string "M" <*> points + <|> MoveTo OriginRelative <$ A.string "m" <*> points + <|> LineTo OriginAbsolute <$ A.string "L" <*> points + <|> LineTo OriginRelative <$ A.string "l" <*> points + <|> HorizontalTo OriginAbsolute <$ A.string "H" <*> nums + <|> HorizontalTo OriginRelative <$ A.string "h" <*> nums + <|> VerticalTo OriginAbsolute <$ A.string "V" <*> nums + <|> VerticalTo OriginRelative <$ A.string "v" <*> nums + <|> CurveTo OriginAbsolute <$ A.string "C" <*> fmap fromList (manyComma curveToArgs) + <|> CurveTo OriginRelative <$ A.string "c" <*> fmap fromList (manyComma curveToArgs) + <|> SmoothCurveTo OriginAbsolute <$ A.string "S" <*> pointPairs + <|> SmoothCurveTo OriginRelative <$ A.string "s" <*> pointPairs + <|> QuadraticBezier OriginAbsolute <$ A.string "Q" <*> pointPairs + <|> QuadraticBezier OriginRelative <$ A.string "q" <*> pointPairs + <|> SmoothQuadraticBezierCurveTo OriginAbsolute <$ A.string "T" <*> points + <|> SmoothQuadraticBezierCurveTo OriginRelative <$ A.string "t" <*> points + <|> EllipticalArc OriginAbsolute <$ A.string "A" <*> manyComma ellipticalArgs + <|> EllipticalArc OriginRelative <$ A.string "a" <*> manyComma ellipticalArgs + <|> EndPath <$ A.string "Z" <* commaWsp + <|> EndPath <$ A.string "z" <* commaWsp + where + curveToArgs = + (,,) <$> (point <* commaWsp) + <*> (point <* commaWsp) + <*> point + manyComma a = fromList <$> a `A.sepBy1` commaWsp + + numComma = num <* commaWsp + flagComma = flag <* commaWsp + ellipticalArgs = + (,,,,,) <$> numComma + <*> numComma + <*> numComma + <*> flagComma + <*> flagComma + <*> point + +-- | Path command definition (ripped from reanimate-svg). +data PathCommand + = -- | M or m command + MoveTo !Origin ![Point Double] + | -- | Line to, L or l Svg path command. + LineTo !Origin ![Point Double] + | -- | Equivalent to the H or h svg path command. + HorizontalTo !Origin ![Double] + | -- | Equivalent to the V or v svg path command. + VerticalTo !Origin ![Double] + | -- | Cubic bezier, C or c command + CurveTo !Origin ![(Point Double, Point Double, Point Double)] + | -- | Smooth cubic bezier, equivalent to S or s command + SmoothCurveTo !Origin ![(Point Double, Point Double)] + | -- | Quadratic bezier, Q or q command + QuadraticBezier !Origin ![(Point Double, Point Double)] + | -- | Quadratic bezier, T or t command + SmoothQuadraticBezierCurveTo !Origin ![Point Double] + | -- | Elliptical arc, A or a command. + EllipticalArc !Origin ![(Double, Double, Double, Bool, Bool, Point Double)] + | -- | Close the path, Z or z svg path command. + EndPath + deriving (Eq, Show, Generic) + +-- | Tell if a path command is absolute (in the current +-- user coordiante) or relative to the previous point. +data Origin + = -- | Next point in absolute coordinate + OriginAbsolute + | -- | Next point relative to the previous + OriginRelative + deriving (Eq, Show, Generic) + +-- | To fit in with the requirements of the library design, specifically the separation of what a chart is into XY data Points from representation of these points, path instructions need to be decontructed into: +-- +-- - define a single chart element as a line. +-- +-- - split a single path element into the start and end points of the line, which become the 'Chart.Types.xys' of a 'Chart.Types.Chart', and the rest of the information, which is called 'PathInfo' and incorporated into the 'Chart.Types.Chart' 'Chart.Types.annotation'. +-- +-- An arc path is variant to affine transformations of the 'Chart.Types.xys' points: angles are not presevred in the new reference frame. +data PathInfo a + = StartI + | LineI + | CubicI (Point a) (Point a) + | QuadI (Point a) + | ArcI (ArcInfo a) + deriving (Show, Eq, Generic) + +pointToSvgCoords :: Point Double -> Point Double +pointToSvgCoords (Point x y) = Point x (-y) + +svgCoords :: PathData Double -> PathData Double +svgCoords (CubicP a b p) = CubicP (pointToSvgCoords a) (pointToSvgCoords b) (pointToSvgCoords p) +svgCoords (QuadP a p) = QuadP (pointToSvgCoords a) (pointToSvgCoords p) +svgCoords (StartP p) = StartP (pointToSvgCoords p) +svgCoords (LineP p) = LineP (pointToSvgCoords p) +svgCoords (ArcP i p) = ArcP i (pointToSvgCoords p) + +-- | Convert from a path info, start point, end point triple to a path text clause. +-- +-- Note that morally, +-- +-- > toPathsAbsolute . toInfos . parsePath == id +-- +-- but the round trip destroys much information, including: +-- +-- - path text spacing +-- +-- - "Z", which is replaced by a LineI instruction from the end point back to the original start of the path. +-- +-- - Sequences of the same instruction type are uncompressed +-- +-- - As the name suggests, relative paths are translated to absolute ones. +-- +-- - implicit L's in multiple M instructions are separated. +-- +-- In converting between chart-svg and SVG there are two changes in reference: +-- +-- - arc rotation is expressed as positive degrees for a clockwise rotation in SVG, and counter-clockwise in radians for chart-svg +-- +-- - A positive y-direction is down for SVG and up for chart-svg +toPathAbsolute :: + PathData Double -> + -- | path text + Text +toPathAbsolute (StartP p) = "M " <> pp p +toPathAbsolute (LineP p) = "L " <> pp p +toPathAbsolute (CubicP c1 c2 p) = + "C " + <> pp c1 + <> " " + <> pp c2 + <> " " + <> pp p +toPathAbsolute (QuadP control p) = + "Q " + <> pp control + <> " " + <> pp p +toPathAbsolute (ArcP (ArcInfo (Point x y) phi' l sw) x2) = + "A " + <> (pack . show) x + <> " " + <> (pack . show) y + <> " " + <> (pack . show) (-phi' * 180 / pi) + <> " " + <> bool "0" "1" l + <> " " + <> bool "0" "1" sw + <> " " + <> pp x2 + +-- | Render a point (including conversion to SVG Coordinates). +pp :: Point Double -> Text +pp (Point x y) = + formatOrShow (FixedStyle 4) Nothing x <> "," + <> formatOrShow (FixedStyle 4) Nothing (bool (-y) y (y == zero)) + +data PathCursor = PathCursor + { -- | previous position + curPrevious :: Point Double, + -- | start point (to close out the path) + curStart :: Point Double, + -- | last control point + curControl :: Maybe (Point Double) + } + deriving (Eq, Show, Generic) + +stateCur0 :: PathCursor +stateCur0 = PathCursor zero zero Nothing + +-- | Convert an SVG d path text snippet to a [PathData Double] +svgToPathData :: Text -> [PathData Double] +svgToPathData = toPathDatas . either error id . parsePath + +-- | Convert [PathData] to an SVG d path text. +pathDataToSvg :: [PathData Double] -> Text +pathDataToSvg xs = Text.intercalate " " $ fmap toPathAbsolute xs + +-- | Convert from a path command list to a PathA specification +toPathDatas :: [PathCommand] -> [PathData Double] +toPathDatas xs = fmap svgCoords $ mconcat $ flip evalState stateCur0 $ sequence $ toInfo <$> xs + +-- | Convert relative points to absolute points +relToAbs :: (Additive a) => a -> [a] -> [a] +relToAbs p xs = accsum (p : xs) + +moveTo :: [Point Double] -> State PathCursor [PathData Double] +moveTo xs = do + put (PathCursor (last xs) (head xs) Nothing) + pure (StartP (head xs) : (LineP <$> tail xs)) + +lineTo :: [Point Double] -> State PathCursor [PathData Double] +lineTo xs = do + modify ((#curPrevious .~ last xs) . (#curControl .~ Nothing)) + pure $ LineP <$> xs + +horTo :: [Double] -> State PathCursor [PathData Double] +horTo xs = do + (PathCursor (Point _ y) _ _) <- get + lineTo (fmap (`Point` y) xs) + +verTo :: [Double] -> State PathCursor [PathData Double] +verTo ys = do + (PathCursor (Point x _) _ _) <- get + lineTo (fmap (Point x) ys) + +curveTo :: [(Point Double, Point Double, Point Double)] -> State PathCursor [PathData Double] +curveTo xs = do + modify + ( (#curPrevious .~ (\(_, _, p) -> p) (last xs)) + . (#curControl ?~ (\(_, c2, _) -> c2) (last xs)) + ) + pure $ (\(c1, c2, x2) -> CubicP c1 c2 x2) <$> xs + +-- | Convert relative points to absolute points +relToAbs3 :: Additive a => a -> [(a, a, a)] -> [(a, a, a)] +relToAbs3 p xs = xs' + where + x1 = (\(x, _, _) -> x) <$> xs + x2 = (\(_, x, _) -> x) <$> xs + x3 = (\(_, _, x) -> x) <$> xs + x1' = fmap (p +) (accsum x1) + x2' = fmap (p +) (accsum x2) + x3' = fmap (p +) (accsum x3) + xs' = zip3 x1' x2' x3' + +reflControlPoint :: State PathCursor (Point Double) +reflControlPoint = do + (PathCursor p _ c) <- get + case c of + Nothing -> pure p + Just c' -> pure (p - (c' - p)) + +smoothCurveToStep :: (Point Double, Point Double) -> State PathCursor (PathData Double) +smoothCurveToStep (c2, x2) = do + c1 <- reflControlPoint + modify ((#curControl ?~ c2) . (#curPrevious .~ x2)) + pure (CubicP c1 c2 x2) + +smoothCurveTo :: [(Point Double, Point Double)] -> State PathCursor [PathData Double] +smoothCurveTo xs = + sequence (smoothCurveToStep <$> xs) + +-- | Convert relative points to absolute points +relToAbs2 :: Additive a => a -> [(a, a)] -> [(a, a)] +relToAbs2 p xs = xs' + where + x1 = fst <$> xs + x2 = snd <$> xs + x1' = fmap (p +) (accsum x1) + x2' = fmap (p +) (accsum x2) + xs' = zip x1' x2' + +quad :: [(Point Double, Point Double)] -> State PathCursor [PathData Double] +quad xs = do + modify + ( (#curPrevious .~ snd (last xs)) + . (#curControl ?~ fst (last xs)) + ) + pure $ uncurry QuadP <$> xs + +smoothQuadStep :: Point Double -> State PathCursor (PathData Double) +smoothQuadStep x2 = do + c1 <- reflControlPoint + modify ((#curControl ?~ c1) . (#curPrevious .~ x2)) + pure (QuadP c1 x2) + +smoothQuad :: [Point Double] -> State PathCursor [PathData Double] +smoothQuad xs = + sequence (smoothQuadStep <$> xs) + +arcTo :: [(Double, Double, Double, Bool, Bool, Point Double)] -> State PathCursor [PathData Double] +arcTo xs = do + modify ((#curPrevious .~ (\(_, _, _, _, _, p) -> p) (last xs)) . (#curControl .~ Nothing)) + pure $ fromPathEllipticalArc <$> xs + +fromPathEllipticalArc :: (a, a, a, Bool, Bool, Point a) -> PathData a +fromPathEllipticalArc (x, y, r, l, s, p) = ArcP (ArcInfo (Point x y) r l s) p + +-- | Convert relative points to absolute points +relToAbsArc :: Additive a => Point a -> [(a, a, a, Bool, Bool, Point a)] -> [(a, a, a, Bool, Bool, Point a)] +relToAbsArc p xs = xs' + where + ps = (\(_, _, _, _, _, pt) -> pt) <$> xs + ps' = fmap (p +) (accsum ps) + xs' = zipWith (\(x0, x1, x2, x3, x4, _) pt -> (x0, x1, x2, x3, x4, pt)) xs ps' + +-- | Convert a path command fragment to PathData +-- +-- flips the y-dimension of points. +toInfo :: PathCommand -> State PathCursor [PathData Double] +toInfo (MoveTo OriginAbsolute xs) = moveTo xs +toInfo (MoveTo OriginRelative xs) = do + (PathCursor p _ _) <- get + moveTo (relToAbs p xs) +toInfo EndPath = do + (PathCursor _ s _) <- get + pure [LineP s] +toInfo (LineTo OriginAbsolute xs) = lineTo xs +toInfo (LineTo OriginRelative xs) = do + (PathCursor p _ _) <- get + lineTo (relToAbs p xs) +toInfo (HorizontalTo OriginAbsolute xs) = horTo xs +toInfo (HorizontalTo OriginRelative xs) = do + (PathCursor (Point x _) _ _) <- get + horTo (relToAbs x xs) +toInfo (VerticalTo OriginAbsolute xs) = verTo xs +toInfo (VerticalTo OriginRelative ys) = do + (PathCursor (Point _ y) _ _) <- get + verTo (relToAbs y ys) +toInfo (CurveTo OriginAbsolute xs) = curveTo xs +toInfo (CurveTo OriginRelative xs) = do + (PathCursor p _ _) <- get + curveTo (relToAbs3 p xs) +toInfo (SmoothCurveTo OriginAbsolute xs) = smoothCurveTo xs +toInfo (SmoothCurveTo OriginRelative xs) = do + (PathCursor p _ _) <- get + smoothCurveTo (relToAbs2 p xs) +toInfo (QuadraticBezier OriginAbsolute xs) = quad xs +toInfo (QuadraticBezier OriginRelative xs) = do + (PathCursor p _ _) <- get + quad (relToAbs2 p xs) +toInfo (SmoothQuadraticBezierCurveTo OriginAbsolute xs) = smoothQuad xs +toInfo (SmoothQuadraticBezierCurveTo OriginRelative xs) = do + (PathCursor p _ _) <- get + smoothQuad (relToAbs p xs) +toInfo (EllipticalArc OriginAbsolute xs) = arcTo xs +toInfo (EllipticalArc OriginRelative xs) = do + (PathCursor p _ _) <- get + arcTo (relToAbsArc p xs)