{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Chart.Page
( chartStyler,
repChartStaticData,
repAnnotation,
repRectStyle,
repTextStyle,
repGlyphStyle,
repLineStyle,
repPlace,
repAnchor,
repBar,
repAdjustments,
repTitle,
repHudOptions,
repAxisOptions,
repSvgOptions,
repData,
repFormatN,
repTickStyle,
repTick,
repPoint,
repPointI,
repRect,
repRectOne,
repRounded,
repTriple,
repGlyphShape,
repChoice,
repLegendOptions,
repChartsWithSharedData,
repChartsWithStaticData,
debugHtml,
debugFlags,
repHudOptionsDefault,
repBarOptions,
repBarData,
repBarChart,
repPixelOptions,
repPixelLegendOptions,
repPixelChart,
)
where
import Chart.Bar
import Chart.Color
import Chart.Format
import Chart.Pixel
import Chart.Render (renderHudOptionsChart)
import Chart.Types
import Control.Category (id)
import Control.Lens
import Data.Attoparsec.Text
import Data.Biapplicative
import Data.List
import qualified Data.Text as Text
import Lucid
import NumHask.Space
import Protolude hiding ((<<*>>))
import Text.Pretty.Simple (pShowNoColor)
import Web.Page hiding (bool)
pShow' :: (Show a) => a -> Text
pShow' = toStrict . pShowNoColor
chartStyler :: Bool -> Page
chartStyler doDebug =
mathjaxSvgPage "hasmathjax"
<> bootstrapPage
<> bridgePage
& #htmlHeader .~ title_ "chart styler"
& #htmlBody
.~ divClass_
"container"
( divClass_
"row d-flex justify-content-between"
( sec "col4" "input"
<> sec "col8" "output"
)
<> bool mempty (divClass_ "row" (with div_ [id_ "debug"] mempty)) doDebug
)
where
sec d n = divClass_ d (with div_ [id_ n] mempty)
subtype :: With a => a -> Text -> Text -> a
subtype h origt t =
with
h
[ class__ "subtype ",
data_ "sumtype" t,
style_ ("display:" <> bool "block" "none" (origt /= t))
]
repChartStaticData :: (Monad m) => Chart a -> SharedRep m (Chart a)
repChartStaticData c = do
ann <- repAnnotation (c ^. #annotation)
pure $ Chart ann (c ^. #spots)
repAnnotation :: (Monad m) => Annotation -> SharedRep m Annotation
repAnnotation initann = bimap hmap mmap rann <<*>> rs <<*>> ts <<*>> gs <<*>> ls <<*>> ps
where
rann =
dropdownSum
takeText
id
(Just "Chart Annotation")
["RectA", "TextA", "GlyphA", "LineA", "BlankA", "PixelA"]
(annotationText initann)
rs = repRectStyle defRectStyle
ts = repTextStyle defText
gs = repGlyphStyle defGlyph
ls = repLineStyle defLine
ps = repPixelStyle defPixel
hmap ann rs ts gs ls ps =
ann
<> subtype rs (annotationText initann) "RectA"
<> subtype ts (annotationText initann) "TextA"
<> subtype gs (annotationText initann) "GlyphA"
<> subtype ls (annotationText initann) "LineA"
<> subtype ps (annotationText initann) "PixelA"
mmap ann rs ts gs ls ps =
case ann of
"RectA" -> RectA rs
"TextA" -> TextA ts texts
"GlyphA" -> GlyphA gs
"LineA" -> LineA ls
"BlankA" -> BlankA
"PixelA" -> PixelA ps
_ -> BlankA
defRectStyle = case initann of
RectA s -> s
_ -> defaultRectStyle
defPixel = case initann of
PixelA s -> s
_ -> defaultPixelStyle
(defText, texts) = case initann of
TextA s xs -> (s, xs)
_ -> (defaultTextStyle, Text.singleton <$> ['a' .. 'z'])
defGlyph = case initann of
GlyphA s -> s
_ -> defaultGlyphStyle
defLine = case initann of
LineA s -> s
_ -> defaultLineStyle
repRectStyle :: (Monad m) => RectStyle -> SharedRep m RectStyle
repRectStyle s = do
bs <- slider (Just "border size") 0.0 0.1 0.001 (s ^. #borderSize)
bc <- colorPicker (Just "border color") (hex $ s ^. #borderColor)
bo <- slider (Just "border opacity") 0 1 0.1 (opac $ s ^. #borderColor)
c <- colorPicker (Just "color") (hex $ s ^. #color)
o <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color)
pure $ RectStyle bs (fromHexOpac bc bo) (fromHexOpac c o)
repPixelStyle ::
(Monad m) =>
PixelStyle ->
SharedRep m PixelStyle
repPixelStyle cfg =
bimap hmap mmap pcmin
<<*>> pomin
<<*>> pcmax
<<*>> pomax
<<*>> pd
<<*>> prs
<<*>> pt
where
pcmax = colorPicker (Just "high color") (toHex $ cfg ^. #pixelColorMax)
pcmin = colorPicker (Just "low color") (toHex $ cfg ^. #pixelColorMin)
pomax = slider (Just "high opacity") 0.0 1.0 0.001 (opac $ cfg ^. #pixelColorMax)
pomin = slider (Just "low opacity") 0.0 1.0 0.001 (opac $ cfg ^. #pixelColorMin)
pd = slider (Just "gradient direction") 0.0 (2 * pi) 0.001 (cfg ^. #pixelGradient)
prs = repRectStyle (cfg ^. #pixelRectStyle)
pt = textbox (Just "texture id") (cfg ^. #pixelTextureId)
hmap pcmin' pomin' pcmax' pomax' pd' prs' pt' =
pcmin' <> pomin' <> pcmax' <> pomax' <> pd' <> prs' <> pt'
mmap pcmin' pomin' pcmax' pomax' pd' prs' pt' =
PixelStyle (fromHexOpac pcmin' pomin') (fromHexOpac pcmax' pomax') pd' prs' pt'
repGlyphStyle :: (Monad m) => GlyphStyle -> SharedRep m GlyphStyle
repGlyphStyle gs = first (\x -> cardify (mempty, [style_ "width: 10 rem;"]) Nothing (x, [])) $ do
sh <- repGlyphShape (gs ^. #shape)
sz <- slider (Just "Size") 0 0.2 0.001 (gs ^. #size)
gc <-
colorPicker
(Just "Color")
(toHex $ gs ^. #color)
go <- slider (Just "Opacity") 0 1 0.1 (opac $ gs ^. #color)
bsz <- slider (Just "Border Size") 0 0.02 0.001 (gs ^. #borderSize)
gbc <- colorPicker (Just "Border Color") (toHex $ gs ^. #borderColor)
gbo <- slider (Just "Border Opacity") 0 1 0.1 (opac $ gs ^. #borderColor)
tr <-
maybeRep
(Just "rotation")
(isJust (gs ^. #rotation))
(slider (Just "rotation") (-180) 180 10 (fromMaybe 0 (gs ^. #rotation)))
tt <-
maybeRep
(Just "translate")
(isJust (gs ^. #translate))
( repPoint
(Point (Range 0 1) (Range 0 1))
(Point 0.001 0.001)
(Point 0 0)
)
pure (GlyphStyle sz (fromHexOpac gc go) (fromHexOpac gbc gbo) bsz sh tr tt)
repTextStyle :: (Monad m) => TextStyle -> SharedRep m TextStyle
repTextStyle s = do
ts <- slider (Just "size") 0.02 0.3 0.01 (s ^. #size)
tc <- colorPicker (Just "color") (toHex $ s ^. #color)
to' <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color)
ta <- repAnchor (s ^. #anchor)
th <- slider (Just "hsize") 0.2 1 0.05 (s ^. #hsize)
tv <- slider (Just "vsize") 0.5 2 0.05 (s ^. #vsize)
tn <- slider (Just "nudge1") (-0.5) 0.5 0.05 (s ^. #nudge1)
tr <-
maybeRep
(Just "rotation")
(isJust (s ^. #rotation))
(slider (Just "rotation") (-180) 180 10 (fromMaybe 0 (s ^. #rotation)))
tt <-
maybeRep
(Just "translate")
(isJust (s ^. #translate))
( repPoint
(Point (Range 0 1) (Range 0 1))
(Point 0.001 0.001)
(Point 0 0)
)
tm <- checkbox (Just "mathjax") (s ^. #hasMathjax)
pure $ TextStyle ts (fromHexOpac tc to') ta th tv tn tr tt tm
repLineStyle :: (Monad m) => LineStyle -> SharedRep m LineStyle
repLineStyle s = do
w <- slider (Just "width") 0.000 0.05 0.001 (s ^. #width)
c <- colorPicker (Just "color") (toHex $ s ^. #color)
o <- slider (Just "opacity") 0 1 0.1 (opac $ s ^. #color)
pure $ LineStyle w (fromHexOpac c o)
repPlace :: (Monad m) => Place -> SharedRep m Place
repPlace initpl = bimap hmap mmap rplace <<*>> rp
where
rplace =
dropdownSum
takeText
id
(Just "Placement")
[ "Bottom",
"Left",
"Top",
"Right",
"Absolute"
]
(placeText initpl)
rp = repPoint (Point (Range 0 1) (Range 0 1)) (Point 0.01 0.01) (defPoint initpl)
defPoint pl = case pl of
PlaceAbsolute p -> p
_ -> Point 0.0 0.0
hmap rplace rp =
div_
( rplace
<> subtype rp (placeText initpl) "Absolute"
)
mmap rplace rp = case rplace of
"Top" -> PlaceTop
"Bottom" -> PlaceBottom
"Left" -> PlaceLeft
"Right" -> PlaceRight
"Absolute" -> PlaceAbsolute rp
_ -> PlaceBottom
repAnchor :: (Monad m) => Anchor -> SharedRep m Anchor
repAnchor a =
toAnchor
<$> dropdown
takeText
id
(Just "Anchor")
(fromAnchor <$> [AnchorStart, AnchorMiddle, AnchorEnd])
(fromAnchor a)
repOrientation :: (Monad m) => Orientation -> SharedRep m Orientation
repOrientation a =
toOrientation
<$> dropdown
takeText
id
(Just "Orientation")
(fromOrientation <$> [Vert, Hori])
(fromOrientation a)
repBar :: (Monad m) => Bar -> SharedRep m Bar
repBar cfg = do
r <- repRectStyle (cfg ^. #rstyle)
w <- slider (Just "width") 0 0.1 0.01 (cfg ^. #wid)
b <- slider (Just "buffer") 0 0.2 0.01 (cfg ^. #buff)
pure $ Bar r w b
repAdjustments :: (Monad m) => Adjustments -> SharedRep m Adjustments
repAdjustments a = do
maxx <- slider (Just "maximum x ratio") 0.000 0.2 0.001 (a ^. #maxXRatio)
maxy <- slider (Just "maximum y ratio") 0.000 0.2 0.001 (a ^. #maxYRatio)
angle <- slider (Just "angle ratio") 0.000 1 0.001 (a ^. #angledRatio)
diag <- checkbox (Just "allow diagonal text") (a ^. #allowDiagonal)
pure $ Adjustments maxx maxy angle diag
repTitle :: (Monad m) => Title -> SharedRep m Title
repTitle cfg = do
ttext <- textbox (Just "text") (cfg ^. #text)
ts <- repTextStyle (cfg ^. #style)
tp <- repPlace (cfg ^. #place)
ta <- repAnchor (cfg ^. #anchor)
b <- slider (Just "buffer") 0 0.2 0.01 (cfg ^. #buff)
pure $ Title ttext ts tp ta b
repHudOptions ::
(Monad m) =>
Int ->
Int ->
Int ->
AxisOptions ->
Title ->
LegendOptions ->
[(Annotation, Text)] ->
Annotation ->
Text ->
HudOptions ->
SharedRep m HudOptions
repHudOptions naxes ntitles nlegendRows defaxis deftitle deflegend deflrs defann deflabel cfg =
bimap hmap (\a b c d -> HudOptions a b c d) can
<<*>> ts
<<*>> axs
<<*>> l
where
can =
maybeRep (Just "canvas") (isJust (cfg ^. #hudCanvas)) $
repRectStyle (fromMaybe defaultCanvas (cfg ^. #hudCanvas))
ts =
listRep
(Just "titles")
"tz"
(checkbox Nothing)
repTitle
ntitles
deftitle
(cfg ^. #hudTitles)
axs =
listRep
(Just "axes")
"axz"
(checkbox Nothing)
repAxisOptions
naxes
defaxis
(cfg ^. #hudAxes)
labelsc =
listRep
(Just "labelsc")
"labelscz"
(checkbox Nothing)
(textbox Nothing)
nlegendRows
deflabel
(snd <$> deflrs)
anns =
listRep
(Just "annotations")
"annsz"
(checkbox Nothing)
repAnnotation
nlegendRows
defann
(fst <$> deflrs)
l =
maybeRep
(Just "legend")
(isJust $ cfg ^. #hudLegend)
( (,)
<$> repLegendOptions (maybe deflegend fst (cfg ^. #hudLegend))
<*> (zip <$> anns <*> labelsc)
)
hmap can' ts' axs' l' =
accordion_
"accc"
Nothing
[ ("Axes", axs'),
("Canvas", can'),
("Titles", ts'),
("Legend", l')
]
repAxisOptions :: (Monad m) => AxisOptions -> SharedRep m AxisOptions
repAxisOptions cfg = bimap hmap AxisOptions b <<*>> adj <<*>> t <<*>> p
where
b =
maybeRep
(Just "axis bar")
(isJust (cfg ^. #abar))
(repBar (fromMaybe defaultBar (cfg ^. #abar)))
adj =
maybeRep
(Just "adjustments")
(isJust (cfg ^. #adjust))
(repAdjustments (fromMaybe defaultAdjustments (cfg ^. #adjust)))
t = repTick (cfg ^. #atick)
p = repPlace (cfg ^. #place)
hmap b' hauto' t' p' =
accordion_
"accaxis"
Nothing
[ ("Bar", b'),
("Auto", hauto'),
("Ticks", t'),
("Place", p')
]
repSvgAspect :: (Monad m) => SvgAspect -> Double -> SharedRep m SvgAspect
repSvgAspect sa ddef =
bimap hmap toSvgAspect sa' <<*>> td
where
sa' =
dropdownSum
takeText
id
(Just "Aspect")
[ "ManualAspect",
"ChartsAspect"
]
(fromSvgAspect sa)
td = slider (Just "aspect scale") 0 10 0.01 (defD ddef)
defD d' = case sa of
ManualAspect d -> d
ChartAspect -> d'
hmap sa'' td' =
div_
( sa''
<> subtype td' (fromSvgAspect sa) "ManualAspect"
)
repSvgOptions :: (Monad m) => SvgOptions -> SharedRep m SvgOptions
repSvgOptions s =
bimap
hmap
SvgOptions
h'
<<*>> op'
<<*>> ip
<<*>> fr
<<*>> esc
<<*>> csso
<<*>> scalec
<<*>> svga
where
svga = repSvgAspect (s ^. #svgAspect) 1.33
h' = slider (Just "height") 1 1000 1 (s ^. #svgHeight)
op' =
maybeRep
(Just "outer pad")
(isJust (s ^. #outerPad))
(slider Nothing 1 1.2 0.01 (fromMaybe 1 (s ^. #outerPad)))
ip =
maybeRep
(Just "inner pad")
(isJust (s ^. #innerPad))
(slider Nothing 1 1.2 0.01 (fromMaybe 1 (s ^. #innerPad)))
fr =
maybeRep
(Just "frame")
(isJust (s ^. #chartFrame))
(repRectStyle (fromMaybe defaultSvgFrame (s ^. #chartFrame)))
esc =
bool NoEscapeText EscapeText
<$> checkbox (Just "escape text") (EscapeText == s ^. #escapeText)
csso =
bool NoCssOptions UseCssCrisp
<$> checkbox (Just "Use CssCrisp") (UseCssCrisp == s ^. #useCssCrisp)
scalec =
bool NoScaleCharts ScaleCharts
<$> checkbox (Just "Scale Charts") (ScaleCharts == s ^. #scaleCharts')
hmap h' op'' ip' fr' esc' csso' scalec' svga' =
accordion_
"accsvg"
Nothing
[ ("Aspect", svga' <> h'),
("Padding", op'' <> ip'),
("Frame", fr'),
("Escape", esc'),
("Css", csso'),
("Scale", scalec')
]
repData :: (Monad m) => Text -> SharedRep m [Spot Double]
repData d = do
a <-
dropdown
takeText
id
(Just "type")
[ "sin",
"line",
"one",
"dist"
]
d
pure
( case a of
"sin" -> SpotPoint <$> gridP sin (Range 0 (2 * pi)) 30
"line" ->
SpotPoint . uncurry Point
<$> [(0.0, 1.0), (1.0, 1.0), (2.0, 5.0)]
"one" -> [SR 0 1 0 1]
"dist" -> SpotRect <$> gridR (\x -> exp (- (x ** 2) / 2)) (Range (-5) 5) 50
_ -> SpotPoint <$> gridP sin (Range 0 (2 * pi)) 30
)
repFormatN :: (Monad m) => FormatN -> SharedRep m FormatN
repFormatN tf = bimap hmap mmap tformat <<*>> tcommas <<*>> tfixed <<*>> texpt <<*>> tpercent
where
tformat =
dropdownSum
takeText
id
(Just "Format")
[ "Comma",
"Fixed",
"Expt",
"Dollar",
"Percent",
"None"
]
(fromFormatN tf)
tcommas = sliderI (Just "prec") 0 8 1 (defInt tf)
tfixed = sliderI (Just "prec") 0 8 1 (defInt tf)
texpt = sliderI (Just "prec") 0 8 1 (defInt tf)
tpercent = sliderI (Just "prec") 0 8 1 (defInt tf)
defInt tf' = case tf' of
FormatComma n -> n
FormatFixed n -> n
_ -> 3
hmap tformat' tcommas' tfixed' texpt' tpercent' =
div_
( tformat'
<> subtype tcommas' (fromFormatN tf) "Comma"
<> subtype tfixed' (fromFormatN tf) "Fixed"
<> subtype texpt' (fromFormatN tf) "Expt"
<> subtype tpercent' (fromFormatN tf) "Percent"
)
mmap tformat' tcommas' tfixed' texpt' tpercent' = case tformat' of
"Comma" -> FormatComma tcommas'
"Fixed" -> FormatFixed tfixed'
"Expt" -> FormatExpt texpt'
"Dollar" -> FormatDollar
"Percent" -> FormatPercent tpercent'
"None" -> FormatNone
_ -> FormatNone
repTickStyle :: (Monad m) => TickStyle -> SharedRep m TickStyle
repTickStyle cfg =
bimap hmap mmap ts <<*>> ls <<*>> tr <<*>> te <<*>> tplaced
where
ts =
dropdownSum
takeText
id
(Just "Tick Style")
["TickNone", "TickLabels", "TickRound", "TickExact", "TickPlaced"]
(tickStyleText cfg)
ls =
accordionList
(Just "tick labels")
"tick-style-labels"
Nothing
(textbox . Just)
(defaultListLabels (length defLabels))
defLabels
tr =
(,,)
<$> sliderI (Just "Number of ticks") 0 20 1 defTn
<*> repFormatN defTf
<*> ( bool NoTickExtend TickExtend
<$> checkbox (Just "extend") defExtend
)
te =
(,)
<$> sliderI (Just "Number of ticks") 0 20 1 defTn
<*> repFormatN defTf
tplaced =
accordionList
(Just "placed ticks")
"tick-style-placed"
Nothing
dt
(defaultListLabels (length dtDef))
dtDef
hmap ts' ls' tr' te' tplaced' =
div_
( ts'
<> subtype ls' (tickStyleText cfg) "TickLabels"
<> subtype tr' (tickStyleText cfg) "TickRound"
<> subtype te' (tickStyleText cfg) "TickExact"
<> subtype tplaced' (tickStyleText cfg) "TickPlaced"
)
mmap ts' ls' (tri, trf, tre) (tei, tef) tplaced' = case ts' of
"TickNone" -> TickNone
"TickLabels" -> TickLabels ls'
"TickRound" -> TickRound trf tri tre
"TickExact" -> TickExact tef tei
"TickPlaced" -> TickPlaced tplaced'
_ -> TickNone
dtDef = case cfg of
TickPlaced x -> x
_ -> zip [0 .. 5] (Text.pack . show <$> [0 .. 5 :: Int])
dt _ (x, l) = (,) <$> slider (Just "placement") 0 1 0.01 x <*> textbox (Just "label") l
defLabels = case cfg of
TickLabels xs -> xs
_ -> replicate 5 ""
defTn = case cfg of
TickRound _ x _ -> x
TickExact _ x -> x
_ -> 8
defTf = case cfg of
TickRound x _ _ -> x
TickExact x _ -> x
_ -> FormatComma 2
defExtend = case cfg of
TickRound _ _ e -> e == TickExtend
_ -> True
repTick :: (Monad m) => Tick -> SharedRep m Tick
repTick cfg = SharedRep $ do
(Rep h fa) <-
unrep $ bimap hmap Tick ts <<*>> gt <<*>> tt <<*>> lt
h' <- zoom _1 h
pure (Rep h' fa)
where
hmap ts' gt' tt' lt' =
accordion
"acctick"
Nothing
[ ("style", ts'),
("glyph", gt'),
("text", tt'),
("line", lt')
]
ts = repTickStyle (cfg ^. #tstyle)
gt =
maybeRep Nothing (isJust (cfg ^. #gtick)) $
bimap
(<>)
(,)
(repGlyphStyle (maybe defaultGlyphTick fst (cfg ^. #gtick)))
<<*>> slider (Just "buffer") 0 0.05 0.001 (maybe 0.05 snd (cfg ^. #gtick))
tt =
maybeRep Nothing (isJust (cfg ^. #ttick)) $
bimap
(<>)
(,)
(repTextStyle (maybe defaultTextTick fst (cfg ^. #ttick)))
<<*>> slider (Just "buffer") 0 0.05 0.001 (maybe 0.05 snd (cfg ^. #ttick))
lt =
maybeRep Nothing (isJust (cfg ^. #ltick)) $
bimap
(<>)
(,)
(repLineStyle (maybe defaultLineTick fst (cfg ^. #ltick)))
<<*>> slider (Just "buffer") (-0.1) 0.1 0.001 (maybe 0 snd (cfg ^. #ltick))
repPoint ::
(Monad m) =>
Point (Range Double) ->
Point Double ->
Point Double ->
SharedRep m (Point Double)
repPoint (Point (Range xmin xmax) (Range ymin ymax)) (Point xstep ystep) (Point x y) =
bimap
(<>)
Point
(slider (Just "x") xmin xmax xstep x)
<<*>> slider (Just "y") ymin ymax ystep y
repPointI ::
(Monad m) =>
Point (Range Int) ->
Point Int ->
Point Int ->
SharedRep m (Point Int)
repPointI (Point (Range xmin xmax) (Range ymin ymax)) (Point xstep ystep) (Point x y) =
bimap
(<>)
Point
(sliderI (Just "x") xmin xmax xstep x)
<<*>> sliderI (Just "y") ymin ymax ystep y
repRect :: (Monad m) => Rect (Range Double) -> Rect Double -> Rect Double -> SharedRep m (Rect Double)
repRect (Rect (Range xmin xmax) (Range zmin zmax) (Range ymin ymax) (Range wmin wmax)) (Rect xstep zstep ystep wstep) (Rect x z y w) =
bimap
(\a b c d -> a <> b <> c <> d)
Rect
(slider (Just "x") xmin xmax xstep x)
<<*>> slider (Just "z") zmin zmax zstep z
<<*>> slider (Just "y") ymin ymax ystep y
<<*>> slider (Just "w") wmin wmax wstep w
repRectOne :: (Monad m) => Rect Double -> SharedRep m (Rect Double)
repRectOne a = repRect (Rect (Range 0 1) (Range 0 1) (Range 0 1) (Range 0 1)) (Rect 0.01 0.01 0.01 0.01) a
repRounded :: (Monad m) => (Double, Double, Double) -> SharedRep m (Double, Double, Double)
repRounded (a, b, c) =
bimap
(\a' b' c' -> a' <> b' <> c')
(,,)
(slider Nothing 0 1 0.001 a)
<<*>> slider Nothing 0 1 0.001 b
<<*>> slider Nothing 0 1 0.001 c
repTriple :: (Monad m) => (a, a, a) -> (a -> SharedRep m a) -> SharedRep m (a, a, a)
repTriple (a, b, c) sr =
bimap (\a' b' c' -> a' <> b' <> c') (,,) (sr a) <<*>> sr b <<*>> sr c
repGlyphShape :: (Monad m) => GlyphShape -> SharedRep m GlyphShape
repGlyphShape sh = bimap hmap mmap sha <<*>> ell <<*>> rsharp <<*>> rround <<*>> tri <<*>> p <<*>> lwidth
where
sha =
dropdownSum
takeText
id
Nothing
[ "Circle",
"Square",
"Triangle",
"Ellipse",
"RectSharp",
"RectRounded",
"VLine",
"HLine",
"Path"
]
(glyphText sh)
ell = slider Nothing 0.5 2 0.01 defRatio
rsharp = slider Nothing 0.5 2 0.01 defRatio
rround = repRounded defRounded
lwidth = slider (Just "width") 0.001 0.02 0.001 defLwidth
tri =
repTriple
defTriangle
( repPoint
(Point (Range 0 1) (Range 0 1))
(Point 0.001 0.001)
)
p = textbox (Just "path") defP
hmap sha' ell' rsharp' rround' tri' p' lwidth' =
sha'
<> subtype ell' (glyphText sh) "Ellipse"
<> subtype rsharp' (glyphText sh) "RectSharp"
<> subtype rround' (glyphText sh) "RectRounded"
<> subtype tri' (glyphText sh) "Triangle"
<> subtype lwidth' (glyphText sh) "VLine"
<> subtype lwidth' (glyphText sh) "HLine"
<> subtype p' (glyphText sh) "Path"
mmap sha' ell' rsharp' rround' tri' p' lwidth' =
case sha' of
"Circle" -> CircleGlyph
"Square" -> SquareGlyph
"Ellipse" -> EllipseGlyph ell'
"RectSharp" -> RectSharpGlyph rsharp'
"RectRounded" -> (\(a, b, c) -> RectRoundedGlyph a b c) rround'
"Triangle" -> (\(a, b, c) -> TriangleGlyph a b c) tri'
"VLine" -> VLineGlyph lwidth'
"HLine" -> HLineGlyph lwidth'
"Path" -> PathGlyph p'
_ -> CircleGlyph
defP = case sh of
PathGlyph p -> p
_ -> mempty
defRatio = case sh of
EllipseGlyph r -> r
RectSharpGlyph r -> r
_ -> 1.5
defLwidth = case sh of
VLineGlyph r -> r
HLineGlyph r -> r
_ -> 0.005
defRounded = case sh of
RectRoundedGlyph a b c -> (a, b, c)
_ -> (0.884, 2.7e-2, 5.0e-2)
defTriangle = case sh of
TriangleGlyph a b c -> (a, b, c)
_ -> (Point 0.0 0.0, Point 1 1, Point 1 0)
repChoice :: (Monad m) => Int -> [(Text, SharedRep m (Text, Text))] -> SharedRep m (Text, Text)
repChoice initt xs =
bimap hmap mmap dd
<<*>> foldr (\x a -> bimap (:) (:) x <<*>> a) (pure []) cs
where
ts = fst <$> xs
cs = snd <$> xs
dd = dropdownSum takeText id Nothing ts t0
t0 = ts !! initt
hmap dd' cs' =
div_
( dd'
<> mconcat (zipWith (\c t -> subtype c t0 t) cs' ts)
)
mmap dd' cs' = maybe (Data.List.head cs') (cs' !!) (elemIndex dd' ts)
repLegendOptions :: (Monad m) => LegendOptions -> SharedRep m LegendOptions
repLegendOptions initl =
bimap
hmap
LegendOptions
lsize'
<<*>> vgap'
<<*>> hgap'
<<*>> ltext'
<<*>> lmax'
<<*>> innerPad'
<<*>> outerPad'
<<*>> legendFrame'
<<*>> lplace'
<<*>> scale'
where
lsize' = slider (Just "element size") 0.000 1 0.001 (initl ^. #lsize)
hgap' = slider (Just "horizontal gap") 0.000 0.5 0.001 (initl ^. #hgap)
vgap' = slider (Just "vertical gap") 0.000 0.5 0.001 (initl ^. #vgap)
ltext' = repTextStyle (initl ^. #ltext)
lmax' = sliderI (Just "max entries") 0 10 1 (initl ^. #lmax)
innerPad' =
slider
(Just "inner padding")
0
0.2
0.001
(initl ^. #innerPad)
outerPad' =
slider
(Just "outer padding")
0
0.2
0.001
(initl ^. #outerPad)
legendFrame' =
maybeRep
(Just "frame")
(isJust (initl ^. #legendFrame))
(repRectStyle (fromMaybe defaultSvgFrame (initl ^. #legendFrame)))
lplace' = repPlace (initl ^. #lplace)
scale' = slider (Just "scale") 0.01 1 0.001 (initl ^. #lscale)
hmap lsize'' vgap'' hgap'' ltext'' lmax'' innerPad'' outerPad'' legendFrame'' lplace'' scale'' =
accordion_
"accleg"
Nothing
[ ("Scale", scale'' <> lsize''),
("Pads", innerPad'' <> outerPad'' <> vgap'' <> hgap''),
("Text", ltext''),
("Frame", legendFrame''),
("Place", lplace''),
("Max Elements", lmax'')
]
repChartsWithSharedData ::
(Monad m) =>
SvgOptions ->
HudOptions ->
Int ->
[Chart Double] ->
([[Spot Double]] -> SharedRep m [[Spot Double]]) ->
SharedRep m (Text, Text)
repChartsWithSharedData css' hc' maxcs' cs' sspots =
bimap
hmap
mmap
cssr
<<*>> annsr
<<*>> sspots spots'
<<*>> hr
<<*>> debugFlags
where
spots' = view #spots <$> cs'
anns' = view #annotation <$> cs'
hr =
repHudOptions
2
3
5
defaultAxisOptions
(defaultTitle "default")
(maybe defaultLegendOptions fst (hc' ^. #hudLegend))
(maybe [] snd (hc' ^. #hudLegend))
BlankA
""
hc'
cssr = repSvgOptions css'
annsr =
listRep
(Just "Annotations")
"annz"
(checkbox Nothing)
repAnnotation
maxcs'
BlankA
anns'
mmap css'' ann' d' h' debug' =
let ch = zipWith Chart ann' d'
in ( renderHudOptionsChart css'' h' [] ch,
debugHtml debug' css'' h' ch
)
hmap css'' ann' _ h' debug' =
accordion_
"acca"
Nothing
[ ("Svg", css''),
("Annotations", ann'),
("Hud", h'),
("Debug", debug')
]
repChartsWithStaticData ::
(Monad m) =>
SvgOptions ->
HudOptions ->
Int ->
[Chart Double] ->
SharedRep m (Text, Text)
repChartsWithStaticData css' hc' maxcs' cs' =
repChartsWithSharedData css' hc' maxcs' cs' (bipure mempty)
debugHtml :: (Bool, Bool, Bool) -> SvgOptions -> HudOptions -> [Chart Double] -> Text
debugHtml debug css hc cs =
bool
mempty
( mconcat $
(\x -> "<p style='white-space: pre'>" <> x <> "</p>")
<$> [ "<h2>config values</h2>",
pShow' css,
pShow' hc
]
)
((\(a, _, _) -> a) debug)
<> bool
mempty
( mconcat $
(\x -> "<p style='white-space: pre'>" <> x <> "</p>")
<$> [ "<h2>chart svg</h2>",
renderHudOptionsChart css hc [] cs
]
)
((\(_, a, _) -> a) debug)
<> bool
mempty
( mconcat $
(\x -> "<p style='white-space: pre'>" <> x <> "</p>")
<$> [ "<h2>chart value</h2>",
Text.pack $ show cs
]
)
((\(_, _, a) -> a) debug)
debugFlags :: (Monad m) => SharedRepF m (Html ()) (Bool, Bool, Bool)
debugFlags =
bimap
(\a b c -> a <> b <> c)
(,,)
(checkbox (Just "show hudOptions values") False)
<<*>> checkbox (Just "show chart svg") False
<<*>> checkbox (Just "show Chart values") False
repHudOptionsDefault :: Monad m => HudOptions -> SharedRep m HudOptions
repHudOptionsDefault hc =
repHudOptions
2
3
5
defaultAxisOptions
(defaultTitle "default")
defaultLegendOptions
[]
BlankA
""
hc
repBarOptions ::
(Monad m) =>
Int ->
RectStyle ->
TextStyle ->
BarOptions ->
SharedRep m BarOptions
repBarOptions nrows defrs defts cfg =
bimap hmap BarOptions rs
<<*>> ts
<<*>> og
<<*>> ig
<<*>> tg
<<*>> dv
<<*>> fn
<<*>> av
<<*>> or
<<*>> ho
where
rs =
listRep
(Just "bar styles")
"rs"
(checkbox Nothing)
repRectStyle
nrows
defrs
(cfg ^. #barRectStyles)
ts =
listRep
(Just "text styles")
"ts"
(checkbox Nothing)
repTextStyle
nrows
defts
(cfg ^. #barTextStyles)
og = slider (Just "outer gap") 0.0 1.0 0.001 (cfg ^. #outerGap)
ig = slider (Just "inner gap") (-1.0) 1 0.001 (cfg ^. #innerGap)
tg = slider (Just "text gap") (-0.05) 0.05 0.001 (cfg ^. #textGap)
dv = checkbox (Just "display values") (cfg ^. #displayValues)
fn = repFormatN (cfg ^. #valueFormatN)
av = checkbox (Just "accumulate values") (cfg ^. #accumulateValues)
or = repOrientation (cfg ^. #orientation)
ho =
repHudOptions
2
3
5
defaultAxisOptions
(defaultTitle "bar options")
(maybe defaultLegendOptions fst (cfg ^. #barHudOptions . #hudLegend))
(maybe [] snd (cfg ^. #barHudOptions . #hudLegend))
BlankA
""
(cfg ^. #barHudOptions)
hmap rs' ts' og' ig' tg' dv' fn' av' or' ho' =
accordion_
"accbo"
Nothing
[ ("Bar Styles", rs'),
("Text Styles", ts'),
("Gaps", og' <> ig' <> tg'),
("Style", dv' <> fn' <> av' <> or'),
("Hud", ho')
]
repBarData ::
(Monad m) =>
BarData ->
SharedRep m BarData
repBarData initbd =
bimap hmap BarData bd
<<*>> rl
<<*>> cl
where
rl =
maybeRep
Nothing
(isJust (initbd ^. #barRowLabels))
( either (const []) id
<$> readTextbox (Just "row labels") (fromMaybe [] (initbd ^. #barRowLabels))
)
cl =
maybeRep
Nothing
(isJust (initbd ^. #barColumnLabels))
( either (const []) id
<$> readTextbox (Just "column labels") (fromMaybe [] (initbd ^. #barColumnLabels))
)
bd =
either (const (pure [])) id
<$> readTextbox (Just "bar data") (initbd ^. #barData)
hmap rl' cl' bd' = rl' <> cl' <> bd'
repPixelOptions ::
(Monad m) =>
PixelOptions ->
SharedRep m PixelOptions
repPixelOptions cfg =
bimap hmap PixelOptions ps
<<*>> pg
<<*>> pr
where
ps = repPixelStyle (cfg ^. #poStyle)
pg = repPointI (Point (Range 1 100) (Range 1 100)) (Point 1 1) (cfg ^. #poGrain)
pr = repRect (Rect (Range 0 5) (Range 0 5) (Range 0 5) (Range 0 5)) (Rect 0.01 0.01 0.01 0.01) (cfg ^. #poRange)
hmap ps' pg' pr' =
accordion_
"accpixel"
Nothing
[ ("Grain", pg'),
("Range", pr'),
("Style", ps')
]
repPixelLegendOptions ::
(Monad m) =>
PixelLegendOptions ->
SharedRep m PixelLegendOptions
repPixelLegendOptions cfg =
bimap hmap PixelLegendOptions ps
<<*>> pt
<<*>> pw
<<*>> pa
<<*>> pl
where
ps = repPixelStyle (cfg ^. #ploStyle)
pt = textbox (Just "title") (cfg ^. #ploTitle)
pw = slider (Just "width") 0.0 0.3 0.001 (cfg ^. #ploWidth)
pa = repAxisOptions (cfg ^. #ploAxisOptions)
pl = repLegendOptions (cfg ^. #ploLegendOptions)
hmap ps' pt' pw' pa' pl' =
accordion_
"accplo"
Nothing
[ ("Style", ps'),
("Title", pt'),
("Width", pw'),
("Axis", pa'),
("Legend", pl')
]
repBarChart :: (Monad m) => SvgOptions -> BarData -> BarOptions -> SharedRep m (Text, Text)
repBarChart css bd bo = bimap hmap mmap rcss <<*>> rbd <<*>> rbo <<*>> debugFlags
where
rcss = repSvgOptions css
rbo = repBarOptions 5 defaultRectStyle defaultTextStyle bo
rbd = repBarData bd
barchartsvg css' bd' bo' =
let (hc', cs') = barChart bo' bd'
in renderHudOptionsChart css' hc' [] cs'
mmap css' bd' bo' debug =
( barchartsvg css' bd' bo',
debugHtml debug css' (bo' ^. #barHudOptions) (bars bo' bd')
)
hmap css' bd' bo' debug =
accordion_
"accbc"
Nothing
[ ("Svg", css'),
("Bar Data", bd'),
("Bar Options", bo'),
("Debug", debug)
]
repPixelChart ::
(Monad m) =>
(SvgOptions, PixelOptions, HudOptions, PixelLegendOptions, Point Double -> Double) ->
SharedRep m (Text, Text)
repPixelChart (css, po, hc, plo, f) = bimap hmap mmap rcss <<*>> rpo <<*>> rhc <<*>> rplo <<*>> debugFlags
where
rcss = repSvgOptions css
rpo = repPixelOptions po
rhc = repHudOptionsDefault hc
rplo = repPixelLegendOptions plo
mmap rcss' rpo' rhc' rplo' debug =
let (cs, hs) = pixelfl f rpo' rplo'
in ( renderHudOptionsChart rcss' rhc' hs cs,
debugHtml debug rcss' rhc' []
)
hmap rcss' rpo' rhc' rplo' debug =
accordion_
"accpc"
Nothing
[ ("Svg", rcss'),
("Hud", rhc'),
("Pixel Options", rpo'),
("Pixel Legend Options", rplo'),
("Debug", debug)
]