diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +0.7 +=== + +- switch to harpie + 0.6.1 === diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: chart-svg -version: 0.6.1.0 +version: 0.7.0.0 license: BSD-3-Clause license-file: LICENSE copyright: Tony Day (c) 2017 @@ -37,7 +37,7 @@ extra-doc-files: ChangeLog.md other/*.svg - readme.org + readme.md source-repository head type: git @@ -62,19 +62,16 @@ hs-source-dirs: src build-depends: , Color >=0.3.2 && <0.4 - , adjunctions >=4.0 && <5 - , attoparsec >=0.13.2 && <0.15 , base >=4.14 && <5 , bytestring >=0.11.3 && <0.13 , containers >=0.6 && <0.8 , cubicbezier >=0.6 && <0.7 , flatparse >=0.5 && <0.6 - , foldl >=1.4 && <1.5 , formatn >=0.3 && <0.4 + , harpie >=0.1 && <0.2 , markup-parse >=0.1 && <0.2 , mtl >=2.2.2 && <2.4 , numhask >=0.11 && <0.13 - , numhask-array >=0.10 && <0.12 , numhask-space >=0.10 && <0.12 , optics-core >=0.4 && <0.5 , random >=1.2 && <1.3 @@ -98,11 +95,10 @@ test-suite doctests import: ghc2021-stanza - type: exitcode-stdio-1.0 - hs-source-dirs: test main-is: doctests.hs - ghc-options: -threaded + hs-source-dirs: test build-depends: - , base - , chart-svg + , base >=4.14 && <5 , doctest-parallel >=0.3 && <0.4 + ghc-options: -threaded + type: exitcode-stdio-1.0 diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,45 @@ + +# Table of Contents + +1. [Usage](#org829f981) +2. [Examples](#orge2856e9) + +[![img](https://img.shields.io/hackage/v/chart-svg.svg)](https://hackage.haskell.org/package/chart-svg) [![img](https://github.com/tonyday567/chart-svg/workflows/haskell-ci/badge.svg)](https://github.com/tonyday567/chart-svg/actions?query=workflow%3Ahaskell-ci) + +![img](other/banner.svg) + +A charting library targetting SVG. + + + + +# Usage + + :r + :set prompt "> " + :set -XOverloadedLabels + :set -XOverloadedStrings + import Chart + import Optics.Core + lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] + styles = (\c -> defaultLineStyle & #color .~ palette c & #size .~ 0.015) <$> [0..2] + cs = zipWith (\s x -> LineChart s [x]) styles lines + lineExample = mempty & #chartTree .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions + writeChartOptions "other/usage.svg" lineExample + +![img](other/usage.svg) + +See the haddock documentation for a detailed overview. + + + + +# Examples + +To redraw all the examples in Chart.Examples + + import Chart.Examples + writeAllExamples + + ok + diff --git a/readme.org b/readme.org deleted file mode 100644 --- a/readme.org +++ /dev/null @@ -1,44 +0,0 @@ -#+TITLE: chart-svg - -[[https://hackage.haskell.org/package/chart-svg][file:https://img.shields.io/hackage/v/chart-svg.svg]] [[https://github.com/tonyday567/chart-svg/actions?query=workflow%3Ahaskell-ci][file:https://github.com/tonyday567/chart-svg/workflows/haskell-ci/badge.svg]] - -[[file:other/banner.svg]] - -A charting library targetting SVG. - -* Usage - -#+begin_src haskell :file other/usage.svg :results output graphics file :exports both -:r -:set prompt "> " -:set -XOverloadedLabels -:set -XOverloadedStrings -import Chart -import Optics.Core -lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] -styles = (\c -> defaultLineStyle & #color .~ palette c & #size .~ 0.015) <$> [0..2] -cs = zipWith (\s x -> LineChart s [x]) styles lines -lineExample = mempty & #chartTree .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions -writeChartOptions "other/usage.svg" lineExample -#+end_src - -#+RESULTS: -[[file:other/usage.svg]] - -See the haddock documentation for a detailed overview. - -* Examples - -To redraw all the examples in Chart.Examples - -#+begin_src haskell :results output -import Chart.Examples -writeAllExamples -#+end_src - -#+RESULTS: -: ok - - - - diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs --- a/src/Data/Colour.hs +++ b/src/Data/Colour.hs @@ -1,9 +1,7 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE UndecidableInstances #-} -- | Colour representations and combinations. module Data.Colour @@ -18,11 +16,7 @@ showOpacity, opac', opac, - hex, rgb, - toHex, - fromHex, - unsafeFromHex, -- * Palette colours palette, @@ -36,7 +30,6 @@ -- * LCH model LCH (..), - pattern LCH, lLCH', cLCH', hLCH', @@ -45,11 +38,9 @@ lch', alpha', RGB3 (..), - pattern RGB3, rgbd', rgb32colour', LAB (..), - pattern LAB, lcha2colour', xy2ch', @@ -71,23 +62,19 @@ where import Chart.Data -import Data.Attoparsec.Text qualified as A -import Data.Bifunctor import Data.Bool (bool) import Data.ByteString (ByteString) -import Data.Char -import Data.Either import Data.FormatN -import Data.Functor.Rep import Data.List qualified as List import Data.String.Interpolate -import Data.Text (Text, pack) +import Data.Text (Text) import Data.Text qualified as Text -import GHC.Exts import GHC.Generics hiding (prec) import Graphics.Color.Model as M hiding (LCH) import Graphics.Color.Space qualified as S -import NumHask.Array.Fixed +import Harpie.Fixed (Array, array, (!)) +import Harpie.Fixed qualified as F +import Harpie.Shape (KnownNats) import Optics.Core import System.Random import System.Random.Stateful @@ -184,60 +171,10 @@ opac' :: Lens' Colour Double opac' = lens opac (\(Colour r g b _) o -> Colour r g b o) --- | Convert to CSS hex representation. -hex :: Colour -> Text -hex c = toHex c - -- | Sets RGB color but not opacity rgb :: Colour -> Colour -> Colour rgb (Colour r g b _) (Colour _ _ _ o) = Colour r g b o --- | Parse CSS hex text. -parseHex :: A.Parser (Color RGB Double) -parseHex = - fmap toDouble - . ( \((r, g), b) -> - ColorRGB (fromIntegral r) (fromIntegral g) (fromIntegral b) :: Color RGB Word8 - ) - . (\(f, b) -> (f `divMod` (256 :: Int), b)) - . (`divMod` 256) - <$> (A.string "#" *> A.hexadecimal) - --- | Convert CSS hex to Colour -fromHex :: Text -> Either Text (Color RGB Double) -fromHex = first pack . A.parseOnly parseHex - --- | Convert CSS hex to Colour, unsafely. -unsafeFromHex :: Text -> Color RGB Double -unsafeFromHex t = fromRight (ColorRGB 0 0 0) $ A.parseOnly parseHex t - --- | Convert from 'Colour' to CSS hex (#xxxxxx) -toHex :: Colour -> Text -toHex c = - "#" - <> Text.justifyRight 2 '0' (hex' r) - <> Text.justifyRight 2 '0' (hex' g) - <> Text.justifyRight 2 '0' (hex' b) - where - (ColorRGBA r g b _) = fromIntegral . toWord8 <$> color' c - -hex' :: Int -> Text -hex' n - | n < 0 = "-" <> go (-n) - | otherwise = go n - where - go n' - | n' < 16 = hexDigit n' - | otherwise = go (n' `quot` 16) <> hexDigit (n' `rem` 16) - -hexDigit :: Int -> Text -hexDigit n - | n <= 9 = Text.singleton $! i2d n - | otherwise = Text.singleton $! toEnum (n + 87) - -i2d :: Int -> Char -i2d x = chr (ord '0' + x) - -- | Select a Colour from the palette -- -- >>> palette 0 @@ -313,6 +250,9 @@ transparent :: Colour transparent = Colour 0 0 0 0 +class ArrayAs f s a where + arrayAs :: (KnownNats s) => Array s a -> f a + -- | LCH colour representation -- -- oklab is a colour space being written into CSS specifications, that attempts to be ok at human-consistent colour representation. See: @@ -328,16 +268,10 @@ -- C: Chromacity, which ranges from 0 to around 0.32 or so. -- -- H: Hue, which ranges from 0 to 360 -newtype LCH a = LCH' {lchArray :: Array '[3] a} deriving (Eq, Show, IsList, Functor) - --- | LCH colour pattern -pattern LCH :: a -> a -> a -> LCH a -pattern LCH l c h <- - LCH' [l, c, h] - where - LCH l c h = LCH' [l, c, h] +data LCH a = LCH a a a deriving (Eq, Show, Functor) -{-# COMPLETE LCH #-} +instance ArrayAs LCH '[3] a where + arrayAs a = LCH (a ! [0]) (a ! [1]) (a ! [2]) -- | Lightness lens for LCH lLCH' :: Lens' (LCH Double) Double @@ -365,25 +299,19 @@ -- | LCHA pattern pattern LCHA :: Double -> Double -> Double -> Double -> LCHA pattern LCHA l c h a <- - LCHA' (LCH' [l, c, h]) a + LCHA' (LCH l c h) a where - LCHA l c h a = LCHA' (LCH' [l, c, h]) a + LCHA l c h a = LCHA' (LCH l c h) a {-# COMPLETE LCHA #-} -- * RGB colour representation -- | A type to represent the RGB triple, useful as an intermediary between 'Colour' and 'LCHA' -newtype RGB3 a = RGB3' {rgb3Array :: Array '[3] a} deriving (Eq, Show, IsList, Functor) - --- | The RGB3 pattern -pattern RGB3 :: a -> a -> a -> RGB3 a -pattern RGB3 r g b <- - RGB3' [r, g, b] - where - RGB3 r g b = RGB3' [r, g, b] +data RGB3 a = RGB3 a a a deriving (Eq, Show, Functor) -{-# COMPLETE RGB3 #-} +instance ArrayAs RGB3 '[3] a where + arrayAs a = RGB3 (a ! [0]) (a ! [1]) (a ! [2]) -- | Lens for conversion between Double and Word8 RGB triples. rgbd' :: Iso' (RGB3 Double) (RGB3 Word8) @@ -396,16 +324,10 @@ -- * LAB colour representation -- | LAB colour representation. a is green-red and b is blue-yellow -newtype LAB a = LAB' {labArray :: Array '[3] a} deriving (Eq, Show, IsList, Functor) - --- | LAB pattern -pattern LAB :: a -> a -> a -> LAB a -pattern LAB l a b <- - LAB' [l, a, b] - where - LAB l a b = LAB' [l, a, b] +data LAB a = LAB a a a deriving (Eq, Show, Functor) -{-# COMPLETE LAB #-} +instance ArrayAs LAB '[3] a where + arrayAs a = LAB (a ! [0]) (a ! [1]) (a ! [2]) -- * Colour conversions @@ -415,14 +337,14 @@ -- -- >>> c0 = Colour 0.78 0.36 0.02 1.00 -- >>> view (re lcha2colour') c0 --- LCHA' {_lch = LCH' {lchArray = [0.5969891006896103, 0.15793931531669247, 49.191113810479784]}, _alpha = 1.0} +-- LCHA' {_lch = LCH 0.5969891006896103 0.15793931531669247 49.191113810479784, _alpha = 1.0} -- -- >>> view (re lcha2colour' % lcha2colour') c0 -- Colour 0.78 0.36 0.02 1.00 -- -- >>> c1 = Colour 0.49 0.14 0.16 1 -- >>> view (re lcha2colour') c1 --- LCHA' {_lch = LCH' {lchArray = [0.40115567099848914, 0.12279066817938503, 21.51476756026837]}, _alpha = 1.0} +-- LCHA' {_lch = LCH 0.40115567099848914 0.12279066817938503 21.51476756026837, _alpha = 1.0} -- -- >>> view (re lcha2colour' % lcha2colour') c1 -- Colour 0.49 0.14 0.16 1.00 @@ -457,50 +379,52 @@ rgb2lab' :: Iso' (RGB3 Double) (LAB Double) rgb2lab' = iso - (\(RGB3' a) -> LAB' . xyz2lab_ . rgb2xyz_ $ a) - (\(LAB' a) -> RGB3' . xyz2rgb_ . lab2xyz_ $ a) + (\(RGB3 r g b) -> arrayAs . xyz2lab_ . rgb2xyz_ $ array [r, g, b]) + (\(LAB l a b) -> arrayAs . xyz2rgb_ . lab2xyz_ $ array [l, a, b]) -- * rgb to xyz -xyz2rgb_ :: Array '[3] Double -> Array '[3] Double -xyz2rgb_ a = fromList [r, g, b] +xyz2rgb_ :: F.Array '[3] Double -> F.Array '[3] Double +xyz2rgb_ a = array [r, g, b] where - (S.ColorSRGB r g b) = S.xyz2rgb (S.ColorXYZ (a `index` [0]) (a `index` [1]) (a `index` [2])) :: Color (S.SRGB 'S.NonLinear) Double + (S.ColorSRGB r g b) = S.xyz2rgb (S.ColorXYZ (a ! [0]) (a ! [1]) (a ! [2])) :: Color (S.SRGB 'S.NonLinear) Double -- >>> rgb2xyz_ [1,1,1] -- [0.9505, 1.0, 1.089] -rgb2xyz_ :: Array '[3] Double -> Array '[3] Double -rgb2xyz_ a = fromList [x, y, z] +rgb2xyz_ :: F.Array '[3] Double -> F.Array '[3] Double +rgb2xyz_ a = array [x, y, z] where - (S.ColorXYZ x y z) = S.rgb2xyz (S.ColorSRGB (a `index` [0]) (a `index` [1]) (a `index` [2])) :: Color (S.XYZ S.D65) Double + (S.ColorXYZ x y z) = S.rgb2xyz (S.ColorSRGB (a ! [0]) (a ! [1]) (a ! [2])) :: Color (S.XYZ S.D65) Double -- * xyz to lab -m1 :: Array '[3, 3] Double +m1 :: F.Array '[3, 3] Double m1 = - [ 0.8189330101, - 0.3618667424, - -0.1288597137, - 0.0329845436, - 0.9293118715, - 0.0361456387, - 0.0482003018, - 0.2643662691, - 0.6338517070 - ] + array + [ 0.8189330101, + 0.3618667424, + -0.1288597137, + 0.0329845436, + 0.9293118715, + 0.0361456387, + 0.0482003018, + 0.2643662691, + 0.6338517070 + ] -m2 :: Array '[3, 3] Double +m2 :: F.Array '[3, 3] Double m2 = - [ 0.2104542553, - 0.7936177850, - -0.0040720468, - 1.9779984951, - -2.4285922050, - 0.4505937099, - 0.0259040371, - 0.7827717662, - -0.8086757660 - ] + array + [ 0.2104542553, + 0.7936177850, + -0.0040720468, + 1.9779984951, + -2.4285922050, + 0.4505937099, + 0.0259040371, + 0.7827717662, + -0.8086757660 + ] cubicroot :: (Floating a, Ord a) => a -> a cubicroot x = bool ((-1) * (-x) ** (1 / 3.0)) (x ** (1 / 3.0)) (x >= 0) @@ -519,39 +443,41 @@ -- -- >>> xyz2lab_ [0,0,1] -- [0.15260258004008057, -1.4149965510120839, -0.4489272035597538] -xyz2lab_ :: Array '[3] Double -> Array '[3] Double +xyz2lab_ :: F.Array '[3] Double -> F.Array '[3] Double xyz2lab_ xyz = - dot sum (*) m2 (cubicroot <$> dot sum (*) m1 xyz) + F.dot sum (*) m2 (cubicroot <$> F.dot sum (*) m1 xyz) -m1' :: Array '[3, 3] Double +m1' :: F.Array '[3, 3] Double m1' = - [ 1.227013851103521026, - -0.5577999806518222383, - 0.28125614896646780758, - -0.040580178423280593977, - 1.1122568696168301049, - -0.071676678665601200577, - -0.076381284505706892869, - -0.42148197841801273055, - 1.5861632204407947575 - ] + array + [ 1.227013851103521026, + -0.5577999806518222383, + 0.28125614896646780758, + -0.040580178423280593977, + 1.1122568696168301049, + -0.071676678665601200577, + -0.076381284505706892869, + -0.42148197841801273055, + 1.5861632204407947575 + ] -m2' :: Array '[3, 3] Double +m2' :: F.Array '[3, 3] Double m2' = - [ 0.99999999845051981432, - 0.39633779217376785678, - 0.21580375806075880339, - 1.0000000088817607767, - -0.1055613423236563494, - -0.063854174771705903402, - 1.0000000546724109177, - -0.089484182094965759684, - -1.2914855378640917399 - ] + array + [ 0.99999999845051981432, + 0.39633779217376785678, + 0.21580375806075880339, + 1.0000000088817607767, + -0.1055613423236563494, + -0.063854174771705903402, + 1.0000000546724109177, + -0.089484182094965759684, + -1.2914855378640917399 + ] -lab2xyz_ :: Array '[3] Double -> Array '[3] Double +lab2xyz_ :: F.Array '[3] Double -> F.Array '[3] Double lab2xyz_ lab = - dot sum (*) m1' ((** 3.0) <$> dot sum (*) m2' lab) + F.dot sum (*) m1' ((** 3.0) <$> F.dot sum (*) m2' lab) -- * mixins diff --git a/src/Data/Path.hs b/src/Data/Path.hs --- a/src/Data/Path.hs +++ b/src/Data/Path.hs @@ -9,6 +9,7 @@ pointPath, movePath, scalePath, + projectPath, projectPaths, pathBoxes, pathBox, @@ -44,8 +45,6 @@ where import Chart.Data -import Control.Foldl qualified as L -import Control.Monad.State.Lazy import GHC.Generics import Geom2D.CubicBezier qualified as B import NumHask.Prelude @@ -107,16 +106,7 @@ -- | Project a list of connected PathDatas from one Rect (XY plave) to a new one. projectPaths :: Rect Double -> Rect Double -> [PathData Double] -> [PathData Double] -projectPaths new old ps = - flip evalState zero $ - mapM - ( \p -> do - x <- get - let d = projectPath new old x p - put (pointPath d) - pure d - ) - ps +projectPaths new old ps = snd $ mapAccumL (\s a -> let d = projectPath new old s a in (pointPath d, d)) zero ps -- | Project a PathData from one Rect (XY plave) to a new one. projectPath :: @@ -493,7 +483,8 @@ pathBoxes [] = Nothing pathBoxes (x : xs) = Just $ - L.fold (L.Fold step begin snd) xs + snd $ + foldl' step begin xs where begin :: (Point Double, Rect Double) begin = (pointPath x, singleton (pointPath x))