{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Chart.Hud
( runHudWith,
runHud,
makeHud,
freezeTicks,
flipAxis,
canvas,
title,
tick,
precision,
adjustTick,
makeTickDates,
legendHud,
legendEntry,
legendChart,
legendFromChart,
)
where
import Chart.Core
import Chart.Format
import Chart.Svg (styleBox, styleBoxText, styleBoxes)
import Chart.Types
import Control.Category (id)
import qualified Control.Foldl as L
import Control.Lens
import Control.Monad.Trans.State.Lazy
import Data.Time
import GHC.Generics
import NumHask.Space
import Protolude
runHudWith ::
Rect Double ->
Rect Double ->
[Hud Double] ->
[Chart Double] ->
[Chart Double]
runHudWith ca xs hs cs =
flip evalState (ChartDims ca' da' xs) $
(unhud $ mconcat hs) cs'
where
da' = defRect $ dataBox cs'
ca' = defRect $ styleBoxes cs'
cs' = projectSpotsWith ca xs cs
runHud :: Rect Double -> [Hud Double] -> [Chart Double] -> [Chart Double]
runHud ca hs cs = runHudWith ca (defRectS $ dataBox cs) hs cs
makeHud :: Rect Double -> HudOptions -> ([Hud Double], [Chart Double])
makeHud xs cfg =
(haxes <> [can] <> titles <> [l], [xsext])
where
can = maybe mempty (\x -> canvas x) (cfg ^. #hudCanvas)
titles = title <$> (cfg ^. #hudTitles)
newticks = (\a -> freezeTicks (a ^. #place) xs (a ^. #atick . #tstyle)) <$> (cfg ^. #hudAxes)
axes' = zipWith (\c t -> c & #atick . #tstyle .~ fst t) (cfg ^. #hudAxes) newticks
xsext = Chart BlankA (SpotRect <$> catMaybes (snd <$> newticks))
haxes = (\x -> maybe mempty (\a -> bar (x ^. #place) a) (x ^. #abar) <> adjustedTickHud x) <$> axes'
l = maybe mempty (\(lo, ats) -> legendHud lo (legendChart ats lo)) (cfg ^. #hudLegend)
freezeTicks :: Place -> Rect Double -> TickStyle -> (TickStyle, Maybe (Rect Double))
freezeTicks pl xs' ts@TickRound {} = maybe (ts, Nothing) (\x -> (TickPlaced (zip ps ls), Just x)) ((\x -> replaceRange pl x xs') <$> ext)
where
(TickComponents ps ls ext) = makeTicks ts (placeRange pl xs')
replaceRange :: Place -> Range Double -> Rect Double -> Rect Double
replaceRange pl' (Range a0 a1) (Rect x z y w) = case pl' of
PlaceRight -> Rect x z a0 a1
PlaceLeft -> Rect x z a0 a1
_ -> Rect a0 a1 y w
freezeTicks _ _ ts = (ts, Nothing)
flipAxis :: AxisOptions -> AxisOptions
flipAxis ac = case ac ^. #place of
PlaceBottom -> ac & #place .~ PlaceLeft
PlaceTop -> ac & #place .~ PlaceRight
PlaceLeft -> ac & #place .~ PlaceBottom
PlaceRight -> ac & #place .~ PlaceTop
PlaceAbsolute _ -> ac
addToRect :: (Ord a) => Rect a -> Maybe (Rect a) -> Rect a
addToRect r r' = sconcat $ r :| maybeToList r'
canvas :: (Monad m) => RectStyle -> HudT m Double
canvas s = Hud $ \cs -> do
a <- use #canvasDim
let c = Chart (RectA s) [SpotRect a]
#canvasDim .= addToRect a (styleBox c)
pure $ c : cs
bar_ :: Place -> Bar -> Rect Double -> Rect Double -> Chart Double
bar_ pl b (Rect x z y w) (Rect x' z' y' w') =
case pl of
PlaceTop ->
Chart
(RectA (rstyle b))
[ SR
x
z
(w' + b ^. #buff)
(w' + b ^. #buff + b ^. #wid)
]
PlaceBottom ->
Chart
(RectA (rstyle b))
[ SR
x
z
(y' - b ^. #wid - b ^. #buff)
(y' - b ^. #buff)
]
PlaceLeft ->
Chart
(RectA (rstyle b))
[ SR
(x' - b ^. #wid - b ^. #buff)
(x' - b ^. #buff)
y
w
]
PlaceRight ->
Chart
(RectA (rstyle b))
[ SR
(z' + (b ^. #buff))
(z' + (b ^. #buff) + (b ^. #wid))
y
w
]
PlaceAbsolute (Point x'' _) ->
Chart
(RectA (rstyle b))
[ SR
(x'' + (b ^. #buff))
(x'' + (b ^. #buff) + (b ^. #wid))
y
w
]
bar :: (Monad m) => Place -> Bar -> HudT m Double
bar pl b = Hud $ \cs -> do
da <- use #chartDim
ca <- use #canvasDim
let c = bar_ pl b ca da
#chartDim .= addChartBox c da
pure $ c : cs
title_ :: Title -> Rect Double -> Chart Double
title_ t a =
Chart
( TextA
( style'
& #translate ?~ (realToFrac <$> (placePos' a + alignPos a))
& #rotation ?~ rot
)
[t ^. #text]
)
[SP 0 0]
where
style'
| t ^. #anchor == AnchorStart =
#anchor .~ AnchorStart $ t ^. #style
| t ^. #anchor == AnchorEnd =
#anchor .~ AnchorEnd $ t ^. #style
| otherwise = t ^. #style
rot
| t ^. #place == PlaceRight = 90.0
| t ^. #place == PlaceLeft = -90.0
| otherwise = 0
placePos' (Rect x z y w) = case t ^. #place of
PlaceTop -> Point ((x + z) / 2.0) (w + (t ^. #buff))
PlaceBottom ->
Point
((x + z) / 2.0)
( y - (t ^. #buff)
- 0.5
* realToFrac (t ^. #style . #vsize)
* realToFrac (t ^. #style . #size)
)
PlaceLeft -> Point (x - (t ^. #buff)) ((y + w) / 2.0)
PlaceRight -> Point (z + (t ^. #buff)) ((y + w) / 2.0)
PlaceAbsolute p -> p
alignPos (Rect x z y w)
| t ^. #anchor == AnchorStart
&& t ^. #place `elem` [PlaceTop, PlaceBottom] =
Point ((x - z) / 2.0) 0.0
| t ^. #anchor == AnchorStart
&& t ^. #place == PlaceLeft =
Point 0.0 ((y - w) / 2.0)
| t ^. #anchor == AnchorStart
&& t ^. #place == PlaceRight =
Point 0.0 ((w - y) / 2.0)
| t ^. #anchor == AnchorEnd
&& t ^. #place `elem` [PlaceTop, PlaceBottom] =
Point ((- x + z) / 2.0) 0.0
| t ^. #anchor == AnchorEnd
&& t ^. #place == PlaceLeft =
Point 0.0 ((- y + w) / 2.0)
| t ^. #anchor == AnchorEnd
&& t ^. #place == PlaceRight =
Point 0.0 ((y - w) / 2.0)
| otherwise = Point 0.0 0.0
title :: (Monad m) => Title -> HudT m Double
title t = Hud $ \cs -> do
ca <- use #chartDim
let c = title_ t ca
#chartDim .= addChartBox c ca
pure $ c : cs
placePos :: Place -> Double -> Rect Double -> Point Double
placePos pl b (Rect x z y w) = case pl of
PlaceTop -> Point 0 (w + b)
PlaceBottom -> Point 0 (y - b)
PlaceLeft -> Point (x - b) 0
PlaceRight -> Point (z + b) 0
PlaceAbsolute p -> p
placeRot :: Place -> Maybe Double
placeRot pl = case pl of
PlaceRight -> Just (-90.0)
PlaceLeft -> Just (-90.0)
_ -> Nothing
textPos :: Place -> TextStyle -> Double -> Point Double
textPos pl tt b = case pl of
PlaceTop -> Point 0 b
PlaceBottom -> Point 0 (- b - 0.5 * realToFrac (tt ^. #vsize) * realToFrac (tt ^. #size))
PlaceLeft ->
Point
(- b)
(realToFrac (tt ^. #nudge1) * realToFrac (tt ^. #vsize) * realToFrac (tt ^. #size))
PlaceRight ->
Point
b
(realToFrac (tt ^. #nudge1) * realToFrac (tt ^. #vsize) * realToFrac (tt ^. #size))
PlaceAbsolute p -> p
placeRange :: Place -> Rect Double -> Range Double
placeRange pl (Rect x z y w) = case pl of
PlaceRight -> Range y w
PlaceLeft -> Range y w
_ -> Range x z
placeOrigin :: Place -> Double -> Point Double
placeOrigin pl x
| pl `elem` [PlaceTop, PlaceBottom] = Point x 0
| otherwise = Point 0 x
placeTextAnchor :: Place -> (TextStyle -> TextStyle)
placeTextAnchor pl
| pl == PlaceLeft = #anchor .~ AnchorEnd
| pl == PlaceRight = #anchor .~ AnchorStart
| otherwise = id
placeGridLines :: Place -> Rect Double -> Double -> Double -> [Spot Double]
placeGridLines pl (Rect x z y w) a b
| pl `elem` [PlaceTop, PlaceBottom] = [SP a (y - b), SP a (w + b)]
| otherwise = [SP (x - b) a, SP (z + b) a]
ticksR :: TickStyle -> Range Double -> Range Double -> [(Double, Text)]
ticksR s d r =
case s of
TickNone -> []
TickRound f n e -> zip (project r d <$> ticks0) (formatNs f ticks0)
where
ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer)
TickExact f n -> zip (project r d <$> ticks0) (formatNs f ticks0)
where
ticks0 = grid OuterPos r n
TickLabels ls ->
zip
( project (Range 0 (fromIntegral $ length ls)) d
<$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls])
)
ls
TickPlaced xs -> zip (project r d . fst <$> xs) (snd <$> xs)
data TickComponents
= TickComponents
{ positions :: [Double],
labels :: [Text],
extension :: Maybe (Range Double)
}
deriving (Eq, Show, Generic)
makeTicks :: TickStyle -> Range Double -> TickComponents
makeTicks s r =
case s of
TickNone -> TickComponents [] [] Nothing
TickRound f n e ->
TickComponents
ticks0
(formatNs f ticks0)
(bool (Just $ space1 ticks0) Nothing (e == NoTickExtend))
where
ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer)
TickExact f n -> TickComponents ticks0 (formatNs f ticks0) Nothing
where
ticks0 = grid OuterPos r n
TickLabels ls ->
TickComponents
( project (Range 0 (fromIntegral $ length ls)) r
<$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls])
)
ls
Nothing
TickPlaced xs -> TickComponents (fst <$> xs) (snd <$> xs) Nothing
ticksPlaced :: TickStyle -> Place -> Rect Double -> Rect Double -> TickComponents
ticksPlaced ts pl d xs = TickComponents (project (placeRange pl xs) (placeRange pl d) <$> ps) ls ext
where
(TickComponents ps ls ext) = makeTicks ts (placeRange pl xs)
tickGlyph_ :: Place -> (GlyphStyle, Double) -> TickStyle -> Rect Double -> Rect Double -> Rect Double -> Chart Double
tickGlyph_ pl (g, b) ts ca da xs =
Chart
(GlyphA (g & #rotation .~ (realToFrac <$> placeRot pl)))
( SpotPoint . (placePos pl b ca +) . placeOrigin pl
<$> positions
(ticksPlaced ts pl da xs)
)
tickGlyph ::
(Monad m) =>
Place ->
(GlyphStyle, Double) ->
TickStyle ->
HudT m Double
tickGlyph pl (g, b) ts = Hud $ \cs -> do
a <- use #chartDim
d <- use #canvasDim
xs <- use #dataDim
let c = tickGlyph_ pl (g, b) ts a d xs
#chartDim .= addToRect a (styleBox c)
pure $ c : cs
tickText_ ::
Place ->
(TextStyle, Double) ->
TickStyle ->
Rect Double ->
Rect Double ->
Rect Double ->
[Chart Double]
tickText_ pl (txts, b) ts ca da xs =
zipWith
( \txt sp ->
Chart
( TextA
(placeTextAnchor pl txts)
[txt]
)
[SpotPoint sp]
)
(labels $ ticksPlaced ts pl da xs)
( (placePos pl b ca + textPos pl txts b +) . placeOrigin pl
<$> positions (ticksPlaced ts pl da xs)
)
tickText ::
(Monad m) =>
Place ->
(TextStyle, Double) ->
TickStyle ->
HudT m Double
tickText pl (txts, b) ts = Hud $ \cs -> do
ca <- use #chartDim
da <- use #canvasDim
xs <- use #dataDim
let c = tickText_ pl (txts, b) ts ca da xs
#chartDim .= addChartBoxes c ca
pure $ c <> cs
tickLine ::
(Monad m) =>
Place ->
(LineStyle, Double) ->
TickStyle ->
HudT m Double
tickLine pl (ls, b) ts = Hud $ \cs -> do
da <- use #canvasDim
xs <- use #dataDim
let c =
Chart (LineA ls) . (\x -> placeGridLines pl da x b)
<$> positions (ticksPlaced ts pl da xs)
#chartDim %= addChartBoxes c
pure $ c <> cs
tick ::
(Monad m) =>
Place ->
Tick ->
HudT m Double
tick pl t =
maybe mempty (\x -> tickGlyph pl x (t ^. #tstyle)) (t ^. #gtick)
<> maybe mempty (\x -> tickText pl x (t ^. #tstyle)) (t ^. #ttick)
<> maybe mempty (\x -> tickLine pl x (t ^. #tstyle)) (t ^. #ltick)
<> extendData pl t
computeTickExtension :: TickStyle -> Range Double -> Maybe (Range Double)
computeTickExtension s r =
case s of
TickNone -> Nothing
TickRound _ n e -> bool Nothing (Just (space1 ticks0 <> r)) (e == TickExtend)
where
ticks0 = gridSensible OuterPos (e == NoTickExtend) r (fromIntegral n :: Integer)
TickExact _ _ -> Nothing
TickLabels _ -> Nothing
TickPlaced xs -> Just $ r <> space1 (fst <$> xs)
tickExtended ::
Place ->
Tick ->
Rect Double ->
Rect Double
tickExtended pl t xs =
maybe
xs
(\x -> rangeext xs x)
(computeTickExtension (t ^. #tstyle) (ranged xs))
where
ranged xs' = case pl of
PlaceTop -> rangex xs'
PlaceBottom -> rangex xs'
PlaceLeft -> rangey xs'
PlaceRight -> rangey xs'
PlaceAbsolute _ -> rangex xs'
rangex (Rect x z _ _) = Range x z
rangey (Rect _ _ y w) = Range y w
rangeext (Rect x z y w) (Range a0 a1) = case pl of
PlaceTop -> Rect a0 a1 y w
PlaceBottom -> Rect a0 a1 y w
PlaceLeft -> Rect x z a0 a1
PlaceRight -> Rect x z a0 a1
PlaceAbsolute _ -> Rect a0 a1 y w
extendData :: (Monad m) => Place -> Tick -> HudT m Double
extendData pl t = Hud $ \cs -> do
#dataDim %= tickExtended pl t
pure cs
adjustTick ::
Adjustments ->
Rect Double ->
Rect Double ->
Place ->
Tick ->
Tick
adjustTick (Adjustments mrx ma mry ad) vb cs pl t
| pl `elem` [PlaceBottom, PlaceTop] = case ad of
False -> t & #ttick . _Just . _1 . #size %~ (/ adjustSizeX)
True ->
case adjustSizeX > 1 of
True ->
( case pl of
PlaceBottom -> #ttick . _Just . _1 . #anchor .~ AnchorEnd
PlaceTop -> #ttick . _Just . _1 . #anchor .~ AnchorStart
_ -> #ttick . _Just . _1 . #anchor .~ AnchorEnd
)
. (#ttick . _Just . _1 . #size %~ (/ adjustSizeA))
$ (#ttick . _Just . _1 . #rotation ?~ (-45)) t
False -> (#ttick . _Just . _1 . #size %~ (/ adjustSizeA)) t
| otherwise =
(#ttick . _Just . _1 . #size %~ (/ adjustSizeY)) t
where
max' [] = 1
max' xs = maximum xs
ra (Rect x z y w)
| pl `elem` [PlaceTop, PlaceBottom] = Range x z
| otherwise = Range y w
asp = ra vb
r = ra cs
tickl = snd <$> ticksR (t ^. #tstyle) asp r
maxWidth :: Double
maxWidth =
maybe
1
( \tt ->
max' $
(\(Rect x z _ _) -> z - x)
. (\x -> styleBoxText (fst tt) x (Point 0 0)) <$> tickl
)
(t ^. #ttick)
maxHeight =
maybe
1
( \tt ->
max' $
(\(Rect _ _ y w) -> w - y)
. (\x -> styleBoxText (fst tt) x (Point 0 0)) <$> tickl
)
(t ^. #ttick)
adjustSizeX :: Double
adjustSizeX = max' [(maxWidth / realToFrac (upper asp - lower asp)) / mrx, 1]
adjustSizeY = max' [(maxHeight / realToFrac (upper asp - lower asp)) / mry, 1]
adjustSizeA = max' [(maxHeight / realToFrac (upper asp - lower asp)) / ma, 1]
adjustedTickHud :: (Monad m) => AxisOptions -> HudT m Double
adjustedTickHud c = Hud $ \cs -> do
vb <- use #chartDim
xs <- use #dataDim
let adjTick =
maybe
(c ^. #atick)
(\x -> adjustTick x vb xs (c ^. #place) (c ^. #atick))
(c ^. #adjust)
unhud (tick (c ^. #place) adjTick) cs
makeTickDates :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> [(Int, Text)]
makeTickDates pc fmt n dates =
lastOnes (\(_, x0) (_, x1) -> x0 == x1)
$ fst
$ placedTimeLabelDiscontinuous pc fmt n dates
where
lastOnes :: (a -> a -> Bool) -> [a] -> [a]
lastOnes _ [] = []
lastOnes _ [x] = [x]
lastOnes f (x : xs) = L.fold (L.Fold step (x, []) (\(x0, x1) -> reverse $ x0 : x1)) xs
where
step (a0, rs) a1 = if f a0 a1 then (a1, rs) else (a1, a0 : rs)
legendHud :: LegendOptions -> [Chart Double] -> Hud Double
legendHud l lcs = Hud $ \cs -> do
ca <- use #chartDim
let cs' = cs <> movedleg ca scaledleg
#chartDim .= defRect (styleBoxes cs')
pure cs'
where
scaledleg =
(#annotation %~ scaleAnn (realToFrac $ l ^. #lscale))
. (#spots %~ fmap (fmap (* l ^. #lscale)))
<$> lcs
movedleg ca' leg =
maybe id (moveChart . SpotPoint . placel (l ^. #lplace) ca') (styleBoxes leg) leg
placel pl (Rect x z y w) (Rect x' z' y' w') =
case pl of
PlaceTop -> Point ((x + z) / 2.0) (w + (w' - y') / 2.0)
PlaceBottom -> Point ((x + z) / 2.0) (y - (w' - y' / 2.0))
PlaceLeft -> Point (x - (z' - x') / 2.0) ((y + w) / 2.0)
PlaceRight -> Point (z + (z' - x') / 2.0) ((y + w) / 2.0)
PlaceAbsolute p -> p
legendEntry ::
LegendOptions ->
Annotation ->
Text ->
(Chart Double, Chart Double)
legendEntry l a t =
( Chart ann sps,
Chart (TextA (l ^. #ltext & #anchor .~ AnchorStart) [t]) [SP 0 0]
)
where
(ann, sps) = case a of
RectA rs ->
( RectA rs,
[SR 0 (l ^. #lsize) 0 (l ^. #lsize)]
)
PixelA ps ->
( PixelA ps,
[SR 0 (l ^. #lsize) 0 (l ^. #lsize)]
)
TextA ts txts ->
( TextA (ts & #size .~ realToFrac (l ^. #lsize)) (take 1 txts),
[SP 0 0]
)
GlyphA gs ->
( GlyphA (gs & #size .~ realToFrac (l ^. #lsize)),
[SP (0.5 * l ^. #lsize) (0.33 * l ^. #lsize)]
)
LineA ls ->
( LineA (ls & #width %~ (/ (realToFrac $ l ^. #lscale))),
[SP 0 (0.33 * l ^. #lsize), SP (2 * l ^. #lsize) (0.33 * l ^. #lsize)]
)
BlankA ->
( BlankA,
[SP 0 0]
)
legendChart :: [(Annotation, Text)] -> LegendOptions -> [Chart Double]
legendChart lrs l =
padChart (l ^. #outerPad)
. maybe id (\x -> frameChart x (l ^. #innerPad)) (l ^. #legendFrame)
. vert (l ^. #hgap)
$ (\(a, t) -> hori ((l ^. #vgap) + twidth - gapwidth t) [[t], [a]])
<$> es
where
es = reverse $ uncurry (legendEntry l) <$> lrs
twidth = maybe 0 (\(Rect _ z _ _) -> z) . foldRect $ catMaybes (styleBox . snd <$> es)
gapwidth t = maybe 0 (\(Rect _ z _ _) -> z) (styleBox t)
legendFromChart :: [Text] -> [Chart Double] -> [(Annotation, Text)]
legendFromChart = zipWith (\t c -> (c ^. #annotation, t))