diff --git a/app/examples.hs b/app/examples.hs --- a/app/examples.hs +++ b/app/examples.hs @@ -7,85 +7,68 @@ import Chart import Chart.Examples -import Control.Category (id) import Control.Lens -import Control.Monad.Trans.State.Lazy -import Network.Wai.Middleware.Static ((>->), addBase, noDots, staticPolicy) -import Protolude hiding ((<<*>>), Rep, replace) -import Web.Page -import Web.Scotty - -repNoData :: (Monad m) => SvgOptions -> Annotation -> HudOptions -> SharedRep m (Text, Text) -repNoData css ann hc = - repChartsWithStaticData css hc 10 [Chart ann [SR (-0.5) 0.5 (-0.5) 0.5]] - - -repEx :: (Monad m) => Ex -> SharedRep m (Text, Text) -repEx (Ex css hc maxcs anns xs) = - repChartsWithStaticData css hc maxcs (zipWith Chart anns xs) +import NumHask.Prelude hiding (replace) +import Web.Rep +import Lucid -midChart :: - SharedRep IO (Text, Text) -> - Application -> - Application -midChart sr = midShared sr initChartRender updateChart +chartServer :: SharedRep IO (Text, Text) -> IO () +chartServer srep = sharedServer srep defaultSocketConfig (chartStyler True) defaultInputCode chartOutputCode -initChartRender :: - Engine -> - Rep (Text, Text) -> - StateT (HashMap Text Text) IO () -initChartRender e r = - void $ - oneRep - r - ( \(Rep h fa) m -> do - append e "input" (toText h) - replace e "output" (either id fst . snd $ fa m) - replace e "debug" (either id snd . snd $ fa m) - ) +chartOutputCode :: Either Text (Text,Text) -> IO [Code] +chartOutputCode ea = do + pure $ case ea of + Left err -> [Append "debug" ("hashmap error: " <> err)] + Right (chart',debug') -> + [ Replace "output" chart', + Replace "debug" debug' + ] -updateChart :: Engine -> Either Text (HashMap Text Text, Either Text (Text, Text)) -> IO () -updateChart e (Left err) = append e "debug" ("map error: " <> err) -updateChart e (Right (_, Left err)) = append e "debug" ("parse error: " <> err) -updateChart e (Right (_, Right (c, d))) = do - replace e "output" c - replace e "debug" d +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 = - scotty 3000 $ do - middleware $ staticPolicy (noDots >-> addBase "other") - middleware - ( midChart - ( repChoice - 0 - [ ( "examples", - repChoice - 0 - [ ("mempty", repEx memptyExample), - ("unit", repEx unitExample), - ("hud", repEx hudExample), - ("rect", repEx rectExample), - ("line", repEx lineExample), - ("text", repEx textExample), - ("glyph", repEx glyphExample), - ("bar", repBarChart defaultSvgOptions barDataExample defaultBarOptions), - ("pixel", repPixelChart (defaultSvgOptions, defaultPixelOptions & #poGrain .~ Point 100 100 & #poRange .~ Rect 1 2 1 2, defaultHudOptions, defaultPixelLegendOptions "pixel test", f1)) - ] - ), - ( "stuff", - repChoice - 0 - [ ("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) - ] - ), - ("main", repEx mainExample) - ] - ) - ) - servePageWith "" (defaultPageConfig "default") (chartStyler True) + 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/venn.hs b/app/venn.hs --- a/app/venn.hs +++ b/app/venn.hs @@ -12,14 +12,14 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} import Chart -import Control.Category (id) 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.Svg hiding (z) -import Protolude +import NumHask.Prelude +import Lucid +import Lucid.Base xs :: Map.Map Text (Point Double) xs = @@ -145,7 +145,7 @@ 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) [SP 0.0 0.0]) vennGlyphs palette +venns = zipWith (\p c -> Chart (GlyphA $ seg p c) [SpotPoint (Point 0.0 0.0)]) vennGlyphs palette1 phrases :: [Chart Double] phrases = phraseChart <$> mainPhrases @@ -184,22 +184,28 @@ where c = black -renderToSvgt :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> [(TextStyle, Text)] -> Svg () +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'), viewBox_ (show x <> " " <> show (- w) <> " " <> show (z - x) <> " " <> show (w - y))] + 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 $ prettyText $ + writeFile "other/venn2.svg" $ Lazy.toStrict $ renderText $ renderToSvgt NoCssOptions (Point 300 300) (Rect (-2) 2 (-2) 2) - (phrases <> venns <> [Chart BlankA [SR (-2.0) 2.0 (-2.0) 2.0]]) $ + (phrases <> venns <> [Chart BlankA [SpotRect (Rect (-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) [SP 0.0 0.0]) [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3] cs) <> [Chart BlankA [SR (-1.5) 1.5 (-1.5) 1.5]]) +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) [SpotPoint (Point 0.0 0.0)]) [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3] cs <> [Chart BlankA [SpotRect (Rect (-1.5) 1.5 (-1.5) 1.5)]]) main :: IO () main = do writeVennWords - writeVenn palette + writeVenn palette1 diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,6 +1,6 @@ -cabal-version: 3.0 +cabal-version: 2.4 name: chart-svg -version: 0.0.3 +version: 0.1.0 synopsis: Charts in SVG description: Chart library targetting SVG. category: project @@ -12,8 +12,9 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple -extra-source-files: - stack.yaml +extra-doc-files: + readme.md, + other/*.svg source-repository head type: git @@ -23,83 +24,120 @@ exposed-modules: Chart Chart.Bar - Chart.Color - Chart.Core Chart.Examples - Chart.Format - Chart.Hud Chart.Pixel Chart.Render - Chart.Svg Chart.Page Chart.Types hs-source-dirs: - src - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + src build-depends: - Color - , attoparsec - , base >=4.7 && <5 - , bifunctors - , foldl - , generic-lens >= 1.2 && < 2.0 - , lucid - , lucid-svg - , lens - , numhask-space >= 0.4 && < 0.5 - , pretty-simple - , protolude >= 0.3 && < 0.4 - , scientific - , tagsoup - , text - , text-format - , time - , transformers - , web-rep >= 0.5 && < 0.6 + Color >= 0.1.4, + attoparsec >= 0.13, + base >=4.7 && <5, + foldl >= 1.4, + generic-lens >= 1.2 && < 3.0, + lucid >= 2.9, + lens >= 4.0, + numhask >= 0.6 && < 0.7, + numhask-space >= 0.5 && < 0.6, + pretty-simple >= 3.2, + scientific >= 0.3, + tagsoup >= 0.14, + text >= 1.2, + time >= 1.9, + transformers >= 0.5, + web-rep >= 0.6 && < 0.7 default-language: Haskell2010 + default-extensions: + NegativeLiterals + NoImplicitPrelude + OverloadedStrings + UnicodeSyntax + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints executable examples main-is: examples.hs hs-source-dirs: - app - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + app build-depends: - base >=4.7 && <5 - , bifunctors - , chart-svg - , lens - , javascript-bridge - , numhask-space >= 0.4 && < 0.5 - , protolude >= 0.3 && < 0.4 - , scotty - , text - , transformers - , unordered-containers - , wai-middleware-static - , web-rep >= 0.5 && < 0.6 + base >=4.7 && <5, + 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.6 && < 0.7 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 - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + app build-depends: - base >=4.7 && <5 - , bifunctors - , containers - , chart-svg - , generic-lens >= 1.2 && < 2.0 - , lucid-svg - , lens - , javascript-bridge - , numhask-space >= 0.4 && < 0.5 - , protolude >= 0.3 && < 0.4 - , scotty - , text - , transformers - , unordered-containers - , wai-middleware-static - , web-rep >= 0.5 && < 0.6 + 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.5 && < 0.6, + text >= 1.2, + transformers >= 0.5, + unordered-containers >= 0.2.10, + web-rep >= 0.6 && < 0.7 default-language: Haskell2010 + default-extensions: + NegativeLiterals + NoImplicitPrelude + OverloadedStrings + UnicodeSyntax + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints +test-suite test + type: exitcode-stdio-1.0 + main-is: test.hs + hs-source-dirs: + test + build-depends: + base >=4.7 && <5, + chart-svg, + doctest >= 0.16, + numhask >= 0.6 && < 0.7 + default-language: Haskell2010 + default-extensions: + NegativeLiterals + NoImplicitPrelude + OverloadedStrings + UnicodeSyntax + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -funbox-strict-fields diff --git a/other/bar.svg b/other/bar.svg new file mode 100644 --- /dev/null +++ b/other/bar.svg @@ -0,0 +1,29 @@ +Default Bar Chart-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 new file mode 100644 --- /dev/null +++ b/other/boundText.svg @@ -0,0 +1,1 @@ +a pretty long piece of textanother pretty long piece of text diff --git a/other/glyph.svg b/other/glyph.svg new file mode 100644 --- /dev/null +++ b/other/glyph.svg @@ -0,0 +1,3 @@ + diff --git a/other/hud.svg b/other/hud.svg new file mode 100644 --- /dev/null +++ b/other/hud.svg @@ -0,0 +1,45 @@ +-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/legend.svg b/other/legend.svg new file mode 100644 --- /dev/null +++ b/other/legend.svg @@ -0,0 +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 diff --git a/other/linehud.svg b/other/linehud.svg new file mode 100644 --- /dev/null +++ b/other/linehud.svg @@ -0,0 +1,49 @@ +-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 new file mode 100644 --- /dev/null +++ b/other/lines.svg @@ -0,0 +1,5 @@ + diff --git a/other/mempty.svg b/other/mempty.svg new file mode 100644 --- /dev/null +++ b/other/mempty.svg @@ -0,0 +1,1 @@ + diff --git a/other/pixel.svg b/other/pixel.svg new file mode 100644 # file too large to diff: other/pixel.svg diff --git a/other/svgoptions.svg b/other/svgoptions.svg new file mode 100644 --- /dev/null +++ b/other/svgoptions.svg @@ -0,0 +1,5 @@ + diff --git a/other/text.svg b/other/text.svg new file mode 100644 --- /dev/null +++ b/other/text.svg @@ -0,0 +1,1 @@ +abcdefghijklmnopqrstuvwxy diff --git a/other/unit.svg b/other/unit.svg new file mode 100644 --- /dev/null +++ b/other/unit.svg @@ -0,0 +1,1 @@ + diff --git a/other/venn.svg b/other/venn.svg new file mode 100644 --- /dev/null +++ b/other/venn.svg @@ -0,0 +1,1 @@ +λ diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,52 @@ +chart-svg +========= + +[![Build +Status](https://travis-ci.org/tonyday567/chart-svg.svg)](https://travis-ci.org/tonyday567/chart-svg) +[![Hackage](https://img.shields.io/hackage/v/chart-svg.svg)](https://hackage.haskell.org/package/chart-svg) +[![lts](https://www.stackage.org/package/chart-svg/badge/lts)](http://stackage.org/lts/package/chart-svg) +[![nightly](https://www.stackage.org/package/chart-svg/badge/nightly)](http://stackage.org/nightly/package/chart-svg) + +A chart library targetting SVG. + +![](other/venn.svg) + +![hud example](other/linehud.svg) + +Chart Types +=== + +rect + +![](other/unit.svg) + +line + +![](other/line.svg) + +text + +![](other/text.svg) + +glyph + +![](other/glyph.svg) + +bar + +![](other/bar.svg) + +pixel + +![](other/pixel.svg) + +legend + +![](other/legend.svg) + +recipe +------ + +``` +stack exec examples --file-watch +``` diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -1,13 +1,150 @@ +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wall #-} -- | A haskell Charting library targetting SVG module Chart - ( module Chart.Types, - module Chart.Color, - module Chart.Core, - module Chart.Svg, - module Chart.Hud, - module Chart.Format, + ( -- $overview + Chart (..), + Annotation (..), + annotationText, + RectStyle (..), + defaultRectStyle, + blob, + clear, + border, + TextStyle (..), + defaultTextStyle, + Anchor (..), + fromAnchor, + toAnchor, + GlyphStyle (..), + defaultGlyphStyle, + GlyphShape (..), + glyphText, + LineStyle (..), + defaultLineStyle, + PixelStyle (..), + defaultPixelStyle, + Direction (..), + fromDirection, + toDirection, + Spot (..), + toRect, + toPoint, + padRect, + SvgAspect (..), + toSvgAspect, + fromSvgAspect, + EscapeText (..), + CssOptions (..), + ScaleCharts (..), + SvgOptions (..), + defaultSvgOptions, + defaultSvgFrame, + 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, + + -- $color + Colour, + pattern Colour, + opac, + setOpac, + fromRGB, + hex, + palette, + palette1, + blend, + toHex, + fromHex, + unsafeFromHex, + + grayscale, + colorText, + transparent, + black, + white, + + -- $formats + FormatN(..), + defaultFormatN, + fromFormatN, + toFormatN, + fixed, + comma, + expt, + dollar, + formatN, + formatNs, + + -- $core + dataBox, + toAspect, + scaleAnn, + defRect, + defRectS, + moveChart, + + -- $hud + runHudWith, + runHud, + makeHud, + freezeTicks, + flipAxis, + canvas, + title, + tick, + precision, + adjustTick, + makeTickDates, + makeTickDatesContinuous, + legendHud, + legendEntry, + legendChart, + legendFromChart, + + -- $svg + svg, + svgt, + chartDef, + chartDefs, + styleBox, + styleBoxes, + noStyleBoxes, + styleBoxText, + styleBoxGlyph, + padChart, + frameChart, + hori, + vert, + stack, + addChartBox, + addChartBoxes, + module Chart.Page, module Chart.Render, module Chart.Bar, @@ -17,13 +154,86 @@ where import Chart.Bar -import Chart.Color -import Chart.Core -import Chart.Format -import Chart.Hud import Chart.Page import Chart.Pixel import Chart.Render -import Chart.Svg import Chart.Types import NumHask.Space + +{- $setup + +>>> :set -XOverloadedLabels +>>> :set -XNoImplicitPrelude +>>> -- import NumHask.Prelude +>>> import Control.Lens + +-} + + +{- $overview + +A chart consists of related 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. + +>>> :t Chart +Chart :: Annotation -> [Spot a] -> Chart a + +A 'Chart' in this library specifically consists of + +- a list of values, either points or rectangles (unified as a 'Spot') + +- an 'Annotation', which describes the way that the data should be represented on a 2-dimensional plane. + +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 priveleging 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 (SpotPoint . 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)] ] + :} + +>>> :t ls +ls :: [[Spot Double]] + +and an Annotation to describe representation of this data. + +>>> :{ + let anns = LineA <$> + [ defaultLineStyle & #color .~ (palette1 !! 0) & #width .~ 0.015, + defaultLineStyle & #color .~ (palette1 !! 1) & #width .~ 0.03, + defaultLineStyle & #color .~ (palette1 !! 5) & #width .~ 0.01 + ] + :} + +and this is enough to put together a Chart. + +>>> let lines = zipWith Chart anns ls +>>> :t lines +lines :: [Chart Double] + +Most charts will, in reality, be a list of charts, and much of the library API is designed for this. + +> writeCharts "other/lines.svg" lines + +![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. + +> writeHudOptionsChart "other/linehud.svg" defaultSvgOptions defaultHudOptions [] lines + +![hud example](other/linehud.svg) + +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. + +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. + +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. + +-} diff --git a/src/Chart/Bar.hs b/src/Chart/Bar.hs --- a/src/Chart/Bar.hs +++ b/src/Chart/Bar.hs @@ -17,25 +17,28 @@ ) where -import Chart.Color -import Chart.Format -import Chart.Hud + import Chart.Types import Control.Lens -import Data.Bifunctor -import Data.Bool import Data.Generics.Labels () -import Data.List (scanl', transpose) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe -import Data.Semigroup -import Data.Text (Text, pack) -import GHC.Exts -import GHC.Generics +import NumHask.Prelude import NumHask.Space -import Prelude +import qualified Prelude as P +{- $setup + +>>> :set -XOverloadedLabels +>>> :set -XNoImplicitPrelude +>>> -- import NumHask.Prelude +>>> import Control.Lens + +-} + -- | the usual bar chart eye-candy +-- +-- ![bar chart example](other/bar.svg) +-- data BarOptions = BarOptions { barRectStyles :: [RectStyle], @@ -43,14 +46,16 @@ outerGap :: Double, innerGap :: Double, textGap :: Double, + textGapNegative :: Double, displayValues :: Bool, valueFormatN :: FormatN, accumulateValues :: Bool, - orientation :: Orientation, + barOrientation :: Direction, barHudOptions :: HudOptions } deriving (Show, Eq, Generic) +-- | The official bar options. defaultBarOptions :: BarOptions defaultBarOptions = BarOptions @@ -59,6 +64,7 @@ 0.1 0 0.04 + 0.1 True (FormatFixed 0) False @@ -75,18 +81,27 @@ ( defaultLegendOptions & #lplace .~ PlaceRight & #lsize .~ 0.12 - & #vgap .~ 0.16 + & #vgap .~ 0.4 & #hgap .~ 0.14 - & #ltext . #size .~ 0.16 - & #lscale .~ 0.33, + & #ltext . #size .~ 0.12 + & #lscale .~ 0.4, [] ) ) where - gs = (\x -> RectStyle 0.002 colorGrey x) <$> palette - ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04) <$> palette + gs = (\x -> RectStyle 0.002 x x) <$> palette1 + ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04) <$> palette1 --- | imagine a data frame ... +{- | imagine a dataframe you get in other languages: + +- definietly some [[Double]] + +- maybe some row names + +- maybe some column names + +-} + data BarData = BarData { barData :: [[Double]], @@ -96,11 +111,16 @@ deriving (Show, Eq, Generic) -- | Convert BarData to rectangles +-- +-- >>> 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]] -> [[Rect Double]] -barRects (BarOptions _ _ ogap igap _ _ _ add orient _) bs = rects'' orient +barRects (BarOptions _ _ ogap igap _ _ _ _ add orient _) bs = rects'' orient where bs' = bool bs (appendZero bs) add rects'' Hori = rects' @@ -109,7 +129,7 @@ batSet z ys = zipWith ( \x (yl, yh) -> - abs + P.abs ( Rect (x + (ogap / 2) + z * bstep) (x + (ogap / 2) + z * bstep + bstep - igap') @@ -125,6 +145,9 @@ -- | convert data to a range assuming a zero bound -- a very common but implicit assumption in a lot of bar charts +-- +-- >>> barDataLowerUpper False [[1,2],[2,3]] +-- [[(0.0,1.0),(0.0,2.0)],[(0.0,2.0),(0.0,3.0)]] barDataLowerUpper :: Bool -> [[Double]] -> [[(Double, Double)]] barDataLowerUpper add bs = case add of @@ -132,6 +155,9 @@ True -> fmap (0,) <$> accRows bs -- | calculate the Rect range of a bar data set. +-- +-- >>> barRange [[1,2],[2,3]] +-- Rect 0.0 2.0 0.0 3.0 barRange :: [[Double]] -> Rect Double barRange [] = Rect 0 0 0 0 @@ -140,12 +166,17 @@ (Range l u) = sconcat $ space1 <$> (y NonEmpty.:| ys) -- | A bar chart without hud trimmings. +-- +-- >>> bars defaultBarOptions (BarData [[1,2],[2,3]] Nothing Nothing) +-- [Chart {annotation = RectA (RectStyle {borderSize = 2.0e-3, borderColor = RGBA 0.65 0.81 0.89 1.00, color = RGBA 0.65 0.81 0.89 1.00}), spots = [SpotRect Rect 5.0e-2 0.45 0.0 1.0,SpotRect 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}), spots = [SpotRect Rect 0.45 0.8500000000000001 0.0 2.0,SpotRect Rect 1.4500000000000002 1.85 0.0 3.0]},Chart {annotation = BlankA, spots = [SpotRect Rect -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 SpotRect <$> barRects bo (bd ^. #barData)) <> [Chart BlankA [SR (x - (bo ^. #outerGap)) (z + (bo ^. #outerGap)) y w]] + zipWith (\o d -> Chart (RectA o) d) (bo ^. #barRectStyles) (fmap SpotRect <$> barRects bo (bd ^. #barData)) <> [Chart BlankA [SpotRect (Rect (x - (bo ^. #outerGap)) (z + (bo ^. #outerGap)) y w)]] where (Rect x z y w) = fromMaybe unitRect $ foldRect $ catMaybes $ foldRect <$> barRects bo (bd ^. #barData) + maxRows :: [[Double]] -> Int maxRows [] = 0 maxRows xs = maximum $ length <$> xs @@ -156,6 +187,7 @@ accRows :: [[Double]] -> [[Double]] accRows xs = transpose $ drop 1 . scanl' (+) 0 <$> transpose xs +-- | sensible ticks barTicks :: BarData -> TickStyle barTicks bd | bd ^. #barData == [] = TickNone @@ -165,13 +197,11 @@ TickLabels $ take (maxRows (bd ^. #barData)) $ fromMaybe [] (bd ^. #barRowLabels) <> repeat "" -flipAllAxes :: Orientation -> [AxisOptions] -> [AxisOptions] -flipAllAxes o = fmap (bool id flipAxis (o == Vert)) - tickFirstAxis :: BarData -> [AxisOptions] -> [AxisOptions] tickFirstAxis _ [] = [] tickFirstAxis bd (x : xs) = (x & #atick . #tstyle .~ barTicks bd) : xs +-- | bar legend barLegend :: BarData -> BarOptions -> [(Annotation, Text)] barLegend bd bo | bd ^. #barData == [] = [] @@ -181,18 +211,21 @@ -- | A bar chart with hud trimmings. -- -- By convention only, the first axis (if any) is the bar axis. +-- barChart :: BarOptions -> BarData -> (HudOptions, [Chart Double]) barChart bo bd = - ( bo ^. #barHudOptions & #hudLegend %~ fmap (second (const (barLegend bd bo))) & #hudAxes %~ tickFirstAxis bd . flipAllAxes (bo ^. #orientation), + ( bo ^. #barHudOptions & #hudLegend %~ fmap (second (const (barLegend bd bo))) & #hudAxes %~ tickFirstAxis bd . flipAllAxes (barOrientation bo), bars bo bd <> bool [] (barTextCharts bo bd) (bo ^. #displayValues) ) --- | convert data to a text and Point -barDataTP :: Bool -> FormatN -> Double -> [[Double]] -> [[(Text, Double)]] -barDataTP add fn d bs = +flipAllAxes :: Direction -> [AxisOptions] -> [AxisOptions] +flipAllAxes o = fmap (bool id flipAxis (o == Vert)) + +barDataTP :: Bool -> FormatN -> Double -> Double -> [[Double]] -> [[(Text, Double)]] +barDataTP add fn d negd bs = zipWith (zipWith (\x y' -> (formatN fn x, drop' y'))) bs' (bool bs' (accRows bs') add) where - drop' x = bool (x - (d * (w - y))) (x + (d * (w - y))) (x >= 0) + drop' x = bool (x - (negd * (w - y))) (x + (d * (w - y))) (x >= 0) bs' = appendZero bs (Rect _ _ y w) = barRange bs' @@ -201,12 +234,12 @@ BarOptions -> [[Double]] -> [[(Text, Point Double)]] -barTexts (BarOptions _ _ ogap igap tgap _ fn add orient _) bs = zipWith zip (fmap fst <$> barDataTP add fn tgap bs') (txs'' orient) +barTexts (BarOptions _ _ ogap igap tgap tgapneg _ fn add orient _) bs = zipWith zip (fmap fst <$> barDataTP add fn tgap tgapneg bs') (txs'' orient) where bs' = bool bs (appendZero bs) add txs'' Hori = txs' txs'' Vert = fmap (\(Point x y) -> Point y x) <$> txs' - txs' = zipWith addX [0 ..] (fmap snd <$> barDataTP add fn tgap bs') + txs' = zipWith addX [0 ..] (fmap snd <$> barDataTP add fn tgap tgapneg bs') addX z y = zipWith ( \x y' -> @@ -220,6 +253,8 @@ bstep = (1 - (1 + 1) * ogap + (n - 1) * igap') / n igap' = igap * (1 - (1 + 1) * ogap) +-- | text, hold the bars barTextCharts :: BarOptions -> BarData -> [Chart Double] barTextCharts bo bd = zipWith (\o d -> Chart (TextA o (fst <$> d)) (SpotPoint . snd <$> d)) (bo ^. #barTextStyles) (barTexts bo (bd ^. #barData)) + diff --git a/src/Chart/Color.hs b/src/Chart/Color.hs deleted file mode 100644 --- a/src/Chart/Color.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall #-} - -module Chart.Color - ( Colour, - pattern Colour, - opac, - hex, - palette, - blend, - toHex, - fromHex, - unsafeFromHex, - fromHexOpac, - - -- * named colors - colorText, - colorPixelMin, - colorPixelMax, - colorFrame, - colorCanvas, - colorGlyphTick, - colorLineTick, - colorTextTick, - colorGrey, - transparent, - black, - white, - - -- * re-exports - module Graphics.Color.Model, - ) -where - -import Data.Attoparsec.Text hiding (take) -import Data.Generics.Labels () -import GHC.Exts -import Protolude -import qualified Data.Text.Lazy as Lazy -import Data.Text.Lazy.Builder (toLazyText) -import qualified Data.Text.Format -import Data.Text (justifyRight) -import Graphics.Color.Model -import Data.Text (pack) - -type Colour = Color (Alpha RGB) Double - --- | Constructor. -pattern Colour :: Double -> Double -> Double -> Double -> Colour -pattern Colour r g b a = ColorRGBA r g b a -{-# COMPLETE Colour #-} - -opac :: Colour -> Double -opac c = getAlpha c - -hex :: Colour -> Text -hex c = toHex c - -palette :: [Colour] -palette = unsafeFromHex <$> ["#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e", "#31331c", "#454e56", "#94a7b5", "#ab7257", "#001114", "#042f1e", "#033d26", "#034243", "#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e"] - --- | interpolate between 2 colors -blend :: Double -> Colour -> Colour -> Colour -blend c (Colour r g b a) (Colour r' g' b' a') = Colour r'' g'' b'' a'' - where - r'' = r + c * (r' - r) - g'' = g + c * (g' - g) - b'' = b + c * (b' - b) - a'' = a + c * (a' - a) - -parseHex :: Parser Colour -parseHex = (\x -> addAlpha x 1) . fmap toDouble <$> - ( \((r, g), b) -> - ColorRGB (fromIntegral r) (fromIntegral g) (fromIntegral b) :: Color RGB Word8 - ) - . (\(f, b) -> (f `divMod` (256 :: Int), b)) - . (`divMod` 256) - <$> (string "#" *> hexadecimal) - -fromHex :: Text -> Either Text Colour -fromHex = first pack . parseOnly parseHex - -unsafeFromHex :: Text -> Colour -unsafeFromHex t = either (const transparent) (\x -> x) $ parseOnly parseHex t - --- | convert from 'Colour' to #xxxxxx -toHex :: Colour -> Text -toHex c = - "#" - <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ Data.Text.Format.hex r) - <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ Data.Text.Format.hex g) - <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ Data.Text.Format.hex b) - where - (ColorRGBA r g b _) = toWord8 <$> c - -fromHexOpac :: Text -> Double -> Colour -fromHexOpac t o = setAlpha (unsafeFromHex t) o - --- some colors used -colorText :: Colour -colorText = Colour 0.2 0.2 0.2 1 - -colorPixelMin :: Colour -colorPixelMin = Colour 0.8 0.8 0.8 1 - -colorPixelMax :: Colour -colorPixelMax = Colour 0.1 0.1 1 1 - -colorFrame :: Colour -colorFrame = Colour 0 0 1 0.4 - -colorCanvas :: Colour -colorCanvas = Colour 0.8 0.8 0.8 0.1 - -colorGlyphTick :: Colour -colorGlyphTick = Colour 0.34 0.05 0.4 0.5 - -colorLineTick :: Colour -colorLineTick = Colour 0.5 0.5 0.5 0.1 - -colorTextTick :: Colour -colorTextTick = Colour 0.2 0.2 0.2 0.8 - -colorGrey :: Colour -colorGrey = Colour 0.5 0.5 0.5 1 - -black :: Colour -black = Colour 0 0 0 1 - -white :: Colour -white = Colour 1 1 1 1 - -transparent :: Colour -transparent = Colour 0 0 0 0 diff --git a/src/Chart/Core.hs b/src/Chart/Core.hs deleted file mode 100644 --- a/src/Chart/Core.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -module Chart.Core - ( padChart, - frameChart, - projectTo, - projectSpots, - projectSpotsWith, - dataBox, - toAspect, - scaleAnn, - defRect, - defRectS, - moveChart, - hori, - vert, - stack, - addChartBox, - addChartBoxes, - ) -where - -import Chart.Svg (styleBox, styleBoxes) -import Chart.Types -import Control.Category (id) -import Control.Lens hiding (transform) -import Data.Foldable -import Data.Maybe -import Data.Monoid -import Data.Semigroup hiding (getLast) -import NumHask.Space -import Protolude - --- | additively pad a [Chart] -padChart :: Double -> [Chart Double] -> [Chart Double] -padChart p cs = cs <> [Chart BlankA (maybeToList (SpotRect . padRect p <$> styleBoxes cs))] - --- | overlay a frame on some charts with some additive padding between -frameChart :: RectStyle -> Double -> [Chart Double] -> [Chart Double] -frameChart rs p cs = [Chart (RectA rs) (maybeToList (SpotRect . padRect p <$> styleBoxes cs))] <> cs - --- | project a Spot from one Rect to another, preserving relative position. -projectOn :: (Ord a, Fractional a) => Rect a -> Rect a -> Spot a -> Spot a -projectOn new old@(Rect x z y w) po@(SP px py) - | x == z && y == w = po - | x == z = SP px py' - | y == w = SP px' py - | otherwise = SP px' py' - where - (Point px' py') = project old new (toPoint po) -projectOn new old@(Rect x z y w) ao@(SR ox oz oy ow) - | x == z && y == w = ao - | x == z = SR ox oz ny nw - | y == w = SR nx nz oy ow - | otherwise = SpotRect a - where - a@(Rect nx nz ny nw) = projectRect old new (toRect ao) - --- | project a [Spot a] from it's folded space to the given area -projectTo :: (Ord a, Fractional a) => Rect a -> [Spot a] -> [Spot a] -projectTo _ [] = [] -projectTo vb (x : xs) = projectOn vb (toRect $ sconcat (x :| xs)) <$> (x : xs) - --- | project a [[Spot a]] from its folded space to the given area -projectTo2 :: (Ord a, Fractional a) => Rect a -> [[Spot a]] -> [[Spot a]] -projectTo2 vb xss = fmap (maybe id (projectOn vb) (fold $ foldRect . fmap toRect <$> xss)) <$> xss - -defRect :: (Fractional a) => Maybe (Rect a) -> Rect a -defRect = fromMaybe unitRect - -defRectS :: (Eq a, Fractional a) => Maybe (Rect a) -> Rect a -defRectS r = maybe unitRect singletonUnit r - where - singletonUnit :: (Eq a, Fractional a) => Rect a -> Rect a - 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 - -projectSpots :: (Chartable a) => Rect a -> [Chart a] -> [Chart a] -projectSpots a cs = cs' - where - xss = projectTo2 a (spots <$> cs) - ss = annotation <$> cs - cs' = zipWith Chart ss xss - -projectSpotsWith :: (Chartable a) => Rect a -> Rect a -> [Chart a] -> [Chart a] -projectSpotsWith new old cs = cs' - where - xss = fmap (projectOn new old) . spots <$> cs - ss = annotation <$> cs - cs' = zipWith Chart ss xss - -toAspect :: (Fractional a) => Rect a -> a -toAspect (Rect x z y w) = (z - x) / (w - y) - --- | -dataBox :: Chartable a => [Chart a] -> Maybe (Rect a) -dataBox cs = foldRect . mconcat $ fmap toRect <$> (spots <$> 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 :: Chartable a => Spot a -> [Chart a] -> [Chart a] -moveChart sp cs = fmap (#spots %~ fmap (sp +)) 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 (#spots %~ fmap (\s -> SP (z x) 0 - SP (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 (#spots %~ fmap (\s -> SP (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 -stack :: Int -> Double -> [[Chart Double]] -> [Chart Double] -stack _ _ [] = [] -stack n gap cs = vert gap (hori gap <$> group' cs []) - where - group' [] acc = reverse acc - group' x acc = group' (drop n x) (take n x : acc) - -addChartBox :: Chart Double -> Rect Double -> Rect Double -addChartBox c r = sconcat (r :| maybeToList (styleBox c)) - -addChartBoxes :: [Chart Double] -> Rect Double -> Rect Double -addChartBoxes c r = sconcat (r :| maybeToList (styleBoxes c)) diff --git a/src/Chart/Examples.hs b/src/Chart/Examples.hs --- a/src/Chart/Examples.hs +++ b/src/Chart/Examples.hs @@ -8,13 +8,11 @@ module Chart.Examples where import Chart -import Control.Applicative import Control.Lens -import Data.Maybe -import qualified Data.Text as Text -import GHC.Generics -import Protolude import Data.List ((!!)) +import qualified Data.Text as Text +import NumHask.Prelude +import Web.Rep data Ex = Ex @@ -29,6 +27,10 @@ makeExample :: HudOptions -> [Chart Double] -> Ex makeExample hs cs = Ex defaultSvgOptions hs (length cs) (view #annotation <$> cs) (fmap (fmap realToFrac) . view #spots <$> 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' spots') = writeHudOptionsChart fp css' hc' [] (zipWith Chart anns' spots') @@ -62,7 +64,9 @@ ] ropts :: [RectStyle] -ropts = zipWith (\c o -> blob (setAlpha c o)) palette [0.2, 0.7] +ropts = [ blob (fromRGB (palette !! 0) 0.4), + blob (fromRGB (palette !! 5) 0.4) + ] -- | line example lineExample :: Ex @@ -88,9 +92,9 @@ lopts :: [LineStyle] lopts = - [ defaultLineStyle & #color .~ (palette !! 0) & #width .~ 0.015, - defaultLineStyle & #color .~ (palette !! 1) & #width .~ 0.03, - defaultLineStyle & #color .~ (palette !! 2) & #width .~ 0.01 + [ defaultLineStyle & #color .~ (palette1 !! 0) & #width .~ 0.015, + defaultLineStyle & #color .~ (palette1 !! 1) & #width .~ 0.03, + defaultLineStyle & #color .~ (palette1 !! 5) & #width .~ 0.01 ] legopts :: LegendOptions @@ -132,7 +136,7 @@ (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts) ((: []) . SpotPoint . snd <$> ts) where - ts :: [(Text.Text, Point Double)] + ts :: [(Text, Point Double)] ts = zip (fmap Text.singleton ['a' .. 'y']) @@ -166,15 +170,15 @@ (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) ] - [SP x 0 | x <- [0 .. (8 :: Double)]] + [SpotPoint (Point x 0) | x <- [0 .. (8 :: Double)]] -- | bar example barDataExample :: BarData barDataExample = BarData [[1, 2, 3, 5, 8, 0, -2, 11, 2, 1], [1 .. 10]] - (Just (("row " <>) . Text.pack . show <$> [1 .. 11])) - (Just (("column " <>) . Text.pack . show <$> [1 .. 2])) + (Just (("row " <>) . pack . show <$> [1 .. 11])) + (Just (("column " <>) . pack . show <$> [1 .. 2])) barExample :: Ex barExample = makeExample hc cs @@ -185,7 +189,7 @@ pixelEx :: ([Chart Double], [Hud Double]) pixelEx = pixelfl f1 (defaultPixelOptions & #poGrain .~ Point 100 100 & #poRange .~ Rect 1 2 1 2) (defaultPixelLegendOptions "pixel test") -f1 :: (Floating a) => Point a -> a +f1 :: (TrigField a) => Point a -> a f1 (Point x y) = sin (cos (tan x)) * sin (cos (tan y)) -- * stuff @@ -205,14 +209,14 @@ (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.45 & #size .~ 0.08) ["a pretty long piece of text"] ) - [SP 0.0 0.0] + [SpotPoint (Point 0.0 0.0)] t2 = Chart ( TextA (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.45 & #size .~ 0.08) ["another pretty long piece of text"] ) - [SP 1 1] + [SpotPoint (Point 1 1)] -- | compound chart gopts3 :: [GlyphStyle] @@ -226,7 +230,7 @@ . (#size .~ 0.08) $ defaultGlyphStyle ) - palette + palette1 [EllipseGlyph 1.5, SquareGlyph, CircleGlyph] glines :: [Chart Double] @@ -235,9 +239,9 @@ cs = zipWith (\d s -> Chart (LineA s) (SpotPoint <$> d)) ls lopts gs = zipWith (\d s -> Chart (GlyphA s) (SpotPoint <$> d)) ls gopts3 -lgdata :: [(Text.Text, Point Double)] +lgdata :: [(Text, Point Double)] lgdata = - (\p@(Point x y) -> (Text.pack (show x <> "," <> show y), fromIntegral <$> p)) + (\p@(Point x y) -> (pack (show x <> "," <> show y), fromIntegral <$> p)) <$> (Point <$> [0 .. 5] <*> [0 .. 5] :: [Point Int]) lglyph :: [Chart Double] @@ -248,8 +252,8 @@ Chart ( TextA ( defaultTextStyle - & #color %~ (\x -> setAlpha x 0.2) & #translate ?~ Point 0 0.04 + & #color %~ setOpac 0.2 ) [t] ) @@ -280,7 +284,7 @@ (annotation <$> label) (spots <$> label) -placedLabel :: (Chartable a) => Point a -> a -> Text.Text -> Chart a +placedLabel :: (Real a) => Point a -> a -> Text -> Chart a placedLabel p d t = Chart (TextA (defaultTextStyle & #rotation ?~ realToFrac d) [t]) [SpotPoint p] @@ -320,21 +324,31 @@ writeAllExamples :: IO () writeAllExamples = do + + -- haddocks + let ls' = fmap (SpotPoint . 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) [SpotRect (unitRect::Rect Double)]] + let t = zipWith (\x y -> Chart (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) [x]) [SpotPoint 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" [] - writeCharts "other/unit.svg" [Chart (RectA defaultRectStyle) [SpotRect unitRect]] - writeHudOptionsChart "other/hud.svg" defaultSvgOptions defaultHudOptions [] [] - writeChartExample "other/rect.svg" rectExample - writeChartExample "other/line.svg" lineExample - writeChartExample "other/text.svg" textExample - writeChartExample "other/glyph.svg" glyphExample writeChartExample "other/bar.svg" barExample - writeHudOptionsChart "other/pixel.svg" defaultSvgOptions defaultHudOptions (snd pixelEx) (fst pixelEx) - -- stuff writeCharts "other/boundText.svg" boundTextBug - writeCharts "other/compound.svg" (lglyph <> glines) - writeCharts "other/label.svg" label writeHudOptionsChart "other/legend.svg" defaultSvgOptions legendTest [] [] - -- main - writeChartExample "other/main.svg" mainExample putStrLn (" 👍" :: Text) diff --git a/src/Chart/Format.hs b/src/Chart/Format.hs deleted file mode 100644 --- a/src/Chart/Format.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -module Chart.Format - ( fromFormatN, - toFormatN, - fixed, - comma, - expt, - dollar, - formatN, - precision, - formatNs, - ) -where - -import Chart.Types -import Data.Foldable -import Data.List (nub) -import Data.Monoid -import Data.Scientific -import qualified Data.Text as Text -import Protolude - -fromFormatN :: (IsString s) => FormatN -> s -fromFormatN (FormatFixed _) = "Fixed" -fromFormatN (FormatComma _) = "Comma" -fromFormatN (FormatExpt _) = "Expt" -fromFormatN FormatDollar = "Dollar" -fromFormatN (FormatPercent _) = "Percent" -fromFormatN FormatNone = "None" - -toFormatN :: (Eq s, IsString s) => s -> Int -> FormatN -toFormatN "Fixed" n = FormatFixed n -toFormatN "Comma" n = FormatComma n -toFormatN "Expt" n = FormatExpt n -toFormatN "Dollar" _ = FormatDollar -toFormatN "Percent" n = FormatPercent n -toFormatN "None" _ = FormatNone -toFormatN _ _ = FormatNone - -fixed :: Int -> Double -> Text -fixed x n = Text.pack $ formatScientific Fixed (Just x) (fromFloatDigits n) - -comma :: Int -> Double -> Text -comma n a - | a < 1000 = fixed n a - | otherwise = go (floor a) "" - where - go :: Int -> Text -> Text - go x t - | x < 0 = "-" <> go (- x) "" - | x < 1000 = Text.pack (show x) <> t - | otherwise = - let (d, m) = divMod x 1000 - in go d ("," <> Text.pack (show' m)) - where - show' n' = let x' = show n' in (replicate (3 - length x') '0' <> x') - -expt :: Int -> Double -> Text -expt x n = Text.pack $ formatScientific Exponent (Just x) (fromFloatDigits n) - -dollar :: Double -> Text -dollar = ("$" <>) . comma 2 - -percent :: Int -> Double -> Text -percent x n = (<> "%") $ fixed x (100 * n) - -formatN :: FormatN -> Double -> Text -formatN (FormatFixed n) x = fixed n x -formatN (FormatComma n) x = comma n x -formatN (FormatExpt n) x = expt n x -formatN FormatDollar x = dollar x -formatN (FormatPercent n) x = percent n x -formatN FormatNone x = Text.pack (show x) - --- | Provide formatted text for a list of numbers so that they are just distinguished. 'precision commas 2 ticks' means give the tick labels as much precision as is needed for them to be distinguished, but with at least 2 significant figures, and format Integers with commas. -precision :: (Int -> Double -> Text) -> Int -> [Double] -> [Text] -precision f n0 xs = - precLoop f (fromIntegral n0) xs - where - precLoop f' n xs' = - let s = f' n <$> xs' - in if s == nub s || n > 4 - then s - else precLoop f' (n + 1) xs' - -formatNs :: FormatN -> [Double] -> [Text] -formatNs (FormatFixed n) xs = precision fixed n xs -formatNs (FormatComma n) xs = precision comma n xs -formatNs (FormatExpt n) xs = precision expt n xs -formatNs FormatDollar xs = precision (const dollar) 2 xs -formatNs (FormatPercent n) xs = precision percent n xs -formatNs FormatNone xs = Text.pack . show <$> xs diff --git a/src/Chart/Hud.hs b/src/Chart/Hud.hs deleted file mode 100644 --- a/src/Chart/Hud.hs +++ /dev/null @@ -1,628 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | A hud (heads-up display) are decorations in and around a chart that assist with data interpretation. -module Chart.Hud - ( runHudWith, - runHud, - makeHud, - freezeTicks, - flipAxis, - canvas, - title, - tick, - precision, - adjustTick, - makeTickDates, - legendHud, - legendEntry, - legendChart, - legendFromChart, - ) -where - -import Chart.Core -import Chart.Format -import Chart.Svg (styleBox, styleBoxText, styleBoxes) -import Chart.Types -import Control.Category (id) -import qualified Control.Foldl as L -import Control.Lens -import Control.Monad.Trans.State.Lazy -import Data.Time -import GHC.Generics -import NumHask.Space -import Protolude - --- | 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' = defRect $ dataBox cs' - ca' = defRect $ styleBoxes cs' - cs' = projectSpotsWith 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 (defRectS $ 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 (SpotRect <$> 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) [SpotRect 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)) - [ SR - x - z - (w' + b ^. #buff) - (w' + b ^. #buff + b ^. #wid) - ] - PlaceBottom -> - Chart - (RectA (rstyle b)) - [ SR - x - z - (y' - b ^. #wid - b ^. #buff) - (y' - b ^. #buff) - ] - PlaceLeft -> - Chart - (RectA (rstyle b)) - [ SR - (x' - b ^. #wid - b ^. #buff) - (x' - b ^. #buff) - y - w - ] - PlaceRight -> - Chart - (RectA (rstyle b)) - [ SR - (z' + (b ^. #buff)) - (z' + (b ^. #buff) + (b ^. #wid)) - y - w - ] - PlaceAbsolute (Point x'' _) -> - Chart - (RectA (rstyle b)) - [ SR - (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] - ) - [SP 0 0] - 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 -> [Spot Double] -placeGridLines pl (Rect x z y w) a b - | pl `elem` [PlaceTop, PlaceBottom] = [SP a (y - b), SP a (w + b)] - | otherwise = [SP (x - b) a, SP (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))) - ( SpotPoint . (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] - ) - [SpotPoint 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 -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) = L.fold (L.Fold step (x, []) (\(x0, x1) -> reverse $ x0 : x1)) xs - where - step (a0, rs) a1 = if f a0 a1 then (a1, rs) else (a1, a0 : rs) - -legendHud :: LegendOptions -> [Chart Double] -> Hud Double -legendHud l lcs = Hud $ \cs -> do - ca <- use #chartDim - let cs' = cs <> movedleg ca scaledleg - #chartDim .= defRect (styleBoxes cs') - pure cs' - where - scaledleg = - (#annotation %~ scaleAnn (realToFrac $ l ^. #lscale)) - . (#spots %~ fmap (fmap (* l ^. #lscale))) - <$> lcs - movedleg ca' leg = - maybe id (moveChart . SpotPoint . 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]) [SP 0 0] - ) - where - (ann, sps) = case a of - RectA rs -> - ( RectA rs, - [SR 0 (l ^. #lsize) 0 (l ^. #lsize)] - ) - PixelA ps -> - ( PixelA ps, - [SR 0 (l ^. #lsize) 0 (l ^. #lsize)] - ) - TextA ts txts -> - ( TextA (ts & #size .~ realToFrac (l ^. #lsize)) (take 1 txts), - [SP 0 0] - ) - GlyphA gs -> - ( GlyphA (gs & #size .~ realToFrac (l ^. #lsize)), - [SP (0.5 * l ^. #lsize) (0.33 * l ^. #lsize)] - ) - LineA ls -> - ( LineA (ls & #width %~ (/ (realToFrac $ l ^. #lscale))), - [SP 0 (0.33 * l ^. #lsize), SP (2 * l ^. #lsize) (0.33 * l ^. #lsize)] - ) - BlankA -> - ( BlankA, - [SP 0 0] - ) - -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)) diff --git a/src/Chart/Page.hs b/src/Chart/Page.hs --- a/src/Chart/Page.hs +++ b/src/Chart/Page.hs @@ -7,8 +7,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Chart.Page - ( chartStyler, - repChartStaticData, + ( repChartStaticData, repAnnotation, repRectStyle, repTextStyle, @@ -33,7 +32,6 @@ repRounded, repTriple, repGlyphShape, - repChoice, repLegendOptions, repChartsWithSharedData, repChartsWithStaticData, @@ -46,58 +44,26 @@ repPixelOptions, repPixelLegendOptions, repPixelChart, + repNoData, ) where import Chart.Bar -import Chart.Color -import Chart.Format import Chart.Pixel import Chart.Render (renderHudOptionsChart) import Chart.Types -import Control.Category (id) import Control.Lens import Data.Attoparsec.Text -import Data.Biapplicative -import Data.List import qualified Data.Text as Text import Lucid +import NumHask.Prelude import NumHask.Space -import Protolude hiding ((<<*>>)) import Text.Pretty.Simple (pShowNoColor) -import Web.Page hiding (bool) +import Web.Rep pShow' :: (Show a) => a -> Text pShow' = toStrict . pShowNoColor -chartStyler :: Bool -> Page -chartStyler doDebug = - mathjaxSvgPage "hasmathjax" - <> bootstrapPage - <> bridgePage - & #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) - -subtype :: With a => a -> Text -> Text -> a -subtype h origt t = - with - h - [ class__ "subtype ", - data_ "sumtype" t, - style_ ("display:" <> bool "block" "none" (origt /= t)) - ] - repChartStaticData :: (Monad m) => Chart a -> SharedRep m (Chart a) repChartStaticData c = do ann <- repAnnotation (c ^. #annotation) @@ -153,20 +119,20 @@ 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) + 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 (fromHexOpac bc bo) (fromHexOpac c o) + pure $ RectStyle bs (fromRGB (unsafeFromHex bc) bo) (fromRGB (unsafeFromHex c) o) repPixelStyle :: (Monad m) => PixelStyle -> SharedRep m PixelStyle repPixelStyle cfg = - bimap hmap mmap pcmin + bimap hmap mmap (unsafeFromHex <$> pcmin) <<*>> pomin - <<*>> pcmax + <<*>> (unsafeFromHex <$> pcmax) <<*>> pomax <<*>> pd <<*>> prs @@ -182,7 +148,7 @@ hmap pcmin' pomin' pcmax' pomax' pd' prs' pt' = pcmin' <> pomin' <> pcmax' <> pomax' <> pd' <> prs' <> pt' mmap pcmin' pomin' pcmax' pomax' pd' prs' pt' = - PixelStyle (fromHexOpac pcmin' pomin') (fromHexOpac 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 @@ -210,11 +176,11 @@ (Point 0.001 0.001) (Point 0 0) ) - pure (GlyphStyle sz (fromHexOpac gc go) (fromHexOpac gbc gbo) bsz sh tr tt) + 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.3 0.01 (s ^. #size) + 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) @@ -236,14 +202,14 @@ (Point 0 0) ) tm <- checkbox (Just "mathjax") (s ^. #hasMathjax) - pure $ TextStyle ts (fromHexOpac tc to') ta th tv tn tr tt tm + 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 (fromHexOpac c o) + pure $ LineStyle w (fromRGB (unsafeFromHex c) o) repPlace :: (Monad m) => Place -> SharedRep m Place repPlace initpl = bimap hmap mmap rplace <<*>> rp @@ -287,21 +253,21 @@ (fromAnchor <$> [AnchorStart, AnchorMiddle, AnchorEnd]) (fromAnchor a) -repOrientation :: (Monad m) => Orientation -> SharedRep m Orientation -repOrientation a = - toOrientation +repDirection :: (Monad m) => Direction -> SharedRep m Direction +repDirection a = + toDirection <$> dropdown takeText id - (Just "Orientation") - (fromOrientation <$> [Vert, Hori]) - (fromOrientation a) + (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.1 0.01 (cfg ^. #wid) - b <- slider (Just "buffer") 0 0.2 0.01 (cfg ^. #buff) + 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 @@ -465,12 +431,12 @@ maybeRep (Just "outer pad") (isJust (s ^. #outerPad)) - (slider Nothing 1 1.2 0.01 (fromMaybe 1 (s ^. #outerPad))) + (slider Nothing 0 0.1 0.01 (fromMaybe 1 (s ^. #outerPad))) ip = maybeRep (Just "inner pad") (isJust (s ^. #innerPad)) - (slider Nothing 1 1.2 0.01 (fromMaybe 1 (s ^. #innerPad))) + (slider Nothing 0 0.1 0.01 (fromMaybe 1 (s ^. #innerPad))) fr = maybeRep (Just "frame") @@ -516,7 +482,7 @@ "line" -> SpotPoint . uncurry Point <$> [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)] - "one" -> [SR 0 1 0 1] + "one" -> [SpotRect (Rect 0 1 0 1)] "dist" -> SpotRect <$> gridR (\x -> exp (- (x ** 2) / 2)) (Range (-5) 5) 50 _ -> SpotPoint <$> gridP sin (Range 0 (2 * pi)) 30 ) @@ -617,7 +583,7 @@ _ -> TickNone dtDef = case cfg of TickPlaced x -> x - _ -> zip [0 .. 5] (Text.pack . show <$> [0 .. 5 :: Int]) + _ -> 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 @@ -634,15 +600,12 @@ TickRound _ _ e -> e == TickExtend _ -> True + repTick :: (Monad m) => Tick -> SharedRep m Tick -repTick cfg = SharedRep $ do - (Rep h fa) <- - unrep $ bimap hmap Tick ts <<*>> gt <<*>> tt <<*>> lt - h' <- zoom _1 h - pure (Rep h' fa) +repTick cfg = bimap hmap Tick ts <<*>> gt <<*>> tt <<*>> lt where hmap ts' gt' tt' lt' = - accordion + accordion_ "acctick" Nothing [ ("style", ts'), @@ -795,22 +758,6 @@ TriangleGlyph a b c -> (a, b, c) _ -> (Point 0.0 0.0, Point 1 1, Point 1 0) -repChoice :: (Monad m) => Int -> [(Text, SharedRep m (Text, Text))] -> SharedRep m (Text, Text) -repChoice initt xs = - bimap hmap mmap dd - <<*>> foldr (\x a -> bimap (:) (:) x <<*>> a) (pure []) cs - where - ts = fst <$> xs - cs = snd <$> xs - dd = dropdownSum takeText id Nothing ts t0 - t0 = ts !! initt - hmap dd' cs' = - div_ - ( dd' - <> mconcat (zipWith (\c t -> subtype c t0 t) cs' ts) - ) - mmap dd' cs' = maybe (Data.List.head cs') (cs' !!) (elemIndex dd' ts) - repLegendOptions :: (Monad m) => LegendOptions -> SharedRep m LegendOptions repLegendOptions initl = bimap @@ -947,10 +894,11 @@ <> bool mempty ( mconcat $ - (\x -> "

" <> x <> "

") - <$> [ "

chart svg

", - renderHudOptionsChart css hc [] cs - ] + [ "

chart svg

", + "", + renderHudOptionsChart css hc [] cs, + "" + ] ) ((\(_, a, _) -> a) debug) <> bool @@ -958,7 +906,7 @@ ( mconcat $ (\x -> "

" <> x <> "

") <$> [ "

chart value

", - Text.pack $ show cs + pack $ show cs ] ) ((\(_, _, a) -> a) debug) @@ -999,6 +947,7 @@ <<*>> og <<*>> ig <<*>> tg + <<*>> tgn <<*>> dv <<*>> fn <<*>> av @@ -1026,10 +975,11 @@ 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 = repOrientation (cfg ^. #orientation) + or = repDirection (cfg ^. #barOrientation) ho = repHudOptions 2 @@ -1042,13 +992,13 @@ BlankA "" (cfg ^. #barHudOptions) - hmap rs' ts' og' ig' tg' dv' fn' av' or' ho' = + 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'), + ("Gaps", og' <> ig' <> tg' <> tgn'), ("Style", dv' <> fn' <> av' <> or'), ("Hud", ho') ] @@ -1102,9 +1052,6 @@ ("Style", ps') ] --- PixelLegendOptions --- {ploStyle :: PixelStyle, ploTitle :: Text, ploWidth :: Double, ploAxisOptions :: AxisOptions, ploLegendOptions :: LegendOptions} - repPixelLegendOptions :: (Monad m) => PixelLegendOptions -> @@ -1180,3 +1127,7 @@ ("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 [SpotRect (Rect (-0.5) 0.5 (-0.5) 0.5)]] diff --git a/src/Chart/Pixel.hs b/src/Chart/Pixel.hs --- a/src/Chart/Pixel.hs +++ b/src/Chart/Pixel.hs @@ -22,17 +22,11 @@ ) where -import Chart.Color -import Chart.Core -import Chart.Hud -import Chart.Svg (styleBox) import Chart.Types -import Control.Category (id) import Control.Lens import Data.Generics.Labels () -import GHC.Generics +import NumHask.Prelude import NumHask.Space -import Protolude data PixelOptions = PixelOptions @@ -140,10 +134,10 @@ pchart | l ^. #ploLegendOptions . #lplace == PlaceBottom || l ^. #ploLegendOptions . #lplace == PlaceTop = - Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ 0)) [SR x0 x1 0 (l ^. #ploWidth)] + Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ 0)) [SpotRect (Rect x0 x1 0 (l ^. #ploWidth))] | otherwise = - Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ (pi / 2))) [SR 0 (l ^. #ploWidth) x0 x1] - t = Chart (TextA (l ^. #ploLegendOptions . #ltext & #anchor .~ AnchorStart) [l ^. #ploTitle]) [SP 0 0] + Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ (pi / 2))) [SpotRect (Rect 0 (l ^. #ploWidth) x0 x1)] + t = Chart (TextA (l ^. #ploLegendOptions . #ltext & #anchor .~ AnchorStart) [l ^. #ploTitle]) [SpotPoint (Point 0 0)] hs = vert (l ^. #ploLegendOptions . #vgap) [a, [t]] isHori :: PixelLegendOptions -> Bool diff --git a/src/Chart/Render.hs b/src/Chart/Render.hs --- a/src/Chart/Render.hs +++ b/src/Chart/Render.hs @@ -6,8 +6,6 @@ module Chart.Render ( scaleCharts, - frameChart, - padChart, getAspect, getViewbox, getSize, @@ -26,21 +24,15 @@ ) where -import Chart.Core -import Chart.Hud (makeHud, runHud) -import Chart.Svg import Chart.Types -import Control.Category (id) import Control.Lens hiding (transform) import Data.Generics.Labels () -import Data.Maybe -import qualified Data.Text as Text -import qualified Data.Text.IO as Text import qualified Data.Text.Lazy as Lazy +import Lucid import qualified Lucid.Base as Lucid -import Lucid.Svg hiding (z) +import Lucid.Base +import NumHask.Prelude import NumHask.Space hiding (Element) -import Protolude hiding (writeFile) -- | scale chart data, projecting to the supplied Rect, and expanding the resultant Rect for chart style if necessary. -- @@ -56,12 +48,12 @@ getAspect :: SvgAspect -> [Chart Double] -> Double getAspect (ManualAspect a) _ = a -getAspect ChartAspect cs = toAspect $ defRect $ styleBoxes cs +getAspect ChartAspect cs = toAspect . defRect $ styleBoxes cs 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))) $ defRect $ styleBoxes cs + ChartAspect -> (\(Rect x z y w) -> Point (view #svgHeight o * (z - x)) (view #svgHeight o * (w - y))) . defRect $ styleBoxes cs getViewbox :: SvgOptions -> [Chart Double] -> Rect Double getViewbox o cs = @@ -83,27 +75,36 @@ ] m -renderToSvg :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Svg () +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))) [width_ (show w'), height_ (show h'), viewBox_ (show x <> " " <> show (- w) <> " " <> show (z - x) <> " " <> show (w - y))] + with + ( svg2_ + ( bool id (cssCrisp <>) (csso == UseCssCrisp) $ + chartDefs cs <> mconcat (svg <$> cs) + ) + ) + [ width_ (show w'), + height_ (show h'), + makeAttribute "viewBox" (show x <> " " <> show (- w) <> " " <> show (z - x) <> " " <> show (w - y)) + ] -cssCrisp :: Svg () -cssCrisp = style_ [type_ "text/css"] "{ shape-rendering: 'crispEdges'; }" +cssCrisp :: Html () +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.Text +renderCharts_ :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Text renderCharts_ csso p r cs = - Lazy.toStrict $ prettyText (renderToSvg csso p r cs) + Lazy.toStrict $ renderText (renderToSvg csso p r cs) -- | render Charts with the supplied options. -renderChartsWith :: SvgOptions -> [Chart Double] -> Text.Text +renderChartsWith :: SvgOptions -> [Chart Double] -> Text renderChartsWith so cs = - Lazy.toStrict $ prettyText (renderToSvg (so ^. #useCssCrisp) (getSize so cs'') r' cs'') + Lazy.toStrict $ renderText (renderToSvg (so ^. #useCssCrisp) (getSize so cs'') r' cs'') where r' = r & maybe id padRect (so ^. #outerPad) cs'' = cs' - & maybe id (\x -> frameChart x (fromMaybe 1 (so ^. #innerPad))) (so ^. #chartFrame) + & maybe id (\x -> frameChart x (fromMaybe 0 (so ^. #innerPad))) (so ^. #chartFrame) (r, cs') = bool (getViewbox so cs, cs) @@ -111,19 +112,19 @@ (ScaleCharts == so ^. #scaleCharts') -- | render charts with the default options. -renderCharts :: [Chart Double] -> Text.Text +renderCharts :: [Chart Double] -> Text renderCharts = renderChartsWith defaultSvgOptions writeChartsWith :: FilePath -> SvgOptions -> [Chart Double] -> IO () -writeChartsWith fp so cs = Text.writeFile fp (renderChartsWith so cs) +writeChartsWith fp so cs = writeFile fp (renderChartsWith so cs) writeCharts :: FilePath -> [Chart Double] -> IO () -writeCharts fp cs = Text.writeFile fp (renderCharts cs) +writeCharts fp cs = writeFile fp (renderCharts cs) -- | 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 = - Text.writeFile fp (renderCharts_ csso p r cs) + writeFile fp (renderCharts_ csso p r cs) -- * rendering huds and charts @@ -139,4 +140,4 @@ writeHudOptionsChart :: FilePath -> SvgOptions -> HudOptions -> [Hud Double] -> [Chart Double] -> IO () writeHudOptionsChart fp so hc hs cs = - Text.writeFile fp (renderHudOptionsChart so hc hs cs) + writeFile fp (renderHudOptionsChart so hc hs cs) diff --git a/src/Chart/Svg.hs b/src/Chart/Svg.hs deleted file mode 100644 --- a/src/Chart/Svg.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} - -module Chart.Svg - ( svg, - svgt, - chartDef, - chartDefs, - styleBox, - styleBoxes, - styleBoxText, - styleBoxGlyph, - ) -where - -import Chart.Color -import Chart.Types -import Control.Category (id) -import Control.Lens hiding (transform) -import Data.Generics.Labels () -import Data.Maybe -import Data.Monoid -import qualified Data.Text as Text -import qualified Lucid -import Lucid.Svg hiding (z) -import NumHask.Space as NH hiding (Element) -import Protolude hiding (writeFile) -import Text.HTML.TagSoup hiding (Attribute) - --- | the extra area from text styling -styleBoxText :: - TextStyle -> - Text.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 (Protolude.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)) unitRect - RectSharpGlyph a -> NH.scale (Point sz (a * sz)) unitRect - RectRoundedGlyph a _ _ -> NH.scale (Point sz (a * sz)) unitRect - VLineGlyph _ -> NH.scale (Point ((s ^. #borderSize) * sz) sz) unitRect - HLineGlyph _ -> NH.scale (Point sz ((s ^. #borderSize) * sz)) unitRect - TriangleGlyph a b c -> (sz *) <$> sconcat (toRect . SpotPoint <$> (a :| [b, c]) :: NonEmpty (Rect Double)) - _ -> (sz *) <$> unitRect - 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) - --- | 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 -> Svg () -lgPixel o = - linearGradient_ - [ id_ (o ^. #pixelTextureId), - x1_ (show x0), - y1_ (show y0), - x2_ (show x1), - y2_ (show y1) - ] - ( mconcat - [ stop_ - [ stop_opacity_ (show $ opac $ o ^. #pixelColorMin), - stop_color_ (toHex (o ^. #pixelColorMin)), - offset_ "0" - ], - stop_ - [ stop_opacity_ (show $ opac $ o ^. #pixelColorMax), - stop_color_ (toHex (o ^. #pixelColorMax)), - 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] -> Svg () -chartDefs cs = bool (defs_ (mconcat ds)) mempty (0 == length ds) - where - ds = mconcat $ chartDef <$> cs - -chartDef :: Chart a -> [Svg ()] -chartDef c = case c of - (Chart (PixelA s) _) -> [lgPixel s] - _ -> [] - --- | Rectangle svg -svgRect :: Rect Double -> Svg () -svgRect (Rect x z y w) = - rect_ - [ width_ (show $ z - x), - height_ (show $ w - y), - x_ (show x), - y_ (show $ - w) - ] - --- | Text svg -svgText :: TextStyle -> Text -> Point Double -> Svg () -svgText s t p@(Point x y) = - bool id (g_ [class_ "hasmathjax"]) (s ^. #hasMathjax) $ - text_ - ( [ x_ (show x), - y_ (show $ - y) - ] - <> maybe [] (\x' -> [transform_ (toRotateText x' p)]) (s ^. #rotation) - ) - (toHtmlRaw t) - --- | line svg -svgLine :: [Point Double] -> Svg () -svgLine xs = polyline_ [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 -> Svg () -svgShape CircleGlyph s (Point x y) = - circle_ - [ cx_ (show x), - cy_ (show $ - y), - r_ (show $ 0.5 * s) - ] -svgShape SquareGlyph s p = - svgRect (move p ((s *) <$> unitRect)) -svgShape (RectSharpGlyph x') s p = - svgRect (move p (NH.scale (Point s (x' * s)) unitRect)) -svgShape (RectRoundedGlyph x' rx ry) s p = - rect_ - [ width_ (show $ z - x), - height_ (show $ w - y), - x_ (show x), - y_ (show $ - w), - rx_ (show rx), - ry_ (show ry) - ] - where - (Rect x z y w) = move p (NH.scale (Point s (x' * s)) unitRect) -svgShape (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = - polygon_ - [ transform_ (toTranslateText p), - 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) = - ellipse_ - [ cx_ (show x), - cy_ (show $ - y), - rx_ (show $ 0.5 * s), - ry_ (show $ 0.5 * s * x') - ] -svgShape (VLineGlyph _) s (Point x y) = - polyline_ [points_ (show x <> "," <> show (- (y - s / 2)) <> "\n" <> show x <> "," <> show (- (y + s / 2)))] -svgShape (HLineGlyph _) s (Point x y) = - polyline_ [points_ (show (x - s / 2) <> "," <> show (- y) <> "\n" <> show (x + s / 2) <> "," <> show (- y))] -svgShape (PathGlyph path) _ p = - path_ [d_ path, transform_ (toTranslateText p)] - --- | GlyphStyle to svg Tree -svgGlyph :: GlyphStyle -> Point Double -> Svg () -svgGlyph s p = - svgShape (s ^. #shape) (s ^. #size) (realToFrac <$> p) - & maybe id (\r -> g_ [transform_ (toRotateText r p)]) (s ^. #rotation) - --- | convert a Chart to svg -svg :: Chart Double -> Svg () -svg (Chart (TextA s ts) xs) = - g_ (attsText s) (mconcat $ zipWith (\t p -> svgText s t (toPoint p)) ts xs) -svg (Chart (GlyphA s) xs) = - g_ (attsGlyph s) (mconcat $ svgGlyph s . toPoint <$> xs) -svg (Chart (LineA s) xs) = - g_ (attsLine s) (svgLine $ toPoint <$> xs) -svg (Chart (RectA s) xs) = - g_ (attsRect s) (mconcat $ svgRect . toRect <$> xs) -svg (Chart (PixelA s) xs) = - g_ (attsPixel s) (mconcat $ svgRect . toRect <$> xs) -svg (Chart BlankA _) = mempty - --- | add a tooltip to a chart -svgt :: Chart Double -> (TextStyle, Text) -> Svg () -svgt (Chart (TextA s ts) xs) (s', ts') = - g_ (attsText s) (title_ (attsText s') (Lucid.toHtml ts') <> mconcat (zipWith (\t p -> svgText s t (toPoint p)) ts xs)) -svgt (Chart (GlyphA s) xs) (s', ts') = - g_ (attsGlyph s) (title_ (attsText s') (Lucid.toHtml ts') <> mconcat (svgGlyph s . toPoint <$> xs)) -svgt (Chart (LineA s) xs) (s', ts') = - g_ (attsLine s) (title_ (attsText s') (Lucid.toHtml ts') <> svgLine (toPoint <$> xs)) -svgt (Chart (RectA s) xs) (s', ts') = - g_ (attsRect s) (title_ (attsText s') (Lucid.toHtml ts') <> mconcat (svgRect . toRect <$> xs)) -svgt (Chart (PixelA s) xs) (s', ts') = - g_ (attsPixel s) (title_ (attsText s') (Lucid.toHtml ts') <> mconcat (svgRect . toRect <$> xs)) -svgt (Chart BlankA _) _ = mempty - --- * Style to Attributes - -attsRect :: RectStyle -> [Attribute] -attsRect o = - [ stroke_width_ (show $ o ^. #borderSize), - stroke_ (hex $ o ^. #borderColor), - stroke_opacity_ (show $ opac $ o ^. #borderColor), - fill_ (hex $ o ^. #color), - fill_opacity_ (show $ opac $ o ^. #color) - ] - -attsPixel :: PixelStyle -> [Attribute] -attsPixel o = - [ stroke_width_ (show $ o ^. #pixelRectStyle . #borderSize), - stroke_ (toHex $ o ^. #pixelRectStyle . #borderColor), - stroke_opacity_ (show $ opac $ o ^. #pixelRectStyle . #borderColor), - fill_ ("url(#" <> (o ^. #pixelTextureId) <> ")") - ] - -attsText :: TextStyle -> [Attribute] -attsText o = - [ stroke_width_ "0.0", - stroke_ "none", - fill_ (toHex $ o ^. #color), - fill_opacity_ (show $ opac $ o ^. #color), - font_size_ (show $ o ^. #size), - text_anchor_ (toTextAnchor $ o ^. #anchor) - ] - <> maybe [] ((: []) . transform_ . toTranslateText) (o ^. #translate) - where - toTextAnchor :: Anchor -> Text - toTextAnchor AnchorMiddle = "middle" - toTextAnchor AnchorStart = "start" - toTextAnchor AnchorEnd = "end" - -attsGlyph :: GlyphStyle -> [Attribute] -attsGlyph o = - [ stroke_width_ (show $ o ^. #borderSize), - stroke_ (toHex $ o ^. #borderColor), - stroke_opacity_ (show $ opac $ o ^. #borderColor), - fill_ (toHex $ o ^. #color), - fill_opacity_ (show $ opac $ o ^. #color) - ] - <> maybe [] ((: []) . transform_ . toTranslateText) (o ^. #translate) - -attsLine :: LineStyle -> [Attribute] -attsLine o = - [ stroke_width_ (show $ o ^. #width), - stroke_ (toHex $ o ^. #color), - stroke_opacity_ (show $ opac $ o ^. #color), - 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) <> ")" diff --git a/src/Chart/Types.hs b/src/Chart/Types.hs --- a/src/Chart/Types.hs +++ b/src/Chart/Types.hs @@ -1,621 +1,2038 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wall #-} - -module Chart.Types - ( Chart (..), - Chartable, - Annotation (..), - annotationText, - RectStyle (RectStyle), - defaultRectStyle, - blob, - clear, - border, - TextStyle (..), - defaultTextStyle, - Anchor (..), - fromAnchor, - toAnchor, - GlyphStyle (..), - defaultGlyphStyle, - GlyphShape (..), - glyphText, - LineStyle (..), - defaultLineStyle, - PixelStyle (..), - defaultPixelStyle, - Orientation (..), - fromOrientation, - toOrientation, - Spot (..), - toRect, - toPoint, - pattern SR, - pattern SP, - padRect, - SvgAspect (..), - toSvgAspect, - fromSvgAspect, - EscapeText (..), - CssOptions (..), - ScaleCharts (..), - SvgOptions (..), - defaultSvgOptions, - defaultSvgFrame, - 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, - FormatN (..), - defaultFormatN, - ) -where - -import Chart.Color -import Control.Lens -import Data.Generics.Labels () -import Data.List ((!!)) -import qualified Data.Text as Text -import GHC.Exts -import GHC.Generics -import NumHask.Space hiding (Element) -import Protolude - --- * Chart - --- | A `Chart` consists of --- - a list of spots on the xy-plane, and --- - specific style of representation for each spot (an Annotation) -data Chart a - = Chart - { annotation :: Annotation, - spots :: [Spot a] - } - deriving (Eq, Show, Generic) - --- | the aspects a number needs to be to form the data for a chart -type Chartable a = - (Real a, Fractional a, RealFrac a, RealFloat a, Floating a) - --- | a piece of chart structure --- | The use of #rowName with Annotation doesn't seem to mesh well with polymorphism, so a switch to concrete types (which fit it with svg-tree methods) occurs at this layer, and the underlying ADTs use a lot of Doubles -data Annotation - = RectA RectStyle - | TextA TextStyle [Text.Text] - | GlyphA GlyphStyle - | LineA LineStyle - | BlankA - | PixelA PixelStyle - deriving (Eq, Show, Generic) - -annotationText :: Annotation -> Text -annotationText (RectA _) = "RectA" -annotationText TextA {} = "TextA" -annotationText (GlyphA _) = "GlyphA" -annotationText (LineA _) = "LineA" -annotationText BlankA = "BlankA" -annotationText (PixelA _) = "PixelA" - --- | Rectangle styling -data RectStyle - = RectStyle - { borderSize :: Double, - borderColor :: Colour, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the style -defaultRectStyle :: RectStyle -defaultRectStyle = RectStyle 0.02 (palette !! 0) (palette !! 1) - --- | solid rectangle, no border -blob :: Colour -> RectStyle -blob = RectStyle 0 transparent - --- | clear and utrans rect -clear :: RectStyle -clear = RectStyle 0 transparent transparent - --- | transparent rectangle, with border -border :: Double -> Colour -> RectStyle -border s c = RectStyle s c transparent - --- | Text styling -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) - -data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic) - -fromAnchor :: (IsString s) => Anchor -> s -fromAnchor AnchorMiddle = "Middle" -fromAnchor AnchorStart = "Start" -fromAnchor AnchorEnd = "End" - -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 -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 circle style -defaultGlyphStyle :: GlyphStyle -defaultGlyphStyle = - GlyphStyle - 0.03 - (setAlpha (palette !! 0) 0.8) - (setAlpha (palette !! 1) 0.4) - 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) - -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 -data LineStyle - = LineStyle - { width :: Double, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the official default line style -defaultLineStyle :: LineStyle -defaultLineStyle = LineStyle 0.012 (palette !! 0) - -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) - -defaultPixelStyle :: PixelStyle -defaultPixelStyle = - PixelStyle colorPixelMin colorPixelMax (pi / 2) (blob black) "pixel" - --- | Verticle or Horizontal -data Orientation = Vert | Hori deriving (Eq, Show, Generic) - -fromOrientation :: (IsString s) => Orientation -> s -fromOrientation Hori = "Hori" -fromOrientation Vert = "Vert" - -toOrientation :: (Eq s, IsString s) => s -> Orientation -toOrientation "Hori" = Hori -toOrientation "Vert" = Vert -toOrientation _ = Hori - --- * primitive Chart elements - --- | unification of a point and rect on the plane -data Spot a - = SpotPoint (Point a) - | SpotRect (Rect a) - deriving (Eq, Show, Functor) - -instance (Ord a, Num a, Fractional a) => Num (Spot a) where - SpotPoint (Point x y) + SpotPoint (Point x' y') = SpotPoint (Point (x + x') (y + y')) - SpotPoint (Point x' y') + SpotRect (Rect x z y w) = SpotRect $ Rect (x + x') (z + x') (y + y') (w + y') - SpotRect (Rect x z y w) + SpotPoint (Point x' y') = SpotRect $ Rect (x + x') (z + x') (y + y') (w + y') - SpotRect (Rect x z y w) + SpotRect (Rect x' z' y' w') = - SpotRect $ Rect (x + x') (z + z') (y + y') (w + w') - - x * y = SpotRect $ toRect x `multRect` toRect y - - abs x = SpotPoint $ abs <$> toPoint x - - signum x = SpotPoint $ signum <$> toPoint x - - negate (SpotPoint (Point x y)) = SpotPoint (Point (- x) (- y)) - negate (SpotRect (Rect x z y w)) = SpotRect (Rect (- x) (- z) (- y) (- w)) - - fromInteger x = SP (fromInteger x) (fromInteger x) - --- | pattern for SP x y -pattern SP :: a -> a -> Spot a -pattern SP a b = SpotPoint (Point a b) - -{-# COMPLETE SP #-} - --- | pattern for SA lowerx upperx lowery uppery -pattern SR :: a -> a -> a -> a -> Spot a -pattern SR a b c d = SpotRect (Rect a b c d) - -{-# COMPLETE SR #-} - --- | Convert a spot to an Rect -toRect :: Spot a -> Rect a -toRect (SP x y) = Rect x x y y -toRect (SpotRect a) = a - --- | Convert a spot to a Point -toPoint :: (Ord a, Fractional a) => Spot a -> Point a -toPoint (SP x y) = Point x y -toPoint (SpotRect (Ranges x y)) = Point (mid x) (mid y) - -instance (Ord a) => Semigroup (Spot a) where - (<>) a b = SpotRect (toRect a `union` toRect b) - --- | additive padding -padRect :: (Num a) => a -> Rect a -> Rect a -padRect p (Rect x z y w) = Rect (x - p) (z + p) (y - p) (w + p) - -data EscapeText = EscapeText | NoEscapeText deriving (Show, Eq, Generic) - -data CssOptions = UseCssCrisp | NoCssOptions deriving (Show, Eq, Generic) - -data ScaleCharts = ScaleCharts | NoScaleCharts deriving (Show, Eq, Generic) - -data SvgAspect = ManualAspect Double | ChartAspect deriving (Show, Eq, Generic) - -fromSvgAspect :: (IsString s) => SvgAspect -> s -fromSvgAspect (ManualAspect _) = "ManualAspect" -fromSvgAspect ChartAspect = "ChartAspect" - -toSvgAspect :: (Eq s, IsString s) => s -> Double -> SvgAspect -toSvgAspect "ManualAspect" a = ManualAspect a -toSvgAspect "ChartAspect" _ = ChartAspect -toSvgAspect _ _ = ChartAspect - --- | Top-level SVG options. -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) - -defaultSvgOptions :: SvgOptions -defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoEscapeText NoCssOptions ScaleCharts (ManualAspect 1.5) - -defaultSvgFrame :: RectStyle -defaultSvgFrame = border 0.01 colorFrame - --- | 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) - -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. -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 - -defaultHudOptions :: HudOptions -defaultHudOptions = - HudOptions - (Just defaultCanvas) - [] - [ defaultAxisOptions, - defaultAxisOptions & #place .~ PlaceLeft - ] - Nothing - -defaultCanvas :: RectStyle -defaultCanvas = blob colorCanvas - --- | 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) - -placeText :: Place -> Text -placeText p = - case p of - PlaceTop -> "Top" - PlaceBottom -> "Bottom" - PlaceLeft -> "Left" - PlaceRight -> "Right" - PlaceAbsolute _ -> "Absolute" - -data AxisOptions - = AxisOptions - { abar :: Maybe Bar, - adjust :: Maybe Adjustments, - atick :: Tick, - place :: Place - } - deriving (Eq, Show, Generic) - -defaultAxisOptions :: AxisOptions -defaultAxisOptions = AxisOptions (Just defaultBar) (Just defaultAdjustments) defaultTick PlaceBottom - -data Bar - = Bar - { rstyle :: RectStyle, - wid :: Double, - buff :: Double - } - deriving (Show, Eq, Generic) - -defaultBar :: Bar -defaultBar = Bar (RectStyle 0 colorGlyphTick colorGlyphTick) 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) - -defaultTitle :: Text -> Title -defaultTitle txt = - Title - txt - ( (#size .~ 0.12) - . (#color .~ colorText) - $ defaultTextStyle - ) - PlaceTop - AnchorMiddle - 0.04 - -data Tick - = Tick - { tstyle :: TickStyle, - gtick :: Maybe (GlyphStyle, Double), - ttick :: Maybe (TextStyle, Double), - ltick :: Maybe (LineStyle, Double) - } - deriving (Show, Eq, Generic) - -defaultGlyphTick :: GlyphStyle -defaultGlyphTick = - defaultGlyphStyle - & #borderSize .~ 0.005 - & #borderColor .~ colorGlyphTick - & #color .~ colorGlyphTick - & #shape .~ VLineGlyph 0.005 - -defaultTextTick :: TextStyle -defaultTextTick = - defaultTextStyle & #size .~ 0.05 & #color .~ colorTextTick - -defaultLineTick :: LineStyle -defaultLineTick = - defaultLineStyle - & #color .~ colorLineTick - & #width .~ 5.0e-3 - -defaultTick :: Tick -defaultTick = - Tick - defaultTickStyle - (Just (defaultGlyphTick, 0.0125)) - (Just (defaultTextTick, 0.015)) - (Just (defaultLineTick, 0.005)) - --- | 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) - -defaultTickStyle :: TickStyle -defaultTickStyle = TickRound (FormatComma 0) 8 TickExtend - -tickStyleText :: TickStyle -> Text -tickStyleText TickNone = "TickNone" -tickStyleText TickLabels {} = "TickLabels" -tickStyleText TickRound {} = "TickRound" -tickStyleText TickExact {} = "TickExact" -tickStyleText TickPlaced {} = "TickPlaced" - -data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) - --- | options for prettifying axis decorations -data Adjustments - = Adjustments - { maxXRatio :: Double, - maxYRatio :: Double, - angledRatio :: Double, - allowDiagonal :: Bool - } - deriving (Show, Eq, Generic) - -defaultAdjustments :: Adjustments -defaultAdjustments = Adjustments 0.08 0.06 0.12 True - --- You're all Legends! - --- | Legend options -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) - -defaultLegendOptions :: LegendOptions -defaultLegendOptions = - LegendOptions - 0.1 - 0.2 - 0.1 - ( defaultTextStyle - & #size .~ 0.08 - & #color .~ colorGrey - ) - 10 - 0.1 - 0.1 - (Just (RectStyle 0.02 (palette !! 0) black)) - PlaceBottom - 0.2 - -data FormatN - = FormatFixed Int - | FormatComma Int - | FormatExpt Int - | FormatDollar - | FormatPercent Int - | FormatNone - deriving (Eq, Show, Generic) - -defaultFormatN :: FormatN -defaultFormatN = FormatComma 2 +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# 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-overlapping-patterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Chart.Types + ( Chart (..), + Annotation (..), + annotationText, + blank, + RectStyle (..), + defaultRectStyle, + blob, + clear, + border, + TextStyle (..), + defaultTextStyle, + Anchor (..), + fromAnchor, + toAnchor, + GlyphStyle (..), + defaultGlyphStyle, + GlyphShape (..), + glyphText, + LineStyle (..), + defaultLineStyle, + PixelStyle (..), + defaultPixelStyle, + Direction (..), + fromDirection, + toDirection, + Spot (..), + toRect, + toPoint, + padRect, + SvgAspect (..), + toSvgAspect, + fromSvgAspect, + EscapeText (..), + CssOptions (..), + ScaleCharts (..), + SvgOptions (..), + defaultSvgOptions, + defaultSvgFrame, + 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, + + -- $color + Colour, + pattern Colour, + opac, + setOpac, + fromRGB, + hex, + palette, + palette1, + blend, + toHex, + fromHex, + unsafeFromHex, + + grayscale, + colorText, + transparent, + black, + white, + + -- * re-exports + module Graphics.Color.Model, + + -- $formats + FormatN(..), + defaultFormatN, + fromFormatN, + toFormatN, + fixed, + comma, + expt, + dollar, + formatN, + precision, + formatNs, + + -- $core + projectTo, + projectSpots, + projectSpotsWith, + dataBox, + toAspect, + scaleAnn, + defRect, + defRectS, + 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 qualified Data.Attoparsec.Text as A +import Data.Generics.Labels () +import Data.List ((!!)) +import Graphics.Color.Model +import NumHask.Prelude +import NumHask.Space hiding (Element) +import qualified Prelude as P +import qualified Data.Text as Text +import Data.List (nub) +import Data.Scientific +import Data.Time +import qualified Control.Foldl as L +import Data.Generics.Labels () +import qualified Lucid +import Lucid (with, term, width_, height_, id_, class_, toHtmlRaw) +import NumHask.Space as NH hiding (Element) +import Text.HTML.TagSoup hiding (Attribute) +import Lucid.Base (makeXmlElementNoEnd) +import qualified Lucid.Base as Lucid + + +{- $setup + +>>> :set -XOverloadedLabels +>>> :set -XNoImplicitPrelude +>>> -- import NumHask.Prelude +>>> import Control.Lens +>>> import Chart.Render + +-} + + +-- * Chart + +-- | A `Chart` consists of +-- - a list of spots on the xy-plane, and +-- - specific style of representation for each spot. +-- +data Chart a + = Chart + { annotation :: Annotation, + spots :: [Spot 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) + +annotationText :: Annotation -> Text +annotationText (RectA _) = "RectA" +annotationText TextA {} = "TextA" +annotationText (GlyphA _) = "GlyphA" +annotationText (LineA _) = "LineA" +annotationText BlankA = "BlankA" +annotationText (PixelA _) = "PixelA" + +blank :: [Chart Double] +blank = [Chart 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} +-- +-- >writeCharts "other/unit.svg" [Chart (RectA defaultRectStyle) [SpotRect (unitRect::Rect Double)]] +-- +-- ![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]) [SpotPoint 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 + +-- | unification of a point and rect on the plane +data Spot a + = SpotPoint (Point a) + | SpotRect (Rect a) + deriving (Eq, Show, Functor) + +instance (Ord a, Num a, Fractional a) => Num (Spot a) where + SpotPoint (Point x y) + SpotPoint (Point x' y') = SpotPoint (Point (x P.+ x') (y P.+ y')) + SpotPoint (Point x' y') + SpotRect (Rect x z y w) = SpotRect $ Rect (x P.+ x') (z P.+ x') (y P.+ y') (w P.+ y') + SpotRect (Rect x z y w) + SpotPoint (Point x' y') = SpotRect $ Rect (x P.+ x') (z P.+ x') (y P.+ y') (w P.+ y') + SpotRect (Rect x z y w) + SpotRect (Rect x' z' y' w') = + SpotRect $ Rect (x P.+ x') (z P.+ z') (y P.+ y') (w P.+ w') + + x * y = SpotRect $ toRect x `multRect` toRect y + + abs x = SpotPoint $ P.abs <$> toPoint x + + signum x = SpotPoint $ signum <$> toPoint x + + negate (SpotPoint (Point x y)) = SpotPoint (Point (P.negate x) (P.negate y)) + negate (SpotRect (Rect x z y w)) = SpotRect (Rect (P.negate x) (P.negate z) (P.negate y) (P.negate w)) + + fromInteger x = SpotPoint (Point (P.fromInteger x) (P.fromInteger x)) + +-- | Convert a spot to an Rect +toRect :: Spot a -> Rect a +toRect (SpotPoint (Point x y)) = Rect x x y y +toRect (SpotRect a) = a + +-- | Convert a spot to a Point +toPoint :: (Ord a, Fractional a) => Spot a -> Point a +toPoint (SpotPoint (Point x y)) = Point x y +toPoint (SpotRect (Ranges x y)) = Point (mid x) (mid y) + +instance (Ord a) => Semigroup (Spot a) where + (<>) a b = SpotRect (toRect a `union` toRect b) + +-- | 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 0) 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 0) 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 + +-- | snatching Colour as the library color representation. +newtype Colour = Colour' { color' :: Color (Alpha RGB) Double } deriving (Eq, Generic) + +-- | Constructor. +pattern Colour :: Double -> Double -> Double -> Double -> Colour +pattern Colour r g b a = Colour' (ColorRGBA r g b a) +{-# COMPLETE Colour #-} + +instance Show Colour where + show (Colour r g b a) = + Text.unpack $ "RGBA " <> + fixed 2 r <> " " <> + fixed 2 g <> " " <> + fixed 2 b <> " " <> + fixed 2 a + +-- | get opacity +opac :: Colour -> Double +opac c = getAlpha (color' c) + +-- | set opacity +setOpac :: Double -> Colour -> Colour +setOpac o (Colour r g b _) = Colour r g b o + +-- | +fromRGB :: Color RGB Double -> Double -> Colour +fromRGB (ColorRGB r b g) o = Colour' $ ColorRGBA r b g o + +-- | +hex :: Colour -> Text +hex c = toHex c + +-- | interpolate between 2 colors +blend :: Double -> Colour -> Colour -> Colour +blend c (Colour r g b a) (Colour r' g' b' a') = Colour r'' g'' b'' a'' + where + r'' = r + c * (r' - r) + g'' = g + c * (g' - g) + b'' = b + c * (b' - b) + a'' = a + c * (a' - a) + +-- | +parseHex :: A.Parser (Color RGB Double) +parseHex = + (fmap toDouble + . ( \((r, g), b) -> + ColorRGB (fromIntegral r) (fromIntegral g) (fromIntegral b) :: Color RGB Word8 + ) + . (\(f, b) -> (f `divMod` (256 :: Int), b)) + . (`divMod` 256) + <$> (A.string "#" *> A.hexadecimal)) + +-- | +fromHex :: Text -> Either Text (Color RGB Double) +fromHex = first pack . A.parseOnly parseHex + +-- | +unsafeFromHex :: Text -> Color RGB Double +unsafeFromHex t = either (const (ColorRGB 0 0 0)) id $ A.parseOnly parseHex t + +-- | convert from 'Colour' to #xxxxxx +toHex :: Colour -> Text +toHex c = + "#" + <> Text.justifyRight 2 '0' (hex' r) + <> Text.justifyRight 2 '0' (hex' g) + <> Text.justifyRight 2 '0' (hex' b) + where + (ColorRGBA r g b _) = toWord8 <$> color' c + +-- | +hex' :: (FromInteger a, ToIntegral a Integer, Integral a, Ord a, Subtractive a) => a -> Text +hex' i + | i < 0 = "-" <> go (- i) + | otherwise = go i + where + go n + | n < 16 = hexDigit n + | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16) + +-- | +hexDigit :: (Ord a, FromInteger a, ToIntegral a Integer) => a -> Text +hexDigit n + | n <= 9 = Text.singleton P.$! i2d (fromIntegral n) + | otherwise = Text.singleton P.$! toEnum (fromIntegral n + 87) + +-- | +i2d :: Int -> Char +i2d i = (chr (ord '0' + i)) + +-- | some RGB colors to work with +palette :: [Color RGB Double] +palette = unsafeFromHex <$> ["#a6cee3","#1f78b4","#b2df8a","#33a02c","#fb9a99","#e31a1c","#fdbf6f","#ff7f00","#cab2d6","#6a3d9a","#ffff99","#b15928"] + +-- | some RGBA colors +palette1 :: [Colour] +palette1 = (\c -> fromRGB c 1) <$> palette + +-- | gray with 1 opacity +grayscale :: Double -> Color RGB Double +grayscale n = ColorRGB n n n + +-- | standard text color +colorText :: Colour +colorText = fromRGB (grayscale 0.2) 1 + +-- | +black :: Colour +black = fromRGB (grayscale 0) 1 + +-- | +white :: Colour +white = fromRGB (grayscale 1) 1 + +-- | +transparent :: Colour +transparent = Colour 0 0 0 0 + +-- | Number formatting options. +-- +-- >>> defaultFormatN +-- FormatComma 2 +-- +data FormatN + = FormatFixed Int + | FormatComma Int + | FormatExpt Int + | FormatDollar + | FormatPercent Int + | FormatNone + deriving (Eq, Show, Generic) + +-- | The official format +defaultFormatN :: FormatN +defaultFormatN = FormatComma 2 + +-- | textifier +fromFormatN :: (IsString s) => FormatN -> s +fromFormatN (FormatFixed _) = "Fixed" +fromFormatN (FormatComma _) = "Comma" +fromFormatN (FormatExpt _) = "Expt" +fromFormatN FormatDollar = "Dollar" +fromFormatN (FormatPercent _) = "Percent" +fromFormatN FormatNone = "None" + +-- | readifier +toFormatN :: (Eq s, IsString s) => s -> Int -> FormatN +toFormatN "Fixed" n = FormatFixed n +toFormatN "Comma" n = FormatComma n +toFormatN "Expt" n = FormatExpt n +toFormatN "Dollar" _ = FormatDollar +toFormatN "Percent" n = FormatPercent n +toFormatN "None" _ = FormatNone +toFormatN _ _ = FormatNone + +-- | to x decimal places +fixed :: Int -> Double -> Text +fixed x n = pack $ formatScientific Fixed (Just x) (fromFloatDigits n) + +-- | comma format +comma :: Int -> Double -> Text +comma n a + | a < 1000 = fixed n a + | otherwise = go (fromInteger $ floor a) "" + where + go :: Int -> Text -> Text + go x t + | x < 0 = "-" <> go (- x) "" + | x < 1000 = pack (show x) <> t + | otherwise = + let (d, m) = divMod x 1000 + in go d ("," <> pack (show' m)) + where + show' n' = let x' = show n' in (replicate (3 - length x') '0' <> x') + +-- | scientific exponential +expt :: Int -> Double -> Text +expt x n = pack $ formatScientific Exponent (Just x) (fromFloatDigits n) + +-- | dollars and cents +dollar :: Double -> Text +dollar = ("$" <>) . comma 2 + +-- | fixed percent +percent :: Int -> Double -> Text +percent x n = (<> "%") $ fixed x (100 * n) + +-- | make text +formatN :: FormatN -> Double -> Text +formatN (FormatFixed n) x = fixed n x +formatN (FormatComma n) x = comma n x +formatN (FormatExpt n) x = expt n x +formatN FormatDollar x = dollar x +formatN (FormatPercent n) x = percent n x +formatN FormatNone x = pack (show x) + +-- | Provide formatted text for a list of numbers so that they are just distinguished. 'precision commas 2 ticks' means give the tick labels as much precision as is needed for them to be distinguished, but with at least 2 significant figures, and format Integers with commas. +precision :: (Int -> Double -> Text) -> Int -> [Double] -> [Text] +precision f n0 xs = + precLoop f (fromIntegral n0) xs + where + precLoop f' n xs' = + let s = f' n <$> xs' + in if s == nub s || n > 4 + then s + else precLoop f' (n + 1) xs' + +-- | textifier +formatNs :: FormatN -> [Double] -> [Text] +formatNs (FormatFixed n) xs = precision fixed n xs +formatNs (FormatComma n) xs = precision comma n xs +formatNs (FormatExpt n) xs = precision expt n xs +formatNs FormatDollar xs = precision (const dollar) 2 xs +formatNs (FormatPercent n) xs = precision percent n xs +formatNs FormatNone xs = pack . show <$> xs + +-- | project a Spot from one Rect to another, preserving relative position. +-- +-- >>> projectOn unitRect (Rect 0 1 0 1) (SpotPoint $ Point 0 0) +-- SpotPoint Point -0.5 -0.5 +projectOn :: (Ord a, Fractional a) => Rect a -> Rect a -> Spot a -> Spot a +projectOn new old@(Rect x z y w) po@(SpotPoint (Point px py)) + | x == z && y == w = po + | x == z = SpotPoint (Point px py') + | y == w = SpotPoint (Point px' py) + | otherwise = SpotPoint (Point px' py') + where + (Point px' py') = project old new (toPoint po) +projectOn new old@(Rect x z y w) ao@(SpotRect (Rect ox oz oy ow)) + | x == z && y == w = ao + | x == z = SpotRect (Rect ox oz ny nw) + | y == w = SpotRect (Rect nx nz oy ow) + | otherwise = SpotRect a + where + a@(Rect nx nz ny nw) = projectRect old new (toRect ao) + +-- | project a [Spot a] from it's folded space to the given area +-- +-- >>> projectTo unitRect (SpotPoint <$> zipWith Point [0..2] [0..2]) +-- [SpotPoint Point -0.5 -0.5,SpotPoint Point 0.0 0.0,SpotPoint Point 0.5 0.5] +projectTo :: (Ord a, Fractional a) => Rect a -> [Spot a] -> [Spot a] +projectTo _ [] = [] +projectTo vb (x : xs) = projectOn vb (toRect $ sconcat (x :| xs)) <$> (x : xs) + +defRect :: (Fractional a) => Maybe (Rect a) -> Rect a +defRect = fromMaybe unitRect + +defRectS :: (Subtractive a, Eq a, FromRational a, Fractional a) => Maybe (Rect a) -> Rect a +defRectS r = maybe unitRect singletonUnit r + where + singletonUnit :: (Subtractive a, Eq a, FromRational a) => Rect a -> Rect a + 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 + +projectSpots :: (Ord a, Fractional a) => Rect a -> [Chart a] -> [Chart a] +projectSpots a cs = cs' + where + xss = projectTo2 a (spots <$> cs) + ss = annotation <$> cs + cs' = zipWith Chart ss xss + projectTo2 vb xss = + fmap (maybe id (projectOn vb) + (fold $ foldRect . fmap toRect <$> xss)) <$> xss + +projectSpotsWith :: (Ord a, Fractional a) => Rect a -> Rect a -> [Chart a] -> [Chart a] +projectSpotsWith new old cs = cs' + where + xss = fmap (projectOn new old) . spots <$> cs + ss = annotation <$> cs + cs' = zipWith Chart ss xss + +toAspect :: (Divisive a, Subtractive a) => Rect a -> a +toAspect (Rect x z y w) = (z - x) / (w - y) + +-- | +dataBox :: (Ord a) =>[Chart a] -> Maybe (Rect a) +dataBox cs = foldRect . mconcat $ fmap toRect <$> (spots <$> 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 :: (Ord a, Fractional a) => Spot a -> [Chart a] -> [Chart a] +moveChart sp cs = fmap (#spots %~ fmap (sp P.+)) cs + +-- | pattern for SP x y +pattern SP' :: a -> a -> Spot a +pattern SP' a b = SpotPoint (Point a b) + +{-# COMPLETE SP' #-} + +-- | pattern for SA lowerx upperx lowery uppery +pattern SR' :: a -> a -> a -> a -> Spot a +pattern SR' a b c d = SpotRect (Rect a b c d) + +{-# COMPLETE SR' #-} + + +-- | 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' = defRect $ dataBox cs' + ca' = defRect $ styleBoxes cs' + cs' = projectSpotsWith 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 (defRectS $ 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 (SpotRect <$> 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) [SpotRect 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)) + [ SR' + x + z + (w' + b ^. #buff) + (w' + b ^. #buff + b ^. #wid) + ] + PlaceBottom -> + Chart + (RectA (rstyle b)) + [ SR' + x + z + (y' - b ^. #wid - b ^. #buff) + (y' - b ^. #buff) + ] + PlaceLeft -> + Chart + (RectA (rstyle b)) + [ SR' + (x' - b ^. #wid - b ^. #buff) + (x' - b ^. #buff) + y + w + ] + PlaceRight -> + Chart + (RectA (rstyle b)) + [ SR' + (z' + (b ^. #buff)) + (z' + (b ^. #buff) + (b ^. #wid)) + y + w + ] + PlaceAbsolute (Point x'' _) -> + Chart + (RectA (rstyle b)) + [ SR' + (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 P.+ alignPos a)) + & #rotation ?~ rot + ) + [t ^. #text] + ) + [SP' 0 0] + 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 -> [Spot Double] +placeGridLines pl (Rect x z y w) a b + | pl `elem` [PlaceTop, PlaceBottom] = [SP' a (y - b), SP' a (w + b)] + | otherwise = [SP' (x - b) a, SP' (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))) + ( SpotPoint . (placePos pl b ca P.+) . 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] + ) + [SpotPoint sp] + ) + (labels $ ticksPlaced ts pl da xs) + ( (placePos pl b ca P.+ textPos pl txts b P.+) . 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) = L.fold (L.Fold step (x, []) (\(x0, x1) -> reverse $ x0 : x1)) 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 .= defRect (styleBoxes cs') + pure cs' + where + scaledleg = + (#annotation %~ scaleAnn (realToFrac $ l ^. #lscale)) + . (#spots %~ fmap (fmap (* l ^. #lscale))) + <$> lcs + movedleg ca' leg = + maybe id (moveChart . SpotPoint . 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]) [SP' 0 0] + ) + where + (ann, sps) = case a of + RectA rs -> + ( RectA rs, + [SR' 0 (l ^. #lsize) 0 (l ^. #lsize)] + ) + PixelA ps -> + ( PixelA ps, + [SR' 0 (l ^. #lsize) 0 (l ^. #lsize)] + ) + TextA ts txts -> + ( TextA (ts & #size .~ realToFrac (l ^. #lsize)) (take 1 txts), + [SP' 0 0] + ) + GlyphA gs -> + ( GlyphA (gs & #size .~ realToFrac (l ^. #lsize)), + [SP' (0.5 * l ^. #lsize) (0.33 * l ^. #lsize)] + ) + LineA ls -> + ( LineA (ls & #width %~ (/ (realToFrac $ l ^. #lscale))), + [SP' 0 (0.33 * l ^. #lsize), SP' (2 * l ^. #lsize) (0.33 * l ^. #lsize)] + ) + BlankA -> + ( BlankA, + [SP' 0 0] + ) + +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.+ 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)) unitRect + RectSharpGlyph a -> NH.scale (Point sz (a * sz)) unitRect + RectRoundedGlyph a _ _ -> NH.scale (Point sz (a * sz)) unitRect + VLineGlyph _ -> NH.scale (Point ((s ^. #borderSize) * sz) sz) unitRect + HLineGlyph _ -> NH.scale (Point sz ((s ^. #borderSize) * sz)) unitRect + TriangleGlyph a b c -> (sz *) <$> sconcat (toRect . SpotPoint <$> (a :| [b, c]) :: NonEmpty (Rect Double)) + _ -> (sz *) <$> unitRect + 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 #spots <$> 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 *) <$> unitRect)) +svgShape (RectSharpGlyph x') s p = + svgRect (move p (NH.scale (Point s (x' * s)) unitRect)) +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)) unitRect) +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) [SpotRect unitRect]] +-- [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}), spots = [SpotRect Rect -0.5 0.5 -0.5 0.5]},Chart {annotation = BlankA, spots = [SpotRect Rect -0.605 0.605 -0.605 0.605]}] +-- +padChart :: Double -> [Chart Double] -> [Chart Double] +padChart p cs = cs <> [Chart BlankA (maybeToList (SpotRect . padRect p <$> styleBoxes cs))] + +-- | overlay a frame on some charts with some additive padding between +-- +-- >>> frameChart defaultRectStyle 0.1 blank +-- [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}), spots = []},Chart {annotation = BlankA, spots = []}] +-- +frameChart :: RectStyle -> Double -> [Chart Double] -> [Chart Double] +frameChart rs p cs = [Chart (RectA rs) (maybeToList (SpotRect . 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 (#spots %~ fmap (\s -> SpotPoint (Point (z x) 0) P.- SpotPoint (Point (origx x) 0) P.+ 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 (#spots %~ fmap (\s -> SpotPoint (Point (origx x - origx a) (w x)) P.+ 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 +stack :: Int -> Double -> [[Chart Double]] -> [Chart Double] +stack _ _ [] = [] +stack n gap cs = vert gap (hori gap <$> group' cs []) + where + group' [] acc = reverse acc + group' x acc = group' (drop n x) (take n x : acc) + +addChartBox :: Chart Double -> Rect Double -> Rect Double +addChartBox c r = sconcat (r :| maybeToList (styleBox c)) + +addChartBoxes :: [Chart Double] -> Rect Double -> Rect Double +addChartBoxes c r = sconcat (r :| maybeToList (styleBoxes c)) diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,17 +0,0 @@ -resolver: lts-15.13 - -packages: - - . - -extra-deps: - - protolude-0.3.0 - - box-0.4.0 - - numhask-space-0.4.0 - - web-rep-0.5.0 - # external non-stack libraries - - generic-lens-1.2.0.1 - - Color-0.1.4 - - interpolatedstring-perl6-1.0.2 - - javascript-bridge-0.2.0 - - lucid-svg-0.7.1 - - text-format-0.3.2 diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +module Main where + +import NumHask.Prelude +import Test.DocTest + +main :: IO () +main = doctest + [ "src/Chart.hs", + "src/Chart/Types.hs", + "src/Chart/Bar.hs" + ] +