diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Changelog + +## 0.1.0.0 + +First release. + +- `diagram` places a diagrams-lib `Diagram` in a nano-ui layout, drawn + through a nano-ui backend for diagrams. +- `NanoUI.Plot` builds line, bar, scatter, area and step charts with axes, + legends, and hover lookup, and decimates long series before drawing them. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2026 goolord + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# nano-ui-diagrams + +Charts and [diagrams](https://diagrams.github.io/) drawings for +[nano-ui](https://github.com/goolord/nano-ui). + +`diagram` places a diagrams-lib `Diagram` in a nano-ui layout. `NanoUI.Plot` +builds line, bar, scatter, area, and step charts with axes, legends, and hover +lookup, and thins out long series before drawing them. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Data.Text qualified as T +import NanoUI +import NanoUI.Plot + +temperatures :: Chart +temperatures = + withTitle "Temperature" . withLegend LegendBottom $ + chart + [ line "Indoor" [(0, 20), (1, 21.5), (2, 22), (3, 21)] + , line "Outdoor" [(0, 8), (1, 11), (2, 14), (3, 12)] + ] + +view :: NanoUI () +view = column $ do + resp <- plot (minH 240 . fillW) temperatures + case plotHover resp of + Just h -> label (T.pack (show (hoverDataX h, hoverDataY h))) + Nothing -> pure () +``` + +The Plots tab of `nano-ui-sdl-demo` in `nano-ui-demo` shows more charts and a +diagram. diff --git a/lib/NanoUI/Diagrams.hs b/lib/NanoUI/Diagrams.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Diagrams.hs @@ -0,0 +1,11 @@ +-- | The whole nano-ui-diagrams API: the diagrams-lib backend, the diagram +-- widgets, and "NanoUI.Plot". +module NanoUI.Diagrams + ( module NanoUI.Diagrams.Backend + , module NanoUI.Diagrams.Widget + , module NanoUI.Plot + ) where + +import NanoUI.Diagrams.Backend +import NanoUI.Diagrams.Widget +import NanoUI.Plot diff --git a/lib/NanoUI/Diagrams/Backend.hs b/lib/NanoUI/Diagrams/Backend.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Diagrams/Backend.hs @@ -0,0 +1,252 @@ +-- | A diagrams-lib backend that renders a diagram to nano-ui @DrawOp@ values, +-- scaled into a target size. +module NanoUI.Diagrams.Backend + ( NanoUIBackend (..) + , B + , diagramOps + , diagramTextOps + , letterbox + ) +where + +import Control.Lens (Lens', (^.), (^?)) +import Data.Colour (AlphaColour, alphaChannel, black, over) +import Data.Colour.SRGB (RGB (..), toSRGB) +import Data.DList (DList) +import Data.DList qualified as DL +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Tree (Tree (Node)) +import Data.Typeable (Typeable) +import Data.Primitive.SmallArray (SmallArray, emptySmallArray, mapSmallArray', smallArrayFromList) +import Diagrams.Attributes (_lineWidthU) +import Diagrams.Core + ( Backend (..) + , N + , QDiagram + , Renderable (..) + , V + , renderDia + ) +import Diagrams.Core qualified as DiaCore +import Diagrams.Core.Types (Annotation, RNode (..), RTree) +import Diagrams.Located (Located, unLoc) +import Diagrams.Path (Path, pathTrails) +import Diagrams.Prelude + ( Any + , P2 + , SizeSpec + , Trail + , V2 (..) + , origin + , p2 + , papply + , reflectY + , reflectionY + , size + , unp2 + , (#) + ) +import Diagrams.Segment (FixedSegment (..)) +import Diagrams.Trail (fixTrail, isLoop) +import Diagrams.TwoD.Adjust (adjustDia2D) +import Diagrams.TwoD.Attributes (_AC, _fillTexture, _lineTexture) +import Diagrams.TwoD.Size (mkHeight) +import Diagrams.TwoD.Text (Text (..), TextAlignment (..)) +import NanoUI + ( Color + , DrawOp (..) + , colorA + , colorRGBA + , defaultTheme + , shiftDrawOp + , themeMuted + ) +import NanoUI.Diagrams.Tessellation + ( fillPolygon + , flattenCubic + , strokePolyline + ) + +data NanoUIBackend = NanoUIBackend + deriving (Eq, Show) + +type B = NanoUIBackend + +type instance V NanoUIBackend = V2 + +type instance N NanoUIBackend = Double + +fullSize :: Lens' (Options NanoUIBackend V2 n) (SizeSpec V2 n) +fullSize f (NanoUIOptions sz textOnly) = fmap (\sz' -> NanoUIOptions sz' textOnly) (f sz) + +instance (Typeable n, RealFloat n) => Backend NanoUIBackend V2 n where + newtype Render NanoUIBackend V2 n + = NRenderFull (Bool -> DiaCore.Style V2 n -> DList DrawOp) + type Result NanoUIBackend V2 n = SmallArray DrawOp + data Options NanoUIBackend V2 n = NanoUIOptions (SizeSpec V2 n) Bool + renderRTree _ (NanoUIOptions _ textOnly) rt = smallArrayFromList (DL.toList (walkFull textOnly mempty rt)) + adjustDia c opts d = (sz, t <> reflectionY, d') + where + (sz, t, d') = adjustDia2D fullSize c opts (d # reflectY) + +instance Semigroup (Render NanoUIBackend V2 n) where + NRenderFull f <> NRenderFull g = NRenderFull (\textOnly sty -> f textOnly sty <> g textOnly sty) + +instance Monoid (Render NanoUIBackend V2 n) where + mempty = NRenderFull (\_ _ -> DL.empty) + +walkFull :: + (Typeable n, RealFloat n) => + Bool + -> DiaCore.Style V2 n + -> RTree NanoUIBackend V2 n Annotation + -> DList DrawOp +walkFull textOnly sty (Node n cs) = + case n of + RPrim prim -> + let + NRenderFull f = render NanoUIBackend prim + in + f textOnly sty + RStyle s -> foldMap (walkFull textOnly (sty <> s)) cs + _ -> foldMap (walkFull textOnly sty) cs + +instance (Typeable n, RealFloat n) => Renderable (Path V2 n) NanoUIBackend where + render _ path = NRenderFull $ \textOnly sty -> + if textOnly + then DL.empty + else foldMap (DL.fromList . trailOps sty) (pathTrails path) + +textOps :: + (Typeable n, RealFloat n) => Text n -> DiaCore.Style V2 n -> DList DrawOp +textOps (Text tr align str) sty + | null str = DL.empty + | otherwise = + let + p = papply tr origin + (x, y) = unp2 p + (ax, ay) = + case align of + BaselineText -> (0, -1) + BoxAlignedText bx by -> (toF bx, toF by) + col = + case solidColour (sty ^? (_fillTexture . _AC)) of + Just c -> c + Nothing -> + fromMaybe + (themeMuted defaultTheme) + (solidColour (sty ^? (_lineTexture . _AC))) + in + DL.singleton (DrawText (toF x) (toF y) ax ay (T.pack str) col) + +instance (Typeable n, RealFloat n) => Renderable (Text n) NanoUIBackend where + render _ t = NRenderFull (const (textOps t)) + +trailOps :: + (Typeable n, RealFloat n) => + DiaCore.Style V2 n -> Located (Trail V2 n) -> [DrawOp] +trailOps sty lt = + let + pts = [(toF x, toF y) | (x, y) <- map unp2 (trailSamples lt)] + lineW0 = sty ^. _lineWidthU + lineW = + case fmap toF lineW0 of + Nothing -> 1 + Just w + | w <= 0 -> 0 + | w < 1 -> 1 + | otherwise -> w + fillC = solidColour (sty ^? (_fillTexture . _AC)) + lineC = solidColour (sty ^? (_lineTexture . _AC)) + closed = isLoop (unLoc lt) + fills = + case fillC of + Just c + | colorA c > 0 && closed && length pts >= 3 -> fillPolygon c pts + _ -> [] + strokes = + case lineC of + Just c + | colorA c > 0 && lineW > 0 && length pts >= 2 -> + strokePolyline c lineW closed pts + _ -> [] + in + fills ++ strokes + +trailSamples :: RealFloat n => Located (Trail V2 n) -> [P2 n] +trailSamples lt = + case map sampleSeg (fixTrail lt) of + [] -> [] + (firstSeg : rest) -> + let + pts = firstSeg ++ concatMap (drop 1) rest + in + if isLoop (unLoc lt) && not (null pts) + then pts ++ take 1 pts + else pts + +sampleSeg :: RealFloat n => FixedSegment V2 n -> [P2 n] +sampleSeg (FLinear p0 p1) = [p0, p1] +sampleSeg (FCubic p0 c1 c2 p1) = + [ p2 (realToFrac x, realToFrac y) + | (x, y) <- flattenCubic (f p0) (f c1) (f c2) (f p1) + ] + where + f p = let (x, y) = unp2 p in (toF x, toF y) + +solidColour :: Maybe (AlphaColour Double) -> Maybe Color +solidColour mc = do + ac <- mc + let + a = alphaChannel ac + if a <= 0 + then Nothing + else + let + RGB r g b = toSRGB (ac `over` black) + q x = round (clamp01 x * 255) + in + Just (colorRGBA (q r) (q g) (q b) (q a)) + +clamp01 :: Double -> Double +clamp01 x = max 0 (min 1 x) + +toF :: Real n => n -> Float +toF = realToFrac + +diagramOps :: + Double -> Double -> QDiagram NanoUIBackend V2 Double Any -> SmallArray DrawOp +diagramOps = renderFull False + +diagramTextOps :: + Double -> Double -> QDiagram NanoUIBackend V2 Double Any -> SmallArray DrawOp +-- Text uses the same backend and viewport as geometry. In particular, do not +-- coerce a QDiagram between backends: its primitives carry Renderable dictionaries. +diagramTextOps = renderFull True + +renderFull :: + Bool + -> Double + -> Double + -> QDiagram NanoUIBackend V2 Double Any + -> SmallArray DrawOp +renderFull textOnly w h d + | w <= 0 || h <= 0 = emptySmallArray + | otherwise = + let + V2 dw dh = size d + (_, outH, dx, dy) = letterbox dw dh w h + ops = renderDia NanoUIBackend (NanoUIOptions (mkHeight outH) textOnly) d + in + mapSmallArray' (shiftDrawOp (realToFrac dx) (realToFrac dy)) ops + +-- | Scale a @dw@ by @dh@ diagram uniformly to fit a @w@ by @h@ box and centre +-- it: the drawn width and height, and the x and y offsets inside the box. +letterbox :: Double -> Double -> Double -> Double -> (Double, Double, Double, Double) +letterbox dw dh w h = + let + outH = if dw <= 1e-9 || dh <= 1e-9 then h else min h (w * dh / dw) + outW = if dh <= 1e-9 then w else outH * dw / dh + in + (outW, outH, (w - outW) / 2, (h - outH) / 2) diff --git a/lib/NanoUI/Diagrams/Tessellation.hs b/lib/NanoUI/Diagrams/Tessellation.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Diagrams/Tessellation.hs @@ -0,0 +1,250 @@ +-- | Polygon triangulation and filling, polyline stroking, and cubic Bezier +-- flattening for the diagrams backend. +module NanoUI.Diagrams.Tessellation + ( triangulatePolygon + , fillPolygon + , strokePolyline + , flattenCubic + ) where + +import Control.Monad (forM_) +import Control.Monad.ST (runST) +import Data.Primitive.PrimArray + ( PrimArray + , indexPrimArray + , newPrimArray + , readPrimArray + , runPrimArray + , sizeofPrimArray + , writePrimArray + ) +import NanoUI (Color, DrawOp (..), Rect (..)) + +bezierTolerance :: Float +bezierTolerance = 0.5 + +triangulatePolygon :: [(Float, Float)] -> [((Float, Float), (Float, Float), (Float, Float))] +triangulatePolygon [] = [] +triangulatePolygon [_] = [] +triangulatePolygon pts0 = + let pts = stripClosed pts0 + in earClip (pointsArray pts) + +stripClosed :: [(Float, Float)] -> [(Float, Float)] +stripClosed [] = [] +stripClosed [p] = [p] +stripClosed (p : rest) + | p == last rest = p : init rest + | otherwise = p : rest + +-- | Points stored as x then y. +pointsArray :: [(Float, Float)] -> PrimArray Float +pointsArray pts = runPrimArray $ do + out <- newPrimArray (2 * length pts) + let fill !_ [] = pure out + fill !i ((x, y) : rest) = do + writePrimArray out (2 * i) x + writePrimArray out (2 * i + 1) y + fill (i + 1) rest + fill 0 pts + +{-# INLINE pointAt #-} +pointAt :: PrimArray Float -> Int -> (Float, Float) +pointAt vs i = (indexPrimArray vs (2 * i), indexPrimArray vs (2 * i + 1)) + +signedArea :: PrimArray Float -> Float +signedArea vs = + let n = sizeofPrimArray vs `div` 2 + in foldl' (\acc i -> acc + cross (pointAt vs i) (pointAt vs ((i + 1) `mod` n)) / 2) 0 [0 .. n - 1] + +cross :: (Float, Float) -> (Float, Float) -> Float +cross (x0, y0) (x1, y1) = x0 * y1 - x1 * y0 + +diff :: (Float, Float) -> (Float, Float) -> (Float, Float) +diff (x0, y0) (x1, y1) = (x1 - x0, y1 - y0) + +isConvex :: Bool -> (Float, Float) -> (Float, Float) -> (Float, Float) -> Bool +isConvex ccw a b c = + let ab = diff a b + bc = diff b c + in if ccw then cross ab bc >= 0 else cross ab bc <= 0 + +pointInTri :: (Float, Float) -> (Float, Float) -> (Float, Float) -> (Float, Float) -> Bool +pointInTri p a b c = + let sign (p1, p2, p3) = cross (diff p1 p3) (diff p2 p3) + d1 = sign (p, a, b) + d2 = sign (p, b, c) + d3 = sign (p, c, a) + in not ((d1 < 0 || d2 < 0 || d3 < 0) && (d1 > 0 || d2 > 0 || d3 > 0)) + +earClip :: PrimArray Float -> [((Float, Float), (Float, Float), (Float, Float))] +earClip vs + | n < 3 = [] + | n == 3 = [(at 0, at 1, at 2)] + | otherwise = runST $ do + let !ccw = signedArea vs >= 0 + -- Coordinates never move. Remove an ear by relinking two neighbours, + -- instead of copying the remaining coordinates at every step. + prevs <- newPrimArray n + nexts <- newPrimArray n + forM_ [0 .. n - 1] $ \i -> do + writePrimArray prevs i ((i - 1 + n) `mod` n) + writePrimArray nexts i ((i + 1) `mod` n) + let triangle i = do + p <- readPrimArray prevs i + q <- readPrimArray nexts i + pure (p, q, (at p, at i, at q)) + isEarAt first count i p q (a, b, c) + | not (isConvex ccw a b c) = pure False + | otherwise = outside first count + where + outside !_ 0 = pure True + outside !j !left + | j /= p && j /= i && j /= q && pointInTri (at j) a b c = pure False + | otherwise = do + next <- readPrimArray nexts j + outside next (left - 1) + convex !_ 0 = pure True + convex !i !left = do + (_, q, (a, b, c)) <- triangle i + if isConvex ccw a b c then convex q (left - 1) else pure False + fan origin i left + | left <= 0 = pure [] + | otherwise = do + q <- readPrimArray nexts i + rest <- fan origin q (left - 1) + pure ((at origin, at i, at q) : rest) + go !first !count !idx !tries tris + | count == 3 = do + second <- readPrimArray nexts first + third <- readPrimArray nexts second + pure ((at first, at second, at third) : tris) + | tries >= count = do + isConvexRing <- convex first count + if isConvexRing then do + second <- readPrimArray nexts first + rest <- fan first second (count - 2) + pure (tris ++ rest) + else pure tris + | otherwise = do + (p, q, tri) <- triangle idx + ear <- isEarAt first count idx p q tri + if ear then do + writePrimArray nexts p q + writePrimArray prevs q p + let !first' = if idx == first then q else first + go first' (count - 1) first' 0 (tri : tris) + else go first count q (tries + 1) tris + reverse <$> go 0 n 0 0 [] + where + n = sizeofPrimArray vs `div` 2 + at = pointAt vs + +fillPolygon :: Color -> [(Float, Float)] -> [DrawOp] +fillPolygon col pts = + case axisAlignedRect pts of + Just r -> [FillRect r col] + Nothing -> + [ FillTriangle x0 y0 x1 y1 x2 y2 col + | ((x0, y0), (x1, y1), (x2, y2)) <- triangulatePolygon pts + ] + +axisAlignedRect :: [(Float, Float)] -> Maybe Rect +axisAlignedRect pts = + case stripClosed pts of + [(x0, y0), (x1, y1), (x2, y2), (x3, y3)] + | near y0 y1 && near x1 x2 && near y2 y3 && near x3 x0 -> + Just (Rect (min x0 x3) (min y0 y2) (abs (x1 - x0)) (abs (y2 - y0))) + [(x0, y0), (x1, y1), (x2, y2), (x3, y3)] + | near x0 x1 && near y1 y2 && near x2 x3 && near y3 y0 -> + Just (Rect (min x0 x2) (min y0 y1) (abs (x2 - x0)) (abs (y1 - y0))) + _ -> Nothing + where + near a b = abs (a - b) <= 1e-3 + + +strokePolyline :: Color -> Float -> Bool -> [(Float, Float)] -> [DrawOp] +strokePolyline _ _ _ [] = [] +strokePolyline _ _ _ [_] = [] +strokePolyline col w closed pts0 = + let pts = if closed && length pts0 > 2 then stripClosed pts0 else pts0 + hw = w / 2 + !vPts = pointsArray pts + !n = sizeofPrimArray vPts `div` 2 + in if n < 2 + then [] + else + let !segCount = if closed then n else n - 1 + -- Each segment's unit normal, x then y. + !segNormals = runPrimArray $ do + out <- newPrimArray (2 * segCount) + forM_ [0 .. segCount - 1] $ \i -> do + let !(p0x, p0y) = pointAt vPts i + !(p1x, p1y) = pointAt vPts ((i + 1) `mod` n) + nx = p0y - p1y + ny = p1x - p0x + d = sqrt (nx * nx + ny * ny) + writePrimArray out (2 * i) (if d <= 1e-9 then 0 else nx / d) + writePrimArray out (2 * i + 1) (if d <= 1e-9 then 0 else ny / d) + pure out + joinNormal !i + | not closed && i <= 0 = pointAt segNormals 0 + | not closed && i >= n - 1 = pointAt segNormals (segCount - 1) + | otherwise = + let (ax, ay) = pointAt segNormals ((i - 1 + segCount) `mod` segCount) + (bx, by) = pointAt segNormals (i `mod` segCount) + sx = ax + bx + sy = ay + by + d = sqrt (sx * sx + sy * sy) + in if d <= 1e-9 then (0, 0) else (sx / d, sy / d) + -- Adjacent quads share a vertex, so offset each vertex once: the + -- two sides' points, four numbers a vertex. + !offsets = runPrimArray $ do + out <- newPrimArray (4 * n) + forM_ [0 .. n - 1] $ \i -> do + let (!px, !py) = pointAt vPts i + (!nx, !ny) = joinNormal i + writePrimArray out (4 * i) (px + hw * nx) + writePrimArray out (4 * i + 1) (py + hw * ny) + writePrimArray out (4 * i + 2) (px - hw * nx) + writePrimArray out (4 * i + 3) (py - hw * ny) + pure out + offset i k = indexPrimArray offsets (4 * i + k) + buildQuads !i + | i >= segCount = [] + | otherwise = + let !j = if closed then (i + 1) `mod` n else i + 1 + in FillTriangle (offset i 0) (offset i 1) (offset j 0) (offset j 1) (offset j 2) (offset j 3) col + : FillTriangle (offset i 0) (offset i 1) (offset j 2) (offset j 3) (offset i 2) (offset i 3) col + : buildQuads (i + 1) + in buildQuads 0 + +flattenCubic :: + (Float, Float) -> + (Float, Float) -> + (Float, Float) -> + (Float, Float) -> + [(Float, Float)] +flattenCubic p0 c1 c2 p1 = go p0 c1 c2 p1 + where + go a b c d = + let mid (p, q) = ((fst p + fst q) / 2, (snd p + snd q) / 2) + ab = mid (a, b) + bc = mid (b, c) + cd = mid (c, d) + abbc = mid (ab, bc) + bccd = mid (bc, cd) + mid12 = mid (abbc, bccd) + flat = + let (dx, dy) = diff d a + len = sqrt (dx * dx + dy * dy) + dist = + if len <= 1e-9 + then 0 + else abs (cross (diff b a) (dx, dy)) / len + in dist <= bezierTolerance + in if flat + then [a, d] + else + let rest = go mid12 bccd cd d + in go a ab abbc mid12 ++ drop 1 rest diff --git a/lib/NanoUI/Diagrams/Widget.hs b/lib/NanoUI/Diagrams/Widget.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Diagrams/Widget.hs @@ -0,0 +1,327 @@ +-- | Widgets that place a diagram in a nano-ui layout, and the plot style +-- derived from the current theme. +module NanoUI.Diagrams.Widget + ( diagram + , diagramWithEnvelope + , diagramWithKeyAndEnvelope + , fitLayout + , labelFitScale + , diagramFrame + , frameInner + , PlotStyle (..) + , themePlotStyle + , defaultPlotStyle + , uiPlotStyle + , colourOf + , themePlotKey + ) where + + +import Data.Colour (Colour) +import Data.Colour.SRGB (sRGB24) +import Data.Hashable (hash, hashWithSalt) +import Data.Primitive.PrimArray (indexPrimArray, newPrimArray, runPrimArray, writePrimArray) +import Data.Primitive.SmallArray (SmallArray, emptySmallArray, indexSmallArray, mapSmallArray', sizeofSmallArray, smallArrayFromList) +import Diagrams.Core (QDiagram) +import Diagrams.Prelude (Any, Diagram, V2 (..), size) +import Effectful (Eff, type (:>)) +import NanoUI + ( Color + , DrawOp (..) + , FontMetrics (..) + , Layout (..) + , Rect (..) + , Response + , Sizing (..) + , Style (..) + , Theme (..) + , Ui + , colorB + , colorG + , colorR + , colorToWord32 + , defaultLayout + , defaultTheme + , drawTextBox + , drawingCached + , lerpColor + , shiftDrawOp + , styleBg + , styleBorder + , themeAccent + , themeGreen + , themeMuted + , themeOrange + , themePurple + , themeRed + , themeSeparator + , themeWindow + , themeYellow + , uiFontMetrics + , prepareFontMetricsMany + , uiTheme + ) +import NanoUI.Context (lookupDrawFitEnvelope) +import NanoUI.Monad (askContext, currentId, uiIO) +import NanoUI.Diagrams.Backend + ( B + , NanoUIBackend + , diagramOps + , diagramTextOps + ) + +data PlotStyle = PlotStyle + { plotInk :: Colour Double + , plotFill :: Colour Double + , plotGrid :: Colour Double + , plotMuted :: Colour Double + , plotFrameBg :: Color + , plotFrameBorder :: Color + } + deriving (Eq, Show) + +colourOf :: Color -> Colour Double +colourOf c = sRGB24 (colorR c) (colorG c) (colorB c) + +themePlotStyle :: Theme -> PlotStyle +themePlotStyle t = + let muted = themeMuted t + panel = themePanel t + in PlotStyle + { plotInk = colourOf (themeRed t) + , plotFill = colourOf (lerpColor (themeAccent t) muted 0.22) + , plotGrid = colourOf (lerpColor (themeSeparator t) muted 0.30) + , plotMuted = colourOf muted + , plotFrameBg = styleBg (themeInput t) + , plotFrameBorder = styleBorder panel + } + +defaultPlotStyle :: PlotStyle +defaultPlotStyle = themePlotStyle defaultTheme + +themePlotKey :: Theme -> Int +themePlotKey t = + hash (colorToWord32 (themeAccent t)) + `hashWithSalt` colorToWord32 (themeMuted t) + `hashWithSalt` colorToWord32 (themeRed t) + `hashWithSalt` colorToWord32 (themeOrange t) + `hashWithSalt` colorToWord32 (themeYellow t) + `hashWithSalt` colorToWord32 (themeGreen t) + `hashWithSalt` colorToWord32 (themePurple t) + `hashWithSalt` colorToWord32 (themeSeparator t) + `hashWithSalt` colorToWord32 (themeWindow t) + `hashWithSalt` colorToWord32 (styleBg (themePanel t)) + `hashWithSalt` colorToWord32 (styleBorder (themePanel t)) + `hashWithSalt` colorToWord32 (styleBg (themeInput t)) + +uiPlotStyle :: Ui :> es => Eff es PlotStyle +uiPlotStyle = fmap themePlotStyle uiTheme + +labelFitScale :: FontMetrics -> SmallArray DrawOp -> Double +labelFitScale fm ops = + let -- Six numbers a label: its anchor, and its box's origin and size. + !n = foldl' (\c op -> case op of DrawText {} -> c + 1; _ -> c) 0 ops + !ts = runPrimArray $ do + out <- newPrimArray (n * 6) + let fill !i !b + | i >= sizeofSmallArray ops = pure out + | otherwise = case indexSmallArray ops i of + DrawText x y ax ay t _ -> do + let Rect px py tw th = drawTextBox fm x y ax ay t + writePrimArray out b x + writePrimArray out (b + 1) y + writePrimArray out (b + 2) px + writePrimArray out (b + 3) py + writePrimArray out (b + 4) tw + writePrimArray out (b + 5) th + fill (i + 1) (b + 6) + _ -> fill (i + 1) b + fill 0 0 + at i field = indexPrimArray ts (i * 6 + field) + !k = outerLoop 0 (1.0 :: Float) + where + outerLoop !i !acc + | i >= n - 1 = acc + | otherwise = + let innerLoop !j !m + | j >= n = m + | otherwise = + let !pairVal = pairK (at i 0) (at i 1) (at i 2) (at i 3) (at i 4) (at i 5) (at j 0) (at j 1) (at j 2) (at j 3) (at j 4) (at j 5) + in innerLoop (j + 1) (max m pairVal) + in outerLoop (i + 1) (innerLoop (i + 1) acc) + in min 2 (realToFrac k) + where + + pairK !x1 !y1 !px1 !py1 !tw1 !th1 !x2 !y2 !px2 !py2 !tw2 !th2 = + let !overlapX = px1 < px2 + tw2 && px2 < px1 + tw1 + !overlapY = py1 < py2 + th2 && py2 < py1 + th1 + in if overlapX && overlapY + then + max + (axisK x1 x2 (px1 - x1) tw1 (px2 - x2) tw2) + (axisK y1 y2 (py1 - y1) th1 (py2 - y2) th2) + else 1.0 + + axisK !a1 !a2 !o1 !size1 !o2 !size2 = + let (!loA, !loO, !loS, !hiA, !hiO) = + if a1 <= a2 + then (a1, o1, size1, a2, o2) + else (a2, o2, size2, a1, o1) + !den = hiA - loA + !need = loO + loS + 2 - hiO + in if den <= 1e-6 then 1.0 else max 1.0 (need / den) + +diagramFrame :: PlotStyle -> Float -> Rect -> SmallArray DrawOp +diagramFrame ps bw (Rect x y w h) = + smallArrayFromList + [ FillRect (Rect x y w h) (plotFrameBg ps) + , Stroke x y (x + w) y bw (plotFrameBorder ps) + , Stroke (x + w) y (x + w) (y + h) bw (plotFrameBorder ps) + , Stroke (x + w) (y + h) x (y + h) bw (plotFrameBorder ps) + , Stroke x (y + h) x y bw (plotFrameBorder ps) + ] + +-- Grow plots cap here unless the caller set a tighter layoutMaxH. +growPlotCapH :: Float +growPlotCapH = 260 + +fitLayout :: FontMetrics -> Layout -> Diagram B -> Layout +fitLayout fm layout d = + let V2 dw dh = size d + ar = if dh <= 1e-9 then 1 else dw / dh + growW = + case layoutWidth layout of + Grow _ -> True + _ -> False + (baseW, baseH) = + case (layoutWidth layout, layoutHeight layout) of + (Fixed bw, Fixed bh) + | dw > 1e-9 && dh > 1e-9 -> + let s = min (realToFrac bw / dw) (realToFrac bh / dh) + in (dw * s, dh * s) + (_, Fixed bh) -> + let h = realToFrac bh :: Double + in (h * ar, h) + (Fixed bw, _) -> + let w = realToFrac bw :: Double + in (w, w / ar) + _ -> + let h = + if layoutMinH layout > 0 + then realToFrac (layoutMinH layout) + else 160 + in (h * ar, h) + clampSize x = realToFrac (max 8 x) :: Float + in if growW + then + let capH = min growPlotCapH (layoutMaxH layout) + floorH = if layoutMinH layout > 0 then layoutMinH layout else 180 + probeH0 = + realToFrac + ( if layoutMinH layout > 0 + then layoutMinH layout + else 200 + ) :: + Double + probeH = min probeH0 (realToFrac capH) + probeW = probeH * ar + k = labelFitScale fm (diagramTextOps probeW probeH d) + needW = clampSize (probeW * k) + needH = min capH (max floorH (clampSize (probeH * k))) + in layout + { layoutHeight = Fit + , layoutMinW = max (layoutMinW layout) needW + , layoutMinH = needH + , layoutMaxH = max needH capH + } + else + let k = labelFitScale fm (diagramTextOps baseW baseH d) + wF = clampSize (baseW * k) + hF = clampSize (baseH * k) + in layout + { layoutWidth = Fixed wF + , layoutHeight = Fixed hF + , layoutMinW = wF + , layoutMaxW = wF + , layoutMinH = hF + , layoutMaxH = hF + } + +-- | 'diagramWithEnvelope' whose cached draw ops are also keyed by @userKey@. +-- Change the key when the diagram's content changes. +diagramWithKeyAndEnvelope :: + Ui :> es => + Int -> + Double -> + Double -> + (Layout -> Layout) -> + QDiagram NanoUIBackend V2 Double Any -> + Eff es Response +diagramWithKeyAndEnvelope userKey dw dh f = + framedDiagram (\t -> hash (userKey, themePlotKey t)) dw dh (f defaultLayout) + +-- | 'diagram' with an explicit envelope width and height. +diagramWithEnvelope :: + Ui :> es => + Double -> + Double -> + (Layout -> Layout) -> + QDiagram NanoUIBackend V2 Double Any -> + Eff es Response +diagramWithEnvelope dw dh f = framedDiagram themePlotKey dw dh (f defaultLayout) + +-- | Draw a diagram inside the plot frame. Its draw ops are cached under the +-- content key the caller derives from the current theme. +framedDiagram :: + Ui :> es => + (Theme -> Int) -> + Double -> + Double -> + Layout -> + QDiagram NanoUIBackend V2 Double Any -> + Eff es Response +framedDiagram contentKey dw dh layout d = do + fm <- uiFontMetrics + theme <- uiTheme + let ps = themePlotStyle theme + drawingCached dw dh (fmLineHeight fm) (contentKey theme) (const layout) (fitLayoutIO fm layout d) $ \rectBox -> + let inner = frameInner rectBox + w = realToFrac (rectW inner) :: Double + h = realToFrac (rectH inner) + plot = + if w <= 0 || h <= 0 + then emptySmallArray + else mapSmallArray' (shiftDrawOp (rectX inner) (rectY inner)) (diagramOps w h d) + in diagramFrame ps frameBorder rectBox <> plot + +frameBorder :: Float +frameBorder = 1 + +-- | The box a framed diagram draws into, inside its border. +frameInner :: Rect -> Rect +frameInner (Rect x y w h) = + Rect (x + frameBorder) (y + frameBorder) (max 0 (w - 2 * frameBorder)) (max 0 (h - 2 * frameBorder)) + +fitLayoutIO :: FontMetrics -> Layout -> Diagram B -> IO Layout +fitLayoutIO fm layout d = do + let texts = foldr (\op rest -> case op of + DrawText _ _ _ _ t _ -> t : rest + _ -> rest) [] (diagramTextOps 100 100 d) + prepared <- prepareFontMetricsMany fm texts + pure (fitLayout prepared layout d) + +-- | Draw a diagram inside a framed box sized by the layout modifier. Text in +-- the diagram is measured with the current font so labels fit. +diagram :: Ui :> es => (Layout -> Layout) -> QDiagram NanoUIBackend V2 Double Any -> Eff es Response +diagram f d = do + ctx <- askContext + wid <- currentId + fm <- uiFontMetrics + theme <- uiTheme + let content = themePlotKey theme + mEnv <- uiIO (lookupDrawFitEnvelope ctx wid (fmLineHeight fm) content (f defaultLayout)) + case mEnv of + Just (dw, dh) -> diagramWithEnvelope dw dh f d + Nothing -> + let V2 dw dh = size d + in diagramWithEnvelope dw dh f d diff --git a/lib/NanoUI/Plot.hs b/lib/NanoUI/Plot.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot.hs @@ -0,0 +1,20 @@ +-- | Charting and plotting API for nano-ui. +module NanoUI.Plot + ( module NanoUI.Plot.Types + , module NanoUI.Plot.Series + , module NanoUI.Plot.Scale + , module NanoUI.Plot.Decimate + , module NanoUI.Plot.Chrome + , module NanoUI.Plot.Widget + , module NanoUI.Plot.Builder + , module NanoUI.Plot.Hit + ) where + +import NanoUI.Plot.Builder +import NanoUI.Plot.Hit +import NanoUI.Plot.Chrome +import NanoUI.Plot.Decimate +import NanoUI.Plot.Scale +import NanoUI.Plot.Series +import NanoUI.Plot.Types +import NanoUI.Plot.Widget diff --git a/lib/NanoUI/Plot/Builder.hs b/lib/NanoUI/Plot/Builder.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Builder.hs @@ -0,0 +1,45 @@ +-- | Functions that build a 'NanoUI.Plot.Types.Chart' from series and set its +-- titles, legend, grid and decimation. +module NanoUI.Plot.Builder + ( chart + , withTitle + , withXAxis + , withYAxis + , withLegend + , withGrid + , withDecimate + , addSeries + ) where + +import Data.Text (Text) +import NanoUI.Plot.Types + ( Chart (..) + , GridMode + , LegendPos + , Series + , emptyChart + ) + +chart :: [Series] -> Chart +chart series = emptyChart {chartSeries = series} + +withTitle :: Text -> Chart -> Chart +withTitle t c = c {chartTitle = Just t} + +withXAxis :: Text -> Chart -> Chart +withXAxis t c = c {chartXTitle = Just t} + +withYAxis :: Text -> Chart -> Chart +withYAxis t c = c {chartYTitle = Just t} + +withLegend :: LegendPos -> Chart -> Chart +withLegend p c = c {chartLegend = p} + +withGrid :: GridMode -> Chart -> Chart +withGrid g c = c {chartGrid = g} + +withDecimate :: Bool -> Chart -> Chart +withDecimate b c = c {chartDecimate = b} + +addSeries :: Series -> Chart -> Chart +addSeries s c = c {chartSeries = chartSeries c ++ [s]} diff --git a/lib/NanoUI/Plot/Chrome.hs b/lib/NanoUI/Plot/Chrome.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Chrome.hs @@ -0,0 +1,399 @@ +-- | Chart drawing: axes, ticks, grid, title and legend around the series, as +-- a diagram. +module NanoUI.Plot.Chrome + ( chartDiagram + , chartMargins + , Margins (..) + , seriesDomains + , seriesPoints + ) where + +import Data.Colour (Colour) +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Primitive.PrimArray (indexPrimArray, sizeofPrimArray) +import Data.Vector.Unboxed qualified as U +import Diagrams.Prelude + ( Diagram + , P2 + , alignedText + , alignBL + , circle + , closeTrail + , fc + , fontSizeL + , fromVertices + , lc + , lw + , lwO + , moveTo + , none + , p2 + , phantom + , rect + , strokeTrail + , translate + , (^&) + , ( # ) + ) +import NanoUI + ( Color + , FontMetrics (..) + , Rect (..) + , Theme (..) + , drawTextBox + , fmLineHeight + , lerpColor + , themeSeries + ) +import NanoUI.Diagrams.Backend (B) +import NanoUI.Diagrams.Widget (PlotStyle (..), colourOf) +import NanoUI.Plot.Decimate (lttb) +import NanoUI.Plot.Scale + ( domainExtentBy + , domainToPlot + , formatTick + , mergeDomains + , niceTicks + , padDomain + ) +import NanoUI.Plot.Types + ( Chart (..) + , Domain (..) + , GridMode (..) + , LegendPos (..) + , MarkShape (..) + , Series (..) + , SeriesData (..) + , SeriesKind (..) + ) + +-- lwO is output pixels. Do not scale into the 0..1 plot box. +plotStroke :: Float -> Double +plotStroke pt = realToFrac (max 1 pt) + +-- Marker radius in plot-box units. Sized for ~160-200px charts. +plotMarkerRadius :: Float -> Double +plotMarkerRadius sz = realToFrac sz * 0.006 + +-- Host glyphs do not scale. Convert px using the intended data-box height. +-- Do not iterate against the full letterbox: that grows pads, shrinks the +-- data box, then grows pads again. +plotGapRef :: FontMetrics -> Double +plotGapRef fm = max 120 (realToFrac (fmLineHeight fm) * 7.5) + +data Margins = Margins + { marginLeft :: !Double + , marginRight :: !Double + , marginBottom :: !Double + , marginTop :: !Double + } + deriving (Eq, Show) + +data ChartChrome = ChartChrome + { ccMargins :: !Margins + , ccTickPad :: !Double + , ccXTickPad :: !Double + , ccPx :: Float -> Double + , ccYTitleX :: !Double + , ccXTitleY :: !Double + , ccLegendW :: !Float + } + +chartMargins :: FontMetrics -> Chart -> Margins +chartMargins fm chart = ccMargins (chartChrome fm (snd (seriesDomains chart)) chart) + +-- | Chrome for a chart whose y domain the caller has already computed. +chartChrome :: FontMetrics -> Domain -> Chart -> ChartChrome +chartChrome fm yDom chart = + let yLabels = map formatTick (niceTicks 6 yDom) + maxYW = maximum (0 : map (textWidth fm) yLabels) + lh = fmLineHeight fm + yTitleW = + case chartYTitle chart of + Nothing -> 0 + Just t -> textWidth fm t + legendW = + case chartLegend chart of + LegendNone -> 0 + _ -> + maximum + ( 0 + : map (textWidth fm . seriesName) (chartSeries chart) + ) + s = plotGapRef fm + px u = realToFrac u / s + tickPad = px 6 + xTickPad = px 2 + titleGap = px 10 + -- Glyphs grow in plot units when the data box is shorter than + -- plotGapRef. Pad tick size so titles stay just outside the ticks. + tickW = px maxYW * 1.35 + tickH = px lh * 1.35 + yTitleX = -tickPad - tickW - titleGap + xTitleY = -xTickPad - tickH - titleGap + leftTick = tickPad + tickW + px 4 + botTick = xTickPad + tickH + px 4 + topM = + if chartTitle chart /= Nothing + then px lh + px 8 + else px 4 + rightM = + case chartLegend chart of + LegendRight -> px legendW + 0.22 + _ -> px 4 + leftTitle = + if chartYTitle chart /= Nothing then titleGap + px yTitleW else 0 + botTitle = + if chartXTitle chart /= Nothing then titleGap + tickH else 0 + botLegend = + case chartLegend chart of + LegendBottom -> px lh + px 6 + _ -> 0 + leftM = leftTick + leftTitle + botM = botTick + botTitle + botLegend + in ChartChrome + { ccMargins = + Margins + { marginLeft = leftM + , marginRight = rightM + , marginBottom = botM + , marginTop = topM + } + , ccTickPad = tickPad + , ccXTickPad = xTickPad + , ccPx = px + , ccYTitleX = yTitleX + , ccXTitleY = xTitleY + , ccLegendW = legendW + } + +textWidth :: FontMetrics -> T.Text -> Float +textWidth fm s = rectW (drawTextBox fm 0 0 0 (-1) s) + +seriesDomains :: Chart -> (Domain, Domain) +seriesDomains chart = + case map seriesExtent (chartSeries chart) of + [] -> (Domain 0 1, Domain 0 1) + d : ds -> foldl' mergePair d ds + where + mergePair (dx, dy) (xd, yd) = (mergeDomains dx xd, mergeDomains dy yd) + +seriesExtent :: Series -> (Domain, Domain) +seriesExtent s = + case seriesData s of + PointsXY pts -> + (padDomain 0.05 (domainExtentBy fst pts), padDomain 0.05 (domainExtentBy snd pts)) + CategoryY _ values -> + let n = sizeofPrimArray values + in (Domain (-0.5) (fromIntegral n - 0.5), padDomain 0.05 (domainExtentBy (indexPrimArray values) (U.enumFromN 0 n))) + +-- | Draw a chart from its 'seriesDomains' and each series' 'seriesPoints'. +chartDiagram :: FontMetrics -> Theme -> PlotStyle -> (Domain, Domain) -> [U.Vector (Double, Double)] -> Chart -> Diagram B +chartDiagram fm theme ps (xDom, yDom) points chart = + let chrome = chartChrome fm yDom chart + margins = ccMargins chrome + leftM = marginLeft margins + rightM = marginRight margins + botM = marginBottom margins + topM = marginTop margins + xTicks = niceTicks 6 xDom + yTicks = niceTicks 6 yDom + tickPad = ccTickPad chrome + xTickPad = ccXTickPad chrome + toX = domainToPlot xDom + toY = domainToPlot yDom + horizontalGrid = mconcat [fromVertices [p2 (0, toY y), p2 (1, toY y)] | y <- yTicks] + verticalGrid = mconcat [fromVertices [p2 (toX x, 0), p2 (toX x, 1)] | x <- xTicks] + grid = + case chartGrid chart of + GridNone -> mempty + GridHorizontal -> horizontalGrid + GridVertical -> verticalGrid + GridBoth -> horizontalGrid <> verticalGrid + axes = + fromVertices [p2 (0, 0), p2 (1, 0)] + <> fromVertices [p2 (0, 0), p2 (0, 1)] + <> mconcat [fromVertices [p2 (toX x, 0), p2 (toX x, 0.03)] | x <- xTicks] + <> mconcat [fromVertices [p2 (0, toY y), p2 (0.03, toY y)] | y <- yTicks] + xLabs = + mconcat + [ plotLbl ps 0.5 1 (T.unpack (formatTick x)) # moveTo (p2 (toX x, -xTickPad)) + | x <- xTicks + ] + yLabs = + mconcat + [ plotLbl ps 1 0.5 (T.unpack (formatTick y)) # moveTo (p2 (-tickPad, toY y)) + | y <- yTicks + ] + title = + case chartTitle chart of + Nothing -> mempty + Just t -> plotLbl ps 0.5 0 (T.unpack t) # moveTo (p2 (0.5, 1.03)) + xt = + case chartXTitle chart of + Nothing -> mempty + Just t -> + plotLbl ps 0.5 1 (T.unpack t) + # moveTo (p2 (0.5, ccXTitleY chrome)) + yt = + case chartYTitle chart of + Nothing -> mempty + Just t -> + plotLbl ps 1 0.5 (T.unpack t) + # moveTo (p2 (ccYTitleX chrome, 0.5)) + coloredSeries = + [ (fromMaybe fallback (seriesColor s), s) + | (fallback, s) <- zip (cycle (themeSeries theme)) (chartSeries chart) + ] + seriesDia = + mconcat + [ renderSeries ps color xDom yDom s pts + | ((color, s), pts) <- zip coloredSeries points + ] + legend = renderLegend fm ps coloredSeries chart chrome + marginBox :: Diagram B + marginBox = + rect (1 + leftM + rightM) (1 + botM + topM) + # alignBL + # moveTo (p2 (-leftM, -botM)) + gridDia = grid # lc (plotGrid ps) # lwO (plotStroke 1) + axesDia = axes # lc (plotMuted ps) # lwO (plotStroke 1) + -- Diagrams composes front-to-back: keep the grid behind the data. + in xLabs <> yLabs <> title <> xt <> yt <> legend <> seriesDia <> axesDia <> gridDia <> phantom marginBox + +plotLbl :: PlotStyle -> Double -> Double -> String -> Diagram B +plotLbl ps ax ay s = + alignedText ax ay s # fontSizeL 0.085 # fc (plotMuted ps) # lc (plotMuted ps) # lw none + +renderSeries :: PlotStyle -> Color -> Domain -> Domain -> Series -> U.Vector (Double, Double) -> Diagram B +renderSeries ps c xDom yDom s pts = + let ink = colourOf c + fillCol = lerpColor c (plotFrameBg ps) 0.18 + fill = colourOf fillCol + toP (x, y) = p2 (domainToPlot xDom x, domainToPlot yDom y) + in case seriesKind s of + LineSeries w _ -> + fromVertices (U.foldr (\p acc -> toP p : acc) [] pts) # lc ink # lwO (plotStroke w) + ScatterSeries w mk -> + U.foldl' (\acc p -> acc <> markShape mk w ink (toP p)) mempty pts + BarSeries frac -> + renderBars ink frac pts + AreaSeries baseline -> + areaPath baseline xDom yDom pts # fc fill # lw none + StepSeries w -> + fromVertices (stepPoints pts xDom yDom) # lc ink # lwO (plotStroke w) + +seriesPoints :: Chart -> Series -> U.Vector (Double, Double) +seriesPoints chart s = + case seriesData s of + PointsXY pts -> + let k = decimateK (U.length pts) + in if chartDecimate chart && U.length pts > k then lttb k pts else pts + CategoryY _ values -> + U.generate (sizeofPrimArray values) (\i -> (fromIntegral i, indexPrimArray values i)) + +decimateK :: Int -> Int +decimateK n = min n (max 64 (min 2000 (n `div` 2))) + +renderBars :: Colour Double -> Float -> U.Vector (Double, Double) -> Diagram B +renderBars fill frac pts + | U.null pts = mempty + | otherwise = + let !len = U.length pts + !n = fromIntegral len :: Double + !w = realToFrac frac / n + !invN = 1.0 / n + !xOff = 0.5 * invN + + -- Single-pass strict fold for maxY (avoids allocating a list or intermediate vector) + !maxY = U.foldl' (\ !acc (_, y) -> max acc (abs y)) 1e-9 pts + !invMaxY = 1.0 / maxY + + drawBar (x, y) = + let !absY = abs y + !h = absY * invMaxY + !posX = x * invN + xOff + !posY = signum y * h * 0.5 + in rect w h + # fc fill + # lw none + # translate (posX ^& posY) + in U.foldl' (\acc p -> acc <> drawBar p) mempty pts + +areaPath :: Double -> Domain -> Domain -> U.Vector (Double, Double) -> Diagram B +areaPath baseline xDom yDom pts + | U.null pts = mempty + | otherwise = + let !baseY = domainToPlot yDom baseline + toTop (!x, !y) = p2 (domainToPlot xDom x, domainToPlot yDom y) + toBase (!x, !_) = p2 (domainToPlot xDom x, baseY) + + -- Forward traversal builds `top` in order + top = U.foldr (\p acc -> toTop p : acc) [] pts + -- Left fold naturally yields reverse order without allocating an intermediate reversed vector + base = U.foldl' (\acc p -> toBase p : acc) [] pts + in closedPoly (top ++ base) + +closedPoly :: [P2 Double] -> Diagram B +closedPoly pts = fromVertices pts # closeTrail # strokeTrail + +stepPoints :: U.Vector (Double, Double) -> Domain -> Domain -> [P2 Double] +stepPoints pts xDom yDom = + let toP (x, y) = p2 (domainToPlot xDom x, domainToPlot yDom y) + in U.foldr + (\((x0, y0), (x1, _)) acc -> toP (x0, y0) : toP (x1, y0) : acc) + [] + (U.zip pts (U.drop 1 pts)) + +markShape :: MarkShape -> Float -> Colour Double -> P2 Double -> Diagram B +markShape MarkCircle w c p = + circle (plotMarkerRadius w) # fc c # lw none # moveTo p +markShape MarkSquare w c p = + let s = plotMarkerRadius w * 2 + in rect s s # fc c # lw none # moveTo p +markShape MarkDiamond w c p = + let r = plotMarkerRadius w * 1.4 + in closedPoly [p2 (0, r), p2 (r, 0), p2 (0, -r), p2 (-r, 0)] + # fc c + # lw none + # moveTo p +markShape MarkTriangle w c p = + let r = plotMarkerRadius w * 1.6 + in closedPoly [p2 (0, r), p2 (-r, -r * 0.6), p2 (r, -r * 0.6)] + # fc c + # lw none + # moveTo p +markShape MarkCross w c p = + let r = plotMarkerRadius w * 1.4 + sw = plotStroke w + in ( (fromVertices [p2 (-r, -r), p2 (r, r)] # lc c # lwO sw) + <> (fromVertices [p2 (-r, r), p2 (r, -r)] # lc c # lwO sw) + ) + # moveTo p + +renderLegend :: FontMetrics -> PlotStyle -> [(Color, Series)] -> Chart -> ChartChrome -> Diagram B +renderLegend _ _ _ Chart {chartLegend = LegendNone} _ = mempty +renderLegend fm ps coloredSeries chart chrome = + let px = ccPx chrome + row = px (fmLineHeight fm + 8) + col = px (ccLegendW chrome) + 0.22 + botLegendY = + case chartXTitle chart of + Nothing -> -(ccXTickPad chrome) - px (fmLineHeight fm) - px 6 + Just _ -> ccXTitleY chrome - px (fmLineHeight fm) - px 6 + position i = case chartLegend chart of + LegendRight -> (1.04, 0.98 - i * row) + LegendBottom -> (i * col, botLegendY) + LegendTop -> (i * col, 1.12) + LegendInside -> (0.02, 0.98 - i * row) + LegendNone -> (0, 0) + in mconcat + [ legendEntry ps color (T.unpack (seriesName s)) # moveTo (p2 (position i)) + | (i, (color, s)) <- zip [0 ..] coloredSeries + ] + +legendEntry :: PlotStyle -> Color -> String -> Diagram B +legendEntry ps col name = + (fromVertices [p2 (0, 0), p2 (0.12, 0)] # lc (colourOf col) # lwO (plotStroke 1.5)) + <> (plotLbl ps 0 0.5 name # moveTo (p2 (0.16, 0))) diff --git a/lib/NanoUI/Plot/Decimate.hs b/lib/NanoUI/Plot/Decimate.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Decimate.hs @@ -0,0 +1,108 @@ +-- | Point reduction for long series: largest-triangle-three-buckets and +-- per-bucket minimum and maximum. +module NanoUI.Plot.Decimate + ( lttb + , minMaxDecimate + ) where + +import Control.Monad.ST (runST) +import Data.Vector.Generic (Vector) +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as MV +import qualified Data.Vector.Unboxed as U + +-- | Largest-Triangle-Three-Buckets sampling. Returns at most the requested +-- number of points in input order, preserving both endpoints for budgets >= 2. +{-# INLINABLE lttb #-} +{-# SPECIALIZE lttb :: Int -> U.Vector (Double, Double) -> U.Vector (Double, Double) #-} +lttb :: Vector v (Double, Double) => Int -> v (Double, Double) -> v (Double, Double) +lttb k0 pts + | k0 <= 0 = V.empty + | n <= k0 = pts + | k0 == 1 = V.take 1 pts + | k0 == 2 = V.fromList [V.head pts, V.last pts] + | otherwise = V.create $ do + out <- MV.new k0 + let !k = k0 + !bucketSize = fromIntegral (n - 2) / (fromIntegral (k - 2) :: Double) + !firstPt = pts V.! 0 + !lastPt = pts V.! (n - 1) + go !i !prevIdx + | i >= k - 2 = MV.write out (k - 1) lastPt + | otherwise = + let !rangeStart = floor (fromIntegral i * bucketSize) + 1 + !rangeEnd = min (n - 1) (floor (fromIntegral (i + 1) * bucketSize) + 1) + !avgStart = rangeEnd + !avgEnd = min n (floor (fromIntegral (i + 2) * bucketSize) + 1) + (!avgX, !avgY) = bucketAvg pts avgStart avgEnd + !prevPt = pts V.! prevIdx + findBest !j !bestIdx !bestArea + | j >= rangeEnd = bestIdx + | otherwise = + let !area = triArea prevPt (pts V.! j) (avgX, avgY) + in if area > bestArea + then findBest (j + 1) j area + else findBest (j + 1) bestIdx bestArea + -- An empty range keeps rangeStart; areas are never negative. + !best = findBest rangeStart rangeStart (-1) + in do + MV.write out (i + 1) (pts V.! best) + go (i + 1) best + MV.write out 0 firstPt + go 0 0 + pure out + where + !n = V.length pts + +{-# INLINE bucketAvg #-} +bucketAvg :: Vector v (Double, Double) => v (Double, Double) -> Int -> Int -> (Double, Double) +bucketAvg pts !start !end + | start >= end = (0, 0) + | otherwise = + let !len = end - start + !denom = fromIntegral len :: Double + go !i !sx !sy + | i >= end = (sx / denom, sy / denom) + | otherwise = + let (!x, !y) = pts V.! i + in go (i + 1) (sx + x) (sy + y) + in go start 0 0 + +triArea :: (Double, Double) -> (Double, Double) -> (Double, Double) -> Double +triArea (!x0, !y0) (!x1, !y1) (!x2, !y2) = + abs ((x0 - x2) * (y1 - y0) - (x0 - x1) * (y2 - y0)) * 0.5 + +-- | Split into at most @k@ buckets and retain each bucket's Y extrema in +-- input order. The output has at most @2*k@ points; non-positive budgets +-- return an empty vector. A point selected as both extrema is emitted once. +{-# INLINABLE minMaxDecimate #-} +{-# SPECIALIZE minMaxDecimate :: Int -> U.Vector (Double, Double) -> U.Vector (Double, Double) #-} +minMaxDecimate :: Vector v (Double, Double) => Int -> v (Double, Double) -> v (Double, Double) +minMaxDecimate k pts + | k <= 0 = V.empty + | len <= k = pts + | otherwise = runST $ do + out <- MV.new (min len (2 * numChunks)) + let chunks !start !written + | start >= len = V.freeze (MV.slice 0 written out) + | otherwise = do + let !end = start + min bucket (len - start) + extrema !i !lowIdx !highIdx + | i >= end = (lowIdx, highIdx) + | otherwise = + let !y = snd (pts V.! i) + !lo' = if y < snd (pts V.! lowIdx) then i else lowIdx + !hi' = if y > snd (pts V.! highIdx) then i else highIdx + in extrema (i + 1) lo' hi' + (!lo, !hi) = extrema (start + 1) start start + MV.write out written (pts V.! min lo hi) + if lo == hi + then chunks end (written + 1) + else do + MV.write out (written + 1) (pts V.! max lo hi) + chunks end (written + 2) + chunks 0 0 + where + !len = V.length pts + bucket = (len - 1) `div` k + 1 + numChunks = (len - 1) `div` bucket + 1 diff --git a/lib/NanoUI/Plot/Hit.hs b/lib/NanoUI/Plot/Hit.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Hit.hs @@ -0,0 +1,64 @@ +-- | Finding the data point nearest the pointer on a drawn chart. +module NanoUI.Plot.Hit + ( hitTestChartCached + , nearestPlotHover + ) where + +import NanoUI (Rect (..), V2, rectContains, v2X, v2Y) +import NanoUI.Diagrams.Backend (letterbox) +import NanoUI.Diagrams.Widget (frameInner) +import NanoUI.Plot.Scale (plotToDomain) +import NanoUI.Plot.Types (Domain, PlotHover (..)) +import qualified Data.Vector.Unboxed as U + +-- | The hover target under the pointer, for a diagram of envelope @dw@ by +-- @dh@ with extents @(x0, x1)@ and @(y0, y1)@ drawn framed in @widgetRect@. +hitTestChartCached :: + Double -> + Double -> + (Double, Double) -> + (Double, Double) -> + (Domain, Domain) -> + [U.Vector (Double, Double)] -> + Rect -> + V2 -> + Maybe PlotHover +hitTestChartCached dw dh (x0, x1) (y0, y1) domains points widgetRect mouse + | not (rectContains inner mouse) || w <= 0 || h <= 0 = Nothing + | lx < offX || ly < offY || lx > offX + outW || ly > offY + outH = Nothing + | otherwise = + nearestPlotHover + domains + points + (x0 + (lx - offX) / outW * (x1 - x0)) + (y1 - (ly - offY) / outH * (y1 - y0)) + where + inner = frameInner widgetRect + w = realToFrac (rectW inner) + h = realToFrac (rectH inner) + (outW, outH, offX, offY) = letterbox dw dh w h + lx = realToFrac (v2X mouse - rectX inner) + ly = realToFrac (v2Y mouse - rectY inner) + +-- | The data point nearest a position in the unit plot box, given the chart's +-- domains and each series' drawn points. +nearestPlotHover :: (Domain, Domain) -> [U.Vector (Double, Double)] -> Double -> Double -> Maybe PlotHover +nearestPlotHover (xDom, yDom) points gx gy + | gx < 0 || gx > 1 || gy < 0 || gy > 1 = Nothing + | otherwise = snd <$> scanSeries 0 Nothing points + where + dataX = plotToDomain xDom gx + dataY = plotToDomain yDom gy + -- The best hover carries its squared distance, so each point computes only + -- its own and a point that loses allocates nothing. + scanSeries !_ !best [] = best + scanSeries !si !best (pts : rest) = + let pick current !ptIdx (!x, !y) = + let !dx = x - dataX + !dy = y - dataY + !d = dx * dx + dy * dy + in case current of + Just (bestD, _) | bestD <= d -> current + _ -> Just (d, PlotHover x y si ptIdx) + !best' = U.ifoldl' pick best pts + in scanSeries (si + 1) best' rest diff --git a/lib/NanoUI/Plot/Scale.hs b/lib/NanoUI/Plot/Scale.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Scale.hs @@ -0,0 +1,118 @@ +-- | Mapping between data domains and plot coordinates, tick placement and +-- labels, and domain extents. +module NanoUI.Plot.Scale + ( domainToPlot + , plotToDomain + , niceTicks + , formatTick + , domainExtent + , domainExtentBy + , mergeDomains + , padDomain + ) where + +import Data.Text (Text) +import Data.Text qualified as T +import NanoUI.Plot.Types (Domain (..)) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Builder.Int as TB +import qualified Data.Text.Lazy.Builder.RealFloat as TB +import qualified Data.Vector.Generic as GV + +-- | Map a domain value into the unit plot box: @lo@ goes to 0, @hi@ to 1. +domainToPlot :: Domain -> Double -> Double +domainToPlot (Domain lo hi) v = (v - lo) / max 1e-9 (hi - lo) + +-- | Inverse of 'domainToPlot'. +plotToDomain :: Domain -> Double -> Double +plotToDomain (Domain lo hi) v = lo + v * max 1e-9 (hi - lo) + +-- Works with Data.Vector, Data.Vector.Unboxed, or Data.Vector.Storable +domainExtent :: (GV.Vector v Double) => v Double -> Domain +domainExtent = domainExtentBy id +{-# INLINE domainExtent #-} + +-- | Project while reducing, without materialising a mapped numeric vector. +domainExtentBy :: GV.Vector v a => (a -> Double) -> v a -> Domain +domainExtentBy project xs + | lo > hi = Domain 0 1 + | lo == hi = Domain (lo - 0.5) (hi + 0.5) + | otherwise = extent + where + extent@(Domain lo hi) = + GV.foldl' (\(Domain mn mx) value -> let !x = project value in Domain (min mn x) (max mx x)) (Domain (1 / 0) (-1 / 0)) xs +{-# INLINE domainExtentBy #-} + +mergeDomains :: Domain -> Domain -> Domain +mergeDomains (Domain a b) (Domain c d) = Domain (min a c) (max b d) + +padDomain :: Double -> Domain -> Domain +padDomain frac (Domain lo hi) = + let dSpan = max 1e-9 (hi - lo) + pad = dSpan * frac + in Domain (lo - pad) (hi + pad) + +finite :: Double -> Bool +finite x = not (isNaN x || isInfinite x) + +-- Heckbert-style nice tick step. +niceStep :: Double -> Double +niceStep raw = + let exp10 = floor (logBase 10 raw) :: Int + f = raw / (10 ** fromIntegral exp10) + nf + | f <= 1 = 1 + | f <= 2 = 2 + | f <= 5 = 5 + | otherwise = 10 + in nf * (10 ** fromIntegral exp10) + +niceTicks :: Int -> Domain -> [Double] +niceTicks maxTicks (Domain lo hi) + | maxTicks <= 0 || not (finite lo && finite hi) || hi < lo = [] + | lo == hi = [lo] + | not (finite dSpan) = [] + | not (finite step) || step <= 0 || not (finite (lo / step)) = [] + | otherwise = go start 0 [] + where + dSpan = max 1e-9 (hi - lo) + step = niceStep (dSpan / fromIntegral (max 2 maxTicks)) + start = fromIntegral (ceiling (lo / step - 1e-9) :: Integer) * step + go !v !count acc + | not (finite v) || v > hi + step * 0.001 = reverse acc + | otherwise = + let !accepted = v >= lo - step * 0.001 + acc' = if accepted then v : acc else acc + !next = v + step + in if count >= maxTicks || next <= v + then reverse acc' + else go next (count + 1) acc' + +formatTick :: Double -> Text +formatTick v + | not (finite v) = T.empty + | otherwise = + let snapped = snapNoise v + in if abs snapped >= 1e6 || (abs snapped > 0 && abs snapped < 1e-6) + then render (TB.formatRealFloat TB.Exponent (Just 3) snapped) + else + let n = round snapped :: Integer + in if abs (snapped - fromIntegral n) < 1e-6 + then render (TB.decimal n) + else stripZeros (render (TB.formatRealFloat TB.Fixed (Just 6) snapped)) + where + render = TL.toStrict . TB.toLazyText + +snapNoise :: Double -> Double +snapNoise v = + let s = 1e10 + scaled = v * s + in if finite scaled then fromIntegral (round scaled :: Integer) / s else v + +stripZeros :: Text -> Text +stripZeros s = + let t = T.dropWhileEnd (== '0') s + in case T.unsnoc t of + Just (rest, '.') -> rest + _ -> t diff --git a/lib/NanoUI/Plot/Series.hs b/lib/NanoUI/Plot/Series.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Series.hs @@ -0,0 +1,101 @@ +-- | Series constructors (line, scatter, bar, area, step) and their style +-- modifiers. +module NanoUI.Plot.Series + ( line + , scatter + , bar + , area + , step + , withColor + , withStrokeWidth + , withMarker + , withBaseline + , lineVec + , scatterVec + , areaVec + , stepVec + , barVec + ) where + +import Data.Text (Text) +import Data.Foldable (toList) +import Data.Primitive.PrimArray (generatePrimArray) +import Data.Primitive.SmallArray (createSmallArray, writeSmallArray) +import Data.Vector (Vector) +import Data.Vector qualified as V +import Data.Vector.Generic qualified as G +import Data.Vector.Unboxed qualified as U +import NanoUI (Color) +import NanoUI.Plot.Types + ( MarkShape (..) + , Series (..) + , SeriesData (..) + , SeriesKind (..) + ) + +line :: Foldable f => Text -> f (Double, Double) -> Series +line name = lineVec name . U.fromList . toList + +scatter :: Foldable f => Text -> f (Double, Double) -> Series +scatter name = scatterVec name . U.fromList . toList + +bar :: Foldable f => Text -> f (Text, Double) -> Series +bar name = barVec name . V.fromList . toList + +area :: Foldable f => Text -> f (Double, Double) -> Series +area name = areaVec name . U.fromList . toList + +step :: Foldable f => Text -> f (Double, Double) -> Series +step name = stepVec name . U.fromList . toList + +withColor :: Color -> Series -> Series +withColor c s = s {seriesColor = Just c} + +withStrokeWidth :: Float -> Series -> Series +withStrokeWidth w s = + case seriesKind s of + LineSeries _ m -> s {seriesKind = LineSeries w m} + ScatterSeries _ mk -> s {seriesKind = ScatterSeries w mk} + BarSeries _ -> s {seriesKind = BarSeries w} + StepSeries _ -> s {seriesKind = StepSeries w} + _ -> s + +withMarker :: MarkShape -> Series -> Series +withMarker mk s = + case seriesKind s of + LineSeries w _ -> s {seriesKind = LineSeries w (Just mk)} + ScatterSeries w _ -> s {seriesKind = ScatterSeries w mk} + _ -> s + +withBaseline :: Double -> Series -> Series +withBaseline b s = + case seriesKind s of + AreaSeries _ -> s {seriesKind = AreaSeries b} + _ -> s + +-- | Numeric series retain unboxed coordinates. Unboxed inputs are shared; +-- boxed/storable inputs are converted once at the construction boundary. +{-# INLINE lineVec #-} +lineVec :: G.Vector v (Double, Double) => Text -> v (Double, Double) -> Series +lineVec name pts = Series name Nothing (LineSeries 1.5 Nothing) (PointsXY (G.convert pts)) + +{-# INLINE scatterVec #-} +scatterVec :: G.Vector v (Double, Double) => Text -> v (Double, Double) -> Series +scatterVec name pts = Series name Nothing (ScatterSeries 3 MarkCircle) (PointsXY (G.convert pts)) + +{-# INLINE areaVec #-} +areaVec :: G.Vector v (Double, Double) => Text -> v (Double, Double) -> Series +areaVec name pts = Series name Nothing (AreaSeries 0) (PointsXY (G.convert pts)) + +{-# INLINE stepVec #-} +stepVec :: G.Vector v (Double, Double) => Text -> v (Double, Double) -> Series +stepVec name pts = Series name Nothing (StepSeries 1.5) (PointsXY (G.convert pts)) + +barVec :: Text -> Vector (Text, Double) -> Series +barVec name rows = + Series name Nothing (BarSeries 0.72) $ + CategoryY + (createSmallArray n "" (\out -> V.imapM_ (\i (t, _) -> writeSmallArray out i t) rows)) + (generatePrimArray n (snd . V.unsafeIndex rows)) + where + n = V.length rows diff --git a/lib/NanoUI/Plot/Types.hs b/lib/NanoUI/Plot/Types.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Types.hs @@ -0,0 +1,91 @@ +-- | Chart, series, domain and hover types. +module NanoUI.Plot.Types + ( Domain (..) + , SeriesData (..) + , MarkShape (..) + , SeriesKind (..) + , Series (..) + , LegendPos (..) + , GridMode (..) + , Chart (..) + , PlotHover (..) + , PlotResponse (..) + , emptyChart + ) where + +import Data.Primitive.PrimArray (PrimArray) +import Data.Primitive.SmallArray (SmallArray) +import Data.Text (Text) +import Data.Vector.Unboxed qualified as U +import NanoUI (Color, Response) + +data Domain = Domain !Double !Double + deriving (Eq, Show) + +data SeriesData + = PointsXY !(U.Vector (Double, Double)) + | -- | Bar labels and their values, in order. + CategoryY !(SmallArray Text) !(PrimArray Double) + deriving (Eq, Show) + +data MarkShape = MarkCircle | MarkSquare | MarkDiamond | MarkTriangle | MarkCross + deriving (Eq, Show) + +data SeriesKind + = LineSeries !Float (Maybe MarkShape) + | ScatterSeries !Float !MarkShape + | BarSeries !Float + | AreaSeries !Double + | StepSeries !Float + deriving (Eq, Show) + +data Series = Series + { seriesName :: !Text + , seriesColor :: !(Maybe Color) + , seriesKind :: !SeriesKind + , seriesData :: !SeriesData + } + deriving (Eq, Show) + +data LegendPos = LegendRight | LegendBottom | LegendTop | LegendInside | LegendNone + deriving (Eq, Show) + +data GridMode = GridBoth | GridHorizontal | GridVertical | GridNone + deriving (Eq, Show) + +data Chart = Chart + { chartTitle :: !(Maybe Text) + , chartXTitle :: !(Maybe Text) + , chartYTitle :: !(Maybe Text) + , chartSeries :: ![Series] + , chartLegend :: !LegendPos + , chartGrid :: !GridMode + , chartDecimate :: !Bool + } + deriving (Eq, Show) + +data PlotHover = PlotHover + { hoverDataX :: !Double + , hoverDataY :: !Double + , hoverSeriesIdx :: !Int + , hoverPointIdx :: !Int + } + deriving (Eq, Show) + +data PlotResponse = PlotResponse + { plotResponse :: !Response + , plotHover :: !(Maybe PlotHover) + } + deriving (Eq, Show) + +emptyChart :: Chart +emptyChart = + Chart + { chartTitle = Nothing + , chartXTitle = Nothing + , chartYTitle = Nothing + , chartSeries = [] + , chartLegend = LegendRight + , chartGrid = GridBoth + , chartDecimate = True + } diff --git a/lib/NanoUI/Plot/Widget.hs b/lib/NanoUI/Plot/Widget.hs new file mode 100644 --- /dev/null +++ b/lib/NanoUI/Plot/Widget.hs @@ -0,0 +1,120 @@ +-- | Chart widgets: 'plot' draws a chart and reports the hovered point, and +-- 'lineChart', 'barChart', 'scatterChart' and 'areaChart' draw one series. +module NanoUI.Plot.Widget + ( plot + , lineChart + , barChart + , scatterChart + , areaChart + ) where + +import Data.Dynamic (fromDynamic, toDyn) +import Data.IORef (readIORef) +import qualified Data.IntMap.Strict as IM +import Data.Maybe (fromMaybe, catMaybes) +import Data.Text (Text) +import Data.Vector.Unboxed qualified as U +import Diagrams.Prelude (Diagram, V2 (..), extentX, extentY, size) +import Effectful (Eff, type (:>)) +import NanoUI + ( FontMetrics + , Layout + , Theme + , Ui + , WidgetId + , uiFontMetrics + , uiMousePos + , uiTheme + , prepareFontMetricsMany + , respRect + ) +import NanoUI.Context (Context (..), WidgetStore (..), getStore, intKey, setStore) +import NanoUI.Monad (askContext, nextId, uiIO) +import NanoUI.Diagrams.Backend (B) +import NanoUI.Diagrams.Widget (PlotStyle, diagramWithKeyAndEnvelope, uiPlotStyle) +import NanoUI.Plot.Builder qualified as Builder +import NanoUI.Plot.Chrome (chartDiagram, seriesDomains, seriesPoints) +import NanoUI.Plot.Scale (formatTick, niceTicks) +import NanoUI.Plot.Hit (hitTestChartCached) +import NanoUI.Plot.Series (area, bar, line, scatter) +import NanoUI.Plot.Types + ( Chart (..) + , Domain + , Series (..) + , LegendPos (..) + , PlotResponse (..) + ) + +data CachedChart = CachedChart + { ccChart :: !Chart + , ccTheme :: !Theme + , ccFont :: {-# UNPACK #-} !Int + , ccStyle :: !PlotStyle + , ccVersion :: {-# UNPACK #-} !Int + , ccDiagram :: !(Diagram B) + , ccWidth :: {-# UNPACK #-} !Double + , ccHeight :: {-# UNPACK #-} !Double + , ccExtX :: !(Double, Double) + , ccExtY :: !(Double, Double) + , ccDomains :: !(Domain, Domain) + , ccPoints :: ![U.Vector (Double, Double)] + } + +-- Keep the cache in the owning context's widget store. Versions only need +-- to distinguish successive contents of this widget's draw-op cache. +cachedChartDiagram :: Context -> WidgetId -> FontMetrics -> Theme -> PlotStyle -> Chart -> IO CachedChart +cachedChartDiagram ctx wid fm theme ps chart = do + let k = intKey wid + font <- readIORef (ctxMetricGen ctx) + store <- getStore ctx + let previous = IM.lookup k (storeDyn store) >>= fromDynamic + case previous of + Just cc | ccChart cc == chart && ccTheme cc == theme && ccFont cc == font && ccStyle cc == ps -> pure cc + _ -> do + let domains@(xDom, yDom) = seriesDomains chart + points = map (seriesPoints chart) (chartSeries chart) + labels = catMaybes [chartTitle chart, chartXTitle chart, chartYTitle chart] + ++ map seriesName (chartSeries chart) + ++ map formatTick (niceTicks 6 xDom ++ niceTicks 6 yDom) + prepared <- prepareFontMetricsMany fm labels + let !d = chartDiagram prepared theme ps domains points chart + !(V2 dw dh) = size d + extX = fromMaybe (0, dw) (extentX d) + extY = fromMaybe (0, dh) (extentY d) + let !v = maybe 1 ((+ 1) . ccVersion) previous + !cc = CachedChart chart theme font ps v d dw dh extX extY domains points + setStore ctx (store {storeDyn = IM.insert k (toDyn cc) (storeDyn store)}) + pure cc + +-- | Draw a chart sized by the layout modifier. The response reports the +-- nearest data point under the pointer. +plot :: Ui :> es => (Layout -> Layout) -> Chart -> Eff es PlotResponse +plot f chart = do + wid <- nextId + ctx <- askContext + fm <- uiFontMetrics + theme <- uiTheme + ps <- uiPlotStyle + cc <- uiIO (cachedChartDiagram ctx wid fm theme ps chart) + resp <- diagramWithKeyAndEnvelope (ccVersion cc) (ccWidth cc) (ccHeight cc) f (ccDiagram cc) + mouse <- uiMousePos + let hover = hitTestChartCached (ccWidth cc) (ccHeight cc) (ccExtX cc) (ccExtY cc) (ccDomains cc) (ccPoints cc) (respRect resp) mouse + pure PlotResponse {plotResponse = resp, plotHover = hover} + +-- | One line series with a grid and no legend. +lineChart :: Ui :> es => (Layout -> Layout) -> [(Double, Double)] -> Eff es PlotResponse +lineChart f pts = plot f (singleSeries True (line "series" pts)) + +barChart :: Ui :> es => (Layout -> Layout) -> [(Text, Double)] -> Eff es PlotResponse +barChart f pts = plot f (singleSeries False (bar "series" pts)) + +scatterChart :: Ui :> es => (Layout -> Layout) -> [(Double, Double)] -> Eff es PlotResponse +scatterChart f pts = plot f (singleSeries False (scatter "series" pts)) + +areaChart :: Ui :> es => (Layout -> Layout) -> [(Double, Double)] -> Eff es PlotResponse +areaChart f pts = plot f (singleSeries True (area "series" pts)) + +-- | A gridded chart of one series without a legend, optionally decimated. +singleSeries :: Bool -> Series -> Chart +singleSeries decimate s = + Builder.withDecimate decimate (Builder.withLegend LegendNone (Builder.chart [s])) diff --git a/nano-ui-diagrams.cabal b/nano-ui-diagrams.cabal new file mode 100644 --- /dev/null +++ b/nano-ui-diagrams.cabal @@ -0,0 +1,95 @@ +cabal-version: 3.4 +name: nano-ui-diagrams +version: 0.1.0.0 +synopsis: Charts and diagrams-lib drawings for nano-ui +description: + Places diagrams-lib drawings in nano-ui layouts and builds line, bar, + scatter, area, and step charts with axes, legends, and hover lookup. +license: MIT +license-file: LICENSE +author: goolord +maintainer: zacharyachurchill@gmail.com +category: Graphics +homepage: https://github.com/goolord/nano-ui +bug-reports: https://github.com/goolord/nano-ui/issues +build-type: Simple +tested-with: GHC ==9.10.3 || ==9.14.1 +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/goolord/nano-ui.git + subdir: packages/nano-ui-diagrams + +common extensions + default-language: GHC2024 + default-extensions: + DuplicateRecordFields + OverloadedStrings + TypeFamilies + +common warnings + ghc-options: + -Wall + -Wextra + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-export-lists + -Wmissing-home-modules + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + +library + import: extensions + import: warnings + exposed-modules: + NanoUI.Diagrams + NanoUI.Diagrams.Backend + NanoUI.Diagrams.Tessellation + NanoUI.Diagrams.Widget + NanoUI.Plot + NanoUI.Plot.Types + NanoUI.Plot.Scale + NanoUI.Plot.Decimate + NanoUI.Plot.Series + NanoUI.Plot.Chrome + NanoUI.Plot.Builder + NanoUI.Plot.Hit + NanoUI.Plot.Widget + build-depends: + base >=4.20 && <4.23, + colour >=2.3.3 && <2.4, + containers >=0.6.7 && <0.9, + diagrams-core >=1.5 && <1.6, + diagrams-lib >=1.4.6 && <1.7, + dlist >=1.0 && <1.1, + effectful-core >=2.5 && <2.8, + hashable >=1.4 && <1.6, + lens >=5.0 && <5.4, + nano-ui ^>=0.1, + primitive >=0.8 && <0.10, + text >=2.0 && <2.2, + vector >=0.13 && <0.14 + hs-source-dirs: lib + +test-suite nano-ui-diagrams-test + import: extensions + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + base >=4.20 && <4.23, + colour >=2.3.3 && <2.4, + diagrams-lib >=1.4.6 && <1.7, + hspec >=2.10 && <2.12, + nano-ui, + nano-ui-diagrams, + primitive >=0.8 && <0.10, + text >=2.0 && <2.2, + vector >=0.13 && <0.14 + hs-source-dirs: test diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,505 @@ +module Main (main) where + +import Control.Monad (forM_, unless) +import Data.Colour.Names (coral, steelblue) +import Data.Foldable (toList) +import Data.IORef (readIORef) +import Data.List (tails) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Text qualified as T +import Data.Primitive.SmallArray (SmallArray, emptySmallArray) +import Data.Vector qualified as V +import Diagrams.Prelude + ( Diagram + , circle + , fc + , lw + , lwO + , none + , (#) + ) +import NanoUI +import NanoUI.Context (Context (..), DrawingCacheState (..), withFontMetrics) +import NanoUI.Context.Types (DrawOpCacheEntry (..)) +import NanoUI.Diagrams + ( B + , defaultPlotStyle + , diagram + , diagramOps + , fitLayout + ) +import NanoUI.Diagrams.Backend (diagramTextOps) +import NanoUI.Diagrams.Tessellation + ( strokePolyline + , triangulatePolygon + ) +import NanoUI.Plot.Chrome + ( Margins (..) + , chartDiagram + , chartMargins + , seriesDomains + , seriesPoints + ) +import NanoUI.Plot.Decimate (lttb, minMaxDecimate) +import NanoUI.Plot.Hit (nearestPlotHover) +import NanoUI.Plot.Scale (formatTick, mergeDomains, niceTicks) +import NanoUI.Plot.Series + ( area + , bar + , line + , scatter + , withColor + , withMarker + ) +import NanoUI.Plot.Types + ( Chart (..) + , Domain (..) + , GridMode (..) + , LegendPos (..) + , MarkShape (..) + , PlotHover (..) + , Series (..) + ) +import NanoUI.Plot.Widget qualified as Plot +import NanoUI.Testing (DrawData (..), drawCmdNull, newPixelContext, runFrame) +import Test.Hspec (describe, hspec, it) + +main :: IO () +main = hspec $ do + let + fm = monospaceMetrics 16 + describe "rendering" $ do + it "draws and redraws a filled diagram" $ do + ctx <- newPixelContext + testRendering ctx (emptyInput {inputWindowSize = Size 240 120}) + it "renders chart labels apart from geometry" (testTextOnlyRendering fm) + it "reuses cached chart content within one context" testChartCache + describe "tessellation" $ do + it "triangulates indexed polygons with full coverage" testIndexedTriangulation + it "covers polyline strokes end to end" testStrokeCoversMidpoint + describe "scales and domains" $ do + it "picks and formats nice ticks" testNiceTicks + it "shares bounds across series" testMultiSeriesDomains + describe "decimation" $ do + it "keeps LTTB extrema and endpoints" testLttb + it "keeps min/max extrema" testMinMaxDecimate + describe "chart chrome" $ do + it "keeps labels, titles and legends apart" (testLabelFit fm) + it "colors legend entries like their series" (testLegendColors fm) + it "picks the nearest hover point" testPlotHover + it "fills closed series and markers" (testClosedSeriesFills fm) + it "caps the height of growing plots" (testGrowPlotHeight fm) + +-- | A chart of the given series with no legend, grid or decimation. +bareChart :: [Series] -> Chart +bareChart ss = + Chart + { chartTitle = Nothing + , chartXTitle = Nothing + , chartYTitle = Nothing + , chartSeries = ss + , chartLegend = LegendNone + , chartGrid = GridNone + , chartDecimate = False + } + +chartDia :: FontMetrics -> Chart -> Diagram B +chartDia fm c = chartDiagram fm defaultTheme defaultPlotStyle (seriesDomains c) (map (seriesPoints c) (chartSeries c)) c + +rectsOverlap :: Rect -> Rect -> Bool +rectsOverlap (Rect x1 y1 w1 h1) (Rect x2 y2 w2 h2) = + x1 < x2 + w2 && x2 < x1 + w1 && y1 < y2 + h2 && y2 < y1 + h1 + +testTextOnlyRendering :: FontMetrics -> IO () +testTextOnlyRendering fm = do + let + d = linePlotDiag fm [(0, 0), (1, 2), (2, 1)] + isText DrawText {} = True + isText _ = False + forM_ [(400, 240), (120, 400), (0, 100), (100, -1)] $ \(w, h) -> do + let + full = diagramOps w h d + labels = diagramTextOps w h d + unless (toList labels == filter isText (toList full)) $ + fail "text-only rendering differs from the full render's text" + unless + (w <= 0 || h <= 0 || (not (null labels) && length labels < length full)) $ + fail "text-only rendering did not separate chart labels from geometry" + +testChartCache :: IO () +testChartCache = do + base <- newPixelContext + other <- newPixelContext + let + inp = emptyInput {inputWindowSize = Size 400 240} + fm = monospaceMetrics 16 + larger = monospaceMetrics 24 + ctx = withFontMetrics base fm + render c = do + _ <- + runFrame c inp $ Plot.lineChart (fixedWH 360 200) [(0, 0), (1, 1)] + cache <- readIORef (ctxDrawingCache c) + pure (map doeContent (toList (dcsDrawOpCache cache))) + first <- render ctx + again <- render ctx + unless (not (null first) && first == again) $ + fail "chart cache did not reuse unchanged content" + changed <- render (withFontMetrics base larger) + unless (changed /= first) $ + fail "chart cache ignored changed font metrics" + independent <- render (withFontMetrics other larger) + unless (independent == first) $ + fail "chart cache version leaked across contexts" + +testRendering :: Context -> Input -> IO () +testRendering ctx inp = do + let + ok d = drawIndexCount d > 0 && not (drawCmdNull d) + (_, _, filled, _) <- + runFrame ctx inp $ + diagram (fixedWH 200 80) (circle 1 # fc coral # lw none) + unless (ok filled) $ + fail "diagram produced no draw commands" + (_, _, filledAgain, _) <- + runFrame ctx inp $ + diagram (fixedWH 200 80) (circle 1 # fc coral # lw none) + unless (ok filledAgain) $ + fail "cached diagram produced no draw commands" + +linePlotDiag :: FontMetrics -> [(Double, Double)] -> Diagram B +linePlotDiag fm pts = + chartDia fm (bareChart [line "s" pts]) + # lwO 2 + # fc steelblue + +triArea :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float +triArea (x0, y0) (x1, y1) (x2, y2) = + abs ((x0 - x2) * (y1 - y0) - (x0 - x1) * (y2 - y0)) * 0.5 + +testIndexedTriangulation :: IO () +testIndexedTriangulation = do + forM_ [[], [(0, 0)], [(0, 0), (1, 1)], [(0, 0), (1, 1), (0, 0)]] $ \pts -> + unless (null (triangulatePolygon pts)) $ + fail "undersized polygon emitted triangles" + -- Alternating radii exercise repeated ear removal and wraparound indices. + forM_ [3, 16, 127, 256 :: Int] $ \n -> do + let + points = + [ let + angle = 2 * pi * fromIntegral i / fromIntegral n + radius = if even i then 10 else 6 + in + (radius * cos angle, radius * sin angle) + | i <- [0 .. n - 1] + ] + polygonArea = + abs + (sum [x * y' - x' * y | ((x, y), (x', y')) <- zip points (drop 1 (cycle points))]) + / 2 + forM_ [points, reverse points, points ++ take 1 points] $ \pts -> do + let + triangles = triangulatePolygon pts + areaSum = sum [triArea a b c | (a, b, c) <- triangles] + unless (length triangles == n - 2 && abs (areaSum - polygonArea) < 0.01) $ + fail + ( "indexed triangulation changed polygon coverage: " + ++ show (n, length triangles, areaSum, polygonArea) + ) + +testStrokeCoversMidpoint :: IO () +testStrokeCoversMidpoint = do + let + col = themeRed defaultTheme + ops = strokePolyline col 2 False [(0, 0), (20, 0), (20, 20)] + tris = + [ ((x0, y0), (x1, y1), (x2, y2)) + | FillTriangle x0 y0 x1 y1 x2 y2 _ <- ops + ] + covered p = any (inTri p) tris + unless (covered (10, 0) && covered (1, 0) && covered (20, 10)) $ + fail "stroke polyline left a gap along the segment" + +inTri :: + (Float, Float) -> ((Float, Float), (Float, Float), (Float, Float)) -> Bool +inTri p (a, b, c) = + let + s = triArea a b c + s' = triArea p b c + triArea a p c + triArea a b p + in + s > 1e-6 && abs (s' - s) <= 1e-3 + +testNiceTicks :: IO () +testNiceTicks = do + let + t0 = niceTicks 6 (Domain 0 100) + t1 = niceTicks 6 (Domain (-5) 5) + unless + ( maybe False (<= 0) (listToMaybe t0) + && maybe False (>= 100) (listToMaybe (reverse t0)) + ) $ + fail "nice ticks failed for [0,100]" + unless (any (== 0) t1) $ + fail "nice ticks failed for [-5,5]" + unless (formatTick 6 == "6") $ + fail "formatTick integer" + unless (formatTick 0.2 == "0.2" && formatTick 0.4 == "0.4") $ + fail "formatTick fractional" + unless (formatTick (0.2 + 0.2 + 0.2) == "0.6") $ + fail "formatTick binary residue" + unless (formatTick 0.0008 == "0.0008") $ + fail "formatTick small decimal" + unless (formatTick 1e308 == "1.000e308" && formatTick (-1e308) == "-1.000e308") $ + fail "formatTick overflowed while snapping a finite value" + unless + ( niceTicks 6 (Domain (-1e308) 1e308) == [] + && niceTicks 6 (Domain 1e308 1e308) == [1e308] + && niceTicks 0 (Domain 0 100) == [] + ) + $ fail "niceTicks failed on overflowing, singleton, or empty-budget domains" + +testMultiSeriesDomains :: IO () +testMultiSeriesDomains = do + let + s1 = line "a" (V.fromList [(0, 0), (1, 1)]) + s2 = line "b" [(0, 10), (1, 20)] + (Domain xLo xHi, Domain yLo yHi) = seriesDomains (bareChart [s1, s2]) + unless (yLo <= 0 && yHi >= 20 && xLo <= 0 && xHi >= 1) $ + fail "multi-series domains do not share bounds" + unless (mergeDomains (Domain 0 1) (Domain 0 10) == Domain 0 10) $ + fail "mergeDomains broken" + let + (Domain fitXLo _, Domain fitYLo _) = seriesDomains (bareChart [scatter "s" [(4, 3), (9, 8)]]) + unless (fitXLo > 2 && fitYLo > 1) $ + fail "seriesDomains seeded with 0..1" + +testLttb :: IO () +testLttb = do + let + pts = + V.fromList + [(fromIntegral i, sin (fromIntegral i / 10)) | i <- [0 .. 9999 :: Int]] + out = lttb 500 pts + unless (V.length out == 500) $ + fail "LTTB did not downsample to target count" + let + ys = toList (V.map snd out) + unless (minimum ys < -0.5 && maximum ys > 0.5) $ + fail "LTTB lost waveform extrema" + let + spike = V.fromList [(x, if x == 1 then 10 else 0) | x <- [0 .. 9]] + unless (lttb 3 spike == V.fromList [(0, 0), (1, 10), (9, 0)]) $ + fail "LTTB skipped the first bucket's spike" + forM_ [0 .. 60] $ \n -> forM_ [-1 .. n + 1] $ \k -> do + let + input = V.generate n (\i -> (fromIntegral i, sin (fromIntegral i))) + sampled = lttb k input + unless (V.length sampled == min n (max 0 k) && orderedPoints sampled) $ + fail "LTTB violated its point budget or input order" + unless (V.null sampled || V.head sampled == V.head input) $ + fail "LTTB lost the first endpoint" + unless (V.length sampled < 2 || V.last sampled == V.last input) $ + fail "LTTB lost the last endpoint" + +testMinMaxDecimate :: IO () +testMinMaxDecimate = do + unless + (minMaxDecimate 1 (V.fromList [(0, 2), (1, 2), (2, 2)]) == V.singleton (0, 2)) $ + fail "min/max decimation changed equal-extrema tie handling" + let + descending = V.fromList [(x, 9 - x) | x <- [0 .. 8]] + unless + (minMaxDecimate 2 descending == V.fromList [(0, 9), (4, 5), (5, 4), (8, 1)]) $ + fail "min/max decimation lost extrema or reversed their order" + forM_ [0 .. 60] $ \n -> forM_ [-1 .. n + 1] $ \k -> do + let + input = V.generate n (\i -> (fromIntegral i, sin (fromIntegral i))) + sampled = minMaxDecimate k input + unless (V.length sampled <= max 0 (2 * k) && orderedPoints sampled) $ + fail "min/max decimation violated its bucket budget or input order" + unless (V.all (`V.elem` input) sampled) $ + fail "min/max decimation invented a point" + unless + ( V.null sampled + || ( V.minimum (V.map snd input) == V.minimum (V.map snd sampled) + && V.maximum (V.map snd input) == V.maximum (V.map snd sampled) + ) + ) + $ fail "min/max decimation lost a global extremum" + +orderedPoints :: V.Vector (Double, Double) -> Bool +orderedPoints points = V.and (V.zipWith (\a b -> fst a < fst b) points (V.drop 1 points)) + +testLabelFit :: FontMetrics -> IO () +testLabelFit fm = do + let + dump = chartDia fm barChartSample + fitted = fitLayout fm (fixedH 180 defaultLayout) dump + ops = + case (layoutWidth fitted, layoutHeight fitted) of + (Fixed bw, Fixed bh) -> diagramOps (realToFrac bw) (realToFrac bh) dump + _ -> emptySmallArray + texts = [(x, y, ax, ay, t) | DrawText x y ax ay t _ <- toList ops] + xs = [x | (x, _, _, _, _) <- texts] + boxes = [drawTextBox fm x y ax ay t | (x, y, ax, ay, t) <- texts] + unless (length xs >= 3 && maximum xs - minimum xs > 20) $ + fail "axis labels did not spread along x" + unless (not (or [rectsOverlap a b | (a : rest) <- tails boxes, b <- rest])) $ + fail "axis label boxes overlap" + let + sleepChart = + (bareChart [scatter "focus" [(4, 3), (9, 8)], line "trend" [(4, 3), (9, 8)]]) + { chartLegend = LegendRight + , chartYTitle = Just "focus" + , chartXTitle = Just "hours slept" + } + legendDump = chartDia fm sleepChart + legendOps = diagramOps 400 240 legendDump + tightOps = diagramOps 220 150 legendDump + barTightOps = diagramOps 220 150 dump + botChart = sleepChart {chartLegend = LegendBottom} + botOps = diagramOps 400 240 (chartDia fm botChart) + tickText t = + T.all (\c -> c == '-' || c == '.' || c >= '0' && c <= '9') t && not (T.null t) + overlapTitleTick chart w h drawOps = + let + ts = + [(drawTextBox fm x y ax ay t, t) | DrawText x y ax ay t _ <- toList drawOps] + titles = + [ b + | (b@(Rect bx by _ _), t) <- ts + , (chartXTitle chart == Just t && by < h * 0.45) + || (chartYTitle chart == Just t && bx < w * 0.4) + ] + ticks = [b | (b, t) <- ts, tickText t] + in + or [rectsOverlap a b | a <- titles, b <- ticks] + overlapLegendTick chart w h drawOps = + let + names = map seriesName (chartSeries chart) + ts = + [(drawTextBox fm x y ax ay t, t) | DrawText x y ax ay t _ <- toList drawOps] + legends = + [ b + | (b@(Rect bx by _ _), t) <- ts + , t `elem` names + , case chartLegend chart of + LegendRight -> bx > w * 0.55 + LegendBottom -> by < h * 0.45 + _ -> False + ] + ticks = [b | (b, t) <- ts, tickText t] + in + or [rectsOverlap a b | a <- legends, b <- ticks] + unless (not (overlapTitleTick sleepChart 400 240 legendOps)) $ + fail "axis titles overlap ticks" + unless (not (overlapLegendTick sleepChart 400 240 legendOps)) $ + fail "legend overlaps ticks" + unless (not (overlapTitleTick sleepChart 220 150 tightOps)) $ + fail "axis titles overlap ticks on a small plot" + unless (not (overlapTitleTick barChartSample 220 150 barTightOps)) $ + fail "bar axis titles overlap ticks on a small plot" + unless (not (overlapTitleTick botChart 400 240 botOps)) $ + fail "axis titles overlap ticks with bottom legend" + unless (not (overlapLegendTick botChart 400 240 botOps)) $ + fail "bottom legend overlaps ticks" + let + shortTitles = + (bareChart [line "sin(x)" [(0, 0), (1, 1)]]) + { chartLegend = LegendRight + , chartYTitle = Just "y" + , chartXTitle = Just "x" + } + shortM = chartMargins fm shortTitles + unless (marginLeft shortM < 0.85 && marginBottom shortM < 0.65) $ + fail "short axis titles left a huge gutter" + +barChartSample :: Chart +barChartSample = + (bareChart [bar "count" [("Mon", 2), ("Tue", 5), ("Wed", 4), ("Thu", 7), ("Fri", 3)]]) + { chartXTitle = Just "day" + , chartYTitle = Just "count" + , chartLegend = LegendRight + , chartGrid = GridBoth + } + +testPlotHover :: IO () +testPlotHover = do + let hoverAt c = nearestPlotHover (seriesDomains c) (map (seriesPoints c) (chartSeries c)) 0.5 0.5 + forM_ [bareChart [], bareChart [line "empty" []]] $ \chart -> + unless (hoverAt chart == Nothing) $ + fail "empty chart produced a hover target" + let + tied = bareChart [line "first" [(0, 0), (0, 0)], line "second" [(0, 0)]] + unless + ( fmap (\h -> (hoverSeriesIdx h, hoverPointIdx h)) (hoverAt tied) + == Just (0, 0) + ) $ + fail "equidistant hover targets did not prefer the first point" + case hoverAt (bareChart [line "a" [(0, 0), (1, 1), (2, 4)]]) of + Nothing -> fail "nearestPlotHover missed center point" + Just h -> + unless + ( hoverSeriesIdx h == 0 + && hoverPointIdx h == 1 + && hoverDataX h == 1 + && hoverDataY h == 1 + ) $ + fail "nearestPlotHover picked wrong point" + +-- Empty series isolate the legend strokes from data geometry. Every placement +-- must retain the labels and use the same color overrides as the series. +testLegendColors :: FontMetrics -> IO () +testLegendColors fm = do + let + custom = colorRGBA 17 211 83 255 + chart = bareChart [withColor custom (line "custom" []), line "default" []] + fallback = themeSeries defaultTheme !! 1 + forM_ [LegendNone, LegendRight, LegendBottom, LegendTop, LegendInside] $ \position -> do + let + ops = toList (diagramOps 400 280 (chartDia fm chart {chartLegend = position})) + labels = + [text | DrawText _ _ _ _ text _ <- ops, text == "custom" || text == "default"] + colors = [color | FillTriangle _ _ _ _ _ _ color <- ops] + if position == LegendNone + then + unless (null labels && custom `notElem` colors) $ + fail "hidden legend rendered entries" + else do + unless (length labels == 2 && "custom" `elem` labels && "default" `elem` labels) $ + fail "legend lost or duplicated a series label" + unless (custom `elem` colors && fallback `elem` colors) $ + fail "legend colors differ from series colors" + +fillTriCount :: SmallArray DrawOp -> Int +fillTriCount ops = length [() | FillTriangle {} <- toList ops] + +testClosedSeriesFills :: FontMetrics -> IO () +testClosedSeriesFills fm = do + let + seriesOps s = diagramOps 200 120 (chartDia fm (bareChart [s])) + areaOps = seriesOps (area "a" [(0, 1), (1, 2), (2, 0)]) + diamondOps = seriesOps (withMarker MarkDiamond (scatter "d" [(1, 1), (2, 3)])) + triOps = seriesOps (withMarker MarkTriangle (scatter "t" [(1, 1)])) + crossOps = seriesOps (withMarker MarkCross (scatter "x" [(8, 8)])) + ink = fromMaybe (themeRed defaultTheme) (listToMaybe (themeSeries defaultTheme)) + inkXs = + [ x + | FillTriangle x0 _ x1 _ x2 _ c <- toList crossOps + , c == ink + , x <- [x0, x1, x2] + ] + unless (fillTriCount areaOps >= 2) $ + fail "area series produced no fill triangles" + unless (fillTriCount diamondOps >= 2) $ + fail "diamond marker produced no fill" + unless (fillTriCount triOps >= 1) $ + fail "triangle marker produced no fill" + unless (not (null inkXs) && maximum inkXs - minimum inkXs < 40) $ + fail "MarkCross arm left at origin" + +testGrowPlotHeight :: FontMetrics -> IO () +testGrowPlotHeight fm = do + let + fitted = fitLayout fm (fillW defaultLayout) (chartDia fm barChartSample) + unless (layoutMinH fitted <= 260 && layoutMaxH fitted <= 260) $ + fail "plot grow height ballooned"