chart-svg 0.2.1 → 0.2.2
raw patch · 14 files changed
+730/−688 lines, 14 filesdep +containersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: containers
API changes (from Hackage documentation)
- Chart.Examples: barDataExample :: BarData
- Chart.Reanimate: daText :: () => TextStyle -> DrawAttributes
- Chart.Reanimate: fromFile :: FilePath -> IO Tree
- Chart.Reanimate: groupTreeA :: ReanimateConfig -> (Double -> ChartSvg) -> Double -> Tree
- Chart.Reanimate: reanimChartSvg :: ReanimateConfig -> (Double -> ChartSvg) -> IO ()
- Chart.Reanimate: scaleDA :: HasDrawAttributes s => Point Double -> s -> s
- Chart.Reanimate: toPixelRGBA8 :: Colour -> PixelRGBA8
- Chart.Reanimate: translateDA :: HasDrawAttributes s => Point Double -> s -> s
- Chart.Types: legendChart :: [(Annotation, Text)] -> LegendOptions -> [Chart Double]
- Chart.Types: legendEntry :: LegendOptions -> Annotation -> Text -> (Chart Double, Chart Double)
- Data.Colour: grey :: Colour
+ Chart.Reanimate: ChartReanimate :: [Tree] -> Rect Double -> Point Double -> ChartReanimate
+ Chart.Reanimate: [box] :: ChartReanimate -> Rect Double
+ Chart.Reanimate: [size] :: ChartReanimate -> Point Double
+ Chart.Reanimate: [trees] :: ChartReanimate -> [Tree]
+ Chart.Reanimate: data ChartReanimate
+ Chart.Reanimate: toTreeA :: ReanimateConfig -> (Double -> ChartSvg) -> Double -> Tree
+ Chart.Reanimate: treeFromFile :: FilePath -> IO Tree
+ Data.Colour: palette1_ :: [Colour]
- Chart.Bar: barChart :: BarOptions -> BarData -> (HudOptions, [Chart Double])
+ Chart.Bar: barChart :: BarOptions -> BarData -> ChartSvg
- Chart.Various: digitChart :: Text -> [UTCTime] -> [Double] -> (HudOptions, [Chart Double])
+ Chart.Various: digitChart :: Text -> [UTCTime] -> [Double] -> ChartSvg
- Chart.Various: histChart :: Text -> Maybe [Text] -> Range Double -> Int -> [Double] -> (HudOptions, [Chart Double])
+ Chart.Various: histChart :: Text -> Maybe [Text] -> Range Double -> Int -> [Double] -> ChartSvg
- Chart.Various: quantileChart :: Text -> [Text] -> [LineStyle] -> [AxisOptions] -> [[Double]] -> (HudOptions, [Chart Double])
+ Chart.Various: quantileChart :: Text -> [Text] -> [LineStyle] -> [AxisOptions] -> [[Double]] -> ChartSvg
- Chart.Various: quantileHistChart :: Text -> Maybe [Text] -> [Double] -> [Double] -> (HudOptions, [Chart Double])
+ Chart.Various: quantileHistChart :: Text -> Maybe [Text] -> [Double] -> [Double] -> ChartSvg
- Data.Colour: palette1 :: [Colour]
+ Data.Colour: palette1 :: Int -> Colour
Files
- app/reanimate-example.hs +11/−30
- chart-svg.cabal +9/−8
- src/Chart.hs +6/−20
- src/Chart/Bar.hs +33/−31
- src/Chart/Examples.hs +148/−140
- src/Chart/Reanimate.hs +138/−111
- src/Chart/Render.hs +35/−32
- src/Chart/Surface.hs +50/−49
- src/Chart/Types.hs +33/−35
- src/Chart/Various.hs +12/−14
- src/Data/Colour.hs +39/−15
- src/Data/FormatN.hs +4/−4
- src/Data/Path.hs +209/−198
- test/test.hs +3/−1
app/reanimate-example.hs view
@@ -1,36 +1,32 @@ #!/usr/bin/env stack -- stack runghc --package reanimate -{- | reanimate example--To run this example:--stack runghc --package reanimate app/reanimate-example.hs--and wait for the browser to open ...---}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE MonoLocalBinds #-} +-- | 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 NumHask.Prelude hiding (fold)-import Chart.Reanimate import Reanimate as Re main :: IO () main =- -- 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+ 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 =@@ -59,18 +55,3 @@ vennExample, arrowExample ]--sOpac :: ChartSvg -> Double -> ChartSvg-sOpac cs o =- scaleOpacChartSvg (Range 0 1) o .- (#hudOptions %~ colourHudOptions light) $- cs--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)-
chart-svg.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: chart-svg-version: 0.2.1+version: 0.2.2 synopsis: Charting library targetting SVGs. description: This package provides a charting library targetting SVG as the rendered output.@@ -8,15 +8,15 @@ == Usage . >>> import Chart- >>>- >>> let xs = [[(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)], [(0.0, 0.0), (3.0, 3.0)], [(0.5, 4.0), (0.5, 0)]] :: [[(Double, Double)]]- >>> let ls = fmap (PointXY . uncurry Point) <$> xs- >>> let anns = zipWith (\w c -> LineA (LineStyle w c Nothing Nothing Nothing Nothing)) [0.015, 0.03, 0.01] palette1- >>> let lineChart = zipWith Chart anns ls- >>> writeChartSvgHud "other/lineshud.svg" lineChart+ >>> :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 .+ + . See "Chart" for a broad overview of concepts, and "Chart.Examples" for a variety of practical examples. category: charts@@ -55,6 +55,7 @@ JuicyPixels >= 3.3 && < 3.4, attoparsec >= 0.13 && < 0.14, base >=4.7 && <5,+ containers >= 0.6 && < 0.7, cubicbezier >= 0.6 && < 0.7, foldl >= 1.4 && < 1.5, generic-lens >= 1.2 && < 3.0,
src/Chart.hs view
@@ -4,10 +4,12 @@ -- | A haskell Charting library targetting SVGs module Chart ( -- * Usage+ -- -- $setup -- * Overview+ -- -- $overview @@ -190,7 +192,7 @@ -- -- and an Annotation to describe representation of this data; three line styles with different colors and widths: ----- >>> let anns = zipWith (\w c -> LineA (LineStyle w c Nothing Nothing Nothing Nothing)) [0.015, 0.03, 0.01] palette1+-- >>> let anns = zipWith (\w c -> LineA (LineStyle w c Nothing Nothing Nothing Nothing)) [0.015, 0.03, 0.01] palette1_ -- -- and this is enough to create a Chart. --@@ -198,25 +200,9 @@ -- >>> :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.------ > writeChartSvg "other/lines.svg" lineExample------ ------ chart-svg takes inspiration from gaming heads-up display aesthetics. Chart decorations such as titles and axes are tools to interpret the landscape of data being viewed. They should be readily transparent, have sane defaults but be fully configurable.------ The library considers a hud to be a recipe for the creation of a 'Chart' list, but with the physical, on-the-page representation of the data in mind.------ Here is the line chart presented with default hud options.------ > writeChartSvgHud "other/lineshud.svg" lineChart------ ------ 'Hud' creation is a process of integrating the data domain and the physical representation. In the chart above, for example, the axis placement takes into account the physical attributes of the thick blue line which extends slightly beyond the abstract data range. The data area (the canvas) has also been extended so that a tick value (3.5 on the x-axis) can be included.+-- > writeChartSvg "other/line.svg" lineExample ----- Beyond this, there is nothing special about hud elements such as tick marks and titles, axes. Once they are created (with 'runHudWith') they themselves become charts.+--  -- -- $hud@@ -236,4 +222,4 @@ -- This process is encapsulated in 'runHud'. -- -- 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.-+--
src/Chart/Bar.hs view
@@ -19,6 +19,7 @@ where import Chart.Types+import Chart.Render import Control.Lens import Data.Colour import Data.FormatN@@ -39,25 +40,24 @@ -- | 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 (ho, cs) = barChart defaultBarOptions barDataExample+-- >>> let barExample = barChart defaultBarOptions barDataExample ----- > writeChartSvg "other/bar.svg" (ChartSvg defaultSvgOptions ho [] cs)+-- > writeChartSvg "other/bar.svg" barExample -- -- -data BarOptions- = BarOptions- { barRectStyles :: [RectStyle],- barTextStyles :: [TextStyle],- outerGap :: Double,- innerGap :: Double,- textGap :: Double,- textGapNegative :: Double,- displayValues :: Bool,- valueFormatN :: FormatN,- accumulateValues :: Bool,- barOrientation :: Orientation,- barHudOptions :: HudOptions- }+data BarOptions = BarOptions+ { barRectStyles :: [RectStyle],+ barTextStyles :: [TextStyle],+ outerGap :: Double,+ innerGap :: Double,+ textGap :: Double,+ textGapNegative :: Double,+ displayValues :: Bool,+ valueFormatN :: FormatN,+ accumulateValues :: Bool,+ barOrientation :: Orientation,+ barHudOptions :: HudOptions+ } deriving (Show, Eq, Generic) -- | The official bar options.@@ -93,8 +93,8 @@ ) ) where- gs = (\x -> RectStyle 0.002 x x) <$> palette1- ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04) <$> palette1+ gs = (\x -> RectStyle 0.002 x x) <$> palette1_+ ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04) <$> palette1_ -- | imagine a dataframe you get in other languages: --@@ -103,12 +103,11 @@ -- - maybe some row names -- -- - maybe some column names-data BarData- = BarData- { barData :: [[Double]],- barRowLabels :: Maybe [Text],- barColumnLabels :: Maybe [Text]- }+data BarData = BarData+ { barData :: [[Double]],+ barRowLabels :: Maybe [Text],+ barColumnLabels :: Maybe [Text]+ } deriving (Show, Eq, Generic) -- | Convert BarData to rectangles@@ -191,8 +190,9 @@ | isNothing (bd ^. #barRowLabels) = TickLabels $ pack . show <$> [0 .. (maxRows (bd ^. #barData) - 1)] | otherwise =- TickLabels $ take (maxRows (bd ^. #barData)) $- fromMaybe [] (bd ^. #barRowLabels) <> repeat ""+ TickLabels $+ take (maxRows (bd ^. #barData)) $+ fromMaybe [] (bd ^. #barRowLabels) <> repeat "" tickFirstAxis :: BarData -> [AxisOptions] -> [AxisOptions] tickFirstAxis _ [] = []@@ -205,14 +205,16 @@ | isNothing (bd ^. #barColumnLabels) = [] | otherwise = zip (RectA <$> bo ^. #barRectStyles) $ take (length (bd ^. #barData)) $ fromMaybe [] (bd ^. #barColumnLabels) <> repeat "" --- | A bar chart with hud trimmings.+-- | A bar chart. -- -- By convention only, the first axis (if any) is the bar axis.-barChart :: BarOptions -> BarData -> (HudOptions, [Chart Double])+barChart :: BarOptions -> BarData -> ChartSvg barChart bo bd =- ( bo ^. #barHudOptions & #hudLegend %~ fmap (second (const (barLegend bd bo))) & #hudAxes %~ tickFirstAxis bd . flipAllAxes (barOrientation bo),- bars bo bd <> bool [] (barTextCharts bo bd) (bo ^. #displayValues)- )+ 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))
src/Chart/Examples.hs view
@@ -1,7 +1,7 @@+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE NegativeLiterals #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -15,7 +15,6 @@ textExample, glyphsExample, lineExample,- barDataExample, barExample, waveExample, lglyphExample,@@ -40,7 +39,6 @@ import Chart import Control.Lens-import qualified Data.List as List import qualified Data.Text as Text import NumHask.Prelude hiding (lines) @@ -85,8 +83,8 @@ ropts :: [RectStyle] ropts =- [ blob (palette1 List.!! 1),- blob (palette1 List.!! 2)+ [ blob (palette1 1),+ blob (palette1 2) ] -- | line example@@ -103,7 +101,7 @@ -- >>> 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+-- >>> 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})] --@@ -117,12 +115,13 @@ lineExample :: ChartSvg lineExample = mempty- & #svgOptions . #chartAspect .~ CanvasAspect 1.5+ & #svgOptions . #chartAspect+ .~ CanvasAspect 1.5 & #hudOptions .~ exampleLineHudOptions- "Line Chart"- (Just "An example from chart-svg")- (Just (defaultLegendOptions, zip (LineA <$> lopts) ["hockey", "line", "vertical"]))+ "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 @@ -136,9 +135,9 @@ lopts :: [LineStyle] lopts =- [ defaultLineStyle & #color .~ (palette1 List.!! 0) & #width .~ 0.015,- defaultLineStyle & #color .~ (palette1 List.!! 1) & #width .~ 0.03,- defaultLineStyle & #color .~ (palette1 List.!! 2) & #width .~ 0.01+ [ 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@@ -169,7 +168,7 @@ textExample = mempty & #chartList .~ zipWith- Chart + Chart (TextA (defaultTextStyle & (#color .~ dark) & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) ((: []) . PointXY . snd <$> ts) where@@ -184,9 +183,10 @@ --  glyphsExample :: ChartSvg glyphsExample =- mempty &- #svgOptions . #svgHeight .~ 50 &- #chartList+ mempty+ & #svgOptions . #svgHeight+ .~ 50+ & #chartList .~ zipWith ( \(sh, bs) p -> Chart@@ -216,20 +216,18 @@ 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])))+ (Just (("row " <>) . pack . show <$> ([1 .. 11] :: [Int])))+ (Just (("column " <>) . pack . show <$> ([1 .. 2] :: [Int]))) -- | Bar chart example. -- --  barExample :: ChartSvg-barExample = mempty & #hudOptions .~ hc & #chartList .~ cs- where- (hc, cs) = barChart defaultBarOptions barDataExample+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. -----  +--  textLocalExample :: ChartSvg textLocalExample = mempty & #chartList@@ -267,7 +265,7 @@ . (#size .~ 0.08) $ defaultGlyphStyle )- palette1+ palette1_ [EllipseGlyph 1.5, SquareGlyph, CircleGlyph] -- | Glyph + Lines@@ -309,7 +307,7 @@ ( defaultGlyphStyle & #size .~ 0.01 & #borderSize .~ 0- & #color .~ palette1 List.!! 2+ & #color .~ palette1 2 ) ) (PointXY <$> [d])@@ -328,7 +326,7 @@ 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)]]+ .~ [Chart (TextA (defaultTextStyle & #rotation ?~ - pi / 4) ["text at (1,1) rotated by -(pi/4) radians"]) [PointXY (Point 1.0 1.0)]] -- | legend test --@@ -367,10 +365,10 @@ --  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) &- #hudOptions .~ defaultHudOptions+ 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)+ & #hudOptions .~ defaultHudOptions {- These were originally based on:@@ -386,36 +384,36 @@ -} vennSegs :: [Text] vennSegs =- [ "M0.0,-1.2320508075688774 A0.5 0.5 0.0 1 1 1.0,0.5 1.0 1.0 0.0 0 0 0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 0.0,-1.2320508075688774 Z",- "M-1.0,0.5 A0.5 0.5 0.0 1 0 1.0,0.5 1.0 1.0 0.0 0 1 0.0,0.5 1.0 1.0 0.0 0 1 -1.0,0.5 Z",- "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",- "M0.5,-0.3660254037844387 A1.0 1.0 0.0 0 1 1.0,0.5 1.0 1.0 0.0 0 1 0.0,0.5 1.0 1.0 0.0 0 0 0.5,-0.3660254037844387 Z",- "M0.0,0.5 A1.0 1.0 0.0 0 1 -1.0,0.5 1.0 1.0 0.0 0 1 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 0.0,0.5 Z",- "M0.0,-1.2320508075688774 A1.0 1.0 0.0 0 1 0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 1 0.0,-1.2320508075688774 Z",- "M0.5,-0.3660254037844387 A1.0 1.0 0.0 0 1 0.0,0.5 1.0 1.0 0.0 0 1 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 1 0.5,-0.3660254037844387 Z"- ]+ [ "M0.0,-1.2320508075688774 A0.5 0.5 0.0 1 1 1.0,0.5 1.0 1.0 0.0 0 0 0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 0.0,-1.2320508075688774 Z",+ "M-1.0,0.5 A0.5 0.5 0.0 1 0 1.0,0.5 1.0 1.0 0.0 0 1 0.0,0.5 1.0 1.0 0.0 0 1 -1.0,0.5 Z",+ "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",+ "M0.5,-0.3660254037844387 A1.0 1.0 0.0 0 1 1.0,0.5 1.0 1.0 0.0 0 1 0.0,0.5 1.0 1.0 0.0 0 0 0.5,-0.3660254037844387 Z",+ "M0.0,0.5 A1.0 1.0 0.0 0 1 -1.0,0.5 1.0 1.0 0.0 0 1 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 0.0,0.5 Z",+ "M0.0,-1.2320508075688774 A1.0 1.0 0.0 0 1 0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 1 0.0,-1.2320508075688774 Z",+ "M0.5,-0.3660254037844387 A1.0 1.0 0.0 0 1 0.0,0.5 1.0 1.0 0.0 0 1 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 1 0.5,-0.3660254037844387 Z"+ ] -- | Compound path example. -- --  pathExample :: ChartSvg pathExample =- mempty &- #chartList .~ [path', c0] &- #hudOptions .~ defaultHudOptions &- #svgOptions %~- ((#outerPad ?~ 0.1) .- (#chartAspect .~ ChartAspect))+ mempty+ & #chartList .~ [path', c0]+ & #hudOptions .~ defaultHudOptions+ & #svgOptions+ %~ ( (#outerPad ?~ 0.1)+ . (#chartAspect .~ ChartAspect)+ ) where ps =- [- (StartI, Point 0 0),+ [ (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)+ (ArcI (ArcInfo (Point 1 1) (- pi / 6) False False), Point 0 0) ]- 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)+ 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) -- | ellipse example@@ -423,41 +421,37 @@ -- (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) 0 True True)) -- -- --- ellipseExample :: ChartSvg ellipseExample =- mempty &- #chartList .~ [ell, ellFull, c0, bbox, xradii, yradii] &- #hudOptions .~ defaultHudOptions &- #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect))+ 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)+ 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 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])+ 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)])+ 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 -- -- ------ There is a bug for rotated ellipses. See 'problematic2' for scaling issue when phi is non-zero.--- arcExample :: ChartSvg arcExample =- mempty &- #chartList .~ [arc, ell, c0, bbox] &- #hudOptions .~ defaultHudOptions &- #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ FixedAspect 1))+ 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 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])+ 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)] @@ -466,67 +460,79 @@ --  arcFlagsExample :: ChartSvg arcFlagsExample =- mempty &- #chartList .~- vert 0.02- [hori 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]],- 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]]- ] &- #hudOptions .~ mempty &- #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect))+ mempty+ & #chartList+ .~ vert+ 0.02+ [ hori+ 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]+ ],+ 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]+ ]+ ]+ & #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]+ mempty+ & #hudOptions .~ defaultHudOptions+ & #svgOptions . #chartAspect .~ UnadjustedAspect+ & #chartList .~ [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])+ 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 :: ChartSvg quadExample =- mempty &- #chartList .~ [path', curve, c0, bbox] &- #hudOptions .~ defaultHudOptions &- #svgOptions %~ ((#outerPad ?~ 0.05) . (#chartAspect .~ ChartAspect))+ 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 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])+ 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)] @@ -535,41 +541,43 @@ --  cubicExample :: ChartSvg cubicExample =- mempty &- #chartList .~ [path', curve, c0, bbox] &- #hudOptions .~ mempty &- #svgOptions %~ ((#outerPad ?~ 0.02) . (#chartAspect .~ ChartAspect))+ mempty+ & #chartList .~ [path', curve, c0, bbox]+ & #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 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])+ 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)] -- | The common way to create a surface chart is usually a grid over a function. -- -- --- surfaceExample :: ChartSvg surfaceExample =- mempty &- #hudList .~ hs &- #chartList .~ cs &- #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp)+ 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 &- #soGrain .~ grain &- #soRange .~ r &- #soStyle . #surfaceColors .~ take 6 palette1)- (defaultSurfaceLegendOptions t &- #sloStyle . #surfaceColors .~ take 6 palette1)+ surfacefl+ f+ ( defaultSurfaceOptions+ & #soGrain .~ grain+ & #soRange .~ r+ & #soStyle . #surfaceColors .~ (palette1 <$> [0 .. 5])+ )+ ( defaultSurfaceLegendOptions t+ & #sloStyle . #surfaceColors .~ (palette1 <$> [0 .. 5])+ ) -- | arrow example --@@ -578,25 +586,25 @@ --  arrowExample :: ChartSvg arrowExample =- mempty &- #hudOptions .~ (defaultHudOptions & #hudAxes %~ fmap (#axisTick . #ltick .~ Nothing)) &- #chartList .~ ((\p -> chart (tail . f $ p) (angle . f $ p) p) <$> ps) &- #svgOptions .~ defaultSvgOptions+ mempty+ & #hudOptions .~ (defaultHudOptions & #hudAxes %~ fmap (#axisTick . #ltick .~ Nothing))+ & #chartList .~ ((\p -> chart (tail . f $ p) (angle . f $ p) p) <$> ps)+ & #svgOptions .~ defaultSvgOptions where 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 .~ dark &- #rotation .~ Just r' &- #shape .~ arrow+ defaultGlyphStyle+ & #borderSize .~ 0.05+ & #size .~ s+ & #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.05 . 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) @@ -608,7 +616,7 @@ -- > 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. writeAllExamples :: IO ()
src/Chart/Reanimate.hs view
@@ -2,101 +2,74 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | Integration of reanimate and chart-svg module Chart.Reanimate- ( ReanimateConfig(..),+ ( ReanimateConfig (..), defaultReanimateConfig,- reanimChartSvg, animChartSvg,+ ChartReanimate (..), chartReanimate,- groupTreeA,+ toTreeA, tree,- toPixelRGBA8,- daText,- fromFile,- translateDA,- scaleDA,+ treeFromFile, ) where -import Chart as C hiding (transform, Line, renderChartsWith)+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 Graphics.SvgTree as Svg hiding (Text)+import qualified Graphics.SvgTree.PathParser as Svg import Linear.V2 import NumHask.Prelude hiding (fold) import Reanimate as Re-import qualified Graphics.SvgTree.PathParser as Svg-import Graphics.SvgTree as Svg hiding (Text) +-- | 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)+ }+ deriving (Eq, Show, Generic) +-- | defaultReanimateConfig :: ReanimateConfig defaultReanimateConfig = ReanimateConfig 5 (Just "black") (Just ["Arial", "Helvetica", "sans-serif"]) (Just FontStyleNormal) AlignxMinYMin -reanimChartSvg :: ReanimateConfig -> (Double -> ChartSvg) -> IO ()-reanimChartSvg cfg cs =- reanimate $ animChartSvg cfg cs-+-- | Animate a ChartSvg animation. animChartSvg :: ReanimateConfig -> (Double -> ChartSvg) -> Animation animChartSvg cfg cs =- mkAnimation (view #duration cfg) $ groupTreeA cfg cs+ mkAnimation (view #duration cfg) $ toTreeA cfg cs 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)--data ChartReanimate = ChartReanimate { trees :: [Tree], box :: Rect Double, size :: C.Point Double} deriving (Eq, Show, Generic)---- | 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)- ]--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; }")+ mempty+ & maybe+ id+ (\x -> fontFamily .~ Last (Just (fmap unpack x)))+ (view #globalFontFamily cfg)+ . maybe+ id+ (\x -> fontStyle .~ Last (Just x))+ (view #globalFontStyle cfg) -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+-- | 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@@ -105,6 +78,44 @@ 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 =@@ -159,10 +170,12 @@ (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))+ ( 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@@ -181,13 +194,15 @@ 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))+ 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))@@ -208,24 +223,25 @@ GroupTree (drawAttributes %~ (<> da') $ groupChildren .~ tree' $ defaultSvg) -- * DrawAttribute computations+ daRect :: RectStyle -> DrawAttributes daRect o =- mempty &- (strokeWidth .~ Last (Just $ Num (o ^. #borderSize))) &- (strokeColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #borderColor))) &- (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) &- (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) &- (fillOpacity ?~ realToFrac (opac $ o ^. #color))+ mempty+ & (strokeWidth .~ Last (Just $ Num (o ^. #borderSize)))+ & (strokeColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #borderColor)))+ & (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor))+ & (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color)))+ & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) daText :: () => TextStyle -> DrawAttributes daText o =- mempty &- (fontSize .~ Last (Just $ Num (o ^. #size))) &- (strokeWidth .~ Last (Just $ Num 0)) &- (strokeColor .~ Last (Just FillNone)) &- (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) &- (fillOpacity ?~ realToFrac (opac $ o ^. #color)) &- (textAnchor .~ Last (Just (toTextAnchor $ o ^. #anchor)))+ mempty+ & (fontSize .~ Last (Just $ Num (o ^. #size)))+ & (strokeWidth .~ Last (Just $ Num 0))+ & (strokeColor .~ Last (Just FillNone))+ & (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color)))+ & (fillOpacity ?~ realToFrac (opac $ o ^. #color))+ & (textAnchor .~ Last (Just (toTextAnchor $ o ^. #anchor))) where toTextAnchor :: Anchor -> Svg.TextAnchor toTextAnchor AnchorMiddle = TextAnchorMiddle@@ -234,30 +250,39 @@ daGlyph :: GlyphStyle -> DrawAttributes daGlyph o =- mempty &- (strokeWidth .~ Last (Just $ Num (o ^. #borderSize))) &- (strokeColor .~- Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #borderColor))) &- (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) &- (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) &- (fillOpacity ?~ realToFrac (opac $ o ^. #color)) &- maybe id (\(C.Point x y) -> transform ?~ [Translate x (-y)]) (o ^. #translate)+ mempty+ & (strokeWidth .~ Last (Just $ Num (o ^. #borderSize)))+ & ( strokeColor+ .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #borderColor))+ )+ & (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor))+ & (fillColor .~ Last (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 .~ Last (Just $ Num (o ^. #width))) &- (strokeColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) &- (strokeOpacity ?~ realToFrac (opac $ o ^. #color)) &- (fillColor .~ Last (Just FillNone)) &- maybe id (\x -> strokeLineCap .~ Last (Just $ fromLineCap' x))- (o ^. #linecap) &- maybe id (\x -> strokeLineJoin .~ Last (Just $ fromLineJoin' x))- (o ^. #linejoin) &- maybe id (\x -> strokeOffset .~ Last (Just $ Num x))- (o ^. #dashoffset) &- maybe id (\xs -> strokeDashArray .~ Last (Just (Num <$> xs)))- (o ^. #dasharray)+ mempty+ & (strokeWidth .~ Last (Just $ Num (o ^. #width)))+ & (strokeColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color)))+ & (strokeOpacity ?~ realToFrac (opac $ o ^. #color))+ & (fillColor .~ Last (Just FillNone))+ & maybe+ id+ (\x -> strokeLineCap .~ Last (Just $ fromLineCap' x))+ (o ^. #linecap)+ & maybe+ id+ (\x -> strokeLineJoin .~ Last (Just $ fromLineJoin' x))+ (o ^. #linejoin)+ & maybe+ id+ (\x -> strokeOffset .~ Last (Just $ Num x))+ (o ^. #dashoffset)+ & maybe+ id+ (\xs -> strokeDashArray .~ Last (Just (Num <$> xs)))+ (o ^. #dasharray) fromLineCap' :: LineCap -> Svg.Cap fromLineCap' LineCapButt = CapButt@@ -271,13 +296,15 @@ daPath :: PathStyle -> DrawAttributes daPath o =- mempty &- (strokeWidth .~ Last (Just $ Num (o ^. #borderSize))) &- (strokeColor .~ Last- (Just $ ColorRef (toPixelRGBA8 $ o ^. #borderColor))) &- (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor)) &- (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color))) &- (fillOpacity ?~ realToFrac (opac $ o ^. #color))+ mempty+ & (strokeWidth .~ Last (Just $ Num (o ^. #borderSize)))+ & ( strokeColor+ .~ Last+ (Just $ ColorRef (toPixelRGBA8 $ o ^. #borderColor))+ )+ & (strokeOpacity ?~ realToFrac (opac $ o ^. #borderColor))+ & (fillColor .~ Last (Just $ ColorRef (toPixelRGBA8 $ o ^. #color)))+ & (fillOpacity ?~ realToFrac (opac $ o ^. #color)) -- * svg primitives @@ -299,7 +326,7 @@ 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))]+ r = [Rotate (- a * 180 / pi) (Just (x, - y))] -- | A DrawAttributes to translate by a Point. translateDA :: (HasDrawAttributes s) => C.Point Double -> s -> s@@ -321,7 +348,7 @@ . (rectHeight .~ Just (Num (w - y))) -- | import a Tree from a file-fromFile :: FilePath -> IO Tree-fromFile fp = do+treeFromFile :: FilePath -> IO Tree+treeFromFile fp = do t <- Svg.loadSvgFile fp pure $ maybe Svg.None Re.unbox t
src/Chart/Render.hs view
@@ -38,26 +38,25 @@ where import Chart.Types-import Data.Colour-import Data.Path import Control.Lens hiding (transform)+import Data.Colour import Data.Generics.Labels ()+import Data.Path+import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy import Lucid-import qualified Lucid.Base as Lucid import Lucid.Base+import qualified Lucid.Base as Lucid import NumHask.Prelude import NumHask.Space as NH hiding (Element)-import qualified Data.Text as Text -- | Specification of a chart for rendering to SVG-data ChartSvg- = ChartSvg- { svgOptions :: SvgOptions,- hudOptions :: HudOptions,- hudList :: [Hud Double],- chartList :: [Chart Double]- }+data ChartSvg = ChartSvg+ { svgOptions :: SvgOptions,+ hudOptions :: HudOptions,+ hudList :: [Hud Double],+ chartList :: [Chart Double]+ } deriving (Generic) instance Semigroup ChartSvg where@@ -68,6 +67,7 @@ mempty = ChartSvg defaultSvgOptions mempty [] [] -- * rendering+ -- | @svg@ element + svg 2 attributes svg2Tag :: Term [Attribute] (s -> t) => s -> t svg2Tag m =@@ -81,8 +81,8 @@ renderToSvg csso (Point w' h') (Rect x z y w) cs = with ( svg2Tag- ( cssText csso <>- mconcat (svg <$> cs)+ ( cssText csso+ <> mconcat (svg <$> cs) ) ) [ width_ (show w'),@@ -105,20 +105,22 @@ 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')+ 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)+ 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)+ size' = Point ((so ^. #svgHeight) / h * w) (so ^. #svgHeight) penult = case so ^. #chartAspect of FixedAspect _ -> styleBoxesS cs CanvasAspect _ -> dataBoxesS cs@@ -136,14 +138,16 @@ 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+ & runHud penult [chartAspectHud (so ^. #chartAspect)]+ & maybe+ id+ (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad)))+ (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)+ size' = Point ((so ^. #svgHeight) / h * w) (so ^. #svgHeight) penult = case so ^. #chartAspect of FixedAspect _ -> styleBoxesS cs CanvasAspect _ -> dataBoxesS cs@@ -362,11 +366,11 @@ term "stroke" (toHex $ o ^. #color), term "stroke-opacity" (show $ opac $ o ^. #color), term "fill" "none"- ] <>- maybe [] (\x -> [term "stroke-linecap" (fromLineCap x)]) (o ^. #linecap) <>- maybe [] (\x -> [term "stroke-linejoin" (fromLineJoin x)]) (o ^. #linejoin) <>- maybe [] (\x -> [term "stroke-dasharray" (fromDashArray x)]) (o ^. #dasharray) <>- maybe [] (\x -> [term "stroke-dashoffset" (show x)]) (o ^. #dashoffset)+ ]+ <> maybe [] (\x -> [term "stroke-linecap" (fromLineCap x)]) (o ^. #linecap)+ <> maybe [] (\x -> [term "stroke-linejoin" (fromLineJoin x)]) (o ^. #linejoin)+ <> maybe [] (\x -> [term "stroke-dasharray" (fromDashArray x)]) (o ^. #dasharray)+ <> maybe [] (\x -> [term "stroke-dashoffset" (show x)]) (o ^. #dashoffset) -- | PathStyle to Attributes attsPath :: PathStyle -> [Lucid.Attribute]@@ -390,10 +394,9 @@ -- - from counter-clockwise is a positive rotation to clockwise is positive -- -- - flip y dimension--- toRotateText :: Double -> Point Double -> Text toRotateText r (Point x y) =- "rotate(" <> show (-r*180/pi) <> ", " <> show x <> ", " <> show (- y) <> ")"+ "rotate(" <> show (- r * 180 / pi) <> ", " <> show x <> ", " <> show (- y) <> ")" toScaleText :: Double -> Text toScaleText x =
src/Chart/Surface.hs view
@@ -33,16 +33,14 @@ import NumHask.Space -- | Options for a Surface chart.----data SurfaceOptions- = SurfaceOptions- { -- | surface style- soStyle :: SurfaceStyle,- -- | The grain or granularity of the chart- soGrain :: Point Int,- -- | Chart range- soRange :: Rect Double- }+data SurfaceOptions = SurfaceOptions+ { -- | surface style+ soStyle :: SurfaceStyle,+ -- | The grain or granularity of the chart+ soGrain :: Point Int,+ -- | Chart range+ soRange :: Rect Double+ } deriving (Show, Eq, Generic) -- | official style@@ -56,27 +54,25 @@ -- 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}} -- -- -data SurfaceStyle- = SurfaceStyle- { -- | list of colours to interpolate between.- surfaceColors :: [Colour],- surfaceRectStyle :: RectStyle- }+data SurfaceStyle = SurfaceStyle+ { -- | list of colours to interpolate between.+ surfaceColors :: [Colour],+ surfaceRectStyle :: RectStyle+ } deriving (Show, Eq, Generic) -- | The official surface style. defaultSurfaceStyle :: SurfaceStyle defaultSurfaceStyle =- SurfaceStyle (take 2 palette1) (blob dark)+ SurfaceStyle (take 2 palette1_) (blob dark) -- | Main surface data elements-data SurfaceData- = SurfaceData- { -- | XY Coordinates of surface.- surfaceRect :: Rect Double,- -- | Surface colour.- surfaceColor :: Colour- }+data SurfaceData = SurfaceData+ { -- | XY Coordinates of surface.+ surfaceRect :: Rect Double,+ -- | Surface colour.+ surfaceColor :: Colour+ } deriving (Show, Eq, Generic) -- | surface chart without any hud trimmings@@ -120,18 +116,16 @@ (cs, dr) = surfacef f po -- | Legend specialization for a surface chart.----data SurfaceLegendOptions- = SurfaceLegendOptions- { sloStyle :: SurfaceStyle,- sloTitle :: Text,- -- | Width of the legend glyph- sloWidth :: Double,- -- | Resolution of the legend glyph- sloResolution :: Int,- sloAxisOptions :: AxisOptions,- sloLegendOptions :: LegendOptions- }+data SurfaceLegendOptions = SurfaceLegendOptions+ { sloStyle :: SurfaceStyle,+ sloTitle :: Text,+ -- | Width of the legend glyph+ sloWidth :: Double,+ -- | Resolution of the legend glyph+ sloResolution :: Int,+ sloAxisOptions :: AxisOptions,+ sloLegendOptions :: LegendOptions+ } deriving (Eq, Show, Generic) surfaceAxisOptions :: AxisOptions@@ -166,7 +160,6 @@ & #legendFrame .~ Nothing -- | Creation of the classical heatmap glyph within a legend context.--- surfaceLegendChart :: Range Double -> SurfaceLegendOptions -> [Chart Double] surfaceLegendChart dataRange l = padChart (l ^. #sloLegendOptions . #outerPad)@@ -176,26 +169,35 @@ a = makeSurfaceTick l pchart pchart | l ^. #sloLegendOptions . #lplace == PlaceBottom- || l ^. #sloLegendOptions . #lplace == PlaceTop = vertGlyph+ || l ^. #sloLegendOptions . #lplace == 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] vertGlyph = zipWith- (\r c -> Chart (RectA $ blob c) [RectXY r])- ((\xr -> Ranges xr (Range 0 (l ^. #sloWidth))) <$> gridSpace dataRange- (l ^. #sloResolution))- ((\x -> blends x (l ^. #sloStyle . #surfaceColors)) <$>- grid MidPos (Range 0 1) (l ^. #sloResolution))+ (\r c -> Chart (RectA $ blob c) [RectXY r])+ ( (\xr -> Ranges xr (Range 0 (l ^. #sloWidth)))+ <$> gridSpace+ dataRange+ (l ^. #sloResolution)+ )+ ( (\x -> blends x (l ^. #sloStyle . #surfaceColors))+ <$> grid MidPos (Range 0 1) (l ^. #sloResolution)+ ) horiGlyph :: [Chart Double] horiGlyph = zipWith- (\r c -> Chart (RectA $ blob c) [RectXY r])- ((\yr -> Ranges (Range 0 (l ^. #sloWidth)) yr) <$> gridSpace dataRange- (l ^. #sloResolution))- ((\x -> blends x (l ^. #sloStyle . #surfaceColors)) <$>- grid MidPos (Range 0 1) (l ^. #sloResolution))+ (\r c -> Chart (RectA $ blob c) [RectXY r])+ ( (\yr -> Ranges (Range 0 (l ^. #sloWidth)) yr)+ <$> gridSpace+ dataRange+ (l ^. #sloResolution)+ )+ ( (\x -> blends x (l ^. #sloStyle . #surfaceColors))+ <$> grid MidPos (Range 0 1) (l ^. #sloResolution)+ ) isHori :: SurfaceLegendOptions -> Bool isHori l =@@ -216,4 +218,3 @@ ] ) phud = runHudWith r' r hs pchart-
src/Chart/Types.hs view
@@ -111,8 +111,6 @@ LegendOptions (..), defaultLegendOptions, legendHud,- legendChart,- legendEntry, Orientation (..), fromOrientation, toOrientation,@@ -148,7 +146,6 @@ import Data.Colour import Data.FormatN import Data.Generics.Labels ()-import qualified Data.List as List import Data.Path import qualified Data.Text as Text import Data.Time@@ -221,7 +218,7 @@ scaleOpacAnn _ BlankA = BlankA scaleOpac :: Double -> Colour -> Colour-scaleOpac x (Colour r g b o') = Colour r g b (o'*x)+scaleOpac x (Colour r g b o') = Colour r g b (o' * x) -- | select a main colour colourAnn :: Colour -> Annotation -> Annotation@@ -257,7 +254,7 @@ -- | the style defaultRectStyle :: RectStyle-defaultRectStyle = RectStyle 0.01 (palette1 List.!! 1) (palette1 List.!! 2)+defaultRectStyle = RectStyle 0.01 (palette1 1) (palette1 2) -- | solid rectangle, no border --@@ -346,8 +343,8 @@ defaultGlyphStyle = GlyphStyle 0.03- (palette1 List.!! 1)- (palette1 List.!! 2)+ (palette1 1)+ (palette1 2) 0.003 SquareGlyph Nothing@@ -452,7 +449,7 @@ -- | the style defaultPathStyle :: PathStyle defaultPathStyle =- PathStyle 0.01 (palette1 List.!! 1) (palette1 List.!! 2)+ 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@@ -656,32 +653,33 @@ -- | 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))))+ 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))))+ 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)+mix (Colour r g b o') (Colour _ _ _ o) = Colour r g b (o' * o) -- | The official hud canvas defaultCanvas :: RectStyle@@ -752,8 +750,8 @@ defaultTitle txt = Title txt- ( defaultTextStyle &- #size .~ 0.12+ ( defaultTextStyle+ & #size .~ 0.12 ) PlaceTop AnchorMiddle@@ -866,7 +864,7 @@ } deriving (Show, Eq, Generic) --- | The official legend options +-- | The official legend options defaultLegendOptions :: LegendOptions defaultLegendOptions = LegendOptions@@ -1642,21 +1640,21 @@ -- | useful for testing bounding boxes frameAllCharts :: [Chart Double] -> [Chart Double]-frameAllCharts cs = mconcat $ frameChart (border 0.004 light) 0.004 . (:[]) <$> cs+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+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)+ 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+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)
src/Chart/Various.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -36,7 +35,6 @@ import Chart import Control.Lens import qualified Data.HashMap.Strict as HashMap-import Data.List ((!!)) import Data.Time (UTCTime (..)) import NumHask.Prelude hiding (fold) import NumHask.Space@@ -89,7 +87,7 @@ -- | Can of the main palette stdLines :: Double -> [LineStyle]-stdLines w = (\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> palette1+stdLines w = (\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> palette1_ -- | Legend template for a line chart. lineLegend :: Double -> [Text] -> [Colour] -> (LegendOptions, [(Annotation, Text)])@@ -97,7 +95,7 @@ ( defaultLegendOptions & #ltext . #size .~ 0.3 & #lplace .~ PlaceBottom- & #legendFrame .~ Just (RectStyle 0.02 (palette1 !! 5) (palette1 !! 4)),+ & #legendFrame .~ Just (RectStyle 0.02 (palette1 5) (palette1 4)), zipWith (\a r -> (LineA a, r)) ((\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> cs)@@ -129,7 +127,7 @@ -- | GlyphStyle palette gpaletteStyle :: Double -> [GlyphStyle]-gpaletteStyle s = zipWith (\c g -> defaultGlyphStyle & #size .~ s & #color .~ c & #shape .~ fst g & #borderSize .~ snd g) palette1 gpalette+gpaletteStyle s = zipWith (\c g -> defaultGlyphStyle & #size .~ s & #color .~ c & #shape .~ fst g & #borderSize .~ snd g) palette1_ gpalette -- | Glyph palette gpalette :: [(GlyphShape, Double)]@@ -154,9 +152,9 @@ [LineStyle] -> [AxisOptions] -> [[Double]] ->- (HudOptions, [Chart Double])+ ChartSvg quantileChart title names ls as xs =- (hudOptions, chart')+ mempty & #hudOptions .~ hudOptions & #chartList .~ chart' where hudOptions = defaultHudOptions@@ -194,9 +192,9 @@ Text -> [UTCTime] -> [Double] ->- (HudOptions, [Chart Double])+ ChartSvg digitChart title utcs xs =- (hudOptions, [c])+ mempty & #hudOptions .~ hudOptions & #chartList .~ [c] where hudOptions = defaultHudOptions@@ -226,10 +224,10 @@ Range Double -> Int -> [Double] ->- (HudOptions, [Chart Double])+ ChartSvg histChart title names r g xs = barChart defaultBarOptions barData- & first (#hudTitles .~ [defaultTitle title])+ & (#hudOptions . #hudTitles .~ [defaultTitle title]) where barData = BarData [hr] names Nothing hcuts = grid OuterPos r g@@ -246,8 +244,9 @@ [Double] -> -- | quantile values [Double] ->- (HudOptions, [Chart Double])-quantileHistChart title names qs vs = (hudOptions, [chart'])+ ChartSvg+quantileHistChart title names qs vs =+ mempty & #hudOptions .~ hudOptions & #chartList .~ [chart'] where hudOptions = defaultHudOptions@@ -321,4 +320,3 @@ -- | 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 ..]-
src/Data/Colour.hs view
@@ -28,28 +28,29 @@ fromHex, unsafeFromHex, palette1,+ palette1_, transparent, black, white, light, dark,- grey, ) where import qualified Data.Attoparsec.Text as A import Data.FormatN import Data.Generics.Labels ()+import qualified Data.List as List import qualified Data.Text as Text import Graphics.Color.Model import NumHask.Prelude as NHP import qualified Prelude as P -- | Wrapper for 'Color'.-newtype Colour =- Colour'+newtype Colour = Colour' { color' :: Color (Alpha RGB) Double- } deriving (Eq, Generic)+ }+ deriving (Eq, Generic) -- | Constructor pattern. pattern Colour :: Double -> Double -> Double -> Double -> Colour@@ -99,11 +100,11 @@ -- True -- -- >>> blends 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white]--- RGBA 0.16 0.48 0.64 0.60+-- Colour 0.36 0.68 0.84 0.60 blends :: Double -> [Colour] -> Colour blends _ [] = light blends _ [c] = c-blends x cs = blend r (cs P.!! i) (cs P.!! (i+1))+blends x cs = blend r (cs P.!! i) (cs P.!! (i + 1)) where l = length cs - 1 x' = x * fromIntegral l@@ -159,9 +160,16 @@ i2d :: Int -> Char i2d i = chr (ord '0' + i) --- | some RGBA colors-palette1 :: [Colour]-palette1 =+-- | select a Colour from the palette+--+-- >>> palette1 0+-- Colour 0.69 0.35 0.16 1.00+palette1 :: Int -> Colour+palette1 x = cycle palette1_ List.!! x++-- | finite list of Colours+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,@@ -178,26 +186,42 @@ ] -- |+--+-- >>> black+-- Colour 0.00 0.00 0.00 1.00 black :: Colour black = Colour 0 0 0 1 -- |+--+-- >>> white+-- Colour 0.99 0.99 0.99 1.00 white :: Colour white = Colour 0.99 0.99 0.99 1 -- |+--+-- For lighter huds against a dark background ...+--+-- > colourHudOptions light defaultHudOptions+--+-- >>> light+-- Colour 0.94 0.94 0.94 1.00 light :: Colour light = Colour 0.94 0.94 0.94 1 -- |+--+-- dark is hardcoded in most of the default options.+--+-- >>> dark+-- Colour 0.05 0.05 0.05 1.00 dark :: Colour dark = Colour 0.05 0.05 0.05 1 -grey :: Colour-grey = Colour 0.5 0.5 0.5 1---- |+-- | zero opacity black+--+-- >>> transparent+-- Colour 0.00 0.00 0.00 0.00 transparent :: Colour transparent = Colour 0 0 0 0--
src/Data/FormatN.hs view
@@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}@@ -34,8 +35,8 @@ ) where +import Data.Containers.ListUtils (nubOrd) import Data.Generics.Labels ()-import Data.List (nub) import Data.Scientific import qualified Data.Text as Text import NumHask.Prelude@@ -118,7 +119,7 @@ (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)+ + 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.@@ -214,7 +215,7 @@ where precLoop f' n xs' = let s = f' (Just n) <$> xs'- in if s == nub s || n > 4+ in if s == nubOrd s || n > 4 then s else precLoop f' (n + 1) xs' @@ -235,4 +236,3 @@ where f' = formatN f x s' = show x-
src/Data/Path.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NegativeLiterals #-}-{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | SVG path manipulation module Data.Path@@ -48,21 +48,22 @@ toSingletonArc, pathBoxes, pathBox,- ) where+ )+where -import qualified Graphics.SvgTree as SvgTree-import Graphics.SvgTree (PathCommand (..), Origin(..))-import Graphics.SvgTree.PathParser-import qualified Data.Attoparsec.Text as A-import qualified Data.Text as Text-import NumHask.Space-import NumHask.Prelude hiding (rotate)-import qualified Linear import qualified Control.Foldl as L import Control.Lens hiding ((...))+import qualified Data.Attoparsec.Text as A+import Data.FormatN import Data.Generics.Labels ()+import qualified Data.Text as Text import qualified Geom2D.CubicBezier as B-import Data.FormatN+import Graphics.SvgTree (Origin (..), PathCommand (..))+import qualified Graphics.SvgTree as SvgTree+import Graphics.SvgTree.PathParser+import qualified Linear+import NumHask.Prelude hiding (rotate)+import NumHask.Space -- $setup -- >>> :set -XRebindableSyntax@@ -78,7 +79,6 @@ -- [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 --@@ -87,23 +87,22 @@ -- [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 = either (const []) id $ A.parseOnly pathParser t --- | To fit in with the requirements of the 'Chart' interface, path instructions need to be decontructed into:+-- | 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'. ----- A lot of detail rides on whether the PathInfo is invariant to affine transformations of the 'Chart.Types.xys' points. Cubic and quadratic bezier paths need to be re-projected whenever 'Chart.Types.xys' are re-projected. Arcs are problematic (See 'Chart.Examples.problematic2' & 'Chart.Examples.problematic2').-data PathInfo a =- StartI |- LineI |- CubicI (Point a) (Point a) |- QuadI (Point a) |- ArcI (ArcInfo a)+-- 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) -- | convert from a path info, start point, end point triple to a path text clause.@@ -129,37 +128,44 @@ -- - 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 (StartI, p) = "M " <> pp p+toPathAbsolute (LineI, p) = "L " <> pp p toPathAbsolute (CubicI c1 c2, next) =- "C " <>- pp c1 <> " " <>- pp c2 <> " " <>- pp next+ "C "+ <> pp c1+ <> " "+ <> pp c2+ <> " "+ <> pp next toPathAbsolute (QuadI control, next) =- "Q " <>- pp control <> " " <>- pp next+ "Q "+ <> pp control+ <> " "+ <> pp next toPathAbsolute (ArcI (ArcInfo (Point x y) phi' l sw), x2) =- "A " <>- show x <> " " <>- show y <> " " <>- show (-phi' * 180 / pi) <> " " <>- bool "0" "1" l <> " " <>- bool "0" "1" sw <> " " <>- pp x2+ "A "+ <> show x+ <> " "+ <> show y+ <> " "+ <> 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))+ 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@@ -167,33 +173,32 @@ where done = Text.intercalate " " . reverse begin = []- step ts (info, next) = toPathAbsolute (info, next):ts+ 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 (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)]+ EllipticalArc OriginAbsolute [(rx, ry, phi', l, sw, toV2 p)] toV2 :: Point a -> Linear.V2 a toV2 (Point x y) = Linear.V2 x y -data StateInfo =- StateInfo- {- -- | previous position+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)+ }+ deriving (Eq, Show, Generic) stateInfo0 :: StateInfo stateInfo0 = StateInfo zero zero zero@@ -203,125 +208,128 @@ -- 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)+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)+ 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)+ 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)+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)+ 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+ 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+ 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+ 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+ 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)+ 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'+ 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)+ 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'+ 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)+ 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'+ 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)+ 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'+ 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)+ 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'+ 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)+ ( s+ & #cur .~ x2+ & #infoControl .~ c1,+ (QuadI c1, x2) : p+ ) toInfo s (QuadraticBezier OriginRelative xs) =- L.fold (L.Fold step (s,[]) (second reverse)) 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)+ 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'+ 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)+ ( 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'+ 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)+ ( s+ & #cur .~ (x2 + s ^. #cur)+ & #infoControl .~ (s ^. #cur - (s ^. #infoControl - s ^. #cur)),+ (QuadI (s ^. #cur - (s ^. #infoControl - s ^. #cur)), x2 + s ^. #cur) : p+ ) toInfo s (EllipticalArc OriginAbsolute xs) =- L.fold (L.Fold step (s,[]) (second reverse)) 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)+ 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'+ 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)+ 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)+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)+ 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)]@@ -348,14 +356,13 @@ -- | 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 ((StartI, s) : (ArcI i, e) : _) = Just $ ArcPosition s e i toSingletonArc _ = Nothing -- * Arc types+ -- | Information about an individual arc path.----data ArcInfo a =- ArcInfo+data ArcInfo a = ArcInfo { -- | ellipse radii radii :: Point a, -- | rotation of the ellipse. positive means counter-clockwise (which is different to SVG).@@ -363,22 +370,21 @@ large :: Bool, -- | sweep means clockwise clockwise :: Bool- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | Specification of an Arc using positional referencing as per SVG standard.-data ArcPosition a =- ArcPosition+data ArcPosition a = ArcPosition { posStart :: Point a, posEnd :: Point a, posInfo :: ArcInfo a- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | Arc specification based on centroidal interpretation. -- -- See: https://www.w3.org/TR/SVG/implnote.html#ArcConversionEndpointToCenter----data ArcCentroid a =- ArcCentroid+data ArcCentroid a = ArcCentroid { -- | ellipse center centroid :: Point a, -- | ellipse radii@@ -389,7 +395,8 @@ ang0 :: a, -- | difference between ending point angle and starting point angle angdiff :: a- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | convert from an ArcPosition spec to ArcCentroid spec. --@@ -401,25 +408,27 @@ 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 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) * sqrt- (snumer / (rx*rx*y1'*y1' + ry*ry*x1'*x1'))- cx' = s * rx * y1' / ry- cy' = s * (-ry) * x1' / rx+ 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)+ * 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' c = Point cx cy- ang1 = angle (Point (-(cx'-x1')/rx) (-(cy'-y1')/ry))- ang2 = angle (Point (-(cx'+x1')/rx) (-(cy'+y1')/ry))+ 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) +- angd'+ bool 0 (2 * pi) (not clockwise && angd' < 0)+ + bool 0 (-2 * pi) (clockwise && angd' > 0)+ + angd' -- | convert from an ArcCentroid to an ArcPosition specification. --@@ -431,13 +440,12 @@ -- - angle diff is pi and large is True -- -- - 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) where p1 = ellipse c r phi ang1- p2 = ellipse c r phi (ang1+angd)+ p2 = ellipse c r phi (ang1 + angd) large = abs angd > pi clockwise = angd < zero @@ -455,7 +463,6 @@ -- > c + (rotate phi |. (r * ray theta)) -- -- 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)) @@ -468,21 +475,22 @@ arcBox p = space1 pts where (ArcCentroid c r phi ang0 angd) = arcCentroid p- (x',y') = arcDerivs r phi+ (x', y') = arcDerivs r phi angr = ang0 ... (ang0 + angd) :: Range Double angs =- filter (|.| angr)- [ x',- x' - 2 * pi,- x'+pi,- x'-pi,- y',- y' - 2 * pi,- y'+pi,- y'-pi,- ang0,- ang0+angd- ]+ filter+ (|.| angr)+ [ x',+ x' - 2 * pi,+ x' + pi,+ x' - pi,+ y',+ y' - 2 * pi,+ y' + pi,+ y' - pi,+ ang0,+ ang0 + angd+ ] pts = ellipse c r phi <$> angs -- | potential arc turning points.@@ -492,32 +500,32 @@ arcDerivs :: Point Double -> Double -> (Double, Double) arcDerivs (Point rx ry) phi = (thetax1, thetay1) where- thetax1 = atan2 (-sin phi * ry) (cos phi * rx)+ thetax1 = atan2 (- sin phi * ry) (cos phi * rx) thetay1 = atan2 (cos phi * ry) (sin phi * rx) -- * bezier+ -- | Quadratic bezier curve expressed in positional terms.----data QuadPosition a =- QuadPosition+data QuadPosition a = QuadPosition { -- | starting point qposStart :: Point a, -- | ending point qposEnd :: Point a, -- | control point qposControl :: Point a- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | Quadratic bezier curve with control point expressed in polar terms normalised to the start - end line.-data QuadPolar a =- QuadPolar+data QuadPolar a = QuadPolar { -- | starting point qpolStart :: Point a, -- | ending point qpolEnd :: Point a, -- | control point in terms of distance from and angle to the qp0 - qp2 line qpolControl :: Polar a a- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | Convert from a positional to a polar representation of a cubic bezier. --@@ -547,20 +555,20 @@ -- 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 +- 2 * (1-theta) * theta .* control +- theta^2 .* end+ (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)) -- [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)+ 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 --@@ -570,13 +578,12 @@ quadBox p = space1 pts where ts = quadDerivs p- pts = quadBezier p <$> ([0,1] <> ts)+ pts = quadBezier p <$> ([0, 1] <> ts) -- | cubic bezier curve -- -- Note that the ordering is different to the svg standard.-data CubicPosition a =- CubicPosition+data CubicPosition a = CubicPosition { -- | starting point cposStart :: Point a, -- | ending point@@ -585,11 +592,11 @@ cposControl1 :: Point a, -- | control point 2 cposControl2 :: Point a- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | A polar representation of a cubic bezier with control points expressed as polar and normalised to the start - end line.-data CubicPolar a =- CubicPolar+data CubicPolar a = CubicPolar { -- | starting point cpolStart :: Point a, -- | ending point@@ -598,7 +605,8 @@ cpolControl1 :: Polar a a, -- | control point in terms of distance from and angle to the start end line cpolControl2 :: Polar a a- } deriving (Eq, Show, Generic)+ }+ deriving (Eq, Show, Generic) -- | Convert from a positional to a polar representation of a cubic bezier. --@@ -633,46 +641,50 @@ -- 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 +- 3 * (1-theta)^2 * theta .* control1 +- 3 * (1-theta) * theta^2 .* control2 +- theta^3 .* end+ (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)) -- [0.8535533905932737,0.14644660940672624,0.5] cubicDerivs :: CubicPosition Double -> [Double]-cubicDerivs (CubicPosition (Point c0x c0y) (Point c3x c3y)- (Point c1x c1y) (Point c2x c2y)) =- B.bezierHoriz b <> B.bezierVert b- where- b =- B.CubicBezier- (B.Point c0x c0y)- (B.Point c1x c1y)- (B.Point c2x c2y)- (B.Point c3x c3y)+cubicDerivs+ ( CubicPosition+ (Point c0x c0y)+ (Point c3x c3y)+ (Point c1x c1y)+ (Point c2x c2y)+ ) =+ B.bezierHoriz b <> B.bezierVert b+ where+ b =+ B.CubicBezier+ (B.Point c0x c0y)+ (B.Point c1x c1y)+ (B.Point c2x c2y)+ (B.Point c3x c3y) -- | Bounding box for a CubicPosition -- -- >>> 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 where ts = cubicDerivs p- pts = cubicBezier p <$>- filter+ pts =+ cubicBezier p+ <$> filter (|.| Range 0 1)- ([0,1] <> ts)+ ([0, 1] <> ts) -- | Bounding box for a list of path XYs.--- pathBoxes :: [(PathInfo Double, Point Double)] -> Maybe (Rect Double) pathBoxes [] = Nothing-pathBoxes (x:xs) =+pathBoxes (x : xs) = L.fold (L.Fold step begin (Just . snd)) xs where begin :: (Point Double, Rect Double)@@ -684,7 +696,6 @@ step (start, r) a = (snd 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) = case info of
test/test.hs view
@@ -15,5 +15,7 @@ "src/Chart/Bar.hs", "src/Chart/Render.hs", "src/Chart/Surface.hs",- "src/Chart/Examples.hs"+ "src/Chart/Examples.hs",+ "src/Data/Colour.hs",+ "src/Chart/Reanimate.hs" ]