diff --git a/app/reanimate-example.hs b/app/reanimate-example.hs --- a/app/reanimate-example.hs +++ b/app/reanimate-example.hs @@ -10,48 +10,67 @@ and wait for the browser to open ... -} - {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MonoLocalBinds #-} module Main where import Chart import Chart.Examples import Control.Lens hiding (transform) -import Graphics.SvgTree.Types hiding (Point, Text) import NumHask.Prelude hiding (fold) -import Reanimate hiding (scale) --- import qualified Reanimate as Re import Chart.Reanimate +import Reanimate as Re main :: IO () main = - reanimate . - addStatic (mkBackgroundPixel (toPixelRGBA8 $ Colour 0.9 0.9 0.9 1)) . - mkAnimation 5 $ - (\x -> - chartSvgTree - (expScaleChartData x hudOptionsExample)) - --- (pan surf one (Rect 0.2 0.21 0.1 0.11)) - -surf :: Rect Double -> ChartSvg -surf r = surfacegExample "rosenbrock" (Point 100 100) (Point 20 20) r (bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10) & #hudOptions . #hudAxes %~ fmap (#axisTick . #tstyle .~ TickRound (FormatComma (Just 2)) 8 NoTickExtend) + -- reanimChartSvg defaultReanimateConfig (sOpac lineExample) + reanimate $ + foldl' seqA (pause 0) $ (applyE (overBeginning 1 fadeInE) . applyE (overEnding 1 fadeOutE)) . mapA pathify . (\cs -> animChartSvg defaultReanimateConfig (const cs)) . (#hudOptions %~ colourHudOptions light) <$> examples -pan :: (Rect Double -> ChartSvg) -> Rect Double -> Rect Double -> Double -> Tree -pan f start end x = chartSvgTree $ f (start + fmap (*x) (end - start)) +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 + ] -expScaleChartData :: Double -> ChartSvg -> ChartSvg -expScaleChartData x cs = - cs & - #chartList %~ fmap (expScaleData (10 * (x - 0.5))) & - #hudOptions . #hudAxes %~ - fmap (set (#axisTick . #tstyle) - (TickRound (FormatComma (Just 2)) 8 NoTickExtend)) +sOpac :: ChartSvg -> Double -> ChartSvg +sOpac cs o = + scaleOpacChartSvg (Range 0 1) o . + (#hudOptions %~ colourHudOptions light) $ + cs -expScaleData :: Double -> Chart Double -> Chart Double -expScaleData s c = c & #xys %~ fmap (fmap ((10.0 ** s) *)) +scaleOpacChartSvg :: Range Double -> Double -> ChartSvg -> ChartSvg +scaleOpacChartSvg r x cs = + cs & + #hudOptions .~ scaleOpacHudOptions (cs & view #hudOptions) (project (Range zero one) r x) & + #chartList .~ + ((#annotation %~ scaleOpacAnn (project (Range zero one) r x)) <$> + view #chartList cs) diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: chart-svg -version: 0.2.0 +version: 0.2.1 synopsis: Charting library targetting SVGs. description: This package provides a charting library targetting SVG as the rendered output. @@ -15,7 +15,7 @@ >>> let lineChart = zipWith Chart anns ls >>> writeChartSvgHud "other/lineshud.svg" lineChart . - ![main example](other/lineshud.svg) + ![main example](docs/other/lineshud.svg) . See "Chart" for a broad overview of concepts, and "Chart.Examples" for a variety of practical examples. @@ -73,6 +73,7 @@ unordered-containers >= 0.2 && < 0.3, default-language: Haskell2010 default-extensions: + StrictData ghc-options: -Wall -Wcompat diff --git a/other/arc.svg b/other/arc.svg --- a/other/arc.svg +++ b/other/arc.svg @@ -1,147 +1,145 @@ --0.100.10.20.30.40.50.60.70.80.9100.10.20.30.40.50.60.70.80.91 +-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,1241 +1,1201 @@ -01234567890123456789SweepTrueFalseFalseTrueLarge +SweepTrueFalseFalseTrueLarge diff --git a/other/arrow.svg b/other/arrow.svg new file mode 100644 --- /dev/null +++ b/other/arrow.svg @@ -0,0 +1,23 @@ +-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 diff --git a/other/arrowg.svg b/other/arrowg.svg deleted file mode 100644 --- a/other/arrowg.svg +++ /dev/null @@ -1,23 +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.5 diff --git a/other/bar.svg b/other/bar.svg --- a/other/bar.svg +++ b/other/bar.svg @@ -1,29 +1,29 @@ --4-2024681012row 1row 2row 3row 4row 5row 6row 7row 8row 9row 10123580-2112112345678910column 2column 1 +-4-2024681012row 1row 2row 3row 4row 5row 6row 7row 8row 9row 10123580-2112112345678910column 2column 1 diff --git a/other/boundTextBug.svg b/other/boundTextBug.svg deleted file mode 100644 --- a/other/boundTextBug.svg +++ /dev/null @@ -1,1 +0,0 @@ -a pretty long piece of textanother pretty long piece of text diff --git a/other/compound.svg b/other/compound.svg --- a/other/compound.svg +++ b/other/compound.svg @@ -1,5 +1,5 @@ -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 +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,145 +1,101 @@ -M 0,0 C 1.0,0 0,-1.0 1.0,-1.000.10.20.30.40.50.60.70.80.9100.10.20.30.40.50.60.70.80.91 + diff --git a/other/ellipse.svg b/other/ellipse.svg --- a/other/ellipse.svg +++ b/other/ellipse.svg @@ -1,174 +1,174 @@ --2-1.5-1-0.500.511.5-1.5-1-0.500.511.5-2-1.5-1-0.500.511.5-1.5-1-0.500.511.5 +0.8747752644279139,-0.6661542092725852 +0.8395466401811942,-0.723351558815974 +0.8004468164255343,-0.7762828919243687 +0.7576301023022891,-0.8247393128080156 +0.7112654758210062,-0.86852958611132 +0.6615359169804229,-0.907480891631427 +0.6086376856300113,-0.9414395063606076"/> diff --git a/other/glines.svg b/other/glines.svg --- a/other/glines.svg +++ b/other/glines.svg @@ -1,5 +1,5 @@ - +0.3214285714285712,-0.5"/> diff --git a/other/glyphs.svg b/other/glyphs.svg --- a/other/glyphs.svg +++ b/other/glyphs.svg @@ -1,3 +1,3 @@ - + diff --git a/other/hudoptions.svg b/other/hudoptions.svg --- a/other/hudoptions.svg +++ b/other/hudoptions.svg @@ -1,45 +1,45 @@ --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.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 diff --git a/other/label.svg b/other/label.svg --- a/other/label.svg +++ b/other/label.svg @@ -1,1 +1,1 @@ -text at (1,1) rotated by -(pi/4) radians +text at (1,1) rotated by -(pi/4) radians diff --git a/other/legend.svg b/other/legend.svg --- a/other/legend.svg +++ b/other/legend.svg @@ -1,46 +1,46 @@ --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 +-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 --- a/other/lglyph.svg +++ b/other/lglyph.svg @@ -1,1 +1,1 @@ -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 +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,44 @@ -An example from chart-svgLine Chart00.511.522.533.544.5500.511.522.53verticallinehockey +An example from chart-svgLine Chart0.00.51.01.52.02.53.03.54.04.55.00.00.51.01.52.02.53.0verticallinehockey diff --git a/other/lines.svg b/other/lines.svg deleted file mode 100644 --- a/other/lines.svg +++ /dev/null @@ -1,5 +0,0 @@ - diff --git a/other/lineshud.svg b/other/lineshud.svg deleted file mode 100644 --- a/other/lineshud.svg +++ /dev/null @@ -1,43 +0,0 @@ -00.511.522.533.544.5500.511.522.533.5 diff --git a/other/path.svg b/other/path.svg --- a/other/path.svg +++ b/other/path.svg @@ -1,35 +1,35 @@ -00.20.40.60.811.21.41.6-0.4-0.200.20.40.60.81 +00.20.40.60.811.21.41.6-0.4-0.200.20.40.60.81 diff --git a/other/problematic1.svg b/other/problematic1.svg deleted file mode 100644 --- a/other/problematic1.svg +++ /dev/null @@ -1,55 +0,0 @@ -00.10.20.30.40.50.60.70.80.9100.10.20.30.40.50.60.70.80.91 diff --git a/other/problematic2.svg b/other/problematic2.svg deleted file mode 100644 --- a/other/problematic2.svg +++ /dev/null @@ -1,339 +0,0 @@ --0.500.511.522.533.5-4-3-2-101231.000,2.000 diff --git a/other/quad.svg b/other/quad.svg --- a/other/quad.svg +++ b/other/quad.svg @@ -1,145 +1,145 @@ --1-0.8-0.6-0.4-0.200.20.40.60.8100.20.40.60.811.21.41.61.82 +-1-0.8-0.6-0.4-0.200.20.40.60.8100.20.40.60.811.21.41.61.82 diff --git a/other/rect.svg b/other/rect.svg --- a/other/rect.svg +++ b/other/rect.svg @@ -1,23 +1,23 @@ --5-4-3-2-1012345 +-5-4-3-2-1012345 diff --git a/other/surface.svg b/other/surface.svg --- a/other/surface.svg +++ b/other/surface.svg @@ -1,4 +1,4 @@ --6-4-2rosenbrock +-6-4-2rosenbrock diff --git a/other/surfaceg.svg b/other/surfaceg.svg deleted file mode 100644 # file too large to diff: other/surfaceg.svg diff --git a/other/svgoptions.svg b/other/svgoptions.svg --- a/other/svgoptions.svg +++ b/other/svgoptions.svg @@ -1,5 +1,5 @@ - diff --git a/other/text.svg b/other/text.svg --- a/other/text.svg +++ b/other/text.svg @@ -1,1 +1,1 @@ -abcdefghijklmnopqrstuvwxy +abcdefghijklmnopqrstuvwxy diff --git a/other/textlocal.svg b/other/textlocal.svg new file mode 100644 --- /dev/null +++ b/other/textlocal.svg @@ -0,0 +1,1 @@ +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,1 @@ - + diff --git a/other/venn.svg b/other/venn.svg --- a/other/venn.svg +++ b/other/venn.svg @@ -1,29 +1,29 @@ --1.5-1-0.500.511.5-1.5-1-0.500.511.5 +-1.5-1-0.500.511.5-1.5-1-0.500.511.5 diff --git a/other/wave.svg b/other/wave.svg --- a/other/wave.svg +++ b/other/wave.svg @@ -1,1 +1,1 @@ - + diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -22,6 +22,8 @@ Annotation (..), annotationText, scaleAnn, + scaleOpacAnn, + colourAnn, padRect, -- * Styles @@ -59,6 +61,8 @@ simulHud, HudOptions (..), defaultHudOptions, + scaleOpacHudOptions, + colourHudOptions, defaultCanvas, runHudWith, runHud, @@ -182,11 +186,7 @@ -- -- Here's some data; three lists of points that will form a line: -- --- >>> let xs = [[(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)]] :: [[(Double, Double)]] --- >>> let ls = fmap (uncurry P) <$> xs --- --- >>> :t ls --- ls :: [[XY Double]] +-- >>> 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]] -- -- and an Annotation to describe representation of this data; three line styles with different colors and widths: -- @@ -194,13 +194,13 @@ -- -- and this is enough to create a Chart. -- --- >>> let lineChart = zipWith Chart anns ls --- >>> :t lineChart --- lineChart :: [Chart Double] +-- >>> let lineExample = mempty & (#chartList .~ zipWith Chart anns (fmap (fmap PointXY) xs)) & #hudOptions .~ defaultHudOptions & #svgOptions .~ defaultSvgOptions :: ChartSvg +-- >>> :t lineExample +-- lineExample :: ChartSvg -- -- Most charts will, in reality, be a list of charts such as this, and much of the library API is designed for this. -- --- > writeChartSvgDefault "other/lines.svg" lineChart +-- > writeChartSvg "other/lines.svg" lineExample -- -- ![lines example](other/lines.svg) -- diff --git a/src/Chart/Bar.hs b/src/Chart/Bar.hs --- a/src/Chart/Bar.hs +++ b/src/Chart/Bar.hs @@ -167,7 +167,7 @@ -- | A bar chart without hud trimmings. -- -- >>> bars defaultBarOptions (BarData [[1,2],[2,3]] Nothing Nothing) --- [Chart {annotation = RectA (RectStyle {borderSize = 2.0e-3, borderColor = RGBA 0.65 0.81 0.89 1.00, color = RGBA 0.65 0.81 0.89 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 = RGBA 0.12 0.47 0.71 1.00, color = RGBA 0.12 0.47 0.71 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]}] +-- [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)]] diff --git a/src/Chart/Examples.hs b/src/Chart/Examples.hs --- a/src/Chart/Examples.hs +++ b/src/Chart/Examples.hs @@ -21,12 +21,10 @@ lglyphExample, glinesExample, compoundExample, - boundTextBugExample, + textLocalExample, labelExample, legendExample, surfaceExample, - arrowgExample, - surfacegExample, rosenbrock, arcExample, arcFlagsExample, @@ -35,15 +33,14 @@ cubicExample, pathExample, vennExample, - problematic1, - problematic2, + arrowExample, writeAllExamples, ) where import Chart import Control.Lens -import Data.List ((!!)) +import qualified Data.List as List import qualified Data.Text as Text import NumHask.Prelude hiding (lines) @@ -59,7 +56,7 @@ hudOptionsExample :: ChartSvg hudOptionsExample = mempty - & #hudOptions .~ defaultHudOptions + & #hudOptions .~ colourHudOptions dark defaultHudOptions & #chartList .~ [Chart BlankA [one]] -- | 'SvgOptions' example. @@ -88,21 +85,44 @@ ropts :: [RectStyle] ropts = - [ blob (fromRGB (palette !! 0) 0.4), - blob (fromRGB (palette !! 5) 0.4) + [ blob (palette1 List.!! 1), + blob (palette1 List.!! 2) ] -- | 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 (legopts, zip (LineA <$> lopts) ["hockey", "line", "vertical"])) + (Just (defaultLegendOptions, zip (LineA <$> lopts) ["hockey", "line", "vertical"])) & #chartList .~ zipWith (\s d -> Chart (LineA s) (fmap PointXY d)) lopts ls @@ -116,20 +136,11 @@ lopts :: [LineStyle] lopts = - [ defaultLineStyle & #color .~ (palette1 !! 0) & #width .~ 0.015, - defaultLineStyle & #color .~ (palette1 !! 1) & #width .~ 0.03, - defaultLineStyle & #color .~ (palette1 !! 5) & #width .~ 0.01 + [ defaultLineStyle & #color .~ (palette1 List.!! 0) & #width .~ 0.015, + defaultLineStyle & #color .~ (palette1 List.!! 1) & #width .~ 0.03, + defaultLineStyle & #color .~ (palette1 List.!! 2) & #width .~ 0.01 ] -legopts :: LegendOptions -legopts = - defaultLegendOptions - & #lsize .~ 0.2 - & #ltext . #size .~ 0.25 - & #innerPad .~ 0.05 - & #lscale .~ 0.25 - & #lplace .~ PlaceAbsolute (Point 0.5 -0.3) - exampleLineHudOptions :: Text -> Maybe Text -> Maybe (LegendOptions, [(Annotation, Text)]) -> HudOptions exampleLineHudOptions t1 t2 legends' = defaultHudOptions @@ -149,6 +160,7 @@ t2 ) & #hudLegend .~ legends' + & #hudAxes %~ fmap (#axisTick . #tstyle .~ TickRound (FormatFixed (Just 1)) 8 TickExtend) -- | text example -- @@ -157,8 +169,8 @@ textExample = mempty & #chartList .~ zipWith - Chart - (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) + Chart + (TextA (defaultTextStyle & (#color .~ dark) & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) ((: []) . PointXY . snd <$> ts) where ts :: [(Text, Point Double)] @@ -215,30 +227,30 @@ where (hc, cs) = barChart defaultBarOptions barDataExample --- | An example of how bounding box calculations for text is broken. +-- | A reminder that Text scale is at representation level, and so doesn't scale compared with other chart elements, such as a rectangle. -- --- ![bound text bug example](other/boundtextbug.svg) -boundTextBugExample :: ChartSvg -boundTextBugExample = +-- ![text local example](other/textlocal.svg) +textLocalExample :: ChartSvg +textLocalExample = mempty & #chartList .~ [ t1, t2, - Chart BlankA [R 0 0.1 -0.5 0.5], - Chart (RectA defaultRectStyle) [RectXY (padBox $ styleBox t1)], - Chart (RectA defaultRectStyle) [RectXY (padBox $ styleBox 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.45 & #size .~ 0.08) + (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.5 & #size .~ 0.08) ["a pretty long piece of text"] ) [zero] t2 = Chart ( TextA - (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.45 & #size .~ 0.08) + (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.5 & #size .~ 0.08) ["another pretty long piece of text"] ) [P 1 1] @@ -283,12 +295,11 @@ Chart ( TextA ( defaultTextStyle - & #translate ?~ Point 0 0.04 & #color %~ setOpac 0.2 ) [t] ) - (PointXY <$> [p]) + (PointXY <$> [p + Point 0 0.2]) ) <$> lgdata gly = @@ -298,7 +309,7 @@ ( defaultGlyphStyle & #size .~ 0.01 & #borderSize .~ 0 - & #color .~ black + & #color .~ palette1 List.!! 2 ) ) (PointXY <$> [d]) @@ -404,26 +415,26 @@ (QuadI (Point -1 2), Point 0 1), (ArcI (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) + path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 List.!! 2) & #borderColor .~ Colour 0.2 0.8 0.4 0.3) (fst <$> ps)) (PointXY . snd <$> ps) c0 = Chart (GlyphA defaultGlyphStyle) (PointXY . snd <$> ps) -- | ellipse example -- --- (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi/3) True True)) --- +-- (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) 0 True True)) -- -- ![ellipse example](other/ellipse.svg) -- -ellipseExample :: ArcPosition Double -> ChartSvg -ellipseExample p@(ArcPosition p1 p2 _) = +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]) + ellFull = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1 List.!! 1)) (PointXY . ellipse c r phi' . (\x -> 2 * pi * x / 100.0) <$> [0..100]) + ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1 List.!! 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]) @@ -431,23 +442,22 @@ -- | arc example -- --- > arcExample (ArcPosition (Point 1.0 0.0) (Point 0.0 1.0) (ArcInfo (Point 1.0 0.5) 0 False True)) --- -- ![arc example](other/arc.svg) -- --- See also 'problematic2' for scaling issue when phi is non-zero. +-- There is a bug for rotated ellipses. See 'problematic2' for scaling issue when phi is non-zero. -- -arcExample :: ArcPosition Double -> ChartSvg -arcExample p1 = +arcExample :: ChartSvg +arcExample = mempty & #chartList .~ [arc, ell, c0, bbox] & #hudOptions .~ defaultHudOptions & #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ FixedAspect 1)) 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]) + arc = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 List.!! 2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) + ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1 List.!! 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)] @@ -469,22 +479,22 @@ Chart (TextA (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi/2)) ["False"]) [P 0.1 0.5]] ], vert 0.02 - [checkFlags False True (Colour 1 0 1 0.3) & view #chartList, - checkFlags False False (Colour 0 1 0 0.3) & view #chartList, + [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 (Colour 0 0 1 0.3) & view #chartList, - checkFlags True False (Colour 1 0 0 0.3) & view #chartList, + [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 0 0.75], - Chart (TextA (defaultTextStyle & #size .~ 0.6) ["Large"]) [P 5.5 0.2]] - ] & - #hudOptions .~ defaultHudOptions & + [ Chart BlankA [R 0 9 -2.75 -3.25], + Chart (TextA (defaultTextStyle & #size .~ 0.6) ["Large"]) [P 5.5 -3.0]] + ] & + #hudOptions .~ mempty & #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect)) checkFlags :: Bool -> Bool -> Colour -> ChartSvg @@ -498,79 +508,60 @@ 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 .~ Colour 0 0 0 0.5) (fst <$> ps1)) (PointXY . snd <$> ps1) - c1 = Chart (LineA $ defaultLineStyle & #width .~ 0.02 & #color .~ Colour 0 0 0 0.2) (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 .~ Colour 0 0 0 0.2) (PointXY . ellipse (Point 0.0 0.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0..100]) + 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]) -- | quad example -- --- > quadExample (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) --- -- ![quad example](other/quad.svg) -quadExample :: QuadPosition Double -> ChartSvg -quadExample p@(QuadPosition start end control) = +quadExample :: ChartSvg +quadExample = mempty & #chartList .~ [path', curve, c0, bbox] & #hudOptions .~ defaultHudOptions & #svgOptions %~ ((#outerPad ?~ 0.05) . (#chartAspect .~ ChartAspect)) where + 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]) + path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 List.!! 2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) + curve = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1 List.!! 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)] -- | cubic example -- --- > cubicExample (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) --- -- ![cubic example](other/cubic.svg) -cubicExample :: CubicPosition Double -> ChartSvg -cubicExample p@(CubicPosition start end control1 control2) = +cubicExample :: ChartSvg +cubicExample = mempty & #chartList .~ [path', curve, c0, bbox] & - #hudOptions .~ - ( defaultHudOptions & - #hudTitles .~ - [ defaultTitle pathText & - #place .~ PlaceBottom & - #style . #size .~ 0.06 - ] & - #hudAxes %~ fmap (#axisTick . #tstyle .~ - TickRound (FormatComma (Just 2)) 8 NoTickExtend) - ) & + #hudOptions .~ mempty & #svgOptions %~ ((#outerPad ?~ 0.02) . (#chartAspect .~ ChartAspect)) 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]) + path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1 List.!! 2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) + curve = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1 List.!! 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)] - pathText = toPathAbsolutes ps --- | Create a chart across a surface using a function. --- --- > writeChartSvg "other/surface.svg" $ surfaceExample "rosenbrock" (Point 100 100) one (fst . first (-1.0 *) . second (-1.0 .*) . rosenbrock 1 10) +-- | The common way to create a surface chart is usually a grid over a function. -- -- ![surface example](other/surface.svg) -- -surfaceExample :: - -- | Legend title - Text -> - -- | Surface grid - Point Int -> - -- | Surface range - Rect Double -> - -- | Surface function - (Point Double -> Double) -> - ChartSvg -surfaceExample t grain r f = +surfaceExample :: ChartSvg +surfaceExample = mempty & #hudList .~ hs & #chartList .~ cs & #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp) where + t = "rosenbrock" + grain = Point 20 20 + r = one + f = fst . bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10 (cs, hs) = surfacefl f (defaultSurfaceOptions & @@ -580,67 +571,35 @@ (defaultSurfaceLegendOptions t & #sloStyle . #surfaceColors .~ take 6 palette1) --- | Create an arrow chart across a surface using a function. --- --- Typically used to represent a gradient. --- --- > writeChartSvg "other/arrowg.svg" $ arrowgExample (Point 20 20) one (fst . first (-1.0 *) . second (-1.0 .*) . rosenbrock 1 10) --- --- ![arrowg example](other/arrowg.svg) +-- | arrow example -- +-- Which happens to be the gradient of the surface example. -- -arrowgExample :: - -- | Surface grid - Point Int -> - -- | Surface range - Rect Double -> - -- | Surface gradient function - (Point Double -> Point Double) -> - ChartSvg -arrowgExample grain r f = +-- ![arrow example](other/arrow.svg) +arrowExample :: ChartSvg +arrowExample = mempty & #hudOptions .~ (defaultHudOptions & #hudAxes %~ fmap (#axisTick . #ltick .~ Nothing)) & #chartList .~ ((\p -> chart (tail . f $ p) (angle . f $ p) p) <$> ps) & - #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp) + #svgOptions .~ defaultSvgOptions where - ps = grid MidPos r grain + f = snd . bimap (-1.0 *) (-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" gs s r' = defaultGlyphStyle & #borderSize .~ 0.05 & #size .~ s & - #borderColor .~ black & + #borderColor .~ dark & #rotation .~ Just r' & #shape .~ arrow chart s r' p = Chart (GlyphA (gs s r')) [PointXY p] tail :: Point Double -> Double - tail = max 0.005 . min 0.02 . (*0.01) . (/avmag) . norm + tail = max 0.05 . min 0.02 . (*0.01) . (/avmag) . norm avmag = sum (norm . f <$> ps) / fromIntegral (length ps) --- | A surface chart with gradient arrows. --- --- > writeChartSvg "other/surfaceg.svg" $ surfacegExample "rosenbrock" (Point 100 100) (Point 20 20) one (first (-1.0 *) . second (-1.0 .*) . rosenbrock 1 10) --- --- ![surfaceg example](other/surfaceg.svg) --- -surfacegExample :: - -- | Title - Text -> - -- | Surface grid - Point Int -> - -- | Gradient grid - Point Int -> - -- | Surface range - Rect Double -> - -- | Surface + gradient function - (Point Double -> (Double, Point Double)) -> - ChartSvg -surfacegExample t grainS grainG r f = - surfaceExample t grainS r (fst . f) <> - arrowgExample grainG r (snd . f) - -- | function for testing -- -- > f(x,y) = (a-x)^2 + b * (y - x^2)^2 @@ -651,105 +610,10 @@ 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)) --- | This was a problem chart that helped me get the aspect scaling of curves right. --- --- The answer was that radii of an Arc needs to be transformed by scaling changes but not translation ones (radii are relative to existing points which are already being translated). --- --- The problem can be isolated to RunHud ... --- --- >>> let cs = [toPathChart defaultPathStyle $ singletonArc $ ArcPosition (Point 0 1) (Point 1 0) (ArcInfo (Point 1 1) 0 False False)] --- >>> runHud (aspect 3) [canvas $ blob (Colour 0.2 0.1 0.7 0.1)] cs --- [Chart {annotation = RectA (RectStyle {borderSize = 0.0, borderColor = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.20 0.10 0.70 0.10}), xys = [R -1.5 1.5000000000000002 -0.5 0.5]},Chart {annotation = PathA (PathStyle {borderSize = 1.0e-2, borderColor = RGBA 0.12 0.47 0.71 0.80, color = RGBA 0.12 0.47 0.71 0.30}) [StartI,ArcI (ArcInfo {radii = Point 3.0 1.0, phi = 0.0, large = False, clockwise = False})], xys = [P -1.5 0.5,P 1.5 -0.5]}] --- --- ![problematic1](other/problematic1.svg) --- --- Incorrect scaling of an Arc was occuring on x-axis gaps, but not with gapless x-axis elements, titles or any y axis variations. --- --- > problematic1 (FixedAspect 1) (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.0 0.5) (0) False True)) & #hudOptions .~ (mempty & #hudAxes .~ [defaultAxisOptions & #place .~ PlaceTop & #adjust .~ Nothing & #axisBar .~ Nothing & #axisTick . #ltick .~ Nothing & #axisTick . #tstyle .~ TickRound (FormatComma (Just 2)) 2 NoTickExtend & #axisTick . #ttick .~ Nothing & #axisTick . #gtick .~ Just (defaultGlyphTick, 0.2), defaultAxisOptions & #place .~ PlaceRight & #adjust .~ Nothing & #axisBar .~ Nothing & #axisTick . #ltick .~ Nothing & #axisTick . #tstyle .~ TickRound (FormatComma (Just 2)) 2 NoTickExtend & #axisTick . #ttick .~ Nothing & #axisTick . #gtick .~ Just (defaultGlyphTick, 0.2)]) --- --- Again isolating to runHud ... --- --- > let cs = [toPathChart defaultPathStyle $ singletonArc $ (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.0 0.5) (0) False True))] --- > let dbox = padBox $ dataBoxes cs --- > dbox --- Rect -0.6180339784260676 1.0 -5.901699179399067e-2 1.0 --- --- > let ho = (mempty & #hudAxes .~ [defaultAxisOptions & #place .~ PlaceBottom & #adjust .~ Nothing & #axisBar .~ Nothing & #axisTick . #ltick .~ Nothing & #axisTick . #tstyle .~ TickRound (FormatComma (Just 2)) 2 NoTickExtend & #axisTick . #ttick .~ Nothing & #axisTick . #gtick .~ Just (defaultGlyphTick, 0.2), defaultAxisOptions & #place .~ PlaceRight & #adjust .~ Nothing & #axisBar .~ Nothing & #axisTick . #ltick .~ Nothing & #axisTick . #tstyle .~ TickRound (FormatComma (Just 2)) 2 NoTickExtend & #axisTick . #ttick .~ Nothing & #axisTick . #gtick .~ Just (defaultGlyphTick, 0.2)]) --- > let (hs',cs') = makeHud dbox ho --- > let cs1 = runHud dbox hs' cs --- > cs1 --- --- > [Chart {annotation = GlyphA (GlyphStyle {size = 3.0e-2, color = RGBA 0.50 0.50 0.50 1.00, borderColor = RGBA 0.50 0.50 0.50 1.00, borderSize = 5.0e-3, shape = VLineGlyph 5.0e-3, rotation = Just 1.5707963267948966, translate = Nothing}), xys = [P 1.2049999999999998 0.0,P 1.2049999999999998 0.5,P 1.2049999999999998 1.0]},Chart {annotation = GlyphA (GlyphStyle {size = 3.0e-2, color = RGBA 0.50 0.50 0.50 1.00, borderColor = RGBA 0.50 0.50 0.50 1.00, borderSize = 5.0e-3, shape = VLineGlyph 5.0e-3, rotation = Nothing, translate = Nothing}), xys = [P 0.0 -0.2640169917939907,P 1.0 -0.2640169917939907]},Chart {annotation = PathA (PathStyle {borderSize = 1.0e-2, borderColor = RGBA 0.12 0.47 0.71 0.80, color = RGBA 0.12 0.47 0.71 0.30}) [StartI,ArcI (ArcInfo {radii = Point 1.0 0.5, phi = 0.0, large = False, clockwise = True})], xys = [P 1.0 0.0,P 0.0 1.0]}] --- --- The output from runHud looks ok, so the problem was isolated to projectXYsWith ... --- --- phi was then causing aspect scaling problems. Unadjusted was good: --- --- > writeChartSvg "other/t1.svg" $ problematic1 (UnadjustedAspect) (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.0 0.5) (-pi/4) False True)) & #hudOptions .~ defaultHudOptions --- --- And then I realised that the x and y radii of the ellipse was __firstly__ rotated in the XY-space and only then should be subject to scaling... -problematic1 :: ChartAspect -> ArcPosition Double -> ChartSvg -problematic1 ca p = - mempty & - #chartList .~ [arc, ell, pts, bbox] & - #hudOptions .~ defaultHudOptions & - #svgOptions .~ (defaultSvgOptions & #chartAspect .~ ca) - where - -- p = ArcPosition (Point 0 1) (Point 1 0) (ArcInfo (Point 1 1) 0 False False) - (ArcCentroid c r phi' ang0 angd) = arcCentroid p - ps = singletonArc p - arc = toPathChart defaultPathStyle ps - ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . ellipse c r phi' . (\x -> ang0 + angd * x / 10.0) <$> [0..10]) - pts = Chart (GlyphA defaultGlyphStyle) (fmap PointXY [c, p ^. #posStart, p ^. #posEnd]) - 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)] - --- | FIXME: A guesstimate for arc scaling --- --- In a chart-svg projection (See 'projectOnP' say), points on the ellipse scale, but radii and angles do not, and not sure about the centroid. --- --- This causes distortion for chart-svg re-scaling. --- --- This is a chart of a guess for values for (aspect 2) --- --- > let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 2) (pi/6) True True) --- > let guess = ArcCentroid (Point -0.2864867185179476 1.6092991486979669) (Point 1.3266801807145205 3.0142082605509395) 1.0962340928888052 -2.8 -5.5 --- --- ![problematic2](other/problematic2.svg) -problematic2 :: ArcPosition Double -> ArcCentroid Double -> ChartSvg -problematic2 p@(ArcPosition p1 p2 _) (ArcCentroid gc gr gphi gang0 gangd)= - mempty & - #chartList .~ [ellGuess] <> projectXYsWith asp one [c0, xradii, yradii, dir0, dir1, ell, ellFull, rtxt, gs] & - #hudOptions .~ defaultHudOptions & - #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect)) - where - asp = aspect 2 - (ArcCentroid c r a ang0 angd) = arcCentroid p - ang1 = ang0+angd - ax = c+_x r .* ray a - ay = c+_y r .* ray (a + pi/2) - ellFull = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . ellipse c r a . (\x -> 2 * pi * x / 100.0) <$> [0..100]) - ell = Chart (LineA $ defaultLineStyle & #width .~ 0.04 & #color .~ setOpac 0.3 (palette1!!2)) (PointXY . ellipse c r a . (\x -> ang0 + (ang1 - ang0) * x / 100.0) <$> [0..100]) - ellGuess = Chart (LineA $ defaultLineStyle & #width .~ 0.03 & #color .~ setOpac 0.4 (palette1!!4)) (PointXY . ellipse gc gr gphi . (\x -> gang0 + gangd * x / 100.0) <$> [0..100]) - c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [c,p1,p2,ax,ay]) - gs = Chart (GlyphA $ defaultGlyphStyle & #shape .~ CircleGlyph & #size .~ 0.05) (PointXY <$> [ellipse c r a 0.472, ellipse c r a (0.472 + pi/2)]) - 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 <$> [c, ax]) - yradii = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.9 0.8 0.02 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [c, ay]) - dir0 = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.2 0.9 0.8 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [c, p1]) - dir1 = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.2 0.2 0.9 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [c, p2]) - rtxt = Chart (TextA defaultTextStyle ((\(Point x y) -> fixed (Just 3) x <> "," <> fixed (Just 3) y) <$> [r])) [P 0 2.5, P 0 2] - -- | Run this to refresh haddock example SVGs. writeAllExamples :: IO () writeAllExamples = do - -- Example in cabal file - let xs = [[(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)]] :: [[(Double, Double)]] - let ls = fmap (PointXY . uncurry Point) <$> xs - let anns = zipWith (\w c -> LineA (defaultLineStyle & #width .~ w & #color .~ c)) [0.015, 0.03, 0.01] palette1 - let lineChart = zipWith Chart anns ls - writeChartSvgDefault "other/lines.svg" lineChart - writeChartSvgHud "other/lineshud.svg" lineChart - - -- charts in Chart.Types + -- charts in Chart docs writeChartSvg "other/unit.svg" unitExample writeChartSvg "other/rect.svg" rectExample writeChartSvg "other/text.svg" textExample @@ -758,41 +622,24 @@ writeChartSvg "other/svgoptions.svg" svgOptionsExample writeChartSvg "other/hudoptions.svg" hudOptionsExample writeChartSvg "other/legend.svg" legendExample - -- charts in Chart.Bar + -- charts in Chart.Bar docs writeChartSvg "other/bar.svg" barExample - -- extra Charts in Chart.Example + -- 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/boundTextBug.svg" boundTextBugExample + 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 (ArcPosition (Point 1.0 0.0) (Point 0.0 1.0) - (ArcInfo (Point 1.0 0.5) (-pi/3) False True)) + writeChartSvg "other/arc.svg" arcExample writeChartSvg "other/arcflags.svg" arcFlagsExample - writeChartSvg "other/ellipse.svg" $ ellipseExample - (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi/3) True True)) - writeChartSvg "other/quad.svg" $ - quadExample (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) - writeChartSvg "other/cubic.svg" $ - cubicExample (CubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1)) - writeChartSvg "other/surface.svg" $ - surfaceExample "rosenbrock" (Point 100 100) one - (fst . bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10) - writeChartSvg "other/arrowg.svg" $ - arrowgExample (Point 20 20) one - (snd . bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10) - writeChartSvg "other/surfaceg.svg" $ - surfacegExample "rosenbrock" (Point 100 100) (Point 20 20) one - (bimap (-1.0 *) (-1.0 .*) . rosenbrock 1 10) - - -- problematic charts - writeChartSvg "other/problematic1.svg" $ - problematic1 (FixedAspect 2) (ArcPosition (Point 0 1) (Point 1 0) (ArcInfo (Point 1 1) 0 False False)) - writeChartSvg "other/problematic2.svg" $ - problematic2 (ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 2) (pi/6) True True)) (ArcCentroid (Point -0.2864867185179476 1.6092991486979669) (Point 1.3266801807145205 3.0142082605509395) 1.0962340928888052 -2.8 -5.5) + writeChartSvg "other/ellipse.svg" ellipseExample + writeChartSvg "other/quad.svg" quadExample + writeChartSvg "other/cubic.svg" cubicExample + writeChartSvg "other/arrow.svg" arrowExample putStrLn ("ok" :: Text) diff --git a/src/Chart/Reanimate.hs b/src/Chart/Reanimate.hs --- a/src/Chart/Reanimate.hs +++ b/src/Chart/Reanimate.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-} @@ -7,142 +8,127 @@ -- | Integration of reanimate and chart-svg module Chart.Reanimate - ( chartSvgTree, - chartSvgTreeDef, - chartSvgTrees, - chartSvgTreesDef, - writeChartSvgTree, + ( ReanimateConfig(..), + defaultReanimateConfig, + reanimChartSvg, + animChartSvg, + chartReanimate, + groupTreeA, tree, toPixelRGBA8, + daText, + fromFile, + translateDA, + scaleDA, ) where -import Chart as C hiding (transform, Line) +import Chart as C hiding (transform, Line, renderChartsWith) import Codec.Picture.Types import Control.Lens hiding (transform) import qualified Data.Attoparsec.Text as A -import Graphics.SvgTree.PathParser -import Graphics.SvgTree.Types as SvgTree hiding (Point, Text) import Linear.V2 import NumHask.Prelude hiding (fold) -import qualified Graphics.SvgTree.CssTypes as Css -import qualified Graphics.SvgTree as SvgTree -import Reanimate -import NumHask.Space.Types (width) -import Graphics.SvgTree.Printer (ppDocument) +import Reanimate as Re +import qualified Graphics.SvgTree.PathParser as Svg +import Graphics.SvgTree as Svg hiding (Text) --- | Render a 'ChartSvg' to a 'Tree' --- --- Alters the reanimate default viewbox of 16:9, and simplifies the SVG. -chartSvgTree :: ChartSvg -> Tree -chartSvgTree cs = simplify . withViewBox vb . mkGroup $ ts - where - (ts, r, _) = chartSvgTrees cs - (Rect x z y w) = r - vb = (x, -y, z-x, w-y) +data ReanimateConfig = ReanimateConfig + { duration :: Double, + background :: Maybe Text, + globalFontFamily :: Maybe [Text], + globalFontStyle :: Maybe Svg.FontStyle, + globalAlignment :: Svg.Alignment + } deriving (Eq, Show, Generic) --- | Render a 'ChartSvg' to a 'Tree' with the default viewbox -chartSvgTreeDef :: ChartSvg -> Tree -chartSvgTreeDef = simplify . mkGroup . chartSvgTreesDef +defaultReanimateConfig :: ReanimateConfig +defaultReanimateConfig = ReanimateConfig 5 (Just "black") (Just ["Arial", "Helvetica", "sans-serif"]) (Just FontStyleNormal) AlignxMinYMin --- | Render a 'ChartSvg' to 'Tree's, the fitted chart viewbox, and the suggested SVG dimensions --- -chartSvgTrees :: ChartSvg -> ([Tree], Rect Double, Point Double) -chartSvgTrees cs = (ts, rect', size') - where - so = view #svgOptions cs - ho = view #hudOptions cs - hl = view #hudList cs - cl = view #chartList cs - penult = case view #chartAspect so of - FixedAspect _ -> styleBoxesS cl - CanvasAspect _ -> dataBoxesS cl - ChartAspect -> styleBoxesS cl - UnadjustedAspect -> dataBoxesS cl - clAspect = cl & - runHud penult [chartAspectHud (so ^. #chartAspect)] & - maybe id (\x -> frameChart x (fromMaybe 0 (view #innerPad so))) - (view #chartFrame so) - (hlExtra, clExtra) = makeHud (padBox $ dataBoxes clAspect) ho - clAll = clAspect <> clExtra - hlAll = hl <> hlExtra - ts = fmap (SvgTree.cssApply (cssRules (view #cssOptions so)) . tree) - (runHud (initialCanvas (so ^. #chartAspect) clAll) hlAll clAll) - rect' = styleBoxesS clAll & maybe id padRect (view #outerPad so) - Point w h = NumHask.Space.Types.width rect' - size' = Point (view #svgHeight so/h*w) (view #svgHeight so) +reanimChartSvg :: ReanimateConfig -> (Double -> ChartSvg) -> IO () +reanimChartSvg cfg cs = + reanimate $ animChartSvg cfg cs --- | Render a 'ChartSvg' to 'Tree's at the standard reanimate viewbox --- -chartSvgTreesDef :: ChartSvg -> [Tree] -chartSvgTreesDef cs = ts - where - so = view #svgOptions cs - ho = view #hudOptions cs - hl = view #hudList cs - cl = view #chartList cs - clAspect = projectXYs (Rect (-8.0) 8.0 (-4.5) 4.5) cl - (hlExtra, clExtra) = makeHud (padBox $ dataBoxes clAspect) ho - clAll = clAspect <> clExtra - hlAll = hl <> hlExtra - ts = fmap (SvgTree.cssApply (cssRules (view #cssOptions so)) . tree) - (runHud (initialCanvas (so ^. #chartAspect) clAll) hlAll clAll) +animChartSvg :: ReanimateConfig -> (Double -> ChartSvg) -> Animation +animChartSvg cfg cs = + mkAnimation (view #duration cfg) $ groupTreeA cfg cs --- | render Charts to a Document using the supplied size and viewbox. -renderToDocument :: CssOptions -> Point Double -> Rect Double -> [Tree] -> Document -renderToDocument csso (Point w' h') vb ts = - Document - ((\(Rect x z y w) -> Just (x, - w, z - x, w - y)) vb) - (Just (Num w')) - (Just (Num h')) - (SvgTree.cssApply (cssRules csso) <$> ts) - (unpack "") - "" - (PreserveAspectRatio False AlignNone Nothing) +globalAtts :: ReanimateConfig -> Svg.DrawAttributes +globalAtts cfg = + mempty & + maybe id (\x -> fontFamily .~ Last (Just (fmap unpack x))) + (view #globalFontFamily cfg) . + maybe id (\x -> fontStyle .~ Last (Just x)) + (view #globalFontStyle cfg) --- | write a 'ChartSvg' to a file via conversion to a reanimate 'Tree' structure. -writeChartSvgTree :: FilePath -> ChartSvg -> IO () -writeChartSvgTree fp cs = writeFile fp . pack . ppDocument $ doc - where - doc = renderToDocument (view (#svgOptions . #cssOptions) cs) size' rect' ts' - (ts', rect', size') = chartSvgTrees cs +data ChartReanimate = ChartReanimate { trees :: [Tree], box :: Rect Double, size :: C.Point Double} deriving (Eq, Show, Generic) -cssRules :: CssOptions -> [Css.CssRule] -cssRules UseCssCrisp = [cssCrisp'] -cssRules UseGeometricPrecision = [cssGeometricPrecision] -cssRules NoCssOptions = [] +-- | create a Tree maker from a duration, and a chartsvg maker. +groupTreeA :: ReanimateConfig -> (Double -> ChartSvg) -> Double -> Tree +groupTreeA 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) + ] --- | crisp edges css -cssGeometricPrecision :: Css.CssRule -cssGeometricPrecision = Css.CssRule [] [Css.CssDeclaration "shape-rendering" [[Css.CssString "geometricPrecision"]]] +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; }") -cssCrisp' :: Css.CssRule -cssCrisp' = Css.CssRule [] [Css.CssDeclaration "shape-rendering" [[Css.CssString "crispEdges"]]] +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 + } +-- | 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'' + -- | Rectange svg treeRect :: Rect Double -> Tree treeRect a = RectangleTree $ rectSvg a defaultSvg -- | Text svg -treeText :: TextStyle -> Text -> Point Double -> Tree +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 -> Point Double -> 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 (Point s (x' * s)) one)) + treeRect (move p (C.scale (C.Point s (x' * s)) one)) treeShape (RectRoundedGlyph x'' rx ry) s p = RectangleTree - . rectSvg (addPoint p $ C.scale (Point s (x'' * s)) one) + . rectSvg (addPoint p $ C.scale (C.Point s (x'' * s)) one) . (rectCornerRadius .~ (Just $ Num rx, Just $ Num ry)) $ defaultSvg -treeShape (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = +treeShape (TriangleGlyph (C.Point xa ya) (C.Point xb yb) (C.Point xc yc)) s p = PolygonTree . (polygonPoints .~ rps) $ (drawAttributes %~ translateDA p) defaultSvg @@ -159,39 +145,46 @@ (pointSvg p) (Num $ s / 2) (Num $ (x' * s) / 2) -treeShape (VLineGlyph x') s (Point x y) = +treeShape (VLineGlyph x') s (C.Point x y) = LineTree $ Line (mempty & strokeWidth .~ Last (Just (Num x'))) - (pointSvg (Point x (y - s / 2))) - (pointSvg (Point x (y + s / 2))) -treeShape (HLineGlyph x') s (Point x y) = + (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 .~ Last (Just (Num x'))) - (pointSvg (Point (x - s / 2) y)) - (pointSvg (Point (x + s / 2) y)) -treeShape (PathGlyph path) _ p = - PathTree $ Path ((drawAttributes %~ translateDA p) defaultSvg) path' - where - path' = either mempty (: []) $ A.parseOnly command path + (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 -> Point Double -> 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 :: [Point Double] -> Tree +treeLine :: [C.Point Double] -> Tree treeLine xs = PolyLineTree - . (polyLinePoints .~ ((\(Point x y) -> V2 x (- y)) <$> xs)) + . (polyLinePoints .~ ((\(C.Point x y) -> V2 x (- y)) <$> xs)) $ defaultSvg -- | GlyphStyle to svg Tree -treePath :: [PathInfo Double] -> [Point Double] -> Tree -treePath s p = PathTree $ Path mempty (zipWith (curry toPathCommand) s p) +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' -- @@ -232,13 +225,9 @@ (strokeColor .~ Last (Just FillNone)) & (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) & - (textAnchor .~ Last (Just (toTextAnchor $ o ^. #anchor))) & - maybe - id - (\(Point x y) -> transform ?~ [Translate x (-y)]) - (o ^. #translate) + (textAnchor .~ Last (Just (toTextAnchor $ o ^. #anchor))) where - toTextAnchor :: Anchor -> TextAnchor + toTextAnchor :: Anchor -> Svg.TextAnchor toTextAnchor AnchorMiddle = TextAnchorMiddle toTextAnchor AnchorStart = TextAnchorStart toTextAnchor AnchorEnd = TextAnchorEnd @@ -252,7 +241,7 @@ (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) & (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) & - maybe id (\(Point x y) -> transform ?~ [Translate x (-y)]) (o ^. #translate) + maybe id (\(C.Point x y) -> transform ?~ [Translate x (-y)]) (o ^. #translate) daLine :: LineStyle -> DrawAttributes daLine o = @@ -270,12 +259,12 @@ maybe id (\xs -> strokeDashArray .~ Last (Just (Num <$> xs))) (o ^. #dasharray) -fromLineCap' :: LineCap -> Cap +fromLineCap' :: LineCap -> Svg.Cap fromLineCap' LineCapButt = CapButt fromLineCap' LineCapRound = CapRound fromLineCap' LineCapSquare = CapSquare -fromLineJoin' :: C.LineJoin -> SvgTree.LineJoin +fromLineJoin' :: C.LineJoin -> Svg.LineJoin fromLineJoin' LineJoinMiter = JoinMiter fromLineJoin' LineJoinBevel = JoinBevel fromLineJoin' LineJoinRound = JoinRound @@ -303,24 +292,36 @@ -- | convert a point to the svg co-ordinate system -- The svg coordinate system has the y-axis going from top to bottom. -pointSvg :: Point Double -> (Number, Number) -pointSvg (Point x y) = (Num x, Num (- y)) +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 -> Point Double -> s -> s -rotatePDA a (Point x y) s = s & transform %~ (Just . maybe r (<> r)) +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) => Point Double -> s -> s -translateDA (Point x' y') = +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 -> Rectangle -> Rectangle +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 +fromFile :: FilePath -> IO Tree +fromFile 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 --- a/src/Chart/Render.hs +++ b/src/Chart/Render.hs @@ -10,6 +10,8 @@ -- Note that type signatures are tightened to Double as sane SVG rendering suggests. module Chart.Render ( ChartSvg (..), + renderToCharts, + renderToCRS, chartSvg, chartSvgDefault, chartSvgHud, @@ -25,17 +27,13 @@ terms, makeAttribute, - -- * Augmentation - ChartExtra (..), - toChartExtra, - renderChartExtrasWith, - -- * low-level conversions attsRect, attsText, attsGlyph, attsLine, attsPath, + svgShape, ) where @@ -69,25 +67,7 @@ instance Monoid ChartSvg where mempty = ChartSvg defaultSvgOptions mempty [] [] --- | Specification of a chart for rendering to SVG -data ChartSvgExtra - = ChartSvgExtra - { svgOptionsExtra :: SvgOptions, - hudOptionsExtra :: HudOptions, - hudListExtra :: [Hud Double], - chartExtraList :: [ChartExtra Double] - } - deriving (Generic) - -instance Semigroup ChartSvgExtra where - (<>) (ChartSvgExtra _ o h c) (ChartSvgExtra s' o' h' c') = - ChartSvgExtra s' (o <> o') (h <> h') (c <> c') - -instance Monoid ChartSvgExtra where - mempty = ChartSvgExtra defaultSvgOptions mempty [] [] - -- * rendering - -- | @svg@ element + svg 2 attributes svg2Tag :: Term [Attribute] (s -> t) => s -> t svg2Tag m = @@ -110,19 +90,6 @@ makeAttribute "viewBox" (show x <> " " <> show (- w) <> " " <> show (z - x) <> " " <> show (w - y)) ] -renderToSvgExtra :: CssOptions -> Point Double -> Rect Double -> [ChartExtra Double] -> Html () -renderToSvgExtra csso (Point w' h') (Rect x z y w) cs = - with - ( svg2Tag - ( cssText csso <> - mconcat (svgExtra <$> cs) - ) - ) - [ width_ (show w'), - height_ (show h'), - makeAttribute "viewBox" (show x <> " " <> show (- w) <> " " <> show (z - x) <> " " <> show (w - y)) - ] - cssText :: CssOptions -> Html () cssText UseCssCrisp = cssCrisp cssText UseGeometricPrecision = geometricPrecision @@ -136,10 +103,13 @@ geometricPrecision :: Html () geometricPrecision = style_ [type_ "text/css"] ("* { shape-rendering: geometricPrecision; }" :: Text) --- | render Charts with the supplied options. -renderChartsWith :: SvgOptions -> [Chart Double] -> Text -renderChartsWith so cs = - Lazy.toStrict $ renderText (renderToSvg (so ^. #cssOptions) size' rect' cs') +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' = @@ -155,25 +125,30 @@ ChartAspect -> styleBoxesS cs UnadjustedAspect -> dataBoxesS cs --- | render ChartExtras with the supplied options. -renderChartExtrasWith :: SvgOptions -> [ChartExtra Double] -> Text -renderChartExtrasWith so cs = - Lazy.toStrict $ renderText (renderToSvgExtra (so ^. #cssOptions) size' rect' 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 - cs' = zipWith (\(ChartExtra _ l a h') c' -> ChartExtra c' l a h') cs (csFinalize csa) - rect' = styleBoxesS (csFinalize csa) & maybe id padRect (so ^. #outerPad) - csFinalize = + 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) . - runHud penult [chartAspectHud (so ^. #chartAspect)] + (so ^. #chartFrame) + cs'' = + maybe [] (\c -> [Chart (RectA (blob c)) [RectXY rect']]) (so ^. #background) <> cs' Point w h = NH.width rect' size' = Point ((so ^. #svgHeight)/h*w) (so ^. #svgHeight) - csa = fmap (view #chartActual) cs penult = case so ^. #chartAspect of - FixedAspect _ -> styleBoxesS csa - CanvasAspect _ -> dataBoxesS csa - ChartAspect -> styleBoxesS csa - UnadjustedAspect -> dataBoxesS csa + 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 @@ -339,16 +314,6 @@ svg :: Chart Double -> Lucid.Html () svg c = term "g" (svgAtts $ c ^. #annotation) (svgHtml c) --- | render extra attributes and html -svgExtra :: ChartExtra Double -> Lucid.Html () -svgExtra (ChartExtra c l' as h) = - case l' of - Nothing -> x - Just l -> - term "a" [term "xlink:href" l :: Lucid.Attribute] x - where - x = term "g" (svgAtts (c ^. #annotation) <> as) (svgHtml c <> h) - -- | Make Lucid Html given term and attributes terms :: Text -> [Lucid.Attribute] -> Lucid.Html () terms t = with $ makeXmlElementNoEnd t @@ -373,7 +338,6 @@ term "font-size" (show $ o ^. #size), term "text-anchor" (toTextAnchor $ o ^. #anchor) ] - <> maybe [] ((: []) . term "transform" . toTranslateText) (o ^. #translate) where toTextAnchor :: Anchor -> Text toTextAnchor AnchorMiddle = "middle" @@ -434,16 +398,3 @@ toScaleText :: Double -> Text toScaleText x = "scale(" <> show x <> ")" - --- | Augmentation of a chart to include Html content. -data ChartExtra a = - ChartExtra - { chartActual :: Chart a, - chartLink :: Maybe Text, - chartAttributes :: [Attribute], - chartContent :: Html () - } deriving (Show, Generic) - --- | Convert a plain chart top a 'ChartExtra'. -toChartExtra :: Chart a -> ChartExtra a -toChartExtra c = ChartExtra c Nothing mempty mempty diff --git a/src/Chart/Surface.hs b/src/Chart/Surface.hs --- a/src/Chart/Surface.hs +++ b/src/Chart/Surface.hs @@ -34,8 +34,6 @@ -- | Options for a Surface chart. -- --- >>> defaultSurfaceOptions --- SurfaceOptions {soStyle = SurfaceStyle {surfaceColors = [RGBA 0.65 0.81 0.89 1.00,RGBA 0.12 0.47 0.71 1.00], surfaceRectStyle = RectStyle {borderSize = 0.0, borderColor = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 1.00}}, soGrain = Point 10 10, soRange = Rect -0.5 0.5 -0.5 0.5} data SurfaceOptions = SurfaceOptions { -- | surface style @@ -55,7 +53,7 @@ -- | A surface chart is a specialization of a 'RectA' chart -- -- >>> defaultSurfaceStyle --- SurfaceStyle {surfaceColors = [RGBA 0.65 0.81 0.89 1.00,RGBA 0.12 0.47 0.71 1.00], surfaceRectStyle = RectStyle {borderSize = 0.0, borderColor = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 1.00}} +-- 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}} -- -- ![surface example](other/surface.svg) data SurfaceStyle @@ -69,7 +67,7 @@ -- | The official surface style. defaultSurfaceStyle :: SurfaceStyle defaultSurfaceStyle = - SurfaceStyle (take 2 palette1) (blob black) + SurfaceStyle (take 2 palette1) (blob dark) -- | Main surface data elements data SurfaceData @@ -123,8 +121,6 @@ -- | Legend specialization for a surface chart. -- --- >>> defaultSurfaceLegendOptions "" --- SurfaceLegendOptions {sloStyle = SurfaceStyle {surfaceColors = [RGBA 0.65 0.81 0.89 1.00,RGBA 0.12 0.47 0.71 1.00], surfaceRectStyle = RectStyle {borderSize = 0.0, borderColor = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 1.00}}, sloTitle = "", sloWidth = 5.0e-2, sloResolution = 100, sloAxisOptions = AxisOptions {axisBar = Nothing, adjust = Nothing, axisTick = Tick {tstyle = TickRound (FormatPrec (Just 3)) 4 NoTickExtend, gtick = Just (GlyphStyle {size = 3.0e-2, color = RGBA 0.00 0.00 0.00 1.00, borderColor = RGBA 0.50 0.50 0.50 1.00, borderSize = 5.0e-3, shape = VLineGlyph 5.0e-3, rotation = Nothing, translate = Nothing},1.0e-2), ttick = Just (TextStyle {size = 5.0e-2, color = RGBA 0.50 0.50 0.50 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing, translate = Nothing},3.0e-2), ltick = Nothing}, place = PlaceRight}, sloLegendOptions = LegendOptions {lsize = 0.5, vgap = 5.0e-2, hgap = 1.0e-2, ltext = TextStyle {size = 8.0e-2, color = RGBA 0.20 0.20 0.20 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing, translate = Nothing}, lmax = 10, innerPad = 5.0e-2, outerPad = 2.0e-2, legendFrame = Nothing, lplace = PlaceRight, lscale = 0.7}} data SurfaceLegendOptions = SurfaceLegendOptions { sloStyle :: SurfaceStyle, @@ -145,7 +141,7 @@ Nothing ( Tick (TickRound (FormatPrec (Just 3)) 4 NoTickExtend) - (Just (defaultGlyphTick & #color .~ black & #shape .~ VLineGlyph 0.005, 0.01)) + (Just (defaultGlyphTick & #color .~ dark & #shape .~ VLineGlyph 0.005, 0.01)) (Just (defaultTextTick, 0.03)) Nothing ) diff --git a/src/Chart/Types.hs b/src/Chart/Types.hs --- a/src/Chart/Types.hs +++ b/src/Chart/Types.hs @@ -30,6 +30,8 @@ Annotation (..), annotationText, scaleAnn, + scaleOpacAnn, + colourAnn, padRect, -- * Styles @@ -67,6 +69,8 @@ simulHud, HudOptions (..), defaultHudOptions, + colourHudOptions, + scaleOpacHudOptions, defaultCanvas, runHudWith, runHud, @@ -107,6 +111,8 @@ LegendOptions (..), defaultLegendOptions, legendHud, + legendChart, + legendEntry, Orientation (..), fromOrientation, toOrientation, @@ -120,6 +126,7 @@ -- * Chart manipulation padChart, frameChart, + frameAllCharts, hori, vert, stack, @@ -141,7 +148,7 @@ import Data.Colour import Data.FormatN import Data.Generics.Labels () -import Data.List ((!!)) +import qualified Data.List as List import Data.Path import qualified Data.Text as Text import Data.Time @@ -194,12 +201,51 @@ 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 = RGBA 0.12 0.47 0.71 0.80, color = RGBA 0.12 0.47 0.71 0.30} --- --- > writeChartSvgDefault "other/unit.svg" [Chart (RectA defaultRectStyle) [one]] +-- 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 @@ -211,38 +257,36 @@ -- | the style defaultRectStyle :: RectStyle -defaultRectStyle = RectStyle 0.01 (fromRGB (palette !! 1) 0.8) (fromRGB (palette !! 1) 0.3) +defaultRectStyle = RectStyle 0.01 (palette1 List.!! 1) (palette1 List.!! 2) -- | solid rectangle, no border -- -- >>> blob black --- RectStyle {borderSize = 0.0, borderColor = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 1.00} +-- 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 = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 0.00} +-- 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 = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 0.00} +-- 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 = RGBA 0.20 0.20 0.20 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing, translate = Nothing} +-- 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} -- -- >>> 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]] -- --- > writeChartSvgDefault "other/text.svg" t --- -- ![text example](other/text.svg) data TextStyle = TextStyle { size :: Double, @@ -251,8 +295,7 @@ hsize :: Double, vsize :: Double, nudge1 :: Double, - rotation :: Maybe Double, - translate :: Maybe (Point Double) + rotation :: Maybe Double } deriving (Show, Eq, Generic) @@ -275,14 +318,12 @@ -- | the offical text style defaultTextStyle :: TextStyle defaultTextStyle = - TextStyle 0.08 colorText AnchorMiddle 0.5 1.45 -0.2 Nothing Nothing + TextStyle 0.08 dark AnchorMiddle 0.5 1.45 -0.2 Nothing -- | Glyph styling -- -- >>> defaultGlyphStyle --- GlyphStyle {size = 3.0e-2, color = RGBA 0.65 0.81 0.89 0.30, borderColor = RGBA 0.12 0.47 0.71 0.80, borderSize = 3.0e-3, shape = SquareGlyph, rotation = Nothing, translate = Nothing} --- --- See 'Chart.Examples.glyphsExample'. +-- 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 @@ -305,8 +346,8 @@ defaultGlyphStyle = GlyphStyle 0.03 - (fromRGB (P.head palette) 0.3) - (fromRGB (palette !! 1) 0.8) + (palette1 List.!! 1) + (palette1 List.!! 2) 0.003 SquareGlyph Nothing @@ -378,7 +419,7 @@ -- | line style -- -- >>> defaultLineStyle --- LineStyle {width = 1.2e-2, color = RGBA 0.65 0.81 0.89 0.30, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing} +-- 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) -- @@ -395,12 +436,12 @@ -- | the official default line style defaultLineStyle :: LineStyle -defaultLineStyle = LineStyle 0.012 (fromRGB (P.head palette) 0.3) Nothing Nothing Nothing Nothing +defaultLineStyle = LineStyle 0.012 dark Nothing Nothing Nothing Nothing -- | Path styling -- -- >>> defaultPathStyle --- PathStyle {borderSize = 1.0e-2, borderColor = RGBA 0.12 0.47 0.71 0.80, color = RGBA 0.12 0.47 0.71 0.30} +-- 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, @@ -411,7 +452,7 @@ -- | the style defaultPathStyle :: PathStyle defaultPathStyle = - PathStyle 0.01 (fromRGB (palette !! 1) 0.8) (fromRGB (palette !! 1) 0.3) + PathStyle 0.01 (palette1 List.!! 1) (palette1 List.!! 2) -- | Convert from a path command list to a PathA chart toPathChart :: PathStyle -> [(PathInfo Double, Point Double)] -> Chart Double @@ -477,9 +518,8 @@ -- | SVG tag options. -- -- >>> defaultSvgOptions --- SvgOptions {svgHeight = 300.0, outerPad = Just 2.0e-2, innerPad = Nothing, chartFrame = Nothing, cssOptions = NoCssOptions, chartAspect = FixedAspect 1.5} +-- SvgOptions {svgHeight = 300.0, outerPad = Just 2.0e-2, innerPad = Nothing, chartFrame = Nothing, cssOptions = NoCssOptions, chartAspect = FixedAspect 1.5, background = Nothing} -- --- > writeChartSvg "other/svgoptions.svg" (SvgChart (defaultSvgOptions & #chartAspect .~ FixedAspect 0.7) mempty [] lines) -- -- ![svgoptions example](other/svgoptions.svg) data SvgOptions = SvgOptions @@ -488,17 +528,18 @@ innerPad :: Maybe Double, chartFrame :: Maybe RectStyle, cssOptions :: CssOptions, - chartAspect :: ChartAspect + 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) +defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoCssOptions (FixedAspect 1.5) Nothing -- | frame style defaultSvgFrame :: RectStyle -defaultSvgFrame = border 0.01 (fromRGB (grayscale 0.7) 0.5) +defaultSvgFrame = border 0.01 dark -- | Dimensions that are tracked in the 'HudT': -- @@ -612,9 +653,39 @@ ] 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)))) + +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 (fromRGB (grayscale 0.5) 0.025) +defaultCanvas = blob (setOpac 0.05 dark) -- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas data Place @@ -651,7 +722,7 @@ -- | The bar on an axis representing the x or y plane. -- -- >>> defaultAxisBar --- AxisBar {rstyle = RectStyle {borderSize = 0.0, borderColor = RGBA 0.50 0.50 0.50 1.00, color = RGBA 0.50 0.50 0.50 1.00}, wid = 5.0e-3, buff = 1.0e-2} +-- 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, @@ -661,12 +732,12 @@ -- | The official axis bar defaultAxisBar :: AxisBar -defaultAxisBar = AxisBar (RectStyle 0 (fromRGB (grayscale 0.5) 1) (fromRGB (grayscale 0.5) 1)) 0.005 0.01 +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 = RGBA 0.20 0.20 0.20 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing, translate = Nothing}, place = PlaceTop, anchor = AnchorMiddle, buff = 4.0e-2} +-- 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, @@ -681,9 +752,8 @@ defaultTitle txt = Title txt - ( (#size .~ 0.12) - . (#color .~ colorText) - $ defaultTextStyle + ( defaultTextStyle & + #size .~ 0.12 ) PlaceTop AnchorMiddle @@ -692,7 +762,7 @@ -- | xy coordinate markings -- -- >>> defaultTick --- Tick {tstyle = TickRound (FormatComma (Just 2)) 8 TickExtend, gtick = Just (GlyphStyle {size = 3.0e-2, color = RGBA 0.50 0.50 0.50 1.00, borderColor = RGBA 0.50 0.50 0.50 1.00, borderSize = 5.0e-3, shape = VLineGlyph 5.0e-3, rotation = Nothing, translate = Nothing},1.25e-2), ttick = Just (TextStyle {size = 5.0e-2, color = RGBA 0.50 0.50 0.50 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing, translate = Nothing},1.5e-2), ltick = Just (LineStyle {width = 5.0e-3, color = RGBA 0.50 0.50 0.50 0.05, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},0.0)} +-- 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), @@ -705,22 +775,22 @@ defaultGlyphTick :: GlyphStyle defaultGlyphTick = defaultGlyphStyle - & #borderSize .~ 0.005 - & #borderColor .~ fromRGB (grayscale 0.5) 1 - & #color .~ fromRGB (grayscale 0.5) 1 + & #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 & #color .~ fromRGB (grayscale 0.5) 1 + defaultTextStyle & #size .~ 0.05 -- | The official line tick defaultLineTick :: LineStyle defaultLineTick = defaultLineStyle - & #color .~ fromRGB (grayscale 0.5) 0.05 & #width .~ 5.0e-3 + & #color %~ setOpac 0.05 -- | The official tick defaultTick :: Tick @@ -779,7 +849,7 @@ -- | Legend options -- -- >>> defaultLegendOptions --- LegendOptions {lsize = 0.1, vgap = 0.2, hgap = 0.1, ltext = TextStyle {size = 8.0e-2, color = RGBA 0.20 0.20 0.20 1.00, anchor = AnchorMiddle, hsize = 0.5, vsize = 1.45, nudge1 = -0.2, rotation = Nothing, translate = Nothing}, lmax = 10, innerPad = 0.1, outerPad = 0.1, legendFrame = Just (RectStyle {borderSize = 2.0e-2, borderColor = RGBA 0.50 0.50 0.50 1.00, color = RGBA 1.00 1.00 1.00 1.00}), lplace = PlaceBottom, lscale = 0.2} +-- 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 @@ -796,22 +866,22 @@ } deriving (Show, Eq, Generic) --- | The official legend options +-- | The official legend options defaultLegendOptions :: LegendOptions defaultLegendOptions = LegendOptions - 0.1 + 0.3 0.2 0.1 ( defaultTextStyle - & #size .~ 0.08 + & #size .~ 0.12 ) 10 0.1 - 0.1 - (Just (RectStyle 0.02 (fromRGB (grayscale 0.5) 1) white)) - PlaceBottom - 0.2 + 0.02 + (Just (RectStyle 0.01 (setOpac 1 dark) (setOpac 0 dark))) + PlaceRight + 0.25 -- | Generically scale an Annotation. scaleAnn :: Double -> Annotation -> Annotation @@ -954,12 +1024,11 @@ Chart ( TextA ( style' - & #translate ?~ (placePos' a + alignPos a) & #rotation ?~ rot ) [t ^. #text] ) - [zero] + [PointXY (placePos' a + alignPos a)] where style' | t ^. #anchor == AnchorStart = @@ -1390,7 +1459,7 @@ ) LineA ls -> ( LineA (ls & #width %~ (/ (l ^. #lscale))), - [P 0 (0.33 * l ^. #lsize), P (2 * l ^. #lsize) (0.33 * l ^. #lsize)] + [P 0 (1 * l ^. #lsize), P (2 * l ^. #lsize) (1 * l ^. #lsize)] ) PathA ps _ -> ( let cs = @@ -1506,7 +1575,7 @@ Text -> Point Double -> Rect Double -styleBoxText o t p = move (p + p') $ maybe flat (`rotationBound` flat) (o ^. #rotation) +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 @@ -1520,7 +1589,6 @@ AnchorStart -> 0.5 AnchorEnd -> -0.5 AnchorMiddle -> 0.0 - p' = fromMaybe (Point 0.0 0.0) (o ^. #translate) -- | the extra area from glyph styling styleBoxGlyph :: GlyphStyle -> Rect Double @@ -1561,17 +1629,21 @@ -- | additively pad a [Chart] -- -- >>> padChart 0.1 [Chart (RectA defaultRectStyle) [RectXY one]] --- [Chart {annotation = RectA (RectStyle {borderSize = 1.0e-2, borderColor = RGBA 0.12 0.47 0.71 0.80, color = RGBA 0.12 0.47 0.71 0.30}), xys = [R -0.5 0.5 -0.5 0.5]},Chart {annotation = BlankA, xys = [R -0.605 0.605 -0.605 0.605]}] +-- [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 = RGBA 0.12 0.47 0.71 0.80, color = RGBA 0.12 0.47 0.71 0.30}), xys = []},Chart {annotation = BlankA, xys = []}] +-- [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 _ [] = [] @@ -1579,7 +1651,7 @@ 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' _) -> y') (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] diff --git a/src/Chart/Various.hs b/src/Chart/Various.hs --- a/src/Chart/Various.hs +++ b/src/Chart/Various.hs @@ -97,7 +97,7 @@ ( defaultLegendOptions & #ltext . #size .~ 0.3 & #lplace .~ PlaceBottom - & #legendFrame .~ Just (RectStyle 0.02 (palette1 !! 5) white), + & #legendFrame .~ Just (RectStyle 0.02 (palette1 !! 5) (palette1 !! 4)), zipWith (\a r -> (LineA a, r)) ((\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> cs) @@ -189,7 +189,7 @@ bs = (\x -> blend x c1 c2) <$> cs lo = (\c -> defaultLineStyle & #width .~ w & #color .~ c) <$> bs --- | FIXME: better name +-- | No idea what this is really. digitChart :: Text -> [UTCTime] -> diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs --- a/src/Data/Colour.hs +++ b/src/Data/Colour.hs @@ -21,20 +21,19 @@ pattern Colour, opac, setOpac, - fromRGB, hex, - palette, - palette1, blend, blends, toHex, fromHex, unsafeFromHex, - grayscale, - colorText, + palette1, transparent, black, white, + light, + dark, + grey, ) where @@ -61,7 +60,7 @@ instance Show Colour where show (Colour r g b a) = Text.unpack $ - "RGBA " + "Colour " <> fixed (Just 2) r <> " " <> fixed (Just 2) g @@ -70,19 +69,15 @@ <> " " <> fixed (Just 2) a --- | get opacity +-- | opac opac :: Colour -> Double -opac c = getAlpha (color' c) +opac (Colour _ _ _ o) = o -- | set opacity setOpac :: Double -> Colour -> Colour setOpac o (Colour r g b _) = Colour r g b o -- | -fromRGB :: Color RGB Double -> Double -> Colour -fromRGB (ColorRGB r b g) o = Colour' $ ColorRGBA r b g o - --- | hex :: Colour -> Text hex c = toHex c @@ -106,7 +101,7 @@ -- >>> blends 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white] -- RGBA 0.16 0.48 0.64 0.60 blends :: Double -> [Colour] -> Colour -blends _ [] = black +blends _ [] = light blends _ [c] = c blends x cs = blend r (cs P.!! i) (cs P.!! (i+1)) where @@ -164,30 +159,45 @@ i2d :: Int -> Char i2d i = chr (ord '0' + i) --- | some RGB colors to work with -palette :: [Color RGB Double] -palette = unsafeFromHex <$> ["#a6cee3", "#1f78b4", "#e31a1c", "#b2df8a", "#33a02c", "#fb9a99", "#fdbf6f", "#ff7f00", "#cab2d6", "#6a3d9a", "#ffff99", "#b15928"] - -- | some RGBA colors palette1 :: [Colour] -palette1 = (\c -> fromRGB c 1) <$> palette - --- | gray with 1 opacity -grayscale :: Double -> Color RGB Double -grayscale n = ColorRGB n n n - --- | standard text color -colorText :: Colour -colorText = fromRGB (grayscale 0.2) 1 +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 + ] -- | black :: Colour -black = fromRGB (grayscale 0) 1 +black = Colour 0 0 0 1 -- | white :: Colour -white = fromRGB (grayscale 1) 1 +white = Colour 0.99 0.99 0.99 1 -- | +light :: Colour +light = Colour 0.94 0.94 0.94 1 + +-- | +dark :: Colour +dark = Colour 0.05 0.05 0.05 1 + +grey :: Colour +grey = Colour 0.5 0.5 0.5 1 + +-- | transparent :: Colour transparent = Colour 0 0 0 0 + + diff --git a/src/Data/FormatN.hs b/src/Data/FormatN.hs --- a/src/Data/FormatN.hs +++ b/src/Data/FormatN.hs @@ -139,7 +139,7 @@ prec :: Maybe Int -> Double -> Text prec n x | x < 0 = "-" <> prec n (- x) - | x == 0 = "0" + | x == 0 = decimal n (toRealFloat x') | x < 0.001 = expt n x | x > 1e6 = expt n x | otherwise = decimal n (toRealFloat x') @@ -206,7 +206,7 @@ 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 2 ticks' means use as much precision as is needed for them to be distinguished, but with at least 2 significant figures. +-- | 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 = diff --git a/src/Data/Path.hs b/src/Data/Path.hs --- a/src/Data/Path.hs +++ b/src/Data/Path.hs @@ -393,6 +393,8 @@ -- | convert from an ArcPosition spec to ArcCentroid spec. -- +-- See also [this](https://math.stackexchange.com/questions/55627/how-to-find-the-center-of-an-scaled-ellipse) +-- -- >>> 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} @@ -446,7 +448,7 @@ -- -- Compare this "elegent" definition from [stackexchange](https://math.stackexchange.com/questions/426150/what-is-the-general-equation-of-the-ellipse-that-is-not-in-the-origin-and-rotate) -- --- \[dfrac {((x-h)\cos(A)+(y-k)\sin(A))^2}{a^2}+\dfrac{((x-h) \sin(A)-(y-k) \cos(A))^2}{b^2}=1\] +-- \[\dfrac{((x-h)\cos(A)+(y-k)\sin(A))^2}{a^2}+\dfrac{((x-h) \sin(A)-(y-k) \cos(A))^2}{b^2}=1\] -- -- with the haskell code: -- @@ -657,7 +659,6 @@ -- >>> cubicBox (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) -- Rect 0.0 1.0 -0.20710678118654752 1.2071067811865475 -- --- ![Cubic]("other/cubic.svg") cubicBox :: CubicPosition Double -> Rect Double cubicBox p = space1 pts where