chart-svg (empty) → 0.0.1
raw patch · 18 files changed
+4428/−0 lines, 18 filesdep +JuicyPixelsdep +attoparsecdep +basesetup-changed
Dependencies added: JuicyPixels, attoparsec, base, bifunctors, chart-svg, colour, containers, foldl, generic-lens, javascript-bridge, lens, lucid, lucid-svg, numhask-space, palette, pretty-simple, protolude, scientific, scotty, tagsoup, text, text-format, time, transformers, unordered-containers, wai-middleware-static, web-rep
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/examples.hs +90/−0
- app/venn.hs +187/−0
- chart-svg.cabal +107/−0
- src/Chart.hs +36/−0
- src/Chart/Bar.hs +225/−0
- src/Chart/Color.hs +110/−0
- src/Chart/Core.hs +145/−0
- src/Chart/Examples.hs +350/−0
- src/Chart/Format.hs +97/−0
- src/Chart/Hud.hs +630/−0
- src/Chart/Page.hs +1172/−0
- src/Chart/Pixel.hs +169/−0
- src/Chart/Render.hs +139/−0
- src/Chart/Svg.hs +290/−0
- src/Chart/Types.hs +634/−0
- stack.yaml +15/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tony Day nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/examples.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wall #-}++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 Web.Page+import Web.Scotty+import Protolude hiding ((<<*>>), Rep, replace)++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)++midChart ::+ SharedRep IO (Text, Text) ->+ Application ->+ Application+midChart sr = midShared sr initChartRender updateChart++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)+ )++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++-- 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)
+ app/venn.hs view
@@ -0,0 +1,187 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++import Protolude+import NumHask.Space+import Chart+import Control.Category (id)+import Control.Lens+import qualified Data.Map.Strict as Map+import Data.Generics.Labels ()+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Lazy+import Lucid.Svg hiding (z)++xs :: Map.Map Text (Point Double)+xs = Map.fromList+ [ ("origin", Point 0 0) -- origin+ , ("circle1", Point 0.5 (-0.5 + cos (pi/6))) -- center of circle 1+ , ("circle2", Point 0 (-0.5)) -- center of circle 2+ , ("circle3", Point (-0.5) ((-0.5) + cos (pi/6))) -- center of circle 3+ , ("corner1", Point 0 ((-0.5) + 2 * cos (pi/6))) -- corner 1+ , ("corner2", Point 1 (-0.5)) -- corner 2+ , ("corner3", Point (-1) (-0.5)) -- corner 3+ ]++vennps :: Text -> (Double, Double)+vennps k = let (Point x y) = xs Map.! k in (x, -y)++moveA :: Double -> Double -> Text+moveA x y = "M" <> show x <> "," <> show y++data Arc = Arc { arcXr :: Double, arcYr :: Double, arcRot :: Double, arcLargeArcFlag :: Bool, arcSweepFlag :: Bool, arcX :: Double, arcY :: Double} deriving (Eq, Show, Generic)++arcA_ :: Arc -> Text+arcA_ a = show (view #arcXr a) <> " " <> show (view #arcYr a) <> " " <> show (view #arcRot a) <> " " <> bool "0" "1" (view #arcLargeArcFlag a) <> " " <> bool "0" "1" (view #arcSweepFlag a) <> " " <> show (view #arcX a) <> "," <> show (view #arcY a)++arcA :: [Arc] -> Text+arcA as = "A" <> Text.intercalate " " (arcA_ <$> as)++outerseg1 :: Text+outerseg1 = Text.intercalate " "+ [ uncurry moveA (vennps "corner1")+ , arcA + [ uncurry (Arc 0.5 0.5 0 True True) (vennps "corner2")+ , uncurry (Arc 1 1 0 False False) (vennps "circle1")+ , uncurry (Arc 1 1 0 False False) (vennps "corner1")+ ]+ , "Z"+ ]++outerseg2 :: Text+outerseg2 = Text.intercalate " "+ [ uncurry moveA (vennps "corner3")+ , arcA + [ uncurry (Arc 0.5 0.5 0 True False) (vennps "corner2")+ , uncurry (Arc 1 1 0 False True) (vennps "circle2")+ , uncurry (Arc 1 1 0 False True) (vennps "corner3")+ ]+ , "Z"+ ]++outerseg3 :: Text+outerseg3 = Text.intercalate " "+ [ uncurry moveA (vennps "corner3")+ , arcA + [ uncurry (Arc 0.5 0.5 0 True True) (vennps "corner1")+ , uncurry (Arc 1 1 0 False False) (vennps "circle3")+ , uncurry (Arc 1 1 0 False False) (vennps "corner3")+ ]+ , "Z"+ ]++innerseg :: Text+innerseg = Text.intercalate " "+ [ uncurry moveA (vennps "circle1")+ , arcA + [ uncurry (Arc 1 1 0 False True) (vennps "circle2")+ , uncurry (Arc 1 1 0 False True) (vennps "circle3")+ , uncurry (Arc 1 1 0 False True) (vennps "circle1")+ ]+ , "Z"+ ]++midseg1 :: Text+midseg1 = Text.intercalate " "+ [ uncurry moveA (vennps "corner1")+ , arcA + [ uncurry (Arc 1 1 0 False True) (vennps "circle1")+ , uncurry (Arc 1 1 0 False False) (vennps "circle3")+ , uncurry (Arc 1 1 0 False True) (vennps "corner1")+ ]+ , "Z"+ ]++midseg2 :: Text+midseg2 = Text.intercalate " "+ [ uncurry moveA (vennps "circle1")+ , arcA + [ uncurry (Arc 1 1 0 False True) (vennps "corner2")+ , uncurry (Arc 1 1 0 False True) (vennps "circle2")+ , uncurry (Arc 1 1 0 False False) (vennps "circle1")+ ]+ , "Z"+ ]++midseg3 :: Text+midseg3 = Text.intercalate " "+ [ uncurry moveA (vennps "circle2")+ , arcA + [ uncurry (Arc 1 1 0 False True) (vennps "corner3")+ , uncurry (Arc 1 1 0 False True) (vennps "circle3")+ , uncurry (Arc 1 1 0 False False) (vennps "circle2")+ ]+ , "Z"+ ]++vennGlyphs :: [Text]+vennGlyphs = [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3, innerseg]++seg :: Text -> PixelRGB8 -> Double -> GlyphStyle+seg p c o = defaultGlyphStyle & set #shape (PathGlyph p) & set #color c & set #borderColor white & set #borderSize 0.06 & set #borderOpacity 1 & set #opacity o++venns :: [Chart Double]+venns = zipWith (\p c -> Chart (GlyphA $ seg p c 0.8) [SP 0.0 0.0]) vennGlyphs chartPalette++phrases :: [Chart Double]+phrases = phraseChart <$> mainPhrases++data Phrase =+ Phrase+ { phraseText :: Text+ , phrasePosition :: Point Double+ , phraseSize :: Double+ , phraseRotation :: Double+ , phraseColor :: PixelRGB8+ , phraseOpacity :: Double+ , phraseTag :: Text+ , phraseLevel :: Int+ } deriving (Eq, Show, Generic)++phraseChart :: Phrase -> Chart Double+phraseChart p = Chart (TextA a [view #phraseText p]) [SpotPoint (view #phrasePosition p)]+ where+ a =+ defaultTextStyle+ & set #size (view #phraseSize p)+ & set #rotation (Just $ view #phraseRotation p)+ & set #color (view #phraseColor p)+ & set #opacity (view #phraseOpacity p)++mainPhrases :: [Phrase]+mainPhrases =+ [ Phrase "Composable" (Point 0.9 0.7) 0.16 60 c 1 "composable" 1+ , Phrase "Functional" (Point 0 (-1)) 0.16 0 c 1 "functional" 1+ , Phrase "Open" (Point (-1) 0.55) 0.16 (-60) c 1 "open" 1+ , Phrase "Accurate" (Point 0.6 (-0.4)) 0.16 0 c 1 "accurate" 1+ , Phrase "Dynamic" (Point (-0.6) (-0.4)) 0.16 0 c 1 "dynamic" 1+ , Phrase "Modern" (Point 0 0.7) 0.16 0 c 1 "modern" 1+ , Phrase "chart-svg" (Point 0 0) 0.2 0 c 1 "chart-svg" 1+ ]+ where+ c = black++renderToSvgt :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> [(TextStyle, Text)] -> Svg ()+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))]++writeVennWords :: IO ()+writeVennWords = writeFile "other/venn2.svg" $ Lazy.toStrict $ prettyText $ renderToSvgt NoCssOptions (Point 300 300) (Rect (-2) 2 (-2) 2) (phrases <> venns <> [Chart BlankA [SR (-2.0) 2.0 (-2.0) 2.0]]) $ (defaultTextStyle & set #color white,) <$> (replicate 7 "" <> (phraseText <$> mainPhrases) <> [""])++writeVenn :: [PixelRGB8] -> Double -> IO ()+writeVenn cs o = writeChartsWith "other/venn.svg" (defaultSvgOptions & set #scaleCharts' NoScaleCharts & set #svgAspect ChartAspect & set #svgHeight 100) ([phraseChart (Phrase "λ" (Point 0 (-0.2)) 0.8 0 (PixelRGB8 27 1 72) 1 "chart-svg" 1)] <> (zipWith (\p c -> Chart (GlyphA $ seg p c o) [SP 0.0 0.0]) [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3] cs) <> [Chart BlankA [SR (-1.5) 1.5 (-1.5) 1.5]])++main :: IO ()+main = do+ writeVennWords+ writeVenn chartPalette 0.8
+ chart-svg.cabal view
@@ -0,0 +1,107 @@+cabal-version: >= 1.10+name: chart-svg+version: 0.0.1+synopsis: See readme.md+description: See readme.md for description.+category: project+homepage: https://github.com/tonyday567/chart-svg#readme+bug-reports: https://github.com/tonyday567/chart-svg/issues+author: Tony Day+maintainer: tonyday567@gmail.com+copyright: Tony Day (c) 2017+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ stack.yaml++source-repository head+ type: git+ location: https://github.com/tonyday567/chart-svg++library+ 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+ build-depends:+ JuicyPixels+ , attoparsec+ , base >=4.7 && <5+ , bifunctors+ , colour+ , palette+ , foldl+ , generic-lens+ , lucid+ , lucid-svg+ , lens+ , numhask-space+ , pretty-simple+ , protolude+ , scientific+ , tagsoup+ , text+ , text-format+ , time+ , transformers+ , web-rep+ default-language: Haskell2010++executable examples+ main-is: examples.hs+ hs-source-dirs:+ app+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , bifunctors+ , chart-svg+ , lens+ , javascript-bridge+ , numhask-space+ , protolude+ , scotty+ , text+ , transformers+ , unordered-containers+ , wai-middleware-static+ , web-rep+ default-language: Haskell2010++executable venn+ main-is: venn.hs+ hs-source-dirs:+ app+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , bifunctors+ , containers+ , chart-svg+ , generic-lens+ , lucid-svg+ , lens+ , javascript-bridge+ , numhask-space+ , protolude+ , scotty+ , text+ , transformers+ , unordered-containers+ , wai-middleware-static+ , web-rep+ default-language: Haskell2010+
+ src/Chart.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -Wall #-}++-- | A haskell Charting library targetting SVG+module Chart+ ( -- * Types+ -- $types+ module Chart.Types,+ module Chart.Color,+ module Chart.Core,+ module Chart.Svg,+ module Chart.Hud,+ module Chart.Format,+ module Chart.Page,+ module Chart.Render,+ module Chart.Bar,+ module Chart.Pixel,+ module NumHask.Space,+ PixelRGB8 (..),+ )+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 Codec.Picture.Types+import NumHask.Space++-- $types+-- There are some.
+ src/Chart/Bar.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++-- | bar charts+module Chart.Bar+ ( BarOptions (..),+ defaultBarOptions,+ BarData (..),+ barDataLowerUpper,+ barRange,+ bars,+ barChart,+ )+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.Space+import Prelude++-- | the usual bar chart eye-candy+data BarOptions+ = BarOptions+ { barRectStyles :: [RectStyle],+ barTextStyles :: [TextStyle],+ outerGap :: Double,+ innerGap :: Double,+ textGap :: Double,+ displayValues :: Bool,+ valueFormatN :: FormatN,+ accumulateValues :: Bool,+ orientation :: Orientation,+ barHudOptions :: HudOptions+ }+ deriving (Show, Eq, Generic)++defaultBarOptions :: BarOptions+defaultBarOptions =+ BarOptions+ gs+ ts+ 0.1+ 0+ 0.04+ True+ (FormatFixed 0)+ False+ Hori+ ( defaultHudOptions+ & #hudAxes+ .~ [ defaultAxisOptions+ & #atick . #ltick .~ Nothing,+ defaultAxisOptions & #place .~ PlaceLeft+ ]+ & #hudTitles .~ [defaultTitle "Default Bar Chart"]+ & #hudLegend+ .~ Just+ ( defaultLegendOptions+ & #lplace .~ PlaceRight+ & #lsize .~ 0.12+ & #vgap .~ 0.16+ & #hgap .~ 0.14+ & #ltext . #size .~ 0.16+ & #lscale .~ 0.33,+ []+ )+ )+ where+ gs = (\x -> RectStyle 0.002 grey 1 x 0.5) <$> chartPalette+ ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04 & #opacity .~ 0.5) <$> chartPalette++-- | imagine a data frame ...+data BarData+ = BarData+ { barData :: [[Double]],+ barRowLabels :: Maybe [Text],+ barColumnLabels :: Maybe [Text]+ }+ deriving (Show, Eq, Generic)++-- | Convert BarData to rectangles+barRects ::+ BarOptions ->+ [[Double]] ->+ [[Rect Double]]+barRects (BarOptions _ _ ogap igap _ _ _ add orient _) bs = rects'' orient+ where+ bs' = bool bs (appendZero bs) add+ rects'' Hori = rects'+ rects'' Vert = fmap (\(Rect x z y w) -> Rect y w x z) <$> rects'+ rects' = zipWith batSet [0 ..] (barDataLowerUpper add bs')+ batSet z ys =+ zipWith+ ( \x (yl, yh) ->+ abs+ ( Rect+ (x + (ogap / 2) + z * bstep)+ (x + (ogap / 2) + z * bstep + bstep - igap')+ yl+ yh+ )+ )+ [0 ..]+ ys+ n = fromIntegral (length bs')+ bstep = (1 - (1 + 1) * ogap + (n - 1) * igap') / n+ igap' = igap * (1 - (1 + 1) * ogap)++-- | convert data to a range assuming a zero bound+-- a very common but implicit assumption in a lot of bar charts+barDataLowerUpper :: Bool -> [[Double]] -> [[(Double, Double)]]+barDataLowerUpper add bs =+ case add of+ False -> fmap (0,) <$> bs+ True -> fmap (0,) <$> accRows bs++-- | calculate the Rect range of a bar data set.+barRange ::+ [[Double]] -> Rect Double+barRange [] = Rect 0 0 0 0+barRange ys'@(y : ys) = Rect 0 (fromIntegral $ maximum (length <$> ys')) (min 0 l) u+ where+ (Range l u) = sconcat $ space1 <$> (y NonEmpty.:| ys)++-- | A bar chart without hud trimmings.+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]]+ 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++appendZero :: [[Double]] -> [[Double]]+appendZero xs = (\x -> take (maxRows xs) (x <> repeat 0)) <$> xs++accRows :: [[Double]] -> [[Double]]+accRows xs = transpose $ drop 1 . scanl' (+) 0 <$> transpose xs++barTicks :: BarData -> TickStyle+barTicks bd+ | bd ^. #barData == [] = TickNone+ | isNothing (bd ^. #barRowLabels) =+ TickLabels $ pack . show <$> [1 .. maxRows (bd ^. #barData)]+ | otherwise =+ 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++barLegend :: BarData -> BarOptions -> [(Annotation, Text)]+barLegend bd bo+ | bd ^. #barData == [] = []+ | isNothing (bd ^. #barColumnLabels) = []+ | otherwise = zip (RectA <$> bo ^. #barRectStyles) $ take (length (bd ^. #barData)) $ fromMaybe [] (bd ^. #barColumnLabels) <> repeat ""++-- | 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),+ 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 =+ 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)+ bs' = appendZero bs+ (Rect _ _ y w) = barRange bs'++-- | Convert BarData to text+barTexts ::+ 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)+ 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')+ addX z y =+ zipWith+ ( \x y' ->+ Point+ (x + (ogap / 2) + z * bstep + bstep / 2 - igap' / 2)+ y'+ )+ [0 ..]+ y+ n = fromIntegral (length bs')+ bstep = (1 - (1 + 1) * ogap + (n - 1) * igap') / n+ igap' = igap * (1 - (1 + 1) * ogap)++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))
+ src/Chart/Color.hs view
@@ -0,0 +1,110 @@+{-# 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+ ( blue,+ grey,+ black,+ white,+ red,+ toColour,+ fromColour,+ d3Palette1,+ chartPalette,+ chartPalette2,+ blend,+ blend',+ toHex,+ fromHex,+ )+where++import Codec.Picture.Types+import qualified Data.Colour.Palette.ColorSet as C+import qualified Data.Colour.RGBSpace as C+import qualified Data.Colour.SRGB.Linear as C+import Data.Generics.Labels ()+import GHC.Exts+import Protolude+import Web.Page.Html+import Data.Attoparsec.Text hiding (take)++-- * color+-- | the official chart-unit blue+blue :: PixelRGB8+blue = PixelRGB8 93 165 218++-- | the official chart-unit grey+grey :: PixelRGB8+grey = PixelRGB8 102 102 102++-- | black+black :: PixelRGB8+black = PixelRGB8 0 0 0++-- | white+white :: PixelRGB8+white = PixelRGB8 255 255 255++-- | red+red :: PixelRGB8+red = PixelRGB8 255 0 0++-- | convert a 'PixelRGB8' to a 'Colour' representation.+toColour :: PixelRGB8 -> C.Colour Double+toColour (PixelRGB8 r g b) =+ C.rgb (fromIntegral r / 256.0) (fromIntegral g / 256.0) (fromIntegral b / 256.0)++-- | convert a 'Colour' to a 'PixelRGB8' representation.+fromColour :: C.Colour Double -> PixelRGB8+fromColour (C.toRGB -> C.RGB r g b) =+ PixelRGB8 (floor (256 * r)) (floor (256 * g)) (floor (256 * b))++-- | the d3 palette+d3Palette1 :: [PixelRGB8]+d3Palette1 = fromColour . C.d3Colors1 <$> [0 .. 9]++chartPalette :: [PixelRGB8]+chartPalette = rights $ parseOnly fromHex <$> ["#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e", "#31331c", "#454e56", "#94a7b5", "#ab7257"]++-- https://twitter.com/PalettesCinema/status/1221263628592009225/photo/1+chartPalette2 :: [PixelRGB8]+chartPalette2 = rights $ parseOnly fromHex <$> reverse ["#001114", "#042f1e", "#033d26", "#034243", "#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e"]+++-- | interpolate between 2 colors+blend :: Double -> PixelRGB8 -> PixelRGB8 -> PixelRGB8+blend c = mixWithAlpha f (f (0 :: Int))+ where+ f _ x0 x1 = fromIntegral (round (fromIntegral x0 + c * (fromIntegral x1 - fromIntegral x0)) :: Integer)++-- | interpolate between 2 alpha colors+blend' :: Double -> (PixelRGB8, Double) -> (PixelRGB8, Double) -> (PixelRGB8, Double)+blend' c (c0, o0) (c1, o1) = (blend c c0 c1, f' c o0 o1)+ where+ f' c' x0 x1 = x0 + c' * (x1 - x0)++{-+-- | convert from 'PixelRGB8' to #xxxxxx+toHex :: PixelRGB8 -> Text+toHex (PixelRGB8 r g b) =+ "#"+ <> justifyRight 2 '0' (toStrict $ toLazyText $ hex r)+ <> justifyRight 2 '0' (toStrict $ toLazyText $ hex g)+ <> justifyRight 2 '0' (toStrict $ toLazyText $ hex b)++-}
+ src/Chart/Core.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# 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.Types+import Chart.Svg (styleBox, styleBoxes)+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))
+ src/Chart/Examples.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++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++data Ex+ = Ex+ { excss :: SvgOptions,+ exhc :: HudOptions,+ exmaxcs :: Int,+ exanns :: [Annotation],+ exspots :: [[Spot Double]]+ }+ deriving (Eq, Show, Generic)++makeExample :: HudOptions -> [Chart Double] -> Ex+makeExample hs cs = Ex defaultSvgOptions hs (length cs) (view #annotation <$> cs) (fmap (fmap realToFrac) . view #spots <$> cs)++writeChartExample :: FilePath -> Ex -> IO ()+writeChartExample fp (Ex css' hc' _ anns' spots') =+ writeHudOptionsChart fp css' hc' [] (zipWith Chart anns' spots')++-- | minimal example+memptyExample :: Ex+memptyExample = Ex defaultSvgOptions mempty 1 [] []++-- | unit example+unitExample :: Ex+unitExample = Ex defaultSvgOptions mempty 1 [RectA defaultRectStyle] [[SpotRect unitRect]]++-- | hud example+hudExample :: Ex+hudExample = Ex defaultSvgOptions defaultHudOptions 1 [] []++-- | rect example+rectExample :: Ex+rectExample =+ Ex+ defaultSvgOptions+ (defaultHudOptions & set #hudAxes [defaultAxisOptions])+ 2+ (RectA <$> ropts)+ (fmap SpotRect <$> rss)++rss :: [[Rect Double]]+rss =+ [ gridR (\x -> exp (- (x ** 2) / 2)) (Range (-5) 5) 50,+ gridR (\x -> 0.5 * exp (- (x ** 2) / 8)) (Range (-5) 5) 50+ ]++ropts :: [RectStyle]+ropts = zipWith blob chartPalette [0.2, 0.7]++-- | line example+lineExample :: Ex+lineExample =+ Ex+ defaultSvgOptions+ ( exampleLineHudOptions+ "Line Chart"+ (Just "An example from chart-svg")+ (Just (legopts, zip (LineA <$> lopts) ["hockey", "line", "vertical"]))+ )+ 3+ (LineA <$> lopts)+ (fmap SpotPoint <$> ls)++ls :: [[Point Double]]+ls =+ fmap (uncurry Point)+ <$> [ [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)],+ [(0.0, 0.0), (2.8, 3.0)],+ [(0.5, 4.0), (0.5, 0)]+ ]++lopts :: [LineStyle]+lopts =+ [ defaultLineStyle & #color .~ PixelRGB8 197 130 75 & #width .~ 0.015+ & #opacity .~ 0.6,+ defaultLineStyle & #color .~ PixelRGB8 60 127 43 & #width .~ 0.03+ & #opacity .~ 0.6,+ defaultLineStyle & #color .~ PixelRGB8 52 41 137 & #width .~ 0.01+ & #opacity .~ 1.0+ ]++legopts :: LegendOptions+legopts =+ defaultLegendOptions+ & #lsize .~ 0.2+ & #ltext . #size .~ 0.25+ & #innerPad .~ 0.05+ & #lscale .~ 0.25+ & #lplace .~ PlaceAbsolute (Point 0.5 (-0.3))++exampleLineHudOptions :: Text -> Maybe Text -> Maybe (LegendOptions, [(Annotation, Text)]) -> HudOptions+exampleLineHudOptions t1 t2 legends' =+ defaultHudOptions+ & #hudTitles+ .~ ( [ defaultTitle t1+ & #style . #size .~ 0.08+ & #style . #opacity .~ 0.6+ ]+ <> maybe+ []+ ( \x ->+ [ defaultTitle x+ & #style . #size .~ 0.05+ & #style . #opacity .~ 0.6+ & #place .~ PlaceBottom+ & #anchor .~ AnchorEnd+ ]+ )+ t2+ )+ & #hudLegend .~ legends'++-- | text example+textExample :: Ex+textExample =+ Ex+ defaultSvgOptions+ defaultHudOptions+ 26+ (TextA (defaultTextStyle & (#size .~ (0.05 :: Double))) . (: []) . fst <$> ts)+ ((: []) . SpotPoint . snd <$> ts)+ where+ ts :: [(Text.Text, Point Double)]+ ts =+ zip+ (fmap Text.singleton ['a' .. 'y'])+ [Point (sin (x * 0.1)) x | x <- [0 .. 25]]++-- | glyph example+glyphExample :: Ex+glyphExample = makeExample mempty glyphs++glyphs :: [Chart Double]+glyphs =+ zipWith+ ( \(sh, bs) p ->+ Chart+ ( GlyphA+ ( defaultGlyphStyle+ & #size .~ (0.1 :: Double)+ & #borderSize .~ bs+ & #shape .~ sh+ )+ )+ [p]+ )+ [ (CircleGlyph, 0.01 :: Double),+ (SquareGlyph, 0.01),+ (RectSharpGlyph 0.75, 0.01),+ (RectRoundedGlyph 0.75 0.01 0.01, 0.01),+ (EllipseGlyph 0.75, 0),+ (VLineGlyph, 0.01),+ (HLineGlyph, 0.01),+ (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01),+ (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01)+ ]+ [SP 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]))++barExample :: Ex+barExample = makeExample hc cs+ where+ (hc, cs) = barChart defaultBarOptions barDataExample++-- | pixel example+pixelEx :: ([Chart Double], [Hud Double])+pixelEx = pixelfl f1 (defaultPixelOptions & #poGrain .~ Point 100 100 & #poRange .~ Rect 1 2 1 2) (defaultPixelLegendOptions "pixel test")++f1 :: (Floating a) => Point a -> a+f1 (Point x y) = sin (cos (tan x)) * sin (cos (tan y))++-- * stuff++boundTextBug :: [Chart Double]+boundTextBug =+ [ t1,+ t2,+ Chart BlankA [SpotRect (Rect 0 0.1 (-0.5) 0.5)],+ Chart (RectA defaultRectStyle) [SpotRect (defRectS $ styleBox t1)],+ Chart (RectA defaultRectStyle) [SpotRect (defRectS $ styleBox t2)]+ ]+ where+ t1 =+ Chart+ ( TextA+ (defaultTextStyle & #anchor .~ AnchorStart & #hsize .~ 0.45 & #size .~ 0.08)+ ["a pretty long piece of text"]+ )+ [SP 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]+++-- | compound chart+gopts3 :: [GlyphStyle]+gopts3 =+ zipWith+ ( \x y ->+ (#color .~ x)+ . (#borderColor .~ x)+ . (#borderSize .~ 0.005)+ . (#shape .~ y)+ . (#size .~ 0.08)+ $ defaultGlyphStyle+ )+ [ PixelRGB8 120 67 30,+ PixelRGB8 30 48 130,+ PixelRGB8 60 60 60+ ]+ [EllipseGlyph 1.5, SquareGlyph, CircleGlyph]++glines :: [Chart Double]+glines = cs <> gs+ where+ 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 =+ (\p@(Point x y) -> (Text.pack (show x <> "," <> show y), fromIntegral <$> p))+ <$> (Point <$> [0 .. 5] <*> [0 .. 5] :: [Point Int])++lglyph :: [Chart Double]+lglyph = txt <> gly+ where+ txt =+ ( \(t, p) ->+ Chart+ ( TextA+ ( defaultTextStyle+ & #opacity .~ 0.2+ & #translate ?~ Point 0 0.04+ )+ [t]+ )+ (SpotPoint <$> [p])+ )+ <$> lgdata+ gly =+ ( \d ->+ Chart+ ( GlyphA+ ( defaultGlyphStyle+ & #size .~ 0.01+ & #borderSize .~ 0+ & #color .~ black+ )+ )+ (SpotPoint <$> [d])+ )+ <$> (snd <$> lgdata)++-- | label example+labelExample :: Ex+labelExample =+ Ex+ defaultSvgOptions+ defaultHudOptions+ 1+ (annotation <$> label)+ (spots <$> label)++placedLabel :: (Chartable a) => Point a -> a -> Text.Text -> Chart a+placedLabel p d t =+ Chart ( TextA ( defaultTextStyle & #rotation ?~ realToFrac d ) [t] ) [SpotPoint p]++label :: [Chart Double]+label =+ [placedLabel (Point (1.0 :: Double) 1.0) (45.0 :: Double) "text at (1,1) rotated by 45 degrees"]++-- | legend test+legendTest :: HudOptions+legendTest =+ defaultHudOptions+ & #hudLegend+ .~ Just+ ( defaultLegendOptions+ & #lscale .~ 0.3+ & #lplace .~ PlaceAbsolute (Point 0.0 0.0)+ & #lsize .~ 0.12+ & #ltext . #size .~ 0.16,+ l1+ )+ where+ l1 =+ [ (GlyphA defaultGlyphStyle, "glyph"),+ (RectA defaultRectStyle, "rect"),+ (TextA (defaultTextStyle & #anchor .~ AnchorStart) ["content"], "text"),+ (LineA defaultLineStyle, "line"),+ (GlyphA defaultGlyphStyle, "abcdefghijklmnopqrst"),+ (BlankA, "blank")+ ]++-- | main example+mainExample :: Ex+mainExample =+ makeExample+ defaultHudOptions+ [Chart (GlyphA defaultGlyphStyle) (SpotPoint <$> gridP sin (Range 0 (2 * pi)) 30)]++writeAllExamples :: IO ()+writeAllExamples = do+ -- 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)
+ src/Chart/Format.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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
+ src/Chart/Hud.hs view
@@ -0,0 +1,630 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}++-- | 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.Text (Text)+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))+
+ src/Chart/Page.hs view
@@ -0,0 +1,1172 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Chart.Page+ ( chartStyler,+ repChartStaticData,+ repAnnotation,+ repRectStyle,+ repTextStyle,+ repGlyphStyle,+ repLineStyle,+ repPlace,+ repAnchor,+ repBar,+ repAdjustments,+ repTitle,+ repHudOptions,+ repAxisOptions,+ repSvgOptions,+ repData,+ repFormatN,+ repTickStyle,+ repTick,+ repPoint,+ repPointI,+ repRect,+ repRectOne,+ repRounded,+ repTriple,+ repGlyphShape,+ repChoice,+ repLegendOptions,+ repChartsWithSharedData,+ repChartsWithStaticData,+ debugHtml,+ debugFlags,+ repHudOptionsDefault,+ repBarOptions,+ repBarData,+ repBarChart,+ repPixelOptions,+ repPixelLegendOptions,+ repPixelChart,+ )+where++import Chart.Bar+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.Space+import Web.Page hiding (bool)+import Text.Pretty.Simple (pShowNoColor)+import Protolude hiding ((<<*>>))++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)+ pure $ Chart ann (c ^. #spots)++repAnnotation :: (Monad m) => Annotation -> SharedRep m Annotation+repAnnotation initann = bimap hmap mmap rann <<*>> rs <<*>> ts <<*>> gs <<*>> ls <<*>> ps+ where+ rann =+ dropdownSum+ takeText+ id+ (Just "Chart Annotation")+ ["RectA", "TextA", "GlyphA", "LineA", "BlankA", "PixelA"]+ (annotationText initann)+ rs = repRectStyle defRectStyle+ ts = repTextStyle defText+ gs = repGlyphStyle defGlyph+ ls = repLineStyle defLine+ ps = repPixelStyle defPixel+ hmap ann rs ts gs ls ps =+ ann+ <> subtype rs (annotationText initann) "RectA"+ <> subtype ts (annotationText initann) "TextA"+ <> subtype gs (annotationText initann) "GlyphA"+ <> subtype ls (annotationText initann) "LineA"+ <> subtype ps (annotationText initann) "PixelA"+ mmap ann rs ts gs ls ps =+ case ann of+ "RectA" -> RectA rs+ "TextA" -> TextA ts texts+ "GlyphA" -> GlyphA gs+ "LineA" -> LineA ls+ "BlankA" -> BlankA+ "PixelA" -> PixelA ps+ _ -> BlankA+ defRectStyle = case initann of+ RectA s -> s+ _ -> defaultRectStyle+ defPixel = case initann of+ PixelA s -> s+ _ -> defaultPixelStyle+ (defText, texts) = case initann of+ TextA s xs -> (s, xs)+ _ -> (defaultTextStyle, Text.singleton <$> ['a' .. 'z'])+ defGlyph = case initann of+ GlyphA s -> s+ _ -> defaultGlyphStyle+ defLine = case initann of+ LineA s -> s+ _ -> defaultLineStyle++repRectStyle :: (Monad m) => RectStyle -> SharedRep m RectStyle+repRectStyle s = do+ bs <- slider (Just "border size") 0.0 0.1 0.001 (s ^. #borderSize)+ bc <- colorPicker (Just "border color") (s ^. #borderColor)+ bo <- slider (Just "border opacity") 0 1 0.1 (s ^. #borderOpacity)+ c <- colorPicker (Just "color") (s ^. #color)+ o <- slider (Just "opacity") 0 1 0.1 (s ^. #opacity)+ pure $ RectStyle bs bc bo c o++repPixelStyle ::+ (Monad m) =>+ PixelStyle ->+ SharedRep m PixelStyle+repPixelStyle cfg =+ bimap hmap PixelStyle pcmin+ <<*>> pomin+ <<*>> pcmax+ <<*>> pomax+ <<*>> pd+ <<*>> prs+ <<*>> pt+ where+ pcmax = colorPicker (Just "high color") (cfg ^. #pixelColorMax)+ pcmin = colorPicker (Just "low color") (cfg ^. #pixelColorMin)+ pomax = slider (Just "high opacity") 0.0 1.0 0.001 (cfg ^. #pixelOpacityMax)+ pomin = slider (Just "low opacity") 0.0 1.0 0.001 (cfg ^. #pixelOpacityMin)+ pd = slider (Just "gradient direction") 0.0 (2 * pi) 0.001 (cfg ^. #pixelGradient)+ prs = repRectStyle (cfg ^. #pixelRectStyle)+ pt = textbox (Just "texture id") (cfg ^. #pixelTextureId)+ hmap pcmin' pomin' pcmax' pomax' pd' prs' pt' =+ pcmin' <> pomin' <> pcmax' <> pomax' <> pd' <> prs' <> pt'++repGlyphStyle :: (Monad m) => GlyphStyle -> SharedRep m GlyphStyle+repGlyphStyle gs = first (\x -> cardify (mempty, [style_ "width: 10 rem;"]) Nothing (x, [])) $ do+ sh <- repGlyphShape (gs ^. #shape)+ sz <- slider (Just "Size") 0 0.2 0.001 (gs ^. #size)+ gc <-+ colorPicker+ (Just "Color")+ (gs ^. #color)+ go <- slider (Just "Opacity") 0 1 0.1 (gs ^. #opacity)+ bsz <- slider (Just "Border Size") 0 0.02 0.001 (gs ^. #borderSize)+ gbc <- colorPicker (Just "Border Color") (gs ^. #borderColor)+ gbo <- slider (Just "Border Opacity") 0 1 0.1 (gs ^. #borderOpacity)+ tr <-+ maybeRep+ (Just "rotation")+ (isJust (gs ^. #rotation))+ (slider (Just "rotation") (-180) 180 10 (fromMaybe 0 (gs ^. #rotation)))+ tt <-+ maybeRep+ (Just "translate")+ (isJust (gs ^. #translate))+ ( repPoint+ (Point (Range 0 1) (Range 0 1))+ (Point 0.001 0.001)+ (Point 0 0)+ )+ pure (GlyphStyle sz gc go 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)+ tc <- colorPicker (Just "color") (s ^. #color)+ to' <- slider (Just "opacity") 0 1 0.1 (s ^. #opacity)+ ta <- repAnchor (s ^. #anchor)+ th <- slider (Just "hsize") 0.2 1 0.05 (s ^. #hsize)+ tv <- slider (Just "vsize") 0.5 2 0.05 (s ^. #vsize)+ tn <- slider (Just "nudge1") (-0.5) 0.5 0.05 (s ^. #nudge1)+ tr <-+ maybeRep+ (Just "rotation")+ (isJust (s ^. #rotation))+ (slider (Just "rotation") (-180) 180 10 (fromMaybe 0 (s ^. #rotation)))+ tt <-+ maybeRep+ (Just "translate")+ (isJust (s ^. #translate))+ ( repPoint+ (Point (Range 0 1) (Range 0 1))+ (Point 0.001 0.001)+ (Point 0 0)+ )+ tm <- checkbox (Just "mathjax") (s ^. #hasMathjax)+ pure $ TextStyle ts 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") (s ^. #color)+ o <- slider (Just "opacity") 0 1 0.1 (s ^. #opacity)+ pure $ LineStyle w c o++repPlace :: (Monad m) => Place -> SharedRep m Place+repPlace initpl = bimap hmap mmap rplace <<*>> rp+ where+ rplace =+ dropdownSum+ takeText+ id+ (Just "Placement")+ [ "Bottom",+ "Left",+ "Top",+ "Right",+ "Absolute"+ ]+ (placeText initpl)+ rp = repPoint (Point (Range 0 1) (Range 0 1)) (Point 0.01 0.01) (defPoint initpl)+ defPoint pl = case pl of+ PlaceAbsolute p -> p+ _ -> Point 0.0 0.0+ hmap rplace rp =+ div_+ ( rplace+ <> subtype rp (placeText initpl) "Absolute"+ )+ mmap rplace rp = case rplace of+ "Top" -> PlaceTop+ "Bottom" -> PlaceBottom+ "Left" -> PlaceLeft+ "Right" -> PlaceRight+ "Absolute" -> PlaceAbsolute rp+ _ -> PlaceBottom++repAnchor :: (Monad m) => Anchor -> SharedRep m Anchor+repAnchor a =+ toAnchor+ <$> dropdown+ takeText+ id+ (Just "Anchor")+ (fromAnchor <$> [AnchorStart, AnchorMiddle, AnchorEnd])+ (fromAnchor a)++repOrientation :: (Monad m) => Orientation -> SharedRep m Orientation+repOrientation a =+ toOrientation+ <$> dropdown+ takeText+ id+ (Just "Orientation")+ (fromOrientation <$> [Vert, Hori])+ (fromOrientation 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)+ pure $ Bar r w b++repAdjustments :: (Monad m) => Adjustments -> SharedRep m Adjustments+repAdjustments a = do+ maxx <- slider (Just "maximum x ratio") 0.000 0.2 0.001 (a ^. #maxXRatio)+ maxy <- slider (Just "maximum y ratio") 0.000 0.2 0.001 (a ^. #maxYRatio)+ angle <- slider (Just "angle ratio") 0.000 1 0.001 (a ^. #angledRatio)+ diag <- checkbox (Just "allow diagonal text") (a ^. #allowDiagonal)+ pure $ Adjustments maxx maxy angle diag++repTitle :: (Monad m) => Title -> SharedRep m Title+repTitle cfg = do+ ttext <- textbox (Just "text") (cfg ^. #text)+ ts <- repTextStyle (cfg ^. #style)+ tp <- repPlace (cfg ^. #place)+ ta <- repAnchor (cfg ^. #anchor)+ b <- slider (Just "buffer") 0 0.2 0.01 (cfg ^. #buff)+ pure $ Title ttext ts tp ta b++repHudOptions ::+ (Monad m) =>+ Int ->+ Int ->+ Int ->+ AxisOptions ->+ Title ->+ LegendOptions ->+ [(Annotation, Text)] ->+ Annotation ->+ Text ->+ HudOptions ->+ SharedRep m HudOptions+repHudOptions naxes ntitles nlegendRows defaxis deftitle deflegend deflrs defann deflabel cfg =+ bimap hmap (\a b c d -> HudOptions a b c d) can+ <<*>> ts+ <<*>> axs+ <<*>> l+ where+ can =+ maybeRep (Just "canvas") (isJust (cfg ^. #hudCanvas)) $+ repRectStyle (fromMaybe defaultCanvas (cfg ^. #hudCanvas))+ ts =+ listRep+ (Just "titles")+ "tz"+ (checkbox Nothing)+ repTitle+ ntitles+ deftitle+ (cfg ^. #hudTitles)+ axs =+ listRep+ (Just "axes")+ "axz"+ (checkbox Nothing)+ repAxisOptions+ naxes+ defaxis+ (cfg ^. #hudAxes)+ labelsc =+ listRep+ (Just "labelsc")+ "labelscz"+ (checkbox Nothing)+ (textbox Nothing)+ nlegendRows+ deflabel+ (snd <$> deflrs)+ anns =+ listRep+ (Just "annotations")+ "annsz"+ (checkbox Nothing)+ repAnnotation+ nlegendRows+ defann+ (fst <$> deflrs)+ l =+ maybeRep+ (Just "legend")+ (isJust $ cfg ^. #hudLegend)+ ( (,)+ <$> repLegendOptions (maybe deflegend fst (cfg ^. #hudLegend))+ <*> (zip <$> anns <*> labelsc)+ )+ hmap can' ts' axs' l' =+ accordion_+ "accc"+ Nothing+ [ ("Axes", axs'),+ ("Canvas", can'),+ ("Titles", ts'),+ ("Legend", l')+ ]++repAxisOptions :: (Monad m) => AxisOptions -> SharedRep m AxisOptions+repAxisOptions cfg = bimap hmap AxisOptions b <<*>> adj <<*>> t <<*>> p+ where+ b =+ maybeRep+ (Just "axis bar")+ (isJust (cfg ^. #abar))+ (repBar (fromMaybe defaultBar (cfg ^. #abar)))+ adj =+ maybeRep+ (Just "adjustments")+ (isJust (cfg ^. #adjust))+ (repAdjustments (fromMaybe defaultAdjustments (cfg ^. #adjust)))+ t = repTick (cfg ^. #atick)+ p = repPlace (cfg ^. #place)+ hmap b' hauto' t' p' =+ accordion_+ "accaxis"+ Nothing+ [ ("Bar", b'),+ ("Auto", hauto'),+ ("Ticks", t'),+ ("Place", p')+ ]++repSvgAspect :: (Monad m) => SvgAspect -> Double -> SharedRep m SvgAspect+repSvgAspect sa ddef =+ bimap hmap toSvgAspect sa' <<*>> td+ where+ sa' =+ dropdownSum+ takeText+ id+ (Just "Aspect")+ [ "ManualAspect",+ "ChartsAspect"+ ]+ (fromSvgAspect sa)+ td = slider (Just "aspect scale") 0 10 0.01 (defD ddef)+ defD d' = case sa of+ ManualAspect d -> d+ ChartAspect -> d'+ hmap sa'' td' =+ div_+ ( sa''+ <> subtype td' (fromSvgAspect sa) "ManualAspect"+ )++repSvgOptions :: (Monad m) => SvgOptions -> SharedRep m SvgOptions+repSvgOptions s =+ bimap+ hmap+ SvgOptions+ h'+ <<*>> op'+ <<*>> ip+ <<*>> fr+ <<*>> esc+ <<*>> csso+ <<*>> scalec+ <<*>> svga+ where+ svga = repSvgAspect (s ^. #svgAspect) 1.33+ h' = slider (Just "height") 1 1000 1 (s ^. #svgHeight)+ op' =+ maybeRep+ (Just "outer pad")+ (isJust (s ^. #outerPad))+ (slider Nothing 1 1.2 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)))+ fr =+ maybeRep+ (Just "frame")+ (isJust (s ^. #chartFrame))+ (repRectStyle (fromMaybe defaultSvgFrame (s ^. #chartFrame)))+ esc =+ bool NoEscapeText EscapeText+ <$> checkbox (Just "escape text") (EscapeText == s ^. #escapeText)+ csso =+ bool NoCssOptions UseCssCrisp+ <$> checkbox (Just "Use CssCrisp") (UseCssCrisp == s ^. #useCssCrisp)+ scalec =+ bool NoScaleCharts ScaleCharts+ <$> checkbox (Just "Scale Charts") (ScaleCharts == s ^. #scaleCharts')+ hmap h' op'' ip' fr' esc' csso' scalec' svga' =+ accordion_+ "accsvg"+ Nothing+ [ ("Aspect", svga' <> h'),+ ("Padding", op'' <> ip'),+ ("Frame", fr'),+ ("Escape", esc'),+ ("Css", csso'),+ ("Scale", scalec')+ ]++repData :: (Monad m) => Text -> SharedRep m [Spot Double]+repData d = do+ a <-+ dropdown+ takeText+ id+ (Just "type")+ [ "sin",+ "line",+ "one",+ "dist"+ ]+ d+ pure+ ( case a of+ "sin" -> SpotPoint <$> gridP sin (Range 0 (2 * pi)) 30+ "line" ->+ SpotPoint . uncurry Point+ <$> [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)]+ "one" -> [SR 0 1 0 1]+ "dist" -> SpotRect <$> gridR (\x -> exp (- (x ** 2) / 2)) (Range (-5) 5) 50+ _ -> SpotPoint <$> gridP sin (Range 0 (2 * pi)) 30+ )++repFormatN :: (Monad m) => FormatN -> SharedRep m FormatN+repFormatN tf = bimap hmap mmap tformat <<*>> tcommas <<*>> tfixed <<*>> texpt <<*>> tpercent+ where+ tformat =+ dropdownSum+ takeText+ id+ (Just "Format")+ [ "Comma",+ "Fixed",+ "Expt",+ "Dollar",+ "Percent",+ "None"+ ]+ (fromFormatN tf)+ tcommas = sliderI (Just "prec") 0 8 1 (defInt tf)+ tfixed = sliderI (Just "prec") 0 8 1 (defInt tf)+ texpt = sliderI (Just "prec") 0 8 1 (defInt tf)+ tpercent = sliderI (Just "prec") 0 8 1 (defInt tf)+ defInt tf' = case tf' of+ FormatComma n -> n+ FormatFixed n -> n+ _ -> 3+ hmap tformat' tcommas' tfixed' texpt' tpercent' =+ div_+ ( tformat'+ <> subtype tcommas' (fromFormatN tf) "Comma"+ <> subtype tfixed' (fromFormatN tf) "Fixed"+ <> subtype texpt' (fromFormatN tf) "Expt"+ <> subtype tpercent' (fromFormatN tf) "Percent"+ )+ mmap tformat' tcommas' tfixed' texpt' tpercent' = case tformat' of+ "Comma" -> FormatComma tcommas'+ "Fixed" -> FormatFixed tfixed'+ "Expt" -> FormatExpt texpt'+ "Dollar" -> FormatDollar+ "Percent" -> FormatPercent tpercent'+ "None" -> FormatNone+ _ -> FormatNone++repTickStyle :: (Monad m) => TickStyle -> SharedRep m TickStyle+repTickStyle cfg =+ bimap hmap mmap ts <<*>> ls <<*>> tr <<*>> te <<*>> tplaced+ where+ ts =+ dropdownSum+ takeText+ id+ (Just "Tick Style")+ ["TickNone", "TickLabels", "TickRound", "TickExact", "TickPlaced"]+ (tickStyleText cfg)+ ls =+ accordionList+ (Just "tick labels")+ "tick-style-labels"+ Nothing+ (textbox . Just)+ (defaultListLabels (length defLabels))+ defLabels+ tr =+ (,,)+ <$> sliderI (Just "Number of ticks") 0 20 1 defTn+ <*> repFormatN defTf+ <*> ( bool NoTickExtend TickExtend+ <$> checkbox (Just "extend") defExtend+ )+ te =+ (,)+ <$> sliderI (Just "Number of ticks") 0 20 1 defTn+ <*> repFormatN defTf+ tplaced =+ accordionList+ (Just "placed ticks")+ "tick-style-placed"+ Nothing+ dt+ (defaultListLabels (length dtDef))+ dtDef+ hmap ts' ls' tr' te' tplaced' =+ div_+ ( ts'+ <> subtype ls' (tickStyleText cfg) "TickLabels"+ <> subtype tr' (tickStyleText cfg) "TickRound"+ <> subtype te' (tickStyleText cfg) "TickExact"+ <> subtype tplaced' (tickStyleText cfg) "TickPlaced"+ )+ mmap ts' ls' (tri, trf, tre) (tei, tef) tplaced' = case ts' of+ "TickNone" -> TickNone+ "TickLabels" -> TickLabels ls'+ "TickRound" -> TickRound trf tri tre+ "TickExact" -> TickExact tef tei+ "TickPlaced" -> TickPlaced tplaced'+ _ -> TickNone+ dtDef = case cfg of+ TickPlaced x -> x+ _ -> zip [0 .. 5] (Text.pack . show <$> [0 .. 5 :: Int])+ dt _ (x, l) = (,) <$> slider (Just "placement") 0 1 0.01 x <*> textbox (Just "label") l+ defLabels = case cfg of+ TickLabels xs -> xs+ _ -> replicate 5 ""+ defTn = case cfg of+ TickRound _ x _ -> x+ TickExact _ x -> x+ _ -> 8+ defTf = case cfg of+ TickRound x _ _ -> x+ TickExact x _ -> x+ _ -> FormatComma 2+ defExtend = case cfg of+ 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)+ where+ hmap ts' gt' tt' lt' =+ accordion+ "acctick"+ Nothing+ [ ("style", ts'),+ ("glyph", gt'),+ ("text", tt'),+ ("line", lt')+ ]+ ts = repTickStyle (cfg ^. #tstyle)+ gt =+ maybeRep Nothing (isJust (cfg ^. #gtick)) $+ bimap+ (<>)+ (,)+ (repGlyphStyle (maybe defaultGlyphTick fst (cfg ^. #gtick)))+ <<*>> slider (Just "buffer") 0 0.05 0.001 (maybe 0.05 snd (cfg ^. #gtick))+ tt =+ maybeRep Nothing (isJust (cfg ^. #ttick)) $+ bimap+ (<>)+ (,)+ (repTextStyle (maybe defaultTextTick fst (cfg ^. #ttick)))+ <<*>> slider (Just "buffer") 0 0.05 0.001 (maybe 0.05 snd (cfg ^. #ttick))+ lt =+ maybeRep Nothing (isJust (cfg ^. #ltick)) $+ bimap+ (<>)+ (,)+ (repLineStyle (maybe defaultLineTick fst (cfg ^. #ltick)))+ <<*>> slider (Just "buffer") (-0.1) 0.1 0.001 (maybe 0 snd (cfg ^. #ltick))++repPoint ::+ (Monad m) =>+ Point (Range Double) ->+ Point Double ->+ Point Double ->+ SharedRep m (Point Double)+repPoint (Point (Range xmin xmax) (Range ymin ymax)) (Point xstep ystep) (Point x y) =+ bimap+ (<>)+ Point+ (slider (Just "x") xmin xmax xstep x)+ <<*>> slider (Just "y") ymin ymax ystep y++repPointI ::+ (Monad m) =>+ Point (Range Int) ->+ Point Int ->+ Point Int ->+ SharedRep m (Point Int)+repPointI (Point (Range xmin xmax) (Range ymin ymax)) (Point xstep ystep) (Point x y) =+ bimap+ (<>)+ Point+ (sliderI (Just "x") xmin xmax xstep x)+ <<*>> sliderI (Just "y") ymin ymax ystep y++repRect :: (Monad m) => Rect (Range Double) -> Rect Double -> Rect Double -> SharedRep m (Rect Double)+repRect (Rect (Range xmin xmax) (Range zmin zmax) (Range ymin ymax) (Range wmin wmax)) (Rect xstep zstep ystep wstep) (Rect x z y w) =+ bimap+ (\a b c d -> a <> b <> c <> d)+ Rect+ (slider (Just "x") xmin xmax xstep x)+ <<*>> slider (Just "z") zmin zmax zstep z+ <<*>> slider (Just "y") ymin ymax ystep y+ <<*>> slider (Just "w") wmin wmax wstep w++repRectOne :: (Monad m) => Rect Double -> SharedRep m (Rect Double)+repRectOne a = repRect (Rect (Range 0 1) (Range 0 1) (Range 0 1) (Range 0 1)) (Rect 0.01 0.01 0.01 0.01) a++repRounded :: (Monad m) => (Double, Double, Double) -> SharedRep m (Double, Double, Double)+repRounded (a, b, c) =+ bimap+ (\a' b' c' -> a' <> b' <> c')+ (,,)+ (slider Nothing 0 1 0.001 a)+ <<*>> slider Nothing 0 1 0.001 b+ <<*>> slider Nothing 0 1 0.001 c++repTriple :: (Monad m) => (a, a, a) -> (a -> SharedRep m a) -> SharedRep m (a, a, a)+repTriple (a, b, c) sr =+ bimap (\a' b' c' -> a' <> b' <> c') (,,) (sr a) <<*>> sr b <<*>> sr c++repGlyphShape :: (Monad m) => GlyphShape -> SharedRep m GlyphShape+repGlyphShape sh = bimap hmap mmap sha <<*>> ell <<*>> rsharp <<*>> rround <<*>> tri <<*>> p+ where+ sha =+ dropdownSum+ takeText+ id+ Nothing+ [ "Circle",+ "Square",+ "Triangle",+ "Ellipse",+ "RectSharp",+ "RectRounded",+ "VLine",+ "HLine",+ "Path"+ ]+ (glyphText sh)+ ell = slider Nothing 0.5 2 0.01 defRatio+ rsharp = slider Nothing 0.5 2 0.01 defRatio+ rround = repRounded defRounded+ tri =+ repTriple+ defTriangle+ ( repPoint+ (Point (Range 0 1) (Range 0 1))+ (Point 0.001 0.001)+ )+ p = textbox (Just "path") defP+ hmap sha' ell' rsharp' rround' tri' p' =+ sha'+ <> subtype ell' (glyphText sh) "Ellipse"+ <> subtype rsharp' (glyphText sh) "RectSharp"+ <> subtype rround' (glyphText sh) "RectRounded"+ <> subtype tri' (glyphText sh) "Triangle"+ <> subtype p' (glyphText sh) "Path"+ mmap sha' ell' rsharp' rround' tri' p' =+ case sha' of+ "Circle" -> CircleGlyph+ "Square" -> SquareGlyph+ "Ellipse" -> EllipseGlyph ell'+ "RectSharp" -> RectSharpGlyph rsharp'+ "RectRounded" -> (\(a, b, c) -> RectRoundedGlyph a b c) rround'+ "Triangle" -> (\(a, b, c) -> TriangleGlyph a b c) tri'+ "VLine" -> VLineGlyph+ "HLine" -> HLineGlyph+ "Path" -> PathGlyph p'+ _ -> CircleGlyph+ defP = case sh of+ PathGlyph p -> p+ _ -> mempty+ defRatio = case sh of+ EllipseGlyph r -> r+ RectSharpGlyph r -> r+ _ -> 1.5+ defRounded = case sh of+ RectRoundedGlyph a b c -> (a, b, c)+ _ -> (0.884, 2.7e-2, 5.0e-2)+ defTriangle = case sh of+ TriangleGlyph a b c -> (a, b, c)+ _ -> (Point 0.0 0.0, Point 1 1, Point 1 0)++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+ hmap+ LegendOptions+ lsize'+ <<*>> vgap'+ <<*>> hgap'+ <<*>> ltext'+ <<*>> lmax'+ <<*>> innerPad'+ <<*>> outerPad'+ <<*>> legendFrame'+ <<*>> lplace'+ <<*>> scale'+ where+ lsize' = slider (Just "element size") 0.000 1 0.001 (initl ^. #lsize)+ hgap' = slider (Just "horizontal gap") 0.000 0.5 0.001 (initl ^. #hgap)+ vgap' = slider (Just "vertical gap") 0.000 0.5 0.001 (initl ^. #vgap)+ ltext' = repTextStyle (initl ^. #ltext)+ lmax' = sliderI (Just "max entries") 0 10 1 (initl ^. #lmax)+ innerPad' =+ slider+ (Just "inner padding")+ 0+ 0.2+ 0.001+ (initl ^. #innerPad)+ outerPad' =+ slider+ (Just "outer padding")+ 0+ 0.2+ 0.001+ (initl ^. #outerPad)+ legendFrame' =+ maybeRep+ (Just "frame")+ (isJust (initl ^. #legendFrame))+ (repRectStyle (fromMaybe defaultSvgFrame (initl ^. #legendFrame)))+ lplace' = repPlace (initl ^. #lplace)+ scale' = slider (Just "scale") 0.01 1 0.001 (initl ^. #lscale)+ hmap lsize'' vgap'' hgap'' ltext'' lmax'' innerPad'' outerPad'' legendFrame'' lplace'' scale'' =+ accordion_+ "accleg"+ Nothing+ [ ("Scale", scale'' <> lsize''),+ ("Pads", innerPad'' <> outerPad'' <> vgap'' <> hgap''),+ ("Text", ltext''),+ ("Frame", legendFrame''),+ ("Place", lplace''),+ ("Max Elements", lmax'')+ ]++repChartsWithSharedData ::+ (Monad m) =>+ SvgOptions ->+ HudOptions ->+ Int ->+ [Chart Double] ->+ ([[Spot Double]] -> SharedRep m [[Spot Double]]) ->+ SharedRep m (Text, Text)+repChartsWithSharedData css' hc' maxcs' cs' sspots =+ bimap+ hmap+ mmap+ cssr+ <<*>> annsr+ <<*>> sspots spots'+ <<*>> hr+ <<*>> debugFlags+ where+ spots' = view #spots <$> cs'+ anns' = view #annotation <$> cs'+ hr =+ repHudOptions+ 2+ 3+ 5+ defaultAxisOptions+ (defaultTitle "default")+ (maybe defaultLegendOptions fst (hc' ^. #hudLegend))+ (maybe [] snd (hc' ^. #hudLegend))+ BlankA+ ""+ hc'+ cssr = repSvgOptions css'+ annsr =+ listRep+ (Just "Annotations")+ "annz"+ (checkbox Nothing)+ repAnnotation+ maxcs'+ BlankA+ anns'+ mmap css'' ann' d' h' debug' =+ let ch = zipWith Chart ann' d'+ in ( renderHudOptionsChart css'' h' [] ch,+ debugHtml debug' css'' h' ch+ )+ hmap css'' ann' _ h' debug' =+ accordion_+ "acca"+ Nothing+ [ ("Svg", css''),+ ("Annotations", ann'),+ ("Hud", h'),+ ("Debug", debug')+ ]++repChartsWithStaticData ::+ (Monad m) =>+ SvgOptions ->+ HudOptions ->+ Int ->+ [Chart Double] ->+ SharedRep m (Text, Text)+repChartsWithStaticData css' hc' maxcs' cs' =+ repChartsWithSharedData css' hc' maxcs' cs' (bipure mempty)++debugHtml :: (Bool, Bool, Bool) -> SvgOptions -> HudOptions -> [Chart Double] -> Text+debugHtml debug css hc cs =+ bool+ mempty+ ( mconcat $+ (\x -> "<p style='white-space: pre'>" <> x <> "</p>")+ <$> [ "<h2>config values</h2>",+ pShow' css,+ pShow' hc+ ]+ )+ ((\(a, _, _) -> a) debug)+ <> bool+ mempty+ ( mconcat $+ (\x -> "<p style='white-space: pre'>" <> x <> "</p>")+ <$> [ "<h2>chart svg</h2>",+ renderHudOptionsChart css hc [] cs+ ]+ )+ ((\(_, a, _) -> a) debug)+ <> bool+ mempty+ ( mconcat $+ (\x -> "<p style='white-space: pre'>" <> x <> "</p>")+ <$> [ "<h2>chart value</h2>",+ Text.pack $ show cs+ ]+ )+ ((\(_, _, a) -> a) debug)++debugFlags :: (Monad m) => SharedRepF m (Html ()) (Bool, Bool, Bool)+debugFlags =+ bimap+ (\a b c -> a <> b <> c)+ (,,)+ (checkbox (Just "show hudOptions values") False)+ <<*>> checkbox (Just "show chart svg") False+ <<*>> checkbox (Just "show Chart values") False++repHudOptionsDefault :: Monad m => HudOptions -> SharedRep m HudOptions+repHudOptionsDefault hc =+ repHudOptions+ 2+ 3+ 5+ defaultAxisOptions+ (defaultTitle "default")+ defaultLegendOptions+ []+ BlankA+ ""+ hc++repBarOptions ::+ (Monad m) =>+ Int ->+ RectStyle ->+ TextStyle ->+ BarOptions ->+ SharedRep m BarOptions+repBarOptions nrows defrs defts cfg =+ bimap hmap BarOptions rs+ <<*>> ts+ <<*>> og+ <<*>> ig+ <<*>> tg+ <<*>> dv+ <<*>> fn+ <<*>> av+ <<*>> or+ <<*>> ho+ where+ rs =+ listRep+ (Just "bar styles")+ "rs"+ (checkbox Nothing)+ repRectStyle+ nrows+ defrs+ (cfg ^. #barRectStyles)+ ts =+ listRep+ (Just "text styles")+ "ts"+ (checkbox Nothing)+ repTextStyle+ nrows+ defts+ (cfg ^. #barTextStyles)+ og = slider (Just "outer gap") 0.0 1.0 0.001 (cfg ^. #outerGap)+ ig = slider (Just "inner gap") (-1.0) 1 0.001 (cfg ^. #innerGap)+ tg = slider (Just "text gap") (-0.05) 0.05 0.001 (cfg ^. #textGap)+ dv = checkbox (Just "display values") (cfg ^. #displayValues)+ fn = repFormatN (cfg ^. #valueFormatN)+ av = checkbox (Just "accumulate values") (cfg ^. #accumulateValues)+ or = repOrientation (cfg ^. #orientation)+ ho =+ repHudOptions+ 2+ 3+ 5+ defaultAxisOptions+ (defaultTitle "bar options")+ (maybe defaultLegendOptions fst (cfg ^. #barHudOptions . #hudLegend))+ (maybe [] snd (cfg ^. #barHudOptions . #hudLegend))+ BlankA+ ""+ (cfg ^. #barHudOptions)+ hmap rs' ts' og' ig' tg' dv' fn' av' or' ho' =+ accordion_+ "accbo"+ Nothing+ [ ("Bar Styles", rs'),+ ("Text Styles", ts'),+ ("Gaps", og' <> ig' <> tg'),+ ("Style", dv' <> fn' <> av' <> or'),+ ("Hud", ho')+ ]++repBarData ::+ (Monad m) =>+ BarData ->+ SharedRep m BarData+repBarData initbd =+ bimap hmap BarData bd+ <<*>> rl+ <<*>> cl+ where+ rl =+ maybeRep+ Nothing+ (isJust (initbd ^. #barRowLabels))+ ( either (const []) id+ <$> readTextbox (Just "row labels") (fromMaybe [] (initbd ^. #barRowLabels))+ )+ cl =+ maybeRep+ Nothing+ (isJust (initbd ^. #barColumnLabels))+ ( either (const []) id+ <$> readTextbox (Just "column labels") (fromMaybe [] (initbd ^. #barColumnLabels))+ )+ bd =+ either (const (pure [])) id+ <$> readTextbox (Just "bar data") (initbd ^. #barData)+ hmap rl' cl' bd' = rl' <> cl' <> bd'++repPixelOptions ::+ (Monad m) =>+ PixelOptions ->+ SharedRep m PixelOptions+repPixelOptions cfg =+ bimap hmap PixelOptions ps+ <<*>> pg+ <<*>> pr+ where+ ps = repPixelStyle (cfg ^. #poStyle)+ pg = repPointI (Point (Range 1 100) (Range 1 100)) (Point 1 1) (cfg ^. #poGrain)+ pr = repRect (Rect (Range 0 5) (Range 0 5) (Range 0 5) (Range 0 5)) (Rect 0.01 0.01 0.01 0.01) (cfg ^. #poRange)+ hmap ps' pg' pr' =+ accordion_+ "accpixel"+ Nothing+ [ ("Grain", pg'),+ ("Range", pr'),+ ("Style", ps')+ ]++-- PixelLegendOptions+-- {ploStyle :: PixelStyle, ploTitle :: Text, ploWidth :: Double, ploAxisOptions :: AxisOptions, ploLegendOptions :: LegendOptions}++repPixelLegendOptions ::+ (Monad m) =>+ PixelLegendOptions ->+ SharedRep m PixelLegendOptions+repPixelLegendOptions cfg =+ bimap hmap PixelLegendOptions ps+ <<*>> pt+ <<*>> pw+ <<*>> pa+ <<*>> pl+ where+ ps = repPixelStyle (cfg ^. #ploStyle)+ pt = textbox (Just "title") (cfg ^. #ploTitle)+ pw = slider (Just "width") 0.0 0.3 0.001 (cfg ^. #ploWidth)+ pa = repAxisOptions (cfg ^. #ploAxisOptions)+ pl = repLegendOptions (cfg ^. #ploLegendOptions)+ hmap ps' pt' pw' pa' pl' =+ accordion_+ "accplo"+ Nothing+ [ ("Style", ps'),+ ("Title", pt'),+ ("Width", pw'),+ ("Axis", pa'),+ ("Legend", pl')+ ]++repBarChart :: (Monad m) => SvgOptions -> BarData -> BarOptions -> SharedRep m (Text, Text)+repBarChart css bd bo = bimap hmap mmap rcss <<*>> rbd <<*>> rbo <<*>> debugFlags+ where+ rcss = repSvgOptions css+ rbo = repBarOptions 5 defaultRectStyle defaultTextStyle bo+ rbd = repBarData bd+ barchartsvg css' bd' bo' =+ let (hc', cs') = barChart bo' bd'+ in renderHudOptionsChart css' hc' [] cs'+ mmap css' bd' bo' debug =+ ( barchartsvg css' bd' bo',+ debugHtml debug css' (bo' ^. #barHudOptions) (bars bo' bd')+ )+ hmap css' bd' bo' debug =+ accordion_+ "accbc"+ Nothing+ [ ("Svg", css'),+ ("Bar Data", bd'),+ ("Bar Options", bo'),+ ("Debug", debug)+ ]++repPixelChart ::+ (Monad m) =>+ (SvgOptions, PixelOptions, HudOptions, PixelLegendOptions, Point Double -> Double) ->+ SharedRep m (Text, Text)+repPixelChart (css, po, hc, plo, f) = bimap hmap mmap rcss <<*>> rpo <<*>> rhc <<*>> rplo <<*>> debugFlags+ where+ rcss = repSvgOptions css+ rpo = repPixelOptions po+ rhc = repHudOptionsDefault hc+ rplo = repPixelLegendOptions plo+ mmap rcss' rpo' rhc' rplo' debug =+ let (cs, hs) = pixelfl f rpo' rplo'+ in ( renderHudOptionsChart rcss' rhc' hs cs,+ debugHtml debug rcss' rhc' []+ )+ hmap rcss' rpo' rhc' rplo' debug =+ accordion_+ "accpc"+ Nothing+ [ ("Svg", rcss'),+ ("Hud", rhc'),+ ("Pixel Options", rpo'),+ ("Pixel Legend Options", rplo'),+ ("Debug", debug)+ ]
+ src/Chart/Pixel.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLabels #-}+{-# OPTIONS_GHC -Wall #-}++-- | pixel charts+--+-- Opting for a Point or a Rect as concrete data elements that make up an individual chart leaves us with a bit more work to construct a Pixel chart, where colors represent detailed data+module Chart.Pixel+ ( PixelOptions (..),+ defaultPixelOptions,+ pixels,+ pixelate,+ pixelf,+ pixelfl,+ pixelLegendChart,+ PixelLegendOptions (..),+ defaultPixelLegendOptions,+ isHori,+ makePixelTick,+ )+where++import Chart.Color+import Chart.Core+import Chart.Hud+import Chart.Svg (styleBox)+import Chart.Types+import Codec.Picture.Types+import Control.Category (id)+import Control.Lens+import Data.Generics.Labels ()+import GHC.Generics+import NumHask.Space+import Protolude++data PixelOptions+ = PixelOptions+ { poStyle :: PixelStyle,+ poGrain :: Point Int,+ poRange :: Rect Double+ }+ deriving (Show, Eq, Generic)++defaultPixelOptions :: PixelOptions+defaultPixelOptions =+ PixelOptions defaultPixelStyle (Point 10 10) unitRect++-- | pixel elements+data PixelData+ = PixelData+ { pixelRect :: Rect Double,+ pixelColor :: PixelRGB8,+ pixelOpacity :: Double+ }+ deriving (Show, Eq, Generic)++-- | pixel chart without any hud trimmings+pixels :: RectStyle -> [PixelData] -> [Chart Double]+pixels rs ps =+ ( \(PixelData r c o) ->+ Chart+ (RectA (rs & #color .~ c & #opacity .~ o))+ [SpotRect r]+ )+ <$> ps++-- | create pixel data from a function on a Point+pixelate ::+ (Point Double -> Double) ->+ Rect Double ->+ Grid (Rect Double) ->+ (PixelRGB8, Double) ->+ (PixelRGB8, Double) ->+ ([PixelData], Range Double)+pixelate f r g c0 c1 = ((\(x, y) -> let (c, o) = blend' y c0 c1 in PixelData x c o) <$> ps', space1 rs)+ where+ ps = gridF f r g+ rs = realToFrac . snd <$> ps+ rs' = project (space1 rs :: Range Double) (Range 0 1) <$> rs+ ps' = zip (fst <$> ps) rs'++-- | create a pixel chart from a function+pixelf :: (Point Double -> Double) -> PixelOptions -> ([Chart Double], Range Double)+pixelf f cfg =+ first (pixels (cfg ^. #poStyle . #pixelRectStyle)) $+ pixelate+ f+ (cfg ^. #poRange)+ (cfg ^. #poGrain)+ (cfg ^. #poStyle . #pixelColorMin, cfg ^. #poStyle . #pixelOpacityMin)+ (cfg ^. #poStyle . #pixelColorMax, cfg ^. #poStyle . #pixelOpacityMax)++pixelfl :: (Point Double -> Double) -> PixelOptions -> PixelLegendOptions -> ([Chart Double], [Hud Double])+pixelfl f po plo = (cs, [legendHud (plo ^. #ploLegendOptions) (pixelLegendChart dr plo)])+ where+ (cs, dr) = pixelf f po++data PixelLegendOptions+ = PixelLegendOptions+ {ploStyle :: PixelStyle, ploTitle :: Text, ploWidth :: Double, ploAxisOptions :: AxisOptions, ploLegendOptions :: LegendOptions}+ deriving (Eq, Show, Generic)++pixelAxisOptions :: AxisOptions+pixelAxisOptions =+ AxisOptions+ Nothing+ Nothing+ ( Tick+ (TickRound (FormatComma 0) 4 NoTickExtend)+ (Just (defaultGlyphTick & #color .~ black & #shape .~ VLineGlyph & #borderSize .~ 0.002, 0.01))+ (Just (defaultTextTick, 0.03))+ Nothing+ )+ PlaceRight++defaultPixelLegendOptions :: Text -> PixelLegendOptions+defaultPixelLegendOptions t =+ PixelLegendOptions defaultPixelStyle t 0.05 pixelAxisOptions pixelLegendOptions++pixelLegendOptions :: LegendOptions+pixelLegendOptions =+ defaultLegendOptions+ & #lplace .~ PlaceRight+ & #lscale .~ 0.7+ & #lsize .~ 0.5+ & #vgap .~ 0.05+ & #hgap .~ 0.01+ & #innerPad .~ 0.05+ & #outerPad .~ 0.02+ & #ltext . #hsize .~ 0.5++pixelLegendChart :: Range Double -> PixelLegendOptions -> [Chart Double]+pixelLegendChart dataRange l =+ padChart (l ^. #ploLegendOptions . #outerPad)+ . maybe id (\x -> frameChart x (l ^. #ploLegendOptions . #innerPad)) (l ^. #ploLegendOptions . #legendFrame)+ $ hs+ where+ (Range x0 x1) = dataRange+ a = makePixelTick l pchart+ pchart+ | l ^. #ploLegendOptions . #lplace == PlaceBottom+ || l ^. #ploLegendOptions . #lplace == PlaceTop =+ Chart (PixelA (l ^. #ploStyle & #pixelGradient .~ 0)) [SR 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]+ hs = vert (l ^. #ploLegendOptions . #vgap) [a, [t]]++isHori :: PixelLegendOptions -> Bool+isHori l =+ l ^. #ploLegendOptions . #lplace == PlaceBottom+ || l ^. #ploLegendOptions . #lplace == PlaceTop++makePixelTick :: PixelLegendOptions -> Chart Double -> [Chart Double]+makePixelTick l pchart = phud+ where+ r = fromMaybe unitRect (styleBox pchart)+ r' = bool (Rect 0 (l ^. #ploWidth) 0 (l ^. #ploLegendOptions . #lsize)) (Rect 0 (l ^. #ploLegendOptions . #lsize) 0 (l ^. #ploWidth)) (isHori l)+ (hs, _) =+ makeHud+ r+ ( mempty & #hudAxes+ .~ [ l ^. #ploAxisOptions+ & #place .~ bool PlaceRight PlaceBottom (isHori l)+ ]+ )+ phud = runHudWith r' r hs [pchart]
+ src/Chart/Render.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++module Chart.Render+ ( scaleCharts,+ frameChart,+ padChart,+ getAspect,+ getViewbox,+ getSize,+ renderToSvg,+ renderChartsWith,+ renderCharts,+ renderCharts_,+ writeChartsWith,+ writeCharts,+ writeCharts_,+ renderHudChart,+ renderHudOptionsChart,+ writeHudOptionsChart,+ svg2_,+ cssCrisp,+ )+where++import Chart.Core+import Chart.Hud (makeHud, runHud)+import Chart.Svg+import Chart.Types+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 NumHask.Space hiding (Element)+import Protolude hiding (writeFile)+import Lucid.Svg hiding (z)+import Control.Category (id)+import qualified Lucid.Base as Lucid++-- | scale chart data, projecting to the supplied Rect, and expanding the resultant Rect for chart style if necessary.+--+-- Note that this modifies the underlying chart data.+-- FIXME: do a divide to make an exact fit+scaleCharts ::+ Rect Double ->+ [Chart Double] ->+ (Rect Double, [Chart Double])+scaleCharts cs r = (defRect $ styleBoxes cs', cs')+ where+ cs' = projectSpots cs r++getAspect :: SvgAspect -> [Chart Double] -> Double+getAspect (ManualAspect a) _ = a+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++getViewbox :: SvgOptions -> [Chart Double] -> Rect Double+getViewbox o cs =+ bool asp (defRect $ styleBoxes cs) (NoScaleCharts == view #scaleCharts' o)+ where+ asp =+ case view #svgAspect o of+ ManualAspect a -> Rect (a * (-0.5)) (a * 0.5) (-0.5) 0.5+ ChartAspect -> defRect $ styleBoxes cs++-- * rendering++-- | @svg@ element + svg 2 attributes+svg2_:: Term [Attribute] (s -> t) => s -> t+svg2_ m = svg_ [ Lucid.makeAttribute "xmlns" "http://www.w3.org/2000/svg"+ , Lucid.makeAttribute "xmlns:xlink" "http://www.w3.org/1999/xlink"+ ]+ m++renderToSvg :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Svg ()+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))]++cssCrisp :: Svg ()+cssCrisp = style_ [type_ "text/css"] "{ shape-rendering: 'crispEdges'; }"++-- | render Charts with the supplied css options, size and viewbox.+renderCharts_ :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> Text.Text+renderCharts_ csso p r cs =+ Lazy.toStrict $ prettyText (renderToSvg csso p r cs)++-- | render Charts with the supplied options.+renderChartsWith :: SvgOptions -> [Chart Double] -> Text.Text+renderChartsWith so cs =+ Lazy.toStrict $ prettyText (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)+ (r, cs') =+ bool+ (getViewbox so cs, cs)+ (scaleCharts (getViewbox so cs) cs)+ (ScaleCharts == so ^. #scaleCharts')++-- | render charts with the default options.+renderCharts :: [Chart Double] -> Text.Text+renderCharts = renderChartsWith defaultSvgOptions++writeChartsWith :: FilePath -> SvgOptions -> [Chart Double] -> IO ()+writeChartsWith fp so cs = Text.writeFile fp (renderChartsWith so cs)++writeCharts :: FilePath -> [Chart Double] -> IO ()+writeCharts fp cs = Text.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)++-- * rendering huds and charts+-- | Render some huds and charts.+renderHudChart :: SvgOptions -> [Hud Double] -> [Chart Double] -> Text+renderHudChart so hs cs = renderChartsWith so (runHud (getViewbox so cs) hs cs)++-- | Render a chart using the supplied svg and hud config.+renderHudOptionsChart :: SvgOptions -> HudOptions -> [Hud Double] -> [Chart Double] -> Text+renderHudOptionsChart so hc hs cs = renderHudChart so (hs <> hs') (cs <> cs')+ where+ (hs', cs') = makeHud (defRect $ styleBoxes cs) hc++writeHudOptionsChart :: FilePath -> SvgOptions -> HudOptions -> [Hud Double] -> [Chart Double] -> IO ()+writeHudOptionsChart fp so hc hs cs =+ Text.writeFile fp (renderHudOptionsChart so hc hs cs)
+ src/Chart/Svg.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall #-}++module Chart.Svg+ ( svg,+ svgt,+ chartDef,+ chartDefs,+ styleBox,+ styleBoxes,+ styleBoxText,+ styleBoxGlyph,+ )+where++import Chart.Color (toHex)+import Chart.Types+import Control.Lens hiding (transform)+import Data.Generics.Labels ()+import Data.Maybe+import Data.Monoid+import qualified Data.Text as Text+import NumHask.Space as NH hiding (Element)+import Control.Category (id)+import Protolude hiding (writeFile)+import Text.HTML.TagSoup hiding (Attribute)+import Lucid.Svg hiding (z)+import qualified Lucid++-- | 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 $ o ^. #pixelOpacityMin)+ , stop_color_ (toHex (o ^. #pixelColorMin))+ , offset_ "0"+ ]+ , stop_+ [ stop_opacity_ (show $ o ^. #pixelOpacityMax)+ , 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_ (toHex $ o ^. #borderColor)+ , stroke_opacity_ (show $ o ^. #borderOpacity)+ , fill_ (toHex $ o ^. #color)+ , fill_opacity_ (show $ o ^. #opacity)+ ]++attsPixel :: PixelStyle -> [Attribute]+attsPixel o =+ [ stroke_width_ (show $ o ^. #pixelRectStyle . #borderSize)+ , stroke_ (toHex $ o ^. #pixelRectStyle . #borderColor)+ , stroke_opacity_ (show $ o ^. #pixelRectStyle . #borderOpacity)+ , fill_ ("url(#" <> (o ^. #pixelTextureId) <> ")")+ ]++attsText :: TextStyle -> [Attribute]+attsText o =+ [ stroke_width_ "0.0"+ , stroke_ "none"+ , fill_ (toHex $ o ^. #color)+ , fill_opacity_ (show $ o ^. #opacity)+ , 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 $ o ^. #borderOpacity)+ , fill_ (toHex $ o ^. #color)+ , fill_opacity_ (show $ o ^. #opacity)+ ]+ <>+ maybe [] ((:[]) . transform_ . toTranslateText) (o ^. #translate)++attsLine :: LineStyle -> [Attribute]+attsLine o =+ [ stroke_width_ (show $ o ^. #width)+ , stroke_ (toHex $ o ^. #color)+ , stroke_opacity_ (show $ o ^. #opacity)+ , 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) <> ")"
+ src/Chart/Types.hs view
@@ -0,0 +1,634 @@+{-# 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 Codec.Picture.Types+import Control.Lens+import Data.Generics.Labels ()+import qualified Data.Text as Text+import GHC.Exts+import GHC.Generics+import NumHask.Space hiding (Element)+import Protolude+import Data.List ((!!))++-- * 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 :: PixelRGB8,+ borderOpacity :: Double,+ color :: PixelRGB8,+ opacity :: Double+ }+ deriving (Show, Eq, Generic)++-- | the official style+defaultRectStyle :: RectStyle+defaultRectStyle = RectStyle 0.02 (chartPalette!!0) 0.5 (chartPalette!!3) 0.5++-- | solid rectangle, no border+blob :: PixelRGB8 -> Double -> RectStyle+blob = RectStyle 0 black 0++-- | clear and utrans rect+clear :: RectStyle+clear = RectStyle 0 black 0 black 0++-- | transparent rectangle, with border+border :: Double -> PixelRGB8 -> Double -> RectStyle+border s c o = RectStyle s c o black 0++-- | Text styling+data TextStyle+ = TextStyle+ { size :: Double,+ color :: PixelRGB8,+ opacity :: Double,+ 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 grey 1.0 AnchorMiddle 0.5 1.45 (-0.2) Nothing Nothing False++-- | Glyph styling+data GlyphStyle+ = GlyphStyle+ { -- | glyph radius+ size :: Double,+ -- | fill color+ color :: PixelRGB8,+ opacity :: Double,+ -- | stroke color+ borderColor :: PixelRGB8,+ borderOpacity :: Double,+ -- | 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+ (PixelRGB8 217 151 33)+ 0.8+ (PixelRGB8 44 66 157)+ 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+ | HLineGlyph+ | 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 :: PixelRGB8,+ opacity :: Double+ }+ deriving (Show, Eq, Generic)++-- | the official default line style+defaultLineStyle :: LineStyle+defaultLineStyle = LineStyle 0.02 blue 0.5++data PixelStyle+ = PixelStyle+ { pixelColorMin :: PixelRGB8,+ pixelOpacityMin :: Double,+ pixelColorMax :: PixelRGB8,+ pixelOpacityMax :: Double,+ -- | 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 grey 1 blue 1 (pi / 2) (RectStyle 0 black 0 black 1) "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 blue 1.0++-- | 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 grey 0.03++-- | 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 grey 0 (PixelRGB8 95 3 145) 0.5) 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 .~ PixelRGB8 0 0 0)+ $ 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+ & #color .~ PixelRGB8 95 3 145+ & #opacity .~ 1+ & #shape .~ VLineGlyph++defaultTextTick :: TextStyle+defaultTextTick =+ defaultTextStyle & #size .~ 0.05++defaultLineTick :: LineStyle+defaultLineTick =+ defaultLineStyle+ & #color .~ PixelRGB8 168 229 238+ & #width .~ 5.0e-3+ & #opacity .~ 0.3++defaultTick :: Tick+defaultTick =+ Tick+ defaultTickStyle+ (Just (defaultGlyphTick, 0.01))+ (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 .~ grey+ )+ 10+ 0.1+ 0.1+ (Just (RectStyle 0.02 (PixelRGB8 55 100 160) 0.5 (PixelRGB8 255 255 255) 1))+ PlaceBottom+ 0.2++data FormatN+ = FormatFixed Int+ | FormatComma Int+ | FormatExpt Int+ | FormatDollar+ | FormatPercent Int+ | FormatNone+ deriving (Eq, Show, Generic)++defaultFormatN :: FormatN+defaultFormatN = FormatComma 2
+ stack.yaml view
@@ -0,0 +1,15 @@+resolver: lts-15.6++packages:+ - .++extra-deps:+ - lucid-svg-0.7.1+ - javascript-bridge-0.2.0+ - box-0.3.0+ - web-rep-0.3.1+ - numhask-space-0.3.1+ - palette-0.3.0.2+ - tdigest-0.2.1+ - interpolatedstring-perl6-1.0.2+ - text-format-0.3.2