diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,106 @@ +0.6 +=== + +0.6 is a major refactor. + +* Chart + + - refactored Chart from a sum type to a named Style, ChartData pair. + - in Chart (..) + chartStyle - style + - introduced ChartData + - integrated the various *Style types to a single type. + - introduced partial data lenses: *Data' + - added chart patterns: *Chart + - + blankChart1 + +* ScaleP + + - introduced the ScaleP type + - added scaleP to Style + - added the scaleP function + - - maybeProjectWith + projectChartDataWith + - - scaleStyle - overText + scaleChartData + - + scaleRatio + +* Chart.Style + - integrated styles + - - colourChart + colourStyle + - + Style (..) + - + defaultStyle + - + scaleStyle + - + default*Style + - + gpalette -gpalette1 + +* boxes + - added safeBox', safeStyleBox' + +* Chart.Compound + +* Factored State out of Hud + - ChartHud lenses removed: canvasBox', canvasStyleBox', hudBox', hudStyleBox' + - Introduced HudChartSection type and hudChartBox' which replaces ChartHud lenses. + - removed runHud + - removed hud effect functionality: closes, fromEffect, applyChartAspect, getHudBox + - new hud manipulation tools: appendHud, makeHuds, projectChartTreeWith, addHud, finalCanvas + +* Chart.Hud API + - - axis + axisHud - title + titleHud - legend + legendHud + - removed placeText + - added flipPlace + - + TitleOptions - Title + - - TickStyle + Tick + - + axisHud + titleHud + - - legend - legendFrame + - new tick lenses: + formatN', numTicks', tickExtend' + - In LegendOptions: + scaleChartBy - overallScale + legendSize - size + - In AxisOptions: + adjustments - adjust + axisBar - bar + +* refactored Priority to a named pair + +* Chart.Markup + - added forgetHud + - - CssPreferColorScheme + PreferColorScheme + - - CssShapeRendering + ShapeRendering + - + defaultCssFontFamilies + +* Integrated chart styles to a single Style type + +* changed defaults + - + defaultXAxisOptions + defaultYAxisOptions - defaultAxisOptions + - - defaultGlyphTick + defaultGlyphTickStyleX + defaultGlyphTickStyleY + - - defaultTicks + defaultXTicks + defaultYTicks + - + defaultTick - defaultTickStyle + +* Chart.Bar + - added barTextCharts + - added textShiftVert to BarOptions + +* Data.Colour + - + palette - palette1 + - + paletteO - palette1a + +* Chart.Surface + - - surfaceLegendChart + - - surfaceAxisOptions + - + surfaceLegendAxisOptions + - + gridReferenceChart + - + addSurfaceLegend + +* Chart.Data + - - singletonGuard + isSingleton + + +0.5.1.1 +=== +* test suite removed + +0.5.1.0 +=== +* Bumped markup-parse lower bound to >=0.1 +* Renamed LegendOptions.content to LegendOptions.legendCharts +* markup* functions now return Markup +* renderStyle added as a MarkupOptions component + 0.5.0 === * Library split into markup-parse and chart-svg. diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: chart-svg -version: 0.5.2.0 +version: 0.6.0.0 license: BSD-3-Clause license-file: LICENSE copyright: Tony Day (c) 2017 @@ -20,14 +20,14 @@ >>> import Chart >>> import Optics.Core >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] - >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] + >>> let styles = (\c -> defaultLineStyle & set #color (palette c) & set #size 0.015) <$> [0..2] >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines - >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions + >>> let lineExample = mempty & set #chartTree (named "line" cs) & set #hudOptions defaultHudOptions :: ChartOptions >>> writeChartOptions "other/usage.svg" lineExample ![usage example](docs/other/usage.svg) - See "Chart" for a broad overview of concepts, and "Chart.Examples" for practical examples. + See "Chart" for concept design notes, and "Chart.Examples" for practical usage. build-type: Simple tested-with: GHC == 8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2 || ==9.8.1 @@ -111,16 +111,16 @@ import: ghc2021-stanza hs-source-dirs: src build-depends: - , Color ^>=0.3 + , Color >=0.3.2 && <0.4 , adjunctions >=4.0 && <5 , attoparsec >=0.13.2 && <0.15 , base >=4.7 && <5 , bytestring >=0.11.3 && <0.13 , containers >=0.6 && <0.8 - , cubicbezier ^>=0.6 - , flatparse >=0.3.5 && <0.6 - , foldl ^>=1.4 - , formatn >=0.2.1 && <0.4 + , cubicbezier >=0.6 && <0.7 + , flatparse >=0.5 && <0.6 + , foldl >=1.4 && <1.5 + , formatn >=0.3 && <0.4 , markup-parse >=0.1 && <0.2 , mtl >=2.2.2 && <2.4 , numhask >=0.10 && <0.12 @@ -128,12 +128,13 @@ , numhask-space >=0.10 && <0.12 , optics-core >=0.4 && <0.5 , random >=1.2 && <1.3 - , string-interpolate >=0.3 && <0.4 + , string-interpolate >=0.3 && <0.5 , text >=1.2 && <2.2 , time >=1.9 && <1.13 exposed-modules: Chart Chart.Bar + Chart.Compound Chart.Data Chart.Examples Chart.Hud diff --git a/other/arcflags.svg b/other/arcflags.svg --- a/other/arcflags.svg +++ b/other/arcflags.svg @@ -1,4 +1,4 @@ -SweepTrueFalseFalseTrueLarge diff --git a/other/arrow.svg b/other/arrow.svg --- a/other/arrow.svg +++ b/other/arrow.svg @@ -23,6 +23,13 @@ fill: rgb(5%, 5%, 5%); } } +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + + { .arrow g { fill: rgba(5%, 5%, 5%, 1.00); @@ -35,26 +42,18 @@ stroke: rgba(94%, 94%, 94%, 1.00); } } --0.5-0.4-0.3-0.2-0.1 0.0 0.1 0.2 0.3 0.4 0.5-0.5-0.4-0.3-0.2-0.1 0.0 0.1 0.2 0.3 0.4 0.5 +-0.6-0.4-0.2 0.0 0.2 0.4 0.6-0.6-0.4-0.2 0.0 0.2 0.4 0.6 diff --git a/other/ast.svg b/other/ast.svg new file mode 100644 --- /dev/null +++ b/other/ast.svg @@ -0,0 +1,1114 @@ + + + + + + + + + +Tree + + +Tree + + + + + +TitleOptions + + +TitleOptions + +text + +style + +place + +buffer + +anchor + + + + + +Style + + +Style + +vsize + +vshift + +translate + +size + +scaleP + +rotation + +lineJoin + +lineCap + +hsize + +glyphShape + +frame + +escapeText + +dashoffset + +dasharray + +color + +borderSize + +borderColor + +anchor + + + + + +TitleOptions:xstyle->Style:xStyle + + + + + +Place + + +Place + +PlaceTop + +PlaceRight + +PlaceLeft + +PlaceBottom + +PlaceAbsolute + + + + + +TitleOptions:xplace->Place:xPlace + + + + + +Anchor + + +Anchor + +AnchorStart + +AnchorMiddle + +AnchorEnd + + + + + +TitleOptions:xanchor->Anchor:xAnchor + + + + + +Ticks + + +Ticks + +tick + +textTick + +lineTick + +glyphTick + + + + + +TickStyle + + +TickStyle + +style + +buffer + +anchorTo + + + + + +Ticks:xtextTick->TickStyle:xTickStyle + + +_Just + + + +Ticks:xlineTick->TickStyle:xTickStyle + + +_Just + + + +Ticks:xglyphTick->TickStyle:xTickStyle + + +_Just + + + +Tick + + +Tick + +tickExtend' + +numTicks' + +formatN' + +TickRound + +TickPlaced + +TickNone + +TickLabels + +TickExact + + + + + +Ticks:xtick->Tick:xTick + + +_Just + + + +TickStyle:xstyle->Style:xStyle + + + + + +HudChartSection + + +HudChartSection + +HudStyleSection + +HudSection + +CanvasStyleSection + +CanvasSection + + + + + +TickStyle:xanchorTo->HudChartSection:xHudChartSection + + + + + +TickExtend + + +TickExtend + +NoTickExtend + + + + + +Tick:xtickExtend'->TickExtend:xTickExtend + + +_Just + + + +FormatN + + +FormatN + +sigFigs + +maxDistinguishIterations + +fstyle + +cutRightZeros + +addLPad + + + + + +Tick:xformatN'->FormatN:xFormatN + + +_Just + + + +Style:xframe->Style:xStyle + + +_Just + + + +ScaleP + + +ScaleP + +ScalePY + +ScalePX + +ScalePMinDim + +ScalePArea + +NoScaleP + + + + + +Style:xscaleP->ScaleP:xScaleP + + + + + +Point + + +Point + +_y + +_x + + + + + +Style:xtranslate->Point:xPoint + + +_Just + + + +LineJoin + + +LineJoin + +LineJoinRound + +LineJoinMiter + +LineJoinBevel + + + + + +Style:xlineJoin->LineJoin:xLineJoin + + +_Just + + + +LineCap + + +LineCap + +LineCapSquare + +LineCapRound + +LineCapButt + + + + + +Style:xlineCap->LineCap:xLineCap + + +_Just + + + +GlyphShape + + +GlyphShape + +VLineGlyph + +TriangleGlyph + +SquareGlyph + +RectSharpGlyph + +RectRoundedGlyph + +PathGlyph + +HLineGlyph + +EllipseGlyph + +CircleGlyph + + + + + +Style:xglyphShape->GlyphShape:xGlyphShape + + + + + +EscapeText + + +EscapeText + +NoEscapeText + + + + + +Style:xescapeText->EscapeText:xEscapeText + + + + + +Colour + + +Colour + +opac' + +lightness' + +hue' + +chroma' + + + + + +Style:xcolor->Colour:xColour + + + + + +Style:xborderColor->Colour:xColour + + + + + +Style:xanchor->Anchor:xAnchor + + + + + +ShapeRendering + + +ShapeRendering + +UseGeometricPrecision + +UseCssCrisp + +NoShapeRendering + + + + + +RenderStyle + + +RenderStyle + +Indented + +Compact + + + + + +Rect + + +Rect + + + + + +Priority + + +Priority + + + + + +PreferColorScheme + + +PreferColorScheme + +PreferNormal + +PreferLight + +PreferHud + +PreferDark + + + + + +PathData + + +PathData + +StartP + +QuadP + +LineP + +CubicP + +ArcP + + + + + +ArcInfo + + +ArcInfo + +radii + +phi + +large + +clockwise + + + + + +PathData:xArcP->ArcInfo:xArcInfo + + +(ArcP arcinfo _) + + + +MarkupOptions + + +MarkupOptions + +renderStyle + +markupHeight + +cssOptions + +chartAspect + + + + + +MarkupOptions:xrenderStyle->RenderStyle:xRenderStyle + + + + + +CssOptions + + +CssOptions + +shapeRendering + +preferColorScheme + +fontFamilies + +cssExtra + + + + + +MarkupOptions:xcssOptions->CssOptions:xCssOptions + + + + + +ChartAspect + + +ChartAspect + +UnscaledAspect + +FixedAspect + +CanvasAspect + + + + + +MarkupOptions:xchartAspect->ChartAspect:xChartAspect + + + + + +LegendOptions + + +LegendOptions + +vgap + +textStyle + +scaleP + +scaleChartsBy + +place + +outerPad + +legendSize + +legendCharts + +innerPad + +hgap + +frame + +buffer + + + + + +LegendOptions:xtextStyle->Style:xStyle + + + + + +LegendOptions:xframe->Style:xStyle + + +_Just + + + +LegendOptions:xscaleP->ScaleP:xScaleP + + + + + +LegendOptions:xplace->Place:xPlace + + + + + +Chart + + +Chart + +chartStyle + +chartData + + + + + +LegendOptions:xlegendCharts->Chart:xChart + + +each % _2 % each + + + +HudOptions + + +HudOptions + +titles + +legends + +frames + +axes + + + + + +HudOptions:xtitles->TitleOptions:xTitleOptions + + +each % #item + + + +HudOptions:xtitles->Priority:xPriority + + +each % #priority + + + +HudOptions:xlegends->Priority:xPriority + + +each % #priority + + + +HudOptions:xframes->Priority:xPriority + + +each % #priority + + + +HudOptions:xaxes->Priority:xPriority + + +each % #priority + + + +HudOptions:xlegends->LegendOptions:xLegendOptions + + +each % #item + + + +FrameOptions + + +FrameOptions + +frame + +buffer + +anchorTo + + + + + +HudOptions:xframes->FrameOptions:xFrameOptions + + +each % #item + + + +AxisOptions + + +AxisOptions + +ticks + +place + +axisBar + +adjustments + + + + + +HudOptions:xaxes->AxisOptions:xAxisOptions + + +each % #item + + + +FrameOptions:xframe->Style:xStyle + + +#frame % _Just + + + +FrameOptions:xanchorTo->HudChartSection:xHudChartSection + + + + + +FStyle + + +FStyle + +FSPrec + +FSPercent + +FSNone + +FSFixed Int + +FSExponent + +FSDollar + +FSDecimal + +FSCommaPrec + +FSComma + + + + + +FormatN:xfstyle->FStyle:xFStyle + + + + + +CssOptions:xshapeRendering->ShapeRendering:xShapeRendering + + + + + +CssOptions:xpreferColorScheme->PreferColorScheme:xPreferColorScheme + + + + + +ChartTree + + +ChartTree + +tree + +charts' + + + + + +ChartTree:xtree->Tree:xTree + + + + + +ChartTree:xcharts'->Chart:xChart + + +each + + + +ChartOptions + + +ChartOptions + +markupOptions + +hudOptions + +chartTree + + + + + +ChartOptions:xmarkupOptions->MarkupOptions:xMarkupOptions + + + + + +ChartOptions:xhudOptions->HudOptions:xHudOptions + + + + + +ChartOptions:xchartTree->ChartTree:xChartTree + + + + + +ChartData + + +ChartData + +textData' + +rectData' + +pathData' + +lineData' + +glyphData' + +blankData' + + + + + +ChartData:xrectData'->Rect:xRect + + +_Just % each + + + +ChartData:xblankData'->Rect:xRect + + +_Just % each + + + +ChartData:xlineData'->Point:xPoint + + +_Just % each % each + + + +ChartData:xglyphData'->Point:xPoint + + +_Just % each + + + +ChartData:xpathData'->PathData:xPathData + + +_Just % each + + + +(Text,Point) + +(Text,Point) + +_2 + +_1 + + + +ChartData:xtextData'->(Text,Point):x(Text,Point) + + +_Just % each + + + +Chart:xchartStyle->Style:xStyle + + + + + +Chart:xchartData->ChartData:xChartData + + + + + +AxisOptions:xticks->Ticks:xTicks + + + + + +AxisOptions:xplace->Place:xPlace + + + + + +AxisBar + + +AxisBar + +style + +size + +overhang + +buffer + +anchorTo + + + + + +AxisOptions:xaxisBar->AxisBar:xAxisBar + + +_Just + + + +Adjustments + + +Adjustments + +maxYRatio + +maxXRatio + +angledRatio + +allowDiagonal + + + + + +AxisOptions:xadjustments->Adjustments:xAdjustments + + +_Just + + + +AxisBar:xstyle->Style:xStyle + + + + + +AxisBar:xanchorTo->HudChartSection:xHudChartSection + + + + + +(Text,Point):x_2->Point:xPoint + + + + + diff --git a/other/bar.svg b/other/bar.svg --- a/other/bar.svg +++ b/other/bar.svg @@ -1,4 +1,4 @@ -1.02.03.05.08.00.0-2.0112.01.01.02.03.04.05.06.07.08.09.010row 1row 2row 3row 4row 5row 6row 7row 8row 9row 10column 2column 1 diff --git a/other/compound.svg b/other/compound.svg new file mode 100644 --- /dev/null +++ b/other/compound.svg @@ -0,0 +1,56 @@ +-1.0-0.5 0.0 0.5 1.0-1.0-0.5 0.0 0.5 1.0-0.6-0.4-0.2 0.0 0.2 0.4 0.6-0.6-0.4-0.2 0.0 0.2 0.4 0.6chart1chart2 diff --git a/other/cubic.svg b/other/cubic.svg --- a/other/cubic.svg +++ b/other/cubic.svg @@ -1,4 +1,4 @@ -Bounding BoxPath Control PointPath EndpointsPath ChordPath FillCubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1) diff --git a/other/date.svg b/other/date.svg --- a/other/date.svg +++ b/other/date.svg @@ -1,4 +1,4 @@ -00:0003:0006:0009:0012:0015:0018:0021:0000:0006 Dec31 Dec31 Jan28 Feb13 Mar diff --git a/other/debug.svg b/other/debug.svg --- a/other/debug.svg +++ b/other/debug.svg @@ -1,4 +1,4 @@ -0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg diff --git a/other/ellipse.svg b/other/ellipse.svg --- a/other/ellipse.svg +++ b/other/ellipse.svg @@ -1,4 +1,4 @@ --2.0-1.5-1.0-0.5 0.0 0.5 1.0 1.5-2.0-1.0-0.5 0.0 0.5 1.0 2.0Bounding BoxEndpointsCentroidArcFull EllipseMinor AxisMajor AxisArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) diff --git a/other/ellipse2.svg b/other/ellipse2.svg --- a/other/ellipse2.svg +++ b/other/ellipse2.svg @@ -1,4 +1,4 @@ --2.0-1.5-1.0-0.5 0.0 0.5 1.0 1.5-2.0-1.0-0.5 0.0 0.5 1.0 2.0Bounding BoxEndpointsCentroidArcFull EllipseMinor AxisMajor AxisArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) diff --git a/other/glyphs.svg b/other/glyphs.svg --- a/other/glyphs.svg +++ b/other/glyphs.svg @@ -1,4 +1,4 @@ - diff --git a/other/gradient.svg b/other/gradient.svg --- a/other/gradient.svg +++ b/other/gradient.svg @@ -1,4 +1,4 @@ - diff --git a/other/hudoptions.svg b/other/hudoptions.svg --- a/other/hudoptions.svg +++ b/other/hudoptions.svg @@ -22,26 +22,25 @@ .legendBorder g { fill: rgb(5%, 5%, 5%); } -}-0.5-0.4-0.3-0.2-0.1 0.0 0.1 0.2 0.3 0.4 0.5-0.5-0.4-0.3-0.2-0.1 0.0 0.1 0.2 0.3 0.4 0.5 +} +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + +-0.6-0.4-0.2 0.0 0.2 0.4 0.6-0.6-0.4-0.2 0.0 0.2 0.4 0.6 diff --git a/other/line.svg b/other/line.svg --- a/other/line.svg +++ b/other/line.svg @@ -22,22 +22,24 @@ .legendBorder g { fill: rgb(5%, 5%, 5%); } -}0.00.51.01.52.02.53.03.54.04.55.00.00.51.01.52.02.53.0Line ChartMade with love and chart-svgpalette1 2palette1 1palette1 0 +} +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + +0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg diff --git a/other/path.svg b/other/path.svg --- a/other/path.svg +++ b/other/path.svg @@ -1,4 +1,4 @@ -StartP (Point 0 0)LineP (Point 1 0)CubicP (Point 0.2 0) (Point 0.25 1) (Point 1 1)QuadP (Point (-1) 2) (Point 0 1)ArcP (ArcInfo (Point 1 1) (-pi / 6) False False) (Point 0 0)0.00.51.02.0-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.0 diff --git a/other/priorityv1.svg b/other/priorityv1.svg --- a/other/priorityv1.svg +++ b/other/priorityv1.svg @@ -1,4 +1,4 @@ -0123450.00.51.01.52.02.53.0Line ChartMade with 🧡 and chart-svgpalette #2palette #1palette #0 diff --git a/other/priorityv2.svg b/other/priorityv2.svg --- a/other/priorityv2.svg +++ b/other/priorityv2.svg @@ -1,4 +1,4 @@ -0123450.00.51.01.52.02.53.0palette #2palette #1palette #0Line ChartMade with 🧡 and chart-svg diff --git a/other/quad.svg b/other/quad.svg --- a/other/quad.svg +++ b/other/quad.svg @@ -1,4 +1,4 @@ --1.0-0.5 0.0 0.5 1.00.00.51.01.52.0Bounding BoxPath Control PointPath EndpointsPath ChordPath FillQuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1)) diff --git a/other/rect.svg b/other/rect.svg --- a/other/rect.svg +++ b/other/rect.svg @@ -1,4 +1,4 @@ --6-4-2 0 2 4 6 diff --git a/other/sbar.svg b/other/sbar.svg --- a/other/sbar.svg +++ b/other/sbar.svg @@ -1,4 +1,4 @@ -row 1row 2row 3row 4row 5row 6row 7row 8row 9row 10column 2column 1 diff --git a/other/stack.svg b/other/stack.svg new file mode 100644 --- /dev/null +++ b/other/stack.svg @@ -0,0 +1,357 @@ +0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg0123450.00.51.01.52.02.53.0Line Chartpalette #2palette #1palette #0Made with 🧡 and chart-svg diff --git a/other/surface.svg b/other/surface.svg --- a/other/surface.svg +++ b/other/surface.svg @@ -1,4 +1,4 @@ --6-4-2 diff --git a/other/text.svg b/other/text.svg --- a/other/text.svg +++ b/other/text.svg @@ -23,6 +23,13 @@ fill: rgb(5%, 5%, 5%); } } +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + + { .text g { fill: rgb(5%, 5%, 5%); @@ -33,21 +40,16 @@ fill: rgb(94%, 94%, 94%); } } -abcdefghijklmnopqrstuvwxyz 0 5101520250.00.10.20.30.40.50.60.70.80.91.0 +abcdefghijklmnopqrstuvwxyz 0 5101520250.00.20.40.60.81.0 diff --git a/other/unit.svg b/other/unit.svg --- a/other/unit.svg +++ b/other/unit.svg @@ -22,26 +22,25 @@ .legendBorder g { fill: rgb(5%, 5%, 5%); } -}-0.5-0.4-0.3-0.2-0.1 0.0 0.1 0.2 0.3 0.4 0.5-0.5-0.4-0.3-0.2-0.1 0.0 0.1 0.2 0.3 0.4 0.5 +} +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + +-0.6-0.4-0.2 0.0 0.2 0.4 0.6-0.6-0.4-0.2 0.0 0.2 0.4 0.6 diff --git a/other/usage.svg b/other/usage.svg --- a/other/usage.svg +++ b/other/usage.svg @@ -22,22 +22,24 @@ .legendBorder g { fill: rgb(5%, 5%, 5%); } -}0.00.51.01.52.02.53.03.54.04.55.00.00.51.01.52.02.53.0 +} +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + +0123450.00.51.01.52.02.53.0 diff --git a/other/venn.svg b/other/venn.svg --- a/other/venn.svg +++ b/other/venn.svg @@ -1,4 +1,4 @@ --2.0-1.0-0.5 0.0 0.5 1.0 2.0-2.0-1.0-0.5 0.0 0.5 1.0 2.0 diff --git a/other/wave.svg b/other/wave.svg --- a/other/wave.svg +++ b/other/wave.svg @@ -22,23 +22,24 @@ .legendBorder g { fill: rgb(5%, 5%, 5%); } -}-1.0-0.8-0.6-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.001234567 +} +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} + +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + +-1.0-0.5 0.0 0.5 1.001234567 diff --git a/other/wheel.svg b/other/wheel.svg --- a/other/wheel.svg +++ b/other/wheel.svg @@ -1,4 +1,4 @@ --0.3-0.2-0.1 0.0 0.1 0.2-0.15-0.10-0.05 0.00 0.05 0.10 0.15 0.20 0.25 diff --git a/readme.org b/readme.org --- a/readme.org +++ b/readme.org @@ -9,14 +9,16 @@ * Usage #+begin_src haskell :file other/usage.svg :results output graphics file :exports both +:r +:set prompt "> " :set -XOverloadedLabels :set -XOverloadedStrings import Chart import Optics.Core lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] -styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] +styles = (\c -> defaultLineStyle & #color .~ palette c & #size .~ 0.015) <$> [0..2] cs = zipWith (\s x -> LineChart s [x]) styles lines -lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions +lineExample = mempty & #chartTree .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions writeChartOptions "other/usage.svg" lineExample #+end_src @@ -25,14 +27,18 @@ See the haddock documentation for a detailed overview. -* Related projects +* Examples -Downstream projects, where usage of chart-svg in various states of development can be found, include: +To redraw all the examples in Chart.Examples -[[https://github.com/tonyday567/color-adjust][color-adjust]] - experimenting with the [[https://bottosson.github.io/posts/oklab/][oklab]] colour space. Some of this has been incorporated in to chart-svg. +#+begin_src haskell :results output +import Chart.Examples +writeAllExamples +#+end_src -[[https://github.com/tonyday567/dotparse][dotparse]] - a chart-svg <-> graphviz bridge +#+RESULTS: +: ok -[[https://github.com/tonyday567/prettychart][prettychart]] - a chart-svg <-> ghci bridge -[[https://github.com/tonyday567/markup-parse][markup-parse]] - parse and prints markup (eg SVG) + + diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -8,32 +8,46 @@ -- -- $usage + -- * Design + -- $design + -- * What is a chart? -- -- $overview - -- * What is a Hud? + -- * What is style and what is data? -- + -- $fancy + + -- * What is a hud? + + -- -- $hud - -- * What is Markup? + -- * The primitives -- - -- $markup + -- $primitives -- * Optics Usage -- -- $optics + -- * Ecosystem + + -- + -- $ecosystem + -- * Re-exports module Chart.Primitive, module Chart.Data, module Chart.Hud, module Chart.Style, module Chart.Markup, + module Chart.Compound, module Chart.Bar, module Chart.Surface, module Data.Colour, @@ -44,6 +58,7 @@ where import Chart.Bar +import Chart.Compound import Chart.Data import Chart.Hud import Chart.Markup @@ -69,11 +84,34 @@ -- >>> import Chart -- >>> import Optics.Core -- >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] --- >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] +-- >>> let styles = (\c -> defaultLineStyle & set #color (palette c) & set #size 0.015) <$> [0..2] -- >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines --- >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions +-- >>> let lineExample = mempty & set #chartTree (named "line" cs) & set #hudOptions defaultHudOptions :: ChartOptions -- >>> writeChartOptions "other/usage.svg" lineExample +-- $design +-- +-- The library could be cleaved into two parts: +-- +-- - An abstract syntax tree (AST) that describes a chart, +-- +-- - Functionality that makes a chart given an AST. +-- +-- The majority of /work/ from a user perspective is in describing the chart. The library design reflects this and preference has been given to: +-- +-- - making the representation concrete,finite and non-recursive. 'ChartOptions' is the broadest type representing a chart and this has a Show instance. +-- +-- - providing ease of specification of what can be long trails of lenses leading to a chart component. +-- +-- With these design preferences in mind, the complete tree of non-trivial types (in base or IsString instances, say) is contained in the chart below: +-- ![AST](other/AST.svg) +-- +-- The underlying SVG is clickable and contains links to the relevant haddocks: [ChartOptions AST](https://hackage.haskell.org/package/chart-svg/docs/other/ast.svg) +-- +-- The labels on the chart arrows represent lenses between components that are container types (eg lists or maybes). Otherwise, arrows represent either generic lenses (such as #chartTree) or lenses supplied by the library (suffixed with a single quote, such as lineData'). As an example, to move all lines contained in line charts left by 1 (in data terms), you could say: +-- +-- > lineExample & over (#chartTree % charts' % each % #chartData % lineData' % _Just % each % each % _x) (+1) + -- $overview -- -- Charting consists of three tightly-coupled domains: @@ -90,14 +128,14 @@ -- -- and some line styles with different colors in order to distinguish the data: -- --- >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] +-- >>> let styles = (\c -> defaultLineStyle & #color .~ palette c & #size .~ 0.015) <$> [0..2] -- >>> styles --- [LineStyle {size = 1.5e-2, color = Colour 0.02 0.73 0.80 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},LineStyle {size = 1.5e-2, color = Colour 0.02 0.29 0.48 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},LineStyle {size = 1.5e-2, color = Colour 0.66 0.07 0.55 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing}] +-- [Style {size = 1.5e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph},Style {size = 1.5e-2, borderSize = 1.0e-2, color = Colour 0.02 0.29 0.48 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph},Style {size = 1.5e-2, borderSize = 1.0e-2, color = Colour 0.66 0.07 0.55 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}] -- -- This is enough to create the charts. -- -- >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines --- >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions +-- >>> let lineExample = mempty & #chartTree .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions -- >>> :t lineExample -- lineExample :: ChartOptions -- @@ -105,10 +143,22 @@ -- -- ![usage example](other/usage.svg) +-- $fancy +-- +-- The division between what is data and what is style is an arbitrary one, in this library and elsewhere. Hofstadter mused that "content is just fancy form" and this very much applies to charting. Color and glyph shape are just two examples of style used to represent data (See 'Chart.Examples.surfaceExample' and 'Chart.Examples.arrowExample'). +-- +-- If pushed, the canvas of a chart represents the interactions of two domains: a data domain and a physical space (a screen or a html element or a piece of paper). What is 'ChartData' is practically the data domain represented by the xy-plane that is the canvas. Thus it is a point, a rectangle, a path or some text. Everything else; color, shape, finish and polish, is designated 'Style'. + -- $hud -- --- A 'Hud' is the collection of axes, titles, tick marks, grid lines and legends for a 'Chart', which do not explicitly represent the data but, instead, exist to provide references to help explain the data being represented. The collective noun used by the library for these elements is /hud/. Hud elements can usually be distinguished from data syntax, but need information from the chart domain (data domain and style domain) to function. A tick mark and tick value on an axis need to know the range of the data to be placed properly on the screen. A chart border needs to know the syntactic range of the entire data representation inclusive of representational artifacts that might extend beyond the data domain. A glyph representing a one-dimensional point exists in 2 dimensions, or we wouldn't be able to see it. +-- A 'Hud' is a type whose lower-case interpretation is as a collective noun for axes, titles, tick marks, grid lines and legends for a 'Chart'. Formally, a 'Hud': -- +-- - is a 'Priority' helping to order the drawing of hud elements, and +-- +-- - a function with the signature: 'HudChart' -> 'ChartTree'. Given a tree of charts and huds, provide a 'ChartTree' that represents the hud component. +-- +-- A hud does not explicitly represent the data but, instead, exists to provide references to help explain the data being represented. Hud elements can usually be distinguished from data syntax, but need information from the chart domain (data domain and style domain) to function. A tick mark and tick value on an axis need to know the range of the data to be placed properly on the screen. A chart border needs to know the syntactic range of the entire data representation inclusive of representational artifacts that might extend beyond the data domain. A glyph representing a one-dimensional point exists in 2 dimensions, or we wouldn't be able to see it. +-- -- Apart from this functional usage, however, hud elements are pretty much the same as data elements. They are typically composed of the same stuff; rectangles and lines and text and colors. -- -- Given this similarity, the library process for chart creation is roughly: @@ -117,29 +167,45 @@ -- -- - measure the range of the data values -- --- - fold hud elements into a chart, creating new 'ChartTree's from the hud, keeping track of chart dimensions across three domains: --- --- 1. The domain of the underlying data +-- - fold hud elements into a chart, creating new 'ChartTree's from the hud, keeping track of chart dimensions: -- --- 2. The domain of the canvas where the data is being represented +-- 1. across the domain of the underlying data -- --- 3. The domain of the chart, inclusive of Hud or decorative elements. +-- 2. across the domain of the physical chart, inclusive of Hud or decorative elements. -- -- This protocol is reified in 'runHudWith'. The most common Hud concepts, such as axes and titles, have been collected into the 'HudOptions' type. -- --- An important quality of 'runHud' (and conversion of charts to svg in general) is that this is the point at which chart data is converted from the data domain to the page domain, and is destructive. Typically, at that point of the pipeline, information about the data disappears, so that we no longer can tell what is chart and what is hud. +-- An important quality of 'runHudWith' (and conversion of charts to svg in general) is that this is the point at which chart data is converted from the data domain to the page domain, and is destructive. Typically, at that point of the pipeline, information about the data disappears, so that we no longer can tell what is chart and what is hud. --- $markup +-- $primitives -- --- 'Markup' is, essentially, SVG (or XML) sufficient to turn a chart into SVG text, but insufficiently standards compliant to call it that. The pipeline from chart to screen is approximately: +-- A trick of the library is that huds become processed into charts, and complex charts are just compositions of simpler charts. There are exactly six primitive chart types represented by these patterns: -- --- - Create a 'ChartOptions' which is a product of a 'ChartTree', 'HudOptions' and 'MarkupOptions', which is SVG specific configuration details. --- - Convert this to 'Markup' via 'markupChartOptions', or --- - Convert this to ByteString via 'encodeChartOptions',or --- - Convert this to Text via 'renderChartOptions' +-- - 'RectChart': (list of) rectangles +-- - 'LineChart': (list of list of) points +-- - 'TextChart': (list of) text, point tuples +-- - 'GlyphChart': (list of) points (and 'glyphShape' from 'chartStyle') +-- - 'PathChart': (list of) 'PathData' +-- - 'BlankChart': (list of) rectangles with no stylistic manifestation. -- $optics -- -- Usage suggests the use of optics-core and OverloadedLabels, but this is not required. 'Chart', 'HudOptions' and associated chart configuration types are big and sometimes deep syntax trees, and simple optics; getting, setting and modding, makes manipulation more pleasant. Lens works as well, and the library is perfectly capable of being used with records. -- -- Lenses are supplied, for the optics-core library, but can be easily modified for lens. The chart-svg convention is that lenses are either OverloadedLabels, and thus prefixed with a #, or suffixed with a single quote /'/. + +-- $ecosystem +-- +-- Charting is a broad concern and several upstream libraries provide aspects of charting that are used within and in conjunction with this library: +-- +-- - [numhask-space](https://hackage.haskell.org/package/numhask-space): provides abstract mathematics for the 'Space' domain, including representations of points ('Point') and rectangles ('Rect'). +-- +-- - [markup-parse](https://hackage.haskell.org/package/markup-parse): provides conversion to and from SVG, HTML and any other XML-like text-based representations. +-- +-- - [formatn](https://hackage.haskell.org/package/formatn): provides significant figure and rounding compoutations for Doubles. +-- +-- Downstream tools for this library include: +-- +-- - [prettychart](https://hackage.haskell.org/package/prettychart): live creation of charts. +-- +-- - [dotparse](https://hackage.haskell.org/package/dotparse): creation of charts using graphviz and the dot language. diff --git a/src/Chart/Bar.hs b/src/Chart/Bar.hs --- a/src/Chart/Bar.hs +++ b/src/Chart/Bar.hs @@ -10,6 +10,7 @@ bars, barChart, barRects, + barTextCharts, ) where @@ -22,7 +23,7 @@ import Data.Colour import Data.Foldable import Data.FormatN -import Data.List (scanl', transpose) +import Data.List (transpose) import Data.Maybe import Data.Text (Text, pack) import GHC.Generics @@ -56,11 +57,11 @@ -- -- ![bar chart example](other/bar.svg) data BarOptions = BarOptions - { barRectStyles :: [RectStyle], - barTextStyles :: [TextStyle], + { barRectStyles :: [Style], + barTextStyles :: [Style], -- | gap between each bar collection row. outerGap :: Double, - -- | gap between bars within a row collection, negative overlaps + -- | gap between bars within a row collection. Negative numbers represent bar overlaps. innerGap :: Double, -- | gap between top of a bar and text representation of the bar value -- as a proportion of the highest absolute bar value @@ -69,6 +70,9 @@ -- if the value is negative -- as a proportion of the highest absolute bar value textGapNegative :: Double, + -- | A nudge to help text align for horizontal bar charts. + textShiftVert :: Double, + -- | Whether to display text values above bars. displayValues :: Bool, valueFormatN :: FormatN, barOrientation :: Orientation, @@ -77,6 +81,26 @@ } deriving (Show, Eq, Generic) +-- | The official bar options. +defaultBarOptions :: BarOptions +defaultBarOptions = + BarOptions + gs + ts + 0.1 + 0 + 0.03 + 0.05 + (-0.008) + True + (FormatN FSCommaPrec (Just 2) 4 True True) + Vert + NonStacked + defaultLegendOptions + where + gs = (\x -> defaultRectStyle & set #borderSize 0.005 & set #borderColor (palette x) & set #color (paletteO x 0.7)) <$> [1, 2, 6, 7, 5, 3, 4, 0] + ts = (\x -> defaultTextStyle & set #color (palette x) & set #size 0.03) <$> [1, 2, 6, 7, 5, 3, 4, 0] + -- | Number of bars per row of data cols :: Stacked -> [[Double]] -> Int cols Stacked _ = 1 @@ -96,17 +120,25 @@ barX0 :: BarOptions -> [[Double]] -> Int -> Int -> Double barX0 o xs i j = outerGap o / 2 + fromIntegral i + fromIntegral j * (barWidth o xs + innerGap o) --- | Make bars from the double list values. +-- | Make bars from the double list values, normalizing to one :: Rect. -- -- >>> barRects defaultBarOptions [[1,2],[2,3]] --- [[Rect 5.0e-2 0.5 0.0 1.0,Rect 1.05 1.5 0.0 2.0],[Rect 0.5 0.95 0.0 2.0,Rect 1.5 1.95 0.0 3.0]] +-- [[Rect (-0.5) (-0.26315789473684215) (-0.5) (-0.16666666666666669),Rect 2.631578947368418e-2 0.26315789473684204 (-0.5) 0.16666666666666663],[Rect (-0.26315789473684215) (-2.6315789473684292e-2) (-0.5) 0.16666666666666663,Rect 0.26315789473684204 0.4999999999999999 (-0.5) 0.5]] -- -- >>> barRects defaultBarOptions [[]] -- [] barRects :: BarOptions -> [[Double]] -> [[Rect Double]] -barRects o xs = fmap (flipRect (barOrientation o)) <$> zip2With (\y x0 -> abs (Rect x0 (x0 + barWidth o xs) 0 y)) xs' (barX0s o xs') +barRects o xs = rects' where - xs' = bool id accRows (barStacked o == Stacked) (appendZeros xs) + rects' = fmap (fmap (projectOnR one sb)) rects + rects = fmap (fmap (flipRect (barOrientation o))) $ accVals $ zip2With (\y x0 -> abs (Rect x0 (x0 + barWidth o xs') 0 y)) xs' (barX0s o xs') + sb = fromMaybe one $ foldRect (mconcat rects) + xs' = appendZeros xs + accVals = bool id accRectYs (barStacked o == Stacked) + accRectYs xss = foldr addLast [] xss + addLast rs [] = [rs] + addLast rs res@(l : _) = zipWith addW rs l : res + addW (Rect x z y w) (Rect _ _ _ w') = Rect x z (y + w') (w + w') zip2With :: (a -> b -> c) -> [[a]] -> [[b]] -> [[c]] zip2With f = zipWith (zipWith f) @@ -117,7 +149,7 @@ -- | Placements for the bars (x axis for vertical bars) barX0s :: BarOptions -> [[Double]] -> [[Double]] -barX0s o xs = transpose $ iter2 (barX0 o xs) [0 .. (rows xs - 1)] [0 .. cols (barStacked o) xs - 1] +barX0s o xs = transpose $ iter2 (barX0 o xs) [0 .. (rows xs - 1)] (bool (replicate (length xs) 0) [0 .. (length xs - 1)] (barStacked o == NonStacked)) flipRect :: Orientation -> Rect Double -> Rect Double flipRect Vert r = r @@ -132,20 +164,17 @@ ) <$> xs -accRows :: [[Double]] -> [[Double]] -accRows xs = transpose $ drop 1 . scanl' (+) 0 <$> transpose (fmap toList $ toList xs) - -- | A bar chart. -- -- >>> emptyBar = barChart defaultBarOptions (BarData [] [] []) --- >>> foldOf (#charts % charts') emptyBar +-- >>> foldOf (#chartTree % charts') emptyBar -- [] barChart :: BarOptions -> BarData -> ChartOptions barChart bo bd = mempty & set #hudOptions (barHudOptions bo bd) & set - #charts + #chartTree ( named "barchart" ( bars bo bd @@ -156,34 +185,11 @@ barHudOptions :: BarOptions -> BarData -> HudOptions barHudOptions bo bd = mempty - & #axes - .~ [ (1, axis1) - ] - & #legends - .~ [ (10, o & #legendCharts .~ barLegendContent bo bd) - ] + & set #axes [Priority 1 axis1] + & set #legends [Priority 10 (o & set #legendCharts (barLegendContent bo bd))] where o = view #barLegendOptions bo - axis1 = bool id flipAxis (barOrientation bo == Hori) (defaultAxisOptions & #ticks % #ltick .~ Nothing & #ticks % #style .~ barTicks bd) - --- | The official bar options. -defaultBarOptions :: BarOptions -defaultBarOptions = - BarOptions - gs - ts - 0.1 - 0 - 0.04 - 0.1 - True - (FormatN FSCommaPrec (Just 2) 4 True True) - Vert - NonStacked - defaultLegendOptions - where - gs = (\x -> RectStyle 0.005 (palette1 x) (palette1a x 0.7)) <$> [1, 2, 6, 7, 5, 3, 4, 0] - ts = (\x -> defaultTextStyle & #color .~ palette1 x & #size .~ 0.24) <$> [1, 2, 6, 7, 5, 3, 4, 0] + axis1 = bool defaultXAxisOptions defaultYAxisOptions (barOrientation bo == Hori) & set (#ticks % #lineTick) Nothing & set (#ticks % #tick) (barTicks bd) -- | Two dimensional data, maybe with row and column labels. data BarData = BarData @@ -199,17 +205,17 @@ -- Rect 0.0 2.0 0.0 3.0 -- -- >>> barRange [[]] --- Rect -0.5 0.5 -0.5 0.5 +-- Rect (-0.5) 0.5 (-0.5) 0.5 barRange :: [[Double]] -> Rect Double -barRange ys = singletonGuard $ Just $ Rect 0 (fromIntegral $ rows ys) (min 0 l) u +barRange ys = padSingletons $ Rect 0 (fromIntegral $ rows ys) (min 0 l) u where (Range l u) = fromMaybe one $ space1 $ mconcat ys -- | A bar chart without hud trimmings. -- -- >>> bars defaultBarOptions (BarData [[1,2],[2,3]] [] []) --- [RectChart (RectStyle {borderSize = 5.0e-3, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.29 0.48 0.70}) [Rect 5.0e-2 0.5 0.0 1.0,Rect 1.05 1.5 0.0 2.0],RectChart (RectStyle {borderSize = 5.0e-3, borderColor = Colour 0.66 0.07 0.55 1.00, color = Colour 0.66 0.07 0.55 0.70}) [Rect 0.5 0.95 0.0 2.0,Rect 1.5 1.95 0.0 3.0],BlankChart [Rect 0.0 2.0 0.0 3.0]] +-- [Chart {chartStyle = Style {size = 6.0e-2, borderSize = 5.0e-3, color = Colour 0.02 0.29 0.48 0.70, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, chartData = RectData [Rect (-0.5) (-0.26315789473684215) (-0.5) (-0.16666666666666669),Rect 2.631578947368418e-2 0.26315789473684204 (-0.5) 0.16666666666666663]},Chart {chartStyle = Style {size = 6.0e-2, borderSize = 5.0e-3, color = Colour 0.66 0.07 0.55 0.70, borderColor = Colour 0.66 0.07 0.55 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, chartData = RectData [Rect (-0.26315789473684215) (-2.6315789473684292e-2) (-0.5) 0.16666666666666663,Rect 0.26315789473684204 0.4999999999999999 (-0.5) 0.5]}] -- -- >>> bars defaultBarOptions (BarData [[]] [] []) -- [] @@ -219,45 +225,37 @@ cs = zipWith (\o d -> RectChart o d) - (bo ^. #barRectStyles <> repeat defaultRectStyle) - (barRects bo (bd ^. #barData)) - <> [BlankChart [barRange (bd ^. #barData)]] + (view #barRectStyles bo <> repeat defaultRectStyle) + (barRects bo (view #barData bd)) -- | Sensible ticks for a bar chart. -barTicks :: BarData -> TickStyle +barTicks :: BarData -> Tick barTicks bd - | null (bd ^. #barData) = TickNone - | null (bd ^. #barRowLabels) = - TickLabels $ pack . show <$> [0 .. (rows (bd ^. #barData) - 1)] + | null (view #barData bd) = TickNone + | null (view #barRowLabels bd) = + TickLabels $ pack . show <$> [0 .. (rows (view #barData bd) - 1)] | otherwise = TickLabels $ - take (rows (bd ^. #barData)) $ - (bd ^. #barRowLabels) <> repeat "" + take (rows (view #barData bd)) $ + view #barRowLabels bd <> repeat "" -- | A bar legend barLegendContent :: BarOptions -> BarData -> [(Text, [Chart])] barLegendContent bo bd - | null (bd ^. #barData) = [] - | null (bd ^. #barColumnLabels) = [] + | null (view #barData bd) = [] + | null (view #barColumnLabels bd) = [] | otherwise = zip (view #barColumnLabels bd <> repeat "") - ((\s -> [RectChart s [one]]) <$> take (length (view #barData bd)) (bo ^. #barRectStyles)) - -flipPoint :: Orientation -> Point a -> Point a -flipPoint Vert p = p -flipPoint Hori (Point x y) = Point y x - -maxAbsValue :: [[Double]] -> Double -maxAbsValue xs = maximum $ fmap abs (0 : mconcat xs) + ((\s -> [Chart s (RectData [one])]) <$> take (length (view #barData bd)) (view #barRectStyles bo)) barTexts :: BarOptions -> [[Double]] -> [[(Text, Point Double)]] -barTexts o xs = zip2With (\t (Rect x z y w) -> (t, flipPoint (barOrientation o) (Point ((x + z) / 2) (bool (w + gap) (y - gapn) (y < 0))))) (fmap (formatN (valueFormatN o)) <$> xs) (barRects o xs) +barTexts o xs = zip2With (\x r -> (formatN (valueFormatN o) x, gapt (barOrientation o) r x)) xs (barRects o xs) where - gap = textGap o * maxAbsValue xs - gapn = textGapNegative o * maxAbsValue xs + gapt Vert (Rect x z y w) x' = Point ((x + z) / 2) (bool (w + textGap o) (y - textGapNegative o) (x' < 0)) + gapt Hori (Rect x z y w) x' = Point (bool (z + textGap o) (x - textGapNegative o) (x' < 0)) ((y + w) / 2 + textShiftVert o) -- | Placed text, hold the bars. barTextCharts :: BarOptions -> BarData -> [Chart] barTextCharts bo bd = - zipWith TextChart (bo ^. #barTextStyles <> repeat defaultTextStyle) (barTexts bo (bd ^. #barData)) + zipWith TextChart (view #barTextStyles bo <> repeat defaultTextStyle & set (each % #scaleP) ScalePArea) (barTexts bo (view #barData bd)) diff --git a/src/Chart/Compound.hs b/src/Chart/Compound.hs new file mode 100644 --- /dev/null +++ b/src/Chart/Compound.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Combine charts that share a common canvas. +module Chart.Compound + ( runHudCompoundWith, + addHudCompound, + compoundMerge, + writeChartOptionsCompound, + encodeChartOptionsCompound, + markupChartOptionsCompound, + ) +where + +import Chart.Hud +import Chart.Markup +import Chart.Primitive +import Chart.Style +import Data.Bool +import Data.ByteString.Char8 qualified as C +import Data.Foldable +import Data.List qualified as List +import Data.Maybe +import MarkupParse +import Optics.Core +import Prelude + +-- | Write multiple charts to a single file sharing the canvas. +writeChartOptionsCompound :: FilePath -> [ChartOptions] -> IO () +writeChartOptionsCompound fp cs = C.writeFile fp (encodeChartOptionsCompound cs) + +-- | Encode multiple charts. +encodeChartOptionsCompound :: [ChartOptions] -> C.ByteString +encodeChartOptionsCompound [] = mempty +encodeChartOptionsCompound cs@(c0 : _) = + markdown_ (view (#markupOptions % #renderStyle) c0) Xml (markupChartOptionsCompound cs) + +-- | Create Markup representing multiple charts sharing a common canvas. +markupChartOptionsCompound :: [ChartOptions] -> Markup +markupChartOptionsCompound [] = mempty +markupChartOptionsCompound cs@(co0 : _) = + header + (view (#markupOptions % #markupHeight) co0) + viewbox + ( markupCssOptions (view (#markupOptions % #cssOptions) co0) + <> markupChartTree ctFinal + ) + where + viewbox = view safeStyleBox' ctFinal + ctFinal = + projectChartCompoundWith + (view (#markupOptions % #chartAspect) co0) + (zip (view #hudOptions <$> cs) (view #chartTree <$> cs)) + +projectChartCompoundWith :: ChartAspect -> [(HudOptions, ChartTree)] -> ChartTree +projectChartCompoundWith asp css = ctFinal + where + csAndHud = addHudCompound asp css + viewbox = finalCanvas asp (Just csAndHud) + ctFinal = set styleBox' (Just viewbox) csAndHud + +-- | Merge a list of ChartOptions, treating each element as charts to be merged. Note that this routine mempties the hud options and converts them to charts. +compoundMerge :: [ChartOptions] -> ChartOptions +compoundMerge [] = mempty +compoundMerge cs@(c0 : _) = + ChartOptions + (view #markupOptions c0) + mempty + (addHudCompound (view (#markupOptions % #chartAspect) c0) (zip (view #hudOptions <$> cs) (view #chartTree <$> cs))) + +-- | Decorate a ChartTree with HudOptions, merging the individual hud options. +addHudCompound :: ChartAspect -> [(HudOptions, ChartTree)] -> ChartTree +addHudCompound _ [] = mempty +addHudCompound asp ts@((_, cs0) : _) = + runHudCompoundWith + (initialCanvas asp (Just cs0)) + (zip3 dbs' hss css') + where + css :: [ChartTree] + css = snd <$> ts + hos = fst <$> ts + dbs = view safeBox' <$> css + huds = zipWith toHuds hos dbs + mdbs = fst <$> huds + hss = snd <$> huds + dbs' = zipWith fromMaybe dbs mdbs + css' :: [ChartTree] + css' = zipWith3 (\cs mdb db -> cs <> maybe mempty (\r -> bool (named "datapadding" [BlankChart defaultStyle [r]]) mempty (r == db)) mdb) css mdbs dbs + +-- | Combine a collection of chart trees that share a canvas box. +runHudCompoundWith :: + -- | initial canvas + ChartBox -> + -- | databox-huds-chart tuples representing independent chart trees occupying the same canvas space + [(DataBox, [Hud], ChartTree)] -> + -- | integrated chart tree + ChartTree +runHudCompoundWith cb ts = hss + where + hss = + ts + & fmap (\(_, hs, _) -> hs) + & mconcat + & prioritizeHuds + & fmap (fmap (view (#phud % #item))) + & foldl' (\x a -> makeHuds a x) hc0 + & fromHudChart + css = + ts + & fmap (\(db, _, ct) -> over chart' (projectWith cb db) ct) + & mconcat + hc0 = HudChart (css & set styleBox' (Just cb)) mempty + +prioritizeHuds :: [Hud] -> [[Hud]] +prioritizeHuds hss = + hss + & List.sortOn (view (#phud % #priority)) + & List.groupBy (\a b -> view (#phud % #priority) a == view (#phud % #priority) b) diff --git a/src/Chart/Data.hs b/src/Chart/Data.hs --- a/src/Chart/Data.hs +++ b/src/Chart/Data.hs @@ -1,41 +1,49 @@ +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- | Data primitives and utilities -- -- Whilst the library makes use of , it does not re-export, to avoid clashes with Prelude, with the exception of 'zero', 'one', 'angle' & 'abs'. -- --- 'Rect' and 'Point', from , make up the base elements of many chart primitives, and all of numhask-space is re-exported. +-- 'Rect' and 'Point', from , make up the base elements of many chart primitives. module Chart.Data ( -- * Data Primitives Rect (..), + pattern Rect, + mid, + foldRect, + addPoint, + projectOnP, + projectOnR, + space1, padRect, padSingletons, - singletonGuard, + isSingleton, Point (..), addp, + Range (..), -- * NumHask Exports - - -- | Note that (+) and (*) from numhask are not actually re-exported. Multiplicative (one), Additive (zero), abs, - angle, - magnitude, - - -- * Re-exports - module NumHask.Space, + Direction (..), + Basis (..), ) where import NumHask.Prelude import NumHask.Space +-- $setup +-- +-- >>> import Chart +-- >>> import NumHask.Space + -- | Additive pad (or frame or buffer) a Rect. -- -- >>> padRect 1 one --- Rect -1.5 1.5 -1.5 1.5 +-- Rect (-1.5) 1.5 (-1.5) 1.5 padRect :: (Subtractive a) => a -> Rect a -> Rect a padRect p (Rect x z y w) = Rect (x - p) (z + p) (y - p) (w + p) @@ -46,10 +54,10 @@ -- Due to the use of scaling, and thus zero dividing, this is a common exception to guard against. -- -- >>> project (Rect 0 0 0 1) one (Point 0 0) --- Point NaN -0.5 +-- Point NaN (-0.5) -- -- >>> project (padSingletons (Rect 0 0 0 1)) one (Point 0 0) --- Point 0.0 -0.5 +-- Point 0.0 (-0.5) padSingletons :: Rect Double -> Rect Double padSingletons (Rect x z y w) | x == z && y == w = Rect (x - 0.5) (x + 0.5) (y - 0.5) (y + 0.5) @@ -57,9 +65,9 @@ | y == w = Rect x z (y - 0.5) (y + 0.5) | otherwise = Rect x z y w --- | Guard against an upstream Nothing or a singleton dimension -singletonGuard :: Maybe (Rect Double) -> Rect Double -singletonGuard = maybe one padSingletons +-- | is any dimension singular? +isSingleton :: Rect Double -> Bool +isSingleton (Rect x z y w) = x == z || y == w -- | add Points, dimension-wise -- diff --git a/src/Chart/Examples.hs b/src/Chart/Examples.hs --- a/src/Chart/Examples.hs +++ b/src/Chart/Examples.hs @@ -36,6 +36,16 @@ -- * Debugging debugExample, + + -- * Compound Charts + compoundExample, + stackExample, + + -- * Priority + priorityv1Example, + priorityv2Example, + + -- * Writing to file pathChartOptions, writeAllExamples, writeAllExamplesDark, @@ -52,6 +62,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Time +import NumHask.Space import Optics.Core import Prelude hiding (abs) @@ -59,7 +70,10 @@ -- -- ![unit example](other/unit.svg) unitExample :: ChartOptions -unitExample = mempty & #charts .~ named "unit" [RectChart defaultRectStyle [one]] & #hudOptions .~ defaultHudOptions +unitExample = + mempty + & set #chartTree (named "unit" [Chart defaultRectStyle (RectData [one])]) + & set #hudOptions defaultHudOptions -- | A 'BlankChart', 'defaultHudOptions' example. -- @@ -67,8 +81,8 @@ hudOptionsExample :: ChartOptions hudOptionsExample = mempty - & #hudOptions .~ defaultHudOptions - & #charts .~ blank one + & set #hudOptions defaultHudOptions + & set #chartTree (blank one) -- | rect example -- @@ -76,24 +90,19 @@ rectExample :: ChartOptions rectExample = mempty - & #hudOptions - .~ ( mempty - & set - #axes - [(defaultPriority, defaultAxisOptions & #ticks % #ltick .~ Nothing)] - ) - & #charts .~ named "rect" (zipWith RectChart ropts rss) + & set #hudOptions (mempty & set #axes [Priority 5 (defaultXAxisOptions & set (#ticks % #lineTick) Nothing)]) + & set #chartTree (named "rect" (zipWith (\s x -> Chart s (RectData x)) ropts rss)) rss :: [[Rect Double]] rss = - [ gridR (\x -> exp (-x ** 2 / 2)) (Range (-5) 5) 50, - gridR (\x -> 0.5 * exp (-x ** 2 / 8)) (Range (-5) 5) 50 + [ gridR (\x -> exp (-(x ** 2 / 2))) (Range (-5) 5) 50, + gridR (\x -> 0.5 * exp (-(x ** 2 / 8))) (Range (-5) 5) 50 ] -ropts :: [RectStyle] +ropts :: [Style] ropts = - [ blob (palette1a 1 0.4), - blob (palette1a 2 0.4) + [ blob (paletteO 1 0.4), + blob (paletteO 2 0.4) ] -- | line example @@ -101,36 +110,33 @@ -- ![line example](other/line.svg) lineExample :: ChartOptions lineExample = - mempty & set #hudOptions ho & #charts .~ named "line" cs + mempty & set #hudOptions ho & set #chartTree (named "line" cs) where ho = defaultHudOptions & set #titles - [ (6, defaultTitle "Line Chart" & set (#style % #size) 0.1), - ( 11, - defaultTitle "Made with love and chart-svg" - & set (#style % #size) 0.06 + [ Priority 6 (defaultTitleOptions "Line Chart" & set (#style % #size) 0.08), + Priority 13 $ + defaultTitleOptions "Made with 🧡 and chart-svg" + & set (#style % #size) 0.04 & set #place PlaceBottom & set #anchor AnchorEnd - ) ] & set #legends - [ ( 12, + [ Priority 12 $ defaultLegendOptions - & over #frame (fmap (set #color white)) - & set #place (PlaceAbsolute (Point 0.45 (-0.35))) - & set (#textStyle % #size) 0.20 - & set #legendCharts (zipWith (\t c -> (t, [c])) ["palette1 0", "palette1 1", "palette1 2"] cs) - ) + & set #scaleP ScalePX + & set #place (PlaceAbsolute (Point 0.35 (-0.35))) + & set #legendCharts (zipWith (\t c -> (t, [c])) ["palette #0", "palette #1", "palette #2"] cs) ] cs = zipWith ( \c l -> LineChart ( defaultLineStyle - & set #color (palette1 c) + & set #color (palette c) & set #size 0.015 ) [l] @@ -143,11 +149,27 @@ [Point 0.5 4.0, Point 0.5 0] ] +-- | priority Version 1 example +-- +-- ![priorityv1 example](other/priorityv1.svg) priorityv1Example :: ChartOptions -priorityv1Example = lineExample & (#hudOptions % #frames) .~ [(1, FrameOptions (Just defaultRectStyle) 0), (100, FrameOptions (Just (defaultRectStyle & #color .~ (palette1 4 & opac' .~ 0.05) & #borderColor .~ palette1 4)) 0.1)] & #hudOptions % #legends %~ fmap (first (const (Priority 50))) & #hudOptions % #legends %~ fmap (second (set #place PlaceRight)) +priorityv1Example = + lineExample + & set + (#hudOptions % #frames) + [ Priority 1 (FrameOptions (Just defaultRectStyle) CanvasStyleSection 0), + Priority 100 (FrameOptions (Just (defaultRectStyle & set #color (palette 4 & set opac' 0.05) & set #borderColor (palette 4))) HudStyleSection 0.1) + ] + & set (#hudOptions % #legends % each % #priority) 50 + & set (#hudOptions % #legends % each % #item % #place) PlaceRight +-- | priority Version 2 example +-- +-- ![priorityv2 example](other/priorityv2.svg) priorityv2Example :: ChartOptions -priorityv2Example = priorityv1Example & #hudOptions % #titles %~ fmap (first (const (Priority 51))) & #hudOptions % #legends %~ fmap (first (const (Priority 50))) & #hudOptions % #legends %~ fmap (second (set #place PlaceRight)) +priorityv2Example = + priorityv1Example + & set (#hudOptions % #titles % each % #priority) 51 -- | text example -- @@ -155,16 +177,10 @@ textExample :: ChartOptions textExample = mempty - & #charts - .~ named - "text" - [ TextChart - (defaultTextStyle & #color .~ dark & #size .~ 0.05 & #vshift .~ 0) - ts - ] - & #hudOptions .~ defaultHudOptions - & #markupOptions % #cssOptions % #preferColorScheme .~ PreferHud - & #markupOptions % #cssOptions % #cssExtra .~ fillSwitch (dark, light) "dark" "text" + & set #chartTree (named "text" [TextChart (defaultTextStyle & set #color dark & set #size 0.1) ts]) + & set #hudOptions defaultHudOptions + & set (#markupOptions % #cssOptions % #preferColorScheme) PreferHud + & set (#markupOptions % #cssOptions % #cssExtra) (fillSwitch (dark, light) "dark" "text") where ts :: [(Text, Point Double)] ts = @@ -178,18 +194,18 @@ glyphsExample :: ChartOptions glyphsExample = mempty - & set (#markupOptions % #markupHeight) 50 - & set (#hudOptions % #chartAspect) (FixedAspect 12) + & set (#markupOptions % #markupHeight) (Just 50) + & set (#markupOptions % #chartAspect) (FixedAspect 12) & set - #charts + #chartTree ( named "glyphs" $ zipWith ( \(sh, bs) p -> GlyphChart ( defaultGlyphStyle - & #size .~ (0.8 :: Double) - & #borderSize .~ bs - & #shape .~ sh + & set #glyphShape sh + & set #size (0.8 :: Double) + & set #borderSize bs ) [p] ) @@ -200,10 +216,10 @@ (EllipseGlyph 0.75, 0.02), (VLineGlyph, 0.02), (HLineGlyph, 0.02), - (TriangleGlyph (Point 0.0 (0.5 * sqrt 2)) (Point (-cos (pi / 3)) (-sin (pi / 3) / 2)) (Point (cos (pi / 3)) (-sin (pi / 3) / 2)), 0.02), - (PathGlyph "M 0.5,-0.3660 A 1.0 1.0 -0.0 0 1 0,0.5 A 1.0 1.0 -0.0 0 1 -0.5,-0.3660 A 1.0 1.0 -0.0 0 1 0.5,-0.3660 L 0.5,-0.3660 Z" ScaleBorder, 0.02) + (TriangleGlyph (Point 0.0 (0.5 * sqrt 2)) (Point (-(cos (pi / 3))) (-(sin (pi / 3) / 2))) (Point (cos (pi / 3)) (-(sin (pi / 3) / 2))), 0.02), + (PathGlyph "M 0.5,-0.3660 A 1.0 1.0 -0.0 0 1 0,0.5 A 1.0 1.0 -0.0 0 1 -0.5,-0.3660 A 1.0 1.0 -0.0 0 1 0.5,-0.3660 L 0.5,-0.3660 Z", 0.02) ] - [Point x 0 | x <- [0 .. (8 :: Double)]] + (fmap (\x -> Point x 0) [0 ..]) ) -- | Example data for Bar chart @@ -218,19 +234,21 @@ -- -- ![bar example](other/bar.svg) barExample :: ChartOptions -barExample = barChart defaultBarOptions barDataExample +barExample = + barChart defaultBarOptions barDataExample + & set (#hudOptions % #frames) [Priority 101 (defaultFrameOptions & set #buffer 0.02)] -- | Stacked bar chart example. -- -- ![sbar example](other/sbar.svg) sbarExample :: ChartOptions -sbarExample = barChart (defaultBarOptions & set #barOrientation Vert & set #barStacked Stacked & #displayValues .~ False & #barRectStyles %~ fmap (#borderSize .~ 0)) barDataExample +sbarExample = barChart (defaultBarOptions & set #barOrientation Vert & set #barStacked Stacked & set #displayValues False & set (#barRectStyles % each % #borderSize) 0) barDataExample -- | wave example -- -- ![wave example](other/wave.svg) waveExample :: ChartOptions -waveExample = mempty & #charts .~ named "wave" [GlyphChart defaultGlyphStyle $ gridP sin (Range 0 (2 * pi)) 30] & #hudOptions .~ defaultHudOptions +waveExample = mempty & set #chartTree (named "wave" [GlyphChart (defaultGlyphStyle & set #glyphShape SquareGlyph) (gridP sin (Range 0 (2 * pi)) 30)]) & set #hudOptions defaultHudOptions -- | venn diagram -- @@ -238,9 +256,9 @@ vennExample :: ChartOptions vennExample = mempty - & #charts .~ named "venn" (zipWith (\c x -> PathChart (defaultPathStyle & #borderSize .~ 0.005 & #color .~ palette1a c 0.2 & over #borderColor (set opac' 1)) x) [0 ..] (svgToPathData <$> vennSegs)) - & #hudOptions .~ defaultHudOptions - & #hudOptions % #chartAspect .~ FixedAspect 1 + & set #chartTree (named "venn" (zipWith (\c x -> PathChart (defaultPathStyle & set #borderSize 0.005 & set #color (paletteO c 0.2) & over #borderColor (set opac' 1)) x) [0 ..] (svgToPathData <$> vennSegs))) + & set #hudOptions defaultHudOptions + & set (#markupOptions % #chartAspect) (FixedAspect 1) {- These were originally based on: @@ -271,18 +289,20 @@ pathExample :: ChartOptions pathExample = mempty - & #charts .~ named "path" [path', c0] <> named "pathtext" [t0] - & #hudOptions .~ defaultHudOptions - & #hudOptions % #chartAspect .~ ChartAspect - & #markupOptions % #cssOptions % #preferColorScheme .~ PreferHud - & #markupOptions % #cssOptions % #cssExtra .~ fillSwitch (dark, light) "dark" "pathtext" + & set #chartTree (named "path" [path', c0] <> named "pathtext" [t0]) + & set #hudOptions defaultHudOptions + & set (#hudOptions % #axes % each % #item % #ticks % #glyphTick %? #anchorTo) CanvasStyleSection + & set (#hudOptions % #axes % each % #item % #axisBar %? #anchorTo) CanvasStyleSection + & set (#markupOptions % #chartAspect) ChartAspect + & set (#markupOptions % #cssOptions % #preferColorScheme) PreferHud + & set (#markupOptions % #cssOptions % #cssExtra) (fillSwitch (dark, light) "dark" "pathtext") where ps = [ StartP (Point 0 0), LineP (Point 1 0), CubicP (Point 0.2 0) (Point 0.25 1) (Point 1 1), QuadP (Point (-1) 2) (Point 0 1), - ArcP (ArcInfo (Point 1 1) (-pi / 6) False False) (Point 0 0) + ArcP (ArcInfo (Point 1 1) (-(pi / 6)) False False) (Point 0 0) ] ts = [ "StartP (Point 0 0)", @@ -291,15 +311,15 @@ "QuadP (Point (-1) 2) (Point 0 1)", "ArcP (ArcInfo (Point 1 1) (-pi / 6) False False) (Point 0 0)" ] - path' = PathChart (defaultPathStyle & #color .~ palette1a 0 0.1 & #borderColor .~ palette1a 1 1) ps - c0 = GlyphChart defaultGlyphStyle (pointPath <$> ps) + path' = PathChart (defaultPathStyle & set #color (paletteO 0 0.1) & set #borderColor (paletteO 1 1)) ps + c0 = GlyphChart (defaultGlyphStyle & set #glyphShape SquareGlyph) (pointPath <$> ps) midp = Point 0 0 : zipWith (\(Point x y) (Point x' y') -> Point ((x + x') / 2) ((y + y') / 2)) (drop 1 (pointPath <$> ps)) (pointPath <$> ps) - offp = [Point 0 0.05, Point 0 0, Point (-0.2) 0, Point (-0.1) 0.1, Point 0 (-0.1)] - t0 = TextChart (defaultTextStyle & set #size 0.05) (zip ts (zipWith addp offp midp)) + offp = [Point (-0.35) 0.05, Point 0 0.05, Point (-0.2) 0, Point (-0.1) 0.1, Point 0 (-0.1)] + t0 = TextChart (defaultTextStyle & set #size 0.025) (zip ts (zipWith addp offp midp)) -- | ellipse example -- --- Under scaling, angles are not invariant, and this effects the shape of ellipses and thus SVG arc paths. Compare the effect of aspect changes to the axes of this ellipse: +-- Under scaling, angles are not invariant, and this effects the glyphShape of ellipses and thus SVG arc paths. Compare the effect of aspect changes to the axes of this ellipse: -- -- ![ellipse example](other/ellipse.svg) -- @@ -309,37 +329,39 @@ ellipseExample :: ChartAspect -> ChartOptions ellipseExample a = mempty - & #charts .~ named "ellipse" [ell, ellFull, c0, c1, bbox, xradii, yradii] - & #hudOptions .~ defaultHudOptions - & #hudOptions % #chartAspect .~ a - & #hudOptions % #legends .~ [(10, defaultLegendOptions & #legendCharts .~ lrows & #textStyle % #size .~ 0.2 & #size .~ 0.1)] - & #hudOptions % #titles .~ [(11, defaultTitle "ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True)" & #style % #size .~ 0.08)] + & set #chartTree (named "ellipse" [ell, ellFull, c0, c1, bbox, xradii, yradii]) + & set #hudOptions defaultHudOptions + & set (#markupOptions % #chartAspect) a + & set (#hudOptions % #legends) [Priority 10 (defaultLegendOptions & set #legendCharts lrows & set (#textStyle % #size) 0.2 & set #legendSize 0.1 & set #vgap 0.3)] + & set (#hudOptions % #titles) [Priority 11 (defaultTitleOptions "ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True)" & set (#style % #size) 0.032)] + & set (#hudOptions % #axes % ix 1 % #item % #ticks % #textTick %? #buffer) 0.04 + & set (#hudOptions % #axes % ix 1 % #item % #ticks % #glyphTick %? #buffer) 0.01 where p@(ArcPosition p1 p2 _) = ArcPosition (Point 1 0) (Point 0 1) (ArcInfo (Point 1.5 1) (pi / 3) True True) (ArcCentroid c r phi' ang0' angd) = arcCentroid p ellFull = LineChart fullels [ellipse c r phi' . (\x -> 2 * pi * x / 100.0) <$> [0 .. 100]] ell = LineChart els [ellipse c r phi' . (\x -> ang0' + angd * x / 100.0) <$> [0 .. 100]] - g0 = defaultGlyphStyle & #shape .~ CircleGlyph + g0 = defaultGlyphStyle & set #glyphShape CircleGlyph c0 = GlyphChart g0 [c] - g1 = defaultGlyphStyle & #color .~ palette1a 4 0.2 + g1 = defaultGlyphStyle & set #color (paletteO 4 0.2) & set #glyphShape CircleGlyph c1 = GlyphChart g1 [p1, p2] bbox = RectChart bbs [arcBox p] - bbs = defaultRectStyle & #borderSize .~ 0.002 & #color .~ palette1a 7 0.005 & #borderColor .~ grey 0.5 1 + bbs = defaultRectStyle & set #borderSize 0.002 & set #color (paletteO 7 0.005) & set #borderColor (grey 0.5 1) xradii = LineChart xals [[ellipse c r phi' 0, ellipse c r phi' pi]] yradii = LineChart yals [[ellipse c r phi' (pi / 2), ellipse c r phi' (3 / 2 * pi)]] - xals = defaultLineStyle & #color .~ palette1 6 & #size .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound - yals = defaultLineStyle & #color .~ palette1 5 & #size .~ 0.005 & #dasharray .~ Just [0.03, 0.01] & #linecap .~ Just LineCapRound - fullels = defaultLineStyle & #size .~ 0.002 & #color .~ palette1 1 - els = defaultLineStyle & #size .~ 0.005 & #color .~ palette1 2 + xals = defaultLineStyle & set #color (palette 6) & set #size 0.005 & set #dasharray (Just [0.03, 0.01]) & set #lineCap (Just LineCapRound) + yals = defaultLineStyle & set #color (palette 5) & set #size 0.005 & set #dasharray (Just [0.03, 0.01]) & set #lineCap (Just LineCapRound) + fullels = defaultLineStyle & set #size 0.002 & set #color (palette 1) + els = defaultLineStyle & set #size 0.005 & set #color (palette 2) lrows = second (: []) <$> [ ("Major Axis", LineChart xals [[zero]]), ("Minor Axis", LineChart yals [[zero]]), ("Full Ellipse", LineChart fullels [[zero]]), ("Arc", LineChart els [[zero]]), - ("Centroid", GlyphChart (g0 & #size .~ 0.01) [zero]), - ("Endpoints", GlyphChart (g1 & #size .~ 0.01) [zero]), - ("Bounding Box", RectChart (bbs & #borderSize .~ 0.01) [fmap (2 *) one]) + ("Centroid", GlyphChart (g0 & set #size 0.01 & set #glyphShape SquareGlyph) [zero]), + ("Endpoints", GlyphChart (g1 & set #size 0.01 & set #glyphShape SquareGlyph) [zero]), + ("Bounding Box", RectChart (bbs & set #borderSize 0.01) [fmap (2 *) one]) ] -- | Reproduction of the flag explanation chart in @@ -349,17 +371,18 @@ arcFlagsExample = mempty & set - #charts + #chartTree ( vert 0.02 [ hori 0.02 [colSweep, colSweep2, colLargeFalse, colLargeTrue], rowLarge ] ) - & #hudOptions % #chartAspect .~ ChartAspect - & #markupOptions % #cssOptions % #preferColorScheme .~ PreferHud - & #markupOptions % #cssOptions % #cssExtra - .~ [i| + & set (#markupOptions % #chartAspect) UnscaledAspect + & set (#markupOptions % #cssOptions % #preferColorScheme) PreferHud + & set + (#markupOptions % #cssOptions % #cssExtra) + [i| { .chart g { stroke: #{showRGBA dark}; @@ -380,8 +403,8 @@ where rowLarge = unnamed - [ BlankChart [Rect 0 9 (-2.75) (-3.25)], - TextChart (defaultTextStyle & #size .~ 0.6) [("Large", Point 5.5 (-3.0))] + [ blankChart1 (Rect 0 9 (-2.75) (-3.25)), + TextChart (defaultTextStyle & set #size 0.6) [("Large", Point 5.5 (-3.0))] ] colLargeFalse = vert @@ -389,8 +412,8 @@ [ unnamed (checkFlags False True (set opac' 0.3 dark)), unnamed (checkFlags False False (set opac' 0.3 dark)), unnamed - [ BlankChart [Rect (-1) 2 (-0.25) 0.25], - TextChart (defaultTextStyle & #size .~ 0.4) [("False", Point 0.5 (-0.1))] + [ blankChart1 (Rect (-1) 2 (-0.25) 0.25), + TextChart (defaultTextStyle & set #size 0.4) [("False", Point 0.5 (-0.1))] ] ] colLargeTrue = @@ -399,30 +422,30 @@ [ unnamed (checkFlags True True (set opac' 0.3 dark)), unnamed (checkFlags True False (set opac' 0.3 dark)), unnamed - [ BlankChart [Rect (-1) 2 (-0.25) 0.25], - TextChart (defaultTextStyle & #size .~ 0.4) [("True", Point 0.5 (-0.1))] + [ blankChart1 (Rect (-1) 2 (-0.25) 0.25), + TextChart (defaultTextStyle & set #size 0.4) [("True", Point 0.5 (-0.1))] ] ] colSweep = unnamed - [ BlankChart [Rect (-0.4) 0.4 (-1) 5], + [ blankChart1 (Rect (-0.4) 0.4 (-1) 5), TextChart - (defaultTextStyle & #size .~ 0.6 & #rotation .~ Just (pi / 2)) + (defaultTextStyle & set #size 0.6 & set #rotation (Just (pi / 2))) [("Sweep", Point 0.1 2)] ] colSweep2 = vert 0.02 [ unnamed - [ BlankChart [Rect (-0.25) 0.25 (-1) 2], + [ blankChart1 (Rect (-0.25) 0.25 (-1) 2), TextChart - (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi / 2)) + (defaultTextStyle & set #size 0.4 & set #rotation (Just (pi / 2))) [("True", Point 0.1 0.5)] ], unnamed - [ BlankChart [Rect (-0.25) 0.25 (-1) 2], + [ blankChart1 (Rect (-0.25) 0.25 (-1) 2), TextChart - (defaultTextStyle & #size .~ 0.4 & #rotation .~ Just (pi / 2)) + (defaultTextStyle & set #size 0.4 & set #rotation (Just (pi / 2))) [("False", Point 0.1 0.5)] ] ] @@ -434,10 +457,10 @@ p1 = ArcPosition (Point 0.0 1.0) (Point 1.0 0.0) (ArcInfo (Point 1.0 1.0) 0 large' sweep) ps1 = singletonPie c p1 (ArcCentroid c' r phi' ang0' angd) = arcCentroid p1 - arc1 = PathChart (defaultPathStyle & #color .~ co & #borderColor .~ set opac' 0.5 dark) ps1 - c1 = LineChart (defaultLineStyle & #size .~ 0.02 & #color .~ set opac' 0.2 dark) [ellipse (Point 1.0 1.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]] - c2 = LineChart (defaultLineStyle & #size .~ 0.02 & #color .~ set opac' 0.2 dark) [ellipse (Point 0.0 0.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]] - ell = LineChart (defaultLineStyle & #size .~ 0.05 & #color .~ set opac' 0.5 co) [ellipse c' r phi' . (\x -> ang0' + angd * x / 100.0) <$> [0 .. 100]] + arc1 = PathChart (defaultPathStyle & set #color co & set #borderColor (set opac' 0.5 dark)) ps1 + c1 = LineChart (defaultLineStyle & set #size 0.02 & set #color (set opac' 0.2 dark)) [ellipse (Point 1.0 1.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]] + c2 = LineChart (defaultLineStyle & set #size 0.02 & set #color (set opac' 0.2 dark)) [ellipse (Point 0.0 0.0) (Point 1.0 1.0) 0 . (\x -> 0 + 2 * pi * x / 100.0) <$> [0 .. 100]] + ell = LineChart (defaultLineStyle & set #size 0.05 & set #color (set opac' 0.5 co)) [ellipse c' r phi' . (\x -> ang0' + angd * x / 100.0) <$> [0 .. 100]] -- | quad example -- @@ -445,30 +468,32 @@ quadExample :: ChartOptions quadExample = mempty - & #charts .~ named "quad" [path', curve, c0, c1, bbox] - & #hudOptions .~ defaultHudOptions - & #hudOptions % #chartAspect .~ FixedAspect 1.5 - & #hudOptions % #legends .~ [(10, defaultLegendOptions & #legendCharts .~ lrows & #textStyle % #size .~ 0.2 & #size .~ 0.2)] - & #hudOptions % #titles .~ [(11, defaultTitle "QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))" & #style % #size .~ 0.08)] + & set #chartTree (named "quad" [path', curve, c0, c1, bbox]) + & set #hudOptions defaultHudOptions + & set (#markupOptions % #chartAspect) (FixedAspect 1.5) + & set (#hudOptions % #legends) [Priority 10 (defaultLegendOptions & set #legendCharts lrows & set (#textStyle % #size) 0.2 & set #legendSize 0.2 & set #vgap 0.3)] + & set (#hudOptions % #titles) [Priority 11 (defaultTitleOptions "QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))" & set (#style % #size) 0.03)] + & set (#hudOptions % #axes % ix 1 % #item % #ticks % #textTick %? #buffer) 0.04 + & set (#hudOptions % #axes % ix 1 % #item % #ticks % #glyphTick %? #buffer) 0.01 where p@(QuadPosition start end control) = QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1)) ps = singletonQuad p path' = PathChart pathStyle ps curve = LineChart curveStyle [quadBezier p . (/ 100.0) <$> [0 .. 100]] - curveStyle = defaultLineStyle & #size .~ 0.002 & #color .~ palette1 1 - c0 = GlyphChart defaultGlyphStyle [start, end] - c1 = GlyphChart controlStyle [control] + curveStyle = defaultLineStyle & set #size 0.002 & set #color (palette 1) + c0 = GlyphChart (defaultGlyphStyle & set #glyphShape SquareGlyph) [start, end] + c1 = GlyphChart (controlStyle & set #glyphShape CircleGlyph) [control] bbox = RectChart bbs [quadBox p] - bbs = defaultRectStyle & #borderSize .~ 0.002 & #color .~ palette1a 0 0.05 & #borderColor .~ grey 0.4 1 - pathStyle = defaultPathStyle & #color .~ palette1a 2 0.2 & #borderColor .~ transparent - controlStyle = defaultGlyphStyle & #shape .~ CircleGlyph + bbs = defaultRectStyle & set #borderSize 0.002 & set #color (paletteO 0 0.05) & set #borderColor (grey 0.4 1) + pathStyle = defaultPathStyle & set #color (paletteO 2 0.2) & set #borderColor transparent + controlStyle = defaultGlyphStyle & set #glyphShape CircleGlyph lrows = second (: []) <$> [ ("Path Fill", PathChart pathStyle [StartP zero]), ("Path Chord", LineChart curveStyle [[zero]]), - ("Path Endpoints", GlyphChart defaultGlyphStyle [zero]), - ("Path Control Point", GlyphChart controlStyle [zero]), - ("Bounding Box", RectChart (bbs & #borderSize .~ 0.01) [one]) + ("Path Endpoints", GlyphChart (defaultGlyphStyle & set #glyphShape SquareGlyph) [zero]), + ("Path Control Point", GlyphChart (controlStyle & set #glyphShape CircleGlyph) [zero]), + ("Bounding Box", RectChart (bbs & set #borderSize 0.01) [one]) ] -- | cubic example @@ -477,30 +502,30 @@ cubicExample :: ChartOptions cubicExample = mempty - & #charts .~ named "cubic" [path', curve, c0, c1, bbox] - & #hudOptions .~ mempty - & #hudOptions % #chartAspect .~ FixedAspect 1.5 - & #hudOptions % #legends .~ [(10, defaultLegendOptions & #legendCharts .~ lrows & #textStyle % #size .~ 0.2 & #size .~ 0.2)] - & #hudOptions % #titles .~ [(11, defaultTitle "CubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1)" & #style % #size .~ 0.08)] + & set #chartTree (named "cubic" [path', curve, c0, c1, bbox]) + & set #hudOptions mempty + & set (#markupOptions % #chartAspect) (FixedAspect 1.5) + & set (#hudOptions % #legends) [Priority 10 (defaultLegendOptions & set #legendCharts lrows & set (#textStyle % #size) 0.2 & set #legendSize 0.2 & set #vgap 0.3)] + & set (#hudOptions % #titles) [Priority 11 (defaultTitleOptions "CubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1)" & set (#style % #size) 0.03)] where p@(CubicPosition start end control1 control2) = CubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1) ps = singletonCubic p path' = PathChart pathStyle ps curve = LineChart curveStyle [cubicBezier p . (/ 100.0) <$> [0 .. 100]] - c0 = GlyphChart defaultGlyphStyle [start, end] - c1 = GlyphChart controlStyle [control1, control2] + c0 = GlyphChart (defaultGlyphStyle & set #glyphShape SquareGlyph) [start, end] + c1 = GlyphChart (controlStyle & set #glyphShape CircleGlyph) [control1, control2] bbox = RectChart bbs [cubicBox p] - bbs = defaultRectStyle & #borderSize .~ 0.002 & #color .~ palette1a 0 0.05 & #borderColor .~ grey 0.4 1 - pathStyle = defaultPathStyle & #color .~ palette1a 3 0.2 & #borderColor .~ transparent - controlStyle = defaultGlyphStyle & #shape .~ CircleGlyph - curveStyle = defaultLineStyle & #size .~ 0.002 & #color .~ palette1 7 + bbs = defaultRectStyle & set #borderSize 0.002 & set #color (paletteO 0 0.05) & set #borderColor (grey 0.4 1) + pathStyle = defaultPathStyle & set #color (paletteO 3 0.2) & set #borderColor transparent + controlStyle = defaultGlyphStyle + curveStyle = defaultLineStyle & set #size 0.002 & set #color (palette 7) lrows = second (: []) <$> [ ("Path Fill", PathChart pathStyle [StartP zero]), ("Path Chord", LineChart curveStyle [[zero]]), - ("Path Endpoints", GlyphChart defaultGlyphStyle [zero]), - ("Path Control Point", GlyphChart controlStyle [zero]), - ("Bounding Box", RectChart (bbs & #borderSize .~ 0.01) [one]) + ("Path Endpoints", GlyphChart (defaultGlyphStyle & set #glyphShape SquareGlyph) [zero]), + ("Path Control Point", GlyphChart (controlStyle & set #glyphShape CircleGlyph) [zero]), + ("Bounding Box", RectChart (bbs & set #borderSize 0.01) [one]) ] -- | The common way to create a surface chart (or contour chart or heat map) is usually a grid over a function, a process reified in 'surfacef'. @@ -509,24 +534,16 @@ -- -- ![surface example](other/surface.svg) surfaceExample :: ChartOptions -surfaceExample = - mempty - & #charts .~ named "surface" cs - & #markupOptions .~ (defaultMarkupOptions & #cssOptions % #shapeRendering .~ UseCssCrisp) +surfaceExample = mempty & set #chartTree cs' & set #markupOptions (defaultMarkupOptions & set (#cssOptions % #shapeRendering) UseCssCrisp) where - -- FIXME: surface legends are broken as. - -- & #hudOptions % #legends .~ [(30,defaultLegendOptions & #legendCharts .~ [("", foldOf charts' $ surfaceLegendChart rangef (defaultSurfaceLegendOptions dark "text"))])] - - grain = Point 100 100 + grain = Point 20 20 r = one f = fst . bimap ((-1.0) *) (fmap ((-1.0) *)) . rosenbrock 1 10 - evenColors = trimColour . over lightness' (const 0.55) . palette1 <$> [0 .. 5] - (cs, _) = surfacef f so - so = - defaultSurfaceOptions - & #soGrain .~ grain - & #soRange .~ r - & #soStyle % #surfaceColors .~ evenColors + evenColors = trimColour . over lightness' (const 0.55) . palette <$> [0 .. 5] + so = defaultSurfaceOptions & set #soGrain grain & set #soRange r & set (#soStyle % #surfaceColors) evenColors + (cs, rangef) = surfacef f so + slo = defaultSurfaceLegendOptions & set (#sloSurfaceStyle % #surfaceColors) evenColors & set #sloDataRange rangef + cs' = addSurfaceLegend slo (unnamed cs) -- | arrow example -- @@ -536,11 +553,12 @@ arrowExample :: ChartOptions arrowExample = mempty - & #hudOptions .~ (defaultHudOptions & #axes %~ fmap (second (#ticks % #ltick .~ Nothing))) - & #charts .~ named "arrow" ((\p -> gchart (tail' . f $ p) (angle . f $ p) p) <$> ps) - & #markupOptions % #cssOptions % #preferColorScheme .~ PreferHud - & #markupOptions % #cssOptions % #cssExtra - .~ [i| + & set #hudOptions (defaultHudOptions & set (#axes % each % #item % #ticks % #lineTick) Nothing) + & set #chartTree (named "arrow" ((\p -> gchart (tail' . f $ p) (angle . f $ p) p) <$> ps)) + & set (#markupOptions % #cssOptions % #preferColorScheme) PreferHud + & set + (#markupOptions % #cssOptions % #cssExtra) + [i| { .arrow g { fill: #{showRGBA dark}; @@ -557,14 +575,14 @@ where f = snd . bimap ((-1.0) *) (fmap ((-1.0) *)) . rosenbrock 1 10 ps = grid MidPos (one :: Rect Double) (Point 10 10 :: Point Int) :: [Point Double] - arrow = PathGlyph "M -1 0 L 1 0 M 1 0 L 0.4 0.3 M 1 0 L 0.4 -0.3" NoScaleBorder + arrow = PathGlyph "M -1 0 L 1 0 M 1 0 L 0.4 0.3 M 1 0 L 0.4 -0.3" gs s r' = defaultGlyphStyle - & #borderSize .~ 0.05 - & #size .~ s - & #borderColor .~ dark - & #rotation .~ Just r' - & #shape .~ arrow + & set #borderSize 0.05 + & set #size s + & set #borderColor dark + & set #rotation (Just r') + & set #glyphShape arrow gchart s r' p = GlyphChart (gs s r') [p] tail' :: Point Double -> Double @@ -580,7 +598,7 @@ -- > f'y = 2 * b * y - 2 * b * x^2 -- > f a b (Point x y) = (a^2 - 2ax + x^2 + b * y^2 - b * 2 * y * x^2 + b * x^4, Point (-2a + 2 * x - b * 4 * y * x + 4 * b * x ^ 3), 2 * b * y - 2 * b * x^2) rosenbrock :: Double -> Double -> Point Double -> (Double, Point Double) -rosenbrock a b (Point x y) = (a ** 2 - 2 * a * x + x ** 2 + b * y ** 2 - b * 2 * y * x ** 2 + b * x ** 4, Point (-2 * a + 2 * x - b * 4 * y * x + 4 * b * x ** 3) (2 * b * y - 2 * b * x ** 2)) +rosenbrock a b (Point x y) = (a ** 2 - 2 * a * x + x ** 2 + b * y ** 2 - b * 2 * y * x ** 2 + b * x ** 4, Point ((-2) * a + 2 * x - b * 4 * y * x + 4 * b * x ** 3) (2 * b * y - 2 * b * x ** 2)) -- | date example -- @@ -590,15 +608,10 @@ dateExample :: ChartOptions dateExample = mempty - & #charts .~ blank (Rect 0 1 0 1) - & #hudOptions - .~ ( mempty - & #chartAspect .~ FixedAspect 1.5 - & #axes - .~ [ (defaultPriority, defaultAxisOptions & #place .~ PlaceLeft & #ticks % #style .~ TickPlaced tsTime), - (defaultPriority, defaultAxisOptions & #ticks % #style .~ TickPlaced tsDate) - ] - ) + & set #chartTree (blank (Rect 0 1 0 1)) + & set (#markupOptions % #chartAspect) (FixedAspect 1.5) + & over (#hudOptions % #frames) (<> [Priority 100 (defaultFrameOptions & set #buffer 0.05)]) + & set (#hudOptions % #axes) [Priority 5 (defaultYAxisOptions & set (#ticks % #tick) (TickPlaced tsTime)), Priority 6 (defaultXAxisOptions & set (#ticks % #tick) (TickPlaced tsDate))] where tsTime = placedTimeLabelContinuous PosIncludeBoundaries Nothing 12 (Range (UTCTime (fromGregorian 2021 12 6) (toDiffTime 0)) (UTCTime (fromGregorian 2021 12 7) (toDiffTime 0))) tsDate = placedTimeLabelContinuous PosIncludeBoundaries (Just (Text.pack "%d %b")) 2 (Range (UTCTime (fromGregorian 2021 12 6) (toDiffTime 0)) (UTCTime (fromGregorian 2022 3 13) (toDiffTime 0))) @@ -612,13 +625,13 @@ gradientExample = gradient (Just (orig / 360)) 100 6 100 c0 c1 where ok = LCHA 0.5 0.12 127 1 - c0 = ok & lch' % hLCH' .~ 0.001 - c1 = ok & lch' % hLCH' .~ 360 + c0 = ok & set (lch' % hLCH') 0.001 + c1 = ok & set (lch' % hLCH') 360 orig = view (lch' % hLCH') ok gradientChart_ :: Int -> LCHA -> LCHA -> [Chart] gradientChart_ grain c0 c1 = - (\(r, c) -> RectChart (defaultRectStyle & #color .~ c & #borderSize .~ 0) [r]) + (\(r, c) -> RectChart (defaultRectStyle & set #color c & set #borderSize 0) [r]) . (\x -> (Rect x (x + d) 0 1, view lcha2colour' (mixLCHA x c0 c1))) <$> grid LowerPos (Range 0 1) grain where @@ -627,17 +640,15 @@ gradient :: Maybe Double -> Double -> Double -> Int -> LCHA -> LCHA -> ChartOptions gradient marker h fa grain ok0 ok1 = mempty - & #markupOptions % #markupHeight - .~ h - & #markupOptions % #cssOptions % #shapeRendering - .~ UseCssCrisp - & #hudOptions - .~ ( mempty - & #chartAspect .~ FixedAspect fa - & #frames .~ [(Priority 1, FrameOptions (Just (border 0.004 white)) 0.1)] - ) - & #charts - .~ named "gradient" (gradientChart_ grain ok0 ok1) <> strip + & set (#markupOptions % #markupHeight) (Just h) + & set (#markupOptions % #cssOptions % #shapeRendering) UseCssCrisp + & set (#markupOptions % #chartAspect) (FixedAspect fa) + & set + #hudOptions + ( mempty + & set #frames [Priority 1 (FrameOptions (Just (border 0.004 white)) CanvasStyleSection 0.1)] + ) + & set #chartTree (named "gradient" (gradientChart_ grain ok0 ok1) <> strip) where strip = case marker of Nothing -> mempty @@ -647,13 +658,13 @@ [borderStrip 0.02 light (Rect (marker' - 0.02) (marker' + 0.02) (-0.1) 1.1)] borderStrip :: Double -> Colour -> Rect Double -> Chart -borderStrip w c r = RectChart (defaultRectStyle & #color .~ transparent & #borderSize .~ w & #borderColor .~ c) [r] +borderStrip w c r = RectChart (defaultRectStyle & set #color transparent & set #borderSize w & set #borderColor c) [r] --- | Color wheel displaying palette1 choices +-- | Color wheel displaying palette choices -- --- -- ![wheel example](other/wheel.svg) +-- ![wheel example](other/wheel.svg) wheelExample :: ChartOptions -wheelExample = dotMap 0.01 50 0.5 0.5 (palette1 <$> [0 .. 7]) +wheelExample = dotMap 0.01 50 0.5 0.5 (palette <$> [0 .. 7]) -- | The dotMap -- @@ -661,26 +672,11 @@ dotMap :: Double -> Int -> Double -> Double -> [Colour] -> ChartOptions dotMap s grain l maxchroma cs = mempty - & #hudOptions - .~ defaultHudOptions - & #charts - .~ named "dots" (dot_ <$> cs) - <> named - "wheel" - ( ( \(p, c) -> - GlyphChart - ( defaultGlyphStyle - & #size .~ s - & #color .~ c - & #borderSize .~ 0 - ) - [p] - ) - <$> filter (validColour . snd) (wheelPoints grain l maxchroma) - ) + & set #hudOptions defaultHudOptions + & set #chartTree (named "dots" (dot_ <$> cs) <> named "wheel" ((\(p, c) -> GlyphChart (defaultGlyphStyle & set #size s & set #color c & set #borderSize 0 & set #glyphShape CircleGlyph) [p]) <$> filter (validColour . snd) (wheelPoints grain l maxchroma))) dot_ :: Colour -> Chart -dot_ x = (\(p, c) -> GlyphChart (defaultGlyphStyle & #size .~ 0.08 & #color .~ c & #borderColor .~ Colour 0.5 0.5 0.5 1 & #shape .~ CircleGlyph) [p]) (colour2Point x, x) +dot_ x = (\(p, c) -> GlyphChart (defaultGlyphStyle & set #size 0.08 & set #color c & set #borderColor (Colour 0.5 0.5 0.5 1) & set #glyphShape CircleGlyph) [p]) (colour2Point x, x) where colour2Point c = review lcha2colour' c & (\(LCHA _ ch h _) -> uncurry Point (review xy2ch' (ch, h))) @@ -691,18 +687,36 @@ -- | Adding reference points and bounding boxes to visualize chart alignment for use in debugging charts. -- --- -- ![debug example](other/debug.svg) +-- ![debug example](other/debug.svg) debugExample :: ChartOptions -> ChartOptions debugExample cs = mempty & set #markupOptions (view #markupOptions cs) - & set (#hudOptions % #chartAspect) (view (#hudOptions % #chartAspect) cs) - & set #charts (e1 <> e2 <> e3) + & set (#markupOptions % #chartAspect) asp + & set #chartTree (e1 <> e2 <> e3) where - e1 = addHud (view #hudOptions cs) (view #charts cs) - e2 = glyphize (defaultGlyphStyle & #size .~ 0.01 & #shape .~ CircleGlyph) e1 - e3 = rectangularize (defaultRectStyle & #borderColor .~ dark & #borderSize .~ 0.001 & #color % opac' .~ 0.05) e1 + asp = view (#markupOptions % #chartAspect) cs + e1 = view #chartTree (forgetHud cs) + e2 = glyphize (defaultGlyphStyle & set #size 0.01 & set #glyphShape CircleGlyph) e1 + e3 = rectangularize (defaultRectStyle & set #borderColor dark & set #borderSize 0.001 & set (#color % opac') 0.05) e1 +-- | A merge of two rect charts with different data ranges. +-- +-- ![compound example](other/compound.svg) +compoundExample :: ChartOptions +compoundExample = compoundMerge [c1, c2] + where + ho1 = (mempty :: HudOptions) & set #titles [Priority 3 (defaultTitleOptions "chart1")] & set #axes [Priority 2 defaultXAxisOptions, Priority 2 defaultYAxisOptions] & colourHudOptions (const (palette 0)) + c1 = (mempty :: ChartOptions) & set #hudOptions ho1 & set #chartTree (named "c1" [Chart defaultRectStyle (RectData [fmap (2 *) one])]) + ho2 = (mempty :: HudOptions) & set #titles [Priority 3.1 (defaultTitleOptions "chart2")] & set #axes [Priority 2 (defaultXAxisOptions & set #place PlaceTop), Priority 2 (defaultYAxisOptions & set #place PlaceRight)] & colourHudOptions (const (palette 3)) + c2 = (mempty :: ChartOptions) & set #hudOptions ho2 & set #chartTree (named "c2" [Chart (blob (set opac' 0.3 $ palette 3)) (RectData [fmap (* 0.8) one]), BlankChart defaultStyle [one]]) + +-- | Usage of stack. +-- +-- ![stack example](other/stack.svg) +stackExample :: ChartOptions +stackExample = mempty & set #chartTree (stack 5 0.1 (replicate 25 (view #chartTree $ forgetHud lineExample))) + -- | All the examples and the associated filepaths pathChartOptions :: [(FilePath, ChartOptions)] pathChartOptions = @@ -719,7 +733,7 @@ ("other/venn.svg", vennExample), ("other/path.svg", pathExample), ("other/arcflags.svg", arcFlagsExample), - ("other/ellipse.svg", ellipseExample (FixedAspect 1.7)), + ("other/ellipse.svg", ellipseExample (FixedAspect 1.5)), ("other/ellipse2.svg", ellipseExample (FixedAspect 2)), ("other/quad.svg", quadExample), ("other/cubic.svg", cubicExample), @@ -729,7 +743,9 @@ ("other/wheel.svg", wheelExample), ("other/debug.svg", debugExample lineExample), ("other/priorityv1.svg", priorityv1Example), - ("other/priorityv2.svg", priorityv2Example) + ("other/priorityv2.svg", priorityv2Example), + ("other/compound.svg", compoundExample), + ("other/stack.svg", stackExample) ] -- | Run this to refresh example SVG's. @@ -747,8 +763,8 @@ ((<> "d.svg") . reverse . drop 4 . reverse) ( \x -> x - & #hudOptions %~ colourHudOptions (rgb light) - & #markupOptions % #cssOptions % #preferColorScheme .~ PreferDark + & over #hudOptions (colourHudOptions (rgb light)) + & set (#markupOptions % #cssOptions % #preferColorScheme) PreferDark ) ) pathChartOptions diff --git a/src/Chart/Hud.hs b/src/Chart/Hud.hs --- a/src/Chart/Hud.hs +++ b/src/Chart/Hud.hs @@ -1,1144 +1,1129 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} - --- | A hud stands for , and is a collective noun used to name chart elements that assist in data interpretation or otherwise annotate and decorate data. --- --- This includes axes, titles, borders, frames, background canvaii, tick marks and tick value labels. -module Chart.Hud - ( -- * Hud - Hud (..), - Priority (..), - defaultPriority, - HudBox, - CanvasBox, - DataBox, - HudChart (..), - canvasBox', - canvasStyleBox', - hudBox', - hudStyleBox', - - -- * Hud Processing - runHudWith, - runHud, - - -- * HudOptions - HudOptions (..), - defaultHudOptions, - addHud, - initialCanvas, - colourHudOptions, - toHuds, - - -- * Hud Effects - closes, - fromEffect, - applyChartAspect, - getHudBox, - - -- * Hud primitives - AxisOptions (..), - defaultAxisOptions, - flipAxis, - FrameOptions (..), - defaultFrameOptions, - Place (..), - placeText, - AxisBar (..), - defaultAxisBar, - Title (..), - defaultTitle, - Ticks (..), - defaultGlyphTick, - defaultTextTick, - defaultLineTick, - defaultTicks, - TickStyle (..), - defaultTickStyle, - tickStyleText, - TickExtend (..), - adjustTicks, - Adjustments (..), - defaultAdjustments, - LegendOptions (..), - defaultLegendOptions, - - -- * Option to Hud - frameHud, - legend, - legendHud, - legendFrame, - ) -where - -import Chart.Data -import Chart.Primitive -import Chart.Style -import Control.Monad.State.Lazy -import Data.Bifunctor -import Data.Bool -import Data.Colour -import Data.Foldable hiding (sum) -import Data.FormatN -import Data.List qualified as List -import Data.Maybe -import Data.Path -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Tuple -import GHC.Generics hiding (to) -import NumHask.Prelude qualified as NH -import Optics.Core -import Prelude - --- $setup --- --- >>> :set -XOverloadedLabels --- >>> :set -XOverloadedStrings --- >>> import Chart --- >>> import Optics.Core - --- * Hud - --- | The priority of a Hud element or transformation, lower value means higher priority. --- --- Lower priority (higher values) huds will tend to be placed on the outside of a chart. --- --- Hud elements are rendered in order from high to low priority and the positioning of hud elements can depend on the positioning of elements that have already been included. Equal priority values will be placed in the same process step. --- --- The first example below, based in 'Chart.Examples.lineExample' but with the legend placed on the right and coloured frames to help accentuate effects, includes (in order of priority): --- --- - an inner frame, representing the core data area of the chart (Priority 1) --- --- - the axes (defaultPriority (5)) --- --- - the titles (Priority 12) --- --- - the legend (Priority 50) --- --- - an outer frame which is transparent and used to pad out the chart (Priority 100). --- --- > priorityv1Example = lineExample & (#hudOptions % #frames) .~ [(1, FrameOptions (Just defaultRectStyle) 0), (100, FrameOptions (Just (defaultRectStyle & #color .~ (palette1 4 & opac' .~ 0.05) & #borderColor .~ palette1 4)) 0.1)] & #hudOptions % #legends %~ fmap (first (const (Priority 50))) & #hudOptions % #legends %~ fmap (second (set #place PlaceRight)) --- --- ![priorityv1 example](other/priorityv1.svg) --- --- The second variation below drops the title priorities to below the legend: --- --- > priorityv2Example = priorityv1Example & #hudOptions % #titles %~ fmap (first (const (Priority 51))) --- --- ![priorityv2 example](other/priorityv2.svg) -newtype Priority = Priority {priority :: Double} deriving (Eq, Ord, Show, Generic) - -instance Num Priority where - (*) (Priority a) (Priority b) = Priority (a * b) - (+) (Priority a) (Priority b) = Priority (a + b) - negate (Priority a) = Priority (negate a) - abs (Priority a) = Priority (Prelude.abs a) - signum (Priority a) = Priority (signum a) - fromInteger x = Priority (fromInteger x) - -instance Fractional Priority where - fromRational x = Priority (fromRational x) - recip (Priority x) = Priority (recip x) - --- | An arbitrary 5.0 --- --- >>> defaultPriority --- Priority {priority = 5.0} -defaultPriority :: Priority -defaultPriority = Priority 5.0 - --- | Heads-up display additions to charts --- --- A Hud is composed of: --- --- - A priority for the hud element in the chart folding process. --- --- - A chart tree with a state dependency on the chart being created. -data Hud = Hud - { -- | priority for ordering of transformations - priority :: Priority, - -- | additional charts - hud :: State HudChart ChartTree - } - deriving (Generic) - --- | Type to track the split of Chart elements into Hud and Canvas --- --- - charts: charts that form the canvas or data elements of the chart; the rectangular dimension which is considered to be the data representation space. --- --- - hud: charts that form the Hud. --- --- - dataBox: The bounding box of the underlying data domain. --- --- This is done to support functionality where we can choose whether to normalise the chart aspect based on the entire chart (FixedAspect) or on just the data visualisation space (CanvasAspect). -data HudChart = HudChart - { chart :: ChartTree, - hud :: ChartTree, - dataBox :: DataBox - } - deriving (Eq, Show, Generic) - --- | A type for Rect to represent the entire bounding box of a chart, including the Hud -type HudBox = Rect Double - --- | A type for Rect to represent the bounding box of the canvas portion of a chart, excluding Hud elements -type CanvasBox = Rect Double - --- | A type for Rect to represent the bounding box of the data elements a chart, which can be a different metric to Canvas and Hud Rects -type DataBox = Rect Double - -canvasBox_ :: HudChart -> Maybe CanvasBox -canvasBox_ = boxes . foldOf (#chart % charts') - -canvasRebox_ :: HudChart -> Maybe (Rect Double) -> HudChart -canvasRebox_ cs r = - cs - & over (#chart % chart') (maybeProjectWith r (canvasBox_ cs)) - & over (#hud % chart') (maybeProjectWith r (canvasBox_ cs)) - --- | A lens between a HudChart and the bounding box of the canvas -canvasBox' :: Lens' HudChart (Maybe CanvasBox) -canvasBox' = - lens canvasBox_ canvasRebox_ - --- | A lens between a HudChart and the bounding box of the canvas, including style extensions. -canvasStyleBox' :: Getter HudChart (Maybe CanvasBox) -canvasStyleBox' = to (styleBoxes . foldOf (#chart % charts')) - -hudStyleBox_ :: HudChart -> Maybe HudBox -hudStyleBox_ = styleBoxes . (\x -> foldOf (#chart % charts') x <> foldOf (#hud % charts') x) - --- | a lens between a HudChart and the bounding box of the hud. -hudStyleBox' :: Getter HudChart (Maybe HudBox) -hudStyleBox' = to hudStyleBox_ - -hudBox_ :: HudChart -> Maybe HudBox -hudBox_ = boxes . (\x -> foldOf (#chart % charts') x <> foldOf (#hud % charts') x) - -hudRebox_ :: HudChart -> Maybe HudBox -> HudChart -hudRebox_ cs r = - cs - & over #chart (over chart' (maybeProjectWith r' (hudBox_ cs))) - & over #hud (over chart' (maybeProjectWith r' (hudBox_ cs))) - where - r' = (NH.-) <$> r <*> ((NH.-) <$> hudStyleBox_ cs <*> hudBox_ cs) - --- | lens between a HudChart and its hud bounding box, not including style. -hudBox' :: Lens' HudChart (Maybe HudBox) -hudBox' = - lens hudBox_ hudRebox_ - -appendHud :: ChartTree -> HudChart -> HudChart -appendHud cs x = - x & over #hud (<> cs) - --- | Absorb a series of state-dependent tress into state. -closes :: (Traversable f) => f (State HudChart ChartTree) -> State HudChart () -closes xs = do - xs' <- fmap (mconcat . toList) $ sequence xs - modify (appendHud xs') - --- | Wrap a state effect into a Hud -fromEffect :: Priority -> State HudChart () -> Hud -fromEffect p s = Hud p (s >> pure mempty) - --- | Apply a ChartAspect -applyChartAspect :: ChartAspect -> State HudChart () -applyChartAspect fa = do - hc <- get - case fa of - ChartAspect -> pure () - _ -> modify (set hudBox' (getHudBox fa hc)) - --- | Supply the bounding box of the HudChart given a ChartAspect. -getHudBox :: ChartAspect -> HudChart -> Maybe HudBox -getHudBox fa c = - case fa of - FixedAspect a -> Just (aspect a) - CanvasAspect a -> - case (view hudBox' c, view canvasBox' c) of - (Nothing, _) -> Nothing - (_, Nothing) -> Nothing - (Just hb, Just cb) -> Just (aspect (a * ratio hb / ratio cb)) - ChartAspect -> view hudBox' c - --- | Combine huds and charts to form a new Chart using the supplied initial canvas and data dimensions. Note that chart data is transformed by this computation (a linear type might be useful here). -runHudWith :: - -- | initial canvas - CanvasBox -> - -- | initial data space - DataBox -> - -- | huds to add - [Hud] -> - -- | underlying chart - ChartTree -> - -- | integrated chart tree - ChartTree -runHudWith cb db hs cs = - hs - & List.sortOn (view #priority) - & List.groupBy (\a b -> view #priority a == view #priority b) - & mapM_ (closes . fmap (view #hud)) - & flip - execState - ( HudChart - (cs & over chart' (projectWith cb db)) - mempty - db - ) - & (\x -> group (Just "chart") [view #chart x] <> group (Just "hud") [view #hud x]) - --- | Combine huds and charts to form a new ChartTree with a supplied initial canvas dimension. --- --- Note that the original chart data are transformed and irrevocably forgotten by this computation. -runHud :: - -- | initial canvas dimension - CanvasBox -> - -- | huds - [Hud] -> - -- | underlying charts - ChartTree -> - -- | integrated chart list - ChartTree -runHud ca hs cs = runHudWith ca (singletonGuard $ boxes (foldOf charts' cs)) hs cs - --- | Typical, configurable hud elements. Anything else can be hand-coded as a 'Hud'. --- --- ![hud example](other/hudoptions.svg) -data HudOptions = HudOptions - { chartAspect :: ChartAspect, - axes :: [(Priority, AxisOptions)], - frames :: [(Priority, FrameOptions)], - legends :: [(Priority, LegendOptions)], - titles :: [(Priority, Title)] - } - deriving (Eq, Show, Generic) - -instance Semigroup HudOptions where - (<>) (HudOptions _ a c l t) (HudOptions asp a' c' l' t') = - HudOptions asp (a <> a') (c <> c') (l <> l') (t <> t') - -instance Monoid HudOptions where - mempty = HudOptions (FixedAspect 1.5) [] [] [] [] - --- | The official hud options. --- --- - A fixed chart aspect (width:height) of 1.5 --- --- - An x axis at the bottom and y axis at the left. --- --- - The default tick style for each axis of an axis bar, tick glyphs (or marks), automated tick labels, and tick (or grid) lines. --- --- - A high 'Priority' (and thus inner), low-opacity frame, representing the data area of the chart. --- --- - A low priority (outer), transparent frame, providing some padding around the chart. -defaultHudOptions :: HudOptions -defaultHudOptions = - HudOptions - (FixedAspect 1.5) - [ (5, defaultAxisOptions), - (5, defaultAxisOptions & set #place PlaceLeft) - ] - [ (1, defaultFrameOptions), - (20, defaultFrameOptions & #buffer .~ 0.04) - ] - [] - [] - --- | Decorate a ChartTree with HudOptions -addHud :: HudOptions -> ChartTree -> ChartTree -addHud ho cs = - runHudWith - (initialCanvas (view #chartAspect ho) cs) - db' - hs - (cs <> blank db') - where - (hs, db') = toHuds ho (singletonGuard $ view box' cs) - --- | The initial canvas before applying Huds --- --- >>> initialCanvas (FixedAspect 1.5) (unnamed [RectChart defaultRectStyle [one]]) --- Rect -0.75 0.75 -0.5 0.5 -initialCanvas :: ChartAspect -> ChartTree -> Rect Double -initialCanvas (FixedAspect a) _ = aspect a -initialCanvas (CanvasAspect a) _ = aspect a -initialCanvas ChartAspect cs = singletonGuard $ view box' cs - -priorities :: HudOptions -> [Priority] -priorities o = - (fst <$> view #axes o) - <> (fst <$> view #frames o) - <> (fst <$> view #legends o) - <> (fst <$> view #titles o) - -lastPriority :: HudOptions -> Priority -lastPriority o = case priorities o of - [] -> 0 - xs -> maximum xs - --- | Make Huds and potential data box extension; from a HudOption and an initial data box. -toHuds :: HudOptions -> DataBox -> ([Hud], DataBox) -toHuds o db = - (,db''') $ - (as' & fmap (uncurry Hud . second axis)) - <> (view #frames o & fmap (uncurry Hud . second frameHud)) - <> (view #legends o & fmap (uncurry Hud . second legend)) - <> (view #titles o & fmap (uncurry Hud . second title)) - <> [ fromEffect (lastPriority o + 1) $ - applyChartAspect (view #chartAspect o) - ] - where - (as', db''') = - foldr - ( \a (as, db') -> - let (db'', a') = freezeTicks db' (snd a) - in (as <> [(fst a, a')], db'') - ) - ([], db) - (view #axes o) - -freezeTicks :: DataBox -> AxisOptions -> (DataBox, AxisOptions) -freezeTicks db a = - bimap - (\x -> placeRect (view #place a) x db) - (\x -> a & set (#ticks % #style) x) - (toTickPlaced (placeRange (view #place a) db) (view (#ticks % #style) a)) - --- | compute tick components given style, ranges and formatting -makePlacedTicks :: TickStyle -> Range Double -> ([(Double, Text)], Maybe (Range Double)) -makePlacedTicks s r = - case s of - TickNone -> ([], Nothing) - TickRound f n e -> - ( zip - ticks0 - (formatNs f ticks0), - bool (space1 ticks0) Nothing (e == NoTickExtend) - ) - where - ticks0 = gridSensible OuterPos (e == NoTickExtend) r n - TickExact f n -> (zip ticks0 (formatNs f ticks0), Nothing) - where - ticks0 = grid OuterPos r n - TickLabels ls -> - ( zip - ( project (Range 0 (fromIntegral $ length ls)) r - <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) - ) - ls, - Nothing - ) - TickPlaced xs -> (xs, Nothing) - -toTickPlaced :: Range Double -> TickStyle -> (Range Double, TickStyle) -toTickPlaced r t@TickRound {} = (fromMaybe r ext, TickPlaced ts) - where - (ts, ext) = makePlacedTicks t r -toTickPlaced r t = (r, t) - -placeRect :: Place -> Range Double -> Rect Double -> Rect Double -placeRect 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 - -placeRange :: Place -> HudBox -> 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 == PlaceTop || pl == PlaceBottom = Point x 0 - | otherwise = Point 0 x - -axis :: AxisOptions -> State HudChart ChartTree -axis a = do - t <- makeTick a - b <- maybe (pure mempty) (makeAxisBar (view #place a)) (view #bar a) - pure (group (Just "axis") [t, b]) - --- | alter a colour with a function -colourHudOptions :: (Colour -> Colour) -> HudOptions -> HudOptions -colourHudOptions f o = - o - & over #frames (fmap (second fFrame)) - & over #titles (fmap (second (over (#style % #color) f))) - & over #axes (fmap (second fAxis)) - & over #legends (fmap (second fLegend)) - where - fAxis :: AxisOptions -> AxisOptions - fAxis a = - a - & over #bar (fmap (over (#style % #color) f)) - & over - (#ticks % #gtick) - (fmap (first (over #color f . over #borderColor f))) - & over - (#ticks % #ttick) - (fmap (first (over #color f))) - & over - (#ticks % #ltick) - (fmap (first (over #color f))) - fLegend :: LegendOptions -> LegendOptions - fLegend a = - a - & over #textStyle (over #color f) - & over #frame (fmap (over #color f . over #borderColor f)) - fFrame :: FrameOptions -> FrameOptions - fFrame a = - a - & over #frame (fmap (over #color f . over #borderColor f)) - --- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas -data Place - = PlaceLeft - | PlaceRight - | PlaceTop - | PlaceBottom - | PlaceAbsolute (Point Double) - deriving (Show, Eq, Generic) - --- | textifier -placeText :: Place -> Text -placeText p = - case p of - PlaceTop -> "Top" - PlaceBottom -> "Bottom" - PlaceLeft -> "Left" - PlaceRight -> "Right" - PlaceAbsolute _ -> "Absolute" - --- | axis options -data AxisOptions = AxisOptions - { bar :: Maybe AxisBar, - adjust :: Maybe Adjustments, - ticks :: Ticks, - place :: Place - } - deriving (Eq, Show, Generic) - --- | The official axis -defaultAxisOptions :: AxisOptions -defaultAxisOptions = AxisOptions (Just defaultAxisBar) (Just defaultAdjustments) defaultTicks PlaceBottom - --- | The bar on an axis representing the x or y plane. --- --- >>> defaultAxisBar --- AxisBar {style = RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.05 0.05 0.05 0.40}, size = 4.0e-3, buffer = 1.0e-2, overhang = 2.0e-3} -data AxisBar = AxisBar - { style :: RectStyle, - size :: Double, - buffer :: Double, - -- | extension over the edges of the axis range - overhang :: Double - } - deriving (Show, Eq, Generic) - --- | The official axis bar -defaultAxisBar :: AxisBar -defaultAxisBar = AxisBar (RectStyle 0 transparent (set opac' 0.4 dark)) 0.004 0.01 0.002 - --- | Options for titles. Defaults to center aligned, and placed at Top of the hud --- --- >>> defaultTitle "title" --- Title {text = "title", style = TextStyle {size = 0.12, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing}, place = PlaceTop, anchor = AnchorMiddle, buffer = 4.0e-2} -data Title = Title - { text :: Text, - style :: TextStyle, - place :: Place, - anchor :: Anchor, - buffer :: Double - } - deriving (Show, Eq, Generic) - --- | The official hud title -defaultTitle :: Text -> Title -defaultTitle txt = - Title - txt - ( defaultTextStyle - & #size .~ 0.12 - ) - PlaceTop - AnchorMiddle - 0.04 - --- | xy coordinate markings --- --- >>> defaultTicks --- Ticks {style = TickRound (FormatN {fstyle = FSCommaPrec, sigFigs = Just 1, maxDistinguishIterations = 4, addLPad = True, cutRightZeros = True}) 8 TickExtend, gtick = Just (GlyphStyle {size = 3.0e-2, color = Colour 0.05 0.05 0.05 0.40, borderColor = Colour 0.05 0.05 0.05 0.40, borderSize = 4.0e-3, shape = VLineGlyph, rotation = Nothing, translate = Nothing},3.0e-2), ttick = Just (TextStyle {size = 5.0e-2, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing},3.3e-2), ltick = Just (LineStyle {size = 5.0e-3, color = Colour 0.05 0.05 0.05 0.05, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing},0.0)} -data Ticks = Ticks - { style :: TickStyle, - gtick :: Maybe (GlyphStyle, Double), - ttick :: Maybe (TextStyle, Double), - ltick :: Maybe (LineStyle, Double) - } - deriving (Show, Eq, Generic) - --- | The official glyph tick -defaultGlyphTick :: GlyphStyle -defaultGlyphTick = - defaultGlyphStyle - & #borderSize .~ 0.004 - & #shape .~ VLineGlyph - & #color .~ set opac' 0.4 dark - & #borderColor .~ set opac' 0.4 dark - --- | The official text tick -defaultTextTick :: TextStyle -defaultTextTick = - defaultTextStyle & #size .~ 0.05 - --- | The official line tick -defaultLineTick :: LineStyle -defaultLineTick = - defaultLineStyle - & #size .~ 5.0e-3 - & #color %~ set opac' 0.05 - --- | The official tick -defaultTicks :: Ticks -defaultTicks = - Ticks - defaultTickStyle - (Just (defaultGlyphTick, 0.03)) - (Just (defaultTextTick, 0.033)) - (Just (defaultLineTick, 0)) - --- | Style of tick marks on an axis. -data TickStyle - = -- | no ticks on axis - TickNone - | -- | specific labels (equidistant placement) - TickLabels [Text] - | -- | sensibly rounded ticks, a guide to how many, and whether to extend beyond the data bounding box - TickRound FormatN Int TickExtend - | -- | exactly n equally spaced ticks - TickExact FormatN Int - | -- | specific labels and placement - TickPlaced [(Double, Text)] - deriving (Show, Eq, Generic) - --- | The official tick style --- --- >>> defaultTickStyle --- TickRound (FormatN {fstyle = FSCommaPrec, sigFigs = Just 1, maxDistinguishIterations = 4, addLPad = True, cutRightZeros = True}) 8 TickExtend -defaultTickStyle :: TickStyle -defaultTickStyle = TickRound (FormatN FSCommaPrec (Just 1) 4 True True) 8 TickExtend - --- | textifier -tickStyleText :: TickStyle -> Text -tickStyleText TickNone = "TickNone" -tickStyleText TickLabels {} = "TickLabels" -tickStyleText TickRound {} = "TickRound" -tickStyleText TickExact {} = "TickExact" -tickStyleText TickPlaced {} = "TickPlaced" - --- | Whether Ticks are allowed to extend the data range -data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) - --- | options for prettifying axis decorations --- --- >>> defaultAdjustments --- Adjustments {maxXRatio = 8.0e-2, maxYRatio = 6.0e-2, angledRatio = 0.12, allowDiagonal = True} -data Adjustments = Adjustments - { maxXRatio :: Double, - maxYRatio :: Double, - angledRatio :: Double, - allowDiagonal :: Bool - } - deriving (Show, Eq, Generic) - --- | The official hud adjustments. -defaultAdjustments :: Adjustments -defaultAdjustments = Adjustments 0.08 0.06 0.12 True - --- | Legend options --- --- >>> defaultLegendOptions --- LegendOptions {size = 0.3, buffer = 0.1, vgap = 0.2, hgap = 0.1, textStyle = TextStyle {size = 0.18, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing}, innerPad = 0.1, outerPad = 2.0e-2, frame = Just (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.05 0.05 0.05 1.00, color = Colour 0.05 0.05 0.05 0.00}), place = PlaceRight, overallScale = 0.25, legendCharts = []} -data LegendOptions = LegendOptions - { size :: Double, - buffer :: Double, - vgap :: Double, - hgap :: Double, - textStyle :: TextStyle, - innerPad :: Double, - outerPad :: Double, - frame :: Maybe RectStyle, - place :: Place, - overallScale :: Double, - legendCharts :: [(Text, [Chart])] - } - deriving (Show, Eq, Generic) - --- | The official legend options -defaultLegendOptions :: LegendOptions -defaultLegendOptions = - LegendOptions - 0.3 - 0.1 - 0.2 - 0.1 - ( defaultTextStyle - & #size .~ 0.18 - ) - 0.1 - 0.02 - (Just (RectStyle 0.01 (set opac' 1 dark) (set opac' 0 dark))) - PlaceRight - 0.25 - [] - --- | flip an axis from being an X dimension to a Y one or vice-versa. -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 - --- | Options for hud frames --- --- >>> defaultFrameOptions --- FrameOptions {frame = Just (RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 1.00 1.00 1.00 0.02}), buffer = 0.0} -data FrameOptions = FrameOptions - { frame :: Maybe RectStyle, - buffer :: Double - } - deriving (Eq, Show, Generic) - --- | The official hud frame -defaultFrameOptions :: FrameOptions -defaultFrameOptions = FrameOptions (Just (blob (grey 1 0.02))) 0 - --- | Make a frame hud transformation. -frameHud :: FrameOptions -> State HudChart ChartTree -frameHud o = do - hc <- get - let r = padRect (view #buffer o) <$> view hudStyleBox' hc - case r of - Nothing -> pure (unnamed []) - Just r' -> pure $ case view #frame o of - Nothing -> blank r' - Just rs -> named "frame" [RectChart rs [r']] - -bar_ :: Place -> AxisBar -> CanvasBox -> HudBox -> Chart -bar_ pl b (Rect x z y w) (Rect x' z' y' w') = - RectChart (view #style b) $ - case pl of - PlaceTop -> - [ Rect - (x - b ^. #overhang) - (z + b ^. #overhang) - (w' + b ^. #buffer) - (w' + b ^. #buffer + b ^. #size) - ] - PlaceBottom -> - [ Rect - (x - b ^. #overhang) - (z + b ^. #overhang) - (y' - b ^. #size - b ^. #buffer) - (y' - b ^. #buffer) - ] - PlaceLeft -> - [ Rect - (x' - b ^. #size - b ^. #buffer) - (x' - b ^. #buffer) - (y - b ^. #overhang) - (w + b ^. #overhang) - ] - PlaceRight -> - [ Rect - (z' + (b ^. #buffer)) - (z' + (b ^. #buffer) + (b ^. #size)) - (y - b ^. #overhang) - (w + b ^. #overhang) - ] - PlaceAbsolute (Point x'' _) -> - [ Rect - (x'' + (b ^. #buffer)) - (x'' + (b ^. #buffer) + (b ^. #size)) - (y - b ^. #overhang) - (w + b ^. #overhang) - ] - -makeAxisBar :: Place -> AxisBar -> State HudChart ChartTree -makeAxisBar pl b = do - cb <- gets (view canvasBox') - hb <- gets (view hudStyleBox') - let c = bar_ pl b <$> cb <*> hb - pure $ named "axisbar" (maybeToList c) - -title_ :: Title -> HudBox -> Chart -title_ t hb = - TextChart - (style' & #rotation .~ bool (Just rot) Nothing (rot == 0)) - [(t ^. #text, addp (placePosTitle t hb) (alignPosTitle t hb))] - where - style' - | t ^. #anchor == AnchorStart = - #anchor .~ AnchorStart $ t ^. #style - | t ^. #anchor == AnchorEnd = - #anchor .~ AnchorEnd $ t ^. #style - | otherwise = t ^. #style - rot' = fromMaybe 0 (t ^. #style % #rotation) - rot - | t ^. #place == PlaceRight = pi / 2 + rot' - | t ^. #place == PlaceLeft = pi / 2 + rot' - | otherwise = rot' - -placePosTitle :: Title -> HudBox -> Point Double -placePosTitle t (Rect x z y w) = - case t ^. #place of - PlaceTop -> Point ((x + z) / 2.0) (w - y' + (t ^. #buffer)) - PlaceBottom -> Point ((x + z) / 2.0) (y - w' - (t ^. #buffer)) - PlaceLeft -> Point (x + y' - (t ^. #buffer)) ((y + w) / 2.0) - PlaceRight -> Point (z + w' + (t ^. #buffer)) ((y + w) / 2.0) - PlaceAbsolute p -> p - where - (Rect _ _ y' w') = styleBoxText (view #style t) (view #text t) zero - -alignPosTitle :: Title -> HudBox -> Point Double -alignPosTitle t (Rect x z y w) - | t ^. #anchor == AnchorStart - && (t ^. #place == PlaceTop || t ^. #place == 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 ((y - w) / 2.0) - | t ^. #anchor == AnchorEnd - && (t ^. #place == PlaceTop || t ^. #place == 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 append transformation. -title :: Title -> State HudChart ChartTree -title t = do - hb <- gets (view hudStyleBox') - pure $ named "title" (maybeToList $ title_ t <$> hb) - -placePos :: Place -> Double -> HudBox -> 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 (pi / 2) - PlaceLeft -> Just (pi / 2) - _ -> Nothing - -textPos :: Place -> TextStyle -> Double -> Point Double -textPos pl tt b = case pl of - PlaceTop -> Point 0 b - PlaceBottom -> Point 0 (-b - 0.5 * (tt ^. #vsize) * (tt ^. #size)) - PlaceLeft -> - Point - (-b) - ((tt ^. #vshift) * (tt ^. #vsize) * (tt ^. #size)) - PlaceRight -> - Point - b - ((tt ^. #vshift) * (tt ^. #vsize) * (tt ^. #size)) - PlaceAbsolute p -> p - -placeTextAnchor :: Place -> (TextStyle -> TextStyle) -placeTextAnchor pl - | pl == PlaceLeft = #anchor .~ AnchorEnd - | pl == PlaceRight = #anchor .~ AnchorStart - | otherwise = id - -placeGridLines :: Place -> HudBox -> Double -> Double -> [Point Double] -placeGridLines pl (Rect x z y w) a b - | pl == PlaceTop || pl == PlaceBottom = [Point a (y - b), Point a (w + b)] - | otherwise = [Point (x - b) a, Point (z + b) a] - --- | compute tick values and labels given options, ranges and formatting -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 n - 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) - --- | compute tick values in canvas space given placement, canvas box & data box -ticksPlacedCanvas :: TickStyle -> Place -> CanvasBox -> DataBox -> [(Double, Text)] -ticksPlacedCanvas ts pl cb db = - first (project (placeRange pl db) (placeRange pl cb)) - <$> fst (makePlacedTicks ts (placeRange pl db)) - -tickGlyph_ :: Place -> (GlyphStyle, Double) -> TickStyle -> CanvasBox -> CanvasBox -> DataBox -> Maybe Chart -tickGlyph_ pl (g, b) ts sb cb db = - case l of - [] -> Nothing - l' -> Just $ GlyphChart (g & #rotation .~ placeRot pl) l' - where - l = - addp (placePos pl b sb) . placeOrigin pl - <$> fmap fst (ticksPlacedCanvas ts pl cb db) - --- | aka marks -tickGlyph :: - Place -> - (GlyphStyle, Double) -> - TickStyle -> - State HudChart ChartTree -tickGlyph pl (g, b) ts = do - sb <- gets (view canvasStyleBox') - cb <- gets (view canvasBox') - db <- gets (view #dataBox) - let c = tickGlyph_ pl (g, b) ts <$> sb <*> cb <*> pure db - pure $ named "tickglyph" (catMaybes $ maybeToList c) - -tickText_ :: - Place -> - (TextStyle, Double) -> - TickStyle -> - CanvasBox -> - CanvasBox -> - DataBox -> - Maybe Chart -tickText_ pl (txts, b) ts sb cb db = - case l of - [] -> Nothing - _ -> Just $ TextChart (placeTextAnchor pl txts) l - where - l = - swap . first (addp (addp (placePos pl b sb) (textPos pl txts b)) . placeOrigin pl) - <$> ticksPlacedCanvas ts pl cb db - --- | aka tick labels -tickText :: - Place -> - (TextStyle, Double) -> - TickStyle -> - State HudChart ChartTree -tickText pl (txts, b) ts = do - sb <- gets (view canvasStyleBox') - cb <- gets (view canvasBox') - db <- gets (view #dataBox) - let c = tickText_ pl (txts, b) ts <$> sb <*> cb <*> pure db - pure $ named "ticktext" (catMaybes $ maybeToList c) - --- | aka grid lines -tickLine :: - Place -> - (LineStyle, Double) -> - TickStyle -> - State HudChart ChartTree -tickLine pl (ls, b) ts = do - cb <- gets (view canvasBox') - db <- gets (view #dataBox) - case cb of - Nothing -> pure $ named "ticklines" [] - Just cb' -> do - let l = (\x -> placeGridLines pl cb' x b) <$> fmap fst (ticksPlacedCanvas ts pl cb' db) - pure $ named "ticklines" (bool [LineChart ls l] [] (null l)) - --- | Create tick glyphs (marks), lines (grid) and text (labels) -applyTicks :: - Place -> - Ticks -> - State HudChart ChartTree -applyTicks pl t = do - g <- maybe (pure mempty) (\x -> tickGlyph pl x (t ^. #style)) (t ^. #gtick) - l <- maybe (pure mempty) (\x -> tickText pl x (t ^. #style)) (t ^. #ttick) - t' <- maybe (pure mempty) (\x -> tickLine pl x (t ^. #style)) (t ^. #ltick) - pure $ group (Just "ticks") [g, l, t'] - --- | adjust Tick for sane font sizes etc -adjustTicks :: - Adjustments -> - HudBox -> - DataBox -> - Place -> - Ticks -> - Ticks -adjustTicks (Adjustments mrx ma mry ad) vb cs pl t - | pl == PlaceBottom || pl == PlaceTop = - if ad - then - ( 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 ?~ pi / 4) t - False -> (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) t - ) - else t & #ttick % _Just % _1 % #size %~ (/ adjustSizeX) - | otherwise -- pl `elem` [PlaceLeft, PlaceRight] - = - (#ttick % _Just % _1 % #size %~ (/ adjustSizeY)) t - where - max' [] = 1 - max' xs = maximum xs - ra (Rect x z y w) - | pl == PlaceTop || pl == PlaceBottom = Range x z - | otherwise = Range y w - asp = ra vb - r = ra cs - tickl = snd <$> ticksR (t ^. #style) 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 / (upper asp - lower asp)) / mrx) 1 - adjustSizeY = max ((maxHeight / (upper asp - lower asp)) / mry) 1 - adjustSizeA = max ((maxHeight / (upper asp - lower asp)) / ma) 1 - -makeTick :: AxisOptions -> State HudChart ChartTree -makeTick c = do - hb <- gets (view hudBox') - db <- gets (view #dataBox) - case hb of - Nothing -> pure (named "ticks" []) - Just hb' -> do - let adjTick = maybe (c ^. #ticks) (\x -> adjustTicks x hb' db (c ^. #place) (c ^. #ticks)) (c ^. #adjust) - applyTicks (c ^. #place) adjTick - --- | Make a legend from 'LegendOptions' -legend :: LegendOptions -> State HudChart ChartTree -legend o = legendHud o (legendChart o) - --- | Make a legend hud element, from a bespoke ChartTree. -legendHud :: LegendOptions -> ChartTree -> State HudChart ChartTree -legendHud o lcs = do - sb <- gets (view hudStyleBox') - case sb of - Nothing -> pure (named "legend" []) - Just sb' -> pure $ placeLegend o sb' (over chart' (scaleChart (o ^. #overallScale)) lcs) - -placeLegend :: LegendOptions -> HudBox -> ChartTree -> ChartTree -placeLegend o hb t = - case view styleBox' t of - Nothing -> named "legend" [] - Just sb -> t & over chart' (moveChart (placeBeside_ (o ^. #place) (view #buffer o) hb sb)) - -placeBeside_ :: Place -> Double -> Rect Double -> Rect Double -> Point Double -placeBeside_ pl buff (Rect x z y w) (Rect x' z' y' w') = - case pl of - PlaceTop -> Point ((x + z) / 2.0) (buff + w + (w' - y') / 2.0) - PlaceBottom -> Point ((x + z) / 2.0) (y - buff - (w' - y')) - PlaceLeft -> Point (x - buff - (z' - x')) ((y + w) / 2.0) - PlaceRight -> Point (z + buff) ((y + w) / 2.0) - PlaceAbsolute p -> p - --- | frame a legend -legendFrame :: LegendOptions -> ChartTree -> ChartTree -legendFrame l content' = - group (Just "legend") [named "legendBorder" borders, rename (Just "legendContent") content'] - where - borders = [outer, inner] <> frame' - outer = padChart (view #outerPad l) [inner] - frame' = foldMap (\r -> [frameChart r 0 [inner]]) (view #frame l) - inner = padChart (view #innerPad l) (foldOf charts' content') - --- | Make the contents portion of a legend -legendChart :: LegendOptions -> ChartTree -legendChart l = legendFrame l content' - where - content' = - vert - (l ^. #hgap) - ( ( \(t, a) -> - hori - ((l ^. #vgap) + twidth - gapwidth t) - (fmap unnamed [[t], a]) - ) - <$> es - ) - es = reverse $ uncurry (legendEntry l) <$> view #legendCharts l - twidth = maybe zero (\(Rect _ z _ _) -> z) (styleBoxes (fst <$> es)) - gapwidth t = maybe 0 (\(Rect _ z _ _) -> z) (sbox t) - -legendText :: - LegendOptions -> - Text -> - Chart -legendText l t = - TextChart (l ^. #textStyle & #anchor .~ AnchorStart) [(t, zero)] - -legendizeChart :: - LegendOptions -> - Chart -> - Chart -legendizeChart l c = - case c of - (RectChart rs _) -> RectChart rs [Rect 0 (l ^. #size) 0 (l ^. #size)] - (TextChart ts t) -> let txt = fromMaybe "text" (listToMaybe (fst <$> t)) in TextChart (ts & #size .~ (l ^. #size / fromIntegral (Text.length txt))) [(txt, Point (0.5 * l ^. #size) (0.33 * l ^. #size))] - (GlyphChart gs _) -> GlyphChart (gs & #size .~ (l ^. #size)) [Point (0.5 * l ^. #size) (0.33 * l ^. #size)] - (LineChart ls _) -> - LineChart - (ls & #size %~ (/ (l ^. #overallScale))) - [[Point 0 (1 * l ^. #size), Point (2 * l ^. #size) (1 * l ^. #size)]] - (PathChart ps _) -> - ( let cs = - singletonQuad - ( QuadPosition - (Point 0 0) - (Point (l ^. #size) (l ^. #size)) - (Point (2 * l ^. #size) ((-1) * l ^. #size)) - ) - in PathChart (ps & #borderSize .~ (l ^. #size)) cs - ) - (BlankChart _) -> BlankChart [Rect 0 (l ^. #size) 0 (l ^. #size)] - -legendEntry :: - LegendOptions -> - Text -> - [Chart] -> - (Chart, [Chart]) -legendEntry l t cs = - (legendText l t, cs & fmap (legendizeChart l)) +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} + +-- | A hud stands for , and is a collective noun used to name chart elements that assist in data interpretation or otherwise annotate and decorate data. +-- +-- This includes axes, titles, borders, frames, background canvaii, tick marks and tick value labels. +module Chart.Hud + ( -- * Hud + Hud (..), + Priority (..), + ChartBox, + DataBox, + HudChart (..), + HudChartSection (..), + hudChartBox', + + -- * HudOptions + HudOptions (..), + defaultHudOptions, + colourHudOptions, + + -- * Hud Processing + toHuds, + appendHud, + makeHuds, + fromHudChart, + runHudWith, + projectChartTreeWith, + addHud, + initialCanvas, + finalCanvas, + + -- * Hud options + AxisOptions (..), + defaultXAxisOptions, + defaultYAxisOptions, + FrameOptions (..), + defaultFrameOptions, + Place (..), + flipPlace, + AxisBar (..), + defaultAxisBar, + TitleOptions (..), + defaultTitleOptions, + Ticks (..), + TickStyle (..), + defaultGlyphTickStyleX, + defaultGlyphTickStyleY, + defaultTextTick, + defaultLineTick, + defaultXTicks, + defaultYTicks, + Tick (..), + defaultTick, + TickExtend (..), + formatN', + numTicks', + tickExtend', + adjustTicks, + Adjustments (..), + defaultAdjustments, + LegendOptions (..), + defaultLegendOptions, + + -- * Convert Hud elements to charts + axisHud, + titleHud, + frameHud, + legendHud, + ) +where + +import Chart.Data +import Chart.Primitive +import Chart.Style +import Data.Bifunctor +import Data.Bool +import Data.Colour +import Data.Foldable hiding (sum) +import Data.FormatN +import Data.List qualified as List +import Data.Maybe +import Data.Path +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Tuple +import GHC.Generics hiding (to) +import NumHask.Prelude hiding (to) +import NumHask.Space +import Optics.Core + +-- $setup +-- +-- >>> :set -XOverloadedLabels +-- >>> :set -XOverloadedStrings +-- >>> import Chart +-- >>> import Optics.Core + +-- * Hud + +-- | The priority of a Hud element or transformation, lower value means higher priority. +-- +-- Lower priority (higher values) huds will tend to be placed on the outside of a chart. +-- +-- Hud elements are rendered in order from high to low priority and the positioning of hud elements can depend on the positioning of elements that have already been included. Equal priority values will be placed in the same process step. +-- +-- The first example below, based in 'Chart.Examples.lineExample' but with the legend placed on the right and coloured frames to help accentuate effects, includes (in order of priority): +-- +-- - an inner frame, representing the core data area of the chart (Priority 1) +-- +-- - the axes (5) +-- +-- - the titles (Priority 12) +-- +-- - the legend (Priority 50) +-- +-- - an outer frame which is transparent and used to pad out the chart (Priority 100). +-- +-- > priorityv1Example = lineExample & (#hudOptions % #frames) .~ [(1, FrameOptions (Just defaultRectStyle) 0), (100, FrameOptions (Just (defaultRectStyle & #color .~ (palette1 4 & opac' .~ 0.05) & #borderColor .~ palette1 4)) 0.1)] & over (#hudOptions % #legends) (fmap (first (const (Priority 50)))) & #hudOptions % #legends %~ fmap (second (set #place PlaceRight)) +-- +-- ![priorityv1 example](other/priorityv1.svg) +-- +-- The second variation below drops the title priorities to below the legend: +-- +-- > priorityv2Example = priorityv1Example & #hudOptions % #titles %~ fmap (first (const (Priority 51))) +-- +-- ![priorityv2 example](other/priorityv2.svg) +data Priority a = Priority {priority :: Double, item :: a} deriving (Eq, Ord, Show, Generic, Functor) + +-- | Heads-up display additions to charts +newtype Hud = Hud {phud :: Priority (HudChart -> ChartTree)} deriving (Generic) + +-- | Named pair type to track the split of Chart elements into Hud and Canvas +-- +-- - charts: charts that form the canvas or data elements of the chart; the rectangular dimension which is considered to be the data representation space. +-- +-- - hud: charts that form the Hud. +data HudChart = HudChart + { chartSection :: ChartTree, + hudSection :: ChartTree + } + deriving (Eq, Show, Generic) + +-- | A type for Rect to represent the bounding box of a chart. +type ChartBox = Rect Double + +-- | A type for Rect to represent the bounding box of the data. +type DataBox = Rect Double + +-- | A section of a 'HudChart' +data HudChartSection + = -- | The canvas without any style allowances + CanvasSection + | -- | The canvas portion including style boundaries. + CanvasStyleSection + | -- | The hud and canvas sections, not including style. + HudSection + | -- | The hud and canvas sections, including style + HudStyleSection + deriving (Eq, Show, Generic) + +-- | The 'Rect' of a particular 'HudChartSection' of a 'HudChart' +hudChartBox' :: HudChartSection -> Getter HudChart (Maybe (Rect Double)) +hudChartBox' CanvasSection = to (boxes . foldOf (#chartSection % charts')) +hudChartBox' CanvasStyleSection = to (styleBoxes . foldOf (#chartSection % charts')) +hudChartBox' HudSection = to (boxes . (\x -> foldOf (#chartSection % charts') x <> foldOf (#hudSection % charts') x)) +hudChartBox' HudStyleSection = to (styleBoxes . (\x -> foldOf (#chartSection % charts') x <> foldOf (#hudSection % charts') x)) + +-- | Append a 'ChartTree' to the hud section of a 'HudChart'. +appendHud :: ChartTree -> HudChart -> HudChart +appendHud cs x = + x & over #hudSection (<> cs) + +-- | Add huds to the hud section of a 'HudChart', given a list of hud makers. +makeHuds :: [HudChart -> ChartTree] -> HudChart -> HudChart +makeHuds hs hc = over #hudSection (<> mconcat (fmap ($ hc) hs)) hc + +-- | Convert a 'HudChart' to a 'ChartTree' labelling the hud and chart sections. +fromHudChart :: HudChart -> ChartTree +fromHudChart hc = group (Just "chart") [view #chartSection hc] <> group (Just "hud") [view #hudSection hc] + +-- | Combine huds and charts to form a new Chart using the supplied initial canvas and data dimensions. Note that chart data is transformed by this computation (a linear type might be useful here). +runHudWith :: + -- | initial canvas + ChartBox -> + -- | huds to add + [Hud] -> + -- | underlying chart + ChartTree -> + -- | integrated chart tree + ChartTree +runHudWith cb hs cs = + hs + & List.sortOn (view (#phud % #priority)) + & List.groupBy (\a b -> view (#phud % #priority) a == view (#phud % #priority) b) + & fmap (fmap (view (#phud % #item))) + & foldl' (flip makeHuds) hc0 + & fromHudChart + where + hc0 = + HudChart + (cs & set styleBox' (Just cb)) + mempty + +-- | Decorate a ChartTree with HudOptions +addHud :: ChartAspect -> HudOptions -> ChartTree -> ChartTree +addHud asp ho cs = + runHudWith + (initialCanvas asp (Just cs')) + hs + cs' + where + db = view safeBox' cs + (mdb, hs) = toHuds ho db + cs' = cs <> maybe mempty (\r -> bool (named "datapadding" [BlankChart defaultStyle [r]]) mempty (r == db)) mdb + +-- | Compute a Rect representing the initial chart canvas from a 'ChartAspect' and maybe a 'ChartTree', before the addition of style and hud elements. +-- +-- >>> initialCanvas (FixedAspect 1.5) (Just $ unnamed [RectChart defaultRectStyle [one]]) +-- Rect (-0.75) 0.75 (-0.5) 0.5 +initialCanvas :: ChartAspect -> Maybe ChartTree -> Rect Double +initialCanvas (FixedAspect a) _ = aspect a +initialCanvas (CanvasAspect a) _ = aspect a +initialCanvas ChartAspect cs = maybe one (aspect . ratio . view safeStyleBox') cs +initialCanvas UnscaledAspect cs = maybe one (view safeStyleBox') cs + +-- | Compute a Rect representing the final chart canvas from a 'ChartAspect' and maybe a 'ChartTree'. The difference between 'initialCanvas' and finalCanvas is using the actual chart canvas for CanvasAspect. +-- +-- >>> finalCanvas (CanvasAspect 1.5) (Just $ unnamed [RectChart defaultRectStyle [one]]) +-- Rect (-0.5) 0.5 (-0.5) 0.5 +finalCanvas :: ChartAspect -> Maybe ChartTree -> Rect Double +finalCanvas (FixedAspect a) _ = aspect a +finalCanvas (CanvasAspect a) Nothing = aspect a +finalCanvas (CanvasAspect _) cs = finalCanvas ChartAspect cs +finalCanvas ChartAspect cs = maybe one (aspect . ratio . view safeStyleBox') cs +finalCanvas UnscaledAspect cs = maybe one (view safeStyleBox') cs + +-- | Add 'HudOptions' to a 'ChartTree' and scale to the 'ChartAspect'. +projectChartTreeWith :: ChartAspect -> HudOptions -> ChartTree -> ChartTree +projectChartTreeWith asp ho ct = ctFinal + where + csAndHud = addHud asp ho ct + viewbox = finalCanvas asp (Just csAndHud) + ctFinal = set styleBox' (Just viewbox) csAndHud + +-- | Typical, configurable hud elements. Anything else can be hand-coded as a 'Hud'. +-- +-- ![hud example](other/hudoptions.svg) +data HudOptions = HudOptions + { axes :: [Priority AxisOptions], + frames :: [Priority FrameOptions], + legends :: [Priority LegendOptions], + titles :: [Priority TitleOptions] + } + deriving (Eq, Show, Generic) + +instance Semigroup HudOptions where + (<>) (HudOptions a c l t) (HudOptions a' c' l' t') = + HudOptions (a <> a') (c <> c') (l <> l') (t <> t') + +instance Monoid HudOptions where + mempty = HudOptions [] [] [] [] + +-- | The official hud options. +-- +-- - A fixed chart aspect (width:height) of 1.5 +-- +-- - An x axis at the bottom and y axis at the left. +-- +-- - The default tick style for each axis of an axis bar, tick glyphs (or marks), automated tick labels, and tick (or grid) lines. +-- +-- - A high 'Priority' (and thus inner), low-opacity frame, representing the data area of the chart. +-- +-- - A low priority (outer), transparent frame, providing some padding around the chart. +defaultHudOptions :: HudOptions +defaultHudOptions = + HudOptions + [ Priority 5 defaultXAxisOptions, + Priority 5 defaultYAxisOptions + ] + [ Priority 1 (defaultFrameOptions & set #anchorTo CanvasStyleSection), + Priority 20 (defaultFrameOptions & set #buffer 0.04 & set #frame (Just clear)) + ] + [] + [] + +-- | alter a colour with a function +colourHudOptions :: (Colour -> Colour) -> HudOptions -> HudOptions +colourHudOptions f o = + o + & over (#frames % each % #item) fFrame + & over (#titles % each % #item % #style % #color) f + & over (#axes % each % #item) fAxis + & over (#legends % each % #item) fLegend + where + fAxis :: AxisOptions -> AxisOptions + fAxis a = + a + & over (#axisBar %? #style % #color) f + & over (#ticks % #glyphTick %? #style % #color) f + & over (#ticks % #glyphTick %? #style % #borderColor) f + & over (#ticks % #textTick %? #style % #color) f + & over + (#ticks % #lineTick %? #style % #color) + f + fLegend :: LegendOptions -> LegendOptions + fLegend a = + a + & over #textStyle (over #color f) + & over #frame (fmap (over #color f . over #borderColor f)) + fFrame :: FrameOptions -> FrameOptions + fFrame a = + a + & over (#frame % _Just) (over #color f . over #borderColor f) + +-- | Placement of elements around (what is implicity but maybe shouldn't just be) a rectangular canvas +data Place + = PlaceLeft + | PlaceRight + | PlaceTop + | PlaceBottom + | PlaceAbsolute (Point Double) + deriving (Show, Eq, Generic) + +-- | Flip Place to the opposite side, or unchanged if 'PlaceAbsolute'. +-- +-- >>> flipPlace PlaceLeft +-- PlaceRight +flipPlace :: Place -> Place +flipPlace PlaceLeft = PlaceRight +flipPlace PlaceRight = PlaceLeft +flipPlace PlaceTop = PlaceBottom +flipPlace PlaceBottom = PlaceTop +flipPlace x = x + +-- | axis options +data AxisOptions = AxisOptions + { axisBar :: Maybe AxisBar, + adjustments :: Maybe Adjustments, + ticks :: Ticks, + place :: Place + } + deriving (Eq, Show, Generic) + +-- | The official X-axis +defaultXAxisOptions :: AxisOptions +defaultXAxisOptions = AxisOptions (Just defaultAxisBar) (Just defaultAdjustments) defaultXTicks PlaceBottom + +-- | The official Y-axis +defaultYAxisOptions :: AxisOptions +defaultYAxisOptions = AxisOptions (Just defaultAxisBar) (Just defaultAdjustments) defaultYTicks PlaceLeft + +-- | The bar on an axis representing the x or y plane. +-- +-- >>> defaultAxisBar +-- AxisBar {style = Style {size = 6.0e-2, borderSize = 0.0, color = Colour 0.05 0.05 0.05 0.40, borderColor = Colour 0.00 0.00 0.00 0.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, size = 4.0e-3, buffer = 1.0e-2, overhang = 2.0e-3, anchorTo = CanvasSection} +data AxisBar = AxisBar + { style :: Style, + size :: Double, + buffer :: Double, + -- | extension over the edges of the axis range + overhang :: Double, + -- | Which hud-chart section to anchor to + anchorTo :: HudChartSection + } + deriving (Show, Eq, Generic) + +-- | The official axis bar +defaultAxisBar :: AxisBar +defaultAxisBar = AxisBar (defaultRectStyle & set #borderSize 0 & set #borderColor transparent & set #color (set opac' 0.4 dark)) 0.004 0.01 0.002 CanvasSection + +-- | Options for titles. Defaults to center aligned, and placed at Top of the hud +-- +-- >>> defaultTitleOptions "title" +-- TitleOptions {text = "title", style = Style {size = 0.12, borderSize = 1.0e-2, color = Colour 0.05 0.05 0.05 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, place = PlaceTop, anchor = AnchorMiddle, buffer = 4.0e-2} +data TitleOptions = TitleOptions + { text :: Text, + style :: Style, + place :: Place, + anchor :: Anchor, + buffer :: Double + } + deriving (Show, Eq, Generic) + +-- | The official hud title +defaultTitleOptions :: Text -> TitleOptions +defaultTitleOptions txt = + TitleOptions + txt + ( defaultTextStyle + & set #size 0.12 + ) + PlaceTop + AnchorMiddle + 0.04 + +-- | axis tick markings +-- +-- >>> defaultXTicks +-- Ticks {tick = TickRound (FormatN {fstyle = FSCommaPrec, sigFigs = Just 1, maxDistinguishIterations = 4, addLPad = True, cutRightZeros = True}) 5 TickExtend, glyphTick = Just (TickStyle {style = Style {size = 3.0e-2, borderSize = 4.0e-3, color = Colour 0.05 0.05 0.05 0.40, borderColor = Colour 0.05 0.05 0.05 0.40, scaleP = ScalePY, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = VLineGlyph}, anchorTo = CanvasSection, buffer = 1.0e-2}), textTick = Just (TickStyle {style = Style {size = 4.0e-2, borderSize = 1.0e-2, color = Colour 0.05 0.05 0.05 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, anchorTo = HudStyleSection, buffer = 1.0e-2}), lineTick = Just (TickStyle {style = Style {size = 5.0e-3, borderSize = 1.0e-2, color = Colour 0.05 0.05 0.05 0.05, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, anchorTo = CanvasSection, buffer = 0.0})} +data Ticks = Ticks + { tick :: Tick, + glyphTick :: Maybe TickStyle, + textTick :: Maybe TickStyle, + lineTick :: Maybe TickStyle + } + deriving (Show, Eq, Generic) + +-- | Common elements across all tick types. +data TickStyle = TickStyle + { style :: Style, + anchorTo :: HudChartSection, + buffer :: Double + } + deriving (Show, Eq, Generic) + +-- | The official glyph tick +defaultGlyphTickStyleX :: TickStyle +defaultGlyphTickStyleX = + TickStyle + ( defaultGlyphStyle + & set #borderSize 0.004 + & set #glyphShape VLineGlyph + & set #color (set opac' 0.4 dark) + & set #borderColor (set opac' 0.4 dark) + & set #scaleP ScalePY + ) + CanvasSection + 0.01 + +-- | The official glyph tick +defaultGlyphTickStyleY :: TickStyle +defaultGlyphTickStyleY = + TickStyle + ( defaultGlyphStyle + & set #borderSize 0.004 + & set #glyphShape HLineGlyph + & set #color (set opac' 0.4 dark) + & set #borderColor (set opac' 0.4 dark) + & set #scaleP ScalePX + ) + CanvasSection + 0.01 + +-- | The official text tick +defaultTextTick :: TickStyle +defaultTextTick = + TickStyle + (defaultTextStyle & set #size 0.04) + HudStyleSection + 0.01 + +-- | The official line tick +defaultLineTick :: TickStyle +defaultLineTick = + TickStyle + ( defaultLineStyle + & set #size 5.0e-3 + & set (#color % opac') 0.05 + ) + CanvasSection + 0 + +-- | The official X-axis tick +defaultXTicks :: Ticks +defaultXTicks = + Ticks + defaultTick + (Just defaultGlyphTickStyleX) + (Just defaultTextTick) + (Just defaultLineTick) + +-- | The official Y-axis tick +defaultYTicks :: Ticks +defaultYTicks = + Ticks + defaultTick + (Just defaultGlyphTickStyleY) + (Just defaultTextTick) + (Just defaultLineTick) + +-- | Style of tick marks on an axis. +data Tick + = -- | no ticks on axis + TickNone + | -- | specific labels (equidistant placement) + TickLabels [Text] + | -- | sensibly rounded ticks, a guide to how many, and whether to extend beyond the data bounding box + TickRound FormatN Int TickExtend + | -- | exactly n equally spaced ticks + TickExact FormatN Int + | -- | specific labels and placement + TickPlaced [(Double, Text)] + deriving (Show, Eq, Generic) + +-- | Lens between a FormatN and a Tick. +formatN' :: Lens' Tick (Maybe FormatN) +formatN' = + lens formatN_ reformatN_ + +formatN_ :: Tick -> Maybe FormatN +formatN_ = \case + TickRound f _ _ -> Just f + TickExact f _ -> Just f + _ -> Nothing + +reformatN_ :: Tick -> Maybe FormatN -> Tick +reformatN_ ts Nothing = ts +reformatN_ (TickRound _ n e) (Just f) = TickRound f n e +reformatN_ (TickExact _ n) (Just f) = TickExact f n +reformatN_ ts _ = ts + +-- | Lens between number of ticks and a Tick. +-- +-- Only for TickRound and TickExact +numTicks' :: Lens' Tick (Maybe Int) +numTicks' = + lens numTicks_ renumTicks_ + +numTicks_ :: Tick -> Maybe Int +numTicks_ = \case + TickRound _ n _ -> Just n + TickExact _ n -> Just n + _ -> Nothing + +renumTicks_ :: Tick -> Maybe Int -> Tick +renumTicks_ ts Nothing = ts +renumTicks_ (TickRound f _ e) (Just n) = TickRound f n e +renumTicks_ (TickExact f _) (Just n) = TickExact f n +renumTicks_ ts _ = ts + +-- | Lens between a FormatN and a Tick. +tickExtend' :: Lens' Tick (Maybe TickExtend) +tickExtend' = + lens tickExtend_ tickReExtend_ + +tickExtend_ :: Tick -> Maybe TickExtend +tickExtend_ = \case + TickRound _ _ e -> Just e + _ -> Nothing + +tickReExtend_ :: Tick -> Maybe TickExtend -> Tick +tickReExtend_ ts Nothing = ts +tickReExtend_ (TickRound f n _) (Just e) = TickRound f n e +tickReExtend_ ts _ = ts + +-- | The official tick style +-- +-- >>> defaultTick +-- TickRound (FormatN {fstyle = FSCommaPrec, sigFigs = Just 1, maxDistinguishIterations = 4, addLPad = True, cutRightZeros = True}) 5 TickExtend +defaultTick :: Tick +defaultTick = TickRound (FormatN FSCommaPrec (Just 1) 4 True True) 5 TickExtend + +-- | Whether Ticks are allowed to extend the data range +data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic) + +-- | options for prettifying axis decorations +-- +-- >>> defaultAdjustments +-- Adjustments {maxXRatio = 8.0e-2, maxYRatio = 6.0e-2, angledRatio = 0.12, allowDiagonal = True} +data Adjustments = Adjustments + { maxXRatio :: Double, + maxYRatio :: Double, + angledRatio :: Double, + allowDiagonal :: Bool + } + deriving (Show, Eq, Generic) + +-- | The official hud adjustments. +defaultAdjustments :: Adjustments +defaultAdjustments = Adjustments 0.08 0.06 0.12 True + +-- | Legend options +-- +-- >>> defaultLegendOptions +-- LegendOptions {legendSize = 0.3, buffer = 0.1, vgap = 0.2, hgap = 0.1, textStyle = Style {size = 0.16, borderSize = 1.0e-2, color = Colour 0.05 0.05 0.05 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, innerPad = 0.1, outerPad = 2.0e-2, frame = Just (Style {size = 6.0e-2, borderSize = 5.0e-3, color = Colour 0.05 0.05 0.05 0.00, borderColor = Colour 0.05 0.05 0.05 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}), place = PlaceRight, scaleChartsBy = 0.25, scaleP = ScalePX, legendCharts = []} +data LegendOptions = LegendOptions + { legendSize :: Double, + buffer :: Double, + vgap :: Double, + hgap :: Double, + textStyle :: Style, + innerPad :: Double, + outerPad :: Double, + frame :: Maybe Style, + place :: Place, + scaleChartsBy :: Double, + scaleP :: ScaleP, + legendCharts :: [(Text, [Chart])] + } + deriving (Show, Eq, Generic) + +-- | The official legend options +defaultLegendOptions :: LegendOptions +defaultLegendOptions = + LegendOptions + 0.3 + 0.1 + 0.2 + 0.1 + (defaultTextStyle & set #size 0.16) + 0.1 + 0.02 + (Just (defaultRectStyle & set #borderSize 0.005 & set #borderColor (set opac' 1 dark) & set #color (set opac' 0 dark))) + PlaceRight + 0.25 + ScalePX + [] + +-- | Options for hud frames +-- +-- >>> defaultFrameOptions +-- FrameOptions {frame = Just (Style {size = 6.0e-2, borderSize = 0.0, color = Colour 1.00 1.00 1.00 0.02, borderColor = Colour 0.00 0.00 0.00 0.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}), anchorTo = HudStyleSection, buffer = 0.0} +data FrameOptions = FrameOptions + { frame :: Maybe Style, + anchorTo :: HudChartSection, + buffer :: Double + } + deriving (Eq, Show, Generic) + +-- | The official hud frame +defaultFrameOptions :: FrameOptions +defaultFrameOptions = FrameOptions (Just (blob (grey 1 0.02))) HudStyleSection 0 + +-- * Huds + +-- | Make Huds and potential data box extension; from a HudOption and an initial data box. +toHuds :: HudOptions -> DataBox -> (Maybe DataBox, [Hud]) +toHuds o db = + (mdb,) $ + fmap Hud $ + (as' & fmap (over #item (`axisHud` db'))) + <> (view #frames o & fmap (over #item frameHud)) + <> (view #legends o & fmap (over #item legendHud)) + <> (view #titles o & fmap (over #item titleHud)) + where + (mdb, as') = freezeAxes db (view #axes o) + db' = fromMaybe db mdb + +freezeAxes :: DataBox -> [Priority AxisOptions] -> (Maybe DataBox, [Priority AxisOptions]) +freezeAxes db0 = + foldr + ( \ao (dbm, as') -> + let (dbm', ao') = freezeTicks (fromMaybe db0 dbm) (view #item ao) + in (dbm', as' <> [ao & set #item ao']) + ) + (Nothing, []) + +freezeTicks :: DataBox -> AxisOptions -> (Maybe DataBox, AxisOptions) +freezeTicks db a = + bimap + (fmap (\x -> placeRect (view #place a) x db)) + (\x -> a & set (#ticks % #tick) x) + (placeTicks (placeRange (view #place a) db) (view (#ticks % #tick) a)) + +placeRect :: Place -> Range Double -> Rect Double -> Rect Double +placeRect 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 + +placeRange :: Place -> ChartBox -> Range Double +placeRange pl (Rect x z y w) = case pl of + PlaceRight -> Range y w + PlaceLeft -> Range y w + _ -> Range x z + +placeTicks :: Range Double -> Tick -> (Maybe (Range Double), Tick) +placeTicks r t@TickRound {} = (rExtended, TickPlaced tPlaced) + where + (rExtended, tPlaced) = makePlacedTicks r t +placeTicks _ t = (Nothing, t) + +-- | compute tick components given style, ranges and formatting +makePlacedTicks :: Range Double -> Tick -> (Maybe (Range Double), [(Double, Text)]) +makePlacedTicks r s = + case s of + TickNone -> (Nothing, []) + TickRound f n e -> + ( bool (space1 ticks0) Nothing (e == NoTickExtend), + zip ticks0 (formatNs f ticks0) + ) + where + ticks0 = gridSensible OuterPos (e == NoTickExtend) r n + TickExact f n -> (Nothing, zip ticks0 (formatNs f ticks0)) + where + ticks0 = grid OuterPos r n + TickLabels ls -> + ( Nothing, + zip + ( project (Range 0 (fromIntegral $ length ls)) r + <$> ((\x -> x - 0.5) . fromIntegral <$> [1 .. length ls]) + ) + ls + ) + TickPlaced xs -> (Nothing, xs) + +-- | Create an axis. +axisHud :: AxisOptions -> DataBox -> HudChart -> ChartTree +axisHud a db hc = group (Just "axis") [b, t] + where + b = maybe mempty (\x -> axisBarHud (view #place a) x hc) (view #axisBar a) + t = tickHud a db (appendHud b hc) + +axisBarHud :: Place -> AxisBar -> HudChart -> ChartTree +axisBarHud pl b hc = maybe mempty (named "axisbar" . pure) c + where + canvasBox = view (hudChartBox' CanvasSection) hc + anchoredBox = view (hudChartBox' (view #anchorTo b)) hc + c = bar_ pl b <$> canvasBox <*> anchoredBox + +bar_ :: Place -> AxisBar -> Rect Double -> Rect Double -> Chart +bar_ pl b (Rect x z y w) (Rect x' z' y' w') = + Chart (view #style b) . RectData $ + case pl of + PlaceTop -> + [ Rect + (x - view #overhang b) + (z + view #overhang b) + (w' + view #buffer b) + (w' + view #buffer b + view #size b) + ] + PlaceBottom -> + [ Rect + (x - view #overhang b) + (z + view #overhang b) + (y' - view #size b - view #buffer b) + (y' - view #buffer b) + ] + PlaceLeft -> + [ Rect + (x' - view #size b - view #buffer b) + (x' - view #buffer b) + (y - view #overhang b) + (w + view #overhang b) + ] + PlaceRight -> + [ Rect + (z' + view #buffer b) + (z' + view #buffer b + view #size b) + (y - view #overhang b) + (w + view #overhang b) + ] + PlaceAbsolute (Point x'' _) -> + [ Rect + (x'' + view #buffer b) + (x'' + view #buffer b + view #size b) + (y - view #overhang b) + (w + view #overhang b) + ] + +-- * tick hud creation + +tickHud :: AxisOptions -> DataBox -> HudChart -> ChartTree +tickHud ao db hc = maybe mempty ts (view (hudChartBox' HudStyleSection) hc) + where + ts b = applyTicks (view #place ao) (adjTick b) db hc + adjTick b = maybe (view #ticks ao) (\x -> adjustTicks x b db (view #place ao) (view #ticks ao)) (view #adjustments ao) + +-- | Create tick glyphs (marks), lines (grid) and text (labels) +applyTicks :: + Place -> + Ticks -> + DataBox -> + HudChart -> + ChartTree +applyTicks pl t db hc = group (Just "ticks") [lt, gt, tt] + where + lt = maybe mempty (\x -> tickLine pl x (view #tick t) db hc) (view #lineTick t) + gt = maybe mempty (\x -> tickGlyph pl x (view #tick t) db hc) (view #glyphTick t) + tt = maybe mempty (\x -> tickText pl x (view #tick t) db (appendHud gt hc)) (view #textTick t) + +-- | adjust Tick for sane font sizes etc +adjustTicks :: + Adjustments -> + ChartBox -> + DataBox -> + Place -> + Ticks -> + Ticks +adjustTicks (Adjustments mrx ma mry ad) vb cs pl t + | pl == PlaceBottom || pl == PlaceTop = + if ad + then + ( if adjustSizeX > 1 + then + ( case pl of + PlaceBottom -> set (#textTick %? #style % #anchor) AnchorEnd + PlaceTop -> set (#textTick %? #style % #anchor) AnchorStart + _ -> set (#textTick %? #style % #anchor) AnchorEnd + ) + . over (#textTick %? #style % #size) (/ adjustSizeA) + $ (#textTick %? #style % #rotation ?~ pi / 4) t + else over (#textTick %? #style % #size) (/ adjustSizeA) t + ) + else t & over (#textTick %? #style % #size) (/ adjustSizeX) + | otherwise -- pl `elem` [PlaceLeft, PlaceRight] + = + over (#textTick %? #style % #size) (/ adjustSizeY) t + where + max' [] = 1 + max' xs = maximum xs + ra (Rect x z y w) + | pl == PlaceTop || pl == PlaceBottom = Range x z + | otherwise = Range y w + asp = ra vb + r = ra cs + tickl = snd <$> ticksR (view #tick t) asp r + maxWidth :: Double + maxWidth = + maybe + 1 + ( \tt -> + max' $ + (\(Rect x z _ _) -> z - x) + . (\x -> styleBoxText (view #style tt) x (Point 0 0)) + <$> tickl + ) + (view #textTick t) + maxHeight = + maybe + 1 + ( \tt -> + max' $ + (\(Rect _ _ y w) -> w - y) + . (\x -> styleBoxText (view #style tt) x (Point 0 0)) + <$> tickl + ) + (view #textTick t) + + adjustSizeX :: Double + adjustSizeX = max (maxWidth / (upper asp - lower asp) / mrx) 1 + adjustSizeY = max (maxHeight / (upper asp - lower asp) / mry) 1 + adjustSizeA = max (maxHeight / (upper asp - lower asp) / ma) 1 + +-- | compute tick values and labels given options, ranges and formatting +ticksR :: Tick -> 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 n + 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) + +-- | aka marks +tickGlyph :: + Place -> + TickStyle -> + Tick -> + DataBox -> + HudChart -> + ChartTree +tickGlyph pl s ts db hc = maybe mempty (named "tickglyph" . pure) c + where + anchorBox = view (hudChartBox' (view #anchorTo s)) hc + canvasBox = view (hudChartBox' CanvasSection) hc + c = case (canvasBox, anchorBox) of + (Just cb, Just ab) -> Just $ Chart (view #style s) (GlyphData ps) + where + ps = placePosTick pl (view #buffer s) ab bb . fst <$> ticksPlacedCanvas ts pl cb db + bb = fromMaybe zero $ sbox (Chart (view #style s) (GlyphData [zero])) + _ -> Nothing + +placePosTick :: Place -> Double -> ChartBox -> Rect Double -> Double -> Point Double +placePosTick pl b (Rect x z y w) (Rect x' z' y' w') pos = case pl of + PlaceTop -> Point pos (w + b - y') + PlaceBottom -> Point pos (y - b - w') + PlaceLeft -> Point (x - b - z') pos + PlaceRight -> Point (z + b - x') pos + PlaceAbsolute p -> p + Point 0 pos + +-- | compute tick positions and string values in canvas space given placement, the canvas box & data box +ticksPlacedCanvas :: Tick -> Place -> ChartBox -> DataBox -> [(Double, Text)] +ticksPlacedCanvas ts pl cb db = + first (project (placeRange pl db) (placeRange pl cb)) + <$> snd (makePlacedTicks (placeRange pl db) ts) + +-- | aka tick labels +tickText :: + Place -> + TickStyle -> + Tick -> + DataBox -> + HudChart -> + ChartTree +tickText pl s ts db hc = maybe mempty (named "ticktext" . maybeToList) c + where + anchorBox = view (hudChartBox' (view #anchorTo s)) hc + cb = view (hudChartBox' CanvasSection) hc + c = tickText_ pl s ts <$> anchorBox <*> cb <*> pure db + +tickText_ :: + Place -> + TickStyle -> + Tick -> + ChartBox -> + ChartBox -> + DataBox -> + Maybe Chart +tickText_ pl s ts sb cb db = + case l of + [] -> Nothing + _ -> Just $ Chart (placeTextAnchor pl (view #style s)) (TextData l) + where + l = + swap . first (addp (addp (placePos pl (view #buffer s) sb) (textPos pl (view #style s) (view #buffer s))) . placeOrigin pl) + <$> ticksPlacedCanvas ts pl cb db + +placeOrigin :: Place -> Double -> Point Double +placeOrigin pl x + | pl == PlaceTop || pl == PlaceBottom = Point x 0 + | otherwise = Point 0 x + +-- | aka grid lines +tickLine :: + Place -> + TickStyle -> + Tick -> + DataBox -> + HudChart -> + ChartTree +tickLine pl s ts db hc = + case cb of + Nothing -> mempty + Just cb' -> + let l = (\x -> placeGridLines pl cb' x (view #buffer s)) <$> fmap fst (ticksPlacedCanvas ts pl cb' db) + in bool (named "ticklines" [Chart (view #style s) (LineData l)]) mempty (null l) + where + cb = view (hudChartBox' (view #anchorTo s)) hc + +placeGridLines :: Place -> ChartBox -> Double -> Double -> [Point Double] +placeGridLines pl (Rect x z y w) a b + | pl == PlaceTop || pl == PlaceBottom = [Point a (y - b), Point a (w + b)] + | otherwise = [Point (x - b) a, Point (z + b) a] + +-- | title append transformation. +titleHud :: TitleOptions -> HudChart -> ChartTree +titleHud t hc = maybe mempty ((named "title" . pure) . title_ t) hb + where + hb = view (hudChartBox' HudStyleSection) hc + +title_ :: TitleOptions -> ChartBox -> Chart +title_ t hb = + Chart + (style' & set #rotation (bool (Just rot) Nothing (rot == 0))) + (TextData [(view #text t, addp (placePosTitle t hb) (alignPosTitle t hb))]) + where + style' + | view #anchor t == AnchorStart = + set #anchor AnchorStart $ view #style t + | view #anchor t == AnchorEnd = + set #anchor AnchorEnd $ view #style t + | otherwise = view #style t + rot' = fromMaybe 0 (view (#style % #rotation) t) + rot + | view #place t == PlaceRight = pi / 2 + rot' + | view #place t == PlaceLeft = pi / 2 + rot' + | otherwise = rot' + +placePosTitle :: TitleOptions -> ChartBox -> Point Double +placePosTitle t (Rect x z y w) = + case view #place t of + PlaceTop -> Point ((x + z) / 2.0) (w - y' + view #buffer t) + PlaceBottom -> Point ((x + z) / 2.0) (y - w' - view #buffer t) + PlaceLeft -> Point (x + y' - view #buffer t) ((y + w) / 2.0) + PlaceRight -> Point (z + w' + view #buffer t) ((y + w) / 2.0) + PlaceAbsolute p -> p + where + (Rect _ _ y' w') = styleBoxText (view #style t) (view #text t) zero + +alignPosTitle :: TitleOptions -> ChartBox -> Point Double +alignPosTitle t (Rect x z y w) + | view #anchor t == AnchorStart + && (view #place t == PlaceTop || view #place t == PlaceBottom) = + Point ((x - z) / 2.0) 0.0 + | view #anchor t == AnchorStart + && view #place t == PlaceLeft = + Point 0.0 ((y - w) / 2.0) + | view #anchor t == AnchorStart + && view #place t == PlaceRight = + Point 0.0 ((y - w) / 2.0) + | view #anchor t == AnchorEnd + && (view #place t == PlaceTop || view #place t == PlaceBottom) = + Point ((-x + z) / 2.0) 0.0 + | view #anchor t == AnchorEnd + && view #place t == PlaceLeft = + Point 0.0 ((-y + w) / 2.0) + | view #anchor t == AnchorEnd + && view #place t == PlaceRight = + Point 0.0 ((-y + w) / 2.0) + | otherwise = Point 0.0 0.0 + +placePos :: Place -> Double -> ChartBox -> 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 + +textPos :: Place -> Style -> Double -> Point Double +textPos pl tt b = case pl of + PlaceTop -> Point 0 (b - view #vshift tt * view #vsize tt * view #size tt) + PlaceBottom -> Point 0 (-b - view #vshift tt * view #vsize tt * view #size tt - view #vsize tt * view #size tt) + PlaceLeft -> + Point + (-b) + (view #vshift tt * view #vsize tt * view #size tt) + PlaceRight -> + Point + b + (view #vshift tt * view #vsize tt * view #size tt) + PlaceAbsolute p -> p + +placeTextAnchor :: Place -> (Style -> Style) +placeTextAnchor pl + | pl == PlaceLeft = set #anchor AnchorEnd + | pl == PlaceRight = set #anchor AnchorStart + | otherwise = id + +-- | Make a frame hud transformation. +frameHud :: FrameOptions -> HudChart -> ChartTree +frameHud o hc = + case r of + Nothing -> mempty + Just r' -> case view #frame o of + Nothing -> named "frame" [Chart defaultStyle (BlankData [r'])] + Just rs -> named "frame" [Chart rs (RectData [r'])] + where + r = padRect (view #buffer o) <$> view (hudChartBox' (view #anchorTo o)) hc + +-- | Make a legend from 'LegendOptions' given an existing 'HudChart' +legendHud :: LegendOptions -> HudChart -> ChartTree +legendHud o hc = maybe mempty (\b -> placeLegend_ o b (over chart' (scaleChart (view #scaleChartsBy o)) lcs)) (view (hudChartBox' HudStyleSection) hc) + where + lcs = legendChart o & set (charts' % each % #chartStyle % #scaleP) (view #scaleP o) + +placeLegend_ :: LegendOptions -> ChartBox -> ChartTree -> ChartTree +placeLegend_ o hb t = maybe mempty (\b -> t & over chart' (moveChart (placeBeside_ (view #place o) (view #buffer o) hb b))) (view styleBox' t) + +placeBeside_ :: Place -> Double -> Rect Double -> Rect Double -> Point Double +placeBeside_ pl buff (Rect x z y w) (Rect x' z' y' w') = + case pl of + PlaceTop -> Point ((x + z) / 2.0) (buff + w + (w' - y') / 2.0) + PlaceBottom -> Point ((x + z) / 2.0) (y - buff - (w' - y')) + PlaceLeft -> Point (x - buff - (z' - x')) ((y + w) / 2.0) + PlaceRight -> Point (z + buff) ((y + w) / 2.0) + PlaceAbsolute p -> p + +-- | frame a legend +legendFrame :: LegendOptions -> ChartTree -> ChartTree +legendFrame l content' = + group (Just "legend") [borders, rename (Just "legendContent") content'] + where + borders = mconcat $ [outer, inner] <> frame' + outer = padChart (view #outerPad l) inner + frame' = foldMap (\r -> [frameChart r 0 inner]) (view #frame l) + inner = padChart (view #innerPad l) content' + +-- | Make the contents portion of a legend +legendChart :: LegendOptions -> ChartTree +legendChart l = legendFrame l content' + where + content' = + vert + (view #hgap l) + ( ( \(t, a) -> + hori + (view #vgap l + twidth - gapwidth t) + (fmap unnamed [[t], a]) + ) + <$> es + ) + es = reverse $ uncurry (legendEntry l) <$> view #legendCharts l + twidth = maybe zero (\(Rect x z _ _) -> z - x) (styleBoxes (fst <$> es)) + gapwidth t = maybe 0 (\(Rect x z _ _) -> z - x) (sbox t) + +legendText :: + LegendOptions -> + Text -> + Chart +legendText l t = + Chart (view #textStyle l & set #anchor AnchorStart) (TextData [(t, zero)]) + +legendizeChart :: + LegendOptions -> + Chart -> + Chart +legendizeChart l c = + case c of + (Chart rs (RectData _)) -> Chart rs (RectData [Rect 0 (view #legendSize l) 0 (view #legendSize l)]) + (Chart ts (TextData t)) -> let txt = fromMaybe "text" (listToMaybe (fst <$> t)) in Chart (ts & set #size (view #legendSize l / fromIntegral (Text.length txt))) (TextData [(txt, Point (0.5 * view #legendSize l) (0.33 * view #legendSize l))]) + (Chart gs (GlyphData _)) -> Chart (gs & set #size (view #legendSize l)) (GlyphData [Point (0.5 * view #legendSize l) (0.33 * view #legendSize l)]) + (Chart ls (LineData _)) -> + Chart + (ls & over #size (/ view #scaleChartsBy l)) + (LineData [[Point 0 (1 * view #legendSize l), Point (2 * view #legendSize l) (1 * view #legendSize l)]]) + (Chart ps (PathData _)) -> + ( let cs = + singletonQuad + ( QuadPosition + (Point 0 0) + (Point (view #legendSize l) (view #legendSize l)) + (Point (2 * view #legendSize l) ((-1) * view #legendSize l)) + ) + in Chart (ps & set #borderSize (view #legendSize l)) (PathData cs) + ) + _ -> blankChart1 (Rect 0 (view #legendSize l) 0 (view #legendSize l)) + +legendEntry :: + LegendOptions -> + Text -> + [Chart] -> + (Chart, [Chart]) +legendEntry l t cs = + (legendText l t, fmap (legendizeChart l) cs) diff --git a/src/Chart/Markup.hs b/src/Chart/Markup.hs --- a/src/Chart/Markup.hs +++ b/src/Chart/Markup.hs @@ -2,10 +2,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} --- | Conversion between Chart and Markup representations. +-- | Conversion between 'ChartOptions' and 'Markup' representations. module Chart.Markup ( Markup (..), ChartOptions (..), + forgetHud, markupChartOptions, markupChartTree, markupChart, @@ -15,15 +16,16 @@ writeChartOptions, CssOptions (..), defaultCssOptions, - CssPreferColorScheme (..), + PreferColorScheme (..), cssPreferColorScheme, fillSwitch, - CssShapeRendering (..), + ShapeRendering (..), markupCssOptions, MarkupOptions (..), defaultMarkupOptions, encodeNum, encodePx, + defaultCssFontFamilies, ) where @@ -43,6 +45,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import GHC.Generics import MarkupParse +import NumHask.Space import Optics.Core hiding (element) import Prelude @@ -75,27 +78,28 @@ -- | Convert a ChartTree to markup -- --- >>> lineExample & view #charts & markupChartTree & markdown_ Compact Xml +-- >>> lineExample & view #chartTree & markupChartTree & markdown_ Compact Xml -- "" markupChartTree :: ChartTree -> Markup markupChartTree cs = maybe xs' (\l -> element "g" [Attr "class" (encodeUtf8 l)] xs') label where - (ChartTree (Node (label, cs') xs)) = filterChartTree (not . isEmptyChart) cs + (ChartTree (Node (label, cs') xs)) = filterChartTree (not . isEmptyChart . chartData) cs xs' = mconcat $ fmap markupChart cs' <> (markupChartTree . ChartTree <$> xs) -markupText :: TextStyle -> Text -> Point Double -> Markup -markupText s t p@(Point x y) = element "text" as (frame' <> content c) +markupText :: Style -> Text -> Point Double -> Markup +markupText s t p@(Point x y) = frame' <> element "text" as (bool (contentRaw c) (content c) (EscapeText == view #escapeText s)) where as = uncurry Attr <$> [ ("x", encodeNum x), ("y", encodeNum $ -y) ] - <> maybeToList ((\x' -> ("transform", toRotateText x' p)) <$> (s ^. #rotation)) + <> maybeToList ((\x' -> ("transform", toRotateText x' p)) <$> view #rotation s) + -- This is very late for a chart creation. It is here so that the chart doesn't undergo scaling and thus picks up the local size of the text, less the border size of the frame. frame' = case view #frame s of Nothing -> Markup mempty - Just f -> markupChart (RectChart (f & over #borderSize (* view #size s)) [styleBoxText s t p]) + Just f -> markupChart (Chart (f & over #borderSize (* view #size s)) (RectData [styleBoxText (s & set #frame Nothing) t p])) c = encodeUtf8 t -- | Markup a text rotation about a point in radians. @@ -109,7 +113,7 @@ -- - flip y dimension toRotateText :: Double -> Point Double -> ByteString toRotateText r (Point x y) = - "rotate(" <> encodeNum (-r * 180 / pi) <> ", " <> encodeNum x <> ", " <> encodeNum (-y) <> ")" + "rotate(" <> encodeNum (-(r * 180 / pi)) <> ", " <> encodeNum x <> ", " <> encodeNum (-y) <> ")" toScaleText :: Double -> ByteString toScaleText x = @@ -130,17 +134,20 @@ -- | Convert a Chart to Markup -- --- >>> lineExample & view #charts & foldOf charts' & head & markupChart & markdown_ Compact Xml --- "" +-- >>> import MarkupParse +-- >>> import Optics.Core +-- >>> import Control.Category ((>>>)) +-- >>> lineExample & toListOf (#chartTree % charts') & mconcat & fmap (markupChart >>> markdown_ Compact Xml) +-- ["","",""] markupChart :: Chart -> Markup markupChart = uncurry (element "g") . f where - f (RectChart s xs) = (attsRect s, mconcat (markupRect <$> xs)) - f (TextChart s xs) = (attsText s, mconcat (uncurry (markupText s) <$> xs)) - f (GlyphChart s xs) = (attsGlyph s, mconcat (markupGlyph s <$> xs)) - f (PathChart s xs) = (attsPath s, markupPath xs) - f (LineChart s xs) = (attsLine s, markupLine xs) - f (BlankChart _) = ([], mempty) + f (Chart s (RectData xs)) = (attsRect s, mconcat (markupRect <$> xs)) + f (Chart s (TextData xs)) = (attsText s, mconcat (uncurry (markupText s) <$> xs)) + f (Chart s (GlyphData xs)) = (attsGlyph s, mconcat (markupGlyph s <$> xs)) + f (Chart s (PathData xs)) = (attsPath s, markupPath xs) + f (Chart s (LineData xs)) = (attsLine s, markupLine xs) + f (Chart _ (BlankData _)) = ([], mempty) markupLine :: [[Point Double]] -> Markup markupLine lss = @@ -156,13 +163,13 @@ -- | GlyphStyle to markup Tree -- Note rotation on the outside not the inside. -markupGlyph :: GlyphStyle -> Point Double -> Markup +markupGlyph :: Style -> Point Double -> Markup markupGlyph s p = case view #rotation s of Nothing -> gl Just r -> element "g" [Attr "transform" (toRotateText r p)] gl where - gl = markupShape_ (s ^. #shape) (s ^. #size) p + gl = markupShape_ (view #glyphShape s) (view #size s) p -- | Convert a dash representation from a list to text fromDashArray :: [Double] -> ByteString @@ -171,40 +178,40 @@ fromDashOffset :: Double -> ByteString fromDashOffset x = encodeNum x -attsLine :: LineStyle -> [Attr] +attsLine :: Style -> [Attr] attsLine o = uncurry Attr - <$> [ ("stroke-width", encodeNum $ o ^. #size), - ("stroke", showRGB $ o ^. #color), - ("stroke-opacity", showOpacity $ o ^. #color), + <$> [ ("stroke-width", encodeNum $ view #size o), + ("stroke", showRGB $ view #color o), + ("stroke-opacity", showOpacity $ view #color o), ("fill", "none") ] <> catMaybes - [(\x -> ("stroke-linecap", fromLineCap x)) <$> (o ^. #linecap)] - <> foldMap (\x -> [("stroke-linejoin", fromLineJoin x)]) (o ^. #linejoin) - <> foldMap (\x -> [("stroke-dasharray", fromDashArray x)]) (o ^. #dasharray) - <> foldMap (\x -> [("stroke-dashoffset", fromDashOffset x)]) (o ^. #dashoffset) + [(\x -> ("stroke-linecap", fromLineCap x)) <$> view #lineCap o] + <> foldMap (\x -> [("stroke-linejoin", fromLineJoin x)]) (view #lineJoin o) + <> foldMap (\x -> [("stroke-dasharray", fromDashArray x)]) (view #dasharray o) + <> foldMap (\x -> [("stroke-dashoffset", fromDashOffset x)]) (view #dashoffset o) -attsRect :: RectStyle -> [Attr] +attsRect :: Style -> [Attr] attsRect o = uncurry Attr - <$> [ ("stroke-width", encodeNum $ o ^. #borderSize), - ("stroke", showRGB $ o ^. #borderColor), - ("stroke-opacity", showOpacity $ o ^. #borderColor), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color) + <$> [ ("stroke-width", encodeNum $ view #borderSize o), + ("stroke", showRGB $ view #borderColor o), + ("stroke-opacity", showOpacity $ view #borderColor o), + ("fill", showRGB $ view #color o), + ("fill-opacity", showOpacity $ view #color o) ] -- | TextStyle to [Attr] -attsText :: TextStyle -> [Attr] +attsText :: Style -> [Attr] attsText o = uncurry Attr <$> [ ("stroke-width", "0.0"), ("stroke", "none"), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color), - ("font-size", encodeNum $ o ^. #size), - ("text-anchor", toTextAnchor $ o ^. #anchor) + ("fill", showRGB $ view #color o), + ("fill-opacity", showOpacity $ view #color o), + ("font-size", encodeNum $ view #size o), + ("text-anchor", toTextAnchor $ view #anchor o) ] where toTextAnchor :: Anchor -> ByteString @@ -213,31 +220,26 @@ toTextAnchor AnchorEnd = "end" -- | GlyphStyle to [Attr] -attsGlyph :: GlyphStyle -> [Attr] +attsGlyph :: Style -> [Attr] attsGlyph o = uncurry Attr - <$> [ ("stroke-width", encodeNum sw), - ("stroke", showRGB $ o ^. #borderColor), - ("stroke-opacity", showOpacity $ o ^. #borderColor), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color) + <$> [ ("stroke-width", encodeNum $ view #borderSize o), + ("stroke", showRGB $ view #borderColor o), + ("stroke-opacity", showOpacity $ view #borderColor o), + ("fill", showRGB $ view #color o), + ("fill-opacity", showOpacity $ view #color o) ] - <> foldMap ((: []) . (,) "transform" . toTranslateText) (o ^. #translate) - where - sw = case o ^. #shape of - PathGlyph _ NoScaleBorder -> o ^. #borderSize - PathGlyph _ ScaleBorder -> min 0.2 (o ^. #borderSize / o ^. #size) - _ -> o ^. #borderSize + <> foldMap ((: []) . (,) "transform" . toTranslateText) (view #translate o) -- | PathStyle to [Attr] -attsPath :: PathStyle -> [Attr] +attsPath :: Style -> [Attr] attsPath o = uncurry Attr - <$> [ ("stroke-width", encodeNum $ o ^. #borderSize), - ("stroke", showRGB $ o ^. #borderColor), - ("stroke-opacity", showOpacity $ o ^. #borderColor), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color) + <$> [ ("stroke-width", encodeNum $ view #borderSize o), + ("stroke", showRGB $ view #borderColor o), + ("stroke-opacity", showOpacity $ view #borderColor o), + ("fill", showRGB $ view #color o), + ("fill-opacity", showOpacity $ view #color o) ] -- | includes a flip of the y dimension. @@ -293,36 +295,44 @@ emptyElem "polyline" [Attr "points" $ encodeNum x <> "," <> encodeNum (-(y - s / 2)) <> "\n" <> encodeNum x <> "," <> encodeNum (-(y + s / 2))] markupShape_ HLineGlyph s (Point x y) = emptyElem "polyline" [Attr "points" $ encodeNum (x - s / 2) <> "," <> encodeNum (-y) <> "\n" <> encodeNum (x + s / 2) <> "," <> encodeNum (-y)] -markupShape_ (PathGlyph path _) s p = +markupShape_ (PathGlyph path) s p = emptyElem "path" (uncurry Attr <$> [("d", path), ("transform", toTranslateText p <> " " <> toScaleText s)]) -- | Create the classic SVG element -- --- >>> header 100 one (element_ "foo" []) & markdown_ Compact Xml --- "" -header :: Double -> Rect Double -> Markup -> Markup +-- >>> header (Just 300) (Rect (-0.75) 0.75 (-0.5) 0.5) (element_ "foo" []) & markdown_ Compact Xml +-- "" +header :: Maybe Double -> Rect Double -> Markup -> Markup header markupheight viewbox content' = element "svg" ( uncurry Attr - <$> [ ("xmlns", "http://www.w3.org/2000/svg"), - ("xmlns:xlink", "http://www.w3.org/1999/xlink"), - ("width", encodePx w''), - ("height", encodePx h'), - ("viewBox", encodeNum x <> " " <> encodeNum (-w) <> " " <> encodeNum (z - x) <> " " <> encodeNum (w - y)) - ] + <$> ( [ ("xmlns", "http://www.w3.org/2000/svg"), + ("xmlns:xlink", "http://www.w3.org/1999/xlink") + ] + <> widthAndHeight + <> [ ("viewBox", encodeNum x <> " " <> encodeNum (-w) <> " " <> encodeNum (z - x) <> " " <> encodeNum (w - y)) + ] + ) ) content' where (Rect x z y w) = viewbox Point w' h = width viewbox - Point w'' h' = Point (markupheight / h * w') markupheight + widthAndHeight = case markupheight of + Nothing -> [] + Just h' -> + [ ("width", encodePx w''), + ("height", encodePx h') + ] + where + w'' = h' / h * w' -- | CSS prefer-color-scheme text snippet -- -- >>> cssPreferColorScheme (light, dark) PreferHud -- "svg {\n color-scheme: light dark;\n}\n{\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(5%, 5%, 5%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(5%, 5%, 5%);\n }\n .legendBorder g {\n fill: rgb(94%, 94%, 94%);\n }\n}\n@media (prefers-color-scheme:dark) {\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(94%, 94%, 94%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(94%, 94%, 94%);\n }\n .legendBorder g {\n fill: rgb(5%, 5%, 5%);\n }\n}" -cssPreferColorScheme :: (Colour, Colour) -> CssPreferColorScheme -> ByteString +cssPreferColorScheme :: (Colour, Colour) -> PreferColorScheme -> ByteString cssPreferColorScheme (cl, cd) PreferHud = [i|svg { color-scheme: light dark; @@ -392,9 +402,10 @@ -- | Markup options. -- -- >>> defaultMarkupOptions --- MarkupOptions {markupHeight = 300.0, cssOptions = CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, cssExtra = ""}, renderStyle = Compact} +-- MarkupOptions {markupHeight = Just 300.0, chartAspect = FixedAspect 1.5, cssOptions = CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, fontFamilies = "\nsvg { font-family: system-ui,-apple-system,\"Segoe UI\",Roboto,\"Helvetica Neue\",Arial,\"Noto Sans\",\"Liberation Sans\",sans-serif,\"Apple Color Emoji\",\"Segoe UI Emoji\",\"Segoe UI Symbol\",\"Noto Color Emoji\";\n}\n\nticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,\"Liberation Mono\",\"Courier New\",monospace;\n}\n\n", cssExtra = ""}, renderStyle = Compact} data MarkupOptions = MarkupOptions - { markupHeight :: Double, + { markupHeight :: Maybe Double, + chartAspect :: ChartAspect, cssOptions :: CssOptions, renderStyle :: RenderStyle } @@ -402,13 +413,25 @@ -- | The official markup options defaultMarkupOptions :: MarkupOptions -defaultMarkupOptions = MarkupOptions 300 defaultCssOptions Compact +defaultMarkupOptions = MarkupOptions (Just 300) (FixedAspect 1.5) defaultCssOptions Compact --- | CSS shape rendering options -data CssShapeRendering = UseGeometricPrecision | UseCssCrisp | NoShapeRendering deriving (Show, Eq, Generic) +-- | default fonts. +defaultCssFontFamilies :: ByteString +defaultCssFontFamilies = + [i| +svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji"; +} +ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace; +} + +|] + +-- | CSS glyphShape rendering options +data ShapeRendering = UseGeometricPrecision | UseCssCrisp | NoShapeRendering deriving (Show, Eq, Generic) + -- | CSS prefer-color-scheme options -data CssPreferColorScheme +data PreferColorScheme = -- | includes css that switches approriate hud elements between light and dark. PreferHud | PreferDark @@ -419,12 +442,12 @@ -- | css options -- -- >>> defaultCssOptions --- CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, cssExtra = ""} -data CssOptions = CssOptions {shapeRendering :: CssShapeRendering, preferColorScheme :: CssPreferColorScheme, cssExtra :: ByteString} deriving (Show, Eq, Generic) +-- CssOptions {shapeRendering = NoShapeRendering, preferColorScheme = PreferHud, fontFamilies = "\nsvg { font-family: system-ui,-apple-system,\"Segoe UI\",Roboto,\"Helvetica Neue\",Arial,\"Noto Sans\",\"Liberation Sans\",sans-serif,\"Apple Color Emoji\",\"Segoe UI Emoji\",\"Segoe UI Symbol\",\"Noto Color Emoji\";\n}\n\nticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,\"Liberation Mono\",\"Courier New\",monospace;\n}\n\n", cssExtra = ""} +data CssOptions = CssOptions {shapeRendering :: ShapeRendering, preferColorScheme :: PreferColorScheme, fontFamilies :: ByteString, cssExtra :: ByteString} deriving (Show, Eq, Generic) -- | No special shape rendering and default hud responds to user color scheme preferences. defaultCssOptions :: CssOptions -defaultCssOptions = CssOptions NoShapeRendering PreferHud mempty +defaultCssOptions = CssOptions NoShapeRendering PreferHud defaultCssFontFamilies mempty -- | Convert CssOptions to Markup markupCssOptions :: CssOptions -> Markup @@ -432,49 +455,66 @@ elementc "style" [] $ cssPreferColorScheme (light, dark) (view #preferColorScheme css) <> markupShapeRendering (view #shapeRendering css) + <> view #fontFamilies css <> view #cssExtra css -- | CSS shape rendering text snippet -markupShapeRendering :: CssShapeRendering -> ByteString +markupShapeRendering :: ShapeRendering -> ByteString markupShapeRendering UseGeometricPrecision = "svg { shape-rendering: geometricPrecision; }" markupShapeRendering UseCssCrisp = "svg { shape-rendering: crispEdges; }" markupShapeRendering NoShapeRendering = mempty --- | A product type representing charts, hud options and markup options, which can be transformed into 'Markup'. +-- | A product type consisting of a 'ChartTree', 'HudOptions' and 'MarkupOptions', which is what you need to create 'Markup'. data ChartOptions = ChartOptions { markupOptions :: MarkupOptions, hudOptions :: HudOptions, - charts :: ChartTree + chartTree :: ChartTree } deriving (Generic, Eq, Show) +-- | Processes the hud options and turns them into charts, rescales the existing charts, resets the hud options to mempty, and turns on 'ScalePArea' in chart styles. +-- +-- Note that this is a destructive operation, and, in particular, that +-- +-- > view #chartTree (forgetHud (mempty & set #chartTree c)) /= c +forgetHud :: ChartOptions -> ChartOptions +forgetHud co = + co + & set #hudOptions mempty + & set #chartTree (addHud (view (#markupOptions % #chartAspect) co) (view #hudOptions co) (view #chartTree co)) + & set (#chartTree % charts' % each % #chartStyle % #scaleP) ScalePArea + -- | Convert ChartOptions to Markup -- -- >>> markupChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) & markdown_ Compact Xml --- "" +-- "" markupChartOptions :: ChartOptions -> Markup markupChartOptions co = header (view (#markupOptions % #markupHeight) co) viewbox ( markupCssOptions (view (#markupOptions % #cssOptions) co) - <> markupChartTree csAndHud + <> markupChartTree ctFinal ) where - viewbox = singletonGuard (view styleBox' csAndHud) - csAndHud = addHud (view #hudOptions co) (view #charts co) + viewbox = view safeStyleBox' ctFinal + ctFinal = + projectChartTreeWith + (view (#markupOptions % #chartAspect) co) + (view #hudOptions co) + (view #chartTree co) -- | Render ChartOptions to an SVG ByteString -- -- >>> encodeChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) --- "" +-- "" encodeChartOptions :: ChartOptions -> ByteString encodeChartOptions co = markdown_ (view (#markupOptions % #renderStyle) co) Xml $ markupChartOptions co -- | Render ChartOptions to an SVG Text snippet -- -- >>> renderChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) --- "" +-- "" renderChartOptions :: ChartOptions -> Text renderChartOptions = decodeUtf8 . encodeChartOptions diff --git a/src/Chart/Primitive.hs b/src/Chart/Primitive.hs --- a/src/Chart/Primitive.hs +++ b/src/Chart/Primitive.hs @@ -1,17 +1,34 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} -- | Base 'Chart' and 'ChartTree' types and support module Chart.Primitive ( -- * Charts Chart (..), + ChartData (..), + rectData', + lineData', + glyphData', + textData', + pathData', + blankData', + pattern RectChart, + pattern LineChart, + pattern GlyphChart, + pattern TextChart, + pattern PathChart, + pattern BlankChart, + pattern LineChart1, + blankChart1, ChartTree (..), tree', chart', charts', named, unnamed, + renamed, rename, blank, group, @@ -25,16 +42,19 @@ box, sbox, projectWith, - maybeProjectWith, + projectChartDataWith, + moveChartData, moveChart, scaleChart, - scaleStyle, - colourChart, + scaleChartData, + colourStyle, projectChartTree, boxes, box', styleBoxes, styleBox', + safeBox', + safeStyleBox', -- * Combinators vert, @@ -45,8 +65,6 @@ padChart, rectangularize, glyphize, - overText, - renamed, ) where @@ -61,7 +79,6 @@ import Data.Text (Text) import Data.Tree import GHC.Generics -import NumHask.Prelude qualified as NH import Optics.Core import Prelude @@ -73,43 +90,169 @@ -- >>> import Optics.Core -- >>> let r = RectChart defaultRectStyle [one] --- | There are 6 Chart primitives, unified as the Chart type. --- --- - 'RectChart': a rectangle in the XY-domain. For example, a @'Rect' 0 1 0 1@ is the set of points on the XY Plane bounded by (0,0), (0,1), (1,0) & (1,1). Much of the library is built on 'Rect' 'Double's but the base types are polymorphic. --- - 'LineChart': a list of points which represent connected straight lines. ['Point' 0 0, 'Point' 1 1, 'Point' 2 2, 'Point' 3 3] is an example; three lines connected up to form a line from (0,0) to (3,3). --- - 'GlyphChart': a 'GlyphShape' which is a predefined shaped centered at a 'Point' in XY space. --- - 'TextChart': text centered at a 'Point' in XY space. --- - 'PathChart': specification of curvilinear paths using the SVG standards. --- - 'BlankChart': a rectangular space that has no visual representation. --- --- What is a Chart is usually a combination of these primitives into a tree or list of charts. --- --- Each Chart primitive is a product of a style (the syntactic representation of the data) and a list of data. +-- | A product type consisting of a 'Style', which is the stylistic manifestation of chart data, and 'ChartData' representing where data is located on the chart canvas (an xy-plane). -- -- A simple example is: -- --- >>> let r = RectChart defaultRectStyle [one] +-- >>> let r = Chart defaultRectStyle (RectData [one]) -- >>> r --- RectChart (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10}) [Rect -0.5 0.5 -0.5 0.5] +-- Chart {chartStyle = Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 0.10, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, chartData = RectData [Rect (-0.5) 0.5 (-0.5) 0.5]} -- -- Using the defaults, this chart is rendered as: -- --- > writeChartOptions "other/unit.hs" $ mempty & #hudOptions .~ defaultHudOptions & #charts .~ unnamed [r] +-- > writeChartOptions "other/unit.hs" $ mempty & #hudOptions .~ defaultHudOptions & #chartTree .~ unnamed [r] -- -- ![unit example](other/unit.svg) -data Chart where - RectChart :: RectStyle -> [Rect Double] -> Chart - LineChart :: LineStyle -> [[Point Double]] -> Chart - GlyphChart :: GlyphStyle -> [Point Double] -> Chart - TextChart :: TextStyle -> [(Text, Point Double)] -> Chart - PathChart :: PathStyle -> [PathData Double] -> Chart - BlankChart :: [Rect Double] -> Chart - deriving (Eq, Show) +data Chart = Chart {chartStyle :: Style, chartData :: ChartData} deriving (Eq, Show, Generic) +-- | Data of a 'Chart' +-- +-- A sum type representing the data behind six different types of chart: +-- +-- - 'RectData': a list of rectangles in the XY-domain. For example, a @'Rect' 0 1 0 1@ is the set of points on the XY Plane bounded by (0,0), (0,1), (1,0) & (1,1). Much of the library is built on 'Rect' Doubles. +-- - 'LineData': a list of (list of points) which represent connected straight lines. ['Point' 0 0, 'Point' 1 1, 'Point' 2 2, 'Point' 3 3] is an example; three lines connected up to form a line from (0,0) to (3,3). +-- - 'GlyphData': a list of points to draw a 'GlyphShape'. +-- - 'TextData': A list of Text,Point tuples representing text centered at a 'Point' in XY space. +-- - 'PathData': specification of curvilinear paths using the SVG standards. +-- - 'BlankData': a rectangular space that has no visual representation. +data ChartData + = -- | List of rectangles + RectData [Rect Double] + | -- | List of (List of Points) + LineData [[Point Double]] + | -- | List of Points (to place the 'GlyphShape') + GlyphData [Point Double] + | -- | List of text and point to place it. + TextData [(Text, Point Double)] + | -- | List of paths + PathData [PathData Double] + | -- | List of rectangles with no 'Style' representation + BlankData [Rect Double] + deriving (Eq, Show, Generic) + +-- | RectData partial lens +rectData' :: Lens' ChartData (Maybe [Rect Double]) +rectData' = + lens getData setData + where + getData (RectData xs) = Just xs + getData _ = Nothing + setData (RectData _) (Just xs) = RectData xs + setData cd _ = cd + +-- | LineData partial lens +lineData' :: Lens' ChartData (Maybe [[Point Double]]) +lineData' = + lens getData setData + where + getData (LineData xs) = Just xs + getData _ = Nothing + setData (LineData _) (Just xs) = LineData xs + setData cd _ = cd + +-- | GlyphData partial lens +glyphData' :: Lens' ChartData (Maybe [Point Double]) +glyphData' = + lens getData setData + where + getData (GlyphData xs) = Just xs + getData _ = Nothing + setData (GlyphData _) (Just xs) = GlyphData xs + setData cd _ = cd + +-- | TextData partial lens +textData' :: Lens' ChartData (Maybe [(Text, Point Double)]) +textData' = + lens getData setData + where + getData (TextData xs) = Just xs + getData _ = Nothing + setData (TextData _) (Just xs) = TextData xs + setData cd _ = cd + +-- | PathData partial lens +pathData' :: Lens' ChartData (Maybe [PathData Double]) +pathData' = + lens getData setData + where + getData (PathData xs) = Just xs + getData _ = Nothing + setData (PathData _) (Just xs) = PathData xs + setData cd _ = cd + +-- | BlankData partial lens +blankData' :: Lens' ChartData (Maybe [Rect Double]) +blankData' = + lens getData setData + where + getData (BlankData xs) = Just xs + getData _ = Nothing + setData (BlankData _) (Just xs) = BlankData xs + setData cd _ = cd + +-- | pattern of a Chart with RectData +pattern RectChart :: Style -> [Rect Double] -> Chart +pattern RectChart s xs = Chart s (RectData xs) + +{-# COMPLETE RectChart #-} + +-- | pattern of a Chart with LineData +pattern LineChart :: Style -> [[Point Double]] -> Chart +pattern LineChart s xss = Chart s (LineData xss) + +{-# COMPLETE LineChart #-} + +-- | pattern of a Chart with a singleton LineData +pattern LineChart1 :: Style -> [Point Double] -> Chart +pattern LineChart1 s xs = Chart s (LineData [xs]) + +{-# COMPLETE LineChart1 #-} + +-- | pattern of a Chart with GlyphData +pattern GlyphChart :: Style -> [Point Double] -> Chart +pattern GlyphChart s xs = Chart s (GlyphData xs) + +{-# COMPLETE GlyphChart #-} + +-- | pattern of a Chart with TextData +pattern TextChart :: Style -> [(Text, Point Double)] -> Chart +pattern TextChart s xs = Chart s (TextData xs) + +{-# COMPLETE TextChart #-} + +-- | pattern of a Chart with PathData +pattern PathChart :: Style -> [PathData Double] -> Chart +pattern PathChart s xs = Chart s (PathData xs) + +{-# COMPLETE PathChart #-} + +-- | pattern of a Chart with BlankData +pattern BlankChart :: Style -> [Rect Double] -> Chart +pattern BlankChart s xs = Chart s (BlankData xs) + +{-# COMPLETE BlankChart #-} + +-- | Create a blank Chart with a single Rect +blankChart1 :: Rect Double -> Chart +blankChart1 r = Chart defaultStyle (BlankData [r]) + -- | A group of charts represented by a 'Tree' of chart lists with labelled branches. The labelling is particularly useful downstream, when groupings become grouped SVG elements with classes or ids. newtype ChartTree = ChartTree {tree :: Tree (Maybe Text, [Chart])} deriving (Eq, Show, Generic) --- | Apply a filter to ChartTree +-- | Group a list of trees into a new tree. +group :: Maybe Text -> [ChartTree] -> ChartTree +group name cs = ChartTree $ Node (name, []) (tree <$> cs) + +instance Semigroup ChartTree where + (<>) (ChartTree x@(Node (n, cs) xs)) (ChartTree x'@(Node (n', cs') xs')) = + case (n, n') of + (Nothing, Nothing) -> ChartTree $ Node (Nothing, cs <> cs') (xs <> xs') + _ -> ChartTree $ Node (Nothing, []) [x, x'] + +instance Monoid ChartTree where + mempty = ChartTree $ Node (Nothing, []) [] + +-- | Apply a filter to a 'ChartTree' filterChartTree :: (Chart -> Bool) -> ChartTree -> ChartTree filterChartTree p (ChartTree (Node (a, cs) xs)) = ChartTree (Node (a, mapMaybe rem' cs) (tree . filterChartTree p . ChartTree <$> xs)) @@ -146,20 +289,7 @@ -- | A tree with no charts and no label. blank :: Rect Double -> ChartTree -blank r = unnamed [BlankChart [r]] - --- | Group a list of trees into a new tree. -group :: Maybe Text -> [ChartTree] -> ChartTree -group name cs = ChartTree $ Node (name, []) (tree <$> cs) - -instance Semigroup ChartTree where - (<>) (ChartTree x@(Node (n, cs) xs)) (ChartTree x'@(Node (n', cs') xs')) = - case (n, n') of - (Nothing, Nothing) -> ChartTree $ Node (Nothing, cs <> cs') (xs <> xs') - _ -> ChartTree $ Node (Nothing, []) [x, x'] - -instance Monoid ChartTree where - mempty = ChartTree $ Node (Nothing, []) [] +blank r = unnamed [Chart defaultStyle (BlankData [r])] -- $boxes -- @@ -167,114 +297,91 @@ -- | The 'Rect' which encloses the data elements of the chart. /Bounding box/ is a synonym. -- --- >>> box r --- Just Rect -0.5 0.5 -0.5 0.5 -box :: Chart -> Maybe (Rect Double) -box (RectChart _ a) = foldRect a -box (TextChart _ a) = space1 $ snd <$> a -box (LineChart _ a) = space1 $ mconcat a -box (GlyphChart _ a) = space1 a -box (PathChart _ a) = pathBoxes a -box (BlankChart a) = foldRect a +-- >>> box (chartData r) +-- Just Rect (-0.5) 0.5 (-0.5) 0.5 +box :: ChartData -> Maybe (Rect Double) +box (RectData a) = foldRect a +box (TextData a) = space1 $ snd <$> a +box (LineData a) = space1 $ mconcat a +box (GlyphData a) = space1 a +box (PathData a) = pathBoxes a +box (BlankData a) = foldRect a -- | The bounding box for a chart including both data and style elements. -- -- >>> sbox r --- Just Rect -0.505 0.505 -0.505 0.505 +-- Just Rect (-0.505) 0.505 (-0.505) 0.505 -- -- In the above example, the border of the rectangle adds an extra 0.1 to the height and width of the bounding box enclosing the chart. sbox :: Chart -> Maybe (Rect Double) -sbox (RectChart s a) = foldRect $ padRect (0.5 * view #borderSize s) <$> a -sbox (TextChart s a) = foldRect $ uncurry (styleBoxText s) <$> a -sbox (LineChart s a) = padRect (0.5 * s ^. #size) <$> (space1 $ mconcat a) -sbox (GlyphChart s a) = foldRect $ (\p -> addPoint p (styleBoxGlyph s)) <$> a -sbox (PathChart s a) = padRect (0.5 * view #borderSize s) <$> pathBoxes a -sbox (BlankChart a) = foldRect a +sbox (Chart s (RectData a)) = foldRect $ padRect (0.5 * view #borderSize s) <$> a +sbox (Chart s (TextData a)) = foldRect $ uncurry (styleBoxText s) <$> a +sbox (Chart s (LineData a)) = padRect (0.5 * view #size s) <$> (space1 $ mconcat a) +sbox (Chart s (GlyphData a)) = foldRect $ (\x -> addPoint x (styleBoxGlyph s)) <$> a +sbox (Chart s (PathData a)) = padRect (0.5 * view #borderSize s) <$> pathBoxes a +sbox (Chart _ (BlankData a)) = foldRect a -- | projects a Chart to a new space from an old rectangular space, preserving linear metric structure. -- -- >>> projectWith (fmap (2*) one) one r --- RectChart (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10}) [Rect -1.0 1.0 -1.0 1.0] +-- Chart {chartStyle = Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 0.10, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, chartData = RectData [Rect (-1.0) 1.0 (-1.0) 1.0]} projectWith :: Rect Double -> Rect Double -> Chart -> Chart -projectWith new old (RectChart s a) = RectChart s (projectOnR new old <$> a) -projectWith new old (TextChart s a) = TextChart (projectX s) (second (projectOnP new old) <$> a) - where - projectX :: TextStyle -> TextStyle - projectX s' = case view #scalex s' of - NoScaleX -> s' & over #hsize (* (width ox / width nx)) & over #vsize (* (width ox / width nx)) - ScaleX -> s' & over #size (* (width nx / width ox)) - (Ranges nx _) = new - (Ranges ox _) = old -projectWith new old (LineChart s a) = LineChart s (fmap (projectOnP new old) <$> a) -projectWith new old (GlyphChart s a) = GlyphChart s (projectOnP new old <$> a) -projectWith new old (BlankChart a) = BlankChart (projectOnR new old <$> a) -projectWith new old (PathChart s a) = PathChart s (projectPaths new old a) +projectWith new old c = c & over #chartStyle (scaleStyle (scaleRatio (view (#chartStyle % #scaleP) c) new old)) & over #chartData (projectChartDataWith new old) --- | Maybe project a Chart to a new rectangular space from an old rectangular space, if both Rects exist. -maybeProjectWith :: Maybe (Rect Double) -> Maybe (Rect Double) -> Chart -> Chart -maybeProjectWith new old = fromMaybe id (projectWith <$> new <*> old) +-- | Projects 'ChartData' from an old space to a new space. +projectChartDataWith :: Rect Double -> Rect Double -> ChartData -> ChartData +projectChartDataWith new old (RectData a) = RectData (projectOnR new old <$> a) +projectChartDataWith new old (TextData a) = TextData (second (projectOnP new old) <$> a) +projectChartDataWith new old (LineData a) = LineData (fmap (projectOnP new old) <$> a) +projectChartDataWith new old (GlyphData a) = GlyphData (projectOnP new old <$> a) +projectChartDataWith new old (PathData a) = PathData (projectPaths new old a) +projectChartDataWith new old (BlankData a) = BlankData (projectOnR new old <$> a) +-- | Move 'ChartData' by a 'Point' +moveChartData :: Point Double -> ChartData -> ChartData +moveChartData p (RectData a) = RectData (addPoint p <$> a) +moveChartData p (TextData a) = TextData (second (addp p) <$> a) +moveChartData p (LineData a) = LineData (fmap (addp p) <$> a) +moveChartData p (GlyphData a) = GlyphData (addp p <$> a) +moveChartData p (PathData a) = PathData (movePath p <$> a) +moveChartData p (BlankData a) = BlankData (addPoint p <$> a) + -- | Move a chart. moveChart :: Point Double -> Chart -> Chart -moveChart p (RectChart s a) = RectChart s (addPoint p <$> a) -moveChart p (TextChart s a) = TextChart s (second (addp p) <$> a) -moveChart p (LineChart s a) = LineChart s (fmap (addp p) <$> a) -moveChart p (GlyphChart s a) = GlyphChart s (addp p <$> a) -moveChart p (PathChart s a) = PathChart s (movePath p <$> a) -moveChart p (BlankChart a) = BlankChart (addPoint p <$> a) +moveChart p c = c & over #chartData (moveChartData p) --- | Scale a chart (effecting both the chart data and the style). -scaleChart :: Double -> Chart -> Chart -scaleChart p (RectChart s a) = - RectChart (s & #borderSize %~ (* p)) (fmap (fmap (* p)) a) -scaleChart p (LineChart s a) = - LineChart (s & #size %~ (* p)) (fmap (fmap (fmap (* p))) a) -scaleChart p (TextChart s a) = - TextChart (s & #size %~ (* p)) (fmap (second (fmap (* p))) a) -scaleChart p (GlyphChart s a) = - GlyphChart (s & #size %~ (* p)) (fmap (fmap (* p)) a) -scaleChart p (PathChart s a) = - PathChart (s & #borderSize %~ (* p)) (scalePath p <$> a) -scaleChart p (BlankChart a) = - BlankChart (fmap (fmap (* p)) a) +-- | Scale 'ChartData' +scaleChartData :: Double -> ChartData -> ChartData +scaleChartData p (RectData a) = + RectData (fmap (fmap (* p)) a) +scaleChartData p (LineData a) = + LineData (fmap (fmap (fmap (* p))) a) +scaleChartData p (TextData a) = + TextData (fmap (second (fmap (* p))) a) +scaleChartData p (GlyphData a) = + GlyphData (fmap (fmap (* p)) a) +scaleChartData p (PathData a) = + PathData (scalePath p <$> a) +scaleChartData p (BlankData a) = + BlankData (fmap (fmap (* p)) a) --- | Scale just the chart style. -scaleStyle :: Double -> Chart -> Chart -scaleStyle x (LineChart a d) = LineChart (a & #size %~ (* x)) d -scaleStyle x (RectChart a d) = RectChart (a & #borderSize %~ (* x)) d -scaleStyle x (TextChart a d) = TextChart (a & #size %~ (* x)) d -scaleStyle x (GlyphChart a d) = GlyphChart (a & #size %~ (* x)) d -scaleStyle x (PathChart a d) = PathChart (a & #borderSize %~ (* x)) d -scaleStyle _ (BlankChart d) = BlankChart d +-- | Scale a chart (effecting both the chart data and the style, if /#style % #scaleP/ is a scaling value). +scaleChart :: Double -> Chart -> Chart +scaleChart p c = c & over #chartData (scaleChartData p) & over #chartStyle (bool (scaleStyle p) id (view (#chartStyle % #scaleP) c == NoScaleP)) -- | Modify chart colors, applying to both border and main colors. -colourChart :: (Colour -> Colour) -> Chart -> Chart -colourChart f (RectChart s d) = RectChart s' d - where - s' = s & #color %~ f & #borderColor %~ f -colourChart f (TextChart s d) = TextChart s' d - where - s' = s & #color %~ f -colourChart f (LineChart s d) = LineChart s' d - where - s' = s & #color %~ f -colourChart f (GlyphChart s d) = GlyphChart s' d - where - s' = s & #color %~ f & #borderColor %~ f -colourChart f (PathChart s d) = PathChart s' d - where - s' = s & #color %~ f & #borderColor %~ f -colourChart _ (BlankChart d) = BlankChart d +colourStyle :: (Colour -> Colour) -> Style -> Style +colourStyle f s = s & over #color f & over #borderColor f -- | Project a chart tree to a new bounding box, guarding against singleton bounds. -projectChartTree :: Rect Double -> [Chart] -> [Chart] -projectChartTree new cs = case styleBoxes cs of - Nothing -> cs - Just b -> projectWith new b <$> cs +projectChartTree :: Rect Double -> ChartTree -> ChartTree +projectChartTree new ct = case view styleBox' ct of + Nothing -> ct + Just b -> ct & over charts' (fmap (projectWith new b)) --- | Compute the bounding box of a list of charts. +-- | Compute the bounding box of a list of charts, not including style allowances. boxes :: [Chart] -> Maybe (Rect Double) -boxes cs = foldRect $ mconcat $ maybeToList . box <$> cs +boxes cs = foldRect $ mconcat $ maybeToList . box <$> (chartData <$> cs) box_ :: ChartTree -> Maybe (Rect Double) box_ = boxes . foldOf charts' @@ -299,38 +406,51 @@ styleRebox_ :: ChartTree -> Maybe (Rect Double) -> ChartTree styleRebox_ cs r = cs - & over chart' (fromMaybe id $ projectWith <$> r' <*> box_ cs) - where - r' = (NH.-) <$> r <*> ((NH.-) <$> styleBox_ cs <*> box_ cs) + & over chart' (fromMaybe id $ projectWith <$> r <*> styleBox_ cs) -- | Lens between a style bounding box and a ChartTree tree. -- -- Note that a round trip may be only approximately isomorphic ie -- --- > forall c r. \c -> view styleBox' . set styleBox r c ~= r +-- > forall c r. \c -> view styleBox' . set styleBox' r c ~= r styleBox' :: Lens' ChartTree (Maybe (Rect Double)) styleBox' = lens styleBox_ styleRebox_ +-- | Getter of a ChartTree bounding box, including style, with singleton dimension guards, defaulting to one: +safeStyleBox' :: Getter ChartTree (Rect Double) +safeStyleBox' = Optics.Core.to (safeBox_ styleBox') + +-- | Getter of a ChartTree bounding box, excluding style, with singleton dimension guards, defaulting to one: +safeBox' :: Getter ChartTree (Rect Double) +safeBox' = Optics.Core.to (safeBox_ box') + +safeBox_ :: Lens' ChartTree (Maybe (Rect Double)) -> ChartTree -> Rect Double +safeBox_ l ct + | b == Nothing || (Just True == fmap isSingleton b) = maybe one padSingletons (view l ct) + | otherwise = fromMaybe one b + where + b = view l ct + -- | Create a frame over some charts with (additive) padding. -- --- >>> frameChart defaultRectStyle 0.1 [BlankChart []] --- RectChart (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10}) [] -frameChart :: RectStyle -> Double -> [Chart] -> Chart -frameChart rs p cs = RectChart rs (maybeToList (padRect p <$> styleBoxes cs)) +-- >>> frameChart defaultRectStyle 0.1 (unnamed [BlankChart defaultStyle []]) +-- ChartTree {tree = Node {rootLabel = (Just "frame",[Chart {chartStyle = Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 0.10, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}, chartData = RectData []}]), subForest = []}} +frameChart :: Style -> Double -> ChartTree -> ChartTree +frameChart rs p cs = named "frame" [Chart rs (RectData (maybeToList (padRect p <$> view styleBox' cs)))] -- | Additive padding, framing or buffering for a chart list. -padChart :: Double -> [Chart] -> Chart -padChart p cs = BlankChart (maybeToList (padRect p <$> styleBoxes cs)) +padChart :: Double -> ChartTree -> ChartTree +padChart p ct = named "padding" [Chart defaultStyle (BlankData (maybeToList (padRect p <$> view styleBox' ct)))] -- | Whether a chart is empty of data to be represented. -isEmptyChart :: Chart -> Bool -isEmptyChart (RectChart _ []) = True -isEmptyChart (LineChart _ []) = True -isEmptyChart (GlyphChart _ []) = True -isEmptyChart (TextChart _ []) = True -isEmptyChart (PathChart _ []) = True -isEmptyChart (BlankChart _) = True +isEmptyChart :: ChartData -> Bool +isEmptyChart (RectData []) = True +isEmptyChart (LineData []) = True +isEmptyChart (GlyphData []) = True +isEmptyChart (TextData []) = True +isEmptyChart (PathData []) = True +isEmptyChart (BlankData _) = True isEmptyChart _ = False -- | Horizontally stack a list of trees (proceeding to the right) with a gap between @@ -359,39 +479,35 @@ [] -> zero xs -> maybe zero (\(Rect x' _ _ _) -> x') (styleBoxes xs) --- | Stack a list of tree charts horizontally, then vertically +-- | Stack a list of tree charts horizontally, then vertically (proceeding downwards which is opposite to the usual coordinate reference system but intuitively the way people read charts) stack :: Int -> Double -> [ChartTree] -> ChartTree stack _ _ [] = mempty -stack n gap cs = vert gap (hori gap <$> group' cs []) +stack n gap cs = vert gap (reverse $ hori gap <$> group' cs []) where group' [] acc = reverse acc group' x acc = group' (drop n x) (take n x : acc) -- | Make a new chart tree out of the bounding boxes of a chart tree. -rectangularize :: RectStyle -> ChartTree -> ChartTree -rectangularize r c = group (Just "rectangularize") [over chart' (rectangularize_ r) c] - -rectangularize_ :: RectStyle -> Chart -> Chart -rectangularize_ rs (TextChart s xs) = TextChart (s & #frame .~ Just rs) xs -rectangularize_ rs c = RectChart rs (maybeToList $ sbox c) +-- +-- This includes any extra space for style elements. +rectangularize :: Style -> ChartTree -> ChartTree +rectangularize r ct = group (Just "rectangularize") [over chart' (\c -> set #chartStyle r $ set #chartData (rectangularize_ c) c) ct] --- | Make a new chart tree out of the data points of a chart tree, using the supplied glyphs. -glyphize :: GlyphStyle -> ChartTree -> ChartTree -glyphize g c = - group (Just "glyphize") [over chart' (glyphize_ g) c] +rectangularize_ :: Chart -> ChartData +rectangularize_ c = RectData (maybeToList $ sbox c) -glyphize_ :: GlyphStyle -> Chart -> Chart -glyphize_ g (TextChart _ xs) = GlyphChart g (snd <$> xs) -glyphize_ g (PathChart _ xs) = GlyphChart g (pointPath <$> xs) -glyphize_ g (LineChart _ xs) = GlyphChart g (mconcat xs) -glyphize_ g (BlankChart xs) = GlyphChart g (mid <$> xs) -glyphize_ g (RectChart _ xs) = GlyphChart g (mid <$> xs) -glyphize_ g (GlyphChart _ xs) = GlyphChart g xs +-- | Make a new chart tree out of the data points of a chart tree, using the supplied style (for glyphs). +glyphize :: Style -> ChartTree -> ChartTree +glyphize s ct = + group (Just "glyphize") [over chart' (set #chartStyle s . over #chartData pointize_) ct] --- | Modify the text in a text chart. -overText :: (TextStyle -> TextStyle) -> Chart -> Chart -overText f (TextChart s xs) = TextChart (f s) xs -overText _ x = x +pointize_ :: ChartData -> ChartData +pointize_ (TextData xs) = GlyphData (snd <$> xs) +pointize_ (PathData xs) = GlyphData (pointPath <$> xs) +pointize_ (LineData xs) = GlyphData (mconcat xs) +pointize_ (BlankData xs) = GlyphData (mid <$> xs) +pointize_ (RectData xs) = GlyphData (mid <$> xs) +pointize_ (GlyphData xs) = GlyphData xs -- | Verticle or Horizontal data Orientation = Vert | Hori deriving (Eq, Show, Generic) @@ -409,4 +525,6 @@ CanvasAspect Double | -- | Rescale charts to a height of 1, preserving the existing x-y ratio of the underlying charts, inclusive of hud and style. ChartAspect + | -- | Do not rescale charts. The style values should make sense in relation to the data ranges. + UnscaledAspect deriving (Show, Eq, Generic) diff --git a/src/Chart/Style.hs b/src/Chart/Style.hs --- a/src/Chart/Style.hs +++ b/src/Chart/Style.hs @@ -2,32 +2,30 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} --- | Stylistic or syntactical options for chart elements. +-- | Definition of the syntactical manifestation of chart elements. module Chart.Style - ( -- * RectStyle - RectStyle (..), + ( Style (..), + defaultStyle, + scaleStyle, + + -- * RectStyle defaultRectStyle, blob, clear, border, -- * TextStyle - TextStyle (..), defaultTextStyle, styleBoxText, - ScaleX (..), + EscapeText (..), -- * GlyphStyle - GlyphStyle (..), defaultGlyphStyle, styleBoxGlyph, - gpalette1, - ScaleBorder (..), + gpalette, GlyphShape (..), - glyphText, -- * LineStyle - LineStyle (..), defaultLineStyle, LineCap (..), fromLineCap, @@ -40,12 +38,16 @@ toAnchor, -- * PathStyle - PathStyle (..), defaultPathStyle, + + -- * Style scaling + ScaleP (..), + scaleRatio, ) where import Chart.Data +import Data.Bool import Data.ByteString (ByteString) import Data.Colour import Data.List qualified as List @@ -56,6 +58,7 @@ import Data.Text (Text) import Data.Text qualified as Text import GHC.Generics +import NumHask.Space import Optics.Core import Prelude @@ -66,63 +69,123 @@ -- >>> import Chart -- >>> import Optics.Core --- | Rectangle styling --- --- >>> defaultRectStyle --- RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.02 0.73 0.80 0.10} +-- | Stylistic content of chart elements, involving how chart data is represented in the physical chart. -- --- ![unit example](other/unit.svg) -data RectStyle = RectStyle - { borderSize :: Double, +-- >>> defaultStyle +-- Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 0.10, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +data Style = Style + { -- | The size of the element in relation to the canvas domain. + size :: Double, + -- | stroke-width + borderSize :: Double, + -- | fill & fill-opacity + color :: Colour, + -- | stroke & stroke-opacity borderColor :: Colour, - color :: Colour + -- | How to treat scale projections. + scaleP :: ScaleP, + -- | text-anchor + anchor :: Anchor, + -- | element rotation is radians + rotation :: Maybe Double, + -- | element translation + translate :: Maybe (Point Double), + -- | whether to html-like escape text + escapeText :: EscapeText, + -- | rectangular frame around an element. + frame :: Maybe Style, + -- | stroke-linecap + lineCap :: Maybe LineCap, + -- | stroke-linejoin + lineJoin :: Maybe LineJoin, + -- | stroke-dasharray + dasharray :: Maybe [Double], + -- | stroke-dashoffset + dashoffset :: Maybe Double, + -- | horizontal scaling modifier for text + hsize :: Double, + -- | vertical scaling modifier for text + vsize :: Double, + -- | horizontal shift for text alignment + vshift :: Double, + -- | shape for glyph chart elements + glyphShape :: GlyphShape } - deriving (Show, Eq, Generic) + deriving (Eq, Show, Generic) --- | the style -defaultRectStyle :: RectStyle -defaultRectStyle = RectStyle 0.01 (palette1a 1 1) (palette1a 0 0.1) +-- | The official default style +-- +-- >>> defaultStyle +-- Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 0.10, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +defaultStyle :: Style +defaultStyle = Style 0.06 0.01 (paletteO 0 0.1) (paletteO 1 1) NoScaleP AnchorMiddle Nothing Nothing EscapeText Nothing Nothing Nothing Nothing Nothing 0.6 1.1 (-0.25) SquareGlyph +-- | The official style for rectangles. +-- +-- >>> defaultRectStyle +-- Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.02 0.73 0.80 0.10, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +defaultRectStyle :: Style +defaultRectStyle = defaultStyle + +-- | The official style for text elements. +-- +-- >>> defaultTextStyle +-- Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.05 0.05 0.05 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +defaultTextStyle :: Style +defaultTextStyle = defaultStyle & set #size 0.06 & set #color dark + +-- | The official style for glyphs. +-- +-- >>> defaultGlyphStyle +-- Style {size = 3.0e-2, borderSize = 3.0e-3, color = Colour 0.02 0.73 0.80 0.20, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +defaultGlyphStyle :: Style +defaultGlyphStyle = defaultStyle & set #size 0.03 & set #color (paletteO 0 0.2) & set #borderColor (set lightness' 0.4 $ paletteO 1 1) & set #borderSize 0.003 + +-- | The official style for lines. +-- +-- >>> defaultLineStyle +-- Style {size = 1.2e-2, borderSize = 1.0e-2, color = Colour 0.05 0.05 0.05 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +defaultLineStyle :: Style +defaultLineStyle = defaultStyle & set #size 0.012 & set #color dark + +-- | The official style for paths. +-- +-- >>> defaultPathStyle +-- Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.66 0.07 0.55 1.00, borderColor = Colour 0.02 0.29 0.48 1.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +defaultPathStyle :: Style +defaultPathStyle = defaultStyle & set #color (palette 2) & set #borderColor (palette 1) + +-- | Scale the size, borderSize and any translations of a 'Style'. +scaleStyle :: Double -> Style -> Style +scaleStyle x s = + s + & over #size (x *) + & over #borderSize (x *) + & over #translate (fmap (fmap (x *))) + -- | solid rectangle, no border -- -- >>> blob black --- RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 1.00} -blob :: Colour -> RectStyle -blob = RectStyle 0 transparent +-- Style {size = 6.0e-2, borderSize = 0.0, color = Colour 0.00 0.00 0.00 1.00, borderColor = Colour 0.00 0.00 0.00 0.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +blob :: Colour -> Style +blob c = defaultRectStyle & set #borderSize 0 & set #borderColor transparent & set #color c -- | transparent rect -- -- >>> clear --- RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 0.00} -clear :: RectStyle -clear = RectStyle 0 transparent transparent +-- Style {size = 6.0e-2, borderSize = 0.0, color = Colour 0.00 0.00 0.00 0.00, borderColor = Colour 0.00 0.00 0.00 0.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +clear :: Style +clear = defaultRectStyle & set #borderSize 0 & set #borderColor transparent & set #color transparent -- | transparent rectangle, with border -- -- >>> border 0.01 transparent --- RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.00 0.00 0.00 0.00} -border :: Double -> Colour -> RectStyle -border s c = RectStyle s c transparent - --- | Text styling --- --- >>> defaultTextStyle --- TextStyle {size = 0.12, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing} -data TextStyle = TextStyle - { size :: Double, - color :: Colour, - anchor :: Anchor, - hsize :: Double, - vsize :: Double, - vshift :: Double, - rotation :: Maybe Double, - scalex :: ScaleX, - frame :: Maybe RectStyle - } - deriving (Show, Eq, Generic) +-- Style {size = 6.0e-2, borderSize = 1.0e-2, color = Colour 0.00 0.00 0.00 0.00, borderColor = Colour 0.00 0.00 0.00 0.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph} +border :: Double -> Colour -> Style +border s c = defaultRectStyle & set #borderSize s & set #borderColor c & set #color transparent --- | Whether to scale text given X-axis scaling -data ScaleX = ScaleX | NoScaleX deriving (Eq, Show, Generic) +-- | Whether to escape the common XML escaped characters. +data EscapeText = EscapeText | NoEscapeText deriving (Eq, Show, Generic) -- | position anchor data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic) @@ -140,28 +203,23 @@ toAnchor "End" = AnchorEnd toAnchor _ = AnchorMiddle --- | the offical text style -defaultTextStyle :: TextStyle -defaultTextStyle = - TextStyle 0.12 dark AnchorMiddle 0.45 1.1 (-0.25) Nothing ScaleX Nothing - -- | the extra area from text styling styleBoxText :: - TextStyle -> + Style -> Text -> Point Double -> Rect Double -styleBoxText o t p = mpad $ move p $ maybe flat (`rotationBound` flat) (o ^. #rotation) +styleBoxText o t p = mpad $ move p $ maybe flat (`rotationBound` flat) (view #rotation o) where - flat = Rect ((-x' / 2.0) + x' * a') (x' / 2 + x' * a') (-y' / 2 + n1') (y' / 2 + n1') - s = o ^. #size - h = o ^. #hsize - v = o ^. #vsize - n1 = o ^. #vshift + flat = Rect ((-(x' / 2.0)) + x' * a') (x' / 2 + x' * a') (-(y' / 2 + n1')) (y' / 2 + n1') + s = view #size o + h = view #hsize o + v = view #vsize o + n1 = view #vshift o x' = s * h * fromIntegral (Text.length t) y' = s * v - n1' = -s * n1 - a' = case o ^. #anchor of + n1' = (-s) * n1 + a' = case view #anchor o of AnchorStart -> 0.5 AnchorEnd -> -0.5 AnchorMiddle -> 0.0 @@ -169,42 +227,6 @@ Nothing -> id Just f -> padRect (0.5 * view #borderSize f * view #size o) --- | Glyph styling --- --- >>> defaultGlyphStyle --- GlyphStyle {size = 3.0e-2, color = Colour 0.02 0.73 0.80 0.20, borderColor = Colour 0.02 0.29 0.48 1.00, borderSize = 3.0e-3, shape = SquareGlyph, rotation = Nothing, translate = Nothing} --- --- ![glyph example](other/glyphs.svg) -data GlyphStyle = GlyphStyle - { -- | glyph radius - size :: Double, - -- | fill color - color :: Colour, - -- | stroke color - borderColor :: Colour, - -- | stroke width (adds a bit to the bounding box) - borderSize :: Double, - shape :: GlyphShape, - rotation :: Maybe Double, - translate :: Maybe (Point Double) - } - deriving (Show, Eq, Generic) - --- | the offical glyph style -defaultGlyphStyle :: GlyphStyle -defaultGlyphStyle = - GlyphStyle - 0.03 - (palette1a 0 0.2) - (set lightness' 0.4 $ palette1a 1 1) - 0.003 - SquareGlyph - Nothing - Nothing - --- | Should glyph borders be scaled? -data ScaleBorder = ScaleBorder | NoScaleBorder deriving (Show, Eq, Generic) - -- | glyph shapes data GlyphShape = CircleGlyph @@ -216,50 +238,35 @@ TriangleGlyph (Point Double) (Point Double) (Point Double) | VLineGlyph | HLineGlyph - | PathGlyph ByteString ScaleBorder + | PathGlyph ByteString deriving (Show, Eq, Generic) --- | textifier -glyphText :: GlyphShape -> ByteString -glyphText sh = - case sh of - CircleGlyph -> "Circle" - SquareGlyph -> "Square" - TriangleGlyph {} -> "Triangle" - EllipseGlyph _ -> "Ellipse" - RectSharpGlyph _ -> "RectSharp" - RectRoundedGlyph {} -> "RectRounded" - VLineGlyph -> "VLine" - HLineGlyph -> "HLine" - PathGlyph _ _ -> "Path" - -- | the extra area from glyph styling -styleBoxGlyph :: GlyphStyle -> Rect Double +styleBoxGlyph :: Style -> Rect Double styleBoxGlyph s = move p' $ rot' $ - sw $ case sh of + sw $ case view #glyphShape s of CircleGlyph -> (sz *) <$> one SquareGlyph -> (sz *) <$> one EllipseGlyph a -> scale (Point sz (a * sz)) one RectSharpGlyph a -> scale (Point sz (a * sz)) one RectRoundedGlyph a _ _ -> scale (Point sz (a * sz)) one - VLineGlyph -> scale (Point (s ^. #borderSize) sz) one - HLineGlyph -> scale (Point sz (s ^. #borderSize)) one + VLineGlyph -> scale (Point (view #borderSize s) sz) one + HLineGlyph -> scale (Point sz (view #borderSize s)) one TriangleGlyph a b c -> (sz *) <$> unsafeSpace1 ([a, b, c] :: [Point Double]) - PathGlyph path' _ -> maybe zero (fmap (sz *)) (pathBoxes . svgToPathData $ path') + PathGlyph path' -> maybe zero (fmap (sz *)) (pathBoxes . svgToPathData $ path') where - sh = s ^. #shape - sz = s ^. #size - sw = padRect (0.5 * s ^. #borderSize) - p' = fromMaybe (Point 0.0 0.0) (s ^. #translate) + sz = view #size s + sw = padRect (0.5 * view #borderSize s) + p' = fromMaybe (Point 0.0 0.0) (view #translate s) rot' = maybe id rotationBound (view #rotation s) -- | Infinite list of glyph shapes -- --- >>> gpalette1 0 +-- >>> gpalette 0 -- CircleGlyph -gpalette1 :: Int -> GlyphShape -gpalette1 x = cycle gpalette1_ List.!! x +gpalette :: Int -> GlyphShape +gpalette x = cycle gpalette1_ List.!! x -- | finite list of glyphs gpalette1_ :: [GlyphShape] @@ -272,13 +279,13 @@ VLineGlyph, HLineGlyph, TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), - PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z" ScaleBorder + PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z" ] -- | line cap style data LineCap = LineCapButt | LineCapRound | LineCapSquare deriving (Eq, Show, Generic) --- | textifier +-- | svg textifier fromLineCap :: (IsString s) => LineCap -> s fromLineCap LineCapButt = "butt" fromLineCap LineCapRound = "round" @@ -294,7 +301,7 @@ -- | line cap style data LineJoin = LineJoinMiter | LineJoinBevel | LineJoinRound deriving (Eq, Show, Generic) --- | textifier +-- | svg textifier fromLineJoin :: (IsString s) => LineJoin -> s fromLineJoin LineJoinMiter = "miter" fromLineJoin LineJoinBevel = "bevel" @@ -307,40 +314,45 @@ toLineJoin "round" = LineJoinRound toLineJoin _ = LineJoinMiter --- | line style --- --- >>> defaultLineStyle --- LineStyle {size = 1.2e-2, color = Colour 0.05 0.05 0.05 1.00, linecap = Nothing, linejoin = Nothing, dasharray = Nothing, dashoffset = Nothing} --- --- ![line example](other/line.svg) --- --- See also -data LineStyle = LineStyle - { size :: Double, - color :: Colour, - linecap :: Maybe LineCap, - linejoin :: Maybe LineJoin, - dasharray :: Maybe [Double], - dashoffset :: Maybe Double - } - deriving (Show, Eq, Generic) - --- | the official default line style -defaultLineStyle :: LineStyle -defaultLineStyle = LineStyle 0.012 dark Nothing Nothing Nothing Nothing +-- | Scale Projection options +data ScaleP + = -- | Do not scale under projection. + NoScaleP + | -- | Scale based on the X axis ratio of a projection + ScalePX + | -- | Scale based on the Y axis ratio of a projection + ScalePY + | -- | Scale based on minimum of (X axis, Y axis) ratio + ScalePMinDim + | -- | Scale based on the area ratio of a projection + ScalePArea + deriving (Generic, Eq, Show) --- | Path styling +-- | given a ScaleP and two Rects, what is the scaling factor for a projection -- --- >>> defaultPathStyle --- PathStyle {borderSize = 1.0e-2, borderColor = Colour 0.02 0.29 0.48 1.00, color = Colour 0.66 0.07 0.55 1.00} -data PathStyle = PathStyle - { borderSize :: Double, - borderColor :: Colour, - color :: Colour - } - deriving (Show, Eq, Generic) - --- | the style -defaultPathStyle :: PathStyle -defaultPathStyle = - PathStyle 0.01 (palette1 1) (palette1 2) +-- Guards against scaling to zero or infinity +scaleRatio :: ScaleP -> Rect Double -> Rect Double -> Double +scaleRatio NoScaleP _ _ = 1 +scaleRatio ScalePX new old = bool 1 (width nx / width ox) (width ox > 0 && width nx > 0) + where + (Ranges nx _) = new + (Ranges ox _) = old +scaleRatio ScalePY new old = bool 1 (width ny / width oy) (width oy > 0 && width ny > 0) + where + (Ranges _ ny) = new + (Ranges _ oy) = old +scaleRatio ScalePArea new old = bool 1 (sqrt (an / ao)) (an > 0 && ao > 0) + where + (Ranges nx ny) = new + (Ranges ox oy) = old + an = width nx * width ny + ao = width ox * width oy +scaleRatio ScalePMinDim new old = closestToOne + where + x' = scaleRatio ScalePX new old + y' = scaleRatio ScalePY new old + closestToOne + | x' >= 1 && y' >= 1 = bool x' y' (x' > y') + | x' >= 1 && y' < 1 = bool x' y' (x' > (1 / y')) + | x' < 1 && y' >= 1 = bool x' y' ((1 / x') > y') + | otherwise = bool x' y' ((1 / x') > (1 / y')) diff --git a/src/Chart/Surface.hs b/src/Chart/Surface.hs --- a/src/Chart/Surface.hs +++ b/src/Chart/Surface.hs @@ -15,8 +15,9 @@ surfacef, SurfaceLegendOptions (..), defaultSurfaceLegendOptions, - surfaceLegendChart, - surfaceAxisOptions, + surfaceLegendAxisOptions, + gridReferenceChart, + addSurfaceLegend, ) where @@ -29,8 +30,9 @@ import Data.Colour import Data.Foldable import Data.FormatN -import Data.Text (Text) +import Data.Maybe import GHC.Generics +import NumHask.Space import Optics.Core import Prelude @@ -53,20 +55,20 @@ -- | A surface chart is a specialization of a 'RectChart' -- -- >>> defaultSurfaceStyle --- SurfaceStyle {surfaceColors = [Colour 0.02 0.73 0.80 1.00,Colour 0.02 0.29 0.48 1.00], surfaceRectStyle = RectStyle {borderSize = 0.0, borderColor = Colour 0.00 0.00 0.00 0.00, color = Colour 0.05 0.05 0.05 1.00}} +-- SurfaceStyle {surfaceColors = [Colour 0.02 0.73 0.80 1.00,Colour 0.02 0.29 0.48 1.00], surfaceRectStyle = Style {size = 6.0e-2, borderSize = 0.0, color = Colour 0.05 0.05 0.05 1.00, borderColor = Colour 0.00 0.00 0.00 0.00, scaleP = NoScaleP, anchor = AnchorMiddle, rotation = Nothing, translate = Nothing, escapeText = EscapeText, frame = Nothing, lineCap = Nothing, lineJoin = Nothing, dasharray = Nothing, dashoffset = Nothing, hsize = 0.6, vsize = 1.1, vshift = -0.25, glyphShape = SquareGlyph}} -- -- ![surface example](other/surface.svg) data SurfaceStyle = SurfaceStyle { -- | list of colours to interpolate between. surfaceColors :: [Colour], - surfaceRectStyle :: RectStyle + surfaceRectStyle :: Style } deriving (Show, Eq, Generic) -- | The official surface style. defaultSurfaceStyle :: SurfaceStyle defaultSurfaceStyle = - SurfaceStyle (palette1 <$> [0 .. 1]) (blob dark) + SurfaceStyle (palette <$> [0 .. 1]) (blob dark) -- | Main surface data elements data SurfaceData = SurfaceData @@ -78,12 +80,12 @@ deriving (Show, Eq, Generic) -- | surface chart without any hud trimmings -surfaces :: RectStyle -> [SurfaceData] -> [Chart] +surfaces :: Style -> [SurfaceData] -> [Chart] surfaces rs ps = ( \(SurfaceData r c) -> - RectChart - (rs & #color .~ c) - [r] + Chart + (rs & set #color c) + (RectData [r]) ) <$> ps @@ -105,107 +107,77 @@ -- | Create a surface chart from a function. surfacef :: (Point Double -> Double) -> SurfaceOptions -> ([Chart], Range Double) surfacef f cfg = - first (surfaces (cfg ^. #soStyle % #surfaceRectStyle)) $ + first (surfaces (view (#soStyle % #surfaceRectStyle) cfg)) $ mkSurfaceData f - (cfg ^. #soRange) - (cfg ^. #soGrain) - (toList $ cfg ^. #soStyle % #surfaceColors) + (view #soRange cfg) + (view #soGrain cfg) + (toList $ view (#soStyle % #surfaceColors) cfg) -- | Legend specialization for a surface chart. data SurfaceLegendOptions = SurfaceLegendOptions - { sloStyle :: SurfaceStyle, - sloTitle :: Text, + { sloAxisOptions :: AxisOptions, -- | Width of the legend glyph sloWidth :: Double, -- | Resolution of the legend glyph sloResolution :: Int, - sloAxisOptions :: AxisOptions, - sloLegendOptions :: LegendOptions + sloDataRange :: Range Double, + -- | Placement of the legend versus normalised chart placement + sloRect :: Rect Double, + sloSurfaceStyle :: SurfaceStyle } deriving (Eq, Show, Generic) --- | 'AxisOptions' for a surface chart. -surfaceAxisOptions :: Colour -> AxisOptions -surfaceAxisOptions c = +-- | 'AxisOptions' for a surface chart legend. +surfaceLegendAxisOptions :: AxisOptions +surfaceLegendAxisOptions = AxisOptions Nothing Nothing ( Ticks (TickRound (FormatN FSPrec (Just 3) 4 True True) 4 NoTickExtend) - (Just (defaultGlyphTick & #borderColor .~ c & #color .~ c & #shape .~ VLineGlyph, 0.01)) - (Just (defaultTextTick & #color .~ c, 0.03)) + (Just defaultGlyphTickStyleY) + (Just (defaultTextTick & set #buffer 0.05)) Nothing ) PlaceRight -- | official surface legend options -defaultSurfaceLegendOptions :: Colour -> Text -> SurfaceLegendOptions -defaultSurfaceLegendOptions c t = - SurfaceLegendOptions defaultSurfaceStyle t 0.05 100 (surfaceAxisOptions c) surfaceLegendOptions - -surfaceLegendOptions :: LegendOptions -surfaceLegendOptions = - defaultLegendOptions - & #place .~ PlaceRight - & #overallScale .~ 0.9 - & #size .~ 0.5 - & #vgap .~ 0.05 - & #hgap .~ 0.01 - & #innerPad .~ 0.05 - & #outerPad .~ 0.02 - & #textStyle % #hsize .~ 0.5 - & #textStyle % #size .~ 0.1 - & #frame .~ Nothing +defaultSurfaceLegendOptions :: SurfaceLegendOptions +defaultSurfaceLegendOptions = + SurfaceLegendOptions surfaceLegendAxisOptions 0.2 100 one (Rect 0.7 0.9 0 0.5) defaultSurfaceStyle --- | Creation of the classical heatmap glyph within a legend context. -surfaceLegendChart :: Range Double -> SurfaceLegendOptions -> ChartTree -surfaceLegendChart dataRange l = - legendFrame (view #sloLegendOptions l) hs +-- | Chart used as a reference to a surface chart. +gridReferenceChart :: SurfaceLegendOptions -> ChartTree +gridReferenceChart slo = + named "grid reference" $ + zipWith + (\r c -> Chart (blob c) (RectData [r])) + (gridf <$> spaceGrid) + colorGrid where - a = makeSurfaceTick l (named "pchart" pchart) - pchart - | l ^. #sloLegendOptions % #place == PlaceBottom - || l ^. #sloLegendOptions % #place == PlaceTop = - vertGlyph - | otherwise = horiGlyph - t = TextChart (l ^. #sloLegendOptions % #textStyle & #anchor .~ AnchorStart) [(l ^. #sloTitle, zero)] - hs = vert (l ^. #sloLegendOptions % #vgap) [a, unnamed [t]] - vertGlyph :: [Chart] - vertGlyph = - zipWith - (\r c -> RectChart (blob c) [r]) - ( (\xr -> Ranges xr (Range 0 (l ^. #sloWidth))) - <$> gridSpace - dataRange - (l ^. #sloResolution) - ) - ( (\x -> mixes x (toList $ l ^. #sloStyle % #surfaceColors)) - <$> grid MidPos (Range 0 1) (l ^. #sloResolution) - ) - horiGlyph :: [Chart] - horiGlyph = - zipWith - (\r c -> RectChart (blob c) [r]) - ( (\yr -> Ranges (Range 0 (l ^. #sloWidth)) yr) - <$> gridSpace - dataRange - (l ^. #sloResolution) - ) - ( (\x -> mixes x (toList $ l ^. #sloStyle % #surfaceColors)) - <$> grid MidPos (Range 0 1) (l ^. #sloResolution) - ) + spaceGrid = gridSpace (view #sloDataRange slo) (view #sloResolution slo) + gridf = + bool + (\yr -> Ranges (Range 0 (view #sloWidth slo)) yr) + (\xr -> Ranges xr (Range 0 (view #sloWidth slo))) + (isHori slo) + colorGrid = + (\x -> mixes x (toList $ view (#sloSurfaceStyle % #surfaceColors) slo)) + <$> grid MidPos (Range 0 1) (view #sloResolution slo) isHori :: SurfaceLegendOptions -> Bool -isHori l = - l ^. #sloLegendOptions % #place == PlaceBottom - || l ^. #sloLegendOptions % #place == PlaceTop +isHori slo = + view (#sloAxisOptions % #place) slo == PlaceBottom + || view (#sloAxisOptions % #place) slo == PlaceTop -makeSurfaceTick :: SurfaceLegendOptions -> ChartTree -> ChartTree -makeSurfaceTick l pchart = case view styleBox' pchart of - Nothing -> pchart - Just r' -> phud - where - r'' = bool (Rect 0 (l ^. #sloWidth) 0 (l ^. #sloLegendOptions % #size)) (Rect 0 (l ^. #sloLegendOptions % #size) 0 (l ^. #sloWidth)) (isHori l) - (hs, db) = toHuds (mempty & set #chartAspect ChartAspect & set #axes [(9, l ^. #sloAxisOptions & #place .~ bool PlaceRight PlaceBottom (isHori l))]) r' - phud = runHudWith r'' db hs pchart +-- | Add a surface legend to a main surface chart. +addSurfaceLegend :: SurfaceLegendOptions -> ChartTree -> ChartTree +addSurfaceLegend slo ct = ctBoth + where + grc = gridReferenceChart slo + hoLegend = (mempty :: HudOptions) & set #axes [Priority 1 (view #sloAxisOptions slo)] + grcLegend = addHud (FixedAspect (view #sloWidth slo)) hoLegend grc + ctbox = fromMaybe one (view styleBox' ct) + legbox = projectOnR ctbox one (view #sloRect slo) + ctBoth = mconcat [projectChartTree legbox grcLegend, ct] diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs --- a/src/Data/Colour.hs +++ b/src/Data/Colour.hs @@ -25,8 +25,8 @@ unsafeFromHex, -- * Palette colours - palette1, - palette1a, + palette, + paletteO, transparent, black, white, @@ -87,7 +87,6 @@ import GHC.Generics hiding (prec) import Graphics.Color.Model as M hiding (LCH) import Graphics.Color.Space qualified as S -import NumHask.Algebra.Metric import NumHask.Array.Fixed import Optics.Core import System.Random @@ -239,12 +238,12 @@ -- | Select a Colour from the palette -- --- >>> palette1 0 +-- >>> palette 0 -- Colour 0.02 0.73 0.80 1.00 -- -- ![wheel](other/wheel.svg) -palette1 :: Int -> Colour -palette1 x = cycle palette1_ List.!! x +palette :: Int -> Colour +palette x = cycle palette1_ List.!! x palette1LCHA_ :: [LCHA] palette1LCHA_ = [LCHA 0.72 0.123 207 1, LCHA 0.40 0.10 246 1, LCHA 0.50 0.21 338 1, LCHA 0.8 0.15 331 1, LCHA 0.83 0.14 69 1, LCHA 0.57 0.15 50 1, LCHA 0.38 0.085 128 1, LCHA 0.60 0.08 104 1] @@ -253,16 +252,16 @@ -- -- Swatched to the oklab color model: -- --- ![palette1](other/palette1.svg) +-- ![palette](other/palette.svg) palette1_ :: [Colour] palette1_ = trimColour . view lcha2colour' <$> palette1LCHA_ -- | Select a Colour from the palette with a specified opacity -- --- >>> palette1a 0 0.5 +-- >>> paletteO 0 0.5 -- Colour 0.02 0.73 0.80 0.50 -palette1a :: Int -> Double -> Colour -palette1a x a = set opac' a $ cycle palette1_ List.!! x +paletteO :: Int -> Double -> Colour +paletteO x a = set opac' a $ cycle palette1_ List.!! x -- | black -- @@ -502,7 +501,7 @@ ] cubicroot :: (Floating a, Ord a) => a -> a -cubicroot x = bool (-1 * (-x) ** (1 / 3.0)) (x ** (1 / 3.0)) (x >= 0) +cubicroot x = bool ((-1) * (-x) ** (1 / 3.0)) (x ** (1 / 3.0)) (x >= 0) -- >>> xyz2lab_ [0.95, 1, 1.089] -- [0.9999686754143632, -2.580058168537569e-4, -1.1499756458199784e-4] diff --git a/src/Data/Path.hs b/src/Data/Path.hs --- a/src/Data/Path.hs +++ b/src/Data/Path.hs @@ -49,6 +49,7 @@ import GHC.Generics import Geom2D.CubicBezier qualified as B import NumHask.Prelude +import NumHask.Space -- $setup -- @@ -193,7 +194,7 @@ -- -- >>> let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) -- >>> arcCentroid p --- ArcCentroid {centroid = Point 0.20952624903444356 -0.48412291827592724, radius = Point 1.0 0.5, cphi = 0.7853981633974483, ang0 = 1.3753858999692936, angdiff = -1.823476581936975} +-- ArcCentroid {centroid = Point 0.20952624903444356 (-0.48412291827592724), radius = Point 1.0 0.5, cphi = 0.7853981633974483, ang0 = 1.3753858999692936, angdiff = -1.823476581936975} arcCentroid :: (Ord a, FromInteger a, TrigField a, ExpField a) => ArcPosition a -> ArcCentroid a arcCentroid (ArcPosition p1@(Point x1 y1) p2@(Point x2 y2) (ArcInfo rad phi' large' clockwise')) = ArcCentroid c (Point rx ry) phi' ang1 angd where @@ -211,12 +212,12 @@ cx = (x1 + x2) / 2 + cos phi' * cx' - sin phi' * cy' cy = (y1 + y2) / 2 + sin phi' * cx' + cos phi' * cy' c = Point cx cy - ang1 = angle (Point (-(cx' - x1') / rx) (-(cy' - y1') / ry)) - ang2 = angle (Point (-(cx' + x1') / rx) (-(cy' + y1') / ry)) + ang1 = angle (Point (-((cx' - x1') / rx)) (-((cy' - y1') / ry))) + ang2 = angle (Point (-((cx' + x1') / rx)) (-((cy' + y1') / ry))) angd' = ang2 - ang1 angd = bool 0 (2 * pi) (not clockwise' && angd' < 0) - + bool 0 (-2 * pi) (clockwise' && angd' > 0) + + bool 0 (-(2 * pi)) (clockwise' && angd' > 0) + angd' -- | Convert from an ArcCentroid to an ArcPosition specification. @@ -242,7 +243,7 @@ -- | Ellipse formulae -- -- >>> ellipse zero (Point 1 2) (pi/6) pi --- Point -0.8660254037844388 -0.4999999999999997 +-- Point (-0.8660254037844388) (-0.4999999999999997) -- -- Compare this "elegent" definition from [stackexchange](https://math.stackexchange.com/questions/426150/what-is-the-general-equation-of-the-ellipse-that-is-not-in-the-origin-and-rotate) -- @@ -258,10 +259,8 @@ -- | compute the bounding box for an arcBox -- --- >>> let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) --- >>> import Data.FormatN --- >>> fmap (fixed (Just 3)) (arcBox p) --- Rect "-0.000" "1.000" "-0.000" "0.306" +-- > let p = ArcPosition (Point 0 0) (Point 1 0) (ArcInfo (Point 1 0.5) (pi/4) False True) +-- > arcBox p arcBox :: ArcPosition Double -> Rect Double arcBox p = unsafeSpace1 pts where @@ -291,7 +290,7 @@ arcDerivs :: Point Double -> Double -> (Double, Double) arcDerivs (Point rx ry) phi' = (thetax1, thetay1) where - thetax1 = atan2 (-sin phi' * ry) (cos phi' * rx) + thetax1 = atan2 (-(sin phi' * ry)) (cos phi' * rx) thetay1 = atan2 (cos phi' * ry) (sin phi' * rx) -- | Quadratic bezier curve expressed in positional terms. @@ -332,7 +331,7 @@ -- > quadPolar . quadPosition == id -- -- >>> quadPosition $ quadPolar (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) --- QuadPosition {qposStart = Point 0.0 0.0, qposEnd = Point 1.0 1.0, qposControl = Point 2.0 -0.9999999999999998} +-- QuadPosition {qposStart = Point 0.0 0.0, qposEnd = Point 1.0 1.0, qposControl = Point 2.0 (-0.9999999999999998)} quadPosition :: (TrigField a) => QuadPolar a -> QuadPosition a quadPosition (QuadPolar start' end control) = QuadPosition start' end control' where @@ -341,7 +340,7 @@ -- | The quadratic bezier equation -- -- >>> quadBezier (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) 0.33333333 --- Point 0.9999999933333332 -0.33333333333333326 +-- Point 0.9999999933333332 (-0.33333333333333326) quadBezier :: (FromInteger a, ExpField a) => QuadPosition a -> a -> Point a quadBezier (QuadPosition start' end control) theta = (1 - theta) @@ -369,7 +368,7 @@ -- | Bounding box for a QuadPosition -- -- >>> quadBox (QuadPosition (Point 0 0) (Point 1 1) (Point 2 (-1))) --- Rect 0.0 1.3333333333333335 -0.33333333333333337 1.0 +-- Rect 0.0 1.3333333333333335 (-0.33333333333333337) 1.0 quadBox :: QuadPosition Double -> Rect Double quadBox p = unsafeSpace1 pts where @@ -424,7 +423,7 @@ -- > cubicPolar . cubicPosition == id -- -- >>> cubicPosition $ cubicPolar (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) --- CubicPosition {cposStart = Point 0.0 0.0, cposEnd = Point 1.0 1.0, cposControl1 = Point 1.0 -1.0, cposControl2 = Point 1.6653345369377348e-16 2.0} +-- CubicPosition {cposStart = Point 0.0 0.0, cposEnd = Point 1.0 1.0, cposControl1 = Point 1.0 (-1.0), cposControl2 = Point 1.6653345369377348e-16 2.0} cubicPosition :: (Eq a, TrigField a, ExpField a) => CubicPolar a -> CubicPosition a cubicPosition (CubicPolar start' end control1 control2) = CubicPosition start' end control1' control2' where @@ -478,7 +477,7 @@ -- | Bounding box for a CubicPosition -- -- >>> cubicBox (CubicPosition (Point 0 0) (Point 1 1) (Point 1 (-1)) (Point 0 2)) --- Rect 0.0 1.0 -0.20710678118654752 1.2071067811865475 +-- Rect 0.0 1.0 (-0.20710678118654752) 1.2071067811865475 cubicBox :: CubicPosition Double -> Rect Double cubicBox p = unsafeSpace1 pts where diff --git a/src/Data/Path/Parser.hs b/src/Data/Path/Parser.hs --- a/src/Data/Path/Parser.hs +++ b/src/Data/Path/Parser.hs @@ -3,10 +3,9 @@ {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE TemplateHaskell #-} --- | SVG path manipulation +-- | Conversions to and from an SVG path to a 'PathData' module Data.Path.Parser ( -- * Parsing - -- $parsing parsePath, pathParser, command, @@ -33,20 +32,11 @@ import NumHask.Prelude hiding (optional, (<|>)) import Optics.Core hiding ((<|)) --- $parsing --- Every element of an svg path can be thought of as exactly two points in space, with instructions of how to draw a curve between them. From this point of view, one which this library adopts, a path chart is thus very similar to a line chart. There's just a lot more information about the style of this line to deal with. --- --- References: --- --- [SVG d attribute](https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/d) --- --- [SVG Paths](https://developer.mozilla.org/en-US/docs/Web/SVG/Tutorial/Paths) - -- | Parse a raw path string. -- -- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z" -- >>> parsePath outerseg1 --- Just [MoveTo OriginAbsolute [Point -1.0 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 -1.2320508075688774),(1.0,1.0,0.0,False,False,Point -0.5 -0.3660254037844387),(1.0,1.0,0.0,False,False,Point -1.0 0.5)],EndPath] +-- Just [MoveTo OriginAbsolute [Point (-1.0) 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 (-1.2320508075688774)),(1.0,1.0,0.0,False,False,Point (-0.5) (-0.3660254037844387)),(1.0,1.0,0.0,False,False,Point (-1.0) 0.5)],EndPath] parsePath :: ByteString -> Maybe [PathCommand] parsePath = runParserMaybe pathParser @@ -225,7 +215,7 @@ <> " " <> pv' y <> " " - <> pv' (-phi' * 180 / pi) + <> pv' (-(phi' * 180 / pi)) <> " " <> bool "0" "1" l <> " " @@ -277,13 +267,14 @@ relToAbs p xs = accsum (p : xs) moveTo :: [Point Double] -> State PathCursor [PathData Double] -moveTo xs = do - put (PathCursor (last xs) (head xs) Nothing) - pure (StartP (head xs) : (LineP <$> tail xs)) +moveTo [] = pure [] +moveTo (x : xs) = do + put (PathCursor (fromMaybe x $ listToMaybe $ reverse xs) x Nothing) + pure (StartP x : (LineP <$> xs)) lineTo :: [Point Double] -> State PathCursor [PathData Double] lineTo xs = do - modify ((#curPrevious .~ last xs) . (#curControl .~ Nothing)) + modify (set #curPrevious (last xs) . set #curControl Nothing) pure $ LineP <$> xs horTo :: [Double] -> State PathCursor [PathData Double] @@ -299,7 +290,7 @@ curveTo :: [(Point Double, Point Double, Point Double)] -> State PathCursor [PathData Double] curveTo xs = do modify - ( (#curPrevious .~ (\(_, _, p) -> p) (last xs)) + ( set #curPrevious ((\(_, _, p) -> p) (last xs)) . (#curControl ?~ (\(_, c2, _) -> c2) (last xs)) ) pure $ (\(c1, c2, x2) -> CubicP c1 c2 x2) <$> xs @@ -326,12 +317,11 @@ smoothCurveToStep :: (Point Double, Point Double) -> State PathCursor (PathData Double) smoothCurveToStep (c2, x2) = do c1 <- reflControlPoint - modify ((#curControl ?~ c2) . (#curPrevious .~ x2)) + modify ((#curControl ?~ c2) . set #curPrevious x2) pure (CubicP c1 c2 x2) smoothCurveTo :: [(Point Double, Point Double)] -> State PathCursor [PathData Double] -smoothCurveTo xs = - mapM smoothCurveToStep xs +smoothCurveTo = mapM smoothCurveToStep -- | Convert relative points to absolute points relToAbs2 :: (Additive a) => a -> [(a, a)] -> [(a, a)] @@ -346,24 +336,23 @@ quad :: [(Point Double, Point Double)] -> State PathCursor [PathData Double] quad xs = do modify - ( (#curPrevious .~ snd (last xs)) - . (#curControl ?~ fst (last xs)) + ( set #curPrevious (snd (last xs)) + . set #curControl (Just (fst (last xs))) ) pure $ uncurry QuadP <$> xs smoothQuadStep :: Point Double -> State PathCursor (PathData Double) smoothQuadStep x2 = do c1 <- reflControlPoint - modify ((#curControl ?~ c1) . (#curPrevious .~ x2)) + modify (set #curControl (Just c1) . set #curPrevious x2) pure (QuadP c1 x2) smoothQuad :: [Point Double] -> State PathCursor [PathData Double] -smoothQuad xs = - mapM smoothQuadStep xs +smoothQuad = mapM smoothQuadStep arcTo :: [(Double, Double, Double, Bool, Bool, Point Double)] -> State PathCursor [PathData Double] arcTo xs = do - modify ((#curPrevious .~ (\(_, _, _, _, _, p) -> p) (last xs)) . (#curControl .~ Nothing)) + modify (set #curPrevious ((\(_, _, _, _, _, p) -> p) (last xs)) . set #curControl Nothing) pure $ fromPathEllipticalArc <$> xs fromPathEllipticalArc :: (a, a, a, Bool, Bool, Point a) -> PathData a