chart-svg 0.0.1 → 0.0.2
raw patch · 16 files changed
+459/−428 lines, 16 filesdep +Colordep −JuicyPixelsdep −colourdep −palette
Dependencies added: Color
Dependencies removed: JuicyPixels, colour, palette
Files
- app/examples.hs +6/−5
- app/venn.hs +133/−115
- chart-svg.cabal +2/−4
- src/Chart.hs +1/−8
- src/Chart/Bar.hs +2/−2
- src/Chart/Color.hs +106/−68
- src/Chart/Core.hs +2/−2
- src/Chart/Examples.hs +12/−22
- src/Chart/Format.hs +1/−1
- src/Chart/Hud.hs +1/−3
- src/Chart/Page.hs +38/−28
- src/Chart/Pixel.hs +10/−12
- src/Chart/Render.hs +12/−9
- src/Chart/Svg.hs +91/−93
- src/Chart/Types.hs +38/−51
- stack.yaml +4/−5
app/examples.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} import Chart@@ -11,14 +11,15 @@ import Control.Lens import Control.Monad.Trans.State.Lazy import Network.Wai.Middleware.Static ((>->), addBase, noDots, staticPolicy)+import Protolude hiding ((<<*>>), Rep, replace) import Web.Page import Web.Scotty-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)@@ -71,7 +72,7 @@ ("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))+ ("pixel", repPixelChart (defaultSvgOptions, defaultPixelOptions & #poGrain .~ Point 100 100 & #poRange .~ Rect 1 2 1 2, defaultHudOptions, defaultPixelLegendOptions "pixel test", f1)) ] ), ( "stuff",@@ -80,10 +81,10 @@ [ ("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)+ ("legend test", repNoData defaultSvgOptions BlankA legendTest) ] ),- ( "main", repEx mainExample)+ ("main", repEx mainExample) ] ) )
app/venn.hs view
@@ -1,45 +1,45 @@-{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-} {-# 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.Map.Strict as Map import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy import Lucid.Svg hiding (z)+import Protolude 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- ]+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)+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)+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)@@ -48,140 +48,158 @@ 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"- ]+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"- ]+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"- ]+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"- ]+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"- ]+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"- ]+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"- ]+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+seg :: Text -> Colour -> GlyphStyle+seg p c = defaultGlyphStyle & set #shape (PathGlyph p) & set #color c & set #borderColor white & set #borderSize 0.06 venns :: [Chart Double]-venns = zipWith (\p c -> Chart (GlyphA $ seg p c 0.8) [SP 0.0 0.0]) vennGlyphs chartPalette+venns = zipWith (\p c -> Chart (GlyphA $ seg p c) [SP 0.0 0.0]) vennGlyphs palette 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)+data Phrase+ = Phrase+ { phraseText :: Text,+ phrasePosition :: Point Double,+ phraseSize :: Double,+ phraseRotation :: Double,+ phraseColor :: Colour,+ phraseTag :: Text,+ phraseLevel :: Int+ }+ deriving (Eq, Show, Generic) phraseChart :: Phrase -> Chart Double phraseChart p = Chart (TextA a [view #phraseText p]) [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)+ & set #size (view #phraseSize p)+ & set #rotation (Just $ view #phraseRotation p)+ & set #color (view #phraseColor p) mainPhrases :: [Phrase] mainPhrases =- [ Phrase "Composable" (Point 0.9 0.7) 0.16 60 c 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- ]+ [ Phrase "Composable" (Point 0.9 0.7) 0.16 60 c "composable" 1,+ Phrase "Functional" (Point 0 (-1)) 0.16 0 c "functional" 1,+ Phrase "Open" (Point (-1) 0.55) 0.16 (-60) c "open" 1,+ Phrase "Accurate" (Point 0.6 (-0.4)) 0.16 0 c "accurate" 1,+ Phrase "Dynamic" (Point (-0.6) (-0.4)) 0.16 0 c "dynamic" 1,+ Phrase "Modern" (Point 0 0.7) 0.16 0 c "modern" 1,+ Phrase "chart-svg" (Point 0 0) 0.2 0 c "chart-svg" 1+ ] where c = black renderToSvgt :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> [(TextStyle, Text)] -> 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))]+ 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) <> [""])+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 colorText,) <$>+ (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]])+writeVenn :: [Colour] -> 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 (Colour 0.1 0 0.2 1) "chart-svg" 1)] <> (zipWith (\p c -> Chart (GlyphA $ seg p c) [SP 0.0 0.0]) [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3] cs) <> [Chart BlankA [SR (-1.5) 1.5 (-1.5) 1.5]]) main :: IO () main = do writeVennWords- writeVenn chartPalette 0.8+ writeVenn palette 0.8
chart-svg.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: chart-svg-version: 0.0.1+version: 0.0.2 synopsis: See readme.md description: See readme.md for description. category: project@@ -37,12 +37,10 @@ src ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends:- JuicyPixels+ Color , attoparsec , base >=4.7 && <5 , bifunctors- , colour- , palette , foldl , generic-lens , lucid
src/Chart.hs view
@@ -2,9 +2,7 @@ -- | A haskell Charting library targetting SVG module Chart- ( -- * Types- -- $types- module Chart.Types,+ ( module Chart.Types, module Chart.Color, module Chart.Core, module Chart.Svg,@@ -15,7 +13,6 @@ module Chart.Bar, module Chart.Pixel, module NumHask.Space,- PixelRGB8 (..), ) where @@ -29,8 +26,4 @@ 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
@@ -83,8 +83,8 @@ ) ) where- gs = (\x -> RectStyle 0.002 grey 1 x 0.5) <$> chartPalette- ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04 & #opacity .~ 0.5) <$> chartPalette+ gs = (\x -> RectStyle 0.002 colorGrey x) <$> palette+ ts = (\x -> defaultTextStyle & #color .~ x & #size .~ 0.04) <$> palette -- | imagine a data frame ... data BarData
src/Chart/Color.hs view
@@ -16,95 +16,133 @@ {-# OPTIONS_GHC -Wall #-} module Chart.Color- ( blue,- grey,- black,- white,- red,- toColour,- fromColour,- d3Palette1,- chartPalette,- chartPalette2,+ ( Colour,+ pattern Colour,+ opac,+ hex,+ palette, blend,- blend', toHex, fromHex,+ unsafeFromHex,+ fromHexOpac,++ -- * named colors+ colorText,+ colorPixelMin,+ colorPixelMax,+ colorFrame,+ colorCanvas,+ colorGlyphTick,+ colorLineTick,+ colorTextTick,+ colorGrey,+ transparent,+ black,+ white,++ -- * re-exports+ module Graphics.Color.Model, ) where -import 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.Attoparsec.Text hiding (take) import Data.Generics.Labels () import GHC.Exts import Protolude-import Web.Page.Html-import Data.Attoparsec.Text hiding (take)+import qualified Data.Text.Lazy as Lazy+import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Format+import Data.Text (justifyRight)+import Graphics.Color.Model+import Data.Text (pack) --- * color--- | the official chart-unit blue-blue :: PixelRGB8-blue = PixelRGB8 93 165 218+type Colour = Color (Alpha RGB) Double --- | the official chart-unit grey-grey :: PixelRGB8-grey = PixelRGB8 102 102 102+-- | Constructor.+pattern Colour :: Double -> Double -> Double -> Double -> Colour+pattern Colour r g b a = ColorRGBA r g b a+{-# COMPLETE Colour #-} --- | black-black :: PixelRGB8-black = PixelRGB8 0 0 0+opac :: Colour -> Double+opac c = getAlpha c --- | white-white :: PixelRGB8-white = PixelRGB8 255 255 255+hex :: Colour -> Text+hex c = toHex c --- | red-red :: PixelRGB8-red = PixelRGB8 255 0 0+palette :: [Colour]+palette = unsafeFromHex <$> ["#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e", "#31331c", "#454e56", "#94a7b5", "#ab7257", "#001114", "#042f1e", "#033d26", "#034243", "#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e"] --- | 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)+-- | interpolate between 2 colors+blend :: Double -> Colour -> Colour -> Colour+blend c (Colour r g b a) (Colour r' g' b' a') = Colour r'' g'' b'' a''+ where+ r'' = r + c * (r' - r)+ g'' = g + c * (g' - g)+ b'' = b + c * (b' - b)+ a'' = a + c * (a' - a) --- | 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))+parseHex :: Parser Colour+parseHex = (\x -> addAlpha x 1) . fmap toDouble <$>+ ( \((r, g), b) ->+ ColorRGB (fromIntegral r) (fromIntegral g) (fromIntegral b) :: Color RGB Word8+ )+ . (\(f, b) -> (f `divMod` (256 :: Int), b))+ . (`divMod` 256)+ <$> (string "#" *> hexadecimal) --- | the d3 palette-d3Palette1 :: [PixelRGB8]-d3Palette1 = fromColour . C.d3Colors1 <$> [0 .. 9]+fromHex :: Text -> Either Text Colour+fromHex = first pack . parseOnly parseHex -chartPalette :: [PixelRGB8]-chartPalette = rights $ parseOnly fromHex <$> ["#026062", "#0ea194", "#0a865a", "#9d1102", "#f8a631", "#695b1e", "#31331c", "#454e56", "#94a7b5", "#ab7257"]+unsafeFromHex :: Text -> Colour+unsafeFromHex t = either (const transparent) (\x -> x) $ parseOnly parseHex t --- 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"]+-- | convert from 'Colour' to #xxxxxx+toHex :: Colour -> Text+toHex c =+ "#"+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ Data.Text.Format.hex r)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ Data.Text.Format.hex g)+ <> justifyRight 2 '0' (Lazy.toStrict $ toLazyText $ Data.Text.Format.hex b)+ where+ (ColorRGBA r g b _) = toWord8 <$> c +fromHexOpac :: Text -> Double -> Colour+fromHexOpac t o = setAlpha (unsafeFromHex t) o --- | 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)+-- some colors used+colorText :: Colour+colorText = Colour 0.2 0.2 0.2 1 --- | 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)+colorPixelMin :: Colour+colorPixelMin = Colour 0.8 0.8 0.8 1 -{---- | 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)+colorPixelMax :: Colour+colorPixelMax = Colour 0.1 0.1 1 1 --}+colorFrame :: Colour+colorFrame = Colour 0 0 1 0.4++colorCanvas :: Colour+colorCanvas = Colour 0.8 0.8 0.8 0.1++colorGlyphTick :: Colour+colorGlyphTick = Colour 0.34 0.05 0.4 0.5++colorLineTick :: Colour+colorLineTick = Colour 0.5 0.5 0.5 0.1++colorTextTick :: Colour+colorTextTick = Colour 0.2 0.2 0.2 0.8++colorGrey :: Colour+colorGrey = Colour 0.5 0.5 0.5 1++black :: Colour+black = Colour 0 0 0 1++white :: Colour+white = Colour 1 1 1 1++transparent :: Colour+transparent = Colour 0 0 0 0
src/Chart/Core.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} module Chart.Core@@ -22,8 +22,8 @@ ) where -import Chart.Types import Chart.Svg (styleBox, styleBoxes)+import Chart.Types import Control.Category (id) import Control.Lens hiding (transform) import Data.Foldable
src/Chart/Examples.hs view
@@ -14,6 +14,7 @@ import qualified Data.Text as Text import GHC.Generics import Protolude+import Data.List ((!!)) data Ex = Ex@@ -61,7 +62,7 @@ ] ropts :: [RectStyle]-ropts = zipWith blob chartPalette [0.2, 0.7]+ropts = zipWith (\c o -> blob (setAlpha c o)) palette [0.2, 0.7] -- | line example lineExample :: Ex@@ -87,12 +88,9 @@ 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+ [ defaultLineStyle & #color .~ (palette !! 0) & #width .~ 0.015,+ defaultLineStyle & #color .~ (palette !! 1) & #width .~ 0.03,+ defaultLineStyle & #color .~ (palette !! 2) & #width .~ 0.01 ] legopts :: LegendOptions@@ -110,14 +108,12 @@ & #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 ]@@ -139,8 +135,8 @@ ts :: [(Text.Text, Point Double)] ts = zip- (fmap Text.singleton ['a' .. 'y'])- [Point (sin (x * 0.1)) x | x <- [0 .. 25]]+ (fmap Text.singleton ['a' .. 'y'])+ [Point (sin (x * 0.1)) x | x <- [0 .. 25]] -- | glyph example glyphExample :: Ex@@ -165,8 +161,8 @@ (RectSharpGlyph 0.75, 0.01), (RectRoundedGlyph 0.75 0.01 0.01, 0.01), (EllipseGlyph 0.75, 0),- (VLineGlyph, 0.01),- (HLineGlyph, 0.01),+ (VLineGlyph 0.005, 0.01),+ (HLineGlyph 0.005, 0.01), (TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), 0.01), (PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z", 0.01) ]@@ -218,7 +214,6 @@ ) [SP 1 1] - -- | compound chart gopts3 :: [GlyphStyle] gopts3 =@@ -231,10 +226,7 @@ . (#size .~ 0.08) $ defaultGlyphStyle )- [ PixelRGB8 120 67 30,- PixelRGB8 30 48 130,- PixelRGB8 60 60 60- ]+ palette [EllipseGlyph 1.5, SquareGlyph, CircleGlyph] glines :: [Chart Double]@@ -256,7 +248,7 @@ Chart ( TextA ( defaultTextStyle- & #opacity .~ 0.2+ & #color %~ (\x -> setAlpha x 0.2) & #translate ?~ Point 0 0.04 ) [t]@@ -290,7 +282,7 @@ placedLabel :: (Chartable a) => Point a -> a -> Text.Text -> Chart a placedLabel p d t =- Chart ( TextA ( defaultTextStyle & #rotation ?~ realToFrac d ) [t] ) [SpotPoint p]+ Chart (TextA (defaultTextStyle & #rotation ?~ realToFrac d) [t]) [SpotPoint p] label :: [Chart Double] label =@@ -338,13 +330,11 @@ 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
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} module Chart.Format
src/Chart/Hud.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE NoImplicitPrelude #-} -- | A hud (heads-up display) are decorations in and around a chart that assist with data interpretation. module Chart.Hud@@ -32,7 +32,6 @@ 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@@ -627,4 +626,3 @@ legendFromChart :: [Text] -> [Chart Double] -> [(Annotation, Text)] legendFromChart = zipWith (\t c -> (c ^. #annotation, t))-
src/Chart/Page.hs view
@@ -50,6 +50,7 @@ where import Chart.Bar+import Chart.Color import Chart.Format import Chart.Pixel import Chart.Render (renderHudOptionsChart)@@ -62,9 +63,9 @@ import qualified Data.Text as Text import Lucid import NumHask.Space-import Web.Page hiding (bool)-import Text.Pretty.Simple (pShowNoColor) import Protolude hiding ((<<*>>))+import Text.Pretty.Simple (pShowNoColor)+import Web.Page hiding (bool) pShow' :: (Show a) => a -> Text pShow' = toStrict . pShowNoColor@@ -152,18 +153,18 @@ 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+ bc <- colorPicker (Just "border color") (hex $ s ^. #borderColor)+ bo <- slider (Just "border opacity") 0 1 0.1 (opac $ s ^. #borderColor)+ c <- colorPicker (Just "color") (hex $ s ^. #color)+ o <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color)+ pure $ RectStyle bs (fromHexOpac bc bo) (fromHexOpac c o) repPixelStyle :: (Monad m) => PixelStyle -> SharedRep m PixelStyle repPixelStyle cfg =- bimap hmap PixelStyle pcmin+ bimap hmap mmap pcmin <<*>> pomin <<*>> pcmax <<*>> pomax@@ -171,15 +172,17 @@ <<*>> 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)+ pcmax = colorPicker (Just "high color") (toHex $ cfg ^. #pixelColorMax)+ pcmin = colorPicker (Just "low color") (toHex $ cfg ^. #pixelColorMin)+ pomax = slider (Just "high opacity") 0.0 1.0 0.001 (opac $ cfg ^. #pixelColorMax)+ pomin = slider (Just "low opacity") 0.0 1.0 0.001 (opac $ cfg ^. #pixelColorMin) pd = slider (Just "gradient direction") 0.0 (2 * pi) 0.001 (cfg ^. #pixelGradient) prs = repRectStyle (cfg ^. #pixelRectStyle) pt = textbox (Just "texture id") (cfg ^. #pixelTextureId) hmap pcmin' pomin' pcmax' pomax' pd' prs' pt' = pcmin' <> pomin' <> pcmax' <> pomax' <> pd' <> prs' <> pt'+ mmap pcmin' pomin' pcmax' pomax' pd' prs' pt' =+ PixelStyle (fromHexOpac pcmin' pomin') (fromHexOpac 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@@ -188,11 +191,11 @@ gc <- colorPicker (Just "Color")- (gs ^. #color)- go <- slider (Just "Opacity") 0 1 0.1 (gs ^. #opacity)+ (toHex $ gs ^. #color)+ go <- slider (Just "Opacity") 0 1 0.1 (opac $ gs ^. #color) bsz <- slider (Just "Border Size") 0 0.02 0.001 (gs ^. #borderSize)- gbc <- colorPicker (Just "Border Color") (gs ^. #borderColor)- gbo <- slider (Just "Border Opacity") 0 1 0.1 (gs ^. #borderOpacity)+ gbc <- colorPicker (Just "Border Color") (toHex $ gs ^. #borderColor)+ gbo <- slider (Just "Border Opacity") 0 1 0.1 (opac $ gs ^. #borderColor) tr <- maybeRep (Just "rotation")@@ -207,13 +210,13 @@ (Point 0.001 0.001) (Point 0 0) )- pure (GlyphStyle sz gc go gbc gbo bsz sh tr tt)+ pure (GlyphStyle sz (fromHexOpac gc go) (fromHexOpac 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)+ tc <- colorPicker (Just "color") (toHex $ s ^. #color)+ to' <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color) ta <- repAnchor (s ^. #anchor) th <- slider (Just "hsize") 0.2 1 0.05 (s ^. #hsize) tv <- slider (Just "vsize") 0.5 2 0.05 (s ^. #vsize)@@ -233,14 +236,14 @@ (Point 0 0) ) tm <- checkbox (Just "mathjax") (s ^. #hasMathjax)- pure $ TextStyle ts tc to' ta th tv tn tr tt tm+ pure $ TextStyle ts (fromHexOpac 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+ c <- colorPicker (Just "color") (toHex $ s ^. #color)+ o <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color)+ pure $ LineStyle w (fromHexOpac c o) repPlace :: (Monad m) => Place -> SharedRep m Place repPlace initpl = bimap hmap mmap rplace <<*>> rp@@ -723,7 +726,7 @@ 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+repGlyphShape sh = bimap hmap mmap sha <<*>> ell <<*>> rsharp <<*>> rround <<*>> tri <<*>> p <<*>> lwidth where sha = dropdownSum@@ -744,6 +747,7 @@ ell = slider Nothing 0.5 2 0.01 defRatio rsharp = slider Nothing 0.5 2 0.01 defRatio rround = repRounded defRounded+ lwidth = slider (Just "width") 0.001 0.02 0.001 defLwidth tri = repTriple defTriangle@@ -752,14 +756,16 @@ (Point 0.001 0.001) ) p = textbox (Just "path") defP- hmap sha' ell' rsharp' rround' tri' p' =+ hmap sha' ell' rsharp' rround' tri' p' lwidth' = sha' <> subtype ell' (glyphText sh) "Ellipse" <> subtype rsharp' (glyphText sh) "RectSharp" <> subtype rround' (glyphText sh) "RectRounded" <> subtype tri' (glyphText sh) "Triangle"+ <> subtype lwidth' (glyphText sh) "VLine"+ <> subtype lwidth' (glyphText sh) "HLine" <> subtype p' (glyphText sh) "Path"- mmap sha' ell' rsharp' rround' tri' p' =+ mmap sha' ell' rsharp' rround' tri' p' lwidth' = case sha' of "Circle" -> CircleGlyph "Square" -> SquareGlyph@@ -767,8 +773,8 @@ "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+ "VLine" -> VLineGlyph lwidth'+ "HLine" -> HLineGlyph lwidth' "Path" -> PathGlyph p' _ -> CircleGlyph defP = case sh of@@ -778,6 +784,10 @@ EllipseGlyph r -> r RectSharpGlyph r -> r _ -> 1.5+ defLwidth = case sh of+ VLineGlyph r -> r+ HLineGlyph r -> r+ _ -> 0.005 defRounded = case sh of RectRoundedGlyph a b c -> (a, b, c) _ -> (0.884, 2.7e-2, 5.0e-2)
src/Chart/Pixel.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} -- | pixel charts@@ -27,7 +27,6 @@ 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 ()@@ -51,17 +50,16 @@ data PixelData = PixelData { pixelRect :: Rect Double,- pixelColor :: PixelRGB8,- pixelOpacity :: Double+ pixelColor :: Colour } deriving (Show, Eq, Generic) -- | pixel chart without any hud trimmings pixels :: RectStyle -> [PixelData] -> [Chart Double] pixels rs ps =- ( \(PixelData r c o) ->+ ( \(PixelData r c) -> Chart- (RectA (rs & #color .~ c & #opacity .~ o))+ (RectA (rs & #color .~ c)) [SpotRect r] ) <$> ps@@ -71,10 +69,10 @@ (Point Double -> Double) -> Rect Double -> Grid (Rect Double) ->- (PixelRGB8, Double) ->- (PixelRGB8, Double) ->+ Colour ->+ Colour -> ([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)+pixelate f r g c0 c1 = ((\(x, y) -> let c = blend y c0 c1 in PixelData x c) <$> ps', space1 rs) where ps = gridF f r g rs = realToFrac . snd <$> ps@@ -89,8 +87,8 @@ f (cfg ^. #poRange) (cfg ^. #poGrain)- (cfg ^. #poStyle . #pixelColorMin, cfg ^. #poStyle . #pixelOpacityMin)- (cfg ^. #poStyle . #pixelColorMax, cfg ^. #poStyle . #pixelOpacityMax)+ (cfg ^. #poStyle . #pixelColorMin)+ (cfg ^. #poStyle . #pixelColorMax) pixelfl :: (Point Double -> Double) -> PixelOptions -> PixelLegendOptions -> ([Chart Double], [Hud Double]) pixelfl f po plo = (cs, [legendHud (plo ^. #ploLegendOptions) (pixelLegendChart dr plo)])@@ -109,7 +107,7 @@ Nothing ( Tick (TickRound (FormatComma 0) 4 NoTickExtend)- (Just (defaultGlyphTick & #color .~ black & #shape .~ VLineGlyph & #borderSize .~ 0.002, 0.01))+ (Just (defaultGlyphTick & #color .~ black & #shape .~ VLineGlyph 0.005, 0.01)) (Just (defaultTextTick, 0.03)) Nothing )
src/Chart/Render.hs view
@@ -30,17 +30,17 @@ import Chart.Hud (makeHud, runHud) import Chart.Svg import Chart.Types+import Control.Category (id) import Control.Lens hiding (transform) import Data.Generics.Labels () import Data.Maybe import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Text.Lazy as Lazy+import qualified Lucid.Base as Lucid+import Lucid.Svg hiding (z) 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. --@@ -75,15 +75,17 @@ -- * 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+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))]+ 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'; }"@@ -124,6 +126,7 @@ 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)
src/Chart/Svg.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} module Chart.Svg@@ -16,19 +16,19 @@ ) where -import Chart.Color (toHex)+import Chart.Color import Chart.Types+import Control.Category (id) import Control.Lens hiding (transform) import Data.Generics.Labels () import Data.Maybe import Data.Monoid import qualified Data.Text as Text+import qualified Lucid+import Lucid.Svg hiding (z) import NumHask.Space as NH hiding (Element)-import 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 ::@@ -58,8 +58,8 @@ 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+ 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@@ -70,7 +70,7 @@ -- | 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 (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)@@ -86,24 +86,25 @@ 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"+ [ id_ (o ^. #pixelTextureId),+ x1_ (show x0),+ y1_ (show y0),+ x2_ (show x1),+ y2_ (show y1)+ ]+ ( mconcat+ [ stop_+ [ stop_opacity_ (show $ opac $ o ^. #pixelColorMin),+ stop_color_ (toHex (o ^. #pixelColorMin)),+ offset_ "0"+ ],+ stop_+ [ stop_opacity_ (show $ opac $ o ^. #pixelColorMax),+ stop_color_ (toHex (o ^. #pixelColorMax)),+ offset_ "1"+ ] ]- ])+ ) where x0 = min 0 (cos (o ^. #pixelGradient)) x1 = max 0 (cos (o ^. #pixelGradient))@@ -125,69 +126,69 @@ 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)- ]+ [ 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)+ 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'+ 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)- ]+ [ 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)- ]+ [ 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)))- ]+ [ 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))]+ [ 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)] @@ -225,37 +226,35 @@ 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)+ [ stroke_width_ (show $ o ^. #borderSize),+ stroke_ (hex $ o ^. #borderColor),+ stroke_opacity_ (show $ opac $ o ^. #borderColor),+ fill_ (hex $ o ^. #color),+ fill_opacity_ (show $ opac $ o ^. #color) ] attsPixel :: PixelStyle -> [Attribute] attsPixel o =- [ stroke_width_ (show $ o ^. #pixelRectStyle . #borderSize)- , stroke_ (toHex $ o ^. #pixelRectStyle . #borderColor)- , stroke_opacity_ (show $ o ^. #pixelRectStyle . #borderOpacity)- , fill_ ("url(#" <> (o ^. #pixelTextureId) <> ")")+ [ stroke_width_ (show $ o ^. #pixelRectStyle . #borderSize),+ stroke_ (toHex $ o ^. #pixelRectStyle . #borderColor),+ stroke_opacity_ (show $ opac $ o ^. #pixelRectStyle . #borderColor),+ fill_ ("url(#" <> (o ^. #pixelTextureId) <> ")") ] attsText :: TextStyle -> [Attribute] attsText o =- [ stroke_width_ "0.0"- , stroke_ "none"- , fill_ (toHex $ o ^. #color)- , fill_opacity_ (show $ o ^. #opacity)- , font_size_ (show $ o ^. #size)- , text_anchor_ (toTextAnchor $ o ^. #anchor)+ [ stroke_width_ "0.0",+ stroke_ "none",+ fill_ (toHex $ o ^. #color),+ fill_opacity_ (show $ opac $ o ^. #color),+ font_size_ (show $ o ^. #size),+ text_anchor_ (toTextAnchor $ o ^. #anchor) ]- <>- maybe [] ((:[]) . transform_ . toTranslateText) (o ^. #translate)+ <> maybe [] ((: []) . transform_ . toTranslateText) (o ^. #translate) where toTextAnchor :: Anchor -> Text toTextAnchor AnchorMiddle = "middle"@@ -264,27 +263,26 @@ 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)+ [ stroke_width_ (show $ o ^. #borderSize),+ stroke_ (toHex $ o ^. #borderColor),+ stroke_opacity_ (show $ opac $ o ^. #borderColor),+ fill_ (toHex $ o ^. #color),+ fill_opacity_ (show $ opac $ o ^. #color) ]- <>- maybe [] ((:[]) . transform_ . toTranslateText) (o ^. #translate)+ <> 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"+ [ stroke_width_ (show $ o ^. #width),+ stroke_ (toHex $ o ^. #color),+ stroke_opacity_ (show $ opac $ o ^. #color),+ fill_ "none" ] toTranslateText :: Point Double -> Text toTranslateText (Point x y) =- "translate(" <> show x <> ", " <> show (-y) <> ")"+ "translate(" <> show x <> ", " <> show (- y) <> ")" toRotateText :: Double -> Point Double -> Text toRotateText r (Point x y) =- "rotate(" <> show r <> ", " <> show x <> ", " <> show (-y) <> ")"+ "rotate(" <> show r <> ", " <> show x <> ", " <> show (- y) <> ")"
src/Chart/Types.hs view
@@ -90,15 +90,14 @@ where import Chart.Color-import Codec.Picture.Types import Control.Lens import Data.Generics.Labels ()+import Data.List ((!!)) import qualified Data.Text as Text import GHC.Exts import GHC.Generics import NumHask.Space hiding (Element) import Protolude-import Data.List ((!!)) -- * Chart @@ -139,35 +138,32 @@ data RectStyle = RectStyle { borderSize :: Double,- borderColor :: PixelRGB8,- borderOpacity :: Double,- color :: PixelRGB8,- opacity :: Double+ borderColor :: Colour,+ color :: Colour } deriving (Show, Eq, Generic) --- | the official style+-- | the style defaultRectStyle :: RectStyle-defaultRectStyle = RectStyle 0.02 (chartPalette!!0) 0.5 (chartPalette!!3) 0.5+defaultRectStyle = RectStyle 0.02 (palette !! 0) (palette !! 1) -- | solid rectangle, no border-blob :: PixelRGB8 -> Double -> RectStyle-blob = RectStyle 0 black 0+blob :: Colour -> RectStyle+blob = RectStyle 0 transparent -- | clear and utrans rect clear :: RectStyle-clear = RectStyle 0 black 0 black 0+clear = RectStyle 0 transparent transparent -- | transparent rectangle, with border-border :: Double -> PixelRGB8 -> Double -> RectStyle-border s c o = RectStyle s c o black 0+border :: Double -> Colour -> RectStyle+border s c = RectStyle s c transparent -- | Text styling data TextStyle = TextStyle { size :: Double,- color :: PixelRGB8,- opacity :: Double,+ color :: Colour, anchor :: Anchor, hsize :: Double, vsize :: Double,@@ -194,7 +190,7 @@ -- | the offical text style defaultTextStyle :: TextStyle defaultTextStyle =- TextStyle 0.08 grey 1.0 AnchorMiddle 0.5 1.45 (-0.2) Nothing Nothing False+ TextStyle 0.08 colorText AnchorMiddle 0.5 1.45 (-0.2) Nothing Nothing False -- | Glyph styling data GlyphStyle@@ -202,11 +198,9 @@ { -- | glyph radius size :: Double, -- | fill color- color :: PixelRGB8,- opacity :: Double,+ color :: Colour, -- | stroke color- borderColor :: PixelRGB8,- borderOpacity :: Double,+ borderColor :: Colour, -- | stroke width (adds a bit to the bounding box) borderSize :: Double, shape :: GlyphShape,@@ -220,10 +214,8 @@ defaultGlyphStyle = GlyphStyle 0.03- (PixelRGB8 217 151 33)- 0.8- (PixelRGB8 44 66 157)- 0.4+ (setAlpha (palette !! 0) 0.8)+ (setAlpha (palette !! 1) 0.4) 0.003 SquareGlyph Nothing@@ -237,8 +229,8 @@ | RectSharpGlyph Double | RectRoundedGlyph Double Double Double | TriangleGlyph (Point Double) (Point Double) (Point Double)- | VLineGlyph- | HLineGlyph+ | VLineGlyph Double+ | HLineGlyph Double | PathGlyph Text deriving (Show, Eq, Generic) @@ -251,29 +243,26 @@ EllipseGlyph _ -> "Ellipse" RectSharpGlyph _ -> "RectSharp" RectRoundedGlyph {} -> "RectRounded"- VLineGlyph -> "VLine"- HLineGlyph -> "HLine"+ VLineGlyph _ -> "VLine"+ HLineGlyph _ -> "HLine" PathGlyph _ -> "Path" -- | line style data LineStyle = LineStyle { width :: Double,- color :: PixelRGB8,- opacity :: Double+ color :: Colour } deriving (Show, Eq, Generic) -- | the official default line style defaultLineStyle :: LineStyle-defaultLineStyle = LineStyle 0.02 blue 0.5+defaultLineStyle = LineStyle 0.012 (palette !! 0) data PixelStyle = PixelStyle- { pixelColorMin :: PixelRGB8,- pixelOpacityMin :: Double,- pixelColorMax :: PixelRGB8,- pixelOpacityMax :: Double,+ { pixelColorMin :: Colour,+ pixelColorMax :: Colour, -- | expressed in directional terms -- 0 for horizontal -- pi/2 for vertical@@ -285,7 +274,7 @@ defaultPixelStyle :: PixelStyle defaultPixelStyle =- PixelStyle grey 1 blue 1 (pi / 2) (RectStyle 0 black 0 black 1) "pixel"+ PixelStyle colorPixelMin colorPixelMax (pi / 2) (blob black) "pixel" -- | Verticle or Horizontal data Orientation = Vert | Hori deriving (Eq, Show, Generic)@@ -299,8 +288,8 @@ toOrientation "Vert" = Vert toOrientation _ = Hori - -- * primitive Chart elements+ -- | unification of a point and rect on the plane data Spot a = SpotPoint (Point a)@@ -308,7 +297,6 @@ 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')@@ -390,7 +378,7 @@ defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoEscapeText NoCssOptions ScaleCharts (ManualAspect 1.5) defaultSvgFrame :: RectStyle-defaultSvgFrame = border 0.01 blue 1.0+defaultSvgFrame = border 0.01 colorFrame -- | In order to create huds, there are three main pieces of state that need to be kept track of: --@@ -445,7 +433,7 @@ Nothing defaultCanvas :: RectStyle-defaultCanvas = blob grey 0.03+defaultCanvas = blob colorCanvas -- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas data Place@@ -486,7 +474,7 @@ deriving (Show, Eq, Generic) defaultBar :: Bar-defaultBar = Bar (RectStyle 0 grey 0 (PixelRGB8 95 3 145) 0.5) 0.005 0.01+defaultBar = Bar (RectStyle 0 colorGlyphTick colorGlyphTick) 0.005 0.01 -- | Options for titles. Defaults to center aligned, and placed at Top of the hud data Title@@ -504,7 +492,7 @@ Title txt ( (#size .~ 0.12)- . (#color .~ PixelRGB8 0 0 0)+ . (#color .~ colorText) $ defaultTextStyle ) PlaceTop@@ -524,26 +512,25 @@ defaultGlyphTick = defaultGlyphStyle & #borderSize .~ 0.005- & #color .~ PixelRGB8 95 3 145- & #opacity .~ 1- & #shape .~ VLineGlyph+ & #borderColor .~ colorGlyphTick+ & #color .~ colorGlyphTick+ & #shape .~ VLineGlyph 0.005 defaultTextTick :: TextStyle defaultTextTick =- defaultTextStyle & #size .~ 0.05+ defaultTextStyle & #size .~ 0.05 & #color .~ colorTextTick defaultLineTick :: LineStyle defaultLineTick = defaultLineStyle- & #color .~ PixelRGB8 168 229 238+ & #color .~ colorLineTick & #width .~ 5.0e-3- & #opacity .~ 0.3 defaultTick :: Tick defaultTick = Tick defaultTickStyle- (Just (defaultGlyphTick, 0.01))+ (Just (defaultGlyphTick, 0.0125)) (Just (defaultTextTick, 0.015)) (Just (defaultLineTick, 0.005)) @@ -612,12 +599,12 @@ 0.1 ( defaultTextStyle & #size .~ 0.08- & #color .~ grey+ & #color .~ colorGrey ) 10 0.1 0.1- (Just (RectStyle 0.02 (PixelRGB8 55 100 160) 0.5 (PixelRGB8 255 255 255) 1))+ (Just (RectStyle 0.02 (palette !! 0) black)) PlaceBottom 0.2
stack.yaml view
@@ -4,12 +4,11 @@ - . extra-deps:- - lucid-svg-0.7.1- - javascript-bridge-0.2.0 - box-0.3.0- - web-rep-0.3.1+ - interpolatedstring-perl6-1.0.2+ - javascript-bridge-0.2.0+ - lucid-svg-0.7.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+ - web-rep-0.4.0