diff --git a/app/examples.hs b/app/examples.hs deleted file mode 100644 --- a/app/examples.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -import Chart -import Chart.Examples -import Control.Lens -import Lucid -import NumHask.Prelude hiding (replace) -import Web.Rep - -chartServer :: SharedRep IO (Text, Text) -> IO () -chartServer srep = sharedServer srep defaultSocketConfig (chartStyler True) defaultInputCode chartOutputCode - -chartOutputCode :: Either Text (Text, Text) -> IO [Code] -chartOutputCode ea = - pure $ case ea of - Left err -> [Append "debug" ("hashmap error: " <> err)] - Right (chart', debug') -> - [ Replace "output" chart', - Replace "debug" debug' - ] - -chartStyler :: Bool -> Page -chartStyler doDebug = - mathjaxSvgPage "hasmathjax" - <> bootstrapPage - <> socketPage - & #htmlHeader .~ title_ "chart styler" - & #htmlBody - .~ divClass_ - "container" - ( divClass_ - "row d-flex justify-content-between" - ( sec "col4" "input" - <> sec "col8" "output" - ) - <> bool mempty (divClass_ "row" (with div_ [id_ "debug"] mempty)) doDebug - ) - where - sec d n = divClass_ d (with div_ [id_ n] mempty) - --- main example -main :: IO () -main = - chartServer - ( repChoice - 5 - [ ("mempty", repEx memptyExample), - ("unit", repEx unitExample), - ("hud", repEx hudExample), - ("rect", repEx rectExample), - ("line", repEx lineExample), - ("wave", repEx mainExample), - ("text", repEx textExample), - ("glyphs", repEx glyphExample), - ("bar", repBarChart defaultSvgOptions barDataExample defaultBarOptions), - ( "pixel", - repPixelChart - ( defaultSvgOptions, - defaultPixelOptions - & #poGrain .~ Point 20 20 - & #poRange .~ Rect 1 2 1 2, - defaultHudOptions, - defaultPixelLegendOptions "pixel test", - f1 - ) - ), - ("bound text bug", repEx (makeExample defaultHudOptions boundTextBug)), - ("compound chart", repEx (makeExample defaultHudOptions (lglyph <> glines))), - ("label", repEx (makeExample defaultHudOptions label)), - ("legend test", repNoData defaultSvgOptions BlankA legendTest) - ] - ) diff --git a/app/reanimate-example.hs b/app/reanimate-example.hs new file mode 100644 --- /dev/null +++ b/app/reanimate-example.hs @@ -0,0 +1,57 @@ +#!/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 OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NegativeLiterals #-} + +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 + +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) + +pan :: (Rect Double -> ChartSvg) -> Rect Double -> Rect Double -> Double -> Tree +pan f start end x = chartSvgTree $ f (start + fmap (*x) (end - start)) + +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)) + +expScaleData :: Double -> Chart Double -> Chart Double +expScaleData s c = c & #xys %~ fmap (fmap ((10.0 ** s) *)) + diff --git a/app/venn.hs b/app/venn.hs deleted file mode 100644 --- a/app/venn.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -import Chart -import Control.Lens -import Data.Generics.Labels () -import qualified Data.Map.Strict as Map -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy -import Lucid -import Lucid.Base -import NumHask.Prelude - -xs :: Map.Map Text (Point Double) -xs = - Map.fromList - [ ("origin", Point 0 0), -- origin - ("circle1", Point 0.5 (-0.5 + cos (pi / 6))), -- center of circle 1 - ("circle2", Point 0 (-0.5)), -- center of circle 2 - ("circle3", Point (-0.5) ((-0.5) + cos (pi / 6))), -- center of circle 3 - ("corner1", Point 0 ((-0.5) + 2 * cos (pi / 6))), -- corner 1 - ("corner2", Point 1 (-0.5)), -- corner 2 - ("corner3", Point (-1) (-0.5)) -- corner 3 - ] - -vennps :: Text -> (Double, Double) -vennps k = let (Point x y) = xs Map.! k in (x, - y) - -moveA :: Double -> Double -> Text -moveA x y = "M" <> show x <> "," <> show y - -data Arc = Arc {arcXr :: Double, arcYr :: Double, arcRot :: Double, arcLargeArcFlag :: Bool, arcSweepFlag :: Bool, arcX :: Double, arcY :: Double} deriving (Eq, Show, Generic) - -arcA_ :: Arc -> Text -arcA_ a = show (view #arcXr a) <> " " <> show (view #arcYr a) <> " " <> show (view #arcRot a) <> " " <> bool "0" "1" (view #arcLargeArcFlag a) <> " " <> bool "0" "1" (view #arcSweepFlag a) <> " " <> show (view #arcX a) <> "," <> show (view #arcY a) - -arcA :: [Arc] -> Text -arcA as = "A" <> Text.intercalate " " (arcA_ <$> as) - -outerseg1 :: Text -outerseg1 = - Text.intercalate - " " - [ uncurry moveA (vennps "corner1"), - arcA - [ uncurry (Arc 0.5 0.5 0 True True) (vennps "corner2"), - uncurry (Arc 1 1 0 False False) (vennps "circle1"), - uncurry (Arc 1 1 0 False False) (vennps "corner1") - ], - "Z" - ] - -outerseg2 :: Text -outerseg2 = - Text.intercalate - " " - [ uncurry moveA (vennps "corner3"), - arcA - [ uncurry (Arc 0.5 0.5 0 True False) (vennps "corner2"), - uncurry (Arc 1 1 0 False True) (vennps "circle2"), - uncurry (Arc 1 1 0 False True) (vennps "corner3") - ], - "Z" - ] - -outerseg3 :: Text -outerseg3 = - Text.intercalate - " " - [ uncurry moveA (vennps "corner3"), - arcA - [ uncurry (Arc 0.5 0.5 0 True True) (vennps "corner1"), - uncurry (Arc 1 1 0 False False) (vennps "circle3"), - uncurry (Arc 1 1 0 False False) (vennps "corner3") - ], - "Z" - ] - -innerseg :: Text -innerseg = - Text.intercalate - " " - [ uncurry moveA (vennps "circle1"), - arcA - [ uncurry (Arc 1 1 0 False True) (vennps "circle2"), - uncurry (Arc 1 1 0 False True) (vennps "circle3"), - uncurry (Arc 1 1 0 False True) (vennps "circle1") - ], - "Z" - ] - -midseg1 :: Text -midseg1 = - Text.intercalate - " " - [ uncurry moveA (vennps "corner1"), - arcA - [ uncurry (Arc 1 1 0 False True) (vennps "circle1"), - uncurry (Arc 1 1 0 False False) (vennps "circle3"), - uncurry (Arc 1 1 0 False True) (vennps "corner1") - ], - "Z" - ] - -midseg2 :: Text -midseg2 = - Text.intercalate - " " - [ uncurry moveA (vennps "circle1"), - arcA - [ uncurry (Arc 1 1 0 False True) (vennps "corner2"), - uncurry (Arc 1 1 0 False True) (vennps "circle2"), - uncurry (Arc 1 1 0 False False) (vennps "circle1") - ], - "Z" - ] - -midseg3 :: Text -midseg3 = - Text.intercalate - " " - [ uncurry moveA (vennps "circle2"), - arcA - [ uncurry (Arc 1 1 0 False True) (vennps "corner3"), - uncurry (Arc 1 1 0 False True) (vennps "circle3"), - uncurry (Arc 1 1 0 False False) (vennps "circle2") - ], - "Z" - ] - -vennGlyphs :: [Text] -vennGlyphs = [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3, innerseg] - -seg :: Text -> Colour -> GlyphStyle -seg p c = defaultGlyphStyle & set #shape (PathGlyph p) & set #color c & set #borderColor white & set #borderSize 0.06 - -venns :: [Chart Double] -venns = zipWith (\p c -> Chart (GlyphA $ seg p c) [zero]) vennGlyphs palette1 - -phrases :: [Chart Double] -phrases = phraseChart <$> mainPhrases - -data Phrase - = Phrase - { phraseText :: Text, - phrasePosition :: Point Double, - phraseSize :: Double, - phraseRotation :: Double, - phraseColor :: Colour, - phraseTag :: Text, - phraseLevel :: Int - } - deriving (Eq, Show, Generic) - -phraseChart :: Phrase -> Chart Double -phraseChart p = Chart (TextA a [view #phraseText p]) [PointXY (view #phrasePosition p)] - where - a = - defaultTextStyle - & set #size (view #phraseSize p) - & set #rotation (Just $ view #phraseRotation p) - & set #color (view #phraseColor p) - -mainPhrases :: [Phrase] -mainPhrases = - [ Phrase "Composable" (Point 0.9 0.7) 0.16 60 c "composable" 1, - Phrase "Functional" (Point 0 (-1)) 0.16 0 c "functional" 1, - Phrase "Open" (Point (-1) 0.55) 0.16 (-60) c "open" 1, - Phrase "Accurate" (Point 0.6 (-0.4)) 0.16 0 c "accurate" 1, - Phrase "Dynamic" (Point (-0.6) (-0.4)) 0.16 0 c "dynamic" 1, - Phrase "Modern" (Point 0 0.7) 0.16 0 c "modern" 1, - Phrase "chart-svg" (Point 0 0) 0.2 0 c "chart-svg" 1 - ] - where - c = black - -renderToSvgt :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> [(TextStyle, Text)] -> Html () -renderToSvgt csso (Point w' h') (Rect x z y w) cs tts = - with - ( svg2_ - ( bool id (cssCrisp <>) (csso == UseCssCrisp) $ - chartDefs cs - <> mconcat (zipWith svgt cs tts) - ) - ) - [ width_ (show w'), - height_ (show h'), - makeAttribute "viewBox" (show x <> " " <> show (- w) <> " " <> show (z - x) <> " " <> show (w - y)) - ] - -writeVennWords :: IO () -writeVennWords = - writeFile "other/venn2.svg" $ Lazy.toStrict $ renderText - $ renderToSvgt - NoCssOptions - (Point 300 300) - (Rect (-2) 2 (-2) 2) - (phrases <> venns <> [Chart BlankA [R (-2.0) 2.0 (-2.0) 2.0]]) - $ (defaultTextStyle & set #color colorText,) - <$> (replicate 7 "" <> (phraseText <$> mainPhrases) <> [""]) - -writeVenn :: [Colour] -> IO () -writeVenn cs = writeChartsWith "other/venn.svg" (defaultSvgOptions & set #scaleCharts' NoScaleCharts & set #svgAspect ChartAspect & set #svgHeight 100) ([phraseChart (Phrase "λ" (Point 0 (-0.2)) 0.8 0 (Colour 0.1 0 0.2 1) "chart-svg" 1)] <> zipWith (\p c -> Chart (GlyphA $ seg p c) [PointXY (Point 0.0 0.0)]) [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3] cs <> [Chart BlankA [R (-1.5) 1.5 (-1.5) 1.5]]) - -main :: IO () -main = do - writeVennWords - writeVenn palette1 diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,9 +1,25 @@ cabal-version: 2.4 name: chart-svg -version: 0.1.3 -synopsis: Charts in SVG -description: Chart library targetting SVG. -category: project +version: 0.2.0 +synopsis: Charting library targetting SVGs. +description: + This package provides a charting library targetting SVG as the rendered output. + . + == 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 + . + ![main example](other/lineshud.svg) + . + See "Chart" for a broad overview of concepts, and "Chart.Examples" for a variety of practical examples. + +category: charts homepage: https://github.com/tonyday567/chart-svg#readme bug-reports: https://github.com/tonyday567/chart-svg/issues author: Tony Day @@ -24,99 +40,83 @@ Chart Chart.Bar Chart.Examples - Chart.Pixel + Chart.Reanimate + Chart.Surface Chart.Render - Chart.Page Chart.Types + Chart.Various Data.Colour Data.FormatN + Data.Path hs-source-dirs: src build-depends: - Color >= 0.1.4, - attoparsec >= 0.13, + Color >= 0.3 && < 0.4, + JuicyPixels >= 3.3 && < 3.4, + attoparsec >= 0.13 && < 0.14, base >=4.7 && <5, + cubicbezier >= 0.6 && < 0.7, + foldl >= 1.4 && < 1.5, generic-lens >= 1.2 && < 3.0, - lucid >= 2.9, - lens >= 4.0, - numhask >= 0.6 && < 0.7, - numhask-space >= 0.6 && < 0.7, - pretty-simple >= 3.2, - scientific >= 0.3, - tagsoup >= 0.14, - text >= 1.2, - time >= 1.9, - transformers >= 0.5, - web-rep >= 0.7 && < 0.8 + lens >= 4.0 && < 5, + linear >= 1.21 && < 1.22, + lucid >= 2.9 && < 2.10, + numhask >= 0.7 && < 0.8, + numhask-space >= 0.7 && < 0.8, + reanimate >= 1.1.1.0 && < 1.2, + reanimate-svg >= 0.13 && < 0.14, + scientific >= 0.3 && < 0.4, + tagsoup >= 0.14 && < 0.15, + text >= 1.2 && < 1.3, + time >= 1.9 && < 1.10, + transformers >= 0.5 && < 0.6, + unordered-containers >= 0.2 && < 0.3, default-language: Haskell2010 default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + -fwrite-ide-info + -hiedir=.hie -executable examples - main-is: examples.hs +executable reanimate-example + main-is: reanimate-example.hs hs-source-dirs: app build-depends: + attoparsec >= 0.13 && < 0.14, + JuicyPixels >= 3.3.5 && < 3.4, base >=4.7 && <5, + bytestring >= 0.10 && < 0.11, chart-svg, - lens >= 4.0, - lucid >= 2.9, - numhask >= 0.6 && < 0.7, - text >= 1.2, - transformers >= 0.5, - unordered-containers >= 0.2.10, - web-rep >= 0.7 && < 0.8 + concurrency >= 1.11 && < 1.12, + foldl >= 1.4 && < 1.5, + lucid >= 2.9 && < 2.10, + lens >= 4.19 && < 4.20, + linear >= 1.21 && < 1.22, + numhask >= 0.7 && < 0.8, + numhask-space >= 0.7 && < 0.8, + reanimate >= 1.1.1.0 && < 1.2, + reanimate-svg >= 0.13 && < 0.14, + text >= 1.2 && < 1.3, + time >= 1.9 && < 1.10, + transformers >= 0.5 && < 0.6, + unordered-containers >= 0.2 && < 0.3, + vector >= 0.12 && < 0.13, default-language: Haskell2010 default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - -executable venn - main-is: venn.hs - hs-source-dirs: - app - build-depends: - base >=4.7 && <5, - containers >= 0.6, - chart-svg, - generic-lens >= 1.2 && < 3.0, - lucid >= 2.9, - lens >= 4.0, - numhask >= 0.6 && < 0.7, - numhask-space >= 0.6 && < 0.7, - text >= 1.2, - transformers >= 0.5, - unordered-containers >= 0.2.10, - web-rep >= 0.7 && < 0.8 - default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax - ghc-options: - -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints + -funbox-strict-fields + -fwrite-ide-info + -hiedir=.hie test-suite test type: exitcode-stdio-1.0 @@ -126,18 +126,14 @@ build-depends: base >=4.7 && <5, chart-svg, - doctest >= 0.16, - numhask >= 0.6 && < 0.7 + doctest >= 0.16 && < 0.18, + numhask >= 0.7 && < 0.8, default-language: Haskell2010 - default-extensions: - NegativeLiterals - NoImplicitPrelude - OverloadedStrings - UnicodeSyntax ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - -funbox-strict-fields + -fwrite-ide-info + -hiedir=.hie diff --git a/other/arc.svg b/other/arc.svg new file mode 100644 --- /dev/null +++ b/other/arc.svg @@ -0,0 +1,147 @@ +-0.100.10.20.30.40.50.60.70.80.9100.10.20.30.40.50.60.70.80.91 diff --git a/other/arcflags.svg b/other/arcflags.svg new file mode 100644 --- /dev/null +++ b/other/arcflags.svg @@ -0,0 +1,1241 @@ +01234567890123456789SweepTrueFalseFalseTrueLarge diff --git a/other/arrowg.svg b/other/arrowg.svg new file mode 100644 --- /dev/null +++ b/other/arrowg.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/bar.svg b/other/bar.svg --- a/other/bar.svg +++ b/other/bar.svg @@ -1,29 +1,29 @@ -Default Bar Chart-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/boundText.svg b/other/boundText.svg deleted file mode 100644 --- a/other/boundText.svg +++ /dev/null @@ -1,1 +0,0 @@ -a pretty long piece of textanother pretty long piece of text diff --git a/other/boundTextBug.svg b/other/boundTextBug.svg new file mode 100644 --- /dev/null +++ b/other/boundTextBug.svg @@ -0,0 +1,1 @@ +a pretty long piece of textanother pretty long piece of text diff --git a/other/compound.svg b/other/compound.svg new file mode 100644 --- /dev/null +++ b/other/compound.svg @@ -0,0 +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 diff --git a/other/cubic.svg b/other/cubic.svg new file mode 100644 --- /dev/null +++ b/other/cubic.svg @@ -0,0 +1,145 @@ +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 new file mode 100644 --- /dev/null +++ b/other/ellipse.svg @@ -0,0 +1,233 @@ +-2-1.5-1-0.500.511.5-1.5-1-0.500.511.5 diff --git a/other/glines.svg b/other/glines.svg new file mode 100644 --- /dev/null +++ b/other/glines.svg @@ -0,0 +1,5 @@ + diff --git a/other/glyph.svg b/other/glyph.svg deleted file mode 100644 --- a/other/glyph.svg +++ /dev/null @@ -1,3 +0,0 @@ - diff --git a/other/glyphs.svg b/other/glyphs.svg new file mode 100644 --- /dev/null +++ b/other/glyphs.svg @@ -0,0 +1,3 @@ + diff --git a/other/hud.svg b/other/hud.svg deleted file mode 100644 --- a/other/hud.svg +++ /dev/null @@ -1,45 +0,0 @@ --0.5-0.4-0.3-0.2-0.10.00.10.20.30.40.5-0.5-0.4-0.3-0.2-0.10.00.10.20.30.40.5 diff --git a/other/hudoptions.svg b/other/hudoptions.svg new file mode 100644 --- /dev/null +++ b/other/hudoptions.svg @@ -0,0 +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 diff --git a/other/label.svg b/other/label.svg new file mode 100644 --- /dev/null +++ b/other/label.svg @@ -0,0 +1,1 @@ +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.10.00.10.20.30.40.5-0.5-0.4-0.3-0.2-0.10.00.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 new file mode 100644 --- /dev/null +++ b/other/lglyph.svg @@ -0,0 +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 diff --git a/other/line.svg b/other/line.svg new file mode 100644 --- /dev/null +++ b/other/line.svg @@ -0,0 +1,44 @@ +An example from chart-svgLine Chart00.511.522.533.544.5500.511.522.53verticallinehockey diff --git a/other/linehud.svg b/other/linehud.svg deleted file mode 100644 --- a/other/linehud.svg +++ /dev/null @@ -1,49 +0,0 @@ --0.50.00.51.01.52.02.53.03.54.04.55.05.5-0.50.00.51.01.52.02.53.03.5 diff --git a/other/lines.svg b/other/lines.svg --- a/other/lines.svg +++ b/other/lines.svg @@ -1,5 +1,5 @@ - + diff --git a/other/lineshud.svg b/other/lineshud.svg new file mode 100644 --- /dev/null +++ b/other/lineshud.svg @@ -0,0 +1,43 @@ +00.511.522.533.544.5500.511.522.533.5 diff --git a/other/mempty.svg b/other/mempty.svg deleted file mode 100644 --- a/other/mempty.svg +++ /dev/null @@ -1,1 +0,0 @@ - diff --git a/other/path.svg b/other/path.svg new file mode 100644 --- /dev/null +++ b/other/path.svg @@ -0,0 +1,35 @@ +00.20.40.60.811.21.41.6-0.4-0.200.20.40.60.81 diff --git a/other/pixel.svg b/other/pixel.svg deleted file mode 100644 # file too large to diff: other/pixel.svg diff --git a/other/problematic1.svg b/other/problematic1.svg new file mode 100644 --- /dev/null +++ b/other/problematic1.svg @@ -0,0 +1,55 @@ +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 new file mode 100644 --- /dev/null +++ b/other/problematic2.svg @@ -0,0 +1,339 @@ +-0.500.511.522.533.5-4-3-2-101231.000,2.000 diff --git a/other/quad.svg b/other/quad.svg new file mode 100644 --- /dev/null +++ b/other/quad.svg @@ -0,0 +1,145 @@ +-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 new file mode 100644 --- /dev/null +++ b/other/rect.svg @@ -0,0 +1,23 @@ +-5-4-3-2-1012345 diff --git a/other/surface.svg b/other/surface.svg new file mode 100644 --- /dev/null +++ b/other/surface.svg @@ -0,0 +1,4 @@ +-6-4-2rosenbrock diff --git a/other/surfaceg.svg b/other/surfaceg.svg new 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/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,1 +1,29 @@ -λ +-1.5-1-0.500.511.5-1.5-1-0.500.511.5 diff --git a/other/wave.svg b/other/wave.svg new file mode 100644 --- /dev/null +++ b/other/wave.svg @@ -0,0 +1,1 @@ + diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -1,13 +1,30 @@ -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} --- | A haskell Charting library targetting SVG +-- | A haskell Charting library targetting SVGs module Chart - ( -- $overview + ( -- * Usage + -- + -- $setup + + -- * Overview + -- + -- $overview + + -- * Chart Chart (..), + moveChart, + projectXYs, + projectXYsWith, + projectArcPosition, + + -- * Annotation Annotation (..), annotationText, + scaleAnn, padRect, + + -- * Styles RectStyle (..), defaultRectStyle, blob, @@ -15,41 +32,54 @@ border, TextStyle (..), defaultTextStyle, - Anchor (..), - fromAnchor, - toAnchor, GlyphStyle (..), defaultGlyphStyle, GlyphShape (..), glyphText, LineStyle (..), defaultLineStyle, - PixelStyle (..), - defaultPixelStyle, - Direction (..), - fromDirection, - toDirection, - SvgAspect (..), - toSvgAspect, - fromSvgAspect, - EscapeText (..), - CssOptions (..), - ScaleCharts (..), - SvgOptions (..), - defaultSvgOptions, - defaultSvgFrame, + LineCap (..), + fromLineCap, + toLineCap, + LineJoin (..), + fromLineJoin, + toLineJoin, + fromDashArray, + Anchor (..), + fromAnchor, + toAnchor, + PathStyle (..), + toPathChart, + defaultPathStyle, + + -- * Hud types ChartDims (..), HudT (..), Hud, + simulHud, HudOptions (..), defaultHudOptions, defaultCanvas, + runHudWith, + runHud, + makeHud, + ChartAspect (..), + toChartAspect, + fromChartAspect, + initialCanvas, + chartAspectHud, + canvas, + title, + tick, + + -- * Hud primitives AxisOptions (..), defaultAxisOptions, + flipAxis, Place (..), placeText, - Bar (..), - defaultBar, + AxisBar (..), + defaultAxisBar, Title (..), defaultTitle, Tick (..), @@ -61,141 +91,149 @@ defaultTickStyle, tickStyleText, TickExtend (..), + adjustTick, + makeTickDates, + makeTickDatesContinuous, Adjustments (..), defaultAdjustments, LegendOptions (..), defaultLegendOptions, - - -- $core - dataBox, - toAspect, - scaleAnn, - moveChart, - - -- $hud - runHudWith, - runHud, - makeHud, - freezeTicks, - flipAxis, - canvas, - title, - tick, - adjustTick, - makeTickDates, - makeTickDatesContinuous, legendHud, - legendEntry, - legendChart, - legendFromChart, + Orientation (..), + fromOrientation, + toOrientation, - -- $svg - svg, - svgt, - chartDef, - chartDefs, - styleBox, - styleBoxes, - noStyleBoxes, - styleBoxText, - styleBoxGlyph, + -- * SVG primitives + CssOptions (..), + SvgOptions (..), + defaultSvgOptions, + defaultSvgFrame, + + -- * Chart manipulation padChart, frameChart, hori, vert, stack, - addChartBox, - addChartBoxes, - -- * re-exports - module Chart.Page, + -- * Bounding box calculation + padBox, + dataBox, + dataBoxes, + dataBoxesS, + styleBox, + styleBoxes, + styleBoxesS, + styleBoxText, + styleBoxGlyph, + + -- * Re-exports module Chart.Render, module Chart.Bar, - module Chart.Pixel, + module Chart.Surface, module Data.Colour, module Data.FormatN, + module Data.Path, module NumHask.Space, ) where import Chart.Bar -import Data.FormatN -import Chart.Page -import Chart.Pixel import Chart.Render +import Chart.Surface import Chart.Types import Data.Colour +import Data.FormatN +import Data.Path import NumHask.Space -- $setup -- +-- >>> import Chart +-- +-- chart-svg works well with "NumHask.Prelude" and "Control.Lens" but neither are necessary. +-- -- >>> :set -XOverloadedLabels -- >>> :set -XNoImplicitPrelude --- >>> -- import NumHask.Prelude -- >>> import Control.Lens +-- >>> import NumHask.Prelude -- $overview -- --- A chart consists of related conceptual layers: +-- Charting consists of three highly-coupled conceptual layers: -- --- 1. the data to be represented --- 2. the manifestation of the data on the screen --- 3. visual aids to help interpret the data, such as axes, gridlines and titles. +-- 1. the data to be represented. +-- 2. how the data will be represented on a screen, and. +-- 3. the creation of visual aids that help interpret the data; such as axes, gridlines and titles. -- --- >>> :t Chart --- Chart :: Annotation -> [XY a] -> Chart a +-- == What is a 'Chart'? -- --- A 'Chart' in this library specifically consists of +-- A 'Chart' in this library consists of a specification of the first two items in the above list; data and data annotation. -- --- - a list of values, either 2D points or rectangles (unified as a 'XY') +-- - 'XY': a list of values, specified as either 2D points or rectangles. -- --- - an 'Annotation', which describes the way that the data should be represented on a 2-dimensional plane. +-- - 'Annotation': a description of how the data should be represented on the screen. -- --- What exactly is annotation and what is data is highly variant within charting practice. This construction treats position on a plane differently from other quantitative manifestations such as color and size. The chief advantage of priveliging XY position is that scaling and integrating data with other chart elements becomes much easier. The disadvantage is that, to use quantitative tools such as size, data needs to be consciously separated into that which is position orientated, and that which is defined as 'Annotation'. +-- >>> :t Chart +-- Chart :: Annotation -> [XY a] -> Chart a -- +-- What exactly is annotation and what is data is highly variant within charting practice. This construction treats position on the XY plane differently from other quantitative manifests such as color and size. The chief advantage of priveliging XY position is that scaling and integrating data with other chart elements becomes much easier. The disadvantage is that, to use quantitative tools such as size, data needs to be consciously separated into that which is position-orientated, and that which is defined as 'Annotation'. -- --- Here's some data: -- --- >>> :{ --- let ls = fmap (uncurry P) <$> --- [ [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0 :: Double)], --- [(0.0, 0.0), (3.0, 3.0)], --- [(0.5, 4.0), (0.5, 0)] ] --- :} +-- 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]] -- --- and an Annotation to describe representation of this data. +-- and an Annotation to describe representation of this data; three line styles with different colors and widths: -- --- >>> :{ --- let anns = LineA <$> --- [ defaultLineStyle & #color .~ (palette1 !! 0) & #width .~ 0.015, --- defaultLineStyle & #color .~ (palette1 !! 1) & #width .~ 0.03, --- defaultLineStyle & #color .~ (palette1 !! 5) & #width .~ 0.01 --- ] --- :} +-- >>> 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 put together a Chart. +-- and this is enough to create a Chart. -- --- >>> let lines = zipWith Chart anns ls --- >>> :t lines --- lines :: [Chart Double] +-- >>> let lineChart = zipWith Chart anns ls +-- >>> :t lineChart +-- lineChart :: [Chart Double] -- --- Most charts will, in reality, be a list of charts, and much of the library API is designed for this. +-- Most charts will, in reality, be a list of charts such as this, and much of the library API is designed for this. -- --- > writeCharts "other/lines.svg" lines +-- > writeChartSvgDefault "other/lines.svg" lineChart -- -- ![lines example](other/lines.svg) -- --- Physical, on-the-page representations of data is separate to need to be considered separately to the domain of the data itself but their concerns bleed into each other. An axis on a chart needs to know the range of the data to render a tick value. +-- 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. -- --- > writeHudOptionsChart "other/linehud.svg" defaultSvgOptions defaultHudOptions [] lines +-- 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. -- --- ![hud example](other/linehud.svg) +-- Here is the line chart presented with default hud options. -- --- 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, should be readily transparent, have sane defaults but be fully configurable. +-- > writeChartSvgHud "other/lineshud.svg" lineChart -- --- The library considers a hud to be a recipe for the creation of a 'Chart' list, in the domain of the viewbox of an svg file or similar conception. +-- ![hud example](other/lineshud.svg) -- --- Being charts all the way down creates a direct mapping between a chart and its representation. The best way to understand this would be to run the example app, which serves a websocket receiving chart options and updating a chart. +-- '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. +-- +-- 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 +-- +-- Axes, titles, tick marks, grid lines and legends are chart elements that exist to provide references for the viewer that helps explain the data that is being represented by the chart. They can be clearly distinguished from data representations such as a mark where a value is. +-- +-- Apart from this, hud elements are pretty much the same as data elements. They simulateously have two reference frames: a data domain (tick values reference the data value range) and a page domain (a title needs to be placed on the left say, and has a size of 0.1 versus the page size). They are also typically composed of the same sorts of primitives as data elements, such as rectangles and lines and text and colors. +-- +-- Given this similarity, an efficient process for chart creation is roughly: +-- +-- - collect the chart data and data annotations into a [Chart Double] +-- +-- - measure the range of the data values +-- +-- - begin a process of folding a [Hud Double] in with the charts, supplying the the data values to the hud elements if needed, and keeping track of the overall page size of the chart. +-- +-- 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. + diff --git a/src/Chart/Bar.hs b/src/Chart/Bar.hs --- a/src/Chart/Bar.hs +++ b/src/Chart/Bar.hs @@ -30,12 +30,19 @@ -- $setup -- -- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings -- >>> :set -XNoImplicitPrelude --- >>> -- import NumHask.Prelude +-- >>> import NumHask.Prelude +-- >>> import Chart -- >>> import Control.Lens --- | the usual bar chart eye-candy +-- | 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 +-- +-- > writeChartSvg "other/bar.svg" (ChartSvg defaultSvgOptions ho [] cs) +-- -- ![bar chart example](other/bar.svg) data BarOptions = BarOptions @@ -48,7 +55,7 @@ displayValues :: Bool, valueFormatN :: FormatN, accumulateValues :: Bool, - barOrientation :: Direction, + barOrientation :: Orientation, barHudOptions :: HudOptions } deriving (Show, Eq, Generic) @@ -70,21 +77,20 @@ ( defaultHudOptions & #hudAxes .~ [ defaultAxisOptions - & #atick . #ltick .~ Nothing, + & #axisTick . #ltick .~ Nothing, defaultAxisOptions & #place .~ PlaceLeft ] & #hudTitles .~ [] & #hudLegend - .~ Just - ( defaultLegendOptions - & #lplace .~ PlaceRight - & #lsize .~ 0.12 - & #vgap .~ 0.4 - & #hgap .~ 0.14 - & #ltext . #size .~ 0.12 - & #lscale .~ 0.4, - [] - ) + ?~ ( defaultLegendOptions + & #lplace .~ PlaceRight + & #lsize .~ 0.12 + & #vgap .~ 0.4 + & #hgap .~ 0.14 + & #ltext . #size .~ 0.12 + & #lscale .~ 0.4, + [] + ) ) where gs = (\x -> RectStyle 0.002 x x) <$> palette1 @@ -92,7 +98,7 @@ -- | imagine a dataframe you get in other languages: -- --- - definietly some [[Double]] +-- - definitely some [[Double]] -- -- - maybe some row names -- @@ -109,8 +115,6 @@ -- -- >>> barRects defaultBarOptions [[1,2],[2,3]] -- [[Rect 5.0e-2 0.45 0.0 1.0,Rect 1.05 1.4500000000000002 0.0 2.0],[Rect 0.45 0.8500000000000001 0.0 2.0,Rect 1.4500000000000002 1.85 0.0 3.0]] --- --- FIXME: slows! barRects :: BarOptions -> [[Double]] -> @@ -163,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 = [RectXY Rect 5.0e-2 0.45 0.0 1.0,RectXY Rect 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 = [RectXY Rect 0.45 0.8500000000000001 0.0 2.0,RectXY Rect 1.4500000000000002 1.85 0.0 3.0]},Chart {annotation = BlankA, xys = [RectXY Rect -5.0e-2 1.9500000000000002 0.0 3.0]}] +-- [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]}] 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)]] @@ -183,7 +187,7 @@ -- | sensible ticks barTicks :: BarData -> TickStyle barTicks bd - | bd ^. #barData == [] = TickNone + | null (bd ^. #barData) = TickNone | isNothing (bd ^. #barRowLabels) = TickLabels $ pack . show <$> [0 .. (maxRows (bd ^. #barData) - 1)] | otherwise = @@ -192,12 +196,12 @@ tickFirstAxis :: BarData -> [AxisOptions] -> [AxisOptions] tickFirstAxis _ [] = [] -tickFirstAxis bd (x : xs) = (x & #atick . #tstyle .~ barTicks bd) : xs +tickFirstAxis bd (x : xs) = (x & #axisTick . #tstyle .~ barTicks bd) : xs -- | bar legend barLegend :: BarData -> BarOptions -> [(Annotation, Text)] barLegend bd bo - | bd ^. #barData == [] = [] + | null (bd ^. #barData) = [] | isNothing (bd ^. #barColumnLabels) = [] | otherwise = zip (RectA <$> bo ^. #barRectStyles) $ take (length (bd ^. #barData)) $ fromMaybe [] (bd ^. #barColumnLabels) <> repeat "" @@ -210,7 +214,7 @@ bars bo bd <> bool [] (barTextCharts bo bd) (bo ^. #displayValues) ) -flipAllAxes :: Direction -> [AxisOptions] -> [AxisOptions] +flipAllAxes :: Orientation -> [AxisOptions] -> [AxisOptions] flipAllAxes o = fmap (bool id flipAxis (o == Vert)) barDataTP :: Bool -> FormatN -> Double -> Double -> [[Double]] -> [[(Text, Double)]] diff --git a/src/Chart/Examples.hs b/src/Chart/Examples.hs --- a/src/Chart/Examples.hs +++ b/src/Chart/Examples.hs @@ -1,66 +1,89 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NegativeLiterals #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -module Chart.Examples where +-- | Examples of chart construction. +module Chart.Examples + ( unitExample, + svgOptionsExample, + hudOptionsExample, + rectExample, + textExample, + glyphsExample, + lineExample, + barDataExample, + barExample, + waveExample, + lglyphExample, + glinesExample, + compoundExample, + boundTextBugExample, + labelExample, + legendExample, + surfaceExample, + arrowgExample, + surfacegExample, + rosenbrock, + arcExample, + arcFlagsExample, + ellipseExample, + quadExample, + cubicExample, + pathExample, + vennExample, + problematic1, + problematic2, + writeAllExamples, + ) +where import Chart import Control.Lens import Data.List ((!!)) import qualified Data.Text as Text -import NumHask.Prelude -import Web.Rep - -data Ex - = Ex - { excss :: SvgOptions, - exhc :: HudOptions, - exmaxcs :: Int, - exanns :: [Annotation], - exxys :: [[XY Double]] - } - deriving (Eq, Show, Generic) - -makeExample :: HudOptions -> [Chart Double] -> Ex -makeExample hs cs = Ex defaultSvgOptions hs (length cs) (view #annotation <$> cs) (fmap (fmap realToFrac) . view #xys <$> cs) - -repEx :: (Monad m) => Ex -> SharedRep m (Text, Text) -repEx (Ex css hc maxcs anns xs) = - repChartsWithStaticData css hc maxcs (zipWith Chart anns xs) - -writeChartExample :: FilePath -> Ex -> IO () -writeChartExample fp (Ex css' hc' _ anns' xys') = - writeHudOptionsChart fp css' hc' [] (zipWith Chart anns' xys') - --- | minimal example -memptyExample :: Ex -memptyExample = Ex defaultSvgOptions mempty 1 [] [] +import NumHask.Prelude hiding (lines) -- | unit example -unitExample :: Ex -unitExample = Ex defaultSvgOptions mempty 1 [RectA defaultRectStyle] [[one]] +-- +-- ![unit example](other/unit.svg) +unitExample :: ChartSvg +unitExample = mempty & #chartList .~ [Chart (RectA defaultRectStyle) [one]] --- | hud example -hudExample :: Ex -hudExample = Ex defaultSvgOptions defaultHudOptions 1 [] [] +-- | 'HudOptions' example +-- +-- ![hudoptions example](other/hudoptions.svg) +hudOptionsExample :: ChartSvg +hudOptionsExample = + mempty + & #hudOptions .~ defaultHudOptions + & #chartList .~ [Chart BlankA [one]] +-- | 'SvgOptions' example. +-- +-- ![svgoptions example](other/svgoptions.svg) +svgOptionsExample :: ChartSvg +svgOptionsExample = + mempty + & #svgOptions %~ #chartAspect .~ FixedAspect 0.7 + & #chartList .~ zipWith (\s d -> Chart (LineA s) (fmap PointXY d)) lopts ls + -- | rect example -rectExample :: Ex +-- +-- ![rect example](other/rect.svg) +rectExample :: ChartSvg rectExample = - Ex - defaultSvgOptions - (defaultHudOptions & set #hudAxes [defaultAxisOptions]) - 2 - (RectA <$> ropts) - (fmap RectXY <$> rss) + mempty + & #hudOptions .~ (defaultHudOptions & #hudAxes .~ [defaultAxisOptions]) + & #chartList .~ zipWith Chart (RectA <$> ropts) (fmap RectXY <$> rss) rss :: [[Rect Double]] rss = - [ gridR (\x -> exp (- (x ** 2) / 2)) (Range (-5) 5) 50, - gridR (\x -> 0.5 * exp (- (x ** 2) / 8)) (Range (-5) 5) 50 + [ gridR (\x -> exp (- (x ** 2) / 2)) (Range -5 5) 50, + gridR (\x -> 0.5 * exp (- (x ** 2) / 8)) (Range -5 5) 50 ] ropts :: [RectStyle] @@ -70,18 +93,18 @@ ] -- | line example -lineExample :: Ex +-- +-- ![line example](other/line.svg) +lineExample :: ChartSvg lineExample = - Ex - defaultSvgOptions - ( exampleLineHudOptions - "Line Chart" - (Just "An example from chart-svg") - (Just (legopts, zip (LineA <$> lopts) ["hockey", "line", "vertical"])) - ) - 3 - (LineA <$> lopts) - (fmap PointXY <$> ls) + mempty + & #hudOptions + .~ exampleLineHudOptions + "Line Chart" + (Just "An example from chart-svg") + (Just (legopts, zip (LineA <$> lopts) ["hockey", "line", "vertical"])) + & #chartList + .~ zipWith (\s d -> Chart (LineA s) (fmap PointXY d)) lopts ls ls :: [[Point Double]] ls = @@ -105,7 +128,7 @@ & #ltext . #size .~ 0.25 & #innerPad .~ 0.05 & #lscale .~ 0.25 - & #lplace .~ PlaceAbsolute (Point 0.5 (-0.3)) + & #lplace .~ PlaceAbsolute (Point 0.5 -0.3) exampleLineHudOptions :: Text -> Maybe Text -> Maybe (LegendOptions, [(Annotation, Text)]) -> HudOptions exampleLineHudOptions t1 t2 legends' = @@ -128,14 +151,15 @@ & #hudLegend .~ legends' -- | text example -textExample :: Ex +-- +-- ![text example](other/text.svg) +textExample :: ChartSvg textExample = - Ex - defaultSvgOptions - defaultHudOptions - 26 - (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) - ((: []) . PointXY . snd <$> ts) + mempty & #chartList + .~ zipWith + Chart + (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) + ((: []) . PointXY . snd <$> ts) where ts :: [(Text, Point Double)] ts = @@ -143,66 +167,66 @@ (fmap Text.singleton ['a' .. 'y']) [Point (sin (x * 0.1)) x | x <- [0 .. 25]] --- | glyph example -glyphExample :: Ex -glyphExample = makeExample mempty glyphs - -glyphs :: [Chart Double] -glyphs = - zipWith - ( \(sh, bs) p -> - Chart - ( GlyphA - ( defaultGlyphStyle - & #size .~ (0.1 :: Double) - & #borderSize .~ bs - & #shape .~ sh - ) - ) - [p] - ) - [ (CircleGlyph, 0.01 :: Double), - (SquareGlyph, 0.01), - (RectSharpGlyph 0.75, 0.01), - (RectRoundedGlyph 0.75 0.01 0.01, 0.01), - (EllipseGlyph 0.75, 0), - (VLineGlyph 0.005, 0.01), - (HLineGlyph 0.005, 0.01), - (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01), - (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01) - ] - [P x 0 | x <- [0 .. (8 :: Double)]] +-- | glyphs example +-- +-- ![glyphs example](other/glyphs.svg) +glyphsExample :: ChartSvg +glyphsExample = + mempty & + #svgOptions . #svgHeight .~ 50 & + #chartList + .~ zipWith + ( \(sh, bs) p -> + Chart + ( GlyphA + ( defaultGlyphStyle + & #size .~ (0.1 :: Double) + & #borderSize .~ bs + & #shape .~ sh + ) + ) + [p] + ) + [ (CircleGlyph, 0.01 :: Double), + (SquareGlyph, 0.01), + (RectSharpGlyph 0.75, 0.01), + (RectRoundedGlyph 0.75 0.01 0.01, 0.01), + (EllipseGlyph 0.75, 0), + (VLineGlyph 0.005, 0.01), + (HLineGlyph 0.005, 0.01), + (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01), + (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01) + ] + [P x 0 | x <- [0 .. (8 :: Double)]] --- | bar example +-- | Example data for Bar chart barDataExample :: BarData barDataExample = BarData [[1, 2, 3, 5, 8, 0, -2, 11, 2, 1], [1 .. 10]] - (Just (("row " <>) . pack . show <$> [1 .. 11])) - (Just (("column " <>) . pack . show <$> [1 .. 2])) + (Just (("row " <>) . pack . show <$> ([1 .. 11]::[Int]))) + (Just (("column " <>) . pack . show <$> ([1 .. 2]::[Int]))) -barExample :: Ex -barExample = makeExample hc cs +-- | Bar chart example. +-- +-- ![bar example](other/bar.svg) +barExample :: ChartSvg +barExample = mempty & #hudOptions .~ hc & #chartList .~ cs where (hc, cs) = barChart defaultBarOptions barDataExample --- | pixel example -pixelEx :: ([Chart Double], [Hud Double]) -pixelEx = pixelfl f1 (defaultPixelOptions & #poGrain .~ Point 100 100 & #poRange .~ Rect 1 2 1 2) (defaultPixelLegendOptions "pixel test") - -f1 :: (TrigField a) => Point a -> a -f1 (Point x y) = sin (cos (tan x)) * sin (cos (tan y)) - --- * stuff - -boundTextBug :: [Chart Double] -boundTextBug = - [ t1, - t2, - Chart BlankA [R 0 0.1 (-0.5) 0.5], - Chart (RectA defaultRectStyle) [RectXY (fixRect $ styleBox t1)], - Chart (RectA defaultRectStyle) [RectXY (fixRect $ styleBox t2)] - ] +-- | An example of how bounding box calculations for text is broken. +-- +-- ![bound text bug example](other/boundtextbug.svg) +boundTextBugExample :: ChartSvg +boundTextBugExample = + 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)] + ] where t1 = Chart @@ -234,8 +258,11 @@ palette1 [EllipseGlyph 1.5, SquareGlyph, CircleGlyph] -glines :: [Chart Double] -glines = cs <> gs +-- | Glyph + Lines +-- +-- ![glines example](other/glines.svg) +glinesExample :: ChartSvg +glinesExample = mempty & #chartList .~ (cs <> gs) where cs = zipWith (\d s -> Chart (LineA s) (PointXY <$> d)) ls lopts gs = zipWith (\d s -> Chart (GlyphA s) (PointXY <$> d)) ls gopts3 @@ -245,8 +272,11 @@ (\p@(Point x y) -> (pack (show x <> "," <> show y), fromIntegral <$> p)) <$> (Point <$> [0 .. 5] <*> [0 .. 5] :: [Point Int]) -lglyph :: [Chart Double] -lglyph = txt <> gly +-- | Labelled Glyphs +-- +-- ![lglyph example](other/lglyph.svg) +lglyphExample :: ChartSvg +lglyphExample = mempty & #chartList .~ (txt <> gly) where txt = ( \(t, p) -> @@ -275,37 +305,36 @@ ) <$> (snd <$> lgdata) --- | label example -labelExample :: Ex -labelExample = - Ex - defaultSvgOptions - defaultHudOptions - 1 - (annotation <$> label) - (xys <$> label) - -placedLabel :: (Real a) => Point a -> a -> Text -> Chart a -placedLabel p d t = - Chart (TextA (defaultTextStyle & #rotation ?~ realToFrac d) [t]) [PointXY p] +-- | mappend of lglyph and glines examples +-- +-- ![compound example](other/compound.svg) +compoundExample :: ChartSvg +compoundExample = lglyphExample <> glinesExample -label :: [Chart Double] -label = - [placedLabel (Point (1.0 :: Double) 1.0) (45.0 :: Double) "text at (1,1) rotated by 45 degrees"] +-- | label example. +-- +-- ![label example](other/label.svg) +labelExample :: ChartSvg +labelExample = + mempty & #chartList + .~ [Chart (TextA (defaultTextStyle & #rotation ?~ -pi/4) ["text at (1,1) rotated by -(pi/4) radians"]) [PointXY (Point 1.0 1.0)]] -- | legend test -legendTest :: HudOptions -legendTest = - defaultHudOptions - & #hudLegend - .~ Just - ( defaultLegendOptions - & #lscale .~ 0.3 - & #lplace .~ PlaceAbsolute (Point 0.0 0.0) - & #lsize .~ 0.12 - & #ltext . #size .~ 0.16, - l1 - ) +-- +-- ![legend example](other/legend.svg) +legendExample :: ChartSvg +legendExample = + mempty & #hudOptions + .~ ( defaultHudOptions + & #hudLegend + ?~ ( defaultLegendOptions + & #lscale .~ 0.3 + & #lplace .~ PlaceAbsolute (Point 0.0 0.0) + & #lsize .~ 0.12 + & #ltext . #size .~ 0.16, + l1 + ) + ) where l1 = [ (GlyphA defaultGlyphStyle, "glyph"), @@ -316,41 +345,454 @@ (BlankA, "blank") ] --- | main example -mainExample :: Ex -mainExample = - makeExample - defaultHudOptions - [Chart (GlyphA defaultGlyphStyle) (PointXY <$> gridP sin (Range 0 (2 * pi)) 30)] +-- | wave example +-- +-- ![wave example](other/wave.svg) +waveExample :: ChartSvg +waveExample = mempty & #chartList .~ [Chart (GlyphA defaultGlyphStyle) (PointXY <$> gridP sin (Range 0 (2 * pi)) 30)] +-- | venn diagram +-- +-- ![venn diagram](other/venn.svg) +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 + +{- +These were originally based on: + + [ ("origin", Point 0 0), -- origin + ("circle1", Point 0.5 (-0.5 + cos (pi / 6))), -- center of circle 1 + ("circle2", Point 0 -0.5), -- center of circle 2 + ("circle3", Point -0.5 (-0.5 + cos (pi / 6))), -- center of circle 3 + ("corner1", Point 0 (-0.5 + 2 * cos (pi / 6))), -- corner 1 + ("corner2", Point 1 -0.5), -- corner 2 + ("corner3", Point -1 -0.5) -- corner 3 + ] +-} +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" + ] + +-- | Compound path example. +-- +-- ![path test](other/path.svg) +pathExample :: ChartSvg +pathExample = + mempty & + #chartList .~ [path', c0] & + #hudOptions .~ defaultHudOptions & + #svgOptions %~ + ((#outerPad ?~ 0.1) . + (#chartAspect .~ ChartAspect)) + where + ps = + [ + (StartI, Point 0 0), + (LineI, Point 1 0), + (CubicI (Point 0.2 0) (Point 0.25 1), Point 1 1), + (QuadI (Point -1 2), Point 0 1), + (ArcI (ArcInfo (Point 1 1) (-pi/6) False False), Point 0 0) + ] + 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 +-- +-- (ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi/3) True True)) +-- +-- +-- ![ellipse example](other/ellipse.svg) +-- +ellipseExample :: ArcPosition Double -> ChartSvg +ellipseExample p@(ArcPosition p1 p2 _) = + mempty & + #chartList .~ [ell, ellFull, c0, bbox, xradii, yradii] & + #hudOptions .~ defaultHudOptions & + #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ UnadjustedAspect)) + where + (ArcCentroid c r phi' ang0 angd) = arcCentroid p + ellFull = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . ellipse c r phi' . (\x -> 2 * pi * x / 100.0) <$> [0..100]) + ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . ellipse c r phi' . (\x -> ang0 + angd * x / 100.0) <$> [0..100]) + c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [c,p1,p2]) + bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (arcBox p)] + xradii = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.9 0.2 0.02 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [ellipse c r phi' 0, ellipse c r phi' pi]) + yradii = Chart (LineA $ defaultLineStyle & #color .~ Colour 0.9 0.9 0.02 1 & #width .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound) (PointXY <$> [ellipse c r phi' (pi/2), ellipse c r phi' (3/2*pi)]) + +-- | arc example +-- +-- > 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. +-- +arcExample :: ArcPosition Double -> ChartSvg +arcExample p1 = + mempty & + #chartList .~ [arc, ell, c0, bbox] & + #hudOptions .~ defaultHudOptions & + #svgOptions %~ ((#outerPad .~ Nothing) . (#chartAspect .~ FixedAspect 1)) + where + ps = singletonArc p1 + (ArcCentroid c r phi' ang0 angd) = arcCentroid p1 + arc = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1!!2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) + ell = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . ellipse c r phi' . (\x -> ang0 + angd * x / 100.0) <$> [0..100]) + c0 = Chart (GlyphA defaultGlyphStyle) [PointXY c] + bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (arcBox p1)] + +-- | Reproduction of the flag explanation chart in +-- +-- ![arc flags example](other/arcflags.svg) +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 (Colour 1 0 1 0.3) & view #chartList, + checkFlags False False (Colour 0 1 0 0.3) & 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, + [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 & + #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] + 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 .~ 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]) + 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) = + mempty & + #chartList .~ [path', curve, c0, bbox] & + #hudOptions .~ defaultHudOptions & + #svgOptions %~ ((#outerPad ?~ 0.05) . (#chartAspect .~ ChartAspect)) + where + ps = singletonQuad p + path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1!!2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) + curve = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . quadBezier p . (/100.0) <$> [0..100]) + c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [start, end, control]) + bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (quadBox p)] + +-- | 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) = + 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) + ) & + #svgOptions %~ ((#outerPad ?~ 0.02) . (#chartAspect .~ ChartAspect)) + where + ps = singletonCubic p + path' = Chart (PathA (defaultPathStyle & #color .~ setOpac 0.1 (palette1!!2) & #borderColor .~ transparent) (fst <$> ps)) (PointXY . snd <$> ps) + curve = Chart (LineA $ defaultLineStyle & #width .~ 0.002 & #color .~ (palette1!!1)) (PointXY . cubicBezier p . (/100.0) <$> [0..100]) + c0 = Chart (GlyphA defaultGlyphStyle) (PointXY <$> [start, end, control1, control2, cubicBezier p 0.8]) + bbox = Chart (RectA $ defaultRectStyle & #borderSize .~ 0.002 & #color .~ Colour 0.4 0.4 0.8 0.1 & #borderColor .~ Colour 0.5 0.5 0.5 1) [RectXY (cubicBox p)] + 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) +-- +-- ![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 = + mempty & + #hudList .~ hs & + #chartList .~ cs & + #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp) + where + (cs, hs) = + surfacefl f + (defaultSurfaceOptions & + #soGrain .~ grain & + #soRange .~ r & + #soStyle . #surfaceColors .~ take 6 palette1) + (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) +-- +-- +arrowgExample :: + -- | Surface grid + Point Int -> + -- | Surface range + Rect Double -> + -- | Surface gradient function + (Point Double -> Point Double) -> + ChartSvg +arrowgExample grain r f = + mempty & + #hudOptions .~ (defaultHudOptions & #hudAxes %~ fmap (#axisTick . #ltick .~ Nothing)) & + #chartList .~ ((\p -> chart (tail . f $ p) (angle . f $ p) p) <$> ps) & + #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp) + where + ps = grid MidPos r grain + 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 & + #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 + + 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 +-- > = a^2 - 2ax + x^2 + b * y^2 - b * 2 * y * x^2 + b * x ^ 4 +-- > f'x = -2a + 2 * x - b * 4 * y * x + 4 * b * x ^ 3 +-- > 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)) + +-- | 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 - -- haddocks - let ls' = - fmap (PointXY . uncurry Point) - <$> [ [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0 :: Double)], - [(0.0, 0.0), (3.0, 3.0)], - [(0.5, 4.0), (0.5, 0)] - ] - let anns = - LineA - <$> [ defaultLineStyle & #color .~ (palette1 !! 0) & #width .~ 0.015, - defaultLineStyle & #color .~ (palette1 !! 1) & #width .~ 0.03, - defaultLineStyle & #color .~ (palette1 !! 5) & #width .~ 0.01 - ] - let lines' = zipWith Chart anns ls' - writeCharts "other/lines.svg" lines' - writeHudOptionsChart "other/linehud.svg" defaultSvgOptions defaultHudOptions [] lines' - writeCharts "other/unit.svg" [Chart (RectA defaultRectStyle) [one]] - 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]] - writeCharts "other/text.svg" t - writeCharts "other/glyph.svg" glyphs - writeHudOptionsChart "other/pixel.svg" defaultSvgOptions defaultHudOptions (snd pixelEx) (fst pixelEx) - writeChartsWith "other/svgoptions.svg" (defaultSvgOptions & #svgAspect .~ ManualAspect 0.7) lines' - writeHudOptionsChart "other/hud.svg" defaultSvgOptions defaultHudOptions [] [] - -- basics - writeCharts "other/mempty.svg" [] - writeChartExample "other/bar.svg" barExample - writeCharts "other/boundText.svg" boundTextBug - writeHudOptionsChart "other/legend.svg" defaultSvgOptions legendTest [] [] - putStrLn (" 👍" :: Text) + -- 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 + writeChartSvg "other/unit.svg" unitExample + writeChartSvg "other/rect.svg" rectExample + writeChartSvg "other/text.svg" textExample + writeChartSvg "other/glyphs.svg" glyphsExample + writeChartSvg "other/line.svg" lineExample + writeChartSvg "other/svgoptions.svg" svgOptionsExample + writeChartSvg "other/hudoptions.svg" hudOptionsExample + writeChartSvg "other/legend.svg" legendExample + -- charts in Chart.Bar + writeChartSvg "other/bar.svg" barExample + -- extra Charts in Chart.Example + 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/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/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) + + putStrLn ("ok" :: Text) diff --git a/src/Chart/Page.hs b/src/Chart/Page.hs deleted file mode 100644 --- a/src/Chart/Page.hs +++ /dev/null @@ -1,1158 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Chart.Page - ( repChartStaticData, - repAnnotation, - repRectStyle, - repTextStyle, - repGlyphStyle, - repLineStyle, - repPlace, - repAnchor, - repBar, - repAdjustments, - repTitle, - repHudOptions, - repAxisOptions, - repSvgOptions, - repData, - repFormatN, - repTickStyle, - repTick, - repPoint, - repPointI, - repRect, - repRectOne, - repRounded, - repTriple, - repGlyphShape, - repLegendOptions, - repChartsWithSharedData, - repChartsWithStaticData, - debugHtml, - debugFlags, - repHudOptionsDefault, - repBarOptions, - repBarData, - repBarChart, - repPixelOptions, - repPixelLegendOptions, - repPixelChart, - repNoData, - ) -where - -import Chart.Bar -import Data.FormatN -import Chart.Pixel -import Chart.Render (renderHudOptionsChart) -import Chart.Types -import Control.Lens -import Data.Attoparsec.Text -import Data.Colour -import qualified Data.Text as Text -import Lucid -import NumHask.Prelude -import NumHask.Space -import Text.Pretty.Simple (pShowNoColor) -import Web.Rep - -pShow' :: (Show a) => a -> Text -pShow' = toStrict . pShowNoColor - -repChartStaticData :: (Monad m) => Chart a -> SharedRep m (Chart a) -repChartStaticData c = do - ann <- repAnnotation (c ^. #annotation) - pure $ Chart ann (c ^. #xys) - -repAnnotation :: (Monad m) => Annotation -> SharedRep m Annotation -repAnnotation initann = bimap hmap mmap rann <<*>> rs <<*>> ts <<*>> gs <<*>> ls <<*>> ps - where - rann = - dropdownSum - takeText - id - (Just "Chart Annotation") - ["RectA", "TextA", "GlyphA", "LineA", "BlankA", "PixelA"] - (annotationText initann) - rs = repRectStyle defRectStyle - ts = repTextStyle defText - gs = repGlyphStyle defGlyph - ls = repLineStyle defLine - ps = repPixelStyle defPixel - hmap ann rs ts gs ls ps = - ann - <> subtype rs (annotationText initann) "RectA" - <> subtype ts (annotationText initann) "TextA" - <> subtype gs (annotationText initann) "GlyphA" - <> subtype ls (annotationText initann) "LineA" - <> subtype ps (annotationText initann) "PixelA" - mmap ann rs ts gs ls ps = - case ann of - "RectA" -> RectA rs - "TextA" -> TextA ts texts - "GlyphA" -> GlyphA gs - "LineA" -> LineA ls - "BlankA" -> BlankA - "PixelA" -> PixelA ps - _ -> BlankA - defRectStyle = case initann of - RectA s -> s - _ -> defaultRectStyle - defPixel = case initann of - PixelA s -> s - _ -> defaultPixelStyle - (defText, texts) = case initann of - TextA s xs -> (s, xs) - _ -> (defaultTextStyle, Text.singleton <$> ['a' .. 'z']) - defGlyph = case initann of - GlyphA s -> s - _ -> defaultGlyphStyle - defLine = case initann of - LineA s -> s - _ -> defaultLineStyle - -repRectStyle :: (Monad m) => RectStyle -> SharedRep m RectStyle -repRectStyle s = do - bs <- slider (Just "border size") 0.0 0.1 0.001 (s ^. #borderSize) - bc <- colorPicker (Just "border color") (hex $ s ^. #borderColor) - bo <- slider (Just "border opacity") 0 1 0.1 (opac $ s ^. #borderColor) - c <- colorPicker (Just "color") (hex $ s ^. #color) - o <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color) - pure $ RectStyle bs (fromRGB (unsafeFromHex bc) bo) (fromRGB (unsafeFromHex c) o) - -repPixelStyle :: - (Monad m) => - PixelStyle -> - SharedRep m PixelStyle -repPixelStyle cfg = - bimap hmap mmap (unsafeFromHex <$> pcmin) - <<*>> pomin - <<*>> (unsafeFromHex <$> pcmax) - <<*>> pomax - <<*>> pd - <<*>> prs - <<*>> pt - where - pcmax = colorPicker (Just "high color") (toHex $ cfg ^. #pixelColorMax) - pcmin = colorPicker (Just "low color") (toHex $ cfg ^. #pixelColorMin) - pomax = slider (Just "high opacity") 0.0 1.0 0.001 (opac $ cfg ^. #pixelColorMax) - pomin = slider (Just "low opacity") 0.0 1.0 0.001 (opac $ cfg ^. #pixelColorMin) - pd = slider (Just "gradient direction") 0.0 (2 * pi) 0.001 (cfg ^. #pixelGradient) - prs = repRectStyle (cfg ^. #pixelRectStyle) - pt = textbox (Just "texture id") (cfg ^. #pixelTextureId) - hmap pcmin' pomin' pcmax' pomax' pd' prs' pt' = - pcmin' <> pomin' <> pcmax' <> pomax' <> pd' <> prs' <> pt' - mmap pcmin' pomin' pcmax' pomax' pd' prs' pt' = - PixelStyle (fromRGB pcmin' pomin') (fromRGB pcmax' pomax') pd' prs' pt' - -repGlyphStyle :: (Monad m) => GlyphStyle -> SharedRep m GlyphStyle -repGlyphStyle gs = first (\x -> cardify (mempty, [style_ "width: 10 rem;"]) Nothing (x, [])) $ do - sh <- repGlyphShape (gs ^. #shape) - sz <- slider (Just "Size") 0 0.2 0.001 (gs ^. #size) - gc <- - colorPicker - (Just "Color") - (toHex $ gs ^. #color) - go <- slider (Just "Opacity") 0 1 0.1 (opac $ gs ^. #color) - bsz <- slider (Just "Border Size") 0 0.02 0.001 (gs ^. #borderSize) - gbc <- colorPicker (Just "Border Color") (toHex $ gs ^. #borderColor) - gbo <- slider (Just "Border Opacity") 0 1 0.1 (opac $ gs ^. #borderColor) - tr <- - maybeRep - (Just "rotation") - (isJust (gs ^. #rotation)) - (slider (Just "rotation") (-180) 180 10 (fromMaybe 0 (gs ^. #rotation))) - tt <- - maybeRep - (Just "translate") - (isJust (gs ^. #translate)) - ( repPoint - (Point (Range 0 1) (Range 0 1)) - (Point 0.001 0.001) - (Point 0 0) - ) - pure (GlyphStyle sz (fromRGB (unsafeFromHex gc) go) (fromRGB (unsafeFromHex gbc) gbo) bsz sh tr tt) - -repTextStyle :: (Monad m) => TextStyle -> SharedRep m TextStyle -repTextStyle s = do - ts <- slider (Just "size") 0.02 0.2 0.01 (s ^. #size) - tc <- colorPicker (Just "color") (toHex $ s ^. #color) - to' <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color) - ta <- repAnchor (s ^. #anchor) - th <- slider (Just "hsize") 0.2 1 0.05 (s ^. #hsize) - tv <- slider (Just "vsize") 0.5 2 0.05 (s ^. #vsize) - tn <- slider (Just "nudge1") (-0.5) 0.5 0.05 (s ^. #nudge1) - tr <- - maybeRep - (Just "rotation") - (isJust (s ^. #rotation)) - (slider (Just "rotation") (-180) 180 10 (fromMaybe 0 (s ^. #rotation))) - tt <- - maybeRep - (Just "translate") - (isJust (s ^. #translate)) - ( repPoint - (Point (Range 0 1) (Range 0 1)) - (Point 0.001 0.001) - (Point 0 0) - ) - tm <- checkbox (Just "mathjax") (s ^. #hasMathjax) - pure $ TextStyle ts (fromRGB (unsafeFromHex tc) to') ta th tv tn tr tt tm - -repLineStyle :: (Monad m) => LineStyle -> SharedRep m LineStyle -repLineStyle s = do - w <- slider (Just "width") 0.000 0.05 0.001 (s ^. #width) - c <- colorPicker (Just "color") (toHex $ s ^. #color) - o <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color) - pure $ LineStyle w (fromRGB (unsafeFromHex c) o) - -repPlace :: (Monad m) => Place -> SharedRep m Place -repPlace initpl = bimap hmap mmap rplace <<*>> rp - where - rplace = - dropdownSum - takeText - id - (Just "Placement") - [ "Bottom", - "Left", - "Top", - "Right", - "Absolute" - ] - (placeText initpl) - rp = repPoint (Point (Range 0 1) (Range 0 1)) (Point 0.01 0.01) (defPoint initpl) - defPoint pl = case pl of - PlaceAbsolute p -> p - _ -> Point 0.0 0.0 - hmap rplace rp = - div_ - ( rplace - <> subtype rp (placeText initpl) "Absolute" - ) - mmap rplace rp = case rplace of - "Top" -> PlaceTop - "Bottom" -> PlaceBottom - "Left" -> PlaceLeft - "Right" -> PlaceRight - "Absolute" -> PlaceAbsolute rp - _ -> PlaceBottom - -repAnchor :: (Monad m) => Anchor -> SharedRep m Anchor -repAnchor a = - toAnchor - <$> dropdown - takeText - id - (Just "Anchor") - (fromAnchor <$> [AnchorStart, AnchorMiddle, AnchorEnd]) - (fromAnchor a) - -repDirection :: (Monad m) => Direction -> SharedRep m Direction -repDirection a = - toDirection - <$> dropdown - takeText - id - (Just "Direction") - (fromDirection <$> [Vert, Hori]) - (fromDirection a) - -repBar :: (Monad m) => Bar -> SharedRep m Bar -repBar cfg = do - r <- repRectStyle (cfg ^. #rstyle) - w <- slider (Just "width") 0 0.04 0.001 (cfg ^. #wid) - b <- slider (Just "buffer") 0 0.08 0.001 (cfg ^. #buff) - pure $ Bar r w b - -repAdjustments :: (Monad m) => Adjustments -> SharedRep m Adjustments -repAdjustments a = do - maxx <- slider (Just "maximum x ratio") 0.000 0.2 0.001 (a ^. #maxXRatio) - maxy <- slider (Just "maximum y ratio") 0.000 0.2 0.001 (a ^. #maxYRatio) - angle <- slider (Just "angle ratio") 0.000 1 0.001 (a ^. #angledRatio) - diag <- checkbox (Just "allow diagonal text") (a ^. #allowDiagonal) - pure $ Adjustments maxx maxy angle diag - -repTitle :: (Monad m) => Title -> SharedRep m Title -repTitle cfg = do - ttext <- textbox (Just "text") (cfg ^. #text) - ts <- repTextStyle (cfg ^. #style) - tp <- repPlace (cfg ^. #place) - ta <- repAnchor (cfg ^. #anchor) - b <- slider (Just "buffer") 0 0.2 0.01 (cfg ^. #buff) - pure $ Title ttext ts tp ta b - -repHudOptions :: - (Monad m) => - Int -> - Int -> - Int -> - AxisOptions -> - Title -> - LegendOptions -> - [(Annotation, Text)] -> - Annotation -> - Text -> - HudOptions -> - SharedRep m HudOptions -repHudOptions naxes ntitles nlegendRows defaxis deftitle deflegend deflrs defann deflabel cfg = - bimap hmap (\a b c d -> HudOptions a b c d) can - <<*>> ts - <<*>> axs - <<*>> l - where - can = - maybeRep (Just "canvas") (isJust (cfg ^. #hudCanvas)) $ - repRectStyle (fromMaybe defaultCanvas (cfg ^. #hudCanvas)) - ts = - listRep - (Just "titles") - "tz" - (checkbox Nothing) - repTitle - ntitles - deftitle - (cfg ^. #hudTitles) - axs = - listRep - (Just "axes") - "axz" - (checkbox Nothing) - repAxisOptions - naxes - defaxis - (cfg ^. #hudAxes) - labelsc = - listRep - (Just "labelsc") - "labelscz" - (checkbox Nothing) - (textbox Nothing) - nlegendRows - deflabel - (snd <$> deflrs) - anns = - listRep - (Just "annotations") - "annsz" - (checkbox Nothing) - repAnnotation - nlegendRows - defann - (fst <$> deflrs) - l = - maybeRep - (Just "legend") - (isJust $ cfg ^. #hudLegend) - ( (,) - <$> repLegendOptions (maybe deflegend fst (cfg ^. #hudLegend)) - <*> (zip <$> anns <*> labelsc) - ) - hmap can' ts' axs' l' = - accordion_ - "accc" - Nothing - [ ("Axes", axs'), - ("Canvas", can'), - ("Titles", ts'), - ("Legend", l') - ] - -repAxisOptions :: (Monad m) => AxisOptions -> SharedRep m AxisOptions -repAxisOptions cfg = bimap hmap AxisOptions b <<*>> adj <<*>> t <<*>> p - where - b = - maybeRep - (Just "axis bar") - (isJust (cfg ^. #abar)) - (repBar (fromMaybe defaultBar (cfg ^. #abar))) - adj = - maybeRep - (Just "adjustments") - (isJust (cfg ^. #adjust)) - (repAdjustments (fromMaybe defaultAdjustments (cfg ^. #adjust))) - t = repTick (cfg ^. #atick) - p = repPlace (cfg ^. #place) - hmap b' hauto' t' p' = - accordion_ - "accaxis" - Nothing - [ ("Bar", b'), - ("Auto", hauto'), - ("Ticks", t'), - ("Place", p') - ] - -repSvgAspect :: (Monad m) => SvgAspect -> Double -> SharedRep m SvgAspect -repSvgAspect sa ddef = - bimap hmap toSvgAspect sa' <<*>> td - where - sa' = - dropdownSum - takeText - id - (Just "Aspect") - [ "ManualAspect", - "ChartsAspect" - ] - (fromSvgAspect sa) - td = slider (Just "aspect scale") 0 10 0.01 (defD ddef) - defD d' = case sa of - ManualAspect d -> d - ChartAspect -> d' - hmap sa'' td' = - div_ - ( sa'' - <> subtype td' (fromSvgAspect sa) "ManualAspect" - ) - -repSvgOptions :: (Monad m) => SvgOptions -> SharedRep m SvgOptions -repSvgOptions s = - bimap - hmap - SvgOptions - h' - <<*>> op' - <<*>> ip - <<*>> fr - <<*>> esc - <<*>> csso - <<*>> scalec - <<*>> svga - where - svga = repSvgAspect (s ^. #svgAspect) 1.33 - h' = slider (Just "height") 1 1000 1 (s ^. #svgHeight) - op' = - maybeRep - (Just "outer pad") - (isJust (s ^. #outerPad)) - (slider Nothing 0 0.1 0.01 (fromMaybe 1 (s ^. #outerPad))) - ip = - maybeRep - (Just "inner pad") - (isJust (s ^. #innerPad)) - (slider Nothing 0 0.1 0.01 (fromMaybe 1 (s ^. #innerPad))) - fr = - maybeRep - (Just "frame") - (isJust (s ^. #chartFrame)) - (repRectStyle (fromMaybe defaultSvgFrame (s ^. #chartFrame))) - esc = - bool NoEscapeText EscapeText - <$> checkbox (Just "escape text") (EscapeText == s ^. #escapeText) - csso = - bool NoCssOptions UseCssCrisp - <$> checkbox (Just "Use CssCrisp") (UseCssCrisp == s ^. #useCssCrisp) - scalec = - bool NoScaleCharts ScaleCharts - <$> checkbox (Just "Scale Charts") (ScaleCharts == s ^. #scaleCharts') - hmap h' op'' ip' fr' esc' csso' scalec' svga' = - accordion_ - "accsvg" - Nothing - [ ("Aspect", svga' <> h'), - ("Padding", op'' <> ip'), - ("Frame", fr'), - ("Escape", esc'), - ("Css", csso'), - ("Scale", scalec') - ] - -repData :: (Monad m) => Text -> SharedRep m [XY Double] -repData d = do - a <- - dropdown - takeText - id - (Just "type") - [ "sin", - "line", - "one", - "dist" - ] - d - pure - ( case a of - "sin" -> PointXY <$> gridP sin (Range 0 (2 * pi)) 30 - "line" -> - PointXY . uncurry Point - <$> [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)] - "one" -> [R 0 1 0 1] - "dist" -> RectXY <$> gridR (\x -> exp (- (x ** 2) / 2)) (Range (-5) 5) 50 - _ -> PointXY <$> gridP sin (Range 0 (2 * pi)) 30 - ) - -repFormatN :: (Monad m) => FormatN -> SharedRep m FormatN -repFormatN tf = bimap hmap mmap tformat <<*>> tcommas <<*>> tfixed <<*>> texpt <<*>> tpercent <<*>> tprec <<*>> tdecimal <<*>> tdollar - where - tformat = - dropdownSum - takeText - id - (Just "Format") - [ "Comma", - "Fixed", - "Decimal", - "Prec", - "Expt", - "Dollar", - "Percent", - "None" - ] - (fromFormatN tf) - tcommas = maybeRep Nothing (defSig tf) (sliderI (Just "prec") 0 8 1 (defInt tf)) - tfixed = maybeRep Nothing (defSig tf) $ sliderI (Just "prec") 0 8 1 (defInt tf) - texpt = maybeRep Nothing (defSig tf) $ sliderI (Just "prec") 0 8 1 (defInt tf) - tpercent = maybeRep Nothing (defSig tf) $ sliderI (Just "prec") 0 8 1 (defInt tf) - tprec = maybeRep Nothing (defSig tf) $ sliderI (Just "prec") 0 8 1 (defInt tf) - tdecimal = maybeRep Nothing (defSig tf) $ sliderI (Just "prec") 0 8 1 (defInt tf) - tdollar = maybeRep Nothing (defSig tf) $ sliderI (Just "prec") 0 8 1 (defInt tf) - defInt tf' = case tf' of - FormatComma (Just n) -> n - FormatFixed (Just n) -> n - FormatDecimal (Just n) -> n - FormatPrec (Just n) -> n - FormatExpt (Just n) -> n - FormatDollar (Just n) -> n - FormatPercent (Just n) -> n - _ -> 3 - defSig tf' = case tf' of - FormatComma (Just _) -> True - FormatFixed (Just _) -> True - FormatDecimal (Just _) -> True - FormatPrec (Just _) -> True - FormatExpt (Just _) -> True - FormatDollar (Just _) -> True - FormatPercent (Just _) -> True - _ -> False - hmap tformat' tcommas' tfixed' texpt' tpercent' tprec' tdecimal' tdollar' = - div_ - ( tformat' - <> subtype tcommas' (fromFormatN tf) "Comma" - <> subtype tfixed' (fromFormatN tf) "Fixed" - <> subtype texpt' (fromFormatN tf) "Expt" - <> subtype tpercent' (fromFormatN tf) "Percent" - <> subtype tprec' (fromFormatN tf) "Prec" - <> subtype tdecimal' (fromFormatN tf) "Decimal" - <> subtype tdollar' (fromFormatN tf) "Dollar" - ) - mmap tformat' tcommas' tfixed' texpt' tpercent' tprec' tdecimal' tdollar' = case tformat' of - "Comma" -> FormatComma tcommas' - "Fixed" -> FormatFixed tfixed' - "Decimal" -> FormatDecimal tdecimal' - "Prec" -> FormatPrec tprec' - "Expt" -> FormatExpt texpt' - "Dollar" -> FormatDollar tdollar' - "Percent" -> FormatPercent tpercent' - "None" -> FormatNone - _ -> FormatNone - -repTickStyle :: (Monad m) => TickStyle -> SharedRep m TickStyle -repTickStyle cfg = - bimap hmap mmap ts <<*>> ls <<*>> tr <<*>> te <<*>> tplaced - where - ts = - dropdownSum - takeText - id - (Just "Tick Style") - ["TickNone", "TickLabels", "TickRound", "TickExact", "TickPlaced"] - (tickStyleText cfg) - ls = - accordionList - (Just "tick labels") - "tick-style-labels" - Nothing - (textbox . Just) - (defaultListLabels (length defLabels)) - defLabels - tr = - (,,) - <$> sliderI (Just "Number of ticks") 0 20 1 defTn - <*> repFormatN defTf - <*> ( bool NoTickExtend TickExtend - <$> checkbox (Just "extend") defExtend - ) - te = - (,) - <$> sliderI (Just "Number of ticks") 0 20 1 defTn - <*> repFormatN defTf - tplaced = - accordionList - (Just "placed ticks") - "tick-style-placed" - Nothing - dt - (defaultListLabels (length dtDef)) - dtDef - hmap ts' ls' tr' te' tplaced' = - div_ - ( ts' - <> subtype ls' (tickStyleText cfg) "TickLabels" - <> subtype tr' (tickStyleText cfg) "TickRound" - <> subtype te' (tickStyleText cfg) "TickExact" - <> subtype tplaced' (tickStyleText cfg) "TickPlaced" - ) - mmap ts' ls' (tri, trf, tre) (tei, tef) tplaced' = case ts' of - "TickNone" -> TickNone - "TickLabels" -> TickLabels ls' - "TickRound" -> TickRound trf tri tre - "TickExact" -> TickExact tef tei - "TickPlaced" -> TickPlaced tplaced' - _ -> TickNone - dtDef = case cfg of - TickPlaced x -> x - _ -> zip [0 .. 5] (pack . show <$> [0 .. 5 :: Int]) - dt _ (x, l) = (,) <$> slider (Just "placement") 0 1 0.01 x <*> textbox (Just "label") l - defLabels = case cfg of - TickLabels xs -> xs - _ -> replicate 5 "" - defTn = case cfg of - TickRound _ x _ -> x - TickExact _ x -> x - _ -> 8 - defTf = case cfg of - TickRound x _ _ -> x - TickExact x _ -> x - _ -> FormatPrec (Just 3) - defExtend = case cfg of - TickRound _ _ e -> e == TickExtend - _ -> True - -repTick :: (Monad m) => Tick -> SharedRep m Tick -repTick cfg = bimap hmap Tick ts <<*>> gt <<*>> tt <<*>> lt - where - hmap ts' gt' tt' lt' = - accordion_ - "acctick" - Nothing - [ ("style", ts'), - ("glyph", gt'), - ("text", tt'), - ("line", lt') - ] - ts = repTickStyle (cfg ^. #tstyle) - gt = - maybeRep Nothing (isJust (cfg ^. #gtick)) $ - bimap - (<>) - (,) - (repGlyphStyle (maybe defaultGlyphTick fst (cfg ^. #gtick))) - <<*>> slider (Just "buffer") 0 0.05 0.001 (maybe 0.05 snd (cfg ^. #gtick)) - tt = - maybeRep Nothing (isJust (cfg ^. #ttick)) $ - bimap - (<>) - (,) - (repTextStyle (maybe defaultTextTick fst (cfg ^. #ttick))) - <<*>> slider (Just "buffer") 0 0.05 0.001 (maybe 0.05 snd (cfg ^. #ttick)) - lt = - maybeRep Nothing (isJust (cfg ^. #ltick)) $ - bimap - (<>) - (,) - (repLineStyle (maybe defaultLineTick fst (cfg ^. #ltick))) - <<*>> slider (Just "buffer") (-0.1) 0.1 0.001 (maybe 0 snd (cfg ^. #ltick)) - -repPoint :: - (Monad m) => - Point (Range Double) -> - Point Double -> - Point Double -> - SharedRep m (Point Double) -repPoint (Point (Range xmin xmax) (Range ymin ymax)) (Point xstep ystep) (Point x y) = - bimap - (<>) - Point - (slider (Just "x") xmin xmax xstep x) - <<*>> slider (Just "y") ymin ymax ystep y - -repPointI :: - (Monad m) => - Point (Range Int) -> - Point Int -> - Point Int -> - SharedRep m (Point Int) -repPointI (Point (Range xmin xmax) (Range ymin ymax)) (Point xstep ystep) (Point x y) = - bimap - (<>) - Point - (sliderI (Just "x") xmin xmax xstep x) - <<*>> sliderI (Just "y") ymin ymax ystep y - -repRect :: (Monad m) => Rect (Range Double) -> Rect Double -> Rect Double -> SharedRep m (Rect Double) -repRect (Rect (Range xmin xmax) (Range zmin zmax) (Range ymin ymax) (Range wmin wmax)) (Rect xstep zstep ystep wstep) (Rect x z y w) = - bimap - (\a b c d -> a <> b <> c <> d) - Rect - (slider (Just "x") xmin xmax xstep x) - <<*>> slider (Just "z") zmin zmax zstep z - <<*>> slider (Just "y") ymin ymax ystep y - <<*>> slider (Just "w") wmin wmax wstep w - -repRectOne :: (Monad m) => Rect Double -> SharedRep m (Rect Double) -repRectOne a = repRect (Rect (Range 0 1) (Range 0 1) (Range 0 1) (Range 0 1)) (Rect 0.01 0.01 0.01 0.01) a - -repRounded :: (Monad m) => (Double, Double, Double) -> SharedRep m (Double, Double, Double) -repRounded (a, b, c) = - bimap - (\a' b' c' -> a' <> b' <> c') - (,,) - (slider Nothing 0 1 0.001 a) - <<*>> slider Nothing 0 1 0.001 b - <<*>> slider Nothing 0 1 0.001 c - -repTriple :: (Monad m) => (a, a, a) -> (a -> SharedRep m a) -> SharedRep m (a, a, a) -repTriple (a, b, c) sr = - bimap (\a' b' c' -> a' <> b' <> c') (,,) (sr a) <<*>> sr b <<*>> sr c - -repGlyphShape :: (Monad m) => GlyphShape -> SharedRep m GlyphShape -repGlyphShape sh = bimap hmap mmap sha <<*>> ell <<*>> rsharp <<*>> rround <<*>> tri <<*>> p <<*>> lwidth - where - sha = - dropdownSum - takeText - id - Nothing - [ "Circle", - "Square", - "Triangle", - "Ellipse", - "RectSharp", - "RectRounded", - "VLine", - "HLine", - "Path" - ] - (glyphText sh) - ell = slider Nothing 0.5 2 0.01 defRatio - rsharp = slider Nothing 0.5 2 0.01 defRatio - rround = repRounded defRounded - lwidth = slider (Just "width") 0.001 0.02 0.001 defLwidth - tri = - repTriple - defTriangle - ( repPoint - (Point (Range 0 1) (Range 0 1)) - (Point 0.001 0.001) - ) - p = textbox (Just "path") defP - hmap sha' ell' rsharp' rround' tri' p' lwidth' = - sha' - <> subtype ell' (glyphText sh) "Ellipse" - <> subtype rsharp' (glyphText sh) "RectSharp" - <> subtype rround' (glyphText sh) "RectRounded" - <> subtype tri' (glyphText sh) "Triangle" - <> subtype lwidth' (glyphText sh) "VLine" - <> subtype lwidth' (glyphText sh) "HLine" - <> subtype p' (glyphText sh) "Path" - mmap sha' ell' rsharp' rround' tri' p' lwidth' = - case sha' of - "Circle" -> CircleGlyph - "Square" -> SquareGlyph - "Ellipse" -> EllipseGlyph ell' - "RectSharp" -> RectSharpGlyph rsharp' - "RectRounded" -> (\(a, b, c) -> RectRoundedGlyph a b c) rround' - "Triangle" -> (\(a, b, c) -> TriangleGlyph a b c) tri' - "VLine" -> VLineGlyph lwidth' - "HLine" -> HLineGlyph lwidth' - "Path" -> PathGlyph p' - _ -> CircleGlyph - defP = case sh of - PathGlyph p -> p - _ -> mempty - defRatio = case sh of - EllipseGlyph r -> r - RectSharpGlyph r -> r - _ -> 1.5 - defLwidth = case sh of - VLineGlyph r -> r - HLineGlyph r -> r - _ -> 0.005 - defRounded = case sh of - RectRoundedGlyph a b c -> (a, b, c) - _ -> (0.884, 2.7e-2, 5.0e-2) - defTriangle = case sh of - TriangleGlyph a b c -> (a, b, c) - _ -> (Point 0.0 0.0, Point 1 1, Point 1 0) - -repLegendOptions :: (Monad m) => LegendOptions -> SharedRep m LegendOptions -repLegendOptions initl = - bimap - hmap - LegendOptions - lsize' - <<*>> vgap' - <<*>> hgap' - <<*>> ltext' - <<*>> lmax' - <<*>> innerPad' - <<*>> outerPad' - <<*>> legendFrame' - <<*>> lplace' - <<*>> scale' - where - lsize' = slider (Just "element size") 0.000 1 0.001 (initl ^. #lsize) - hgap' = slider (Just "horizontal gap") 0.000 0.5 0.001 (initl ^. #hgap) - vgap' = slider (Just "vertical gap") 0.000 0.5 0.001 (initl ^. #vgap) - ltext' = repTextStyle (initl ^. #ltext) - lmax' = sliderI (Just "max entries") 0 10 1 (initl ^. #lmax) - innerPad' = - slider - (Just "inner padding") - 0 - 0.2 - 0.001 - (initl ^. #innerPad) - outerPad' = - slider - (Just "outer padding") - 0 - 0.2 - 0.001 - (initl ^. #outerPad) - legendFrame' = - maybeRep - (Just "frame") - (isJust (initl ^. #legendFrame)) - (repRectStyle (fromMaybe defaultSvgFrame (initl ^. #legendFrame))) - lplace' = repPlace (initl ^. #lplace) - scale' = slider (Just "scale") 0.01 1 0.001 (initl ^. #lscale) - hmap lsize'' vgap'' hgap'' ltext'' lmax'' innerPad'' outerPad'' legendFrame'' lplace'' scale'' = - accordion_ - "accleg" - Nothing - [ ("Scale", scale'' <> lsize''), - ("Pads", innerPad'' <> outerPad'' <> vgap'' <> hgap''), - ("Text", ltext''), - ("Frame", legendFrame''), - ("Place", lplace''), - ("Max Elements", lmax'') - ] - -repChartsWithSharedData :: - (Monad m) => - SvgOptions -> - HudOptions -> - Int -> - [Chart Double] -> - ([[XY Double]] -> SharedRep m [[XY Double]]) -> - SharedRep m (Text, Text) -repChartsWithSharedData css' hc' maxcs' cs' sxys = - bimap - hmap - mmap - cssr - <<*>> annsr - <<*>> sxys xys' - <<*>> hr - <<*>> debugFlags - where - xys' = view #xys <$> cs' - anns' = view #annotation <$> cs' - hr = - repHudOptions - 2 - 3 - 5 - defaultAxisOptions - (defaultTitle "default") - (maybe defaultLegendOptions fst (hc' ^. #hudLegend)) - (maybe [] snd (hc' ^. #hudLegend)) - BlankA - "" - hc' - cssr = repSvgOptions css' - annsr = - listRep - (Just "Annotations") - "annz" - (checkbox Nothing) - repAnnotation - maxcs' - BlankA - anns' - mmap css'' ann' d' h' debug' = - let ch = zipWith Chart ann' d' - in ( renderHudOptionsChart css'' h' [] ch, - debugHtml debug' css'' h' ch - ) - hmap css'' ann' _ h' debug' = - accordion_ - "acca" - Nothing - [ ("Svg", css''), - ("Annotations", ann'), - ("Hud", h'), - ("Debug", debug') - ] - -repChartsWithStaticData :: - (Monad m) => - SvgOptions -> - HudOptions -> - Int -> - [Chart Double] -> - SharedRep m (Text, Text) -repChartsWithStaticData css' hc' maxcs' cs' = - repChartsWithSharedData css' hc' maxcs' cs' (bipure mempty) - -debugHtml :: (Bool, Bool, Bool) -> SvgOptions -> HudOptions -> [Chart Double] -> Text -debugHtml debug css hc cs = - bool - mempty - ( mconcat $ - (\x -> "

" <> x <> "

") - <$> [ "

config values

", - pShow' css, - pShow' hc - ] - ) - ((\(a, _, _) -> a) debug) - <> bool - mempty - ( mconcat - [ "

chart svg

", - "", - renderHudOptionsChart css hc [] cs, - "" - ] - ) - ((\(_, a, _) -> a) debug) - <> bool - mempty - ( mconcat $ - (\x -> "

" <> x <> "

") - <$> [ "

chart value

", - pack $ show cs - ] - ) - ((\(_, _, a) -> a) debug) - -debugFlags :: (Monad m) => SharedRepF m (Html ()) (Bool, Bool, Bool) -debugFlags = - bimap - (\a b c -> a <> b <> c) - (,,) - (checkbox (Just "show hudOptions values") False) - <<*>> checkbox (Just "show chart svg") False - <<*>> checkbox (Just "show Chart values") False - -repHudOptionsDefault :: Monad m => HudOptions -> SharedRep m HudOptions -repHudOptionsDefault hc = - repHudOptions - 2 - 3 - 5 - defaultAxisOptions - (defaultTitle "default") - defaultLegendOptions - [] - BlankA - "" - hc - -repBarOptions :: - (Monad m) => - Int -> - RectStyle -> - TextStyle -> - BarOptions -> - SharedRep m BarOptions -repBarOptions nrows defrs defts cfg = - bimap hmap BarOptions rs - <<*>> ts - <<*>> og - <<*>> ig - <<*>> tg - <<*>> tgn - <<*>> dv - <<*>> fn - <<*>> av - <<*>> or - <<*>> ho - where - rs = - listRep - (Just "bar styles") - "rs" - (checkbox Nothing) - repRectStyle - nrows - defrs - (cfg ^. #barRectStyles) - ts = - listRep - (Just "text styles") - "ts" - (checkbox Nothing) - repTextStyle - nrows - defts - (cfg ^. #barTextStyles) - og = slider (Just "outer gap") 0.0 1.0 0.001 (cfg ^. #outerGap) - ig = slider (Just "inner gap") (-1.0) 1 0.001 (cfg ^. #innerGap) - tg = slider (Just "text gap") (-0.05) 0.05 0.001 (cfg ^. #textGap) - tgn = slider (Just "neg. text gap") 0 0.1 0.001 (cfg ^. #textGapNegative) - dv = checkbox (Just "display values") (cfg ^. #displayValues) - fn = repFormatN (cfg ^. #valueFormatN) - av = checkbox (Just "accumulate values") (cfg ^. #accumulateValues) - or = repDirection (cfg ^. #barOrientation) - ho = - repHudOptions - 2 - 3 - 5 - defaultAxisOptions - (defaultTitle "bar options") - (maybe defaultLegendOptions fst (cfg ^. #barHudOptions . #hudLegend)) - (maybe [] snd (cfg ^. #barHudOptions . #hudLegend)) - BlankA - "" - (cfg ^. #barHudOptions) - hmap rs' ts' og' ig' tg' tgn' dv' fn' av' or' ho' = - accordion_ - "accbo" - Nothing - [ ("Bar Styles", rs'), - ("Text Styles", ts'), - ("Gaps", og' <> ig' <> tg' <> tgn'), - ("Style", dv' <> fn' <> av' <> or'), - ("Hud", ho') - ] - -repBarData :: - (Monad m) => - BarData -> - SharedRep m BarData -repBarData initbd = - bimap hmap BarData bd - <<*>> rl - <<*>> cl - where - rl = - maybeRep - Nothing - (isJust (initbd ^. #barRowLabels)) - ( either (const []) id - <$> readTextbox (Just "row labels") (fromMaybe [] (initbd ^. #barRowLabels)) - ) - cl = - maybeRep - Nothing - (isJust (initbd ^. #barColumnLabels)) - ( either (const []) id - <$> readTextbox (Just "column labels") (fromMaybe [] (initbd ^. #barColumnLabels)) - ) - bd = - either (const (pure [])) id - <$> readTextbox (Just "bar data") (initbd ^. #barData) - hmap rl' cl' bd' = rl' <> cl' <> bd' - -repPixelOptions :: - (Monad m) => - PixelOptions -> - SharedRep m PixelOptions -repPixelOptions cfg = - bimap hmap PixelOptions ps - <<*>> pg - <<*>> pr - where - ps = repPixelStyle (cfg ^. #poStyle) - pg = repPointI (Point (Range 1 100) (Range 1 100)) (Point 1 1) (cfg ^. #poGrain) - pr = repRect (Rect (Range 0 5) (Range 0 5) (Range 0 5) (Range 0 5)) (Rect 0.01 0.01 0.01 0.01) (cfg ^. #poRange) - hmap ps' pg' pr' = - accordion_ - "accpixel" - Nothing - [ ("Grain", pg'), - ("Range", pr'), - ("Style", ps') - ] - -repPixelLegendOptions :: - (Monad m) => - PixelLegendOptions -> - SharedRep m PixelLegendOptions -repPixelLegendOptions cfg = - bimap hmap PixelLegendOptions ps - <<*>> pt - <<*>> pw - <<*>> pa - <<*>> pl - where - ps = repPixelStyle (cfg ^. #ploStyle) - pt = textbox (Just "title") (cfg ^. #ploTitle) - pw = slider (Just "width") 0.0 0.3 0.001 (cfg ^. #ploWidth) - pa = repAxisOptions (cfg ^. #ploAxisOptions) - pl = repLegendOptions (cfg ^. #ploLegendOptions) - hmap ps' pt' pw' pa' pl' = - accordion_ - "accplo" - Nothing - [ ("Style", ps'), - ("Title", pt'), - ("Width", pw'), - ("Axis", pa'), - ("Legend", pl') - ] - -repBarChart :: (Monad m) => SvgOptions -> BarData -> BarOptions -> SharedRep m (Text, Text) -repBarChart css bd bo = bimap hmap mmap rcss <<*>> rbd <<*>> rbo <<*>> debugFlags - where - rcss = repSvgOptions css - rbo = repBarOptions 5 defaultRectStyle defaultTextStyle bo - rbd = repBarData bd - barchartsvg css' bd' bo' = - let (hc', cs') = barChart bo' bd' - in renderHudOptionsChart css' hc' [] cs' - mmap css' bd' bo' debug = - ( barchartsvg css' bd' bo', - debugHtml debug css' (bo' ^. #barHudOptions) (bars bo' bd') - ) - hmap css' bd' bo' debug = - accordion_ - "accbc" - Nothing - [ ("Svg", css'), - ("Bar Data", bd'), - ("Bar Options", bo'), - ("Debug", debug) - ] - -repPixelChart :: - (Monad m) => - (SvgOptions, PixelOptions, HudOptions, PixelLegendOptions, Point Double -> Double) -> - SharedRep m (Text, Text) -repPixelChart (css, po, hc, plo, f) = bimap hmap mmap rcss <<*>> rpo <<*>> rhc <<*>> rplo <<*>> debugFlags - where - rcss = repSvgOptions css - rpo = repPixelOptions po - rhc = repHudOptionsDefault hc - rplo = repPixelLegendOptions plo - mmap rcss' rpo' rhc' rplo' debug = - let (cs, hs) = pixelfl f rpo' rplo' - in ( renderHudOptionsChart rcss' rhc' hs cs, - debugHtml debug rcss' rhc' [] - ) - hmap rcss' rpo' rhc' rplo' debug = - accordion_ - "accpc" - Nothing - [ ("Svg", rcss'), - ("Hud", rhc'), - ("Pixel Options", rpo'), - ("Pixel Legend Options", rplo'), - ("Debug", debug) - ] - -repNoData :: (Monad m) => SvgOptions -> Annotation -> HudOptions -> SharedRep m (Text, Text) -repNoData css ann hc = - repChartsWithStaticData css hc 10 [Chart ann [one]] diff --git a/src/Chart/Pixel.hs b/src/Chart/Pixel.hs deleted file mode 100644 --- a/src/Chart/Pixel.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - --- | pixel charts --- --- Opting for a Point or a Rect as concrete data elements that make up an individual chart leaves us with a bit more work to construct a Pixel chart, where colors represent detailed data -module Chart.Pixel - ( PixelOptions (..), - defaultPixelOptions, - pixels, - pixelate, - pixelf, - pixelfl, - pixelLegendChart, - PixelLegendOptions (..), - defaultPixelLegendOptions, - isHori, - makePixelTick, - ) -where - -import Chart.Types -import Control.Lens -import Data.Colour -import Data.FormatN -import Data.Generics.Labels () -import NumHask.Prelude -import NumHask.Space - -data PixelOptions - = PixelOptions - { poStyle :: PixelStyle, - poGrain :: Point Int, - poRange :: Rect Double - } - deriving (Show, Eq, Generic) - -defaultPixelOptions :: PixelOptions -defaultPixelOptions = - PixelOptions defaultPixelStyle (Point 10 10) one - --- | pixel elements -data PixelData - = PixelData - { pixelRect :: Rect Double, - pixelColor :: Colour - } - deriving (Show, Eq, Generic) - --- | pixel chart without any hud trimmings -pixels :: RectStyle -> [PixelData] -> [Chart Double] -pixels rs ps = - ( \(PixelData r c) -> - Chart - (RectA (rs & #color .~ c)) - [RectXY r] - ) - <$> ps - --- | create pixel data from a function on a Point -pixelate :: - (Point Double -> Double) -> - Rect Double -> - Grid (Rect Double) -> - Colour -> - Colour -> - ([PixelData], Range Double) -pixelate f r g c0 c1 = ((\(x, y) -> let c = blend y c0 c1 in PixelData x c) <$> ps', space1 rs) - where - ps = gridF f r g - rs = realToFrac . snd <$> ps - rs' = project (space1 rs :: Range Double) (Range 0 1) <$> rs - ps' = zip (fst <$> ps) rs' - --- | create a pixel chart from a function -pixelf :: (Point Double -> Double) -> PixelOptions -> ([Chart Double], Range Double) -pixelf f cfg = - first (pixels (cfg ^. #poStyle . #pixelRectStyle)) $ - pixelate - f - (cfg ^. #poRange) - (cfg ^. #poGrain) - (cfg ^. #poStyle . #pixelColorMin) - (cfg ^. #poStyle . #pixelColorMax) - -pixelfl :: (Point Double -> Double) -> PixelOptions -> PixelLegendOptions -> ([Chart Double], [Hud Double]) -pixelfl f po plo = (cs, [legendHud (plo ^. #ploLegendOptions) (pixelLegendChart dr plo)]) - where - (cs, dr) = pixelf f po - -data PixelLegendOptions - = PixelLegendOptions - {ploStyle :: PixelStyle, ploTitle :: Text, ploWidth :: Double, ploAxisOptions :: AxisOptions, ploLegendOptions :: LegendOptions} - deriving (Eq, Show, Generic) - -pixelAxisOptions :: AxisOptions -pixelAxisOptions = - AxisOptions - Nothing - Nothing - ( Tick - (TickRound (FormatPrec (Just 3)) 4 NoTickExtend) - (Just (defaultGlyphTick & #color .~ black & #shape .~ VLineGlyph 0.005, 0.01)) - (Just (defaultTextTick, 0.03)) - Nothing - ) - PlaceRight - -defaultPixelLegendOptions :: Text -> PixelLegendOptions -defaultPixelLegendOptions t = - PixelLegendOptions defaultPixelStyle t 0.05 pixelAxisOptions pixelLegendOptions - -pixelLegendOptions :: LegendOptions -pixelLegendOptions = - defaultLegendOptions - & #lplace .~ PlaceRight - & #lscale .~ 0.7 - & #lsize .~ 0.5 - & #vgap .~ 0.05 - & #hgap .~ 0.01 - & #innerPad .~ 0.05 - & #outerPad .~ 0.02 - & #ltext . #hsize .~ 0.5 - -pixelLegendChart :: Range Double -> PixelLegendOptions -> [Chart Double] -pixelLegendChart dataRange l = - padChart (l ^. #ploLegendOptions . #outerPad) - . maybe id (\x -> frameChart x (l ^. #ploLegendOptions . #innerPad)) (l ^. #ploLegendOptions . #legendFrame) - $ hs - where - (Range x0 x1) = dataRange - a = makePixelTick l pchart - pchart - | l ^. #ploLegendOptions . #lplace == PlaceBottom - || l ^. #ploLegendOptions . #lplace == PlaceTop = - Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ 0)) [R x0 x1 0 (l ^. #ploWidth)] - | otherwise = - Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ (pi / 2))) [R 0 (l ^. #ploWidth) x0 x1] - t = Chart (TextA (l ^. #ploLegendOptions . #ltext & #anchor .~ AnchorStart) [l ^. #ploTitle]) [zero] - hs = vert (l ^. #ploLegendOptions . #vgap) [a, [t]] - -isHori :: PixelLegendOptions -> Bool -isHori l = - l ^. #ploLegendOptions . #lplace == PlaceBottom - || l ^. #ploLegendOptions . #lplace == PlaceTop - -makePixelTick :: PixelLegendOptions -> Chart Double -> [Chart Double] -makePixelTick l pchart = phud - where - r = fromMaybe one (styleBox pchart) - r' = bool (Rect 0 (l ^. #ploWidth) 0 (l ^. #ploLegendOptions . #lsize)) (Rect 0 (l ^. #ploLegendOptions . #lsize) 0 (l ^. #ploWidth)) (isHori l) - (hs, _) = - makeHud - r - ( mempty & #hudAxes - .~ [ l ^. #ploAxisOptions - & #place .~ bool PlaceRight PlaceBottom (isHori l) - ] - ) - phud = runHudWith r' r hs [pchart] diff --git a/src/Chart/Reanimate.hs b/src/Chart/Reanimate.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Reanimate.hs @@ -0,0 +1,326 @@ +{-# 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 + ( chartSvgTree, + chartSvgTreeDef, + chartSvgTrees, + chartSvgTreesDef, + writeChartSvgTree, + tree, + toPixelRGBA8, + ) +where + +import Chart as C hiding (transform, Line) +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) + +-- | 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) + +-- | Render a 'ChartSvg' to a 'Tree' with the default viewbox +chartSvgTreeDef :: ChartSvg -> Tree +chartSvgTreeDef = simplify . mkGroup . chartSvgTreesDef + +-- | 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) + +-- | 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) + +-- | 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) + +-- | 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 + +cssRules :: CssOptions -> [Css.CssRule] +cssRules UseCssCrisp = [cssCrisp'] +cssRules UseGeometricPrecision = [cssGeometricPrecision] +cssRules NoCssOptions = [] + +-- | crisp edges css +cssGeometricPrecision :: Css.CssRule +cssGeometricPrecision = Css.CssRule [] [Css.CssDeclaration "shape-rendering" [[Css.CssString "geometricPrecision"]]] + +cssCrisp' :: Css.CssRule +cssCrisp' = Css.CssRule [] [Css.CssDeclaration "shape-rendering" [[Css.CssString "crispEdges"]]] + +-- | Rectange svg +treeRect :: Rect Double -> Tree +treeRect a = + RectangleTree $ rectSvg a defaultSvg + +-- | Text svg +treeText :: TextStyle -> Text -> 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 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)) +treeShape (RectRoundedGlyph x'' rx ry) s p = + RectangleTree + . rectSvg (addPoint p $ C.scale (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 = + PolygonTree + . (polygonPoints .~ rps) + $ (drawAttributes %~ translateDA p) defaultSvg + where + rps = + [ V2 (s * xa) (- s * ya), + V2 (s * xb) (- s * yb), + V2 (s * xc) (- s * yc) + ] +treeShape (EllipseGlyph x') s p = + EllipseTree $ + Ellipse + mempty + (pointSvg p) + (Num $ s / 2) + (Num $ (x' * s) / 2) +treeShape (VLineGlyph x') s (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) = + 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 + +-- | GlyphStyle to svg Tree +treeGlyph :: GlyphStyle -> 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 xs = + PolyLineTree + . (polyLinePoints .~ ((\(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) + +-- | convert a 'Chart' to a 'Tree' +-- +tree :: Chart Double -> Tree +tree (Chart (TextA s ts) xs) = + groupTrees (daText s) (zipWith (treeText s) ts (toPoint <$> xs)) +tree (Chart (GlyphA s) xs) = + groupTrees (daGlyph s) (treeGlyph s . toPoint <$> xs) +tree (Chart (LineA s) xs) = + groupTrees (daLine s) [treeLine (toPoint <$> xs)] +tree (Chart (RectA s) xs) = + groupTrees (daRect s) (treeRect <$> (toRect <$> xs)) +tree (Chart (PathA s pis) xs) = + groupTrees (daPath s) [treePath pis (toPoint <$> xs)] +tree (Chart BlankA _) = + groupTrees mempty [] + +-- | add drawing attributes as a group svg wrapping a [Tree] +groupTrees :: DrawAttributes -> [Tree] -> Tree +groupTrees da' tree' = + GroupTree (drawAttributes %~ (<> da') $ groupChildren .~ tree' $ defaultSvg) + +-- * DrawAttribute computations +daRect :: RectStyle -> DrawAttributes +daRect o = + mempty & + (strokeWidth .~ 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))) & + maybe + id + (\(Point x y) -> transform ?~ [Translate x (-y)]) + (o ^. #translate) + where + toTextAnchor :: Anchor -> TextAnchor + toTextAnchor AnchorMiddle = TextAnchorMiddle + toTextAnchor AnchorStart = TextAnchorStart + toTextAnchor AnchorEnd = TextAnchorEnd + +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 (\(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) + +fromLineCap' :: LineCap -> Cap +fromLineCap' LineCapButt = CapButt +fromLineCap' LineCapRound = CapRound +fromLineCap' LineCapSquare = CapSquare + +fromLineJoin' :: C.LineJoin -> SvgTree.LineJoin +fromLineJoin' LineJoinMiter = JoinMiter +fromLineJoin' LineJoinBevel = JoinBevel +fromLineJoin' LineJoinRound = JoinRound + +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)) + +-- * svg primitives + +-- | Convert to reanimate color primitive. +toPixelRGBA8 :: Colour -> PixelRGBA8 +toPixelRGBA8 (Colour r g b o) = + PixelRGBA8 + (fromIntegral (floor $ r * 256 :: Int)) + (fromIntegral (floor $ g * 256 :: Int)) + (fromIntegral (floor $ b * 256 :: Int)) + (fromIntegral (floor $ o * 256 :: Int)) + +-- | convert a point to the svg co-ordinate system +-- The svg coordinate system has the y-axis going from top to bottom. +pointSvg :: Point Double -> (Number, Number) +pointSvg (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)) + 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') = + transform + %~ (\x -> Just $ maybe [Translate x' (- y')] (<> [Translate x' (- y')]) x) + +-- | convert a Rect to the svg co-ordinate system +rectSvg :: Rect Double -> Rectangle -> Rectangle +rectSvg (Rect x z y w) = + (rectUpperLeftCorner .~ (Num x, Num (- w))) + . (rectWidth .~ Just (Num (z - x))) + . (rectHeight .~ Just (Num (w - y))) diff --git a/src/Chart/Render.hs b/src/Chart/Render.hs --- a/src/Chart/Render.hs +++ b/src/Chart/Render.hs @@ -1,30 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} +-- | Rendering charts to SVG. +-- +-- Note that type signatures are tightened to Double as sane SVG rendering suggests. module Chart.Render - ( scaleCharts, - getAspect, - getViewbox, - getSize, - renderToSvg, + ( ChartSvg (..), + chartSvg, + chartSvgDefault, + chartSvgHud, renderChartsWith, - renderCharts, - renderCharts_, - writeChartsWith, - writeCharts, - writeCharts_, renderHudChart, - renderHudOptionsChart, - writeHudOptionsChart, - svg2_, + writeChartSvg, + writeChartSvgDefault, + writeChartSvgHud, + svg2Tag, cssCrisp, + geometricPrecision, + svg, + terms, + makeAttribute, + + -- * Augmentation + ChartExtra (..), + toChartExtra, + renderChartExtrasWith, + + -- * low-level conversions + attsRect, + attsText, + attsGlyph, + attsLine, + attsPath, ) where import Chart.Types +import Data.Colour +import Data.Path import Control.Lens hiding (transform) import Data.Generics.Labels () import qualified Data.Text.Lazy as Lazy @@ -32,43 +49,48 @@ import qualified Lucid.Base as Lucid import Lucid.Base import NumHask.Prelude -import NumHask.Space hiding (Element) +import NumHask.Space as NH hiding (Element) +import qualified Data.Text as Text --- | scale chart data, projecting to the supplied Rect, and expanding the resultant Rect for chart style if necessary. --- --- Note that this modifies the underlying chart data. --- FIXME: do a divide to make an exact fit -scaleCharts :: - Rect Double -> - [Chart Double] -> - (Rect Double, [Chart Double]) -scaleCharts cs r = (fromMaybe one $ styleBoxes cs', cs') - where - cs' = projectXYs cs r +-- | Specification of a chart for rendering to SVG +data ChartSvg + = ChartSvg + { svgOptions :: SvgOptions, + hudOptions :: HudOptions, + hudList :: [Hud Double], + chartList :: [Chart Double] + } + deriving (Generic) -getAspect :: SvgAspect -> [Chart Double] -> Double -getAspect (ManualAspect a) _ = a -getAspect ChartAspect cs = toAspect . fromMaybe one $ styleBoxes cs +instance Semigroup ChartSvg where + (<>) (ChartSvg _ o h c) (ChartSvg s' o' h' c') = + ChartSvg s' (o <> o') (h <> h') (c <> c') -getSize :: SvgOptions -> [Chart Double] -> Point Double -getSize o cs = case view #svgAspect o of - ManualAspect a -> (view #svgHeight o *) <$> Point a 1 - ChartAspect -> (\(Rect x z y w) -> Point (view #svgHeight o * (z - x)) (view #svgHeight o * (w - y))) . fromMaybe one $ styleBoxes cs +instance Monoid ChartSvg where + mempty = ChartSvg defaultSvgOptions mempty [] [] -getViewbox :: SvgOptions -> [Chart Double] -> Rect Double -getViewbox o cs = - bool asp (fromMaybe one $ styleBoxes cs) (NoScaleCharts == view #scaleCharts' o) - where - asp = - case view #svgAspect o of - ManualAspect a -> Rect (a * (-0.5)) (a * 0.5) (-0.5) 0.5 - ChartAspect -> fromMaybe one $ styleBoxes cs +-- | 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 -svg2_ :: Term [Attribute] (s -> t) => s -> t -svg2_ m = +svg2Tag :: Term [Attribute] (s -> t) => s -> t +svg2Tag m = svg_ [ Lucid.makeAttribute "xmlns" "http://www.w3.org/2000/svg", Lucid.makeAttribute "xmlns:xlink" "http://www.w3.org/1999/xlink" @@ -78,9 +100,9 @@ renderToSvg :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Html () renderToSvg csso (Point w' h') (Rect x z y w) cs = with - ( svg2_ - ( bool id (cssCrisp <>) (csso == UseCssCrisp) $ - chartDefs cs <> mconcat (svg <$> cs) + ( svg2Tag + ( cssText csso <> + mconcat (svg <$> cs) ) ) [ width_ (show w'), @@ -88,57 +110,340 @@ 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 +cssText NoCssOptions = mempty + +-- | crisp edges css cssCrisp :: Html () -cssCrisp = style_ [type_ "text/css"] ("{ shape-rendering: 'crispEdges'; }" :: Text) +cssCrisp = style_ [type_ "text/css"] ("* { shape-rendering: crispEdges; }" :: Text) --- | render Charts with the supplied css options, size and viewbox. -renderCharts_ :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Text -renderCharts_ csso p r cs = - Lazy.toStrict $ renderText (renderToSvg csso p r cs) +-- | crisp edges css +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 ^. #useCssCrisp) (getSize so cs'') r' cs'') + Lazy.toStrict $ renderText (renderToSvg (so ^. #cssOptions) size' rect' cs') where - r' = r & maybe id padRect (so ^. #outerPad) - cs'' = - cs' - & maybe id (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad))) (so ^. #chartFrame) - (r, cs') = - bool - (getViewbox so cs, cs) - (scaleCharts (getViewbox so cs) cs) - (ScaleCharts == so ^. #scaleCharts') + rect' = styleBoxesS cs' & maybe id padRect (so ^. #outerPad) + cs' = + cs & + runHud penult [chartAspectHud (so ^. #chartAspect)] & + maybe id (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad))) + (so ^. #chartFrame) + Point w h = NH.width rect' + size' = Point ((so ^. #svgHeight)/h*w) (so ^. #svgHeight) + penult = case so ^. #chartAspect of + FixedAspect _ -> styleBoxesS cs + CanvasAspect _ -> dataBoxesS cs + ChartAspect -> styleBoxesS cs + UnadjustedAspect -> dataBoxesS cs --- | render charts with the default options. -renderCharts :: [Chart Double] -> Text -renderCharts = renderChartsWith defaultSvgOptions +-- | render ChartExtras with the supplied options. +renderChartExtrasWith :: SvgOptions -> [ChartExtra Double] -> Text +renderChartExtrasWith so cs = + Lazy.toStrict $ renderText (renderToSvgExtra (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 = + maybe id (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad))) + (so ^. #chartFrame) . + runHud penult [chartAspectHud (so ^. #chartAspect)] + 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 -writeChartsWith :: FilePath -> SvgOptions -> [Chart Double] -> IO () -writeChartsWith fp so cs = writeFile fp (renderChartsWith so cs) +-- | render charts with the supplied svg options and huds +renderHudChart :: SvgOptions -> [Hud Double] -> [Chart Double] -> Text +renderHudChart so hs cs = renderChartsWith so (runHud (initialCanvas (so ^. #chartAspect) cs) hs cs) -writeCharts :: FilePath -> [Chart Double] -> IO () -writeCharts fp cs = writeFile fp (renderCharts cs) +-- | Render a chart using the supplied svg and hud config. +-- +-- >>> chartSvg mempty +-- "" +chartSvg :: ChartSvg -> Text +chartSvg (ChartSvg so ho hs cs) = renderHudChart so (hs <> hs') (cs <> cs') + where + (hs', cs') = makeHud (padBox $ dataBoxes cs) ho --- | write Charts to a file with the supplied css options, size and viewbox. -writeCharts_ :: FilePath -> CssOptions -> Point Double -> Rect Double -> [Chart Double] -> IO () -writeCharts_ fp csso p r cs = - writeFile fp (renderCharts_ csso p r cs) +-- | Render a chart using the default svg options and no hud. +-- +-- >>> chartSvgDefault [] == chartSvg mempty +-- True +chartSvgDefault :: [Chart Double] -> Text +chartSvgDefault cs = chartSvg $ mempty & #chartList .~ cs --- * rendering huds and charts +-- | Render a chart using default svg and hud options. +-- +-- >>> chartSvgHud [] == (chartSvg $ mempty & #hudOptions .~ defaultHudOptions) +-- True +chartSvgHud :: [Chart Double] -> Text +chartSvgHud cs = + chartSvg $ + mempty + & #hudOptions .~ defaultHudOptions + & #chartList .~ cs --- | Render some huds and charts. -renderHudChart :: SvgOptions -> [Hud Double] -> [Chart Double] -> Text -renderHudChart so hs cs = renderChartsWith so (runHud (getViewbox so cs) hs cs) +-- | Write to a file. +writeChartSvg :: FilePath -> ChartSvg -> IO () +writeChartSvg fp cs = + writeFile fp (chartSvg cs) --- | Render a chart using the supplied svg and hud config. --- FIXME: fixRect usage -renderHudOptionsChart :: SvgOptions -> HudOptions -> [Hud Double] -> [Chart Double] -> Text -renderHudOptionsChart so hc hs cs = renderHudChart so (hs <> hs') (cs <> cs') +-- | Write a chart to a file with default svg options and no hud. +writeChartSvgDefault :: FilePath -> [Chart Double] -> IO () +writeChartSvgDefault fp cs = writeChartSvg fp (mempty & #chartList .~ cs) + +-- | Write a chart to a file with default svg and hud options. +writeChartSvgHud :: FilePath -> [Chart Double] -> IO () +writeChartSvgHud fp cs = + writeChartSvg + fp + ( mempty + & #chartList .~ cs + & #hudOptions .~ defaultHudOptions + ) + +-- | Rectangle svg +svgRect :: Rect Double -> Lucid.Html () +svgRect (Rect x z y w) = + terms + "rect" + [ width_ (show $ z - x), + height_ (show $ w - y), + term "x" (show x), + term "y" (show $ - w) + ] + +-- | Text svg +svgText :: TextStyle -> Text -> Point Double -> Lucid.Html () +svgText s t p@(Point x y) = + term + "text" + ( [ term "x" (show x), + term "y" (show $ - y) + ] + <> maybe [] (\x' -> [term "transform" (toRotateText x' p)]) (s ^. #rotation) + ) + (toHtmlRaw t) + +-- | line svg +svgLine :: [Point Double] -> Lucid.Html () +svgLine [] = mempty +svgLine xs = terms "polyline" [term "points" (toPointsText xs)] where - (hs', cs') = makeHud (fixRect $ dataBox cs) hc + toPointsText xs' = Text.intercalate "\n" $ (\(Point x y) -> show x <> "," <> show (- y)) <$> xs' -writeHudOptionsChart :: FilePath -> SvgOptions -> HudOptions -> [Hud Double] -> [Chart Double] -> IO () -writeHudOptionsChart fp so hc hs cs = - writeFile fp (renderHudOptionsChart so hc hs cs) +-- | GlyphShape to svg Tree +svgShape :: GlyphShape -> Double -> Point Double -> Lucid.Html () +svgShape CircleGlyph s (Point x y) = + terms + "circle" + [ term "cx" (show x), + term "cy" (show $ - y), + term "r" (show $ 0.5 * s) + ] +svgShape SquareGlyph s p = + svgRect (move p ((s *) <$> one)) +svgShape (RectSharpGlyph x') s p = + svgRect (move p (NH.scale (Point s (x' * s)) one)) +svgShape (RectRoundedGlyph x' rx ry) s p = + terms + "rect" + [ term "width" (show $ z - x), + term "height" (show $ w - y), + term "x" (show x), + term "y" (show $ - w), + term "rx" (show rx), + term "ry" (show ry) + ] + where + (Rect x z y w) = move p (NH.scale (Point s (x' * s)) one) +svgShape (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = + terms + "polygon" + [ term "transform" (toTranslateText p), + term "points" (show (s * xa) <> "," <> show (- (s * ya)) <> " " <> show (s * xb) <> "," <> show (- (s * yb)) <> " " <> show (s * xc) <> "," <> show (- (s * yc))) + ] +svgShape (EllipseGlyph x') s (Point x y) = + terms + "ellipse" + [ term "cx" (show x), + term "cy" (show $ - y), + term "rx" (show $ 0.5 * s), + term "ry" (show $ 0.5 * s * x') + ] +svgShape (VLineGlyph _) s (Point x y) = + terms "polyline" [term "points" (show x <> "," <> show (- (y - s / 2)) <> "\n" <> show x <> "," <> show (- (y + s / 2)))] +svgShape (HLineGlyph _) s (Point x y) = + terms "polyline" [term "points" (show (x - s / 2) <> "," <> show (- y) <> "\n" <> show (x + s / 2) <> "," <> show (- y))] +svgShape (PathGlyph path) s p = + terms "path" [term "d" path, term "transform" (toTranslateText p <> " " <> toScaleText s)] + +-- | GlyphStyle to svg Tree +svgGlyph :: GlyphStyle -> Point Double -> Lucid.Html () +svgGlyph s p = + svgShape (s ^. #shape) (s ^. #size) p + & maybe id (\r -> term "g" [term "transform" (toRotateText r p)]) (s ^. #rotation) + +-- | Path svg +svgPath :: [PathInfo Double] -> [Point Double] -> Lucid.Html () +svgPath _ [] = mempty +svgPath _ [_] = mempty +svgPath infos ps = + terms "path" [term "d" (toPathAbsolutes (zip infos ps))] + +svgAtts :: Annotation -> [Attribute] +svgAtts (TextA s _) = attsText s +svgAtts (GlyphA s) = attsGlyph s +svgAtts (LineA s) = attsLine s +svgAtts (RectA s) = attsRect s +svgAtts (PathA s _) = attsPath s +svgAtts BlankA = mempty + +svgHtml :: Chart Double -> Lucid.Html () +svgHtml (Chart (TextA s ts) xs) = + mconcat $ zipWith (\t p -> svgText s t (toPoint p)) ts xs +svgHtml (Chart (GlyphA s) xs) = + mconcat $ svgGlyph s . toPoint <$> xs +svgHtml (Chart (LineA _) xs) = + svgLine $ toPoint <$> xs +svgHtml (Chart (RectA _) xs) = + mconcat $ svgRect . toRect <$> xs +svgHtml (Chart (PathA _ infos) xs) = + svgPath infos $ toPoint <$> xs +svgHtml (Chart BlankA _) = mempty + +-- | Low-level conversion of a Chart to svg +svg :: Chart Double -> Lucid.Html () +svg c = term "g" (svgAtts $ c ^. #annotation) (svgHtml c) + +-- | 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 + +-- | RectStyle to Attributes +attsRect :: RectStyle -> [Lucid.Attribute] +attsRect o = + [ term "stroke-width" (show $ o ^. #borderSize), + term "stroke" (hex $ o ^. #borderColor), + term "stroke-opacity" (show $ opac $ o ^. #borderColor), + term "fill" (hex $ o ^. #color), + term "fill-opacity" (show $ opac $ o ^. #color) + ] + +-- | TextStyle to Attributes +attsText :: TextStyle -> [Lucid.Attribute] +attsText o = + [ term "stroke-width" "0.0", + term "stroke" "none", + term "fill" (toHex $ o ^. #color), + term "fill-opacity" (show $ opac $ o ^. #color), + 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" + toTextAnchor AnchorStart = "start" + toTextAnchor AnchorEnd = "end" + +-- | GlyphStyle to Attributes +attsGlyph :: GlyphStyle -> [Lucid.Attribute] +attsGlyph o = + [ term "stroke-width" (show $ o ^. #borderSize), + term "stroke" (toHex $ o ^. #borderColor), + term "stroke-opacity" (show $ opac $ o ^. #borderColor), + term "fill" (toHex $ o ^. #color), + term "fill-opacity" (show $ opac $ o ^. #color) + ] + <> maybe [] ((: []) . term "transform" . toTranslateText) (o ^. #translate) + +-- | LineStyle to Attributes +attsLine :: LineStyle -> [Lucid.Attribute] +attsLine o = + [ term "stroke-width" (show $ o ^. #width), + 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) + +-- | PathStyle to Attributes +attsPath :: PathStyle -> [Lucid.Attribute] +attsPath o = + [ term "stroke-width" (show $ o ^. #borderSize), + term "stroke" (hex $ o ^. #borderColor), + term "stroke-opacity" (show $ opac $ o ^. #borderColor), + term "fill" (hex $ o ^. #color), + term "fill-opacity" (show $ opac $ o ^. #color) + ] + +-- | includes a flip of the y dimension. +toTranslateText :: Point Double -> Text +toTranslateText (Point x y) = + "translate(" <> show x <> ", " <> show (- y) <> ")" + +-- | includes reference changes: +-- +-- - from radians to degrees +-- +-- - from counter-clockwise is a positive rotation to clockwise is positive +-- +-- - flip y dimension +-- +toRotateText :: Double -> Point Double -> Text +toRotateText r (Point x y) = + "rotate(" <> show (-r*180/pi) <> ", " <> show x <> ", " <> show (- y) <> ")" + +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 new file mode 100644 --- /dev/null +++ b/src/Chart/Surface.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Surface chart combinators. +-- +-- A common chart is to present a set of rectangles on the XY plane with colour representing values of the underlying data; a surface chart (often called a heatmap). +-- +-- 'SurfaceData', the rectangle and the color value, is a different shape to the usual data elements of a chart, so there is a bit more wrangling to do compared with other chart types. +module Chart.Surface + ( SurfaceData (..), + SurfaceOptions (..), + defaultSurfaceOptions, + SurfaceStyle (..), + defaultSurfaceStyle, + mkSurfaceData, + surfaces, + surfacef, + surfacefl, + SurfaceLegendOptions (..), + defaultSurfaceLegendOptions, + ) +where + +import Chart.Types +import Control.Lens +import Data.Colour +import Data.FormatN +import Data.Generics.Labels () +import NumHask.Prelude +import NumHask.Space + +-- | 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 + soStyle :: SurfaceStyle, + -- | The grain or granularity of the chart + soGrain :: Point Int, + -- | Chart range + soRange :: Rect Double + } + deriving (Show, Eq, Generic) + +-- | official style +defaultSurfaceOptions :: SurfaceOptions +defaultSurfaceOptions = + SurfaceOptions defaultSurfaceStyle (Point 10 10) one + +-- | 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}} +-- +-- ![surface example](other/surface.svg) +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 black) + +-- | Main surface data elements +data SurfaceData + = SurfaceData + { -- | XY Coordinates of surface. + surfaceRect :: Rect Double, + -- | Surface colour. + surfaceColor :: Colour + } + deriving (Show, Eq, Generic) + +-- | surface chart without any hud trimmings +surfaces :: RectStyle -> [SurfaceData] -> [Chart Double] +surfaces rs ps = + ( \(SurfaceData r c) -> + Chart + (RectA (rs & #color .~ c)) + [RectXY r] + ) + <$> ps + +-- | create surface data from a function on a Point +mkSurfaceData :: + (Point Double -> Double) -> + Rect Double -> + Grid (Rect Double) -> + [Colour] -> + ([SurfaceData], Range Double) +mkSurfaceData f r g cs = ((\(x, y) -> SurfaceData x (blends y cs)) <$> ps', space1 rs) + where + ps = gridF f r g + rs = snd <$> ps + rs' = project (space1 rs :: Range Double) (Range 0 1) <$> rs + ps' = zip (fst <$> ps) rs' + +-- | create a surface chart from a function. +surfacef :: (Point Double -> Double) -> SurfaceOptions -> ([Chart Double], Range Double) +surfacef f cfg = + first (surfaces (cfg ^. #soStyle . #surfaceRectStyle)) $ + mkSurfaceData + f + (cfg ^. #soRange) + (cfg ^. #soGrain) + (cfg ^. #soStyle . #surfaceColors) + +-- | Create a surface chart and accompanying legend from a function. +surfacefl :: (Point Double -> Double) -> SurfaceOptions -> SurfaceLegendOptions -> ([Chart Double], [Hud Double]) +surfacefl f po slo = (cs, [legendHud (slo ^. #sloLegendOptions) (surfaceLegendChart dr slo)]) + where + (cs, dr) = surfacef f po + +-- | 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, + 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 +surfaceAxisOptions = + AxisOptions + Nothing + Nothing + ( Tick + (TickRound (FormatPrec (Just 3)) 4 NoTickExtend) + (Just (defaultGlyphTick & #color .~ black & #shape .~ VLineGlyph 0.005, 0.01)) + (Just (defaultTextTick, 0.03)) + Nothing + ) + PlaceRight + +-- | official surface legend options +defaultSurfaceLegendOptions :: Text -> SurfaceLegendOptions +defaultSurfaceLegendOptions t = + SurfaceLegendOptions defaultSurfaceStyle t 0.05 100 surfaceAxisOptions surfaceLegendOptions + +surfaceLegendOptions :: LegendOptions +surfaceLegendOptions = + defaultLegendOptions + & #lplace .~ PlaceRight + & #lscale .~ 0.7 + & #lsize .~ 0.5 + & #vgap .~ 0.05 + & #hgap .~ 0.01 + & #innerPad .~ 0.05 + & #outerPad .~ 0.02 + & #ltext . #hsize .~ 0.5 + & #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) + . maybe id (\x -> frameChart x (l ^. #sloLegendOptions . #innerPad)) (l ^. #sloLegendOptions . #legendFrame) + $ hs + where + a = makeSurfaceTick l pchart + pchart + | l ^. #sloLegendOptions . #lplace == PlaceBottom + || 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)) + 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)) + +isHori :: SurfaceLegendOptions -> Bool +isHori l = + l ^. #sloLegendOptions . #lplace == PlaceBottom + || l ^. #sloLegendOptions . #lplace == PlaceTop + +makeSurfaceTick :: SurfaceLegendOptions -> [Chart Double] -> [Chart Double] +makeSurfaceTick l pchart = phud + where + r = fromMaybe one (styleBoxes pchart) + r' = bool (Rect 0 (l ^. #sloWidth) 0 (l ^. #sloLegendOptions . #lsize)) (Rect 0 (l ^. #sloLegendOptions . #lsize) 0 (l ^. #sloWidth)) (isHori l) + (hs, _) = + makeHud + r + ( mempty & #hudAxes + .~ [ l ^. #sloAxisOptions + & #place .~ bool PlaceRight PlaceBottom (isHori l) + ] + ) + phud = runHudWith r' r hs pchart + diff --git a/src/Chart/Types.hs b/src/Chart/Types.hs --- a/src/Chart/Types.hs +++ b/src/Chart/Types.hs @@ -1,1653 +1,1596 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} - -module Chart.Types - ( Chart (..), - Annotation (..), - annotationText, - RectStyle (..), - defaultRectStyle, - blob, - clear, - border, - TextStyle (..), - defaultTextStyle, - Anchor (..), - fromAnchor, - toAnchor, - GlyphStyle (..), - defaultGlyphStyle, - GlyphShape (..), - glyphText, - LineStyle (..), - defaultLineStyle, - PixelStyle (..), - defaultPixelStyle, - Direction (..), - fromDirection, - toDirection, - padRect, - - SvgAspect (..), - toSvgAspect, - fromSvgAspect, - EscapeText (..), - CssOptions (..), - ScaleCharts (..), - SvgOptions (..), - defaultSvgOptions, - defaultSvgFrame, - - -- $hud machinery - ChartDims (..), - HudT (..), - Hud, - HudOptions (..), - defaultHudOptions, - defaultCanvas, - AxisOptions (..), - defaultAxisOptions, - Place (..), - placeText, - Bar (..), - defaultBar, - Title (..), - defaultTitle, - Tick (..), - defaultGlyphTick, - defaultTextTick, - defaultLineTick, - defaultTick, - TickStyle (..), - defaultTickStyle, - tickStyleText, - TickExtend (..), - Adjustments (..), - defaultAdjustments, - LegendOptions (..), - defaultLegendOptions, - -- $core - projectXYs, - projectXYsWith, - dataBox, - toAspect, - scaleAnn, - moveChart, - - -- $hud - runHudWith, - runHud, - makeHud, - freezeTicks, - flipAxis, - canvas, - title, - tick, - adjustTick, - makeTickDates, - makeTickDatesContinuous, - legendHud, - legendEntry, - legendChart, - legendFromChart, - -- $svg - svg, - svgt, - chartDef, - chartDefs, - styleBox, - styleBoxes, - noStyleBoxes, - styleBoxText, - styleBoxGlyph, - padChart, - frameChart, - hori, - vert, - stack, - addChartBox, - addChartBoxes, - ) -where - -import Control.Lens -import Data.Colour -import Data.FormatN -import Data.Generics.Labels () -import Data.List ((!!)) -import qualified Data.Text as Text -import Data.Time -import qualified Lucid -import Lucid (class_, height_, id_, term, toHtmlRaw, width_, with) -import Lucid.Base (makeXmlElementNoEnd) -import qualified Lucid.Base as Lucid -import NumHask.Prelude -import NumHask.Space as NH hiding (Element) -import Text.HTML.TagSoup hiding (Attribute) -import qualified Prelude as P - --- $setup --- --- >>> :set -XOverloadedLabels --- >>> :set -XNoImplicitPrelude --- >>> -- import NumHask.Prelude --- >>> import Control.Lens --- >>> import Chart.Render - --- * Chart - --- | A `Chart` consists of --- - specific style of representation for each xy point or xy rectangle. --- - a list of points or rectangles on the xy-plane, and -data Chart a - = Chart - { annotation :: Annotation, - xys :: [XY a] - } - deriving (Eq, Show, Generic) - --- | Manifestation of the data on a screen. -data Annotation - = RectA RectStyle - | TextA TextStyle [Text] - | GlyphA GlyphStyle - | LineA LineStyle - | BlankA - | PixelA PixelStyle - deriving (Eq, Show, Generic) - --- | textifier -annotationText :: Annotation -> Text -annotationText (RectA _) = "RectA" -annotationText TextA {} = "TextA" -annotationText (GlyphA _) = "GlyphA" -annotationText (LineA _) = "LineA" -annotationText BlankA = "BlankA" -annotationText (PixelA _) = "PixelA" - --- | 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} --- --- > writeCharts "other/unit.svg" [Chart (RectA defaultRectStyle) [one]] --- --- ![unit example](other/unit.svg) -data RectStyle - = RectStyle - { borderSize :: Double, - borderColor :: Colour, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the style -defaultRectStyle :: RectStyle -defaultRectStyle = RectStyle 0.01 (fromRGB (palette !! 1) 0.8) (fromRGB (palette !! 1) 0.3) - --- | 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} -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} -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} -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, hasMathjax = False} --- --- >>> 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]] --- --- > writeCharts "other/text.svg" t --- --- ![text example](other/text.svg) -data TextStyle - = TextStyle - { size :: Double, - color :: Colour, - anchor :: Anchor, - hsize :: Double, - vsize :: Double, - nudge1 :: Double, - rotation :: Maybe Double, - translate :: Maybe (Point Double), - hasMathjax :: Bool - } - deriving (Show, Eq, Generic) - --- | position anchor -data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic) - --- | text -fromAnchor :: (IsString s) => Anchor -> s -fromAnchor AnchorMiddle = "Middle" -fromAnchor AnchorStart = "Start" -fromAnchor AnchorEnd = "End" - --- | from text -toAnchor :: (Eq s, IsString s) => s -> Anchor -toAnchor "Middle" = AnchorMiddle -toAnchor "Start" = AnchorStart -toAnchor "End" = AnchorEnd -toAnchor _ = AnchorMiddle - --- | the offical text style -defaultTextStyle :: TextStyle -defaultTextStyle = - TextStyle 0.08 colorText AnchorMiddle 0.5 1.45 (-0.2) Nothing Nothing False - --- | 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} --- --- ![glyph example](other/glyph.svg) -data GlyphStyle - = GlyphStyle - { -- | glyph radius - size :: Double, - -- | fill color - color :: Colour, - -- | stroke color - borderColor :: Colour, - -- | stroke width (adds a bit to the bounding box) - borderSize :: Double, - shape :: GlyphShape, - rotation :: Maybe Double, - translate :: Maybe (Point Double) - } - deriving (Show, Eq, Generic) - --- | the offical glyph style -defaultGlyphStyle :: GlyphStyle -defaultGlyphStyle = - GlyphStyle - 0.03 - (fromRGB (palette !! 0) 0.3) - (fromRGB (palette !! 1) 0.8) - 0.003 - SquareGlyph - Nothing - Nothing - --- | glyph shapes -data GlyphShape - = CircleGlyph - | SquareGlyph - | EllipseGlyph Double - | RectSharpGlyph Double - | RectRoundedGlyph Double Double Double - | TriangleGlyph (Point Double) (Point Double) (Point Double) - | VLineGlyph Double - | HLineGlyph Double - | PathGlyph Text - deriving (Show, Eq, Generic) - --- | textifier -glyphText :: GlyphShape -> Text -glyphText sh = - case sh of - CircleGlyph -> "Circle" - SquareGlyph -> "Square" - TriangleGlyph {} -> "Triangle" - EllipseGlyph _ -> "Ellipse" - RectSharpGlyph _ -> "RectSharp" - RectRoundedGlyph {} -> "RectRounded" - VLineGlyph _ -> "VLine" - HLineGlyph _ -> "HLine" - PathGlyph _ -> "Path" - --- | line style --- --- >>> defaultLineStyle --- LineStyle {width = 1.2e-2, color = RGBA 0.65 0.81 0.89 0.30} -data LineStyle - = LineStyle - { width :: Double, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the official default line style -defaultLineStyle :: LineStyle -defaultLineStyle = LineStyle 0.012 (fromRGB (palette !! 0) 0.3) - --- | A pixel chart is a specialization of a 'RectA' chart --- --- >>> defaultPixelStyle --- PixelStyle {pixelColorMin = RGBA 0.65 0.81 0.89 1.00, pixelColorMax = RGBA 0.12 0.47 0.71 1.00, pixelGradient = 1.5707963267948966, pixelRectStyle = RectStyle {borderSize = 0.0, borderColor = RGBA 0.00 0.00 0.00 0.00, color = RGBA 0.00 0.00 0.00 1.00}, pixelTextureId = "pixel"} --- --- ![pixel example](other/pixel.svg) -data PixelStyle - = PixelStyle - { pixelColorMin :: Colour, - pixelColorMax :: Colour, - -- | expressed in directional terms - -- 0 for horizontal - -- pi/2 for vertical - pixelGradient :: Double, - pixelRectStyle :: RectStyle, - pixelTextureId :: Text - } - deriving (Show, Eq, Generic) - --- | The official pixel style. -defaultPixelStyle :: PixelStyle -defaultPixelStyle = - PixelStyle (fromRGB (palette !! 0) 1) (fromRGB (palette !! 1) 1) (pi / 2) (blob black) "pixel" - --- | Verticle or Horizontal -data Direction = Vert | Hori deriving (Eq, Show, Generic) - --- | textifier -fromDirection :: (IsString s) => Direction -> s -fromDirection Hori = "Hori" -fromDirection Vert = "Vert" - --- | readifier -toDirection :: (Eq s, IsString s) => s -> Direction -toDirection "Hori" = Hori -toDirection "Vert" = Vert -toDirection _ = Hori - --- | additive padding -padRect :: (Num a) => a -> Rect a -> Rect a -padRect p (Rect x z y w) = Rect (x P.- p) (z P.+ p) (y P.- p) (w P.+ p) - --- | or html -data EscapeText = EscapeText | NoEscapeText deriving (Show, Eq, Generic) - --- | pixel chart helper -data CssOptions = UseCssCrisp | NoCssOptions deriving (Show, Eq, Generic) - --- | turns off scaling. Usually not what you want. -data ScaleCharts = ScaleCharts | NoScaleCharts deriving (Show, Eq, Generic) - --- | The x-y ratio of the viewing box -data SvgAspect = ManualAspect Double | ChartAspect deriving (Show, Eq, Generic) - --- | textifier -fromSvgAspect :: (IsString s) => SvgAspect -> s -fromSvgAspect (ManualAspect _) = "ManualAspect" -fromSvgAspect ChartAspect = "ChartAspect" - --- | readifier -toSvgAspect :: (Eq s, IsString s) => s -> Double -> SvgAspect -toSvgAspect "ManualAspect" a = ManualAspect a -toSvgAspect "ChartAspect" _ = ChartAspect -toSvgAspect _ _ = ChartAspect - --- | Top-level SVG options. --- --- >>> defaultSvgOptions --- SvgOptions {svgHeight = 300.0, outerPad = Just 2.0e-2, innerPad = Nothing, chartFrame = Nothing, escapeText = NoEscapeText, useCssCrisp = NoCssOptions, scaleCharts' = ScaleCharts, svgAspect = ManualAspect 1.5} --- --- > writeChartsWith "other/svgoptions.svg" (defaultSvgOptions & #svgAspect .~ ManualAspect 0.7) lines --- --- ![svgoptions example](other/svgoptions.svg) -data SvgOptions - = SvgOptions - { svgHeight :: Double, - outerPad :: Maybe Double, - innerPad :: Maybe Double, - chartFrame :: Maybe RectStyle, - escapeText :: EscapeText, - useCssCrisp :: CssOptions, - scaleCharts' :: ScaleCharts, - svgAspect :: SvgAspect - } - deriving (Eq, Show, Generic) - --- | The official svg options -defaultSvgOptions :: SvgOptions -defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoEscapeText NoCssOptions ScaleCharts (ManualAspect 1.5) - --- | frame style -defaultSvgFrame :: RectStyle -defaultSvgFrame = border 0.01 (fromRGB (grayscale 0.7) 0.5) - --- | In order to create huds, there are three main pieces of state that need to be kept track of: --- --- - chartDim: the rectangular dimension of the physical representation of a chart on the screen so that new hud elements can be appended. Adding a hud piece tends to expand the chart dimension. --- --- - canvasDim: the rectangular dimension of the canvas on which data will be represented. At times appending a hud element will cause the canvas dimension to shift. --- --- - dataDim: the rectangular dimension of the data being represented. Adding hud elements can cause this to change. -data ChartDims a - = ChartDims - { chartDim :: Rect a, - canvasDim :: Rect a, - dataDim :: Rect a - } - deriving (Eq, Show, Generic) - --- | Hud monad transformer -newtype HudT m a = Hud {unhud :: [Chart a] -> StateT (ChartDims a) m [Chart a]} - -type Hud = HudT Identity - -instance (Monad m) => Semigroup (HudT m a) where - (<>) (Hud h1) (Hud h2) = Hud $ h1 >=> h2 - -instance (Monad m) => Monoid (HudT m a) where - mempty = Hud pure - --- | Practically, the configuration of a Hud is going to be in decimals, typed into config files and the like, and so we concrete at the configuration level, and settle on doubles for specifying the geomtry of hud elements. --- --- > writeHudOptionsChart "other/hud.svg" defaultSvgOptions defaultHudOptions [] [] --- --- ![hud example](other/hud.svg) -data HudOptions - = HudOptions - { hudCanvas :: Maybe RectStyle, - hudTitles :: [Title], - hudAxes :: [AxisOptions], - hudLegend :: Maybe (LegendOptions, [(Annotation, Text)]) - } - deriving (Eq, Show, Generic) - -instance Semigroup HudOptions where - (<>) (HudOptions c t a l) (HudOptions c' t' a' l') = - HudOptions (listToMaybe $ catMaybes [c, c']) (t <> t') (a <> a') (listToMaybe $ catMaybes [l, l']) - -instance Monoid HudOptions where - mempty = HudOptions Nothing [] [] Nothing - --- | The official hud options. -defaultHudOptions :: HudOptions -defaultHudOptions = - HudOptions - (Just defaultCanvas) - [] - [ defaultAxisOptions, - defaultAxisOptions & #place .~ PlaceLeft - ] - Nothing - --- | The official hud canvas -defaultCanvas :: RectStyle -defaultCanvas = blob (fromRGB (grayscale 0.5) 0.025) - --- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas -data Place - = PlaceLeft - | PlaceRight - | PlaceTop - | PlaceBottom - | PlaceAbsolute (Point Double) - deriving (Show, Eq, Generic) - --- | textifier -placeText :: Place -> Text -placeText p = - case p of - PlaceTop -> "Top" - PlaceBottom -> "Bottom" - PlaceLeft -> "Left" - PlaceRight -> "Right" - PlaceAbsolute _ -> "Absolute" - --- | axis options -data AxisOptions - = AxisOptions - { abar :: Maybe Bar, - adjust :: Maybe Adjustments, - atick :: Tick, - place :: Place - } - deriving (Eq, Show, Generic) - --- | The official axis -defaultAxisOptions :: AxisOptions -defaultAxisOptions = AxisOptions (Just defaultBar) (Just defaultAdjustments) defaultTick PlaceBottom - --- | The bar on an axis representing the x or y plane. --- --- >>> defaultBar --- Bar {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} -data Bar - = Bar - { rstyle :: RectStyle, - wid :: Double, - buff :: Double - } - deriving (Show, Eq, Generic) - --- | The official axis bar -defaultBar :: Bar -defaultBar = Bar (RectStyle 0 (fromRGB (grayscale 0.5) 1) (fromRGB (grayscale 0.5) 1)) 0.005 0.01 - --- | Options for titles. Defaults to center aligned, and placed at Top of the hud -data Title - = Title - { text :: Text, - style :: TextStyle, - place :: Place, - anchor :: Anchor, - buff :: Double - } - deriving (Show, Eq, Generic) - --- | The official hud title -defaultTitle :: Text -> Title -defaultTitle txt = - Title - txt - ( (#size .~ 0.12) - . (#color .~ colorText) - $ defaultTextStyle - ) - PlaceTop - AnchorMiddle - 0.04 - --- | 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, hasMathjax = False},1.5e-2), ltick = Just (LineStyle {width = 5.0e-3, color = RGBA 0.50 0.50 0.50 0.05},0.0)} -data Tick - = Tick - { tstyle :: TickStyle, - gtick :: Maybe (GlyphStyle, Double), - ttick :: Maybe (TextStyle, Double), - ltick :: Maybe (LineStyle, Double) - } - deriving (Show, Eq, Generic) - --- | The official glyph tick -defaultGlyphTick :: GlyphStyle -defaultGlyphTick = - defaultGlyphStyle - & #borderSize .~ 0.005 - & #borderColor .~ fromRGB (grayscale 0.5) 1 - & #color .~ fromRGB (grayscale 0.5) 1 - & #shape .~ VLineGlyph 0.005 - --- | The official text tick -defaultTextTick :: TextStyle -defaultTextTick = - defaultTextStyle & #size .~ 0.05 & #color .~ fromRGB (grayscale 0.5) 1 - --- | The official line tick -defaultLineTick :: LineStyle -defaultLineTick = - defaultLineStyle - & #color .~ fromRGB (grayscale 0.5) 0.05 - & #width .~ 5.0e-3 - --- | The official tick -defaultTick :: Tick -defaultTick = - Tick - defaultTickStyle - (Just (defaultGlyphTick, 0.0125)) - (Just (defaultTextTick, 0.015)) - (Just (defaultLineTick, 0)) - --- | Style of tick marks on an axis. -data TickStyle - = -- | no ticks on axis - TickNone - | -- | specific labels (equidistant placement) - TickLabels [Text] - | -- | sensibly rounded ticks, a guide to how many, and whether to extend beyond the data bounding box - TickRound FormatN Int TickExtend - | -- | exactly n equally spaced ticks - TickExact FormatN Int - | -- | specific labels and placement - TickPlaced [(Double, Text)] - deriving (Show, Eq, Generic) - --- | The official tick style -defaultTickStyle :: TickStyle -defaultTickStyle = TickRound (FormatComma (Just 2)) 8 TickExtend - --- | textifier -tickStyleText :: TickStyle -> Text -tickStyleText TickNone = "TickNone" -tickStyleText TickLabels {} = "TickLabels" -tickStyleText TickRound {} = "TickRound" -tickStyleText TickExact {} = "TickExact" -tickStyleText TickPlaced {} = "TickPlaced" - --- | Whether Ticks are allowed to extend the data range -data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) - --- | options for prettifying axis decorations --- --- >>> defaultAdjustments --- Adjustments {maxXRatio = 8.0e-2, maxYRatio = 6.0e-2, angledRatio = 0.12, allowDiagonal = True} -data Adjustments - = Adjustments - { maxXRatio :: Double, - maxYRatio :: Double, - angledRatio :: Double, - allowDiagonal :: Bool - } - deriving (Show, Eq, Generic) - --- | The official hud adjustments. -defaultAdjustments :: Adjustments -defaultAdjustments = Adjustments 0.08 0.06 0.12 True - --- You're all Legends! - --- | 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, hasMathjax = False}, 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} --- --- ![legend example](other/legend.svg) -data LegendOptions - = LegendOptions - { lsize :: Double, - vgap :: Double, - hgap :: Double, - ltext :: TextStyle, - lmax :: Int, - innerPad :: Double, - outerPad :: Double, - legendFrame :: Maybe RectStyle, - lplace :: Place, - lscale :: Double - } - deriving (Show, Eq, Generic) - --- | The official legend options -defaultLegendOptions :: LegendOptions -defaultLegendOptions = - LegendOptions - 0.1 - 0.2 - 0.1 - ( defaultTextStyle - & #size .~ 0.08 - ) - 10 - 0.1 - 0.1 - (Just (RectStyle 0.02 (fromRGB (grayscale 0.5) 1) white)) - PlaceBottom - 0.2 - --- | Project the xys of a chart to a new XY Space. -projectXYs :: Rect Double -> [Chart Double] -> [Chart Double] -projectXYs a cs = cs' - where - xss = projectTo2 a (xys <$> cs) - ss = annotation <$> cs - cs' = zipWith Chart ss xss - projectTo2 vb xss = - fmap - ( maybe - id - (projectOn vb) - (fold $ foldRect . fmap toRect <$> xss) - ) - <$> xss - --- | Project chart xys to a new XY Space from an old XY Space -projectXYsWith :: Rect Double -> Rect Double -> [Chart Double] -> [Chart Double] -projectXYsWith new old cs = cs' - where - xss = fmap (projectOn new old) . xys <$> cs - ss = annotation <$> cs - cs' = zipWith Chart ss xss - --- | convert to a ratio -toAspect :: (Divisive a, Subtractive a) => Rect a -> a -toAspect (Rect x z y w) = (z - x) / (w - y) - --- | get the Space of a [Chart a] -dataBox :: (Ord a) => [Chart a] -> Maybe (Rect a) -dataBox cs = foldRect . mconcat $ fmap toRect <$> (xys <$> cs) - -scaleAnn :: Double -> Annotation -> Annotation -scaleAnn x (LineA a) = LineA $ a & #width %~ (* x) -scaleAnn x (RectA a) = RectA $ a & #borderSize %~ (* x) -scaleAnn x (TextA a txs) = TextA (a & #size %~ (* x)) txs -scaleAnn x (GlyphA a) = GlyphA (a & #size %~ (* x)) -scaleAnn x (PixelA a) = PixelA $ a & #pixelRectStyle . #borderSize %~ (* x) -scaleAnn _ BlankA = BlankA - -moveChart :: (Additive a) => XY a -> [Chart a] -> [Chart a] -moveChart sp cs = fmap (#xys %~ fmap (sp +)) cs - --- | combine huds and charts to form a new Chart using the supplied --- initial canvas and data dimensions. --- Note that chart data is transformed by this computation. --- used once in makePixelTick -runHudWith :: - -- | initial canvas dimension - Rect Double -> - -- | initial data dimension - Rect Double -> - -- | huds to add - [Hud Double] -> - -- | underlying chart - [Chart Double] -> - -- | chart list - [Chart Double] -runHudWith ca xs hs cs = - flip evalState (ChartDims ca' da' xs) $ - (unhud $ mconcat hs) cs' - where - da' = fromMaybe one $ dataBox cs' - ca' = fromMaybe one $ styleBoxes cs' - cs' = projectXYsWith ca xs cs - --- | Combine huds and charts to form a new [Chart] using the supplied canvas and the actual data dimension. --- Note that the original chart data are transformed and irrevocably lost by this computation. --- used once in renderHudChart -runHud :: Rect Double -> [Hud Double] -> [Chart Double] -> [Chart Double] -runHud ca hs cs = runHudWith ca (fixRect $ dataBox cs) hs cs - --- | Make huds from a HudOptions --- Some huds, such as the creation of tick values, can extend the data dimension of a chart, so we also return a blank chart with the new data dimension. --- The complexity internally is due to the creation of ticks and, specifically, gridSensible, which is not idempotent. As a result, a tick calculation that does extends the data area, can then lead to new tick values when applying TickRound etc. -makeHud :: Rect Double -> HudOptions -> ([Hud Double], [Chart Double]) -makeHud xs cfg = - (haxes <> [can] <> titles <> [l], [xsext]) - where - can = maybe mempty (\x -> canvas x) (cfg ^. #hudCanvas) - titles = title <$> (cfg ^. #hudTitles) - newticks = (\a -> freezeTicks (a ^. #place) xs (a ^. #atick . #tstyle)) <$> (cfg ^. #hudAxes) - axes' = zipWith (\c t -> c & #atick . #tstyle .~ fst t) (cfg ^. #hudAxes) newticks - xsext = Chart BlankA (RectXY <$> catMaybes (snd <$> newticks)) - haxes = (\x -> maybe mempty (\a -> bar (x ^. #place) a) (x ^. #abar) <> adjustedTickHud x) <$> axes' - l = maybe mempty (\(lo, ats) -> legendHud lo (legendChart ats lo)) (cfg ^. #hudLegend) - --- convert TickRound to TickPlaced -freezeTicks :: Place -> Rect Double -> TickStyle -> (TickStyle, Maybe (Rect Double)) -freezeTicks pl xs' ts@TickRound {} = maybe (ts, Nothing) (\x -> (TickPlaced (zip ps ls), Just x)) ((\x -> replaceRange pl x xs') <$> ext) - where - (TickComponents ps ls ext) = makeTicks ts (placeRange pl xs') - replaceRange :: Place -> Range Double -> Rect Double -> Rect Double - replaceRange pl' (Range a0 a1) (Rect x z y w) = case pl' of - PlaceRight -> Rect x z a0 a1 - PlaceLeft -> Rect x z a0 a1 - _ -> Rect a0 a1 y w -freezeTicks _ _ ts = (ts, Nothing) - --- | -flipAxis :: AxisOptions -> AxisOptions -flipAxis ac = case ac ^. #place of - PlaceBottom -> ac & #place .~ PlaceLeft - PlaceTop -> ac & #place .~ PlaceRight - PlaceLeft -> ac & #place .~ PlaceBottom - PlaceRight -> ac & #place .~ PlaceTop - PlaceAbsolute _ -> ac - -addToRect :: (Ord a) => Rect a -> Maybe (Rect a) -> Rect a -addToRect r r' = sconcat $ r :| maybeToList r' - -canvas :: (Monad m) => RectStyle -> HudT m Double -canvas s = Hud $ \cs -> do - a <- use #canvasDim - let c = Chart (RectA s) [RectXY a] - #canvasDim .= addToRect a (styleBox c) - pure $ c : cs - -bar_ :: Place -> Bar -> Rect Double -> Rect Double -> Chart Double -bar_ pl b (Rect x z y w) (Rect x' z' y' w') = - case pl of - PlaceTop -> - Chart - (RectA (rstyle b)) - [ R - x - z - (w' + b ^. #buff) - (w' + b ^. #buff + b ^. #wid) - ] - PlaceBottom -> - Chart - (RectA (rstyle b)) - [ R - x - z - (y' - b ^. #wid - b ^. #buff) - (y' - b ^. #buff) - ] - PlaceLeft -> - Chart - (RectA (rstyle b)) - [ R - (x' - b ^. #wid - b ^. #buff) - (x' - b ^. #buff) - y - w - ] - PlaceRight -> - Chart - (RectA (rstyle b)) - [ R - (z' + (b ^. #buff)) - (z' + (b ^. #buff) + (b ^. #wid)) - y - w - ] - PlaceAbsolute (Point x'' _) -> - Chart - (RectA (rstyle b)) - [ R - (x'' + (b ^. #buff)) - (x'' + (b ^. #buff) + (b ^. #wid)) - y - w - ] - -bar :: (Monad m) => Place -> Bar -> HudT m Double -bar pl b = Hud $ \cs -> do - da <- use #chartDim - ca <- use #canvasDim - let c = bar_ pl b ca da - #chartDim .= addChartBox c da - pure $ c : cs - -title_ :: Title -> Rect Double -> Chart Double -title_ t a = - Chart - ( TextA - ( style' - & #translate ?~ (realToFrac <$> (placePos' a + alignPos a)) - & #rotation ?~ rot - ) - [t ^. #text] - ) - [zero] - where - style' - | t ^. #anchor == AnchorStart = - #anchor .~ AnchorStart $ t ^. #style - | t ^. #anchor == AnchorEnd = - #anchor .~ AnchorEnd $ t ^. #style - | otherwise = t ^. #style - rot - | t ^. #place == PlaceRight = 90.0 - | t ^. #place == PlaceLeft = -90.0 - | otherwise = 0 - placePos' (Rect x z y w) = case t ^. #place of - PlaceTop -> Point ((x + z) / 2.0) (w + (t ^. #buff)) - PlaceBottom -> - Point - ((x + z) / 2.0) - ( y - (t ^. #buff) - - 0.5 - * realToFrac (t ^. #style . #vsize) - * realToFrac (t ^. #style . #size) - ) - PlaceLeft -> Point (x - (t ^. #buff)) ((y + w) / 2.0) - PlaceRight -> Point (z + (t ^. #buff)) ((y + w) / 2.0) - PlaceAbsolute p -> p - alignPos (Rect x z y w) - | t ^. #anchor == AnchorStart - && t ^. #place `elem` [PlaceTop, PlaceBottom] = - Point ((x - z) / 2.0) 0.0 - | t ^. #anchor == AnchorStart - && t ^. #place == PlaceLeft = - Point 0.0 ((y - w) / 2.0) - | t ^. #anchor == AnchorStart - && t ^. #place == PlaceRight = - Point 0.0 ((w - y) / 2.0) - | t ^. #anchor == AnchorEnd - && t ^. #place `elem` [PlaceTop, PlaceBottom] = - Point ((- x + z) / 2.0) 0.0 - | t ^. #anchor == AnchorEnd - && t ^. #place == PlaceLeft = - Point 0.0 ((- y + w) / 2.0) - | t ^. #anchor == AnchorEnd - && t ^. #place == PlaceRight = - Point 0.0 ((y - w) / 2.0) - | otherwise = Point 0.0 0.0 - --- | Add a title to a chart. The logic used to work out placement is flawed due to being able to freely specify text rotation. It works for specific rotations (Top, Bottom at 0, Left at 90, Right @ 270) -title :: (Monad m) => Title -> HudT m Double -title t = Hud $ \cs -> do - ca <- use #chartDim - let c = title_ t ca - #chartDim .= addChartBox c ca - pure $ c : cs - -placePos :: Place -> Double -> Rect Double -> Point Double -placePos pl b (Rect x z y w) = case pl of - PlaceTop -> Point 0 (w + b) - PlaceBottom -> Point 0 (y - b) - PlaceLeft -> Point (x - b) 0 - PlaceRight -> Point (z + b) 0 - PlaceAbsolute p -> p - -placeRot :: Place -> Maybe Double -placeRot pl = case pl of - PlaceRight -> Just (-90.0) - PlaceLeft -> Just (-90.0) - _ -> Nothing - -textPos :: Place -> TextStyle -> Double -> Point Double -textPos pl tt b = case pl of - PlaceTop -> Point 0 b - PlaceBottom -> Point 0 (- b - 0.5 * realToFrac (tt ^. #vsize) * realToFrac (tt ^. #size)) - PlaceLeft -> - Point - (- b) - (realToFrac (tt ^. #nudge1) * realToFrac (tt ^. #vsize) * realToFrac (tt ^. #size)) - PlaceRight -> - Point - b - (realToFrac (tt ^. #nudge1) * realToFrac (tt ^. #vsize) * realToFrac (tt ^. #size)) - PlaceAbsolute p -> p - -placeRange :: Place -> Rect Double -> Range Double -placeRange pl (Rect x z y w) = case pl of - PlaceRight -> Range y w - PlaceLeft -> Range y w - _ -> Range x z - -placeOrigin :: Place -> Double -> Point Double -placeOrigin pl x - | pl `elem` [PlaceTop, PlaceBottom] = Point x 0 - | otherwise = Point 0 x - -placeTextAnchor :: Place -> (TextStyle -> TextStyle) -placeTextAnchor pl - | pl == PlaceLeft = #anchor .~ AnchorEnd - | pl == PlaceRight = #anchor .~ AnchorStart - | otherwise = id - -placeGridLines :: Place -> Rect Double -> Double -> Double -> [XY Double] -placeGridLines pl (Rect x z y w) a b - | pl `elem` [PlaceTop, PlaceBottom] = [P a (y - b), P a (w + b)] - | otherwise = [P (x - b) a, P (z + b) a] - --- | compute tick values and labels given options, ranges and formatting -ticksR :: TickStyle -> Range Double -> Range Double -> [(Double, Text)] -ticksR s d r = - case s of - TickNone -> [] - TickRound f n e -> zip (project r d <$> ticks0) (formatNs f ticks0) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) - TickExact f n -> zip (project r d <$> ticks0) (formatNs f ticks0) - where - ticks0 = grid OuterPos r n - TickLabels ls -> - zip - ( project (Range 0 (fromIntegral $ length ls)) d - <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) - ) - ls - TickPlaced xs -> zip (project r d . fst <$> xs) (snd <$> xs) - -data TickComponents - = TickComponents - { positions :: [Double], - labels :: [Text], - extension :: Maybe (Range Double) - } - deriving (Eq, Show, Generic) - --- | compute tick components given style, ranges and formatting -makeTicks :: TickStyle -> Range Double -> TickComponents -makeTicks s r = - case s of - TickNone -> TickComponents [] [] Nothing - TickRound f n e -> - TickComponents - ticks0 - (formatNs f ticks0) - (bool (Just $ space1 ticks0) Nothing (e == NoTickExtend)) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) - TickExact f n -> TickComponents ticks0 (formatNs f ticks0) Nothing - where - ticks0 = grid OuterPos r n - TickLabels ls -> - TickComponents - ( project (Range 0 (fromIntegral $ length ls)) r - <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) - ) - ls - Nothing - TickPlaced xs -> TickComponents (fst <$> xs) (snd <$> xs) Nothing - --- | compute tick values given placement, canvas dimension & data range -ticksPlaced :: TickStyle -> Place -> Rect Double -> Rect Double -> TickComponents -ticksPlaced ts pl d xs = TickComponents (project (placeRange pl xs) (placeRange pl d) <$> ps) ls ext - where - (TickComponents ps ls ext) = makeTicks ts (placeRange pl xs) - -tickGlyph_ :: Place -> (GlyphStyle, Double) -> TickStyle -> Rect Double -> Rect Double -> Rect Double -> Chart Double -tickGlyph_ pl (g, b) ts ca da xs = - Chart - (GlyphA (g & #rotation .~ (realToFrac <$> placeRot pl))) - ( PointXY . (placePos pl b ca +) . placeOrigin pl - <$> positions - (ticksPlaced ts pl da xs) - ) - --- | aka marks -tickGlyph :: - (Monad m) => - Place -> - (GlyphStyle, Double) -> - TickStyle -> - HudT m Double -tickGlyph pl (g, b) ts = Hud $ \cs -> do - a <- use #chartDim - d <- use #canvasDim - xs <- use #dataDim - let c = tickGlyph_ pl (g, b) ts a d xs - #chartDim .= addToRect a (styleBox c) - pure $ c : cs - -tickText_ :: - Place -> - (TextStyle, Double) -> - TickStyle -> - Rect Double -> - Rect Double -> - Rect Double -> - [Chart Double] -tickText_ pl (txts, b) ts ca da xs = - zipWith - ( \txt sp -> - Chart - ( TextA - (placeTextAnchor pl txts) - [txt] - ) - [PointXY sp] - ) - (labels $ ticksPlaced ts pl da xs) - ( (placePos pl b ca + textPos pl txts b +) . placeOrigin pl - <$> positions (ticksPlaced ts pl da xs) - ) - --- | aka tick labels -tickText :: - (Monad m) => - Place -> - (TextStyle, Double) -> - TickStyle -> - HudT m Double -tickText pl (txts, b) ts = Hud $ \cs -> do - ca <- use #chartDim - da <- use #canvasDim - xs <- use #dataDim - let c = tickText_ pl (txts, b) ts ca da xs - #chartDim .= addChartBoxes c ca - pure $ c <> cs - --- | aka grid lines -tickLine :: - (Monad m) => - Place -> - (LineStyle, Double) -> - TickStyle -> - HudT m Double -tickLine pl (ls, b) ts = Hud $ \cs -> do - da <- use #canvasDim - xs <- use #dataDim - let c = - Chart (LineA ls) . (\x -> placeGridLines pl da x b) - <$> positions (ticksPlaced ts pl da xs) - #chartDim %= addChartBoxes c - pure $ c <> cs - --- | Create tick glyphs (marks), lines (grid) and text (labels) -tick :: - (Monad m) => - Place -> - Tick -> - HudT m Double -tick pl t = - maybe mempty (\x -> tickGlyph pl x (t ^. #tstyle)) (t ^. #gtick) - <> maybe mempty (\x -> tickText pl x (t ^. #tstyle)) (t ^. #ttick) - <> maybe mempty (\x -> tickLine pl x (t ^. #tstyle)) (t ^. #ltick) - <> extendData pl t - --- | compute an extension to the Range if a tick went over the data bounding box -computeTickExtension :: TickStyle -> Range Double -> Maybe (Range Double) -computeTickExtension s r = - case s of - TickNone -> Nothing - TickRound _ n e -> bool Nothing (Just (space1 ticks0 <> r)) (e == TickExtend) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) - TickExact _ _ -> Nothing - TickLabels _ -> Nothing - TickPlaced xs -> Just $ r <> space1 (fst <$> xs) - --- | Create a style extension for the data, if ticks extend beyond the existing range -tickExtended :: - Place -> - Tick -> - Rect Double -> - Rect Double -tickExtended pl t xs = - maybe - xs - (\x -> rangeext xs x) - (computeTickExtension (t ^. #tstyle) (ranged xs)) - where - ranged xs' = case pl of - PlaceTop -> rangex xs' - PlaceBottom -> rangex xs' - PlaceLeft -> rangey xs' - PlaceRight -> rangey xs' - PlaceAbsolute _ -> rangex xs' - rangex (Rect x z _ _) = Range x z - rangey (Rect _ _ y w) = Range y w - rangeext (Rect x z y w) (Range a0 a1) = case pl of - PlaceTop -> Rect a0 a1 y w - PlaceBottom -> Rect a0 a1 y w - PlaceLeft -> Rect x z a0 a1 - PlaceRight -> Rect x z a0 a1 - PlaceAbsolute _ -> Rect a0 a1 y w - -extendData :: (Monad m) => Place -> Tick -> HudT m Double -extendData pl t = Hud $ \cs -> do - #dataDim %= tickExtended pl t - pure cs - --- | adjust Tick for sane font sizes etc -adjustTick :: - Adjustments -> - Rect Double -> - Rect Double -> - Place -> - Tick -> - Tick -adjustTick (Adjustments mrx ma mry ad) vb cs pl t - | pl `elem` [PlaceBottom, PlaceTop] = case ad of - False -> t & #ttick . _Just . _1 . #size %~ (/ adjustSizeX) - True -> - case adjustSizeX > 1 of - True -> - ( case pl of - PlaceBottom -> #ttick . _Just . _1 . #anchor .~ AnchorEnd - PlaceTop -> #ttick . _Just . _1 . #anchor .~ AnchorStart - _ -> #ttick . _Just . _1 . #anchor .~ AnchorEnd - ) - . (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) - $ (#ttick . _Just . _1 . #rotation ?~ (-45)) t - False -> (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) t - | otherwise = -- pl `elem` [PlaceLeft, PlaceRight] - (#ttick . _Just . _1 . #size %~ (/ adjustSizeY)) t - where - max' [] = 1 - max' xs = maximum xs - ra (Rect x z y w) - | pl `elem` [PlaceTop, PlaceBottom] = Range x z - | otherwise = Range y w - asp = ra vb - r = ra cs - tickl = snd <$> ticksR (t ^. #tstyle) asp r - maxWidth :: Double - maxWidth = - maybe - 1 - ( \tt -> - max' $ - (\(Rect x z _ _) -> z - x) - . (\x -> styleBoxText (fst tt) x (Point 0 0)) <$> tickl - ) - (t ^. #ttick) - maxHeight = - maybe - 1 - ( \tt -> - max' $ - (\(Rect _ _ y w) -> w - y) - . (\x -> styleBoxText (fst tt) x (Point 0 0)) <$> tickl - ) - (t ^. #ttick) - adjustSizeX :: Double - adjustSizeX = max' [(maxWidth / realToFrac (upper asp - lower asp)) / mrx, 1] - adjustSizeY = max' [(maxHeight / realToFrac (upper asp - lower asp)) / mry, 1] - adjustSizeA = max' [(maxHeight / realToFrac (upper asp - lower asp)) / ma, 1] - -adjustedTickHud :: (Monad m) => AxisOptions -> HudT m Double -adjustedTickHud c = Hud $ \cs -> do - vb <- use #chartDim - xs <- use #dataDim - let adjTick = - maybe - (c ^. #atick) - (\x -> adjustTick x vb xs (c ^. #place) (c ^. #atick)) - (c ^. #adjust) - unhud (tick (c ^. #place) adjTick) cs - --- | Convert a UTCTime list into sensible ticks, placed exactly -makeTickDates :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Int, Text)] -makeTickDates pc fmt n dates = - lastOnes (\(_, x0) (_, x1) -> x0 == x1) . fst $ placedTimeLabelDiscontinuous pc fmt n dates - where - lastOnes :: (a -> a -> Bool) -> [a] -> [a] - lastOnes _ [] = [] - lastOnes _ [x] = [x] - lastOnes f (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x, []) xs - where - step (a0, rs) a1 = if f a0 a1 then (a1, rs) else (a1, a0 : rs) - --- | Convert a UTCTime list into sensible ticks, placed on the (0,1) space -makeTickDatesContinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Double, Text)] -makeTickDatesContinuous pc fmt n dates = placedTimeLabelContinuous pc fmt n (l, u) - where - l = minimum dates - u = maximum dates - -legendHud :: LegendOptions -> [Chart Double] -> Hud Double -legendHud l lcs = Hud $ \cs -> do - ca <- use #chartDim - let cs' = cs <> movedleg ca scaledleg - #chartDim .= fromMaybe one (styleBoxes cs') - pure cs' - where - scaledleg = - (#annotation %~ scaleAnn (realToFrac $ l ^. #lscale)) - . (#xys %~ fmap (fmap (* l ^. #lscale))) - <$> lcs - movedleg ca' leg = - maybe id (moveChart . PointXY . placel (l ^. #lplace) ca') (styleBoxes leg) leg - placel pl (Rect x z y w) (Rect x' z' y' w') = - case pl of - PlaceTop -> Point ((x + z) / 2.0) (w + (w' - y') / 2.0) - PlaceBottom -> Point ((x + z) / 2.0) (y - (w' - y' / 2.0)) - PlaceLeft -> Point (x - (z' - x') / 2.0) ((y + w) / 2.0) - PlaceRight -> Point (z + (z' - x') / 2.0) ((y + w) / 2.0) - PlaceAbsolute p -> p - -legendEntry :: - LegendOptions -> - Annotation -> - Text -> - (Chart Double, Chart Double) -legendEntry l a t = - ( Chart ann sps, - Chart (TextA (l ^. #ltext & #anchor .~ AnchorStart) [t]) [zero] - ) - where - (ann, sps) = case a of - RectA rs -> - ( RectA rs, - [R 0 (l ^. #lsize) 0 (l ^. #lsize)] - ) - PixelA ps -> - ( PixelA ps, - [R 0 (l ^. #lsize) 0 (l ^. #lsize)] - ) - TextA ts txts -> - ( TextA (ts & #size .~ realToFrac (l ^. #lsize)) (take 1 txts), - [zero] - ) - GlyphA gs -> - ( GlyphA (gs & #size .~ realToFrac (l ^. #lsize)), - [P (0.5 * l ^. #lsize) (0.33 * l ^. #lsize)] - ) - LineA ls -> - ( LineA (ls & #width %~ (/ (realToFrac $ l ^. #lscale))), - [P 0 (0.33 * l ^. #lsize), P (2 * l ^. #lsize) (0.33 * l ^. #lsize)] - ) - BlankA -> - ( BlankA, - [zero] - ) - -legendChart :: [(Annotation, Text)] -> LegendOptions -> [Chart Double] -legendChart lrs l = - padChart (l ^. #outerPad) - . maybe id (\x -> frameChart x (l ^. #innerPad)) (l ^. #legendFrame) - . vert (l ^. #hgap) - $ (\(a, t) -> hori ((l ^. #vgap) + twidth - gapwidth t) [[t], [a]]) - <$> es - where - es = reverse $ uncurry (legendEntry l) <$> lrs - twidth = maybe 0 (\(Rect _ z _ _) -> z) . foldRect $ catMaybes (styleBox . snd <$> es) - gapwidth t = maybe 0 (\(Rect _ z _ _) -> z) (styleBox t) - -legendFromChart :: [Text] -> [Chart Double] -> [(Annotation, Text)] -legendFromChart = zipWith (\t c -> (c ^. #annotation, t)) - -terms :: Text -> [Lucid.Attribute] -> Lucid.Html () -terms t = with $ makeXmlElementNoEnd t - --- | the extra area from text styling -styleBoxText :: - TextStyle -> - Text -> - Point Double -> - Rect Double -styleBoxText o t p = move (p + p') $ maybe flat (`rotateRect` flat) (o ^. #rotation) - where - flat = Rect ((- x' / 2.0) + x' * a') (x' / 2 + x' * a') ((- y' / 2) - n1') (y' / 2 - n1') - s = o ^. #size - h = o ^. #hsize - v = o ^. #vsize - n1 = o ^. #nudge1 - x' = s * h * fromIntegral (sum $ maybe 0 Text.length . maybeTagText <$> parseTags t) - y' = s * v - n1' = s * n1 - a' = case o ^. #anchor of - AnchorStart -> 0.5 - AnchorEnd -> -0.5 - AnchorMiddle -> 0.0 - p' = fromMaybe (Point 0.0 0.0) (o ^. #translate) - --- | the extra area from glyph styling -styleBoxGlyph :: GlyphStyle -> Rect Double -styleBoxGlyph s = move p' $ sw $ case sh of - EllipseGlyph a -> NH.scale (Point sz (a * sz)) one - RectSharpGlyph a -> NH.scale (Point sz (a * sz)) one - RectRoundedGlyph a _ _ -> NH.scale (Point sz (a * sz)) one - VLineGlyph _ -> NH.scale (Point ((s ^. #borderSize) * sz) sz) one - HLineGlyph _ -> NH.scale (Point sz ((s ^. #borderSize) * sz)) one - TriangleGlyph a b c -> (sz *) <$> sconcat (toRect . PointXY <$> (a :| [b, c]) :: NonEmpty (Rect Double)) - _ -> (sz *) <$> one - where - sh = s ^. #shape - sz = s ^. #size - sw = padRect (0.5 * s ^. #borderSize) - p' = fromMaybe (Point 0.0 0.0) (s ^. #translate) - --- | the geometric dimensions of a Chart inclusive of style geometry -styleBox :: Chart Double -> Maybe (Rect Double) -styleBox (Chart (TextA s ts) xs) = foldRect $ zipWith (\t x -> styleBoxText s t (toPoint x)) ts xs -styleBox (Chart (GlyphA s) xs) = foldRect $ (\x -> move (toPoint x) (styleBoxGlyph s)) <$> xs -styleBox (Chart (RectA s) xs) = foldRect (padRect (0.5 * s ^. #borderSize) . toRect <$> xs) -styleBox (Chart (LineA s) xs) = foldRect (padRect (0.5 * s ^. #width) . toRect <$> xs) -styleBox (Chart BlankA xs) = foldRect (toRect <$> xs) -styleBox (Chart (PixelA s) xs) = foldRect (padRect (0.5 * s ^. #pixelRectStyle . #borderSize) . toRect <$> xs) - --- | the extra geometric dimensions of a [Chart] -styleBoxes :: [Chart Double] -> Maybe (Rect Double) -styleBoxes xss = foldRect $ catMaybes (styleBox <$> xss) - --- | geometric dimensions of a [Chart] not including style -noStyleBoxes :: [Chart Double] -> Maybe (Rect Double) -noStyleBoxes cs = foldRect $ toRect <$> mconcat (view #xys <$> cs) - --- | calculate the linear gradient to shove in defs --- FIXME: Only works for #pixelGradient = 0 or pi//2. Can do much better with something like https://stackoverflow.com/questions/9025678/how-to-get-a-rotated-linear-gradient-svg-for-use-as-a-background-image -lgPixel :: PixelStyle -> Lucid.Html () -lgPixel o = - term - "linearGradient" - [ Lucid.id_ (o ^. #pixelTextureId), - Lucid.makeAttribute "x1" (show x0), - Lucid.makeAttribute "y1" (show y0), - Lucid.makeAttribute "x2" (show x1), - Lucid.makeAttribute "y2" (show y1) - ] - ( mconcat - [ terms - "stop" - [ Lucid.makeAttribute "stop-opacity" (show $ opac $ o ^. #pixelColorMin), - Lucid.makeAttribute "stop-color" (toHex (o ^. #pixelColorMin)), - Lucid.makeAttribute "offset" "0" - ], - terms - "stop" - [ Lucid.makeAttribute "stop-opacity" (show $ opac $ o ^. #pixelColorMax), - Lucid.makeAttribute "stop-color" (toHex (o ^. #pixelColorMax)), - Lucid.makeAttribute "offset" "1" - ] - ] - ) - where - x0 = min 0 (cos (o ^. #pixelGradient)) - x1 = max 0 (cos (o ^. #pixelGradient)) - y0 = max 0 (sin (o ^. #pixelGradient)) - y1 = min 0 (sin (o ^. #pixelGradient)) - --- | get chart definitions -chartDefs :: [Chart a] -> Lucid.Html () -chartDefs cs = bool (term "defs" (mconcat ds)) mempty (0 == length ds) - where - ds = mconcat $ chartDef <$> cs - -chartDef :: Chart a -> [Lucid.Html ()] -chartDef c = case c of - (Chart (PixelA s) _) -> [lgPixel s] - _ -> [] - --- | Rectangle svg -svgRect :: Rect Double -> Lucid.Html () -svgRect (Rect x z y w) = - terms - "rect" - [ width_ (show $ z - x), - height_ (show $ w - y), - term "x" (show x), - term "y" (show $ - w) - ] - --- | Text svg -svgText :: TextStyle -> Text -> Point Double -> Lucid.Html () -svgText s t p@(Point x y) = - bool id (term "g" [class_ "hasmathjax"]) (s ^. #hasMathjax) $ - term - "text" - ( [ term "x" (show x), - term "y" (show $ - y) - ] - <> maybe [] (\x' -> [term "transform" (toRotateText x' p)]) (s ^. #rotation) - ) - (toHtmlRaw t) - --- | line svg -svgLine :: [Point Double] -> Lucid.Html () -svgLine [] = mempty -svgLine xs = terms "polyline" [term "points" (toPointsText xs)] - where - toPointsText xs' = Text.intercalate "\n" $ (\(Point x y) -> show x <> "," <> show (- y)) <$> xs' - --- | GlyphShape to svg Tree -svgShape :: GlyphShape -> Double -> Point Double -> Lucid.Html () -svgShape CircleGlyph s (Point x y) = - terms - "circle" - [ term "cx" (show x), - term "cy" (show $ - y), - term "r" (show $ 0.5 * s) - ] -svgShape SquareGlyph s p = - svgRect (move p ((s *) <$> one)) -svgShape (RectSharpGlyph x') s p = - svgRect (move p (NH.scale (Point s (x' * s)) one)) -svgShape (RectRoundedGlyph x' rx ry) s p = - terms - "rect" - [ term "width" (show $ z - x), - term "height" (show $ w - y), - term "x" (show x), - term "y" (show $ - w), - term "rx" (show rx), - term "ry" (show ry) - ] - where - (Rect x z y w) = move p (NH.scale (Point s (x' * s)) one) -svgShape (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = - terms - "polygon" - [ term "transform" (toTranslateText p), - term "points" (show (s * xa) <> "," <> show (- (s * ya)) <> " " <> show (s * xb) <> "," <> show (- (s * yb)) <> " " <> show (s * xc) <> "," <> show (- (s * yc))) - ] -svgShape (EllipseGlyph x') s (Point x y) = - terms - "ellipse" - [ term "cx" (show x), - term "cy" (show $ - y), - term "rx" (show $ 0.5 * s), - term "ry" (show $ 0.5 * s * x') - ] -svgShape (VLineGlyph _) s (Point x y) = - terms "polyline" [term "points" (show x <> "," <> show (- (y - s / 2)) <> "\n" <> show x <> "," <> show (- (y + s / 2)))] -svgShape (HLineGlyph _) s (Point x y) = - terms "polyline" [term "points" (show (x - s / 2) <> "," <> show (- y) <> "\n" <> show (x + s / 2) <> "," <> show (- y))] -svgShape (PathGlyph path) _ p = - terms "path" [term "d" path, term "transform" (toTranslateText p)] - --- | GlyphStyle to svg Tree -svgGlyph :: GlyphStyle -> Point Double -> Lucid.Html () -svgGlyph s p = - svgShape (s ^. #shape) (s ^. #size) (realToFrac <$> p) - & maybe id (\r -> term "g" [term "transform" (toRotateText r p)]) (s ^. #rotation) - --- | convert a Chart to svg -svg :: Chart Double -> Lucid.Html () -svg (Chart (TextA s ts) xs) = - term "g" (attsText s) (mconcat $ zipWith (\t p -> svgText s t (toPoint p)) ts xs) -svg (Chart (GlyphA s) xs) = - term "g" (attsGlyph s) (mconcat $ svgGlyph s . toPoint <$> xs) -svg (Chart (LineA s) xs) = - term "g" (attsLine s) (svgLine $ toPoint <$> xs) -svg (Chart (RectA s) xs) = - term "g" (attsRect s) (mconcat $ svgRect . toRect <$> xs) -svg (Chart (PixelA s) xs) = - term "g" (attsPixel s) (mconcat $ svgRect . toRect <$> xs) -svg (Chart BlankA _) = mempty - --- | add a tooltip to a chart -svgt :: Chart Double -> (TextStyle, Text) -> Lucid.Html () -svgt (Chart (TextA s ts) xs) (s', ts') = - term "g" (attsText s) (Lucid.title_ (attsText s') (Lucid.toHtml ts') <> mconcat (zipWith (\t p -> svgText s t (toPoint p)) ts xs)) -svgt (Chart (GlyphA s) xs) (s', ts') = - term "g" (attsGlyph s) (Lucid.title_ (attsText s') (Lucid.toHtml ts') <> mconcat (svgGlyph s . toPoint <$> xs)) -svgt (Chart (LineA s) xs) (s', ts') = - term "g" (attsLine s) (Lucid.title_ (attsText s') (Lucid.toHtml ts') <> svgLine (toPoint <$> xs)) -svgt (Chart (RectA s) xs) (s', ts') = - term "g" (attsRect s) (Lucid.title_ (attsText s') (Lucid.toHtml ts') <> mconcat (svgRect . toRect <$> xs)) -svgt (Chart (PixelA s) xs) (s', ts') = - term "g" (attsPixel s) (Lucid.title_ (attsText s') (Lucid.toHtml ts') <> mconcat (svgRect . toRect <$> xs)) -svgt (Chart BlankA _) _ = mempty - --- * Style to Attributes - -attsRect :: RectStyle -> [Lucid.Attribute] -attsRect o = - [ term "stroke-width" (show $ o ^. #borderSize), - term "stroke" (hex $ o ^. #borderColor), - term "stroke-opacity" (show $ opac $ o ^. #borderColor), - term "fill" (hex $ o ^. #color), - term "fill-opacity" (show $ opac $ o ^. #color) - ] - -attsPixel :: PixelStyle -> [Lucid.Attribute] -attsPixel o = - [ term "stroke-width" (show $ o ^. #pixelRectStyle . #borderSize), - term "stroke" (toHex $ o ^. #pixelRectStyle . #borderColor), - term "stroke-opacity" (show $ opac $ o ^. #pixelRectStyle . #borderColor), - term "fill" ("url(#" <> (o ^. #pixelTextureId) <> ")") - ] - -attsText :: TextStyle -> [Lucid.Attribute] -attsText o = - [ term "stroke-width" "0.0", - term "stroke" "none", - term "fill" (toHex $ o ^. #color), - term "fill-opacity" (show $ opac $ o ^. #color), - 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" - toTextAnchor AnchorStart = "start" - toTextAnchor AnchorEnd = "end" - -attsGlyph :: GlyphStyle -> [Lucid.Attribute] -attsGlyph o = - [ term "stroke-width" (show $ o ^. #borderSize), - term "stroke" (toHex $ o ^. #borderColor), - term "stroke-opacity" (show $ opac $ o ^. #borderColor), - term "fill" (toHex $ o ^. #color), - term "fill-opacity" (show $ opac $ o ^. #color) - ] - <> maybe [] ((: []) . term "transform" . toTranslateText) (o ^. #translate) - -attsLine :: LineStyle -> [Lucid.Attribute] -attsLine o = - [ term "stroke-width" (show $ o ^. #width), - term "stroke" (toHex $ o ^. #color), - term "stroke-opacity" (show $ opac $ o ^. #color), - term "fill" "none" - ] - -toTranslateText :: Point Double -> Text -toTranslateText (Point x y) = - "translate(" <> show x <> ", " <> show (- y) <> ")" - -toRotateText :: Double -> Point Double -> Text -toRotateText r (Point x y) = - "rotate(" <> show r <> ", " <> show x <> ", " <> show (- y) <> ")" - --- | 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 = [RectXY Rect -0.5 0.5 -0.5 0.5]},Chart {annotation = BlankA, xys = [RectXY Rect -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 = []}] -frameChart :: RectStyle -> Double -> [Chart Double] -> [Chart Double] -frameChart rs p cs = [Chart (RectA rs) (maybeToList (RectXY . padRect p <$> styleBoxes cs))] <> cs - --- horizontally stack a list of list of charts (proceeding to the right) with a gap between -hori :: Double -> [[Chart Double]] -> [Chart Double] -hori _ [] = [] -hori gap cs = foldl step [] cs - where - step x a = x <> (a & fmap (#xys %~ fmap (\s -> P (z x) 0 - P (origx x) 0 + s))) - z xs = maybe 0 (\(Rect _ z' _ _) -> z' + gap) (styleBoxes xs) - origx xs = maybe 0 (\(Rect x' _ _ _) -> x') (styleBoxes xs) - --- vertically stack a list of charts (proceeding upwards), aligning them to the left -vert :: Double -> [[Chart Double]] -> [Chart Double] -vert _ [] = [] -vert gap cs = foldl step [] cs - where - step x a = x <> (a & fmap (#xys %~ fmap (\s -> P (origx x - origx a) (w x) + s))) - w xs = maybe 0 (\(Rect _ _ _ w') -> w' + gap) (styleBoxes xs) - origx xs = maybe 0 (\(Rect x' _ _ _) -> x') (styleBoxes xs) - --- stack a list of charts horizontally, then vertically +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- | Chart API +module Chart.Types + ( -- * Chart + Chart (..), + moveChart, + projectXYs, + projectXYsWith, + projectArcPosition, + + -- * Annotation + Annotation (..), + annotationText, + scaleAnn, + padRect, + + -- * Styles + RectStyle (..), + defaultRectStyle, + blob, + clear, + border, + TextStyle (..), + defaultTextStyle, + GlyphStyle (..), + defaultGlyphStyle, + GlyphShape (..), + glyphText, + LineStyle (..), + defaultLineStyle, + LineCap (..), + fromLineCap, + toLineCap, + LineJoin (..), + fromLineJoin, + toLineJoin, + fromDashArray, + Anchor (..), + fromAnchor, + toAnchor, + PathStyle (..), + toPathChart, + defaultPathStyle, + + -- * Hud types + ChartDims (..), + HudT (..), + Hud, + simulHud, + HudOptions (..), + defaultHudOptions, + defaultCanvas, + runHudWith, + runHud, + makeHud, + ChartAspect (..), + toChartAspect, + fromChartAspect, + initialCanvas, + chartAspectHud, + canvas, + title, + tick, + + -- * Hud primitives + AxisOptions (..), + defaultAxisOptions, + flipAxis, + Place (..), + placeText, + AxisBar (..), + defaultAxisBar, + Title (..), + defaultTitle, + Tick (..), + defaultGlyphTick, + defaultTextTick, + defaultLineTick, + defaultTick, + TickStyle (..), + defaultTickStyle, + tickStyleText, + TickExtend (..), + adjustTick, + makeTickDates, + makeTickDatesContinuous, + Adjustments (..), + defaultAdjustments, + LegendOptions (..), + defaultLegendOptions, + legendHud, + Orientation (..), + fromOrientation, + toOrientation, + + -- * SVG primitives + CssOptions (..), + SvgOptions (..), + defaultSvgOptions, + defaultSvgFrame, + + -- * Chart manipulation + padChart, + frameChart, + hori, + vert, + stack, + + -- * Bounding box calculation + padBox, + dataBox, + dataBoxes, + dataBoxesS, + styleBox, + styleBoxes, + styleBoxesS, + styleBoxText, + styleBoxGlyph, + ) +where + +import Control.Lens +import Data.Colour +import Data.FormatN +import Data.Generics.Labels () +import Data.List ((!!)) +import Data.Path +import qualified Data.Text as Text +import Data.Time +import NumHask.Prelude +import NumHask.Space as NH hiding (Element) +import Text.HTML.TagSoup hiding (Attribute) +import qualified Prelude as P + +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XNoImplicitPrelude +-- >>> -- import NumHask.Prelude +-- >>> import Control.Lens +-- >>> import Chart.Render + +-- * Chart + +-- | A `Chart` is annotated xy-data. +data Chart a = Chart + { -- | annotation style for the data + annotation :: Annotation, + -- | list of data elements, either points or rectangles. + xys :: [XY a] + } + deriving (Eq, Show, Generic) + +-- | How data will be represented onscreen. +-- +-- The definition of what might be an Annotation type is opinionated. +-- +-- More complex combinations across Annotations can be constructed from combining charts. See 'Chart.Example.glinesExample', 'Chart.Examples.lglyphExample' and "Chart.Bar" for examples. +-- +-- There may be exceptions, but the approximate magnitude of annotation values are in reference to the size of the screen. For example, a size of 0.01 (say), will means about 1% of the height and/or width of the screen height or width. +data Annotation + = RectA RectStyle + | TextA TextStyle [Text] + | GlyphA GlyphStyle + | LineA LineStyle + | PathA PathStyle [PathInfo Double] + | BlankA + deriving (Eq, Show, Generic) + +-- | textifier +annotationText :: Annotation -> Text +annotationText (RectA _) = "RectA" +annotationText TextA {} = "TextA" +annotationText (GlyphA _) = "GlyphA" +annotationText (LineA _) = "LineA" +annotationText PathA {} = "PathA" +annotationText BlankA = "BlankA" + +-- | 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]] +-- +-- ![unit example](other/unit.svg) +data RectStyle = RectStyle + { borderSize :: Double, + borderColor :: Colour, + color :: Colour + } + deriving (Show, Eq, Generic) + +-- | the style +defaultRectStyle :: RectStyle +defaultRectStyle = RectStyle 0.01 (fromRGB (palette !! 1) 0.8) (fromRGB (palette !! 1) 0.3) + +-- | 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} +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} +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} +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} +-- +-- >>> 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, + color :: Colour, + anchor :: Anchor, + hsize :: Double, + vsize :: Double, + nudge1 :: Double, + rotation :: Maybe Double, + translate :: Maybe (Point Double) + } + deriving (Show, Eq, Generic) + +-- | position anchor +data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic) + +-- | text +fromAnchor :: (IsString s) => Anchor -> s +fromAnchor AnchorMiddle = "Middle" +fromAnchor AnchorStart = "Start" +fromAnchor AnchorEnd = "End" + +-- | from text +toAnchor :: (Eq s, IsString s) => s -> Anchor +toAnchor "Middle" = AnchorMiddle +toAnchor "Start" = AnchorStart +toAnchor "End" = AnchorEnd +toAnchor _ = AnchorMiddle + +-- | the offical text style +defaultTextStyle :: TextStyle +defaultTextStyle = + TextStyle 0.08 colorText AnchorMiddle 0.5 1.45 -0.2 Nothing 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'. +-- +-- ![glyph example](other/glyphs.svg) +data GlyphStyle = GlyphStyle + { -- | glyph radius + size :: Double, + -- | fill color + color :: Colour, + -- | stroke color + borderColor :: Colour, + -- | stroke width (adds a bit to the bounding box) + borderSize :: Double, + shape :: GlyphShape, + rotation :: Maybe Double, + translate :: Maybe (Point Double) + } + deriving (Show, Eq, Generic) + +-- | the offical glyph style +defaultGlyphStyle :: GlyphStyle +defaultGlyphStyle = + GlyphStyle + 0.03 + (fromRGB (P.head palette) 0.3) + (fromRGB (palette !! 1) 0.8) + 0.003 + SquareGlyph + Nothing + Nothing + +-- | glyph shapes +data GlyphShape + = CircleGlyph + | SquareGlyph + | EllipseGlyph Double + | RectSharpGlyph Double + | RectRoundedGlyph Double Double Double + | TriangleGlyph (Point Double) (Point Double) (Point Double) + | VLineGlyph Double + | HLineGlyph Double + | PathGlyph Text + deriving (Show, Eq, Generic) + +-- | textifier +glyphText :: GlyphShape -> Text +glyphText sh = + case sh of + CircleGlyph -> "Circle" + SquareGlyph -> "Square" + TriangleGlyph {} -> "Triangle" + EllipseGlyph _ -> "Ellipse" + RectSharpGlyph _ -> "RectSharp" + RectRoundedGlyph {} -> "RectRounded" + VLineGlyph _ -> "VLine" + HLineGlyph _ -> "HLine" + PathGlyph _ -> "Path" + +-- | line cap style +data LineCap = LineCapButt | LineCapRound | LineCapSquare deriving (Eq, Show, Generic) + +-- | textifier +fromLineCap :: (IsString s) => LineCap -> s +fromLineCap LineCapButt = "butt" +fromLineCap LineCapRound = "round" +fromLineCap LineCapSquare = "square" + +-- | readifier +toLineCap :: (Eq s, IsString s) => s -> LineCap +toLineCap "butt" = LineCapButt +toLineCap "round" = LineCapRound +toLineCap "square" = LineCapSquare +toLineCap _ = LineCapButt + +-- | line cap style +data LineJoin = LineJoinMiter | LineJoinBevel | LineJoinRound deriving (Eq, Show, Generic) + +-- | textifier +fromLineJoin :: (IsString s) => LineJoin -> s +fromLineJoin LineJoinMiter = "miter" +fromLineJoin LineJoinBevel = "bevel" +fromLineJoin LineJoinRound = "round" + +-- | readifier +toLineJoin :: (Eq s, IsString s) => s -> LineJoin +toLineJoin "miter" = LineJoinMiter +toLineJoin "bevel" = LineJoinBevel +toLineJoin "round" = LineJoinRound +toLineJoin _ = LineJoinMiter + +-- | Convert a dash representation from a list to text +fromDashArray :: [Double] -> Text +fromDashArray xs = Text.intercalate " " $ show <$> xs + +-- | 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} +-- +-- ![line example](other/line.svg) +-- +-- See also +data LineStyle = LineStyle + { width :: Double, + color :: Colour, + linecap :: Maybe LineCap, + linejoin :: Maybe LineJoin, + dasharray :: Maybe [Double], + dashoffset :: Maybe Double + } + deriving (Show, Eq, Generic) + +-- | the official default line style +defaultLineStyle :: LineStyle +defaultLineStyle = LineStyle 0.012 (fromRGB (P.head palette) 0.3) 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} +data PathStyle = PathStyle + { borderSize :: Double, + borderColor :: Colour, + color :: Colour + } + deriving (Show, Eq, Generic) + +-- | the style +defaultPathStyle :: PathStyle +defaultPathStyle = + PathStyle 0.01 (fromRGB (palette !! 1) 0.8) (fromRGB (palette !! 1) 0.3) + +-- | Convert from a path command list to a PathA chart +toPathChart :: PathStyle -> [(PathInfo Double, Point Double)] -> Chart Double +toPathChart ps xs = Chart (PathA ps (fst <$> xs)) (PointXY . snd <$> xs) + +-- | Verticle or Horizontal +data Orientation = Vert | Hori deriving (Eq, Show, Generic) + +-- | textifier +fromOrientation :: (IsString s) => Orientation -> s +fromOrientation Hori = "Hori" +fromOrientation Vert = "Vert" + +-- | readifier +toOrientation :: (Eq s, IsString s) => s -> Orientation +toOrientation "Hori" = Hori +toOrientation "Vert" = Vert +toOrientation _ = Hori + +-- | additive padding +padRect :: (Num a) => a -> Rect a -> Rect a +padRect p (Rect x z y w) = Rect (x P.- p) (z P.+ p) (y P.- p) (w P.+ p) + +-- | +data CssOptions = UseGeometricPrecision | UseCssCrisp | NoCssOptions deriving (Show, Eq, Generic) + +-- | The basis for the x-y ratio of the final chart +-- +-- Default style features tend towards assuming that the usual height of the overall svg image is around 1, and ChartAspect is based on this assumption, so that a ChartAspect of "FixedAspect 1.5", say, means a height of 1 and a width of 1.5. +data ChartAspect + = -- | Rescale charts to a fixed x-y ratio, inclusive of hud and style features + FixedAspect Double + | -- | Rescale charts to an overall height of 1, preserving the x-y ratio of the data canvas. + CanvasAspect Double + | -- | Rescale charts to a height of 1, preserving the existing x-y ratio of the underlying charts, inclusive of hud and style. + ChartAspect + | -- | Do not rescale. + UnadjustedAspect + deriving (Show, Eq, Generic) + +-- | textifier +fromChartAspect :: (IsString s) => ChartAspect -> s +fromChartAspect (FixedAspect _) = "FixedAspect" +fromChartAspect (CanvasAspect _) = "CanvasAspect" +fromChartAspect ChartAspect = "ChartAspect" +fromChartAspect UnadjustedAspect = "UnadjustedAspect" + +-- | readifier +toChartAspect :: (Eq s, IsString s) => s -> Double -> ChartAspect +toChartAspect "FixedAspect" a = FixedAspect a +toChartAspect "CanvasAspect" a = CanvasAspect a +toChartAspect "ChartAspect" _ = ChartAspect +toChartAspect "UnadjustedAspect" _ = UnadjustedAspect +toChartAspect _ _ = ChartAspect + +-- | calculation of the canvas given the 'ChartAspect' +initialCanvas :: ChartAspect -> [Chart Double] -> Rect Double +initialCanvas (FixedAspect a) _ = aspect a +initialCanvas (CanvasAspect a) _ = aspect a +initialCanvas ChartAspect cs = aspect $ ratio $ styleBoxesS cs +initialCanvas UnadjustedAspect cs = dataBoxesS cs + +-- | SVG tag options. +-- +-- >>> defaultSvgOptions +-- SvgOptions {svgHeight = 300.0, outerPad = Just 2.0e-2, innerPad = Nothing, chartFrame = Nothing, cssOptions = NoCssOptions, chartAspect = FixedAspect 1.5} +-- +-- > writeChartSvg "other/svgoptions.svg" (SvgChart (defaultSvgOptions & #chartAspect .~ FixedAspect 0.7) mempty [] lines) +-- +-- ![svgoptions example](other/svgoptions.svg) +data SvgOptions = SvgOptions + { svgHeight :: Double, + outerPad :: Maybe Double, + innerPad :: Maybe Double, + chartFrame :: Maybe RectStyle, + cssOptions :: CssOptions, + chartAspect :: ChartAspect + } + deriving (Eq, Show, Generic) + +-- | The official svg options +defaultSvgOptions :: SvgOptions +defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoCssOptions (FixedAspect 1.5) + +-- | frame style +defaultSvgFrame :: RectStyle +defaultSvgFrame = border 0.01 (fromRGB (grayscale 0.7) 0.5) + +-- | Dimensions that are tracked in the 'HudT': +-- +-- - chartDim: the rectangular dimension of the physical representation of a chart on the screen so that new hud elements can be appended. Adding a hud piece tends to expand the chart dimension. +-- +-- - canvasDim: the rectangular dimension of the canvas on which data will be represented. At times appending a hud element will cause the canvas dimension to shift. +-- +-- - dataDim: the rectangular dimension of the data being represented. Adding hud elements can cause this to change. +data ChartDims a = ChartDims + { chartDim :: Rect a, + canvasDim :: Rect a, + dataDim :: Rect a + } + deriving (Eq, Show, Generic) + +-- | Hud monad transformer +newtype HudT m a = Hud {unhud :: [Chart a] -> StateT (ChartDims a) m [Chart a]} + +-- | Heads-Up-Display for a 'Chart' +type Hud = HudT Identity + +instance (Monad m) => Semigroup (HudT m a) where + (<>) (Hud h1) (Hud h2) = Hud $ h1 >=> h2 + +instance (Monad m) => Monoid (HudT m a) where + mempty = Hud pure + +-- | run two hud's simultaneously (using the same original ChartDims state) rather than sequentially (which is the <> operation). +simulHud :: (Ord a, Monad m) => HudT m a -> HudT m a -> HudT m a +simulHud (Hud fa) (Hud fb) = Hud $ \cs -> do + s <- get + (cs', ChartDims ch ca d) <- lift $ runStateT (fa cs) s + (cs'', ChartDims ch' ca' d') <- lift $ runStateT (fb cs') s + put (ChartDims (ch <> ch') (ca <> ca') (d <> d')) + pure cs'' + +-- | Project the chart data given the ChartAspect +chartAspectHud :: (Monad m) => ChartAspect -> HudT m Double +chartAspectHud fa = Hud $ \cs -> do + canvasd <- use #canvasDim + chartd <- use #chartDim + case fa of + FixedAspect a -> pure $ projectXYs (aspect a) cs + CanvasAspect a -> + pure $ + projectXYs (aspect (a * ratio canvasd / ratio chartd)) cs + ChartAspect -> pure $ projectXYs (aspect $ ratio chartd) cs + UnadjustedAspect -> pure cs + +-- | Combine huds and charts to form a new Chart using the supplied initial canvas and data dimensions. Note that chart data is transformed by this computation (and the use of a linear type is an open question). +runHudWith :: + -- | initial canvas dimension + Rect Double -> + -- | initial data dimension + Rect Double -> + -- | huds to add + [Hud Double] -> + -- | underlying chart + [Chart Double] -> + -- | integrated chart list + [Chart Double] +runHudWith ca xs hs cs = + evalState + ((unhud $ mconcat hs) cs') + (ChartDims ca' da' xs) + where + da' = fromMaybe one $ dataBoxes cs' + ca' = fromMaybe one $ styleBoxes cs' + cs' = projectXYsWith ca xs cs + +-- | Combine huds and charts to form a new [Chart] using the supplied canvas and the actual data dimension. +-- +-- Note that the original chart data are transformed and irrevocably lost by this computation. +runHud :: + -- | initial canvas dimension + Rect Double -> + -- | huds + [Hud Double] -> + -- | underlying charts + [Chart Double] -> + -- | integrated chart list + [Chart Double] +runHud ca hs cs = runHudWith ca (padBox $ dataBoxes cs) hs cs + +-- | Typical configurable hud elements. Anything else can be hand-coded as a 'HudT'. +-- +-- ![hud example](other/hudoptions.svg) +data HudOptions = HudOptions + { hudCanvas :: Maybe RectStyle, + hudTitles :: [Title], + hudAxes :: [AxisOptions], + hudLegend :: Maybe (LegendOptions, [(Annotation, Text)]) + } + deriving (Eq, Show, Generic) + +instance Semigroup HudOptions where + (<>) (HudOptions c t a l) (HudOptions c' t' a' l') = + HudOptions (listToMaybe $ catMaybes [c, c']) (t <> t') (a <> a') (listToMaybe $ catMaybes [l, l']) + +instance Monoid HudOptions where + mempty = HudOptions Nothing [] [] Nothing + +-- | The official hud options. +defaultHudOptions :: HudOptions +defaultHudOptions = + HudOptions + (Just defaultCanvas) + [] + [ defaultAxisOptions, + defaultAxisOptions & #place .~ PlaceLeft + ] + Nothing + +-- | The official hud canvas +defaultCanvas :: RectStyle +defaultCanvas = blob (fromRGB (grayscale 0.5) 0.025) + +-- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas +data Place + = PlaceLeft + | PlaceRight + | PlaceTop + | PlaceBottom + | PlaceAbsolute (Point Double) + deriving (Show, Eq, Generic) + +-- | textifier +placeText :: Place -> Text +placeText p = + case p of + PlaceTop -> "Top" + PlaceBottom -> "Bottom" + PlaceLeft -> "Left" + PlaceRight -> "Right" + PlaceAbsolute _ -> "Absolute" + +-- | axis options +data AxisOptions = AxisOptions + { axisBar :: Maybe AxisBar, + adjust :: Maybe Adjustments, + axisTick :: Tick, + place :: Place + } + deriving (Eq, Show, Generic) + +-- | The official axis +defaultAxisOptions :: AxisOptions +defaultAxisOptions = AxisOptions (Just defaultAxisBar) (Just defaultAdjustments) defaultTick PlaceBottom + +-- | The bar on an axis representing the x or y plane. +-- +-- >>> defaultAxisBar +-- AxisBar {rstyle = RectStyle {borderSize = 0.0, borderColor = 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} +data AxisBar = AxisBar + { rstyle :: RectStyle, + wid :: Double, + buff :: Double + } + deriving (Show, Eq, Generic) + +-- | The official axis bar +defaultAxisBar :: AxisBar +defaultAxisBar = AxisBar (RectStyle 0 (fromRGB (grayscale 0.5) 1) (fromRGB (grayscale 0.5) 1)) 0.005 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} +data Title = Title + { text :: Text, + style :: TextStyle, + place :: Place, + anchor :: Anchor, + buff :: Double + } + deriving (Show, Eq, Generic) + +-- | The official hud title +defaultTitle :: Text -> Title +defaultTitle txt = + Title + txt + ( (#size .~ 0.12) + . (#color .~ colorText) + $ defaultTextStyle + ) + PlaceTop + AnchorMiddle + 0.04 + +-- | 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)} +data Tick = Tick + { tstyle :: TickStyle, + gtick :: Maybe (GlyphStyle, Double), + ttick :: Maybe (TextStyle, Double), + ltick :: Maybe (LineStyle, Double) + } + deriving (Show, Eq, Generic) + +-- | The official glyph tick +defaultGlyphTick :: GlyphStyle +defaultGlyphTick = + defaultGlyphStyle + & #borderSize .~ 0.005 + & #borderColor .~ fromRGB (grayscale 0.5) 1 + & #color .~ fromRGB (grayscale 0.5) 1 + & #shape .~ VLineGlyph 0.005 + +-- | The official text tick +defaultTextTick :: TextStyle +defaultTextTick = + defaultTextStyle & #size .~ 0.05 & #color .~ fromRGB (grayscale 0.5) 1 + +-- | The official line tick +defaultLineTick :: LineStyle +defaultLineTick = + defaultLineStyle + & #color .~ fromRGB (grayscale 0.5) 0.05 + & #width .~ 5.0e-3 + +-- | The official tick +defaultTick :: Tick +defaultTick = + Tick + defaultTickStyle + (Just (defaultGlyphTick, 0.0125)) + (Just (defaultTextTick, 0.015)) + (Just (defaultLineTick, 0)) + +-- | Style of tick marks on an axis. +data TickStyle + = -- | no ticks on axis + TickNone + | -- | specific labels (equidistant placement) + TickLabels [Text] + | -- | sensibly rounded ticks, a guide to how many, and whether to extend beyond the data bounding box + TickRound FormatN Int TickExtend + | -- | exactly n equally spaced ticks + TickExact FormatN Int + | -- | specific labels and placement + TickPlaced [(Double, Text)] + deriving (Show, Eq, Generic) + +-- | The official tick style +defaultTickStyle :: TickStyle +defaultTickStyle = TickRound (FormatComma (Just 2)) 8 TickExtend + +-- | textifier +tickStyleText :: TickStyle -> Text +tickStyleText TickNone = "TickNone" +tickStyleText TickLabels {} = "TickLabels" +tickStyleText TickRound {} = "TickRound" +tickStyleText TickExact {} = "TickExact" +tickStyleText TickPlaced {} = "TickPlaced" + +-- | Whether Ticks are allowed to extend the data range +data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) + +-- | options for prettifying axis decorations +-- +-- >>> defaultAdjustments +-- Adjustments {maxXRatio = 8.0e-2, maxYRatio = 6.0e-2, angledRatio = 0.12, allowDiagonal = True} +data Adjustments = Adjustments + { maxXRatio :: Double, + maxYRatio :: Double, + angledRatio :: Double, + allowDiagonal :: Bool + } + deriving (Show, Eq, Generic) + +-- | The official hud adjustments. +defaultAdjustments :: Adjustments +defaultAdjustments = Adjustments 0.08 0.06 0.12 True + +-- | Legend options +-- +-- >>> defaultLegendOptions +-- LegendOptions {lsize = 0.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} +-- +-- ![legend example](other/legend.svg) +data LegendOptions = LegendOptions + { lsize :: Double, + vgap :: Double, + hgap :: Double, + ltext :: TextStyle, + lmax :: Int, + innerPad :: Double, + outerPad :: Double, + legendFrame :: Maybe RectStyle, + lplace :: Place, + lscale :: Double + } + deriving (Show, Eq, Generic) + +-- | The official legend options +defaultLegendOptions :: LegendOptions +defaultLegendOptions = + LegendOptions + 0.1 + 0.2 + 0.1 + ( defaultTextStyle + & #size .~ 0.08 + ) + 10 + 0.1 + 0.1 + (Just (RectStyle 0.02 (fromRGB (grayscale 0.5) 1) white)) + PlaceBottom + 0.2 + +-- | Generically scale an Annotation. +scaleAnn :: Double -> Annotation -> Annotation +scaleAnn x (LineA a) = LineA $ a & #width %~ (* x) +scaleAnn x (RectA a) = RectA $ a & #borderSize %~ (* x) +scaleAnn x (TextA a txs) = TextA (a & #size %~ (* x)) txs +scaleAnn x (GlyphA a) = GlyphA (a & #size %~ (* x)) +scaleAnn x (PathA a pxs) = PathA (a & #borderSize %~ (* x)) pxs +scaleAnn _ BlankA = BlankA + +-- | Translate the data in a chart. +moveChart :: (Additive a) => XY a -> [Chart a] -> [Chart a] +moveChart sp = fmap (#xys %~ fmap (sp +)) + +-- | Make huds from a HudOptions. +-- +-- Some huds, such as the creation of tick values, can extend the data dimension of a chart, so we return a blank chart with the new data dimension. +-- The complexity internally to this function is due to the creation of ticks and, specifically, 'gridSensible', which is not idempotent. As a result, a tick calculation that does extends the data area, can then lead to new tick values when applying TickRound etc. +makeHud :: Rect Double -> HudOptions -> ([Hud Double], [Chart Double]) +makeHud xs cfg = + ([axes] <> can <> titles <> l, xsext) + where + xs' = padBox (Just xs) + can = maybe [] (\x -> [canvas x]) (cfg ^. #hudCanvas) + titles = title <$> (cfg ^. #hudTitles) + ticks = + (\a -> freezeTicks (a ^. #place) xs' (a ^. #axisTick . #tstyle)) + <$> (cfg ^. #hudAxes) + hudaxes = + zipWith + (\c t -> c & #axisTick . #tstyle .~ fst t) + (cfg ^. #hudAxes) + ticks + tickRects = catMaybes (snd <$> ticks) + xsext = bool [Chart BlankA (RectXY <$> tickRects)] [] (tickRects == []) + axes = + foldr simulHud mempty $ + ( \x -> + maybe mempty (makeAxisBar (x ^. #place)) (x ^. #axisBar) + <> makeTick x + ) + <$> hudaxes + l = + maybe + [] + (\(lo, ats) -> [legendHud lo (legendChart ats lo)]) + (cfg ^. #hudLegend) + +-- | convert TickRound to TickPlaced +freezeTicks :: Place -> Rect Double -> TickStyle -> (TickStyle, Maybe (Rect Double)) +freezeTicks pl xs' ts@TickRound {} = maybe (ts, Nothing) (\x -> (TickPlaced (zip ps ls), Just x)) ((\x -> replaceRange pl x xs') <$> ext) + where + (TickComponents ps ls ext) = makeTicks ts (placeRange pl xs') + replaceRange :: Place -> Range Double -> Rect Double -> Rect Double + replaceRange pl' (Range a0 a1) (Rect x z y w) = case pl' of + PlaceRight -> Rect x z a0 a1 + PlaceLeft -> Rect x z a0 a1 + _ -> Rect a0 a1 y w +freezeTicks _ _ ts = (ts, Nothing) + +-- | flip an axis from being an X dimension to a Y one or vice-versa. +flipAxis :: AxisOptions -> AxisOptions +flipAxis ac = case ac ^. #place of + PlaceBottom -> ac & #place .~ PlaceLeft + PlaceTop -> ac & #place .~ PlaceRight + PlaceLeft -> ac & #place .~ PlaceBottom + PlaceRight -> ac & #place .~ PlaceTop + PlaceAbsolute _ -> ac + +addToRect :: (Ord a) => Rect a -> Maybe (Rect a) -> Rect a +addToRect r r' = sconcat $ r :| maybeToList r' + +-- | Make a canvas hud element. +canvas :: (Monad m) => RectStyle -> HudT m Double +canvas s = Hud $ \cs -> do + a <- use #canvasDim + let c = Chart (RectA s) [RectXY a] + #canvasDim .= addToRect a (styleBox c) + pure $ c : cs + +axisBar_ :: Place -> AxisBar -> Rect Double -> Rect Double -> Chart Double +axisBar_ pl b (Rect x z y w) (Rect x' z' y' w') = + case pl of + PlaceTop -> + Chart + (RectA (rstyle b)) + [ R + x + z + (w' + b ^. #buff) + (w' + b ^. #buff + b ^. #wid) + ] + PlaceBottom -> + Chart + (RectA (rstyle b)) + [ R + x + z + (y' - b ^. #wid - b ^. #buff) + (y' - b ^. #buff) + ] + PlaceLeft -> + Chart + (RectA (rstyle b)) + [ R + (x' - b ^. #wid - b ^. #buff) + (x' - b ^. #buff) + y + w + ] + PlaceRight -> + Chart + (RectA (rstyle b)) + [ R + (z' + (b ^. #buff)) + (z' + (b ^. #buff) + (b ^. #wid)) + y + w + ] + PlaceAbsolute (Point x'' _) -> + Chart + (RectA (rstyle b)) + [ R + (x'' + (b ^. #buff)) + (x'' + (b ^. #buff) + (b ^. #wid)) + y + w + ] + +makeAxisBar :: (Monad m) => Place -> AxisBar -> HudT m Double +makeAxisBar pl b = Hud $ \cs -> do + da <- use #chartDim + ca <- use #canvasDim + let c = axisBar_ pl b ca da + #chartDim .= addChartBox c da + pure $ c : cs + +title_ :: Title -> Rect Double -> Chart Double +title_ t a = + Chart + ( TextA + ( style' + & #translate ?~ (placePos' a + alignPos a) + & #rotation ?~ rot + ) + [t ^. #text] + ) + [zero] + where + style' + | t ^. #anchor == AnchorStart = + #anchor .~ AnchorStart $ t ^. #style + | t ^. #anchor == AnchorEnd = + #anchor .~ AnchorEnd $ t ^. #style + | otherwise = t ^. #style + rot + | t ^. #place == PlaceRight = pi / 2 + | t ^. #place == PlaceLeft = - pi / 2 + | otherwise = 0 + placePos' (Rect x z y w) = case t ^. #place of + PlaceTop -> Point ((x + z) / 2.0) (w + (t ^. #buff)) + PlaceBottom -> + Point + ((x + z) / 2.0) + ( y - (t ^. #buff) + - 0.5 + * (t ^. #style . #vsize) + * (t ^. #style . #size) + ) + PlaceLeft -> Point (x - (t ^. #buff)) ((y + w) / 2.0) + PlaceRight -> Point (z + (t ^. #buff)) ((y + w) / 2.0) + PlaceAbsolute p -> p + alignPos (Rect x z y w) + | t ^. #anchor == AnchorStart + && t ^. #place `elem` [PlaceTop, PlaceBottom] = + Point ((x - z) / 2.0) 0.0 + | t ^. #anchor == AnchorStart + && t ^. #place == PlaceLeft = + Point 0.0 ((y - w) / 2.0) + | t ^. #anchor == AnchorStart + && t ^. #place == PlaceRight = + Point 0.0 ((w - y) / 2.0) + | t ^. #anchor == AnchorEnd + && t ^. #place `elem` [PlaceTop, PlaceBottom] = + Point ((- x + z) / 2.0) 0.0 + | t ^. #anchor == AnchorEnd + && t ^. #place == PlaceLeft = + Point 0.0 ((- y + w) / 2.0) + | t ^. #anchor == AnchorEnd + && t ^. #place == PlaceRight = + Point 0.0 ((y - w) / 2.0) + | otherwise = Point 0.0 0.0 + +-- | Add a title to a chart. The logic used to work out placement is flawed due to being able to freely specify text rotation. It works for specific rotations (Top, Bottom at 0, Left at 90, Right @ 270) +title :: (Monad m) => Title -> HudT m Double +title t = Hud $ \cs -> do + ca <- use #chartDim + let c = title_ t ca + #chartDim .= addChartBox c ca + pure $ c : cs + +placePos :: Place -> Double -> Rect Double -> Point Double +placePos pl b (Rect x z y w) = case pl of + PlaceTop -> Point 0 (w + b) + PlaceBottom -> Point 0 (y - b) + PlaceLeft -> Point (x - b) 0 + PlaceRight -> Point (z + b) 0 + PlaceAbsolute p -> p + +placeRot :: Place -> Maybe Double +placeRot pl = case pl of + PlaceRight -> Just (pi / 2) + PlaceLeft -> Just (pi / 2) + _ -> Nothing + +textPos :: Place -> TextStyle -> Double -> Point Double +textPos pl tt b = case pl of + PlaceTop -> Point 0 b + PlaceBottom -> Point 0 (- b - 0.5 * (tt ^. #vsize) * (tt ^. #size)) + PlaceLeft -> + Point + (- b) + ((tt ^. #nudge1) * (tt ^. #vsize) * (tt ^. #size)) + PlaceRight -> + Point + b + ((tt ^. #nudge1) * (tt ^. #vsize) * (tt ^. #size)) + PlaceAbsolute p -> p + +placeRange :: Place -> Rect Double -> Range Double +placeRange pl (Rect x z y w) = case pl of + PlaceRight -> Range y w + PlaceLeft -> Range y w + _ -> Range x z + +placeOrigin :: Place -> Double -> Point Double +placeOrigin pl x + | pl `elem` [PlaceTop, PlaceBottom] = Point x 0 + | otherwise = Point 0 x + +placeTextAnchor :: Place -> (TextStyle -> TextStyle) +placeTextAnchor pl + | pl == PlaceLeft = #anchor .~ AnchorEnd + | pl == PlaceRight = #anchor .~ AnchorStart + | otherwise = id + +placeGridLines :: Place -> Rect Double -> Double -> Double -> [XY Double] +placeGridLines pl (Rect x z y w) a b + | pl `elem` [PlaceTop, PlaceBottom] = [P a (y - b), P a (w + b)] + | otherwise = [P (x - b) a, P (z + b) a] + +-- | compute tick values and labels given options, ranges and formatting +ticksR :: TickStyle -> Range Double -> Range Double -> [(Double, Text)] +ticksR s d r = + case s of + TickNone -> [] + TickRound f n e -> zip (project r d <$> ticks0) (formatNs f ticks0) + where + ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) + TickExact f n -> zip (project r d <$> ticks0) (formatNs f ticks0) + where + ticks0 = grid OuterPos r n + TickLabels ls -> + zip + ( project (Range 0 (fromIntegral $ length ls)) d + <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) + ) + ls + TickPlaced xs -> zip (project r d . fst <$> xs) (snd <$> xs) + +data TickComponents = TickComponents + { positions :: [Double], + labels :: [Text], + extension :: Maybe (Range Double) + } + deriving (Eq, Show, Generic) + +-- | compute tick components given style, ranges and formatting +makeTicks :: TickStyle -> Range Double -> TickComponents +makeTicks s r = + case s of + TickNone -> TickComponents [] [] Nothing + TickRound f n e -> + TickComponents + ticks0 + (formatNs f ticks0) + (bool (Just $ space1 ticks0) Nothing (e == NoTickExtend)) + where + ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) + TickExact f n -> TickComponents ticks0 (formatNs f ticks0) Nothing + where + ticks0 = grid OuterPos r n + TickLabels ls -> + TickComponents + ( project (Range 0 (fromIntegral $ length ls)) r + <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) + ) + ls + Nothing + TickPlaced xs -> TickComponents (fst <$> xs) (snd <$> xs) Nothing + +-- | compute tick values given placement, canvas dimension & data range +ticksPlaced :: TickStyle -> Place -> Rect Double -> Rect Double -> TickComponents +ticksPlaced ts pl d xs = TickComponents (project (placeRange pl xs) (placeRange pl d) <$> ps) ls ext + where + (TickComponents ps ls ext) = makeTicks ts (placeRange pl xs) + +tickGlyph_ :: Place -> (GlyphStyle, Double) -> TickStyle -> Rect Double -> Rect Double -> Rect Double -> Chart Double +tickGlyph_ pl (g, b) ts ca da xs = + Chart + (GlyphA (g & #rotation .~ placeRot pl)) + ( PointXY . (placePos pl b ca +) . placeOrigin pl + <$> positions + (ticksPlaced ts pl da xs) + ) + +-- | aka marks +tickGlyph :: + (Monad m) => + Place -> + (GlyphStyle, Double) -> + TickStyle -> + HudT m Double +tickGlyph pl (g, b) ts = Hud $ \cs -> do + a <- use #chartDim + d <- use #canvasDim + xs <- use #dataDim + let c = tickGlyph_ pl (g, b) ts a d xs + #chartDim .= addToRect a (styleBox c) + pure $ c : cs + +tickText_ :: + Place -> + (TextStyle, Double) -> + TickStyle -> + Rect Double -> + Rect Double -> + Rect Double -> + [Chart Double] +tickText_ pl (txts, b) ts ca da xs = + zipWith + ( \txt sp -> + Chart + ( TextA + (placeTextAnchor pl txts) + [txt] + ) + [PointXY sp] + ) + (labels $ ticksPlaced ts pl da xs) + ( (placePos pl b ca + textPos pl txts b +) . placeOrigin pl + <$> positions (ticksPlaced ts pl da xs) + ) + +-- | aka tick labels +tickText :: + (Monad m) => + Place -> + (TextStyle, Double) -> + TickStyle -> + HudT m Double +tickText pl (txts, b) ts = Hud $ \cs -> do + ca <- use #chartDim + da <- use #canvasDim + xs <- use #dataDim + let c = tickText_ pl (txts, b) ts ca da xs + #chartDim .= addChartBoxes c ca + pure $ c <> cs + +-- | aka grid lines +tickLine :: + (Monad m) => + Place -> + (LineStyle, Double) -> + TickStyle -> + HudT m Double +tickLine pl (ls, b) ts = Hud $ \cs -> do + da <- use #canvasDim + xs <- use #dataDim + let c = + Chart (LineA ls) . (\x -> placeGridLines pl da x b) + <$> positions (ticksPlaced ts pl da xs) + #chartDim %= addChartBoxes c + pure $ c <> cs + +-- | Create tick glyphs (marks), lines (grid) and text (labels) +tick :: + (Monad m) => + Place -> + Tick -> + HudT m Double +tick pl t = + maybe mempty (\x -> tickGlyph pl x (t ^. #tstyle)) (t ^. #gtick) + <> maybe mempty (\x -> tickText pl x (t ^. #tstyle)) (t ^. #ttick) + <> maybe mempty (\x -> tickLine pl x (t ^. #tstyle)) (t ^. #ltick) + <> extendData pl t + +-- | compute an extension to the Range if a tick went over the data bounding box +computeTickExtension :: TickStyle -> Range Double -> Maybe (Range Double) +computeTickExtension s r = + case s of + TickNone -> Nothing + TickRound _ n e -> bool Nothing (Just (space1 ticks0 <> r)) (e == TickExtend) + where + ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer) + TickExact _ _ -> Nothing + TickLabels _ -> Nothing + TickPlaced xs -> Just $ r <> space1 (fst <$> xs) + +-- | Create a style extension for the data, if ticks extend beyond the existing range +tickExtended :: + Place -> + Tick -> + Rect Double -> + Rect Double +tickExtended pl t xs = + maybe + xs + (rangeext xs) + (computeTickExtension (t ^. #tstyle) (ranged xs)) + where + ranged xs' = case pl of + PlaceTop -> rangex xs' + PlaceBottom -> rangex xs' + PlaceLeft -> rangey xs' + PlaceRight -> rangey xs' + PlaceAbsolute _ -> rangex xs' + rangex (Rect x z _ _) = Range x z + rangey (Rect _ _ y w) = Range y w + rangeext (Rect x z y w) (Range a0 a1) = case pl of + PlaceTop -> Rect a0 a1 y w + PlaceBottom -> Rect a0 a1 y w + PlaceLeft -> Rect x z a0 a1 + PlaceRight -> Rect x z a0 a1 + PlaceAbsolute _ -> Rect a0 a1 y w + +extendData :: (Monad m) => Place -> Tick -> HudT m Double +extendData pl t = Hud $ \cs -> do + #dataDim %= tickExtended pl t + pure cs + +-- | adjust Tick for sane font sizes etc +adjustTick :: + Adjustments -> + Rect Double -> + Rect Double -> + Place -> + Tick -> + Tick +adjustTick (Adjustments mrx ma mry ad) vb cs pl t + | pl `elem` [PlaceBottom, PlaceTop] = + if ad + then + ( case adjustSizeX > 1 of + True -> + ( case pl of + PlaceBottom -> #ttick . _Just . _1 . #anchor .~ AnchorEnd + PlaceTop -> #ttick . _Just . _1 . #anchor .~ AnchorStart + _ -> #ttick . _Just . _1 . #anchor .~ AnchorEnd + ) + . (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) + $ (#ttick . _Just . _1 . #rotation ?~ pi / 4) t + False -> (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) t + ) + else t & #ttick . _Just . _1 . #size %~ (/ adjustSizeX) + | otherwise -- pl `elem` [PlaceLeft, PlaceRight] + = + (#ttick . _Just . _1 . #size %~ (/ adjustSizeY)) t + where + max' [] = 1 + max' xs = maximum xs + ra (Rect x z y w) + | pl `elem` [PlaceTop, PlaceBottom] = Range x z + | otherwise = Range y w + asp = ra vb + r = ra cs + tickl = snd <$> ticksR (t ^. #tstyle) asp r + maxWidth :: Double + maxWidth = + maybe + 1 + ( \tt -> + max' $ + (\(Rect x z _ _) -> z - x) + . (\x -> styleBoxText (fst tt) x (Point 0 0)) + <$> tickl + ) + (t ^. #ttick) + maxHeight = + maybe + 1 + ( \tt -> + max' $ + (\(Rect _ _ y w) -> w - y) + . (\x -> styleBoxText (fst tt) x (Point 0 0)) + <$> tickl + ) + (t ^. #ttick) + adjustSizeX :: Double + adjustSizeX = max' [(maxWidth / (upper asp - lower asp)) / mrx, 1] + adjustSizeY = max' [(maxHeight / (upper asp - lower asp)) / mry, 1] + adjustSizeA = max' [(maxHeight / (upper asp - lower asp)) / ma, 1] + +makeTick :: (Monad m) => AxisOptions -> HudT m Double +makeTick c = Hud $ \cs -> do + vb <- use #chartDim + xs <- use #dataDim + let adjTick = + maybe + (c ^. #axisTick) + (\x -> adjustTick x vb xs (c ^. #place) (c ^. #axisTick)) + (c ^. #adjust) + unhud (tick (c ^. #place) adjTick) cs + +-- | Convert a UTCTime list into sensible ticks, placed exactly +makeTickDates :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Int, Text)] +makeTickDates pc fmt n dates = + lastOnes (\(_, x0) (_, x1) -> x0 == x1) . fst $ placedTimeLabelDiscontinuous pc fmt n dates + where + lastOnes :: (a -> a -> Bool) -> [a] -> [a] + lastOnes _ [] = [] + lastOnes _ [x] = [x] + lastOnes f (x : xs) = (\(x0, x1) -> reverse $ x0 : x1) $ foldl' step (x, []) xs + where + step (a0, rs) a1 = if f a0 a1 then (a1, rs) else (a1, a0 : rs) + +-- | Convert a UTCTime list into sensible ticks, placed on the (0,1) space +makeTickDatesContinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Double, Text)] +makeTickDatesContinuous pc fmt n dates = + placedTimeLabelContinuous pc fmt n (space1 dates) + +-- | Make a legend hud element taking into account the chart. +legendHud :: LegendOptions -> [Chart Double] -> Hud Double +legendHud l lcs = Hud $ \cs -> do + ca <- use #chartDim + let cs' = cs <> movedleg ca scaledleg + #chartDim .= fromMaybe one (styleBoxes cs') + pure cs' + where + scaledleg = + (#annotation %~ scaleAnn (l ^. #lscale)) + . (#xys %~ fmap (fmap (* l ^. #lscale))) + <$> lcs + movedleg ca' leg = + maybe id (moveChart . PointXY . placel (l ^. #lplace) ca') (styleBoxes leg) leg + placel pl (Rect x z y w) (Rect x' z' y' w') = + case pl of + PlaceTop -> Point ((x + z) / 2.0) (w + (w' - y') / 2.0) + PlaceBottom -> Point ((x + z) / 2.0) (y - (w' - y' / 2.0)) + PlaceLeft -> Point (x - (z' - x') / 2.0) ((y + w) / 2.0) + PlaceRight -> Point (z + (z' - x') / 2.0) ((y + w) / 2.0) + PlaceAbsolute p -> p + +legendEntry :: + LegendOptions -> + Annotation -> + Text -> + (Chart Double, Chart Double) +legendEntry l a t = + ( Chart ann sps, + Chart (TextA (l ^. #ltext & #anchor .~ AnchorStart) [t]) [zero] + ) + where + (ann, sps) = case a of + RectA rs -> + ( RectA rs, + [R 0 (l ^. #lsize) 0 (l ^. #lsize)] + ) + TextA ts txts -> + ( TextA (ts & #size .~ (l ^. #lsize)) (take 1 txts), + [zero] + ) + GlyphA gs -> + ( GlyphA (gs & #size .~ (l ^. #lsize)), + [P (0.5 * l ^. #lsize) (0.33 * l ^. #lsize)] + ) + LineA ls -> + ( LineA (ls & #width %~ (/ (l ^. #lscale))), + [P 0 (0.33 * l ^. #lsize), P (2 * l ^. #lsize) (0.33 * l ^. #lsize)] + ) + PathA ps _ -> + ( let cs = + singletonCubic + ( CubicPosition + (Point 0 0) + (Point (0.33 * l ^. #lsize) (0.33 * l ^. #lsize)) + (Point 0 (0.33 * l ^. #lsize)) + (Point (0.33 * l ^. #lsize) 0) + ) + in (PathA (ps & #borderSize .~ (l ^. #lsize)) (fst <$> cs), PointXY . snd <$> cs) + ) + BlankA -> + ( BlankA, + [zero] + ) + +legendChart :: [(Annotation, Text)] -> LegendOptions -> [Chart Double] +legendChart lrs l = + padChart (l ^. #outerPad) + . maybe id (\x -> frameChart x (l ^. #innerPad)) (l ^. #legendFrame) + . vert (l ^. #hgap) + $ (\(a, t) -> hori ((l ^. #vgap) + twidth - gapwidth t) [[t], [a]]) + <$> es + where + es = reverse $ uncurry (legendEntry l) <$> lrs + twidth = maybe 0 (\(Rect _ z _ _) -> z) . foldRect $ catMaybes (styleBox . snd <$> es) + gapwidth t = maybe 0 (\(Rect _ z _ _) -> z) (styleBox t) + +-- | Project the xys of a chart to a new XY Space. +-- +-- > projectXYs (dataBox cs) cs == cs if cs is non-empty +projectXYs :: Rect Double -> [Chart Double] -> [Chart Double] +projectXYs _ [] = [] +projectXYs new cs = projectXYsWith new old cs + where + old = fromMaybe one (dataBoxes cs) + +-- | Project chart xys to a new XY Space from an old XY Space +-- +-- The projections needed are: +-- +-- - project the 'xys' +-- +-- - project the control points of bezier curves +-- +-- - project aspect changes only to radii of ellipticals. +-- +-- > projectXYsWith x x == id +projectXYsWith :: Rect Double -> Rect Double -> [Chart Double] -> [Chart Double] +projectXYsWith new old cs = cs' + where + xss = fmap (projectOn new old) . xys <$> cs + ss = projectAnn <$> cs + cs' = zipWith Chart ss xss + projectAnn (Chart (PathA ps ips) xys) = + PathA ps (projectControls ips xys) + projectAnn x = annotation x + + projectControls pis xys = + (reverse . snd) (foldl' (\(prevp, l) (i, xy) -> (xy, projectControl prevp xy i : l)) (zero, []) (zip pis xys)) + + projectControl _ _ (CubicI c1 c2) = + CubicI (projectOnP new old c1) (projectOnP new old c2) + projectControl _ _ (QuadI c) = + QuadI (projectOnP new old c) + projectControl p1 p2 (ArcI ai) = ArcI $ projectArcPosition new old (ArcPosition (toPoint p1) (toPoint p2) ai) + projectControl _ _ x = x + +-- | project an ArcPosition given new and old Rects +-- +-- The radii of the ellipse can be represented as: +-- +-- Point rx 0 & Point 0 ry +-- +-- These two points are firstly rotated by p and then undergo scaling... +projectArcPosition :: Rect Double -> Rect Double -> ArcPosition Double -> ArcInfo Double +projectArcPosition new old (ArcPosition _ _ (ArcInfo (Point rx ry) phi l cl)) = ArcInfo (Point rx'' ry'') phi l cl + where + rx' = rotateP phi (Point rx zero) + rx'' = norm $ rx' * NH.width new / NH.width old + ry' = rotateP phi (Point zero ry) + ry'' = norm $ ry' * NH.width new / NH.width old + +-- | pad a Rect to remove singleton dimensions +padBox :: Maybe (Rect Double) -> Rect Double +padBox = maybe one singletonUnit + where + singletonUnit (Rect x z y w) + | x == z && y == w = Rect (x - 0.5) (x + 0.5) (y - 0.5) (y + 0.5) + | x == z = Rect (x - 0.5) (x + 0.5) y w + | y == w = Rect x z (y - 0.5) (y + 0.5) + | otherwise = Rect x z y w + +-- | 'Rect' of a 'Chart', not including style +dataBox :: Chart Double -> Maybe (Rect Double) +dataBox c = + case c ^. #annotation of + PathA _ path' -> pathBoxes $ zip path' (toPoint <$> c ^. #xys) + _ -> foldRect $ fmap toRect (c ^. #xys) + +-- | 'Rect' of charts, not including style +dataBoxes :: [Chart Double] -> Maybe (Rect Double) +dataBoxes cs = foldRect $ catMaybes $ dataBox <$> cs + +-- | 'Rect' of charts, not including style, with defaults for Nothing and singleton dimensions if any. +dataBoxesS :: [Chart Double] -> Rect Double +dataBoxesS cs = padBox $ foldRect $ catMaybes $ dataBox <$> cs + +-- | the extra area from text styling +styleBoxText :: + TextStyle -> + Text -> + Point Double -> + Rect Double +styleBoxText o t p = move (p + p') $ maybe flat (`rotationBound` flat) (o ^. #rotation) + where + flat = Rect ((- x' / 2.0) + x' * a') (x' / 2 + x' * a') ((- y' / 2) - n1') (y' / 2 - n1') + s = o ^. #size + h = o ^. #hsize + v = o ^. #vsize + n1 = o ^. #nudge1 + x' = s * h * fromIntegral (sum $ maybe 0 Text.length . maybeTagText <$> parseTags t) + y' = s * v + n1' = s * n1 + a' = case o ^. #anchor of + AnchorStart -> 0.5 + AnchorEnd -> -0.5 + AnchorMiddle -> 0.0 + p' = fromMaybe (Point 0.0 0.0) (o ^. #translate) + +-- | the extra area from glyph styling +styleBoxGlyph :: GlyphStyle -> Rect Double +styleBoxGlyph s = move p' $ + sw $ case sh of + CircleGlyph -> (sz *) <$> one + SquareGlyph -> (sz *) <$> one + EllipseGlyph a -> NH.scale (Point sz (a * sz)) one + RectSharpGlyph a -> NH.scale (Point sz (a * sz)) one + RectRoundedGlyph a _ _ -> NH.scale (Point sz (a * sz)) one + VLineGlyph _ -> NH.scale (Point ((s ^. #borderSize) * sz) sz) one + HLineGlyph _ -> NH.scale (Point sz ((s ^. #borderSize) * sz)) one + TriangleGlyph a b c -> (sz *) <$> sconcat (toRect . PointXY <$> (a :| [b, c]) :: NonEmpty (Rect Double)) + PathGlyph path' -> (sz *) <$> fromMaybe one (pathBoxes . toPathXYs . parsePath $ path') + where + sh = s ^. #shape + sz = s ^. #size + sw = padRect (0.5 * s ^. #borderSize) + p' = fromMaybe (Point 0.0 0.0) (s ^. #translate) + +-- | the geometric dimensions of a Chart inclusive of style geometry, but excluding PathA effects +styleBox :: Chart Double -> Maybe (Rect Double) +styleBox (Chart (TextA s ts) xs) = foldRect $ zipWith (\t x -> styleBoxText s t (toPoint x)) ts xs +styleBox (Chart (GlyphA s) xs) = foldRect $ (\x -> move (toPoint x) (styleBoxGlyph s)) <$> xs +styleBox (Chart (RectA s) xs) = foldRect (padRect (0.5 * s ^. #borderSize) . toRect <$> xs) +styleBox (Chart (LineA s) xs) = foldRect (padRect (0.5 * s ^. #width) . toRect <$> xs) +styleBox c@(Chart (PathA s _) _) = padRect (0.5 * s ^. #borderSize) <$> dataBox c +styleBox (Chart BlankA xs) = foldRect (toRect <$> xs) + +-- | the extra geometric dimensions of a [Chart] +styleBoxes :: [Chart Double] -> Maybe (Rect Double) +styleBoxes xss = foldRect $ catMaybes (styleBox <$> xss) + +-- | the extra geometric dimensions of a [Chart], adjusted for Nothing or singleton dimensions. +styleBoxesS :: [Chart Double] -> Rect Double +styleBoxesS xss = padBox $ foldRect $ catMaybes (styleBox <$> xss) + +-- | additively pad a [Chart] +-- +-- >>> 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]}] +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 = []}] +frameChart :: RectStyle -> Double -> [Chart Double] -> [Chart Double] +frameChart rs p cs = [Chart (RectA rs) (maybeToList (RectXY . padRect p <$> styleBoxes cs))] <> cs + +-- | horizontally stack a list of list of charts (proceeding to the right) with a gap between +hori :: Double -> [[Chart Double]] -> [Chart Double] +hori _ [] = [] +hori gap cs = foldl step [] cs + where + step x a = x <> (a & fmap (#xys %~ fmap (\s -> P (widthx x) (aligny x - aligny a) + s))) + widthx xs = maybe 0 (\(Rect x' z' _ _) -> z' - x' + gap) (styleBoxes xs) + aligny xs = maybe 0 (\(Rect _ _ y' _) -> y') (styleBoxes xs) + +-- | vertically stack a list of charts (proceeding upwards), aligning them to the left +vert :: Double -> [[Chart Double]] -> [Chart Double] +vert _ [] = [] +vert gap cs = foldl step [] cs + where + step x a = x <> (a & fmap (#xys %~ fmap (\s -> P (alignx x - alignx a) (widthy x) + s))) + widthy xs = maybe 0 (\(Rect _ _ y' w') -> w' - y' + gap) (styleBoxes xs) + alignx xs = maybe 0 (\(Rect x' _ _ _) -> x') (styleBoxes xs) + +-- | stack a list of charts horizontally, then vertically stack :: Int -> Double -> [[Chart Double]] -> [Chart Double] stack _ _ [] = [] stack n gap cs = vert gap (hori gap <$> group' cs []) diff --git a/src/Chart/Various.hs b/src/Chart/Various.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Various.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Various common chart patterns. +module Chart.Various + ( -- * sub-chart patterns + xify, + xify', + yify, + yify', + addLineX, + addLineY, + stdLineChart, + stdLines, + lineLegend, + tsAxes, + titlesHud, + gpalette, + gpaletteStyle, + blendMidLineStyles, + + -- * chart patterns + quantileChart, + digitChart, + scatterChart, + histChart, + quantileHistChart, + digitSurfaceChart, + tableChart, + ) +where + +import Chart +import Control.Lens +import qualified Data.HashMap.Strict as HashMap +import Data.List ((!!)) +import Data.Time (UTCTime (..)) +import NumHask.Prelude hiding (fold) +import NumHask.Space + +-- | convert from [a] to [Point a], by adding the index as the x axis +xify :: [Double] -> [Point Double] +xify ys = + zipWith Point [0 ..] ys + +-- | convert from [a] to [XY a], by adding the index as the x axis +xify' :: [Double] -> [XY Double] +xify' ys = + zipWith P [0 ..] ys + +-- | convert from [a] to [Point a], by adding the index as the y axis +yify :: [Double] -> [Point Double] +yify xs = + zipWith Point xs [0 ..] + +-- | convert from [a] to [XY a], by adding the index as the y axis +yify' :: [Double] -> [XY Double] +yify' xs = + zipWith P xs [0 ..] + +-- | add a horizontal line at y +addLineX :: Double -> LineStyle -> [Chart Double] -> [Chart Double] +addLineX y ls cs = cs <> [l] + where + l = Chart (LineA ls) (PointXY <$> [Point lx y, Point ux y]) + (Rect lx ux _ _) = fromMaybe one $ foldRect $ mconcat $ fmap toRect . xys <$> cs + +-- | add a verticle line at x +addLineY :: Double -> LineStyle -> [Chart Double] -> [Chart Double] +addLineY x ls cs = cs <> [zeroLine] + where + zeroLine = Chart (LineA ls) (PointXY <$> [Point x ly, Point x uy]) + (Rect _ _ ly uy) = fromMaybe one $ foldRect $ mconcat $ fmap toRect . xys <$> cs + +-- | interpret a [[Double]] as a series of lines with x coordinates of [0..] +stdLineChart :: Double -> [Colour] -> [[Double]] -> [Chart Double] +stdLineChart w p xss = + zipWith + ( \c xs -> + Chart + (LineA (defaultLineStyle & #color .~ c & #width .~ w)) + (xify' xs) + ) + p + xss + +-- | Can of the main palette +stdLines :: Double -> [LineStyle] +stdLines w = (\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> palette1 + +-- | Legend template for a line chart. +lineLegend :: Double -> [Text] -> [Colour] -> (LegendOptions, [(Annotation, Text)]) +lineLegend w rs cs = + ( defaultLegendOptions + & #ltext . #size .~ 0.3 + & #lplace .~ PlaceBottom + & #legendFrame .~ Just (RectStyle 0.02 (palette1 !! 5) white), + zipWith + (\a r -> (LineA a, r)) + ((\c -> defaultLineStyle & #color .~ c & #width .~ w) <$> cs) + rs + ) + +-- | Create a hud that has time as the x-axis, based on supplied days, and a rounded yaxis. +tsAxes :: [UTCTime] -> [AxisOptions] +tsAxes ds = + [ defaultAxisOptions + & #axisTick . #tstyle .~ TickRound (FormatPrec (Just 3)) 6 TickExtend + & #place .~ PlaceLeft, + defaultAxisOptions & #axisTick . #tstyle + .~ TickPlaced + ( first fromIntegral + <$> makeTickDates PosIncludeBoundaries Nothing 8 ds + ) + ] + +-- | common pattern of chart title, x-axis title and y-axis title +titlesHud :: Text -> Text -> Text -> HudOptions +titlesHud t x y = + defaultHudOptions + & #hudTitles + .~ [ defaultTitle t, + defaultTitle x & #place .~ PlaceBottom & #style . #size .~ 0.08, + defaultTitle y & #place .~ PlaceLeft & #style . #size .~ 0.08 + ] + +-- | GlyphStyle palette +gpaletteStyle :: Double -> [GlyphStyle] +gpaletteStyle s = zipWith (\c g -> defaultGlyphStyle & #size .~ s & #color .~ c & #shape .~ fst g & #borderSize .~ snd g) palette1 gpalette + +-- | Glyph palette +gpalette :: [(GlyphShape, Double)] +gpalette = + [ (CircleGlyph, 0.01 :: Double), + (SquareGlyph, 0.01), + (RectSharpGlyph 0.75, 0.01), + (RectRoundedGlyph 0.75 0.01 0.01, 0.01), + (EllipseGlyph 0.75, 0), + (VLineGlyph 0.005, 0.01), + (HLineGlyph 0.005, 0.01), + (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01), + (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01) + ] + +-- * charts + +-- | Chart template for quantiles. +quantileChart :: + Text -> + [Text] -> + [LineStyle] -> + [AxisOptions] -> + [[Double]] -> + (HudOptions, [Chart Double]) +quantileChart title names ls as xs = + (hudOptions, chart') + where + hudOptions = + defaultHudOptions + & #hudTitles .~ [defaultTitle title] + & ( #hudLegend + .~ Just + ( defaultLegendOptions + & #ltext . #size .~ 0.1 + & #vgap .~ 0.05 + & #innerPad .~ 0.2 + & #lplace .~ PlaceRight, + extractAnns names chart' + ) + ) + & #hudAxes .~ as + extractAnns = zipWith (\t c -> (c ^. #annotation, t)) + + chart' = + zipWith + (\l c -> Chart (LineA l) c) + ls + (zipWith P [0 ..] <$> xs) + +-- | /blendMidLineStyle n w/ produces n lines of width w interpolated between two colors. +blendMidLineStyles :: Int -> Double -> (Colour, Colour) -> [LineStyle] +blendMidLineStyles l w (c1, c2) = lo + where + m = (fromIntegral l - 1) / 2 :: Double + cs = (\x -> 1 - abs (fromIntegral x - m) / m) <$> [0 .. (l - 1)] + bs = (\x -> blend x c1 c2) <$> cs + lo = (\c -> defaultLineStyle & #width .~ w & #color .~ c) <$> bs + +-- | FIXME: better name +digitChart :: + Text -> + [UTCTime] -> + [Double] -> + (HudOptions, [Chart Double]) +digitChart title utcs xs = + (hudOptions, [c]) + where + hudOptions = + defaultHudOptions + & #hudTitles .~ [defaultTitle title] + & #hudAxes .~ tsAxes utcs + c = + Chart + ( GlyphA + ( defaultGlyphStyle + & #color .~ Colour 0 0 1 1 + & #shape .~ CircleGlyph + & #size .~ 0.01 + ) + ) + (xify' xs) + +-- | scatter chart +scatterChart :: + [[Point Double]] -> + [Chart Double] +scatterChart xss = zipWith (\gs xs -> Chart (GlyphA gs) (PointXY <$> xs)) (gpaletteStyle 0.02) xss + +-- | histogram chart +histChart :: + Text -> + Maybe [Text] -> + Range Double -> + Int -> + [Double] -> + (HudOptions, [Chart Double]) +histChart title names r g xs = + barChart defaultBarOptions barData + & first (#hudTitles .~ [defaultTitle title]) + where + barData = BarData [hr] names Nothing + hcuts = grid OuterPos r g + h = fill hcuts xs + hr = + (\(Rect x x' _ _) -> (x + x') / 2) + <$> makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) h + +-- | a chart drawing a histogram based on quantile information +quantileHistChart :: + Text -> + Maybe [Text] -> + -- | quantiles + [Double] -> + -- | quantile values + [Double] -> + (HudOptions, [Chart Double]) +quantileHistChart title names qs vs = (hudOptions, [chart']) + where + hudOptions = + defaultHudOptions + & #hudTitles + .~ [defaultTitle title] + & #hudAxes + .~ [ maybe + ( defaultAxisOptions & #axisTick . #tstyle + .~ TickRound (FormatPrec (Just 3)) 8 TickExtend + ) + ( \x -> + defaultAxisOptions & #axisTick . #tstyle + .~ TickPlaced (zip vs x) + ) + names + ] + chart' = Chart (RectA defaultRectStyle) (RectXY <$> hr) + hr = + zipWith + (\(y, w) (x, z) -> Rect x z 0 ((w - y) / (z - x))) + (zip qs (drop 1 qs)) + (zip vs (drop 1 vs)) + +-- | pixel chart of digitized vs digitized counts +digitSurfaceChart :: + SurfaceStyle -> + SurfaceLegendOptions -> + (Text, Text, Text) -> + [Text] -> + [(Int, Int)] -> + [Chart Double] +digitSurfaceChart pixelStyle plo ts names ps = + runHud (aspect 1) (hs0 <> hs1) (cs0 <> cs1) + where + l = length names + pts = Point l l + gr :: Rect Double + gr = fromIntegral <$> Rect 0 l 0 l + mapCount = foldl' (\m x -> HashMap.insertWith (+) x 1.0 m) HashMap.empty ps + f :: Point Double -> Double + f (Point x y) = fromMaybe 0 $ HashMap.lookup (floor x, floor y) mapCount + (hs0, cs0) = makeHud gr (qvqHud ts names) + (cs1, hs1) = + surfacefl + f + (SurfaceOptions pixelStyle pts gr) + plo + +-- style helpers +qvqHud :: (Text, Text, Text) -> [Text] -> HudOptions +qvqHud ts labels = + defaultHudOptions + & #hudTitles .~ makeTitles ts + & #hudAxes + .~ [ defaultAxisOptions + & #axisTick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labels) + & #place .~ PlaceLeft, + defaultAxisOptions + & #axisTick . #tstyle .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labels) + & #place .~ PlaceBottom + ] + +makeTitles :: (Text, Text, Text) -> [Title] +makeTitles (t, xt, yt) = + reverse + [ defaultTitle t, + defaultTitle xt & #place .~ PlaceBottom & #style . #size .~ 0.06, + defaultTitle yt & #place .~ PlaceLeft & #style . #size .~ 0.06 + ] + +-- | Chart for double list of Text. +tableChart :: [[Text]] -> [Chart Double] +tableChart tss = zipWith (\ts x -> Chart (TextA defaultTextStyle ts) (P x <$> take (length ts) [0 ..])) tss [0 ..] + diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs --- a/src/Data/Colour.hs +++ b/src/Data/Colour.hs @@ -1,26 +1,23 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} +-- | Colour representations and combinations, based on module Data.Colour - ( -- $color - Colour, + ( Colour, pattern Colour, opac, setOpac, @@ -29,6 +26,7 @@ palette, palette1, blend, + blends, toHex, fromHex, unsafeFromHex, @@ -37,9 +35,6 @@ transparent, black, white, - - -- * re-exports - module Graphics.Color.Model, ) where @@ -47,21 +42,17 @@ import Data.FormatN import Data.Generics.Labels () import qualified Data.Text as Text -import Graphics.Color.Model hiding (one, toRealFloat, zero) -import NumHask.Prelude +import Graphics.Color.Model +import NumHask.Prelude as NHP import qualified Prelude as P --- $setup --- --- >>> :set -XOverloadedLabels --- >>> :set -XNoImplicitPrelude --- >>> import Control.Lens --- >>> import Chart.Render - --- | snatching Colour as the library color representation. -newtype Colour = Colour' {color' :: Color (Alpha RGB) Double} deriving (Eq, Generic) +-- | Wrapper for 'Color'. +newtype Colour = + Colour' + { color' :: Color (Alpha RGB) Double + } deriving (Eq, Generic) --- | Constructor. +-- | Constructor pattern. pattern Colour :: Double -> Double -> Double -> Double -> Colour pattern Colour r g b a = Colour' (ColorRGBA r g b a) @@ -104,6 +95,26 @@ b'' = b + c * (b' - b) a'' = a + c * (a' - a) +-- | interpolate across a list of Colours, with input being in Range 0 1 +-- +-- >>> blends 0 [black, (Colour 0.2 0.6 0.8 0.5), white] == black +-- True +-- +-- >>> blends 1 [black, (Colour 0.2 0.6 0.8 0.5), white] == white +-- True +-- +-- >>> blends 0.6 [black, (Colour 0.2 0.6 0.8 0.5), white] +-- RGBA 0.16 0.48 0.64 0.60 +blends :: Double -> [Colour] -> Colour +blends _ [] = black +blends _ [c] = c +blends x cs = blend r (cs P.!! i) (cs P.!! (i+1)) + where + l = length cs - 1 + x' = x * fromIntegral l + i = max 0 (min (floor x') (l - 1)) + r = x' - fromIntegral i + -- | parseHex :: A.Parser (Color RGB Double) parseHex = @@ -131,10 +142,10 @@ <> Text.justifyRight 2 '0' (hex' g) <> Text.justifyRight 2 '0' (hex' b) where - (ColorRGBA r g b _) = toWord8 <$> color' c + (ColorRGBA r g b _) = toIntegral . toWord8 <$> color' c -- | -hex' :: (FromInteger a, ToIntegral a Integer, Integral a, Ord a, Subtractive a) => a -> Text +hex' :: Int -> Text hex' i | i < 0 = "-" <> go (- i) | otherwise = go i @@ -144,10 +155,10 @@ | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16) -- | -hexDigit :: (Ord a, FromInteger a, ToIntegral a Integer) => a -> Text +hexDigit :: Int -> Text hexDigit n - | n <= 9 = Text.singleton P.$! i2d (fromIntegral n) - | otherwise = Text.singleton P.$! toEnum (fromIntegral n + 87) + | n <= 9 = Text.singleton P.$! i2d n + | otherwise = Text.singleton P.$! toEnum (n + 87) -- | i2d :: Int -> Char @@ -155,7 +166,7 @@ -- | some RGB colors to work with palette :: [Color RGB Double] -palette = unsafeFromHex <$> ["#a6cee3", "#1f78b4", "#b2df8a", "#33a02c", "#fb9a99", "#e31a1c", "#fdbf6f", "#ff7f00", "#cab2d6", "#6a3d9a", "#ffff99", "#b15928"] +palette = unsafeFromHex <$> ["#a6cee3", "#1f78b4", "#e31a1c", "#b2df8a", "#33a02c", "#fb9a99", "#fdbf6f", "#ff7f00", "#cab2d6", "#6a3d9a", "#ffff99", "#b15928"] -- | some RGBA colors palette1 :: [Colour] diff --git a/src/Data/FormatN.hs b/src/Data/FormatN.hs --- a/src/Data/FormatN.hs +++ b/src/Data/FormatN.hs @@ -1,15 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TypeFamilies #-} @@ -18,9 +15,9 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} +-- | Formatting of numeric values. module Data.FormatN - ( -- $formats - FormatN (..), + ( FormatN (..), defaultFormatN, fromFormatN, toFormatN, @@ -33,6 +30,7 @@ formatN, precision, formatNs, + showOr, ) where @@ -120,7 +118,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 :: Int)) + + 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. @@ -146,7 +144,7 @@ | x > 1e6 = expt n x | otherwise = decimal n (toRealFloat x') where - x' = maybe fromFloatDigits roundSig n $ x + x' = maybe fromFloatDigits roundSig n x -- | round to n significant figures and always use decimal notation -- >>> decimal (Just 2) 0.000001234 @@ -157,7 +155,7 @@ decimal :: Maybe Int -> Double -> Text decimal n x = x'' where - x' = pack $ formatScientific Fixed Nothing $ maybe fromFloatDigits roundSig n $ x + x' = pack $ formatScientific Fixed Nothing $ maybe fromFloatDigits roundSig n x x'' = (\x -> bool x' (fst x) (snd x == ".0")) $ Text.breakOn "." x' -- | add commas format for numbers above 1,000 but below 1 million, otherwise use prec. @@ -176,7 +174,7 @@ Just _ -> addcomma (prec n x) where addcomma :: Text -> Text - addcomma x = (\x -> fst x <> snd x) . first (Text.reverse . Text.intercalate "," . Text.chunksOf 3 . Text.reverse) $ Text.breakOn "." x + addcomma x = uncurry (<>) . first (Text.reverse . Text.intercalate "," . Text.chunksOf 3 . Text.reverse) $ Text.breakOn "." x -- | dollars and cents, always decimal notation -- @@ -185,7 +183,7 @@ -- -- >>> dollar (Just 2) 0.01234 -- "$0.0123" -dollar :: (Maybe Int) -> Double -> Text +dollar :: Maybe Int -> Double -> Text dollar n x | x < 0 = "-" <> dollar n (- x) | otherwise = "$" <> comma n x @@ -230,3 +228,11 @@ formatNs (FormatDollar n) xs = precision dollar n xs formatNs (FormatPercent n) xs = precision percent n xs formatNs FormatNone xs = pack . show <$> xs + +-- | Format with the shorter of show and formatN. +showOr :: FormatN -> Double -> Text +showOr f x = bool (bool f' s' (Text.length s' < Text.length f')) "0" (x < 1e-6 && x > -1e-6) + where + f' = formatN f x + s' = show x + diff --git a/src/Data/Path.hs b/src/Data/Path.hs new file mode 100644 --- /dev/null +++ b/src/Data/Path.hs @@ -0,0 +1,694 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | SVG path manipulation +module Data.Path + ( -- * Path fundamental + -- $path + PathInfo (..), + ArcInfo (..), + ArcPosition (..), + parsePath, + toPathAbsolute, + toPathCommand, + toPathAbsolutes, + toPathXYs, + ArcCentroid (..), + arcCentroid, + arcPosition, + arcBox, + arcDerivs, + ellipse, + QuadPosition (..), + QuadPolar (..), + quadPosition, + quadPolar, + quadBox, + quadBezier, + quadDerivs, + CubicPosition (..), + CubicPolar (..), + cubicPosition, + cubicPolar, + cubicBox, + cubicBezier, + cubicDerivs, + singletonCubic, + singletonQuad, + singletonArc, + singletonPie, + singletonPie', + toSingletonArc, + pathBoxes, + pathBox, + ) 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 Data.Generics.Labels () +import qualified Geom2D.CubicBezier as B +import Data.FormatN + +-- $setup +-- >>> :set -XRebindableSyntax +-- >>> :set -XNegativeLiterals +-- >>> import NumHask.Prelude +-- >>> import Chart + +-- $path +-- Every element of an svg path can be thought of as exactly two points in space, with instructions of how to draw a curve between them. From this point of view, one which this library adopts, a path chart is thus very similar to a line chart. There's just a lot more information about the style of this line to deal with. +-- +-- References: +-- +-- [SVG d](https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d) +-- +-- [SVG path](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths) +-- + +-- | parse a raw path string +-- +-- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z" +-- >>> parsePath outerseg1 +-- [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: +-- +-- - 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) + deriving (Show, Eq, Generic) + +-- | convert from a path info, start point, end point triple to a path text clause. +-- +-- Note that morally, +-- +-- > toPathsAbsolute . toInfos . parsePath == id +-- +-- but the round trip destroys much information, including: +-- +-- - path text spacing +-- +-- - "Z", which is replaced by a LineI instruction from the end point back to the original start of the path. +-- +-- - Sequences of the same instruction type are uncompressed +-- +-- - As the name suggests, relative paths are translated to absolute ones. +-- +-- - implicit L's in multiple M instructions are separated. +-- +-- In converting between chart-svg and SVG there are two changes in reference: +-- +-- - arc rotation is expressed as positive degrees for a clockwise rotation in SVG, and counter-clockwise in radians for chart-svg +-- +-- - A positive y-direction is down for SVG and up for chart-svg +-- +toPathAbsolute :: + -- | (info, start, end) + (PathInfo Double, Point Double) -> + -- | path text + Text +toPathAbsolute (StartI,p) = "M " <> pp p +toPathAbsolute (LineI,p) = "L " <> pp p +toPathAbsolute (CubicI c1 c2, next) = + "C " <> + pp c1 <> " " <> + pp c2 <> " " <> + pp next +toPathAbsolute (QuadI control, next) = + "Q " <> + pp control <> " " <> + pp next +toPathAbsolute (ArcI (ArcInfo (Point x y) phi' l sw), x2) = + "A " <> + 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)) + +-- | convert an (info, point) list to an svg d path text. +toPathAbsolutes :: [(PathInfo Double, Point Double)] -> Text +toPathAbsolutes = L.fold (L.Fold step begin done) + where + done = Text.intercalate " " . reverse + begin = [] + step ts (info, next) = toPathAbsolute (info, next):ts + +-- | Convert from PathInfo to PathCommand +toPathCommand :: + (PathInfo Double, Point Double) -> + -- | path text + PathCommand +toPathCommand (StartI,p) = MoveTo OriginAbsolute [toV2 p] +toPathCommand (LineI,p) = LineTo OriginAbsolute [toV2 p] +toPathCommand (CubicI c1 c2, p) = CurveTo OriginAbsolute [(toV2 c1, toV2 c2, toV2 p)] +toPathCommand (QuadI c, p) = QuadraticBezier OriginAbsolute [(toV2 c, toV2 p)] +toPathCommand (ArcI (ArcInfo (Point rx ry) phi' l sw), p) = + EllipticalArc OriginAbsolute [(rx,ry,phi',l,sw,toV2 p)] + +toV2 :: Point a -> Linear.V2 a +toV2 (Point x y) = Linear.V2 x y + +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) + +stateInfo0 :: StateInfo +stateInfo0 = StateInfo zero zero zero + +-- | Convert a path command fragment to an instruction + point. +-- +-- flips the y-dimension of points. +toInfo :: StateInfo -> SvgTree.PathCommand -> (StateInfo, [(PathInfo Double, Point Double)]) +toInfo s (MoveTo _ []) = (s, []) +toInfo _ (MoveTo OriginAbsolute (x:xs)) = L.fold (L.Fold step begin (second reverse)) (fromV2 <$> xs) + where + x0 = fromV2 x + begin = (StateInfo x0 x0 zero, [(StartI, x0)]) + step (s, p) a = (s & #cur .~ a, (LineI, a):p) +toInfo s (MoveTo OriginRelative (x:xs)) = L.fold (L.Fold step begin (second reverse)) (fromV2 <$> xs) + where + x0 = s ^. #cur + fromV2 x + begin = (StateInfo x0 x0 zero, [(StartI, x0)]) + step (s, p) a = let a' = a + s ^. #cur in (s & #cur .~ a', (LineI, a'):p) +toInfo s EndPath = (s, [(LineI, s ^. #start)]) +toInfo s (LineTo OriginAbsolute xs) = L.fold (L.Fold step (s,[]) (second reverse)) (fromV2 <$> xs) + where + step (s, p) a = (s & #cur .~ a, (LineI, a):p) +toInfo s (LineTo OriginRelative xs) = L.fold (L.Fold step (s,[]) (second reverse)) (fromV2 <$> xs) + where + step (s, p) a = let a' = a + s ^. #cur in (s & #cur .~ a', (LineI, a'):p) +toInfo s (HorizontalTo OriginAbsolute xs) = L.fold (L.Fold step (s,[]) (second reverse)) xs + where + step (s@(StateInfo (Point _ cy) _ _), p) a = + let a' = Point a cy in (s & #cur .~ a', (LineI, a'):p) +toInfo s (HorizontalTo OriginRelative xs) = L.fold (L.Fold step (s,[]) (second reverse)) xs + where + step (s@(StateInfo (Point cx cy) _ _), p) a = + let a' = Point (a+cx) cy in (s & #cur .~ a', (LineI, a'):p) +toInfo s (VerticalTo OriginAbsolute xs) = L.fold (L.Fold step (s,[]) (second reverse)) xs + where + step (s@(StateInfo (Point cx _) _ _), p) a = + let a' = Point cx a in (s & #cur .~ a', (LineI, a'):p) +toInfo s (VerticalTo OriginRelative xs) = L.fold (L.Fold step (s,[]) (second reverse)) xs + where + step (s@(StateInfo (Point cx cy) _ _), p) a = + let a' = Point cx (a+cy) in (s & #cur .~ a', (LineI, a'):p) +toInfo s (CurveTo OriginAbsolute xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = (\(c1,c2,x2) -> (fromV2 c1, fromV2 c2, fromV2 x2)) <$> xs + step (s, p) (c1,c2,x2) = + (s & #cur .~ x2 & #infoControl .~ c2, (CubicI c1 c2, x2):p) +toInfo s (CurveTo OriginRelative xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = (\(c1,c2,x2) -> (fromV2 c1, fromV2 c2, fromV2 x2)) <$> xs + step (s, p) (c1,c2,x2) = + (s & #cur .~ (x2 + s ^. #cur) & #infoControl .~ (c2 + s ^. #cur), (CubicI (c1+ s ^. #cur) (c2 + s ^. #cur), x2 + s ^. #cur):p) +toInfo s (SmoothCurveTo OriginAbsolute xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = bimap fromV2 fromV2 <$> xs + step (s, p) (c2,x2) = + (s & #cur .~ x2, (CubicI (s ^. #cur - (s ^. #infoControl - s^. #cur)) c2, x2):p) +toInfo s (SmoothCurveTo OriginRelative xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = bimap fromV2 fromV2 <$> xs + step (s, p) (c2,x2) = + (s & + #cur .~ (x2 + s ^. #cur) & + #infoControl .~ (c2 + s ^. #cur), + (CubicI (s ^. #cur - (s ^. #infoControl - s^. #cur)) (c2 + s ^. #cur), x2 + s ^. #cur):p) +toInfo s (QuadraticBezier OriginAbsolute xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = bimap fromV2 fromV2 <$> xs + step (s, p) (c1, x2) = + (s & + #cur .~ x2 & + #infoControl .~ c1, + (QuadI c1, x2):p) +toInfo s (QuadraticBezier OriginRelative xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = bimap fromV2 fromV2 <$> xs + step (s, p) (c1,x2) = + (s & #cur .~ x2 & #infoControl .~ (c1 + s ^. #cur), (QuadI (c1 + s ^. #cur), x2 + s ^. #cur):p) +toInfo s (SmoothQuadraticBezierCurveTo OriginAbsolute xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = fromV2 <$> xs + step (s, p) x2 = + (s & + #cur .~ x2 & + #infoControl .~ (s ^. #cur - (s ^. #infoControl - s ^. #cur)), + (QuadI (s ^. #cur - (s ^. #infoControl - s^. #cur)), x2):p) +toInfo s (SmoothQuadraticBezierCurveTo OriginRelative xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = fromV2 <$> xs + step (s, p) x2 = + (s & + #cur .~ (x2 + s ^. #cur) & + #infoControl .~ (s ^. #cur - (s ^. #infoControl - s ^. #cur)), + (QuadI (s ^. #cur - (s ^. #infoControl - s^. #cur)), x2 + s ^. #cur):p) +toInfo s (EllipticalArc OriginAbsolute xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = (\(x,y,r,l,sw,x2) -> (x,y,r,l,sw,fromV2 x2)) <$> xs + step (s, p) a@(_,_,_,_,_,x2) = + (s & #cur .~ x2, (fromPathEllipticalArc (s ^. #cur) a, x2):p) +toInfo s (EllipticalArc OriginRelative xs) = + L.fold (L.Fold step (s,[]) (second reverse)) xs' + where + xs' = (\(x,y,r,l,sw,x2) -> (x,y,r,l,sw,fromV2 x2)) <$> xs + step (s, p) a@(_,_,_,_,_,x2) = + let x2' = x2 + s ^. #cur in + (s & #cur .~ x2', (fromPathEllipticalArc (s ^. #cur) a, x2'):p) + +fromPathEllipticalArc :: Point a -> (a, a, a, Bool, Bool, Point a) -> PathInfo a +fromPathEllipticalArc _ (x, y, r, l, s, _) = ArcI (ArcInfo (Point x y) r l s) + +fromV2 :: (Subtractive a) => Linear.V2 a -> Point a +fromV2 (Linear.V2 x y) = Point x (-y) + +-- | Convert from a path command list to a PathA specification +-- +toPathXYs :: [SvgTree.PathCommand] -> [(PathInfo Double, Point Double)] +toPathXYs [] = [] +toPathXYs xs = + snd (foldl' (\(x,l) a -> second (l<>) $ toInfo x a) (stateInfo0,[]) xs) + +-- | convert cubic position to path info. +singletonCubic :: CubicPosition Double -> [(PathInfo Double, Point Double)] +singletonCubic (CubicPosition s e c1 c2) = [(StartI, s), (CubicI c1 c2, e)] + +-- | convert quad position to path info. +singletonQuad :: QuadPosition Double -> [(PathInfo Double, Point Double)] +singletonQuad (QuadPosition s e c) = [(StartI, s), (QuadI c, e)] + +-- | convert arc position to path info. +singletonArc :: ArcPosition Double -> [(PathInfo Double, Point Double)] +singletonArc (ArcPosition s e i) = [(StartI, s), (ArcI i, e)] + +-- | convert arc position to a pie slice. +singletonPie :: ArcPosition Double -> [(PathInfo Double, Point Double)] +singletonPie p@(ArcPosition s e i) = [(StartI, c), (LineI, s), (ArcI i, e), (LineI, c)] + where + ac = arcCentroid p + c = ac ^. #centroid + +-- | convert arc position to a pie slice, with a specific center. +singletonPie' :: Point Double -> ArcPosition Double -> [(PathInfo Double, Point Double)] +singletonPie' c (ArcPosition s e i) = [(StartI, c), (LineI, s), (ArcI i, e), (LineI, c)] + +-- | convert path info to an ArcPosition. +toSingletonArc :: [(PathInfo Double, Point Double)] -> Maybe (ArcPosition Double) +toSingletonArc ((StartI, s):(ArcI i, e):_) = Just $ ArcPosition s e i +toSingletonArc _ = Nothing + +-- * Arc types +-- | Information about an individual arc path. +-- +data ArcInfo a = + ArcInfo + { -- | ellipse radii + radii :: Point a, + -- | rotation of the ellipse. positive means counter-clockwise (which is different to SVG). + phi :: a, + large :: Bool, + -- | sweep means clockwise + clockwise :: Bool + } deriving (Eq, Show, Generic) + +-- | Specification of an Arc using positional referencing as per SVG standard. +data ArcPosition a = + ArcPosition + { posStart :: Point a, + posEnd :: Point a, + posInfo :: ArcInfo a + } deriving (Eq, Show, Generic) + +-- | Arc specification based on centroidal interpretation. +-- +-- See: https://www.w3.org/TR/SVG/implnote.html#ArcConversionEndpointToCenter +-- +data ArcCentroid a = + ArcCentroid + { -- | ellipse center + centroid :: Point a, + -- | ellipse radii + radius :: Point a, + -- | ellipse rotation + cphi :: a, + -- | starting point angle to the x-axis + ang0 :: a, + -- | difference between ending point angle and starting point angle + angdiff :: a + } deriving (Eq, Show, Generic) + +-- | convert from an ArcPosition spec to ArcCentroid spec. +-- +-- >>> let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) +-- >>> arcCentroid p +-- ArcCentroid {centroid = Point 0.20952624903444356 -0.48412291827592724, radius = Point 1.0 0.5, cphi = 0.7853981633974483, ang0 = 1.3753858999692936, angdiff = -1.823476581936975} +arcCentroid :: (FromInteger a, Ord a, TrigField a, ExpField a) => ArcPosition a -> ArcCentroid a +arcCentroid (ArcPosition p1@(Point x1 y1) p2@(Point x2 y2) (ArcInfo rad phi large clockwise)) = ArcCentroid c (Point rx ry) phi ang1 angd + where + (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 + cx = (x1 + x2) / 2 + cos phi * cx' - sin phi * cy' + cy = (y1 + y2) / 2 + sin phi * cx' + cos phi * cy' + c = Point cx cy + ang1 = angle (Point (-(cx'-x1')/rx) (-(cy'-y1')/ry)) + ang2 = angle (Point (-(cx'+x1')/rx) (-(cy'+y1')/ry)) + angd' = ang2 - ang1 + angd = + bool 0 (2*pi) (not clockwise && angd'<0) + + bool 0 (-2*pi) (clockwise && angd'>0) + + angd' + +-- | convert from an ArcCentroid to an ArcPosition specification. +-- +-- Morally, +-- > arcPosition . arcCentroid == id +-- +-- Not isomorphic if: +-- +-- - 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) + large = abs angd > pi + clockwise = angd < zero + +-- | ellipse formulae +-- +-- >>> ellipse zero (Point 1 2) (pi/6) pi +-- Point -0.8660254037844388 -0.4999999999999997 +-- +-- 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\] +-- +-- with the haskell code: +-- +-- > 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)) + +-- | compute the bounding box for an arcBox +-- +-- > let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) +-- > arcBox p +-- Rect -8.326672684688674e-17 0.9999999999999998 -5.551115123125783e-17 0.30644649676616753 +arcBox :: ArcPosition Double -> Rect Double +arcBox p = space1 pts + where + (ArcCentroid c r phi ang0 angd) = arcCentroid p + (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 + ] + pts = ellipse c r phi <$> angs + +-- | potential arc turning points. +-- +-- >>> arcDerivs (Point 1 0.5) (pi/4) +-- (-0.4636476090008061,0.4636476090008062) +arcDerivs :: Point Double -> Double -> (Double, Double) +arcDerivs (Point rx ry) phi = (thetax1, thetay1) + where + 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 + { -- | starting point + qposStart :: Point a, + -- | ending point + qposEnd :: Point a, + -- | control point + qposControl :: Point a + } deriving (Eq, Show, Generic) + +-- | Quadratic bezier curve with control point expressed in polar terms normalised to the start - end line. +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) + +-- | Convert from a positional to a polar representation of a cubic bezier. +-- +-- >>> quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- QuadPolar {qpolStart = Point 0.0 0.0, qpolEnd = Point 1.0 1.0, qpolControl = Polar {magnitude = 2.1213203435596424, direction = -0.7853981633974483}} +quadPolar :: (ExpField a, TrigField a) => QuadPosition a -> QuadPolar a +quadPolar (QuadPosition start end control) = QuadPolar start end control' + where + mp = (start + end) /. two + control' = polar (control - mp) + +-- | Convert from a polar to a positional representation of a quadratic bezier. +-- +-- > quadPosition . quadPolar == id +-- > quadPolar . quadPosition == id +-- +-- >>> quadPosition $ quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- QuadPosition {qposStart = Point 0.0 0.0, qposEnd = Point 1.0 1.0, qposControl = Point 2.0 -0.9999999999999998} +quadPosition :: (ExpField a, TrigField a) => QuadPolar a -> QuadPosition a +quadPosition (QuadPolar start end control) = QuadPosition start end control' + where + control' = coord control + (start + end) /. two + +-- | The quadratic bezier equation +-- +-- >>> quadBezier (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) 0.33333333 +-- Point 0.9999999933333332 -0.33333333333333326 +quadBezier :: (ExpField a, FromInteger a) => QuadPosition a -> a -> Point a +quadBezier (QuadPosition start end control) theta = + (1 - theta)^2 .* start + + 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'] + 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) + +-- | Bounding box for a QuadPosition +-- +-- >>> quadBox (QuadPosition (Point 0 0) (Point 1 1) (Point 2 -1)) +-- Rect 0.0 1.3333333333333335 -0.33333333333333337 1.0 +quadBox :: QuadPosition Double -> Rect Double +quadBox p = space1 pts + where + ts = quadDerivs p + pts = quadBezier p <$> ([0,1] <> ts) + +-- | cubic bezier curve +-- +-- Note that the ordering is different to the svg standard. +data CubicPosition a = + CubicPosition + { -- | starting point + cposStart :: Point a, + -- | ending point + cposEnd :: Point a, + -- | control point 1 + cposControl1 :: Point a, + -- | control point 2 + cposControl2 :: Point a + } 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 + { -- | starting point + cpolStart :: Point a, + -- | ending point + cpolEnd :: Point a, + -- | control point in terms of distance from and angle to the start end line + 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) + +-- | Convert from a positional to a polar representation of a cubic bezier. +-- +-- > cubicPosition . cubicPolar == id +-- > cubicPolar . cubicPosition == id +-- +-- >>> cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) +-- CubicPolar {cpolStart = Point 0.0 0.0, cpolEnd = Point 1.0 1.0, cpolControl1 = Polar {magnitude = 1.1180339887498947, direction = -1.2490457723982544}, cpolControl2 = Polar {magnitude = 1.1180339887498947, direction = 1.8925468811915387}} +cubicPolar :: (ExpField a, TrigField a) => CubicPosition a -> CubicPolar a +cubicPolar (CubicPosition start end control1 control2) = CubicPolar start end control1' control2' + where + mp = (start + end) /. two + control1' = polar $ (control1 - mp) /. norm (end - start) + control2' = polar $ (control2 - mp) /. norm (end - start) + +-- | Convert from a polar to a positional representation of a cubic bezier. +-- +-- > cubicPosition . cubicPolar == id +-- > cubicPolar . cubicPosition == id +-- +-- >>> cubicPosition $ cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) +-- CubicPosition {cposStart = Point 0.0 0.0, cposEnd = Point 1.0 1.0, cposControl1 = Point 1.0 -1.0, cposControl2 = Point 1.6653345369377348e-16 2.0} +cubicPosition :: (ExpField a, TrigField a) => CubicPolar a -> CubicPosition a +cubicPosition (CubicPolar start end control1 control2) = CubicPosition start end control1' control2' + where + control1' = norm (end - start) .* coord control1 + (start + end) /. two + control2' = norm (end - start) .* coord control2 + (start + end) /. two + +-- | The cubic bezier equation +-- +-- >>> cubicBezier (CubicPosition (Point 0 0) (Point 1 1) (Point 1 -1) (Point 0 2)) 0.8535533905932737 +-- Point 0.6767766952966369 1.2071067811865475 +cubicBezier :: (ExpField a, FromInteger a) => CubicPosition a -> a -> Point a +cubicBezier (CubicPosition start end control1 control2) theta = + (1 - theta)^3 .* start + + 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) + +-- | 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 +-- +-- ![Cubic]("other/cubic.svg") +cubicBox :: CubicPosition Double -> Rect Double +cubicBox p = space1 pts + where + ts = cubicDerivs p + pts = cubicBezier p <$> + filter + (|.| Range 0 1) + ([0,1] <> ts) + +-- | Bounding box for a list of path XYs. +-- +pathBoxes :: [(PathInfo Double, Point Double)] -> Maybe (Rect Double) +pathBoxes [] = Nothing +pathBoxes (x:xs) = + L.fold (L.Fold step begin (Just . snd)) xs + where + begin :: (Point Double, Rect Double) + begin = (snd x, singleton (snd x)) + step :: + (Point Double, Rect Double) -> + (PathInfo Double, Point Double) -> + (Point Double, Rect Double) + step (start, r) a = (snd a, pathBox start a <> r) + +-- | 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 + StartI -> singleton end + LineI -> space1 [start, end] + CubicI c1 c2 -> cubicBox (CubicPosition start end c1 c2) + QuadI c -> quadBox (QuadPosition start end c) + ArcI i -> arcBox (ArcPosition start end i) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -10,7 +10,10 @@ main = doctest [ "src/Chart.hs", "src/Data/FormatN.hs", + "src/Data/Path.hs", "src/Chart/Types.hs", - "src/Chart/Bar.hs" + "src/Chart/Bar.hs", + "src/Chart/Render.hs", + "src/Chart/Surface.hs", + "src/Chart/Examples.hs" ] -