{-# LANGUAGE Strict #-}

{- |
Module      : Granite.Render.Chrome
Copyright   : (c) 2025
License     : MIT
Maintainer  : mschavinda@gmail.com

Backend-agnostic chart chrome: axes, title, legend. Each helper
returns a list of primitive 'Mark's.
-}
module Granite.Render.Chrome (
    PlotBox (..),
    Margins (..),
    computePlotBox,
    AxisLayout (..),
    XLabelMode,
    xModeNoRotate,
    axisLayout,
    domainLabels,
    axesMarks,
    titleMarks,
    legendMarks,
) where

import Data.Char (isDigit)
import Data.List (nub)
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Text qualified as Text
import Granite.Internal.Util (estLabelWidthPx, truncatePx)
import Text.Read (readMaybe)

import Granite.Color (Color (..))
import Granite.Render.Scene (
    Mark (..),
    Point (..),
    Rect (..),
    Style (..),
    TextAnchor (..),
    TextStyle (..),
    defaultStyle,
    defaultTextStyle,
 )
import Granite.Scale (TrainedScale (..))
import Granite.Spec (
    ColorSpec (..),
    Coord (..),
    PolarAes (..),
    PolarDir (..),
    Size (..),
    Theme (..),
 )

{- | Pixel rectangle the chart body occupies, plus the overall scene
bounds. Margins around the plot area host title, axis labels, legend.
-}
data PlotBox = PlotBox
    { PlotBox -> Double
boxSceneW :: !Double
    , PlotBox -> Double
boxSceneH :: !Double
    , PlotBox -> Double
boxX :: !Double
    , PlotBox -> Double
boxY :: !Double
    , PlotBox -> Double
boxW :: !Double
    , PlotBox -> Double
boxH :: !Double
    }
    deriving (PlotBox -> PlotBox -> Bool
(PlotBox -> PlotBox -> Bool)
-> (PlotBox -> PlotBox -> Bool) -> Eq PlotBox
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlotBox -> PlotBox -> Bool
== :: PlotBox -> PlotBox -> Bool
$c/= :: PlotBox -> PlotBox -> Bool
/= :: PlotBox -> PlotBox -> Bool
Eq, Int -> PlotBox -> ShowS
[PlotBox] -> ShowS
PlotBox -> String
(Int -> PlotBox -> ShowS)
-> (PlotBox -> String) -> ([PlotBox] -> ShowS) -> Show PlotBox
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlotBox -> ShowS
showsPrec :: Int -> PlotBox -> ShowS
$cshow :: PlotBox -> String
show :: PlotBox -> String
$cshowList :: [PlotBox] -> ShowS
showList :: [PlotBox] -> ShowS
Show)

-- | Scene pixel dimensions for a 'Size'.
sceneDims :: Size -> Theme -> (Double, Double)
sceneDims :: Size -> Theme -> (Double, Double)
sceneDims Size
sz Theme
theme = case Size
sz of
    SizeChars Int
w Int
h ->
        (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Theme -> Double
themePxPerChar Theme
theme, Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Theme -> Double
themePxPerLine Theme
theme)
    SizePixels Int
w Int
h -> (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
    SizeResponsive Double
ar -> let h :: Double
h = Double
320 in (Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ar, Double
h)

{- | Inputs that grow the plot margins beyond the theme defaults. @marExtraBottom@
enlarges the bottom margin (for rotated x-labels) and @marLeftWanted@ requests a
left margin (to fit long y-labels / the rotated labels' leftward reach); both
fall back to the defaults when 0\/small.
-}
data Margins = Margins
    { Margins -> Bool
marHasTitle :: !Bool
    , Margins -> Bool
marHasRightLegend :: !Bool
    , Margins -> Bool
marHasBottomLegend :: !Bool
    , Margins -> Double
marExtraBottom :: !Double
    , Margins -> Double
marLeftWanted :: !Double
    }
    deriving (Margins -> Margins -> Bool
(Margins -> Margins -> Bool)
-> (Margins -> Margins -> Bool) -> Eq Margins
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Margins -> Margins -> Bool
== :: Margins -> Margins -> Bool
$c/= :: Margins -> Margins -> Bool
/= :: Margins -> Margins -> Bool
Eq, Int -> Margins -> ShowS
[Margins] -> ShowS
Margins -> String
(Int -> Margins -> ShowS)
-> (Margins -> String) -> ([Margins] -> ShowS) -> Show Margins
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Margins -> ShowS
showsPrec :: Int -> Margins -> ShowS
$cshow :: Margins -> String
show :: Margins -> String
$cshowList :: [Margins] -> ShowS
showList :: [Margins] -> ShowS
Show)

computePlotBox :: Size -> Theme -> Margins -> PlotBox
computePlotBox :: Size -> Theme -> Margins -> PlotBox
computePlotBox Size
sz Theme
theme Margins
m =
    let (Double
sceneW, Double
sceneH) = Size -> Theme -> (Double, Double)
sceneDims Size
sz Theme
theme
        topMargin :: Double
topMargin = if Margins -> Bool
marHasTitle Margins
m then Theme -> Double
themeTitleSize Theme
theme Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
20 else Double
10
        bottomMargin :: Double
bottomMargin =
            (if Margins -> Bool
marHasBottomLegend Margins
m then Double
30 else Double
0)
                Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Theme -> Double
themeFontSize Theme
theme Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1.8 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
8) (Margins -> Double
marExtraBottom Margins
m)
        leftMargin :: Double
leftMargin = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Theme -> Double
themeFontSize Theme
theme Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
5) (Margins -> Double
marLeftWanted Margins
m)
        rightMargin :: Double
rightMargin = Bool -> Double
rightMarginPx (Margins -> Bool
marHasRightLegend Margins
m)
        plotW :: Double
plotW = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Double
sceneW Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
leftMargin Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
rightMargin)
        plotH :: Double
plotH = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Double
sceneH Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
topMargin Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
bottomMargin)
     in Double -> Double -> Double -> Double -> Double -> Double -> PlotBox
PlotBox Double
sceneW Double
sceneH Double
leftMargin Double
topMargin Double
plotW Double
plotH

rightMarginPx :: Bool -> Double
rightMarginPx :: Bool -> Double
rightMarginPx Bool
hasRightLegend = if Bool
hasRightLegend then Double
120 else Double
20

-- | The automatic policy for bottom-axis labels given their per-tick budget.
data XPolicy = XUpright | XThin | XRotate
    deriving (XPolicy -> XPolicy -> Bool
(XPolicy -> XPolicy -> Bool)
-> (XPolicy -> XPolicy -> Bool) -> Eq XPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XPolicy -> XPolicy -> Bool
== :: XPolicy -> XPolicy -> Bool
$c/= :: XPolicy -> XPolicy -> Bool
/= :: XPolicy -> XPolicy -> Bool
Eq, Int -> XPolicy -> ShowS
[XPolicy] -> ShowS
XPolicy -> String
(Int -> XPolicy -> ShowS)
-> (XPolicy -> String) -> ([XPolicy] -> ShowS) -> Show XPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XPolicy -> ShowS
showsPrec :: Int -> XPolicy -> ShowS
$cshow :: XPolicy -> String
show :: XPolicy -> String
$cshowList :: [XPolicy] -> ShowS
showList :: [XPolicy] -> ShowS
Show)

xLabelPolicy :: Double -> Double -> [Text] -> XPolicy
xLabelPolicy :: Double -> Double -> [Text] -> XPolicy
xLabelPolicy Double
fontSize Double
budget [Text]
labels
    | Double -> [Text] -> Double
maxLabelWidth Double
fontSize [Text]
labels Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
budget = XPolicy
XUpright
    | Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
labels) Bool -> Bool -> Bool
&& (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Text -> Bool
isNumericLabel [Text]
labels = XPolicy
XThin
    | Bool
otherwise = XPolicy
XRotate

maxLabelWidth :: Double -> [Text] -> Double
maxLabelWidth :: Double -> [Text] -> Double
maxLabelWidth Double
fontSize = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Double] -> Double) -> ([Text] -> [Double]) -> [Text] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
0 :) ([Double] -> [Double])
-> ([Text] -> [Double]) -> [Text] -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Double) -> [Text] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Text -> Double
estLabelWidthPx Double
fontSize)

-- | Rotated x-labels wider than this (px) are truncated with a hover @\<title\>@.
rotatedLabelLimitPx :: Double
rotatedLabelLimitPx :: Double
rotatedLabelLimitPx = Double
130

-- | @sin 45°@ — a rotated label's horizontal/vertical reach as a fraction of its width.
sin45 :: Double
sin45 :: Double
sin45 = Double -> Double
forall a. Floating a => a -> a
sqrt Double
2 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2

{- | How the bottom (x) axis labels are laid out, plus the extra margins that
choice needs. Decided exactly once per chart so margin sizing and the actual
label rendering can never disagree (the bug when each recomputed the policy
from a slightly different plot width). 'XLabelMode' is threaded to 'axesMarks';
'alExtraBottom'\/'alLeftWanted' feed 'computePlotBox'.
-}
data AxisLayout = AxisLayout
    { AxisLayout -> XLabelMode
alMode :: !XLabelMode
    , AxisLayout -> Double
alExtraBottom :: !Double
    , AxisLayout -> Double
alLeftWanted :: !Double
    }

{- | What a panel's x-axis renderer should do. 'XFixed' carries the
chart-global decision verbatim (single panel). 'XLocalNoRotate' lets a faceted
panel pick upright\/thin from its own width, but never rotate — rotation needs a
per-cell margin reservation the facet layout doesn't make.
-}
data XLabelMode = XFixed !XPolicy | XLocalNoRotate

-- | The mode for axes that never rotate their labels (polar; also the faceted default).
xModeNoRotate :: XLabelMode
xModeNoRotate :: XLabelMode
xModeNoRotate = XLabelMode
XLocalNoRotate

{- | Decide the bottom-axis label policy and the margins it needs, in one pass.
A wide left label grows the left margin (up to ~42% of the scene); rotated
bottom labels also reach down (bottom margin) and left (left margin) by
@sin 45°@ of their width. Faceted charts never rotate, so they reserve no extra
bottom margin.
-}
axisLayout :: Theme -> Size -> Bool -> Bool -> [Text] -> [Text] -> AxisLayout
axisLayout :: Theme -> Size -> Bool -> Bool -> [Text] -> [Text] -> AxisLayout
axisLayout Theme
theme Size
sz Bool
hasRightLegend Bool
faceted [Text]
bottomLbls [Text]
leftLbls =
    AxisLayout
        { alMode :: XLabelMode
alMode = XLabelMode
mode
        , alExtraBottom :: Double
alExtraBottom = Double
bottomExtra
        , alLeftWanted :: Double
alLeftWanted = Double
leftWanted
        }
  where
    (Double
sceneW, Double
_) = Size -> Theme -> (Double, Double)
sceneDims Size
sz Theme
theme
    fontSize :: Double
fontSize = Theme -> Double
themeFontSize Theme
theme
    cap :: Double
cap = Double
0.42 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
sceneW
    -- Left margin from y-labels alone, used to set the plot width that decides
    -- x rotation. Rotation can grow it further (its leftward reach), but the
    -- rotate/thin decision itself is fixed here and threaded, so it never drifts.
    provLeft :: Double
provLeft = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
cap (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max (Double
fontSize Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
5) (Double -> [Text] -> Double
maxLabelWidth Double
fontSize [Text]
leftLbls Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
12))
    provPlotW :: Double
provPlotW = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Double
sceneW Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
provLeft Double -> Double -> Double
forall a. Num a => a -> a -> a
- Bool -> Double
rightMarginPx Bool
hasRightLegend)
    n :: Int
n = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
bottomLbls
    budget :: Double
budget = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Double
provPlotW else Double
provPlotW Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    policy :: XPolicy
policy = Double -> Double -> [Text] -> XPolicy
xLabelPolicy Double
fontSize Double
budget [Text]
bottomLbls
    rotates :: Bool
rotates = Bool -> Bool
not Bool
faceted Bool -> Bool -> Bool
&& XPolicy
policy XPolicy -> XPolicy -> Bool
forall a. Eq a => a -> a -> Bool
== XPolicy
XRotate
    rotatedExtent :: Double
rotatedExtent = Double
sin45 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Double -> [Text] -> Double
maxLabelWidth Double
fontSize [Text]
bottomLbls) Double
rotatedLabelLimitPx
    mode :: XLabelMode
mode = if Bool
faceted then XLabelMode
XLocalNoRotate else XPolicy -> XLabelMode
XFixed XPolicy
policy
    -- A rotated label's baseline sits @fontSize + 4@ below the axis and reaches
    -- down a further @rotatedExtent@; +8 keeps a descender's clearance above the
    -- scene edge.
    bottomExtra :: Double
bottomExtra = if Bool
rotates then Double
fontSize Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
4 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rotatedExtent Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
8 else Double
0
    leftWanted :: Double
leftWanted = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
cap (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
provLeft (if Bool
rotates then Double
rotatedExtent else Double
0))

axesMarks ::
    Theme ->
    PlotBox ->
    Coord ->
    XLabelMode ->
    TrainedScale ->
    TrainedScale ->
    [Mark]
axesMarks :: Theme
-> PlotBox
-> Coord
-> XLabelMode
-> TrainedScale
-> TrainedScale
-> [Mark]
axesMarks Theme
theme PlotBox
box Coord
coord XLabelMode
xmode TrainedScale
xs TrainedScale
ys = case Coord
coord of
    Coord
CoordCartesian -> Theme
-> PlotBox
-> Bool
-> XLabelMode
-> TrainedScale
-> TrainedScale
-> [Mark]
cartesianAxes Theme
theme PlotBox
box Bool
False XLabelMode
xmode TrainedScale
xs TrainedScale
ys
    -- CoordFlip rotates 90° CW so the Y axis grows top-down.
    Coord
CoordFlip -> Theme
-> PlotBox
-> Bool
-> XLabelMode
-> TrainedScale
-> TrainedScale
-> [Mark]
cartesianAxes Theme
theme PlotBox
box Bool
True XLabelMode
xmode TrainedScale
ys TrainedScale
xs
    CoordPolar PolarAes
aes Double
a0 PolarDir
dir -> Theme
-> PlotBox
-> PolarAes
-> Double
-> PolarDir
-> TrainedScale
-> TrainedScale
-> [Mark]
polarAxes Theme
theme PlotBox
box PolarAes
aes Double
a0 PolarDir
dir TrainedScale
xs TrainedScale
ys

{- | Axes are 'MAxisLine' spines (clean box-drawing chars in terminal,
@<line>@ in SVG). Gridlines and tick stubs are omitted so the
terminal output stays uncluttered; tick /labels/ sit beside each
break. @flipY@ inverts Y for 'CoordFlip'.
-}
cartesianAxes ::
    Theme -> PlotBox -> Bool -> XLabelMode -> TrainedScale -> TrainedScale -> [Mark]
cartesianAxes :: Theme
-> PlotBox
-> Bool
-> XLabelMode
-> TrainedScale
-> TrainedScale
-> [Mark]
cartesianAxes Theme
theme PlotBox
box Bool
flipY XLabelMode
xmode TrainedScale
xs TrainedScale
ys =
    let axisColor :: Color
axisColor = ColorSpec -> Color
colorOfSpec (Theme -> ColorSpec
themeAxisColor Theme
theme)
        textColor :: Color
textColor = ColorSpec -> Color
colorOfSpec (Theme -> ColorSpec
themeTextColor Theme
theme)

        px :: Double
px = PlotBox -> Double
boxX PlotBox
box
        py :: Double
py = PlotBox -> Double
boxY PlotBox
box
        pw :: Double
pw = PlotBox -> Double
boxW PlotBox
box
        ph :: Double
ph = PlotBox -> Double
boxH PlotBox
box

        spineStyle :: Style
spineStyle = Style
defaultStyle{styleStroke = Just axisColor, styleStrokeWidth = 1}

        xAxis :: Mark
xAxis = Point -> Point -> Style -> Mark
MAxisLine (Double -> Double -> Point
Point Double
px (Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph)) (Double -> Double -> Point
Point (Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
pw) (Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph)) Style
spineStyle
        yAxis :: Mark
yAxis = Point -> Point -> Style -> Mark
MAxisLine (Double -> Double -> Point
Point Double
px Double
py) (Double -> Double -> Point
Point Double
px (Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph)) Style
spineStyle

        xLabels :: [Mark]
xLabels = Theme
-> Double
-> Double
-> Double
-> Double
-> Color
-> XLabelMode
-> TrainedScale
-> [Mark]
xAxisLabels Theme
theme Double
px Double
py Double
pw Double
ph Color
textColor XLabelMode
xmode TrainedScale
xs
        yLabels :: [Mark]
yLabels = Theme
-> Double
-> Double
-> Double
-> Bool
-> Color
-> TrainedScale
-> [Mark]
yAxisLabels Theme
theme Double
px Double
py Double
ph Bool
flipY Color
textColor TrainedScale
ys
     in [Mark
xAxis, Mark
yAxis] [Mark] -> [Mark] -> [Mark]
forall a. Semigroup a => a -> a -> a
<> [Mark]
xLabels [Mark] -> [Mark] -> [Mark]
forall a. Semigroup a => a -> a -> a
<> [Mark]
yLabels

{- | X-axis tick labels that automatically adapt to long words, following the
chart-global 'XLabelMode' so margin sizing and rendering agree. If the labels
fit their per-tick slot they render upright (unchanged). Otherwise, keyed on the
data: numeric labels are thinned to a subset that fits (dropping ticks on a
continuum is fine, and the first\/last are always kept so the axis bounds stay
labelled), while categorical labels are rotated −45° and, past
'rotatedLabelLimitPx', truncated with a hover @\<title\>@ — a category name is
never silently dropped. Rotation and the @\<title\>@ tooltip are SVG-only; the
terminal backend draws the (truncated) text upright.
-}
xAxisLabels ::
    Theme ->
    Double ->
    Double ->
    Double ->
    Double ->
    Color ->
    XLabelMode ->
    TrainedScale ->
    [Mark]
xAxisLabels :: Theme
-> Double
-> Double
-> Double
-> Double
-> Color
-> XLabelMode
-> TrainedScale
-> [Mark]
xAxisLabels Theme
theme Double
px Double
py Double
pw Double
ph Color
textColor XLabelMode
xmode TrainedScale
xs = case XPolicy
resolvedPolicy of
    XPolicy
XUpright -> ((Double, Text) -> Mark) -> [(Double, Text)] -> [Mark]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> (Double, Text) -> Mark
upright Double
budget) [(Double, Text)]
raw
    XPolicy
XThin ->
        let keep :: [Int]
keep = Int -> Double -> Double -> [Int]
thinIndices Int
n Double
maxW Double
pw
            slot :: Double
slot = Double
pw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
keep))
         in [Double -> (Double, Text) -> Mark
upright Double
slot ([(Double, Text)]
raw [(Double, Text)] -> Int -> (Double, Text)
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) | Int
i <- [Int]
keep]
    XPolicy
XRotate -> ((Double, Text) -> Mark) -> [(Double, Text)] -> [Mark]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Text) -> Mark
rotated [(Double, Text)]
raw
  where
    fontSize :: Double
fontSize = Theme -> Double
themeFontSize Theme
theme
    baseY :: Double
baseY = Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
fontSize Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
4
    raw :: [(Double, Text)]
raw =
        [ (Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
+ TrainedScale -> Double -> Double
tsProject TrainedScale
xs Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
pw, Text
lbl)
        | (Double
v, Text
lbl) <- [Double] -> [Text] -> [(Double, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TrainedScale -> [Double]
tsBreaks TrainedScale
xs) (TrainedScale -> [Text]
tsLabels TrainedScale
xs)
        , (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
xs) Double
v
        ]
    n :: Int
n = [(Double, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Double, Text)]
raw
    maxW :: Double
maxW = Double -> [Text] -> Double
maxLabelWidth Double
fontSize (((Double, Text) -> Text) -> [(Double, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Text) -> Text
forall a b. (a, b) -> b
snd [(Double, Text)]
raw)
    budget :: Double
budget = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 then Double
pw else Double
pw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    resolvedPolicy :: XPolicy
resolvedPolicy = case XLabelMode
xmode of
        XFixed XPolicy
p -> XPolicy
p
        -- Faceted: pick from this panel's own width but never rotate.
        XLabelMode
XLocalNoRotate -> case Double -> Double -> [Text] -> XPolicy
xLabelPolicy Double
fontSize Double
budget (((Double, Text) -> Text) -> [(Double, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Text) -> Text
forall a b. (a, b) -> b
snd [(Double, Text)]
raw) of
            XPolicy
XRotate -> XPolicy
XUpright
            XPolicy
p -> XPolicy
p
    sty :: TextAnchor -> Double -> Maybe Text -> TextStyle
sty TextAnchor
anchor Double
rot Maybe Text
title =
        TextStyle
defaultTextStyle
            { textFill = textColor
            , textSize = fontSize
            , textAnchor = anchor
            , textRotate = rot
            , textTitle = title
            }
    upright :: Double -> (Double, Text) -> Mark
upright Double
slot (Double
xp, Text
full) =
        let (Text
lbl, Maybe Text
title) = Double -> Double -> Text -> (Text, Maybe Text)
truncatePx Double
fontSize Double
slot Text
full
         in Point -> Text -> TextStyle -> Mark
MText (Double -> Double -> Point
Point Double
xp Double
baseY) Text
lbl (TextAnchor -> Double -> Maybe Text -> TextStyle
sty TextAnchor
AnchorMiddle Double
0 Maybe Text
title)
    rotated :: (Double, Text) -> Mark
rotated (Double
xp, Text
full) =
        let (Text
lbl, Maybe Text
title) = Double -> Double -> Text -> (Text, Maybe Text)
truncatePx Double
fontSize Double
rotatedLabelLimitPx Text
full
         in Point -> Text -> TextStyle -> Mark
MText (Double -> Double -> Point
Point Double
xp Double
baseY) Text
lbl (TextAnchor -> Double -> Maybe Text -> TextStyle
sty TextAnchor
AnchorEnd (-Double
45) Maybe Text
title)

{- | Indices of a thinned label subset: the most evenly-spaced labels that fit
@plotW@ at width @maxW@, always including the first and last so the axis bounds
stay labelled. (Even-index thinning could drop the max tick on an even count.)
-}
thinIndices :: Int -> Double -> Double -> [Int]
thinIndices :: Int -> Double -> Double -> [Int]
thinIndices Int
n Double
maxW Double
plotW
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 = [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
    | Bool
otherwise =
        let fit :: Int
fit = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
2 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
plotW Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 Double
maxW)))
            pick :: Int -> b
pick Int
j = Double -> b
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
fit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) :: Double)
         in [Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
forall {b}. Integral b => Int -> b
pick [Int
0 .. Int
fit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])

{- | Y-axis (left) tick labels, one per break. Truncated with a hover
@\<title\>@ to fit the left margin (the margin itself is grown to hold long
labels up to a cap; this only bites past that cap).
-}
yAxisLabels ::
    Theme -> Double -> Double -> Double -> Bool -> Color -> TrainedScale -> [Mark]
yAxisLabels :: Theme
-> Double
-> Double
-> Double
-> Bool
-> Color
-> TrainedScale
-> [Mark]
yAxisLabels Theme
theme Double
px Double
py Double
ph Bool
flipY Color
textColor TrainedScale
ys =
    [ Point -> Text -> TextStyle -> Mark
MText (Double -> Double -> Point
Point (Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
6) (Double
yPos Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
fontSize Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3)) Text
lbl (Maybe Text -> TextStyle
sty Maybe Text
title)
    | (Double
v, Text
full) <- [Double] -> [Text] -> [(Double, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TrainedScale -> [Double]
tsBreaks TrainedScale
ys) (TrainedScale -> [Text]
tsLabels TrainedScale
ys)
    , (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
ys) Double
v
    , let yPos :: Double
yPos =
            if Bool
flipY then Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ TrainedScale -> Double -> Double
tsProject TrainedScale
ys Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ph else Double
py Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ph Double -> Double -> Double
forall a. Num a => a -> a -> a
- TrainedScale -> Double -> Double
tsProject TrainedScale
ys Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ph
          (Text
lbl, Maybe Text
title) = Double -> Double -> Text -> (Text, Maybe Text)
truncatePx Double
fontSize (Double
px Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
10) Text
full
    ]
  where
    fontSize :: Double
fontSize = Theme -> Double
themeFontSize Theme
theme
    sty :: Maybe Text -> TextStyle
sty Maybe Text
title =
        TextStyle
defaultTextStyle
            { textFill = textColor
            , textSize = fontSize
            , textAnchor = AnchorEnd
            , textTitle = title
            }

{- | A label produced by a numeric axis — only decimal\/scientific digits,
so categorical values like @\"NaN\"@, @\"Infinity\"@ or @\"0x10\"@ (which
'readMaybe' would otherwise accept) are correctly treated as categories.
-}
isNumericLabel :: Text -> Bool
isNumericLabel :: Text -> Bool
isNumericLabel Text
t =
    Bool -> Bool
not (Text -> Bool
Text.null Text
s)
        Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
Text.all (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789.eE+-" :: String)) Text
s
        Bool -> Bool -> Bool
&& Maybe Double -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Double
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) :: Maybe Double)
  where
    s :: Text
s = Text -> Text
Text.strip Text
t

{- | Concentric rings (radial breaks) + radial spokes (angular breaks)
+ tick labels. Centred in the plot box with radius = half its
shortest side.
-}
polarAxes ::
    Theme ->
    PlotBox ->
    PolarAes ->
    Double ->
    PolarDir ->
    TrainedScale ->
    TrainedScale ->
    [Mark]
polarAxes :: Theme
-> PlotBox
-> PolarAes
-> Double
-> PolarDir
-> TrainedScale
-> TrainedScale
-> [Mark]
polarAxes Theme
theme PlotBox
box PolarAes
aes Double
a0 PolarDir
dir TrainedScale
xs TrainedScale
ys =
    let cx :: Double
cx = PlotBox -> Double
boxX PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
+ PlotBox -> Double
boxW PlotBox
box Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
        cy :: Double
cy = PlotBox -> Double
boxY PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
+ PlotBox -> Double
boxH PlotBox
box Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
        maxR :: Double
maxR = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (PlotBox -> Double
boxW PlotBox
box) (PlotBox -> Double
boxH PlotBox
box) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
        gridColor :: Color
gridColor = ColorSpec -> Color
colorOfSpec (Theme -> ColorSpec
themeGridColor Theme
theme)
        axisColor :: Color
axisColor = ColorSpec -> Color
colorOfSpec (Theme -> ColorSpec
themeAxisColor Theme
theme)
        textColor :: Color
textColor = ColorSpec -> Color
colorOfSpec (Theme -> ColorSpec
themeTextColor Theme
theme)
        sign :: Double
sign = case PolarDir
dir of
            PolarDir
PolarCW -> Double
1
            PolarDir
PolarCCW -> -Double
1 :: Double

        (TrainedScale
thetaScale, TrainedScale
radialScale) = case PolarAes
aes of
            PolarAes
ThetaX -> (TrainedScale
xs, TrainedScale
ys)
            PolarAes
ThetaY -> (TrainedScale
ys, TrainedScale
xs)

        circleAt :: Double -> Maybe Color -> Double -> Mark
        circleAt :: Double -> Maybe Color -> Double -> Mark
circleAt Double
rPx Maybe Color
stroke Double
widthPx =
            let nSeg :: Int
nSeg = Int
64 :: Int
                pts :: [Point]
pts =
                    [ Double -> Double -> Point
Point (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rPx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
a) (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rPx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
a)
                    | Int
i <- [Int
0 .. Int
nSeg]
                    , let a :: Double
a = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nSeg) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
                    ]
             in [Point] -> Style -> Mark
MPolyline [Point]
pts Style
defaultStyle{styleStroke = stroke, styleStrokeWidth = widthPx}

        rings :: [Mark]
rings =
            [ Double -> Maybe Color -> Double -> Mark
circleAt (TrainedScale -> Double -> Double
tsProject TrainedScale
radialScale Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
maxR) (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
gridColor) Double
0.5
            | Double
v <- TrainedScale -> [Double]
tsBreaks TrainedScale
radialScale
            , (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
radialScale) Double
v
            , TrainedScale -> Double -> Double
tsProject TrainedScale
radialScale Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1e-6
            ]

        outerRing :: Mark
outerRing = Double -> Maybe Color -> Double -> Mark
circleAt Double
maxR (Color -> Maybe Color
forall a. a -> Maybe a
Just Color
axisColor) Double
1

        spokeFor :: Double -> Mark
spokeFor Double
v =
            let t :: Double
t = TrainedScale -> Double -> Double
tsProject TrainedScale
thetaScale Double
v
                theta :: Double
theta = Double
a0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
sign Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
                ox :: Double
ox = Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
maxR Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
theta
                oy :: Double
oy = Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
maxR Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
theta
             in [Point] -> Style -> Mark
MPolyline
                    [Double -> Double -> Point
Point Double
cx Double
cy, Double -> Double -> Point
Point Double
ox Double
oy]
                    Style
defaultStyle{styleStroke = Just gridColor, styleStrokeWidth = 0.5}
        spokes :: [Mark]
spokes =
            [ Double -> Mark
spokeFor Double
v
            | Double
v <- TrainedScale -> [Double]
tsBreaks TrainedScale
thetaScale
            , (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
thetaScale) Double
v
            ]

        thetaLabelOffset :: Double
thetaLabelOffset = Double
10
        thetaLabels :: [Mark]
thetaLabels =
            [ Point -> Text -> TextStyle -> Mark
MText
                ( Double -> Double -> Point
Point
                    (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
maxR Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
thetaLabelOffset) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
theta)
                    (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
maxR Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
thetaLabelOffset) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
theta Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Theme -> Double
themeFontSize Theme
theme Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3)
                )
                Text
lbl
                TextStyle
defaultTextStyle
                    { textFill = textColor
                    , textSize = themeFontSize theme
                    , textAnchor = AnchorMiddle
                    }
            | (Double
v, Text
lbl) <- [Double] -> [Text] -> [(Double, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TrainedScale -> [Double]
tsBreaks TrainedScale
thetaScale) (TrainedScale -> [Text]
tsLabels TrainedScale
thetaScale)
            , (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
thetaScale) Double
v
            , let theta :: Double
theta = Double
a0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
sign Double -> Double -> Double
forall a. Num a => a -> a -> a
* TrainedScale -> Double -> Double
tsProject TrainedScale
thetaScale Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
            ]

        rLabels :: [Mark]
rLabels =
            [ Point -> Text -> TextStyle -> Mark
MText
                ( Double -> Double -> Point
Point
                    (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rPx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
a0 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
3)
                    (Double
cy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rPx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
a0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2)
                )
                Text
lbl
                TextStyle
defaultTextStyle
                    { textFill = textColor
                    , textSize = themeFontSize theme
                    , textAnchor = AnchorStart
                    }
            | (Double
v, Text
lbl) <- [Double] -> [Text] -> [(Double, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TrainedScale -> [Double]
tsBreaks TrainedScale
radialScale) (TrainedScale -> [Text]
tsLabels TrainedScale
radialScale)
            , (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
radialScale) Double
v
            , let rPx :: Double
rPx = TrainedScale -> Double -> Double
tsProject TrainedScale
radialScale Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
maxR
            , Double
rPx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1e-6
            ]
     in [Mark]
rings [Mark] -> [Mark] -> [Mark]
forall a. Semigroup a => a -> a -> a
<> [Mark]
spokes [Mark] -> [Mark] -> [Mark]
forall a. Semigroup a => a -> a -> a
<> [Mark
outerRing] [Mark] -> [Mark] -> [Mark]
forall a. Semigroup a => a -> a -> a
<> [Mark]
thetaLabels [Mark] -> [Mark] -> [Mark]
forall a. Semigroup a => a -> a -> a
<> [Mark]
rLabels

inDomain :: (Double, Double) -> Double -> Bool
inDomain :: (Double, Double) -> Double -> Bool
inDomain (Double
lo, Double
hi) Double
v = Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
lo Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1e-9 Bool -> Bool -> Bool
&& Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hi Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1e-9

-- | A trained scale's in-domain tick labels, in break order.
domainLabels :: TrainedScale -> [Text]
domainLabels :: TrainedScale -> [Text]
domainLabels TrainedScale
s = [Text
lbl | (Double
v, Text
lbl) <- [Double] -> [Text] -> [(Double, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip (TrainedScale -> [Double]
tsBreaks TrainedScale
s) (TrainedScale -> [Text]
tsLabels TrainedScale
s), (Double, Double) -> Double -> Bool
inDomain (TrainedScale -> (Double, Double)
tsDomain TrainedScale
s) Double
v]

titleMarks :: Theme -> PlotBox -> Maybe Text -> [Mark]
titleMarks :: Theme -> PlotBox -> Maybe Text -> [Mark]
titleMarks Theme
_ PlotBox
_ Maybe Text
Nothing = []
titleMarks Theme
_ PlotBox
_ (Just Text
t) | Text -> Bool
Text.null Text
t = []
titleMarks Theme
theme PlotBox
box (Just Text
t) =
    [ Point -> Text -> TextStyle -> Mark
MText
        (Double -> Double -> Point
Point (PlotBox -> Double
boxX PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
+ PlotBox -> Double
boxW PlotBox
box Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) (PlotBox -> Double
boxY PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
8))
        Text
t
        TextStyle
defaultTextStyle
            { textFill = colorOfSpec (themeTextColor theme)
            , textSize = themeTitleSize theme
            , textAnchor = AnchorMiddle
            }
    ]

legendMarks :: Theme -> PlotBox -> [(Text, ColorSpec)] -> [Mark]
legendMarks :: Theme -> PlotBox -> [(Text, ColorSpec)] -> [Mark]
legendMarks Theme
theme PlotBox
box [(Text, ColorSpec)]
entries =
    let lx :: Double
lx = PlotBox -> Double
boxX PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
+ PlotBox -> Double
boxW PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
15
        ly :: Double
ly = PlotBox -> Double
boxY PlotBox
box Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
5
        rowH :: Double
rowH = Theme -> Double
themeFontSize Theme
theme Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
6
     in [[Mark]] -> [Mark]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ let yy :: Double
yy = Double
ly Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
rowH
                  swatch :: Mark
swatch =
                    Rect -> Style -> Mark
MRect
                        (Double -> Double -> Double -> Double -> Rect
Rect Double
lx Double
yy Double
12 Double
12)
                        Style
defaultStyle{styleFill = Just (exactColor col)}
                  label :: Mark
label =
                    Point -> Text -> TextStyle -> Mark
MText
                        (Double -> Double -> Point
Point (Double
lx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
16) (Double
yy Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Theme -> Double
themeFontSize Theme
theme Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1))
                        Text
name
                        TextStyle
defaultTextStyle
                            { textFill = colorOfSpec (themeTextColor theme)
                            , textSize = themeFontSize theme
                            , textAnchor = AnchorStart
                            }
               in [Mark
swatch, Mark
label]
            | (Int
i, (Text
name, ColorSpec
col)) <- [Int] -> [(Text, ColorSpec)] -> [(Int, (Text, ColorSpec))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(Text, ColorSpec)]
entries
            ]

{- | The exact RGB 'Color' for a spec, so a legend swatch matches the data it
labels (the SVG backend renders it exactly; the terminal backend quantises
'Color' to ANSI at draw time). Contrast 'colorOfSpec', which quantises eagerly.
-}
exactColor :: ColorSpec -> Color
exactColor :: ColorSpec -> Color
exactColor (NamedColor Color
c) = Color
c
exactColor (RGB Word8
r Word8
g Word8
b) = Word8 -> Word8 -> Word8 -> Color
Color Word8
r Word8
g Word8
b
exactColor (Hex Text
h) = case Text -> Maybe (Double, Double, Double)
parseHex Text
h of
    Just (Double
r, Double
g, Double
b) -> Word8 -> Word8 -> Word8 -> Color
Color (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
r) (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
g) (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
b)
    Maybe (Double, Double, Double)
Nothing -> Color
Default

{- | Quantise a 'ColorSpec' to the nearest ANSI 'Color' for the
terminal backend; SVG reads RGB / Hex directly.
-}
colorOfSpec :: ColorSpec -> Color
colorOfSpec :: ColorSpec -> Color
colorOfSpec (NamedColor Color
c) = Color
c
colorOfSpec (RGB Word8
r Word8
g Word8
b) = Double -> Double -> Double -> Color
nearestAnsi (Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r) (Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g) (Word8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b)
colorOfSpec (Hex Text
h) =
    case Text -> Maybe (Double, Double, Double)
parseHex Text
h of
        Just (Double
r, Double
g, Double
b) -> Double -> Double -> Double -> Color
nearestAnsi Double
r Double
g Double
b
        Maybe (Double, Double, Double)
Nothing -> Color
Default

parseHex :: Text -> Maybe (Double, Double, Double)
parseHex :: Text -> Maybe (Double, Double, Double)
parseHex Text
t =
    let s :: String
s = Text -> String
Text.unpack ((Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') Text
t)
     in case String
s of
            [Char
a, Char
b, Char
c, Char
d, Char
e, Char
f] ->
                (,,) (Double -> Double -> Double -> (Double, Double, Double))
-> Maybe Double
-> Maybe (Double -> Double -> (Double, Double, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Double
fromHex2 [Char
a, Char
b] Maybe (Double -> Double -> (Double, Double, Double))
-> Maybe Double -> Maybe (Double -> (Double, Double, Double))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Double
fromHex2 [Char
c, Char
d] Maybe (Double -> (Double, Double, Double))
-> Maybe Double -> Maybe (Double, Double, Double)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Double
fromHex2 [Char
e, Char
f]
            String
_ -> Maybe (Double, Double, Double)
forall a. Maybe a
Nothing

fromHex2 :: String -> Maybe Double
fromHex2 :: String -> Maybe Double
fromHex2 [Char
a, Char
b] = do
    Int
h <- Char -> Maybe Int
digit Char
a
    Int
l <- Char -> Maybe Int
digit Char
b
    Double -> Maybe Double
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l))
  where
    digit :: Char -> Maybe Int
digit Char
ch
        | Char -> Bool
isDigit Char
ch = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'0')
        | Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'a')
        | Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'A')
        | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
fromHex2 String
_ = Maybe Double
forall a. Maybe a
Nothing

{- | Nearest of the 16 ANSI colors using the canonical VGA palette
(not the pastel SVG hex values). Important for visibility: mid-gray
@#555555@ maps to 'BrightBlack' (a real grey), not 'Black' (which
would be invisible on a dark terminal).
-}
nearestAnsi :: Double -> Double -> Double -> Color
nearestAnsi :: Double -> Double -> Double -> Color
nearestAnsi Double
r Double
g Double
b =
    let candidates :: [(Color, Double, Double, Double)]
candidates =
            [ (Color
Black, Double
0, Double
0, Double
0)
            , (Color
Red, Double
170, Double
0, Double
0)
            , (Color
Green, Double
0, Double
170, Double
0)
            , (Color
Yellow, Double
170, Double
85, Double
0)
            , (Color
Blue, Double
0, Double
0, Double
170)
            , (Color
Magenta, Double
170, Double
0, Double
170)
            , (Color
Cyan, Double
0, Double
170, Double
170)
            , (Color
White, Double
170, Double
170, Double
170)
            , (Color
BrightBlack, Double
85, Double
85, Double
85)
            , (Color
BrightRed, Double
255, Double
85, Double
85)
            , (Color
BrightGreen, Double
85, Double
255, Double
85)
            , (Color
BrightYellow, Double
255, Double
255, Double
85)
            , (Color
BrightBlue, Double
85, Double
85, Double
255)
            , (Color
BrightMagenta, Double
255, Double
85, Double
255)
            , (Color
BrightCyan, Double
85, Double
255, Double
255)
            , (Color
BrightWhite, Double
255, Double
255, Double
255)
            ]
        dist :: (a, Double, Double, Double) -> Double
dist (a
_, Double
cr, Double
cg, Double
cb) = Double -> Double
forall {a}. Num a => a -> a
sq (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cr) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall {a}. Num a => a -> a
sq (Double
g Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cg) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall {a}. Num a => a -> a
sq (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cb)
        sq :: a -> a
sq a
x = a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x
        pick :: (a, Double) -> (a, Double, Double, Double) -> (a, Double)
pick (a
best, Double
bd) (a, Double, Double, Double)
cand =
            let d :: Double
d = (a, Double, Double, Double) -> Double
forall {a}. (a, Double, Double, Double) -> Double
dist (a, Double, Double, Double)
cand
             in if Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
bd then ((a, Double, Double, Double) -> a
forall {a} {b} {c} {d}. (a, b, c, d) -> a
fstC (a, Double, Double, Double)
cand, Double
d) else (a
best, Double
bd)
        fstC :: (a, b, c, d) -> a
fstC (a
c, b
_, c
_, d
_) = a
c
     in (Color, Double) -> Color
forall a b. (a, b) -> a
fst (((Color, Double)
 -> (Color, Double, Double, Double) -> (Color, Double))
-> (Color, Double)
-> [(Color, Double, Double, Double)]
-> (Color, Double)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Color, Double)
-> (Color, Double, Double, Double) -> (Color, Double)
forall {a}.
(a, Double) -> (a, Double, Double, Double) -> (a, Double)
pick (Color
Default, Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0) [(Color, Double, Double, Double)]
candidates)