diff --git a/plots.cabal b/plots.cabal --- a/plots.cabal +++ b/plots.cabal @@ -1,5 +1,5 @@ name: plots -version: 0.1.1.0 +version: 0.1.1.1 synopsis: Diagrams based plotting library. homepage: http://github.com/cchalmers/plots license: BSD3 @@ -40,7 +40,7 @@ Plots.Types.Histogram Plots.Types.HeatMap Plots.Types.Line - Plots.Types.Pie + -- Plots.Types.Pie Plots.Types.Scatter Plots.Util Diagrams.Coordinates.Isomorphic @@ -50,10 +50,10 @@ base >= 4.7 && < 5.0, adjunctions, colour, - containers >= 0.3 && < 0.6, + containers >= 0.3 && < 0.7, data-default >= 0.5 && < 0.8, - diagrams-core >= 1.3 && < 1.5, - diagrams-lib >= 1.3 && < 1.5, + diagrams >= 2.0 && < 2.1, + geometry, directory, distributive, transformers, diff --git a/src/Diagrams/Coordinates/Polar.hs b/src/Diagrams/Coordinates/Polar.hs --- a/src/Diagrams/Coordinates/Polar.hs +++ b/src/Diagrams/Coordinates/Polar.hs @@ -48,8 +48,8 @@ import Data.Typeable import GHC.Generics (Generic1) -import Diagrams.Angle -import Diagrams.TwoD.Types +import Geometry.Angle +import Geometry.TwoD.Types import Linear.Affine import Linear.Metric diff --git a/src/Plots.hs b/src/Plots.hs --- a/src/Plots.hs +++ b/src/Plots.hs @@ -53,7 +53,7 @@ , module Plots.Types.Histogram -- | Wedge and annular wedge. API for wedge, annular wedge and pie. - , module Plots.Types.Pie + -- , module Plots.Types.Pie -------------------------------------------------------------------- -- * Low level @@ -114,6 +114,6 @@ import Plots.Types.HeatMap import Plots.Types.Histogram import Plots.Types.Line -import Plots.Types.Pie +-- import Plots.Types.Pie import Plots.Types.Scatter diff --git a/src/Plots/Axis.hs b/src/Plots/Axis.hs --- a/src/Plots/Axis.hs +++ b/src/Plots/Axis.hs @@ -30,6 +30,7 @@ -- * Predefined axes , r2Axis + , r3Axis , polarAxis -- ** Base space @@ -101,22 +102,21 @@ -- Single axis --------------------------------------------------------- -- | Render information for a single axis line. -data SingleAxis b v n = SingleAxis --- note the the v is only present for Style v n - { saLabel :: AxisLabel b v n - , saLine :: AxisLine v n - , saTickLabel :: TickLabels b v n - , saScaling :: AxisScaling n - , saGridLines :: GridLines v n - , saTicks :: Ticks v n +data SingleAxis v = SingleAxis +-- note the the v is only present for Style v + { saLabel :: AxisLabel v + , saLine :: AxisLine v + , saTickLabel :: TickLabels v + , saScaling :: AxisScaling + , saGridLines :: GridLines v + , saTicks :: Ticks v , saVisible :: Bool } -type instance V (SingleAxis b v n) = v -type instance N (SingleAxis b v n) = n +type instance V (SingleAxis v) = v +type instance N (SingleAxis v) = Double -instance (TypeableFloat n, Renderable (Text n) b) - => Default (SingleAxis b V2 n) where +instance Default (SingleAxis V2) where def = SingleAxis { saLabel = def , saLine = def @@ -127,43 +127,54 @@ , saVisible = True } -instance Functor f => HasTicks f (SingleAxis b v n) where +instance Default (SingleAxis V3) where + def = SingleAxis + { saLabel = def + , saLine = def + , saTickLabel = def + , saGridLines = def + , saTicks = def + , saScaling = def + , saVisible = True + } + +instance Functor f => HasTicks f (SingleAxis v) where bothTicks = lens saTicks (\sa ticks -> sa {saTicks = ticks}) -instance Functor f => HasMajorTicks f (SingleAxis b v n) where +instance Functor f => HasMajorTicks f (SingleAxis v) where majorTicks = bothTicks . majorTicks -instance Functor f => HasMinorTicks f (SingleAxis b v n) where +instance Functor f => HasMinorTicks f (SingleAxis v) where minorTicks = bothTicks . minorTicks -instance Functor f => HasAxisLabel f (SingleAxis b v n) b where +instance Functor f => HasAxisLabel f (SingleAxis v) where axisLabel = lens saLabel (\sa l -> sa {saLabel = l}) -instance Functor f => HasTickLabels f (SingleAxis b v n) b where +instance Functor f => HasTickLabels f (SingleAxis v) where tickLabel = lens saTickLabel (\sa tl -> sa {saTickLabel = tl}) -instance Functor f => HasAxisLine f (SingleAxis b v n) where +instance Functor f => HasAxisLine f (SingleAxis v) where axisLine = lens saLine (\sa l -> sa {saLine = l}) -instance Functor f => HasGridLines f (SingleAxis b v n) where +instance Functor f => HasGridLines f (SingleAxis v) where gridLines = lens saGridLines (\sa l -> sa {saGridLines = l}) -instance Functor f => HasMajorGridLines f (SingleAxis b v n) where +instance Functor f => HasMajorGridLines f (SingleAxis v) where majorGridLines = gridLines . majorGridLines -instance Functor f => HasMinorGridLines f (SingleAxis b v n) where +instance Functor f => HasMinorGridLines f (SingleAxis v) where minorGridLines = gridLines . minorGridLines -instance Functor f => HasAxisScaling f (SingleAxis b v n) where +instance Functor f => HasAxisScaling f (SingleAxis v) where axisScaling = lens saScaling (\sa s -> sa {saScaling = s}) -instance HasVisibility (SingleAxis b v n) where +instance HasVisibility (SingleAxis v) where visible = lens saVisible (\sa b -> sa {saVisible = b}) --- singleAxisScale :: Lens' (SingleAxis b v n) AxisScale +-- singleAxisScale :: Lens' (SingleAxis v) AxisScale -- singleAxisScale = lens saScale (\sa s -> sa {saScale = s}) --- singleAxisBound :: Lens' (SingleAxis b v n) (Bound n) +-- singleAxisBound :: Lens' (SingleAxis v) (Bound n) -- singleAxisBound = lens saBounds (\sa b -> sa {saBounds = b}) ------------------------------------------------------------------------ @@ -213,36 +224,36 @@ -- Plots are usually added to the axis using specific functions for -- those plots ('Plots.Types.Line.linePlot, 'Plots.Types.Bar.barPlot'). -- These functions use 'addPlotable' to add the plot to the axis. -data Axis b c n = Axis - { _axisStyle :: AxisStyle b (BaseSpace c) n - , _colourBar :: ColourBar b n - , _colourBarR :: (n,n) - , _legend :: Legend b n - , _axisTitle :: Title b (BaseSpace c) n +data Axis c = Axis + { _axisStyle :: AxisStyle (BaseSpace c) + , _colourBar :: ColourBar + , _colourBarR :: (Double,Double) + , _legend :: Legend + , _axisTitle :: Title (BaseSpace c) -- , _axisTitle :: AxisTitle - , _axisPlots :: [DynamicPlot b (BaseSpace c) n] - , _plotModifier :: Endo (StyledPlot b (BaseSpace c) n) + , _axisPlots :: [DynamicPlot (BaseSpace c)] + , _plotModifier :: Endo (StyledPlot (BaseSpace c)) -- the v in each axis is only used for the style - , _axes :: c (SingleAxis b (BaseSpace c) n) + , _axes :: c (SingleAxis (BaseSpace c)) } deriving Typeable -- | Lens onto the separate axes of an axis. Allows changing the -- coordinate system as long as the 'BaseSpace' is the same. -- -- @ --- 'axes' :: 'Lens'' ('Axis' b c n) (c ('SingleAxis' b v n)) +-- 'axes' :: 'Lens'' ('Axis' c) (c ('SingleAxis' v)) -- @ axes :: (v ~ BaseSpace c, v ~ BaseSpace c') - => Lens (Axis b c n) - (Axis b c' n) - (c (SingleAxis b v n)) - (c' (SingleAxis b v n)) + => Lens (Axis c) + (Axis c') + (c (SingleAxis v)) + (c' (SingleAxis v)) axes = lens _axes (\(Axis a1 a2 a3 a4 a5 a6 a7 _) a8 -> Axis a1 a2 a3 a4 a5 a6 a7 a8) -- | The list of plots currently in the axis. -axisPlots :: BaseSpace c ~ v => Lens' (Axis b c n) [DynamicPlot b v n] +axisPlots :: BaseSpace c ~ v => Lens' (Axis c) [DynamicPlot v] axisPlots = lens _axisPlots (\a ps -> a {_axisPlots = ps}) -- | Traversal over the current plots in the axis. @@ -253,7 +264,7 @@ -- @ -- 'finalPlots' . 'connectingLine' .= 'True' -- @ -currentPlots :: BaseSpace c ~ v => Traversal' (Axis b c n) (DynamicPlot b v n) +currentPlots :: BaseSpace c ~ v => Traversal' (Axis c) (DynamicPlot v) currentPlots = axisPlots . traversed -- | Setter over the final plot before the axis is rendered. @@ -266,71 +277,74 @@ -- 'finalPlots' . 'connectingLine' .= 'True' -- @ -- -finalPlots :: BaseSpace c ~ v => Setter' (Axis b c n) (StyledPlot b v n) +finalPlots :: BaseSpace c ~ v => Setter' (Axis c) (StyledPlot v) finalPlots = sets $ \f a -> a {_plotModifier = _plotModifier a <> Endo f} -- | Lens onto the modifier set by 'finalPlots'. This gets applied to -- all plots in the axis, just before they are rendered. -plotModifier :: BaseSpace c ~ v => Lens' (Axis b c n) (Endo (StyledPlot b v n)) +plotModifier :: BaseSpace c ~ v => Lens' (Axis c) (Endo (StyledPlot v)) plotModifier = lens _plotModifier (\a f -> a {_plotModifier = f}) -- Axis instances ------------------------------------------------------ -type instance V (Axis b v n) = BaseSpace v -type instance N (Axis b v n) = n +type instance V (Axis c) = BaseSpace c +type instance N (Axis c) = Double -instance (Applicative f, Traversable c) => HasTicks f (Axis b c n) where +instance (Applicative f, Traversable c) => HasTicks f (Axis c) where bothTicks = axes . traverse . bothTicks -instance (Applicative f, Traversable c) => HasMajorTicks f (Axis b c n) where +instance (Applicative f, Traversable c) => HasMajorTicks f (Axis c) where majorTicks = axes . traverse . majorTicks -instance (Applicative f, Traversable c) => HasMinorTicks f (Axis b c n) where +instance (Applicative f, Traversable c) => HasMinorTicks f (Axis c) where minorTicks = axes . traverse . minorTicks -instance (Applicative f, Traversable c) => HasGridLines f (Axis b c n) where +instance (Applicative f, Traversable c) => HasGridLines f (Axis c) where gridLines = axes . traverse . gridLines -instance (Applicative f, Traversable c) => HasMajorGridLines f (Axis b c n) where +instance (Applicative f, Traversable c) => HasMajorGridLines f (Axis c) where majorGridLines = axes . traverse . majorGridLines -instance (Applicative f, Traversable c) => HasMinorGridLines f (Axis b c n) where +instance (Applicative f, Traversable c) => HasMinorGridLines f (Axis c) where minorGridLines = axes . traverse . minorGridLines -instance (Applicative f, Traversable c) => HasAxisLabel f (Axis b c n) b where +instance (Applicative f, Traversable c) => HasAxisLine f (Axis c) where + axisLine = axes . traverse . axisLine + +instance (Applicative f, Traversable c) => HasAxisLabel f (Axis c) where axisLabel = axes . traverse . axisLabel -instance (Applicative f, Traversable c) => HasTickLabels f (Axis b c n) b where +instance (Applicative f, Traversable c) => HasTickLabels f (Axis c) where tickLabel = axes . traverse . tickLabel -instance (Applicative f, Traversable c) => HasAxisScaling f (Axis b c n) where +instance (Applicative f, Traversable c) => HasAxisScaling f (Axis c) where axisScaling = axes . traverse . axisScaling -instance Settable f => HasPlotOptions f (Axis b c n) b where +instance Settable f => HasPlotOptions f (Axis c) where plotOptions = finalPlots . plotOptions -instance Settable f => HasPlotStyle f (Axis b c n) b where +instance Settable f => HasPlotStyle f (Axis c) where plotStyle = finalPlots . plotStyle -instance HasLegend (Axis b c n) b where +instance HasLegend (Axis c) where legend = lens _legend (\a l -> a {_legend = l}) -instance HasTitle (Axis b c n) b where +instance HasTitle (Axis c) where title = lens _axisTitle (\a t -> a {_axisTitle = t}) -- | The size used for the rendered axis. -axisSize :: (HasLinearMap c, Num n, Ord n) => Lens' (Axis b c n) (SizeSpec c n) -axisSize = axes . column renderSize . iso mkSizeSpec getSpec -- column axisScaling . asSizeSpec -- iso mkSizeSpec getSpec +axisSize :: HasLinearMap c => Lens' (Axis c) (SizeSpec c Double) +axisSize = axes . column renderSize . iso mkSizeSpec getSpec -- | The range used for the colour bar limits. This is automatically set -- when using 'heatMap' or 'heatMap'' -colourBarRange :: Lens' (Axis b v n) (n,n) +colourBarRange :: Lens' (Axis v) (Double,Double) colourBarRange = lens _colourBarR (\a r -> a {_colourBarR = r}) -instance HasAxisStyle (Axis b v n) b where +instance HasAxisStyle (Axis v) where axisStyle = lens _axisStyle (\a sty -> a {_axisStyle = sty}) -instance HasColourBar (Axis b v n) b where +instance HasColourBar (Axis v) where colourBar = lens _colourBar (\a cb -> a {_colourBar = cb}) -- Axis functions ------------------------------------------------------ @@ -338,11 +352,11 @@ -- $plotable -- The 'Plotable' class defines ways of converting the data type to a -- diagram for some axis. There are several variants for adding an axis --- with constraints @('InSpace' v n a, 'Plotable' a b)@: +-- with constraints @('InSpace' v a, 'Plotable' a b)@: -- -- @ --- 'addPlotable' :: a -> 'PlotState' a b -> 'AxisState' b v n --- 'addPlotable'' :: a -> 'AxisState' b v n +-- 'addPlotable' :: a -> 'PlotState' a b -> 'AxisState' v +-- 'addPlotable'' :: a -> 'AxisState' v -- @ -- -- The last argument is a 'PlotState' so you can use @do@ notation to @@ -363,23 +377,23 @@ -- | Add a 'Plotable' 'Plot' to an 'Axis'. addPlot - :: (InSpace (BaseSpace c) n p, MonadState (Axis b c n) m, Plotable p b) - => Plot p b -- ^ the plot - -> m () -- ^ add plot to the 'Axis' + :: (InSpace (BaseSpace c) Double p, MonadState (Axis c) m, Plotable p) + => Plot p -- ^ the plot + -> m () -- ^ add plot to the 'Axis' addPlot p = axisPlots <>= [DynamicPlot p] -- | Add something 'Plotable' to the 'Axis' with a stateful modification -- of the 'Plot'. addPlotable - :: (InSpace (BaseSpace c) n p, MonadState (Axis b c n) m, Plotable p b) + :: (InSpace (BaseSpace c) Double p, MonadState (Axis c) m, Plotable p, HasLinearMap (BaseSpace c)) => p -- ^ the raw plot - -> State (Plot p b) () -- ^ changes to the plot + -> State (Plot p) () -- ^ changes to the plot -> m () -- ^ add plot to the 'Axis' addPlotable p s = addPlot $ execState s (mkPlot p) -- | Simple version of 'AddPlotable' without any changes 'Plot'. addPlotable' - :: (InSpace (BaseSpace v) n p, MonadState (Axis b v n) m, Plotable p b) + :: (InSpace (BaseSpace c) Double p, MonadState (Axis c) m, Plotable p, HasLinearMap (BaseSpace c)) => p -- ^ the raw plot -> m () -- ^ add plot to the 'Axis' addPlotable' p = addPlotable p (return ()) @@ -389,11 +403,7 @@ ------------------------------------------------------------------------ -- | The default axis for plots in the 'V2' coordinate system. -r2Axis - :: (TypeableFloat n, - Renderable (Text n) b, - Renderable (Path V2 n) b) - => Axis b V2 n +r2Axis :: Axis V2 r2Axis = Axis { _axisStyle = fadedColours , _colourBar = defColourBar @@ -407,95 +417,110 @@ , _axes = pure def } +-- | The default axis for plots in the 'V2' coordinate system. +r3Axis :: Axis V3 +r3Axis = Axis + { _axisStyle = fadedColours3D + , _colourBar = defColourBar + , _colourBarR = (0,1) + , _axisTitle = def + + , _legend = def + , _axisPlots = [] + , _plotModifier = mempty + + , _axes = pure def + } + -- The x-axis ---------------------------------------------------------- -- | Lens onto the x-axis of an 'Axis'. -xAxis :: R1 c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) +xAxis :: R1 c => Lens' (Axis c) (SingleAxis (BaseSpace c)) xAxis = axes . _x -- | The label for the x-axis. Shorthand for @'xAxis' . 'axisLabelText'@. -xLabel :: R1 c => Lens' (Axis b c n) String +xLabel :: R1 c => Lens' (Axis c) String xLabel = xAxis . axisLabelText -- | The minimum x value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -xMin :: R1 c => Lens' (Axis b c n) (Maybe n) +xMin :: R1 c => Lens' (Axis c) (Maybe Double) xMin = xAxis . boundMin -- | The minimum x value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -xMax :: R1 c => Lens' (Axis b c n) (Maybe n) +xMax :: R1 c => Lens' (Axis c) (Maybe Double) xMax = xAxis . boundMax -- The y-axis ---------------------------------------------------------- -- | Lens onto the y-axis of an 'Axis'. -yAxis :: R2 c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) +yAxis :: R2 c => Lens' (Axis c) (SingleAxis (BaseSpace c)) yAxis = axes . _y -- | The label for the y-axis. Shorthand for @'yAxis' . 'axisLabelText'@. -yLabel :: R2 c => Lens' (Axis b c n) String +yLabel :: R2 c => Lens' (Axis c) String yLabel = yAxis . axisLabelText -- | The minimum y value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -yMin :: R2 c => Lens' (Axis b c n) (Maybe n) +yMin :: R2 c => Lens' (Axis c) (Maybe Double) yMin = yAxis . boundMin -- | The minimum y value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -yMax :: R2 c => Lens' (Axis b c n) (Maybe n) +yMax :: R2 c => Lens' (Axis c) (Maybe Double) yMax = yAxis . boundMax -- The z-axis ---------------------------------------------------------- -- | Lens onto the z-axis of an 'Axis'. -zAxis :: R3 c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) +zAxis :: R3 c => Lens' (Axis c) (SingleAxis (BaseSpace c)) zAxis = axes . _z -- | The label for the z-axis. Shorthand for @'zAxis' . 'axisLabelText'@. -zLabel :: R3 c => Lens' (Axis b c n) String +zLabel :: R3 c => Lens' (Axis c) String zLabel = zAxis . axisLabelText -- | The minimum z value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -zMin :: R3 c => Lens' (Axis b c n) (Maybe n) +zMin :: R3 c => Lens' (Axis c) (Maybe Double) zMin = zAxis . boundMin -- | The minimum z value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. -zMax :: R3 c => Lens' (Axis b c n) (Maybe n) +zMax :: R3 c => Lens' (Axis c) (Maybe Double) zMax = zAxis . boundMax -- The r-axis ---------------------------------------------------------- -- | Lens onto the radial axis of an 'Axis'. -rAxis :: Radial c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) +rAxis :: Radial c => Lens' (Axis c) (SingleAxis (BaseSpace c)) rAxis = axes . _radial -- | The label for the radial axis. Shorthand for @'rAxis' . 'axisLabelText'@. -rLabel :: Radial c => Lens' (Axis b c n) String +rLabel :: Radial c => Lens' (Axis c) String rLabel = rAxis . axisLabelText -- | The minimum z value for the axis. If the value if 'Nothing' (the -- 'Default'), the bounds will be infered by the plots in the axis. --- rMin :: R3 c => Lens' (Axis b c n) (Maybe n) +-- rMin :: R3 c => Lens' (Axis c) (Maybe Double) -- rMin = zAxis . boundMin -- | The minimum radial value for the axis. If the value if 'Nothing' -- (the 'Default'), the bounds will be infered by the plots in the -- axis. -rMax :: Radial c => Lens' (Axis b c n) (Maybe n) +rMax :: Radial c => Lens' (Axis c) (Maybe Double) rMax = rAxis . boundMax -- The theta-axis ------------------------------------------------------ -- | Lens onto the radial axis of an 'Axis'. -thetaAxis :: Circle c => Lens' (Axis b c n) (SingleAxis b (BaseSpace c) n) +thetaAxis :: Circle c => Lens' (Axis c) (SingleAxis (BaseSpace c)) thetaAxis = axes . el etheta -- | The label for the radial axis. Shorthand for @'rAxis' . 'axisLabelText'@. -thetaLabel :: Circle c => Lens' (Axis b c n) String +thetaLabel :: Circle c => Lens' (Axis c) String thetaLabel = thetaAxis . axisLabelText @@ -521,11 +546,7 @@ -- R3 Axis -polarAxis - :: (TypeableFloat n, - Renderable (Text n) b, - Renderable (Path V2 n) b) - => Axis b Polar n +polarAxis :: Axis Polar polarAxis = Axis { _axisStyle = fadedColours , _colourBar = defColourBar diff --git a/src/Plots/Axis/ColourBar.hs b/src/Plots/Axis/ColourBar.hs --- a/src/Plots/Axis/ColourBar.hs +++ b/src/Plots/Axis/ColourBar.hs @@ -39,9 +39,8 @@ import Data.Bool (bool) import qualified Data.Foldable as F -import Data.Typeable -import Diagrams.Core.Transform (fromSymmetric) -import Diagrams.Prelude hiding (gap) +-- import Diagrams.Core.Transform (fromSymmetric) +import Diagrams.Prelude hiding (orient) import Diagrams.TwoD.Text import Plots.Axis.Grid import Plots.Axis.Labels @@ -50,29 +49,30 @@ import Plots.Types import Plots.Util +import Geometry.TwoD.Transform + -- | Options for drawing a colour bar. Note that for an axis, the -- 'ColourMap' is stored in the 'AxisStyle'. These options are for -- other aspects of the bar, not the colours used. -data ColourBar b n = ColourBar +data ColourBar = ColourBar { cbPlacement :: Placement , cbVisible :: Bool - , cbTicks :: MajorTicks V2 n - , cbMinorTicks :: MinorTicks V2 n - , cbGridLines :: MajorGridLines V2 n - , cbTickLabels :: TickLabels b V2 n - , cbDraw :: ColourMap -> QDiagram b V2 n Any - , cbWidth :: n - , cbLengthFun :: n -> n - , cbGap :: n - , cbStyle :: Style V2 n + , cbTicks :: MajorTicks V2 + , cbMinorTicks :: MinorTicks V2 + , cbGridLines :: MajorGridLines V2 + , cbTickLabels :: TickLabels V2 + , cbDraw :: ColourMap -> Diagram V2 + , cbWidth :: Double + , cbLengthFun :: Double -> Double + , cbGap :: Double + , cbStyle :: Style V2 Double } -type instance V (ColourBar b n) = V2 -type instance N (ColourBar b n) = n +type instance V ColourBar = V2 +type instance N ColourBar = Double -- | The default colour bar. -defColourBar :: (Renderable (Text n) b, Renderable (Path V2 n) b, TypeableFloat n) - => ColourBar b n +defColourBar :: ColourBar defColourBar = ColourBar { cbPlacement = rightMid , cbVisible = False @@ -87,9 +87,9 @@ , cbStyle = mempty } -class HasColourBar a b | a -> b where +class HasColourBar a where -- | Lens onto the 'ColourBar'. - colourBar :: Lens' a (ColourBar b (N a)) + colourBar :: Lens' a ColourBar -- | How to draw the colour bar. Expects a 1 by 1 box with the -- gradient going from left to right, without an outline with origin @@ -100,40 +100,40 @@ -- 'Plots.Style.axisColourMap' from "Plots.Style" -- -- Default is 'gradientColourBar'. - colourBarDraw :: Lens' a (ColourMap -> QDiagram b V2 (N a) Any) + colourBarDraw :: Lens' a (ColourMap -> Diagram V2) colourBarDraw = colourBar . lens cbDraw (\c a -> c {cbDraw = a}) -- | The width (orthogonal to the colour bar direction) of the colour -- bar. -- -- 'Default' is @20@. - colourBarWidth :: Lens' a (N a) + colourBarWidth :: Lens' a Double colourBarWidth = colourBar . lens cbWidth (\c a -> c {cbWidth = a}) -- | Set the length of the colour bar given the length of the axis the -- colour bar is aligned to. -- -- 'Default' is 'id'. - colourBarLengthFunction :: Lens' a (N a -> N a) + colourBarLengthFunction :: Lens' a (Double -> Double) colourBarLengthFunction = colourBar . lens cbLengthFun (\c a -> c {cbLengthFun = a}) -- | Gap between the axis and the colour bar (if rendered with an axis). -- -- 'Default' is @20@. - colourBarGap :: Lens' a (N a) + colourBarGap :: Lens' a Double colourBarGap = colourBar . lens cbGap (\c a -> c {cbGap = a}) -- | Style used for the outline of a colour bar. - colourBarStyle :: Lens' a (Style V2 (N a)) + colourBarStyle :: Lens' a (Style V2 Double) colourBarStyle = colourBar . lens cbStyle (\c a -> c {cbStyle = a}) -instance HasColourBar (ColourBar b n) b where +instance HasColourBar ColourBar where colourBar = id -instance HasGap (ColourBar b n) where +instance HasGap ColourBar where gap = colourBarGap -instance HasPlacement (ColourBar b n) where +instance HasPlacement ColourBar where placement = lens cbPlacement (\c p -> c {cbPlacement = p}) -- This is a kinda strange instance that I'm using as an experiment. @@ -153,7 +153,7 @@ -- When reversing the direction we map E <-> S and N <-> W. The gap -- direction is rotated to match the new position and anchor has its x -- and y flipped. -instance HasOrientation (ColourBar b n) where +instance HasOrientation ColourBar where orientation = lens getter setter where getter p @@ -183,32 +183,32 @@ & placementAnchor %~ flipX_Y & gapDirection ._Dir %~ flipX_Y -instance Typeable n => HasStyle (ColourBar b n) where - applyStyle sty = colourBarStyle %~ applyStyle sty +instance ApplyStyle ColourBar +instance HasStyle ColourBar where + style = colourBarStyle -instance Functor f => HasMajorTicks f (ColourBar b n) where +instance Functor f => HasMajorTicks f ColourBar where majorTicks = lens cbTicks (\c a -> c {cbTicks = a}) -instance Functor f => HasMinorTicks f (ColourBar b n) where +instance Functor f => HasMinorTicks f ColourBar where minorTicks = lens cbMinorTicks (\c a -> c {cbMinorTicks = a}) -instance Functor f => HasMajorGridLines f (ColourBar b n) where +instance Functor f => HasMajorGridLines f ColourBar where majorGridLines = lens cbGridLines (\c a -> c {cbGridLines = a}) -instance Functor f => HasTickLabels f (ColourBar b n) b where +instance Functor f => HasTickLabels f ColourBar where tickLabel = lens cbTickLabels (\c a -> c {cbTickLabels = a}) -instance HasVisibility (ColourBar b n) where +instance HasVisibility ColourBar where visible = lens cbVisible (\c a -> c {cbVisible = a}) -- | Add a colour bar to an object, using the bounding box for the object. addColourBar - :: (TypeableFloat n, Renderable (Path V2 n) b) - => BoundingBox V2 n -- ^ bounding box to place against - -> ColourBar b n -- + :: BoundingBox V2 Double -- ^ bounding box to place against + -> ColourBar -> ColourMap - -> (n,n) - -> QDiagram b V2 n Any + -> (Double,Double) + -> Diagram V2 addColourBar bb cbo@ColourBar {..} cm bnds | cbVisible = placeAgainst bb cbPlacement cbGap cb | otherwise = mempty @@ -224,12 +224,11 @@ -- | Render a colour bar by it's self at a given width. Note this -- ignores 'colourBarGap' and 'colourBarLengthFunction'. renderColourBar - :: (TypeableFloat n, Renderable (Path V2 n) b) - => ColourBar b n -- ^ options for colour bar - -> ColourMap -- ^ map to use - -> (n,n) -- ^ bounds of the values on the colour bar - -> n -- ^ length of the colour bar - -> QDiagram b V2 n Any + :: ColourBar -- ^ options for colour bar + -> ColourMap -- ^ map to use + -> (Double,Double) -- ^ bounds of the values on the colour bar + -> Double -- ^ length of the colour bar + -> Diagram V2 renderColourBar cb@ColourBar {..} cm bnds@(lb,ub) l | cbVisible = bar # xy id reflectY # o id (reflectY . _reflectX_Y) @@ -258,7 +257,7 @@ bar = outline <> tks <> minorTks <> gLines <> colours -- the outline - outline = rect l w # applyStyle (cbStyle & _fillTexture .~ _AC ## transparent) + outline = rect l w # applyStyle (cbStyle & _fillTexture ?~ _AC ## transparent) -- displaying the colour map colours = cbDraw cm # centerXY # scaleX l # scaleY w @@ -269,7 +268,6 @@ tks | cbTicks ^. hidden = mempty | otherwise = F.foldMap (\x -> aTick # translate (V2 (f x) (-w/2))) tickXs' - # applyStyle (cbTicks ^. majorTicksStyle) aTick = someTick (cbTicks ^. majorTicksAlignment) (cbTicks ^. majorTicksLength) minorTickXs = view minorTicksFunction cbMinorTicks tickXs bnds @@ -282,17 +280,17 @@ someTick tType d = case tType of TickSpec (fromRational -> aa) (fromRational -> bb) - -> mkP2 0 (-d*bb) ~~ mkP2 0 (d*aa) - AutoTick -> mkP2 0 (-d) ~~ mkP2 0 d + -> fromVertices [mkP2 0 (-d*bb), mkP2 0 (d*aa)] + AutoTick -> fromVertices [mkP2 0 (-d) , mkP2 0 d ] -- grid lines gridXs = filter inRange $ view majorGridLinesFunction cbGridLines tickXs bnds gLines | cbGridLines ^. hidden = mempty | otherwise = F.foldMap mkGridLine gridXs - # strokePath + # (stroke :: Path V2 Double -> Diagram V2) # applyStyle (cbGridLines ^. majorGridLinesStyle) - mkGridLine x = mkP2 (f x) (-w/2) ~~ mkP2 (f x) (w/2) + mkGridLine x = fromVertices [mkP2 (f x) (-w/2), mkP2 (f x) (w/2)] -- tick labels tickLabelXs = view tickLabelFunction cbTickLabels tickXs' bnds @@ -321,22 +319,21 @@ -- This may not be supported by all backends. -- -- <> -gradientColourBar :: (TypeableFloat n, Renderable (Path V2 n) b) => ColourMap -> QDiagram b V2 n Any +gradientColourBar :: ColourMap -> Diagram V2 gradientColourBar cm = rect 1 1 # fillTexture grad # lw none where - stops = map (\(x,c) -> GradientStop (SomeColor c) (fromRational x)) (colourList cm) - grad = defaultLG & _LG . lGradStops .~ stops + stops = map (\(x,c) -> (c,fromRational x)) (colourList cm) + grad = mkLinearGradient stops origin unitX -- defaultLG & _LG . lGradStops .~ stops -- | Construct a colour bar made up of @n@ solid square paths. The final -- diagram is 1 by 1, with origin at the middle of the left side. This -- can be used as the 'colourBarDraw' function. -- -- <> -pathColourBar :: (TypeableFloat n, Renderable (Path V2 n) b) - => Int -> ColourMap -> QDiagram b V2 n Any +pathColourBar :: Int -> ColourMap -> Diagram V2 pathColourBar n cm = ifoldMap mkR xs where mkR i x = rect d' 1 @@ -358,7 +355,7 @@ flipX_Y (V2 x y) = V2 (-y) (-x) _reflectionX_Y :: (Additive v, R2 v, Num n) => Transformation v n -_reflectionX_Y = fromSymmetric $ (_xy %~ flipX_Y) <-> (_xy %~ flipX_Y) +_reflectionX_Y = undefined -- fromSymmetric $ (_xy %~ flipX_Y) <-> (_xy %~ flipX_Y) _reflectX_Y :: (InSpace v n t, R2 v, Transformable t) => t -> t _reflectX_Y = transform _reflectionX_Y diff --git a/src/Plots/Axis/Grid.hs b/src/Plots/Axis/Grid.hs --- a/src/Plots/Axis/Grid.hs +++ b/src/Plots/Axis/Grid.hs @@ -63,14 +63,14 @@ -- Major grid lines ------------------------------------------------------------------------ -data MajorGridLines v n = MajorGridLines - { magFun :: GridLineFunction n - , magStyle :: Style v n +data MajorGridLines v = MajorGridLines + { magFun :: GridLineFunction Double + , magStyle :: Style v Double , magVisible :: Bool } deriving Typeable -type instance V (MajorGridLines v n) = v -type instance N (MajorGridLines v n) = n +type instance V (MajorGridLines v) = v +type instance N (MajorGridLines v) = Double class HasMajorGridLines f a where -- | The options for how to draw the grid lines. This can be used on @@ -81,45 +81,46 @@ -- 'majorGridLines' :: 'Lens'' ('SingleAxis' b v n) ('GridLines' v n) -- 'majorGridLines' :: 'Lens'' ('GridLines' v n) ('GridLines' v n) -- @ - majorGridLines :: LensLike' f a (MajorGridLines (V a) (N a)) + majorGridLines :: LensLike' f a (MajorGridLines (V a)) -- | The function to calculate location of the major grid lines given -- location of the major ticks and bounds. - majorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction (N a)) + majorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction Double) majorGridLinesFunction = majorGridLines . lens magFun (\gl maf -> gl {magFun = maf}) -- | The style applied to the major grid lines. - majorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + majorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) Double) majorGridLinesStyle = majorGridLines . lens magStyle (\gl sty -> gl {magStyle = sty}) -instance HasMajorGridLines f (MajorGridLines v n) where +instance HasMajorGridLines f (MajorGridLines v) where majorGridLines = id -instance (Typeable n, Floating n) => Default (MajorGridLines v n) where +instance Default (MajorGridLines v) where def = MajorGridLines { magFun = onTicksGridLineFunction , magStyle = mempty # lwO 0.8 , magVisible = True } -instance HasVisibility (MajorGridLines v n) where +instance HasVisibility (MajorGridLines v) where visible = lens magVisible (\gl b -> gl {magVisible = b}) -instance Typeable n => HasStyle (MajorGridLines v n) where - applyStyle s = majorGridLinesStyle %~ applyStyle s +instance ApplyStyle (MajorGridLines v) +instance HasStyle (MajorGridLines v) where + style = majorGridLinesStyle ------------------------------------------------------------------------ -- Minor grid lines ------------------------------------------------------------------------ -data MinorGridLines v n = MinorGridLines - { migFun :: GridLineFunction n - , migStyle :: Style v n +data MinorGridLines v = MinorGridLines + { migFun :: GridLineFunction Double + , migStyle :: Style v Double , migVisible :: Bool } deriving Typeable -type instance V (MinorGridLines v n) = v -type instance N (MinorGridLines v n) = n +type instance V (MinorGridLines v) = v +type instance N (MinorGridLines v) = Double class HasMinorGridLines f a where -- | The options for how to draw the grid lines. This can be used on @@ -130,22 +131,22 @@ -- 'minorGridLines' :: 'Lens'' ('SingleAxis' b v n) ('GridLines' v n) -- 'minorGridLines' :: 'Lens'' ('GridLines' v n) ('GridLines' v n) -- @ - minorGridLines :: LensLike' f a (MinorGridLines (V a) (N a)) + minorGridLines :: LensLike' f a (MinorGridLines (V a)) -- | The function to calculate location of the minor grid lines given -- location of the minor ticks and bounds. - minorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction (N a)) + minorGridLinesFunction :: Functor f => LensLike' f a (GridLineFunction Double) minorGridLinesFunction = minorGridLines . lens migFun (\gl mif -> gl {migFun = mif}) -- | The style applied to the minor grid lines. - minorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + minorGridLinesStyle :: Functor f => LensLike' f a (Style (V a) Double) minorGridLinesStyle = minorGridLines . lens migStyle (\gl sty -> gl {migStyle = sty}) -instance HasMinorGridLines f (MinorGridLines v n) where +instance HasMinorGridLines f (MinorGridLines v) where minorGridLines = id -instance (Typeable n, Floating n) => Default (MinorGridLines v n) where +instance Default (MinorGridLines v) where def = MinorGridLines { migFun = onTicksGridLineFunction , migStyle = mempty # lwO 0.5 @@ -153,11 +154,12 @@ } -- | Hidden by default. -instance HasVisibility (MinorGridLines v n) where +instance HasVisibility (MinorGridLines v) where visible = lens migVisible (\gl b -> gl {migVisible = b}) -instance Typeable n => HasStyle (MinorGridLines v n) where - applyStyle s = minorGridLinesStyle %~ applyStyle s +instance ApplyStyle (MinorGridLines v) +instance HasStyle (MinorGridLines v) where + style = minorGridLinesStyle ------------------------------------------------------------------------ -- Grid lines helpers @@ -184,7 +186,7 @@ -- @ gridLinesVisible :: (HasGridLines f a, Applicative f) => LensLike' f a Bool gridLinesVisible = gridLines . vis where - vis :: Traversal' (GridLines v n) Bool + vis :: Traversal' (GridLines v) Bool vis f a = (\m mn -> a & majorGridLines . visible .~ m & minorGridLines . visible .~ mn) <$> f (a ^. majorGridLines . visible) <*> f (a ^. minorGridLines . visible) @@ -194,33 +196,33 @@ ------------------------------------------------------------------------ -- | Type holding information about both major and minor grid lines. -data GridLines v n = GridLines - { majGrid :: MajorGridLines v n - , minGrid :: MinorGridLines v n +data GridLines v = GridLines + { majGrid :: MajorGridLines v + , minGrid :: MinorGridLines v } deriving Typeable -type instance V (GridLines v n) = v -type instance N (GridLines v n) = n +type instance V (GridLines v) = v +type instance N (GridLines v) = Double class (HasMinorGridLines f a, HasMajorGridLines f a) => HasGridLines f a where - gridLines :: LensLike' f a (GridLines (V a) (N a)) + gridLines :: LensLike' f a (GridLines (V a)) -instance Functor f => HasGridLines f (GridLines v n) where +instance Functor f => HasGridLines f (GridLines v) where gridLines = id -instance (Typeable n, Floating n) => Default (GridLines v n) where +instance Default (GridLines v) where def = GridLines { majGrid = def , minGrid = def } -instance Functor f => HasMajorGridLines f (GridLines v n) where +instance Functor f => HasMajorGridLines f (GridLines v) where majorGridLines = lens majGrid (\g a -> g {majGrid = a}) -instance Functor f => HasMinorGridLines f (GridLines v n) where +instance Functor f => HasMinorGridLines f (GridLines v) where minorGridLines = lens minGrid (\g a -> g {minGrid = a}) -instance Typeable n => HasStyle (GridLines v n) where +instance ApplyStyle (GridLines v) where applyStyle s = (majorGridLines %~ applyStyle s) . (minorGridLines %~ applyStyle s) -- | Hide both major and minor grid lines. @@ -248,9 +250,9 @@ majorGridLines . visible .= True -- | Traversal over both the major and minor grid styles. This can be used at several levels in the axis: -gridLinesStyle :: (HasGridLines f a, Applicative f) => LensLike' f a (Style (V a) (N a)) +gridLinesStyle :: (HasGridLines f a, Applicative f) => LensLike' f a (Style (V a) Double) gridLinesStyle = gridLines . styles where - styles :: Traversal' (GridLines v n) (Style v n) + styles :: Traversal' (GridLines v) (Style v Double) styles f a = (\m mn -> a & majorGridLinesStyle .~ m & minorGridLinesStyle .~ mn) <$> f (a ^. majorGridLinesStyle) <*> f (a ^. minorGridLinesStyle) diff --git a/src/Plots/Axis/Labels.hs b/src/Plots/Axis/Labels.hs --- a/src/Plots/Axis/Labels.hs +++ b/src/Plots/Axis/Labels.hs @@ -46,7 +46,7 @@ -- | Function to render the axis label from a string. This is very basic -- now and will be replace by a more sophisticated system. -type TextFunction b v n = TextAlignment n -> String -> QDiagram b v n Any +type TextFunction v = TextAlignment Double -> String -> Diagram v ------------------------------------------------------------------------ -- Axis labels @@ -74,45 +74,45 @@ -- @ -- -- See 'HasAxisLabel' for more advanced settings. -data AxisLabel b v n = AxisLabel - { alFun :: TextFunction b v n +data AxisLabel v = AxisLabel + { alFun :: TextFunction v , alText :: String - , alStyle :: Style v n - , alGap :: n + , alStyle :: Style v Double + , alGap :: Double , alPos :: AxisLabelPosition , alPlacement :: AxisLabelPlacement , alVisible :: Bool } -type instance V (AxisLabel b v n) = v -type instance N (AxisLabel b v n) = n +type instance V (AxisLabel v) = v +type instance N (AxisLabel v) = Double -class HasAxisLabel f a b | a -> b where +class HasAxisLabel f a where -- | The options for the label of the axis. This can be used on -- various levels of the axis: -- -- @ -- 'axisLabel' :: 'Traversal'' ('Axis' b c n) ('AxisLabel' ('BaseSpace' c) n) - -- 'axisLabel' :: 'Lens'' ('SingleAxis' b v n) ('AxisLabel' v n) + -- 'axisLabel' :: 'Lens'' ('SingleAxis' v) ('AxisLabel' v n) -- 'axisLabel' :: 'Lens'' ('AxisLabel' v n) ('AxisLabel' v n) -- @ - axisLabel :: LensLike' f a (AxisLabel b (V a) (N a)) + axisLabel :: LensLike' f a (AxisLabel (V a)) -- | The text to use when labeling the axis. axisLabelText :: Functor f => LensLike' f a String axisLabelText = axisLabel . lens alText (\al txt -> al {alText = txt}) -- | The 'TextFunction' to render the text of the axis label. - axisLabelTextFunction :: Functor f => LensLike' f a (TextFunction b (V a) (N a)) + axisLabelTextFunction :: Functor f => LensLike' f a (TextFunction (V a)) axisLabelTextFunction = axisLabel . lens alFun (\al f -> al {alFun = f}) -- | The gap between the axis and the labels, in the direction -- corresponding to the 'axisLabelPosition'. - axisLabelGap :: Functor f => LensLike' f a (N a) + axisLabelGap :: Functor f => LensLike' f a Double axisLabelGap = axisLabel . lens alGap (\al sty -> al {alGap = sty}) -- | The 'Style' to use on the rendered text. - axisLabelStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + axisLabelStyle :: Functor f => LensLike' f a (Style (V a) Double) axisLabelStyle = axisLabel . lens alStyle (\al sty -> al {alStyle = sty}) -- | The position the label will be placed parallel to the axis. @@ -124,63 +124,75 @@ axisLabelPlacement :: Functor f => LensLike' f a AxisLabelPosition axisLabelPlacement = axisLabel . lens alPos (\al sty -> al {alPos = sty}) -instance HasAxisLabel f (AxisLabel b v n) b where +instance HasAxisLabel f (AxisLabel v) where axisLabel = id -instance Typeable n => HasStyle (AxisLabel b v n) where - applyStyle = over axisLabelStyle . applyStyle +instance ApplyStyle (AxisLabel v) +instance HasStyle (AxisLabel v) where + style = axisLabelStyle -instance HasVisibility (AxisLabel b v n) where +instance HasVisibility (AxisLabel v) where visible = lens alVisible (\al b -> al {alVisible = b}) -instance HasGap (AxisLabel b v n) where +instance HasGap (AxisLabel v) where gap = axisLabelGap -instance (TypeableFloat n, Renderable (Text n) b) - => Default (AxisLabel b V2 n) where +instance Default (AxisLabel V2) where def = AxisLabel { alFun = mkText , alText = "" , alStyle = mempty & fontSize (output 11) - & recommendFillColor black + & backupFillColor black , alGap = 30 , alPos = MiddleAxisLabel , alPlacement = OutsideAxisLabel , alVisible = True } +instance Default (AxisLabel V3) where + def = AxisLabel + { alFun = mempty + , alText = "" + , alStyle = mempty & fontSize (output 11) + -- & backupFillColor black + , alGap = 30 + , alPos = MiddleAxisLabel + , alPlacement = OutsideAxisLabel + , alVisible = True + } + ------------------------------------------------------------------------ -- Tick labels ------------------------------------------------------------------------ -- | 'TickLabels' describes how to draw the labels next to ticks. See -- 'HasTickLabels' for more options. -data TickLabels b v n = TickLabels - { tlFun :: [n] -> (n,n) -> [(n, String)] - , tlTextFun :: TextFunction b v n - , tlStyle :: Style v n - , tlGap :: n +data TickLabels v = TickLabels + { tlFun :: [Double] -> (Double,Double) -> [(Double, String)] + , tlTextFun :: TextFunction v + , tlStyle :: Style v Double + , tlGap :: Double , tlVisible :: Bool } deriving Typeable -type instance V (TickLabels b v n) = v -type instance N (TickLabels b v n) = n +type instance V (TickLabels v) = v +type instance N (TickLabels v) = Double -class HasTickLabels f a b | a -> b where +class HasTickLabels f a where -- | The options for the label of ticks. This can be used on various -- levels of the axis: -- -- @ - -- 'tickLabel' :: 'Traversal'' ('Tick' b c n) ('TickLabels' ('BaseSpace' c) n) - -- 'tickLabel' :: 'Lens'' ('SingleAxis' b v n) ('TickLabels' v n) - -- 'tickLabel' :: 'Lens'' ('TickLabel' v n) ('TickLabels' v n) + -- 'tickLabel' :: 'Traversal'' ('Tick' c) ('TickLabels' ('BaseSpace' c)) + -- 'tickLabel' :: 'Lens'' ('SingleAxis' v) ('TickLabels' v) + -- 'tickLabel' :: 'Lens'' ('TickLabel' v) ('TickLabels' v) -- @ - tickLabel :: LensLike' f a (TickLabels b (V a) (N a)) + tickLabel :: LensLike' f a (TickLabels (V a)) -- | The 'TextFunction' to render the text. -- -- 'Default' is 'mkText'. - tickLabelTextFunction :: Functor f => LensLike' f a (TextFunction b (V a) (N a)) + tickLabelTextFunction :: Functor f => LensLike' f a (TextFunction (V a)) tickLabelTextFunction = tickLabel . lens tlTextFun (\tl f -> tl {tlTextFun = f}) -- | Tick labels functions are used to draw the tick labels. They have @@ -188,39 +200,48 @@ -- position of the tick and label to use at that position. -- -- 'Default' is @'atMajorTicks' 'floatShow'@ - tickLabelFunction :: Functor f => LensLike' f a ([N a] -> (N a, N a) -> [(N a, String)]) + tickLabelFunction :: Functor f => LensLike' f a ([Double] -> (Double, Double) -> [(Double, String)]) tickLabelFunction = tickLabel . lens tlFun (\tl f -> tl {tlFun = f}) -- | The 'Style' to use on the rendered text. -- -- 'Default' is @'fontSize' ('output' 11)@. - tickLabelStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + tickLabelStyle :: Functor f => LensLike' f a (Style (V a) Double) tickLabelStyle = tickLabel . lens tlStyle (\tl sty -> tl {tlStyle = sty}) -- | The gap between the axis and the tick labels. -- -- 'Default' is @12@. - tickLabelGap :: Functor f => LensLike' f a (N a) + tickLabelGap :: Functor f => LensLike' f a Double tickLabelGap = tickLabel . lens tlGap (\tl n -> tl {tlGap = n}) -instance HasTickLabels f (TickLabels b v n) b where +instance HasTickLabels f (TickLabels v) where tickLabel = id -instance HasGap (TickLabels b v n) where +instance HasGap (TickLabels v) where gap = tickLabelGap -instance (TypeableFloat n, Renderable (Text n) b) - => Default (TickLabels b V2 n) where +instance Default (TickLabels V2) where def = TickLabels { tlFun = atMajorTicks floatShow , tlTextFun = mkText , tlStyle = mempty & fontSize (output 11) - & recommendFillColor black + & backupFillColor black , tlGap = 12 , tlVisible = True } -instance HasVisibility (TickLabels b v n) where +instance Default (TickLabels V3) where + def = TickLabels + { tlFun = atMajorTicks floatShow + , tlTextFun = mempty + , tlStyle = mempty & fontSize (output 11) + -- & sc black + , tlGap = 12 + , tlVisible = True + } + +instance HasVisibility (TickLabels v) where visible = lens tlVisible (\tl b -> tl {tlVisible = b}) -- | Setter over the final positions the major ticks. This is not as @@ -237,8 +258,7 @@ -- If you want to change or add normal ticks see 'majorTicksFunction'. -- tickLabelPositions - :: (HasTickLabels f a b, Settable f) - => LensLike' f a [(N a, String)] + :: (HasTickLabels f a, Settable f) => LensLike' f a [(Double, String)] tickLabelPositions = tickLabelFunction . mapped . mapped -- | Numbers are shown as 'Float's to reduce the chance of numbers like @@ -248,7 +268,7 @@ -- | Make a 'TickLabelFunction' by specifying how to draw a single label -- from a position on the axis. -atMajorTicks :: (n -> String) -> [n] -> (n,n) -> [(n, String)] +atMajorTicks :: (Double -> String) -> [Double] -> (Double,Double) -> [(Double, String)] atMajorTicks f ticks _ = map ((,) <*> f) ticks -- -- | Use the list of strings as the labels for the axis, starting at 1 diff --git a/src/Plots/Axis/Line.hs b/src/Plots/Axis/Line.hs --- a/src/Plots/Axis/Line.hs +++ b/src/Plots/Axis/Line.hs @@ -48,20 +48,20 @@ def = BoxAxisLine -- | Information about position and style of axis lines. -data AxisLine v n = AxisLine +data AxisLine v = AxisLine { alType :: AxisLineType - , alArrowOpts :: Maybe (ArrowOpts n) + -- , alArrowOpts :: Maybe ArrowOpts , alVisible :: Bool - , alStyle :: Style v n + , alStyle :: Style v Double } deriving Typeable -type instance V (AxisLine v n) = v -type instance N (AxisLine v n) = n +type instance V (AxisLine v) = v +type instance N (AxisLine v) = Double -- | Class of object that have an 'AxisLine'. class HasAxisLine f a where -- | Lens onto the 'AxisLine'. - axisLine :: LensLike' f a (AxisLine (V a) (N a)) + axisLine :: LensLike' f a (AxisLine (V a)) -- | The position of the axis line around the axis. -- @@ -75,28 +75,32 @@ -- 'Default' is 'Nothing'. -- -- XXX (feature not currently implimented) - axisLineArrowOpts :: Functor f => LensLike' f a (Maybe (ArrowOpts (N a))) - axisLineArrowOpts = axisLine . lens alArrowOpts (\al sty -> al {alArrowOpts = sty}) + -- axisLineArrowOpts :: Functor f => LensLike' f a (Maybe (ArrowOpts (N a))) + -- axisLineArrowOpts = axisLine . lens alArrowOpts (\al sty -> al {alArrowOpts = sty}) -- | The 'Style' applied to the axis line - axisLineStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + axisLineStyle :: Functor f => LensLike' f a (Style (V a) Double) axisLineStyle = axisLine . lens alStyle (\al sty -> al {alStyle = sty}) -instance HasAxisLine f (AxisLine v n) where +instance HasAxisLine f (AxisLine v) where axisLine = id +instance ApplyStyle (AxisLine v) +instance HasStyle (AxisLine v) where + style = axisLineStyle + -- Note this is different from 'NoAxisLine'. Other parts that are -- tied to the axis line will still be present when -- 'axisLineVisible' is 'False'. But if 'NoAxisLine' is set, there -- never any line for those things to attach to, so they don't -- exist. -instance HasVisibility (AxisLine v n) where +instance HasVisibility (AxisLine v) where visible = lens alVisible (\al b -> al {alVisible = b}) -instance Typeable n => Default (AxisLine v n) where +instance Default (AxisLine v) where def = AxisLine { alType = def - , alArrowOpts = def + -- , alArrowOpts = def , alVisible = True , alStyle = mempty } diff --git a/src/Plots/Axis/Render.hs b/src/Plots/Axis/Render.hs --- a/src/Plots/Axis/Render.hs +++ b/src/Plots/Axis/Render.hs @@ -39,8 +39,9 @@ import Data.List (sort) import Data.Typeable -import Diagrams.BoundingBox +import Geometry.BoundingBox import Diagrams.Prelude +import Geometry.Envelope import Diagrams.TwoD.Text import Linear hiding (rotate, translation) @@ -62,37 +63,65 @@ import Prelude +import qualified Numeric.Interval.NonEmpty as I + +import Geometry.TwoD.Transform +import Geometry.TwoD.Ellipse + +import Diagrams.Types (Prim (..), mkQD) + ------------------------------------------------------------------------ -- Mainable instances ------------------------------------------------------------------------ -instance (TypeableFloat n, - Renderable (Path V2 n) b, - Mainable (QDiagram b V2 n Any)) - => Mainable (Axis b Polar n) where - type MainOpts (Axis b Polar n) = MainOpts (QDiagram b V2 n Any) +instance WithOutcome (Axis Polar) +instance WithOutcome (Axis V2) +instance WithOutcome (Axis V3) - mainRender opts = mainRender opts . renderAxis +instance RenderOutcome t (Diagram V2) => RenderOutcome t (Axis Polar) where + type MainOpts t (Axis Polar) = MainOpts t (Diagram V2) + resultParser t _ = resultParser t (Proxy :: Proxy (Diagram V2)) + renderOutcome t opts axis = renderOutcome t opts (renderPolarAxis axis) -instance (TypeableFloat n, - Renderable (Path V2 n) b, - Mainable (QDiagram b V2 n Any)) - => Mainable (Axis b V2 n) where - type MainOpts (Axis b V2 n) = MainOpts (QDiagram b V2 n Any) +instance RenderOutcome t (Diagram V2) => RenderOutcome t (Axis V2) where + type MainOpts t (Axis V2) = MainOpts t (Diagram V2) + resultParser t _ = resultParser t (Proxy :: Proxy (Diagram V2)) + renderOutcome t opts axis = renderOutcome t opts (renderAxis axis) - mainRender opts = mainRender opts . renderAxis +instance RenderOutcome t (Diagram V3) => RenderOutcome t (Axis V3) where + type MainOpts t (Axis V3) = MainOpts t (Diagram V3) + resultParser t _ = resultParser t (Proxy :: Proxy (Diagram V3)) + renderOutcome t opts axis = renderOutcome t opts (renderAxis axis) -instance ToResult (Axis b v n) where - type Args (Axis b v n) = () - type ResultOf (Axis b v n) = Axis b v n - toResult d _ = d +strokePathV :: (Typeable v, Metric v, Typeable n, OrderedField n) => Path v n -> QDiagram v n Any +strokePathV path = mkQD (Prim path) (getEnvelope path) mempty mempty +-- instance (TypeableFloat n, Mainable (Diagram V2)) +-- => Mainable (Axis b Polar n) where +-- type MainOpts (Axis b Polar n) = MainOpts (Diagram V2) + +-- mainRender opts = mainRender opts . renderAxis + +-- instance (TypeableFloat n, +-- Renderable (Path V2 n) b, +-- Mainable (Diagram V2)) +-- => Mainable (Axis b V2 n) where +-- type MainOpts (Axis b V2 n) = MainOpts (Diagram V2) + +-- mainRender opts = mainRender opts . renderAxis + +-- instance ToResult (Axis b v n) where +-- type Args (Axis b v n) = () +-- type ResultOf (Axis b v n) = Axis b v n + +-- toResult d _ = d + -- | 'mainWith' specialised to a 2D Axis. r2AxisMain - :: (Parseable (MainOpts (QDiagram b V2 Double Any)), - Mainable (Axis b V2 Double)) - => Axis b V2 Double + :: RenderOutcome t (Diagram V2) + => t + -> Axis V2 -> IO () r2AxisMain = mainWith @@ -108,7 +137,7 @@ -- legend entries can be obtained with 'styledPlotLegends'. This is -- what 'renderAxis' can uses internally but might be useful for -- debugging or generating your own legend. -buildPlots :: BaseSpace c ~ v => Axis b c n -> [StyledPlot b v n] +buildPlots :: BaseSpace c ~ v => Axis c -> [StyledPlot v] buildPlots a = map (appEndo $ a ^. plotModifier) $ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots) -- TODO: correct order @@ -118,21 +147,21 @@ ------------------------------------------------------------------------ -- | Renderable axes. -class RenderAxis b v n where +class RenderAxis c where -- | Render an axis to a diagram. The size of the diagram is -- determined by the 'axisSize'. - renderAxis :: Axis b v n -> QDiagram b (BaseSpace v) n Any + renderAxis :: Axis c -> Diagram (BaseSpace c) +-- R2 rendering -------------------------------------------------------- + -- | The 'RenderAxis' class provides a default way to render an axis for -- each space. -instance (TypeableFloat n, Renderable (Path V2 n) b) - => RenderAxis b V2 n where +instance RenderAxis V2 where -- | Render an axis and its plots, as well as the legend and colour -- bar. renderAxis = renderR2Axis -renderR2Axis :: (TypeableFloat n, Renderable (Path V2 n) b) - => Axis b V2 n -> QDiagram b V2 n Any +renderR2Axis :: Axis V2 -> Diagram V2 renderR2Axis a = frame 40 $ leg <> ttl @@ -159,6 +188,41 @@ -- styledPlots = buildPlots a +-- R3 rendering -------------------------------------------------------- + + +instance RenderAxis V3 where + renderAxis = renderR3Axis + +renderR3Axis :: Axis V3 -> Diagram V3 +renderR3Axis a = -- frame 15 + -- -- $ legend + (plots :: Diagram V3) + <> (drawAxis ex ey LowerLabels :: Diagram V3) + <> (drawAxis ey ex UpperLabels :: Diagram V3) + <> (drawAxis ez ey LowerLabels :: Diagram V3) + <> (drawAxis ey ez NoLabels :: Diagram V3) + <> (drawAxis ez ex NoLabels :: Diagram V3) + <> (drawAxis ex ez NoLabels :: Diagram V3) + where + spec = AxisSpec xs t (a^.axes . column logScale) (a ^. axisColourMap) + plots = foldMap (renderStyledPlot spec) styledPlots + drawAxis ll ll2 = axisOnBasis origin xs (a^.axes.el ll) (a^.axes.column logScale) t ll ll2 + -- + (xs, tv, t') = calculateScaling (a^.axes.column axisScaling) (boundingBox styledPlots) + t = tv <> t' + -- + -- bb = fromCorners (P . apply t $ fmap fst xs) (P . apply t $ fmap snd xs) + -- leg = drawLegend bb (styledPlotLegends styledPlots) (a ^. legend) + -- + + -- The colour bar + -- cBar = addColourBar bb (a^.colourBar) (a ^. axisColourMap) (a^.colourBarRange) + -- title + -- ttl = drawTitle bb (a^.title) + -- + styledPlots = buildPlots a + -- | The position of axis labels for a data LabelPosition = NoLabels @@ -169,23 +233,22 @@ deriving (Show, Eq, Typeable) axisOnBasis - :: forall b v n. (v ~ V2, TypeableFloat n, HasLinearMap v, Metric v, - Renderable (Path V2 n) b, n ~ N (v n), v ~ V (v n), OrderedField n) - => Point v n -- start of axis - -> v (n, n) -- calculated bounds - -> SingleAxis b v n -- axis data + :: forall v. (HasLinearMap v, Typeable v) + => Point v Double -- start of axis + -> v (Double, Double) -- calculated bounds + -> SingleAxis v -- axis data -> v LogScale -- log scale - -> T2 n -- transformation to apply to positions of things + -> Transformation v Double -- transformation to apply to positions of things -> E v -- direction of axis -> E v -- orthogonal direction of axis -> LabelPosition -- where (if at all) should labels be placed? - -> QDiagram b V2 n Any -- resulting axis + -> Diagram v -- resulting axis axisOnBasis p bs a ls t e eO lp | a ^. hidden = phantom axis | otherwise = axis where axis = tickLabels <> axLabels <> ticks <> line <> grid - tStroke = stroke . transform t + tStroke = strokePathV . transform t -- axis labels (x,y etc.) axLabels @@ -263,13 +326,13 @@ maTicks | a ^. majorTicks . hidden = mempty | otherwise = foldMap (positionTick majorTick) majorTickXs' - # stroke + # strokePathV # applyStyle (a ^. majorTicksStyle) -- miTicks | a ^. minorTicks . hidden = mempty | otherwise = foldMap (positionTick minorTick) minorTickXs' - # stroke + # strokePathV # applyStyle (a ^. minorTicksStyle) -- minorTick = someTick (a ^. minorTicksAlignment) (a ^. minorTicksLength) @@ -300,16 +363,16 @@ | a ^. axisLine . hidden = mempty | otherwise = foldMap mkline (map snd ys) -- merge with ticks? # transform t - # stroke + # strokePathV # lineCap LineCapSquare # applyStyle (a^.axisLineStyle) where -- TODO: Arrow for R3 mkline y = pathFromVertices - $ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v n + $ map (\x -> over lensP ((el e .~ x) . (el eO .~ y)) p) [x0, x1] :: Path v Double -- measurements - b@(x0,x1) = bs ^. el e :: (n, n) -- bounds + b@(x0,x1) = bs ^. el e :: (Double, Double) -- bounds coscale = ep e %~ coscaleNum coscaleNum = scaleNum (bs ^. el e) (ls ^. el e) yb@(y0,y1) = bs ^. el eO . if lp == UpperLabels @@ -364,8 +427,7 @@ -- Polar ------------------------------------------------------------------------ -instance (TypeableFloat n, Renderable (Path V2 n) b) - => RenderAxis b Polar n where +instance RenderAxis Polar where renderAxis = renderPolarAxis -- | An lower and upper bound for the bounding radius using @n@ envelope @@ -373,15 +435,15 @@ -- the bound. boundingRadiusR :: (InSpace V2 n a, Enveloped a) => Int -> a -> (n, n) boundingRadiusR (max 3 -> n) e = - case appEnvelope (getEnvelope e) of - Nothing -> (0,0) - Just f -> + case getEnvelope e of + EmptyEnvelope -> (0,0) + Envelope f -> let thetas = map (@@rad) $ enumFromToN 0 tau n - vs = map angleV thetas + vs = map angleDir thetas -- The lower bound is the maximum distance obtained from the -- envelope trials. We know the radius will be at least this far. - lowerBound = F.foldr (\v r -> max (f v) r) 0 vs + lowerBound = F.foldr (\v r -> max (I.sup $ f v) r) 0 vs -- In the worst case, there will be a point at the intersection of -- two neighbouring bounding planes from the envelope calculations. @@ -394,9 +456,7 @@ in (lowerBound, upperBound) -renderPolarAxis - :: (TypeableFloat n, Renderable (Path V2 n) b) - => Axis b Polar n -> QDiagram b V2 n Any +renderPolarAxis :: Axis Polar -> Diagram V2 renderPolarAxis a = frame 15 $ leg -- <> colourBar @@ -420,9 +480,7 @@ styledPlots = map (appEndo $ a ^. plotModifier) $ zipWith styleDynamic (a ^.. axisStyles) (a ^. axisPlots) -drawPolarAxis - :: forall b n. (Renderable (Path V2 n) b, TypeableFloat n) - => AxisSpec V2 n -> Polar (SingleAxis b V2 n) -> QDiagram b V2 n Any +drawPolarAxis :: AxisSpec V2 -> Polar (SingleAxis V2) -> Diagram V2 drawPolarAxis spec (Polar (V2 rA thetaA)) = fcA transparent $ rAx <> thetaAx where -- use a radius of the upper x bound for the axis (this is not ideal) @@ -449,8 +507,9 @@ where -- XXX for now the radial axis is on the theta=0 line. Need some -- way to change this - line = (origin ~~ mkP2 r 0) # applyStyle (rA^.axisLineStyle) - # transform t + line = fromVertices [origin, mkP2 r 0] + # applyStyle (rA^.axisLineStyle) + # transform t -- Radial axis label ------------------------------------------------- @@ -495,8 +554,8 @@ someTick tType d = case tType of TickSpec (fromRational -> aa) (fromRational -> bb) - -> mkP2 0 (-d*bb) ~~ mkP2 0 (d*aa) - AutoTick -> mkP2 0 (-d) ~~ mkP2 0 d + -> fromVertices [mkP2 0 (-d*bb), mkP2 0 (d*aa)] + AutoTick -> fromVertices [mkP2 0 (-d) , mkP2 0 d ] -- Radial grid lines ------------------------------------------------- @@ -507,7 +566,7 @@ majorGridRs = view majorGridLinesFunction rA majorTickRs (0,r) majorGridRs' = map (*s) $ filter rInRange majorGridRs - rMajorGridLines :: QDiagram b V2 n Any + rMajorGridLines :: Diagram V2 rMajorGridLines | rA ^. majorGridLines . hidden = mempty | otherwise = F.foldMap circle (filter (>0) majorGridRs') @@ -515,7 +574,7 @@ minorGridRs = view minorGridLinesFunction rA minorTickRs (0,r) minorGridRs' = map (*s) $ filter rInRange minorGridRs - rMinorGridLines :: QDiagram b V2 n Any + rMinorGridLines :: Diagram V2 rMinorGridLines | rA ^. minorGridLines . hidden = mempty | otherwise = F.foldMap circle (filter (>0) minorGridRs') @@ -523,17 +582,17 @@ -- Radial tick labels ------------------------------------------------ - rAxTickLabels :: QDiagram b V2 n Any + rAxTickLabels :: Diagram V2 rAxTickLabels | rA ^. tickLabel . hidden = mempty | otherwise = F.foldMap rDrawTickLabel tickLabelRs -- The positions of the tick labels. - tickLabelRs :: [(n, String)] + tickLabelRs :: [(Double, String)] tickLabelRs = view tickLabelFunction rA (filter rInRange majorTickRs) (0,r) -- Draw a single tick label given the position and the string to use - rDrawTickLabel :: (n,String) -> QDiagram b V2 n Any + rDrawTickLabel :: (Double,String) -> Diagram V2 rDrawTickLabel (x,label) = view tickLabelTextFunction rA (BoxAlignedText 0.5 1) label # translate (V2 (s*x) (- view axisLabelGap rA)) @@ -607,8 +666,8 @@ someThetaTick tType d = case tType of TickSpec (fromRational -> aa) (fromRational -> bb) - -> mkP2 (-d*bb) 0 ~~ mkP2 (d*aa) 0 - AutoTick -> mkP2 (-d) 0 ~~ mkP2 d 0 + -> fromVertices [mkP2 (-d*bb) 0, mkP2 (d*aa) 0] + AutoTick -> fromVertices [mkP2 (-d) 0 , mkP2 d 0 ] -- Angular grid lines ------------------------------------------------ @@ -620,35 +679,35 @@ majorGridThetas = view majorGridLinesFunction thetaA majorTickThetas (0,theta) majorGridThetas' = filter thetaInRange majorGridThetas - thetaMajorGridLines :: QDiagram b V2 n Any + thetaMajorGridLines :: Diagram V2 thetaMajorGridLines | thetaA ^. majorGridLines . hidden = mempty - | otherwise = F.foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) majorGridThetas' + | otherwise = F.foldMap (\phi -> fromVertices [origin, mkP2 r 0] # rotate (phi@@rad)) majorGridThetas' # transform t # applyStyle (thetaA ^. majorGridLinesStyle) minorGridThetas = view minorGridLinesFunction thetaA minorTickThetas (0,theta) minorGridThetas' = filter thetaInRange minorGridThetas - thetaMinorGridLines :: QDiagram b V2 n Any + thetaMinorGridLines :: Diagram V2 thetaMinorGridLines | thetaA ^. minorGridLines . hidden = mempty - | otherwise = F.foldMap (\phi -> origin ~~ mkP2 r 0 # rotate (phi@@rad)) minorGridThetas' + | otherwise = F.foldMap (\phi -> fromVertices [origin, mkP2 r 0] # rotate (phi@@rad)) minorGridThetas' # transform t # applyStyle (thetaA ^. minorGridLinesStyle) -- Angular tick labels ----------------------------------------------- - thetaAxTickLabels :: QDiagram b V2 n Any + thetaAxTickLabels :: Diagram V2 thetaAxTickLabels | thetaA ^. tickLabel . hidden = mempty | otherwise = F.foldMap thetaDrawTickLabel tickLabelThetas -- The positions of the tick labels. - tickLabelThetas :: [(n, String)] + tickLabelThetas :: [(Double, String)] tickLabelThetas = view tickLabelFunction thetaA majorTickThetas' (0,theta) -- Draw a single tick label given the position and the string to use - thetaDrawTickLabel :: (n, String) -> QDiagram b V2 n Any + thetaDrawTickLabel :: (Double, String) -> Diagram V2 thetaDrawTickLabel (x,label) = view tickLabelTextFunction thetaA a label # translate v diff --git a/src/Plots/Axis/Scale.hs b/src/Plots/Axis/Scale.hs --- a/src/Plots/Axis/Scale.hs +++ b/src/Plots/Axis/Scale.hs @@ -29,7 +29,7 @@ , LogScale (..) , logNumber , logPoint - , logDeform + -- , logDeform -- * Low level calculations -- | These functions are used by "Plots.Axis.Render". @@ -44,7 +44,7 @@ import Data.Default import Data.Distributive import Data.Maybe -import qualified Data.Foldable as F +-- import qualified Data.Foldable as F import Diagrams import Linear @@ -71,23 +71,23 @@ -- | Data type used that concerns everything to do with the size or -- scale of the axis. -data AxisScaling n = Scaling - { asRatio :: Maybe n +data AxisScaling = Scaling + { asRatio :: Maybe Double , asMode :: ScaleMode - , asEnlarge :: Extending n - , asBoundMin :: Maybe n - , asBoundMax :: Maybe n - , asSize :: Maybe n + , asEnlarge :: Extending + , asBoundMin :: Maybe Double + , asBoundMax :: Maybe Double + , asSize :: Maybe Double , asLogScale :: LogScale -- backup bound in case there's no inferred bounds to go by - , asBackupBoundMax :: n - , asBackupBoundMin :: n + , asBackupBoundMax :: Double + , asBackupBoundMin :: Double } -type instance N (AxisScaling n) = n +type instance N AxisScaling = Double -instance Fractional n => Default (AxisScaling n) where +instance Default AxisScaling where def = Scaling { asRatio = Nothing , asMode = AutoScale @@ -101,24 +101,24 @@ } -- | How much to extend the bounds beyond any inferred bounds. -data Extending n - = AbsoluteExtend n - | RelativeExtend n - deriving (Show, Ord, Eq, Functor) +data Extending + = AbsoluteExtend !Double + | RelativeExtend !Double + deriving (Show, Ord, Eq) -- | Do not extend the axis beyond the inferred bounds. -noExtend :: Num n => Extending n +noExtend :: Extending noExtend = AbsoluteExtend 0 -- | Class of things that have an 'AxisScaling'. class HasAxisScaling f a where -- | The way to scale in one direction. - axisScaling :: LensLike' f a (AxisScaling (N a)) + axisScaling :: LensLike' f a AxisScaling -- | The ratio relative to other axis. If no ratios are set, the ratio -- is not enforced. If at least one is set, 'Nothing' ratios are -- @1@. - scaleAspectRatio :: Functor f => LensLike' f a (Maybe (N a)) + scaleAspectRatio :: Functor f => LensLike' f a (Maybe Double) scaleAspectRatio = axisScaling . lens asRatio (\as r -> as {asRatio = r}) -- | The mode to determine how to scale the bounds in a direction. @@ -137,7 +137,7 @@ -- | How much to extend the bounds over infered bounds. This is -- ignored if a 'boundMax' or 'boundMin' is set. - axisExtend :: Functor f => LensLike' f a (Extending (N a)) + axisExtend :: Functor f => LensLike' f a Extending axisExtend = axisScaling . lens asEnlarge (\as r -> as {asEnlarge = r}) -- | The maximum bound the axis. There are helper functions for @@ -149,7 +149,7 @@ -- @ -- -- Default is 'Nothing'. - boundMin :: Functor f => LensLike' f a (Maybe (N a)) + boundMin :: Functor f => LensLike' f a (Maybe Double) boundMin = axisScaling . lens asBoundMin (\as b -> as {asBoundMin = b}) -- | The maximum bound the axis. There are helper functions for @@ -162,31 +162,30 @@ -- @ -- -- Default is 'Nothing'. - boundMax :: Functor f => LensLike' f a (Maybe (N a)) + boundMax :: Functor f => LensLike' f a (Maybe Double) boundMax = axisScaling . lens asBoundMax (\as b -> as {asBoundMax = b}) -- | The size of the rendered axis. Default is @'Just' 400@. - renderSize :: Functor f => LensLike' f a (Maybe (N a)) + renderSize :: Functor f => LensLike' f a (Maybe Double) renderSize = axisScaling . lens asSize (\as s -> as {asSize = s}) -- -- backup bound in case there's no inferred bounds to go by -- asBackupBoundMax :: n -- asBackupBoundMax :: n -asSizeSpec :: (HasLinearMap v, Num n, Ord n) => Lens' (v (AxisScaling n)) (SizeSpec v n) +asSizeSpec :: HasLinearMap v => Lens' (v AxisScaling) (SizeSpec v Double) asSizeSpec = column renderSize . iso mkSizeSpec getSpec -instance HasAxisScaling f (AxisScaling n) where +instance HasAxisScaling f AxisScaling where axisScaling = id -- calculating bounds -------------------------------------------------- -- | Calculating the bounds for an axis. calculateBounds - :: OrderedField n - => AxisScaling n -- ^ Scaling to use for this axis - -> Maybe (n, n) -- ^ Inferred bounds (from any plots) - -> (n, n) -- ^ Lower and upper bounds to use for this axis + :: AxisScaling -- ^ Scaling to use for this axis + -> Maybe (Double, Double) -- ^ Inferred bounds (from any plots) + -> (Double, Double) -- ^ Lower and upper bounds to use for this axis calculateBounds Scaling {..} mInferred = (l', u') where -- bounds are only enlarged when min/max bound wasn't set l' = l & whenever (isNothing asBoundMin) (subtract x) @@ -215,10 +214,10 @@ -- - scale to match desired 'scaleAspectRatio' -- - scale to match desired 'asSizeSpec' calculateScaling - :: (HasLinearMap v, OrderedField n, Applicative v) - => v (AxisScaling n) -- ^ axis scaling options - -> BoundingBox v n -- ^ bounding box from the axis plots - -> (v (n,n), Transformation v n, Transformation v n) + :: (HasLinearMap v, Applicative v) + => v AxisScaling -- ^ axis scaling options + -> BoundingBox v Double -- ^ bounding box from the axis plots + -> (v (Double,Double), Transformation v Double, Transformation v Double) calculateScaling aScaling bb = (bounds, aspectScaling, sizeScaling) where -- final bounds of the axis @@ -231,8 +230,8 @@ -- aScaling. Otherwise no ratios are set, ignore them and scale -- such that each axis is the same length | anyOf (folded . scaleAspectRatio) isJust aScaling - = vectorScaling $ view (scaleAspectRatio . non 1) <$> aScaling - | otherwise = inv $ vectorScaling v + = scalingV $ view (scaleAspectRatio . non 1) <$> aScaling + | otherwise = inv $ scalingV v -- scaling used so the axis fits in the size spec sizeScaling = requiredScaling szSpec v' @@ -242,11 +241,6 @@ v' = apply aspectScaling v szSpec = view asSizeSpec aScaling --- | Scale transformation using the respective scale coefficients in the vector. -vectorScaling :: (Additive v, Fractional n) => v n -> Transformation v n -vectorScaling v = fromLinear f f - where f = liftI2 (*) v <-> liftI2 (flip (/)) v - -- | Apply a function if the predicate is true. whenever :: Bool -> (a -> a) -> a -> a whenever b f = bool id f b @@ -283,9 +277,9 @@ -- | Deform an object according to the axis scale. Does nothing for -- linear scales. -logDeform :: (InSpace v n a, F.Foldable v, Floating n, Deformable a a) - => v LogScale -> a -> a -logDeform v - | allOf folded (== LinearAxis) v = id - | otherwise = deform (Deformation $ logPoint v) +-- logDeform :: (InSpace v n a, F.Foldable v, Floating n, Deformable a a) +-- => v LogScale -> a -> a +-- logDeform v +-- | allOf folded (== LinearAxis) v = id +-- | otherwise = deform (Deformation $ logPoint v) diff --git a/src/Plots/Axis/Ticks.hs b/src/Plots/Axis/Ticks.hs --- a/src/Plots/Axis/Ticks.hs +++ b/src/Plots/Axis/Ticks.hs @@ -52,7 +52,6 @@ ) where import Control.Lens hiding (transform, ( # )) -import Data.Data import Data.Default import Data.Foldable as F import Data.Ord @@ -104,15 +103,15 @@ ------------------------------------------------------------------------ -- | The big ticks on the axis line. -data MajorTicks v n = MajorTicks - { matFunction :: (n,n) -> [n] +data MajorTicks v = MajorTicks + { matFunction :: (Double,Double) -> [Double] , matAlign :: TicksAlignment - , matLength :: n - , matStyle :: Style v n + , matLength :: Double + , matStyle :: Style v Double , matVisible :: Bool } -instance TypeableFloat n => Default (MajorTicks v n) where +instance Default (MajorTicks v) where def = MajorTicks { matFunction = linearMajorTicks 5 , matAlign = autoTicks @@ -121,20 +120,20 @@ , matVisible = True } -type instance V (MajorTicks v n) = v -type instance N (MajorTicks v n) = n +type instance V (MajorTicks v) = v +type instance N (MajorTicks v) = Double -- | Class of things that have a 'MajorTicks'. class HasMajorTicks f a where -- | Lens onto the 'MajorTicks' of something. - majorTicks :: LensLike' f a (MajorTicks (V a) (N a)) + majorTicks :: LensLike' f a (MajorTicks (V a)) -- | The function used to place ticks for this axis, given the bounds -- of the axis. The result of these major ticks are also used as -- guides for 'MinorTicks', 'MajorGridLines' and 'MinorGridLines'. -- -- Default is @'linearMinorTicks' 5@. - majorTicksFunction :: Functor f => LensLike' f a ((N a, N a) -> [N a]) + majorTicksFunction :: Functor f => LensLike' f a ((Double, Double) -> [Double]) majorTicksFunction = majorTicks . lens matFunction (\mat a -> mat {matFunction = a}) -- | Alignment of the major ticks. Choose between 'autoTicks' @@ -145,38 +144,42 @@ -- | The total length the major ticks. -- -- Default is @7@. - majorTicksLength :: Functor f => LensLike' f a (N a) + majorTicksLength :: Functor f => LensLike' f a Double majorTicksLength = majorTicks . lens matLength (\mat a -> mat {matLength = a}) -- | The style used to render the major ticks. -- -- Default is @'lwO' 0.6 'mempty'@ (subject to change). - majorTicksStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + majorTicksStyle :: Functor f => LensLike' f a (Style (V a) Double) majorTicksStyle = majorTicks . lens matStyle (\mat sty -> mat {matStyle = sty}) -instance HasMajorTicks f (MajorTicks v n) where +instance HasMajorTicks f (MajorTicks v) where majorTicks = id -instance HasVisibility (MajorTicks v n) where +instance HasVisibility (MajorTicks v) where visible = lens matVisible (\mat b -> mat {matVisible = b}) +instance ApplyStyle (MajorTicks v) where +instance HasStyle (MajorTicks v) where + style = majorTicksStyle + ------------------------------------------------------------------------ -- Minor ticks ------------------------------------------------------------------------ -- | The small ticks on the axis line. -data MinorTicks v n = MinorTicks - { mitFunction :: [n] -> (n,n) -> [n] +data MinorTicks v = MinorTicks + { mitFunction :: [Double] -> (Double,Double) -> [Double] , mitAlign :: TicksAlignment - , mitLength :: n - , mitStyle :: Style v n + , mitLength :: Double + , mitStyle :: Style v Double , mitVisible :: Bool } -type instance V (MinorTicks v n) = v -type instance N (MinorTicks v n) = n +type instance V (MinorTicks v) = v +type instance N (MinorTicks v) = Double -instance TypeableFloat n => Default (MinorTicks v n) where +instance Default (MinorTicks v) where def = MinorTicks { mitFunction = minorTicksHelper 4 , mitAlign = autoTicks @@ -188,13 +191,13 @@ -- | Class of things that have a single 'MinorTicks'. class HasMinorTicks f a where -- | Lens onto the 'MinorTicks' of something. - minorTicks :: LensLike' f a (MinorTicks (V a) (N a)) + minorTicks :: LensLike' f a (MinorTicks (V a)) -- | The function used to place ticks for this axis, given the result -- of 'majorTicksFunction' and the bounds of the axis. -- -- Default is @'linearMinorTicks' 3@. - minorTicksFunction :: Functor f => LensLike' f a ([N a] -> (N a, N a) -> [N a]) + minorTicksFunction :: Functor f => LensLike' f a ([Double] -> (Double, Double) -> [Double]) minorTicksFunction = minorTicks . lens mitFunction (\mit a -> mit {mitFunction = a}) -- | Alignment of the minor ticks. Choose between 'autoTicks' @@ -205,52 +208,56 @@ -- | The total length the minor ticks. -- -- Default is @3@. - minorTicksLength :: Functor f => LensLike' f a (N a) + minorTicksLength :: Functor f => LensLike' f a Double minorTicksLength = minorTicks . lens mitLength (\mit a -> mit {mitLength = a}) -- | The style used to render the minor ticks. -- -- Default is @'lwO' 0.4 'mempty'@ (subject to change). - minorTicksStyle :: Functor f => LensLike' f a (Style (V a) (N a)) + minorTicksStyle :: Functor f => LensLike' f a (Style (V a) Double) minorTicksStyle = minorTicks . lens mitStyle (\mit sty -> mit {mitStyle = sty}) -instance HasMinorTicks f (MinorTicks v n) where +instance HasMinorTicks f (MinorTicks v) where minorTicks = id -instance HasVisibility (MinorTicks v n) where +instance HasVisibility (MinorTicks v) where visible = lens mitVisible (\mit sty -> mit {mitVisible = sty}) +instance ApplyStyle (MinorTicks v) where +instance HasStyle (MinorTicks v) where + style = minorTicksStyle + ------------------------------------------------------------------------ -- Both ticks ------------------------------------------------------------------------ -- | Both 'MajorTicks' and 'MinorTicks' together. -data Ticks v n = Ticks (MajorTicks v n) (MinorTicks v n) +data Ticks v = Ticks (MajorTicks v) (MinorTicks v) -- Ticks are originally split up into major and minor so we can reuse -- major for the colour bar. I'm still undecided whether it's worth all -- the extra boilerplate here. -type instance V (Ticks v n) = v -type instance N (Ticks v n) = n +type instance V (Ticks v) = v +type instance N (Ticks v) = Double -- | Class of things with both 'MajorTicks' and 'MinorTicks'. class (HasMinorTicks f a, HasMajorTicks f a) => HasTicks f a where - bothTicks :: LensLike' f a (Ticks (V a) (N a)) + bothTicks :: LensLike' f a (Ticks (V a)) -instance Functor f => HasTicks f (Ticks v n) where +instance Functor f => HasTicks f (Ticks v) where bothTicks = id -instance Functor f => HasMajorTicks f (Ticks v n) where +instance Functor f => HasMajorTicks f (Ticks v) where majorTicks f (Ticks ma mi) = f ma <&> \ma' -> Ticks ma' mi -instance Functor f => HasMinorTicks f (Ticks v n) where +instance Functor f => HasMinorTicks f (Ticks v) where minorTicks f (Ticks ma mi) = f mi <&> \mi' -> Ticks ma mi' -instance TypeableFloat n => Default (Ticks v n) where +instance Default (Ticks v) where def = Ticks def def -instance Typeable n => HasStyle (Ticks v n) where - applyStyle s = over ticksStyle (applyStyle s) +instance ApplyStyle (Ticks v) where + applyStyle = over ticksStyle . applyStyle -- | Traversal over both major and minor tick alignment. ticksAlign :: (HasTicks f a, Applicative f) => LensLike' f a TicksAlignment @@ -260,7 +267,7 @@ <$> f (a ^. majorTicksAlignment) <*> f (a ^. minorTicksAlignment) -- | Traversal over both major and minor tick styles. -ticksStyle :: (HasTicks f a, Applicative f) => LensLike' f a (Style (V a) (N a)) +ticksStyle :: (HasTicks f a, Applicative f) => LensLike' f a (Style (V a) Double) ticksStyle = bothTicks . styles where styles f a = (\m mn -> a & majorTicksStyle .~ m & minorTicksStyle .~ mn) @@ -291,7 +298,7 @@ -- you want to add or modify existing tick positions. majorTickPositions :: (HasMajorTicks f a, Settable f) - => LensLike' f a [N a] + => LensLike' f a [Double] majorTickPositions = majorTicksFunction . mapped -- | Setter over the final positions the major ticks. This is not as @@ -300,7 +307,7 @@ -- you want to add or modify existing tick positions. minorTickPositions :: (HasMinorTicks f a, Settable f) - => LensLike' f a [N a] + => LensLike' f a [Double] minorTickPositions = minorTicksFunction . mapped . mapped ------------------------------------------------------------------------ diff --git a/src/Plots/Axis/Title.hs b/src/Plots/Axis/Title.hs --- a/src/Plots/Axis/Title.hs +++ b/src/Plots/Axis/Title.hs @@ -30,18 +30,17 @@ import Diagrams.TwoD.Text import Plots.Types -data Title b v n = Title +data Title v = Title { tVisible :: Bool , tTxt :: String - , tTxtFun :: TextAlignment n -> String -> QDiagram b v n Any - , tStyle :: Style v n + , tTxtFun :: TextAlignment Double -> String -> Diagram v + , tStyle :: Style v Double , tPlacement :: Placement - , tAlignment :: TextAlignment n - , tGap :: n + , tAlignment :: TextAlignment Double + , tGap :: Double } deriving Typeable -instance (Renderable (Text n) b, TypeableFloat n) - => Default (Title b V2 n) where +instance Default (Title V2) where def = Title { tVisible = True , tTxt = "" @@ -52,20 +51,31 @@ , tGap = 20 } -type instance V (Title b v n) = v -type instance N (Title b v n) = n +instance Default (Title V3) where + def = Title + { tVisible = True + , tTxt = "" + , tTxtFun = mempty + , tStyle = mempty # fontSize (output 11) + , tPlacement = midAbove + , tAlignment = BoxAlignedText 0.5 0 + , tGap = 20 + } -instance HasVisibility (Title b v n) where +type instance V (Title v) = v +type instance N (Title v) = Double + +instance HasVisibility (Title v) where visible = lens tVisible (\t b -> t {tVisible = b}) -instance HasGap (Title b v n) where +instance HasGap (Title v) where gap = lens tGap (\t g -> t {tGap = g}) -instance HasPlacement (Title b v n) where +instance HasPlacement (Title v) where placement = titlePlacement -class HasTitle a b | a -> b where - title :: Lens' a (Title b (V a) (N a)) +class HasTitle a where + title :: Lens' a (Title (V a)) -- | The text used for the title. If the string is empty, no title is -- drawn. @@ -77,7 +87,7 @@ -- | The style applied to the title. -- -- Default is 'mempty'. - titleStyle :: Lens' a (Style (V a) (N a)) + titleStyle :: Lens' a (Style (V a) Double) titleStyle = title . lens tStyle (\t s -> t {tStyle = s}) -- | The placement of the title against the axis. @@ -89,31 +99,30 @@ -- | The function used to draw the title text. -- -- Default is 'mkText'. - titleTextFunction :: Lens' a (TextAlignment (N a) -> String -> QDiagram b (V a) (N a) Any) + titleTextFunction :: Lens' a (TextAlignment Double -> String -> Diagram (V a)) titleTextFunction = title . lens tTxtFun (\t s -> t {tTxtFun = s}) -- | The 'TextAlignment' used for the title text. This is given to the -- 'titleTextFunction'. -- -- Default is @'BoxAlignedText' 0.5 0@. - titleAlignment :: Lens' a (TextAlignment (N a)) + titleAlignment :: Lens' a (TextAlignment Double) titleAlignment = title . lens tAlignment (\t s -> t {tAlignment = s}) -- | The gap between the axis and the title. -- -- Default is 'mempty'. - titleGap :: Lens' a (N a) + titleGap :: Lens' a Double titleGap = title . lens tGap (\t s -> t {tGap = s}) -instance HasTitle (Title b v n) b where +instance HasTitle (Title v) where title = id -- | Render the title and place it around the bounding box. drawTitle - :: TypeableFloat n - => BoundingBox V2 n - -> Title b V2 n - -> QDiagram b V2 n Any + :: BoundingBox V2 Double + -> Title V2 + -> Diagram V2 drawTitle bb t | t ^. hidden || nullOf titleText t = mempty | otherwise = placeAgainst diff --git a/src/Plots/Legend.hs b/src/Plots/Legend.hs --- a/src/Plots/Legend.hs +++ b/src/Plots/Legend.hs @@ -23,58 +23,58 @@ import Data.Typeable import Diagrams.TwoD.Text -import Diagrams.BoundingBox -import Diagrams.Prelude +import Geometry.BoundingBox +import Diagrams.Prelude hiding (orient) import Plots.Types -- | The data type to describe how to draw a legend. For legend entries -- see 'Plots.Types.LegendEntry'. -data Legend b n = Legend +data Legend = Legend { lPlacement :: Placement - , lGap :: n - , lStyle :: Style V2 n - , lSpacing :: n - , lTextWidth :: n - , lTextF :: String -> QDiagram b V2 n Any - , lTextStyle :: Style V2 n + , lGap :: Double + , lStyle :: Style V2 Double + , lSpacing :: Double + , lTextWidth :: Double + , lTextF :: String -> Diagram V2 + , lTextStyle :: Style V2 Double , lOrientation :: Orientation , lVisible :: Bool } deriving Typeable -type instance V (Legend b n) = V2 -type instance N (Legend b n) = n +type instance V Legend = V2 +type instance N Legend = Double -class HasLegend a b | a -> b where +class HasLegend a where -- | Lens onto the 'Legend' of something. - legend :: Lens' a (Legend b (N a)) + legend :: Lens' a Legend -- | The 'Placement' of the legend relative to the 'Plots.Axis.Axis'. legendPlacement :: Lens' a Placement legendPlacement = legend . lens lPlacement (\l a -> l {lPlacement = a}) -- | The gap between the legend and the axis. - legendGap :: Lens' a (N a) + legendGap :: Lens' a Double legendGap = legend . lens lGap (\l a -> l {lGap = a}) -- | The style applied to the surronding box of the legend. - legendStyle :: Lens' a (Style V2 (N a)) + legendStyle :: Lens' a (Style V2 Double) legendStyle = legend . lens lStyle (\l a -> l {lStyle = a}) -- | The spacing between entries in the legend. - legendSpacing :: Lens' a (N a) + legendSpacing :: Lens' a Double legendSpacing = legend . lens lSpacing (\l a -> l {lSpacing = a}) -- | The space given for the text in the legend. - legendTextWidth :: Lens' a (N a) + legendTextWidth :: Lens' a Double legendTextWidth = legend . lens lTextWidth (\l a -> l {lTextWidth = a}) -- | The function to generate the legend text. - legendTextFunction :: Lens' a (String -> QDiagram b V2 (N a) Any) + legendTextFunction :: Lens' a (String -> Diagram V2) legendTextFunction = legend . lens lTextF (\l a -> l {lTextF = a}) -- | The style applied to the legend text. - legendTextStyle :: Lens' a (Style V2 (N a)) + legendTextStyle :: Lens' a (Style V2 Double) legendTextStyle = legend . lens lTextStyle (\l a -> l {lTextStyle = a}) -- | The way the legend entries are listed. (This will likely be @@ -82,16 +82,16 @@ legendOrientation :: Lens' a Orientation legendOrientation = legend . lens lOrientation (\l a -> l {lOrientation = a}) -instance HasLegend (Legend b n) b where +instance HasLegend Legend where legend = id -instance HasGap (Legend b n) where +instance HasGap Legend where gap = legendGap -instance HasPlacement (Legend b n) where +instance HasPlacement Legend where placement = legendPlacement -instance (TypeableFloat n, Renderable (Text n) b) => Default (Legend b n) where +instance Default Legend where def = Legend { lPlacement = rightTop , lGap = 20 @@ -104,24 +104,26 @@ , lVisible = True } -instance HasVisibility (Legend b n) where +instance HasVisibility Legend where visible = lens lVisible (\l a -> l {lVisible = a}) -instance TypeableFloat n => HasStyle (Legend b n) where - applyStyle sty = over legendStyle (applyStyle sty) +instance ApplyStyle Legend -instance HasOrientation (Legend b n) where +-- | The style for the bounding box of the legend. +instance HasStyle Legend where + style = legendStyle + {-# INLINE style #-} + +instance HasOrientation Legend where orientation = legendOrientation -- | Draw a legend to the bounding box using the legend entries and -- legend options. drawLegend - :: (TypeableFloat n, - Renderable (Path V2 n) b) - => BoundingBox V2 n -- ^ bounding box to place legend against - -> [(QDiagram b V2 n Any, String)] -- ^ diagram pictures along with their key - -> Legend b n -- ^ options for drawing the legend - -> QDiagram b V2 n Any -- ^ rendered legend + :: BoundingBox V2 Double -- ^ bounding box to place legend against + -> [(Diagram V2, String)] -- ^ diagram pictures along with their key + -> Legend -- ^ options for drawing the legend + -> Diagram V2 -- ^ rendered legend drawLegend bb entries l | l ^. hidden || null entries = mempty | otherwise = placeAgainst diff --git a/src/Plots/Name.hs b/src/Plots/Name.hs --- a/src/Plots/Name.hs +++ b/src/Plots/Name.hs @@ -3,48 +3,48 @@ module Plots.Name where -import Control.Lens --- import Data.Map (Map) -import Data.Ord (comparing) -import Data.Function -import Data.Typeable -import Diagrams.Core.Names -import Diagrams.Prelude hiding (view) +-- import Control.Lens +-- -- import Data.Map (Map) +-- import Data.Ord (comparing) +-- import Data.Function +-- import Data.Typeable +-- import Diagrams.Types.Names +-- import Diagrams.Prelude hiding (view) -data PlotName n = PlotName - { _plotName :: String - , _namedSize2D :: SizeSpec V2 n - , _namedT2 :: T2 n - } deriving Typeable +-- data PlotName = PlotName +-- { _plotName :: String +-- , _namedSize2D :: SizeSpec V2 Double +-- , _namedT2 :: T2 Double +-- } deriving Typeable -makeLenses ''PlotName +-- makeLenses ''PlotName -instance Show (PlotName n) where - show pn = "Plot: " ++ view plotName pn +-- instance Show PlotName where +-- show pn = "Plot: " ++ view plotName pn --- equating :: Eq b => (a -> b) -> a -> a -> Bool --- equating = on (==) +-- -- equating :: Eq b => (a -> b) -> a -> a -> Bool +-- -- equating = on (==) -instance Eq (PlotName n) where - (==) = on (==) (view plotName) +-- instance Eq PlotName where +-- (==) = on (==) (view plotName) -instance Ord (PlotName n) where - compare = comparing (view plotName) +-- instance Ord PlotName where +-- compare = comparing (view plotName) -instance Typeable n => IsName (PlotName n) +-- instance IsName PlotName --- _AName :: IsName a => Prism' AName a --- _AName = prism' AName (\(AName a) -> cast a) +-- -- _AName :: IsName a => Prism' AName a +-- -- _AName = prism' AName (\(AName a) -> cast a) --- _Names :: IsName a => Traversal' Name a --- _Names = _Wrapped' . traverse . _AName +-- -- _Names :: IsName a => Traversal' Name a +-- -- _Names = _Wrapped' . traverse . _AName --- _NamedString :: Traversal' Name String --- _NamedString = _Names +-- -- _NamedString :: Traversal' Name String +-- -- _NamedString = _Names --- _NamedPlot :: Typeable n => Traversal' Name (PlotName n) --- _NamedPlot = _Names +-- -- _NamedPlot :: Typeable n => Traversal' Name (PlotName n) +-- -- _NamedPlot = _Names --- diaNames :: OrderedField n => QDiagram b V2 n Any -> Map Name [P2 n] --- diaNames = over (mapped . traversed) location . view (subMap . _Wrapped') +-- -- diaNames :: OrderedField n => QDiagram b V2 n Any -> Map Name [P2 n] +-- -- diaNames = over (mapped . traversed) location . view (subMap . _Wrapped') diff --git a/src/Plots/Style.hs b/src/Plots/Style.hs --- a/src/Plots/Style.hs +++ b/src/Plots/Style.hs @@ -29,6 +29,7 @@ -- ** Predefined styles , fadedColours + , fadedColours3D , vividColours , blackAndWhite @@ -82,6 +83,10 @@ import Diagrams.Prelude hiding (magma) import Linear +import Diagrams.ThreeD.Attributes + +import Geometry + -- | Plot styles are used to style each plot in an axis. Every 'Axis' -- comes with a list of plots styles (contained in the 'AxisStyle') -- which get applied the plots upon rendering. @@ -121,23 +126,23 @@ -- 'histogramPlot') -- * 'markerStyle' - style used for markers in 'scatterPlot' -- * 'plotMarker' - marker used in 'scatterPlot' -data PlotStyle b v n = PlotStyle +data PlotStyle v = PlotStyle { _plotColour :: Colour Double - , _lineStyle :: Colour Double -> Style v n - , _markerStyle :: Colour Double -> Style v n - , _areaStyle :: Colour Double -> Style v n - , _textStyle :: Colour Double -> Style v n - , _plotMarker :: QDiagram b v n Any + , _lineStyle :: Colour Double -> Style v Double + , _markerStyle :: Colour Double -> Style v Double + , _areaStyle :: Colour Double -> Style v Double + , _textStyle :: Colour Double -> Style v Double + , _plotMarker :: Diagram v } deriving Typeable -- XXX link to examples in haddock? -type instance V (PlotStyle b v n) = v -type instance N (PlotStyle b v n) = n +type instance V (PlotStyle v) = v +type instance N (PlotStyle v) = Double -- | Class for objects that contain a 'PlotStyle'. -class HasPlotStyle f a b | a -> b where +class HasPlotStyle f a where -- | Lens onto the 'PlotStyle'. - plotStyle :: LensLike' f a (PlotStyle b (V a) (N a)) + plotStyle :: LensLike' f a (PlotStyle (V a)) -- | The 'plotColour' is the overall colour of the plot. This is passed -- to the other styles ('lineStyle', 'markerStyle' etc.) to give an @@ -152,61 +157,60 @@ -- | This style is applied to any plots made up of lines only (like -- 'Path' plots). This is a less general version of -- 'lineStyleFunction'. - lineStyle :: Settable f => LensLike' f a (Style (V a) (N a)) + lineStyle :: Settable f => LensLike' f a (Style (V a) Double) lineStyle = lineStyleFunction . mapped -- | A version 'lineStyle' with access to the current 'plotColour' -- when 'applyLineStyle' is used. - lineStyleFunction :: Functor f => LensLike' f a (Colour Double -> - Style (V a) (N a)) + lineStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) lineStyleFunction = plotStyle . lens _lineStyle (\p f -> p {_lineStyle = f}) -- | This style is applied to any markers in the plot (usually the -- 'plotMarker'). This is a less general version of -- 'markerStyleFunction'. - markerStyle :: Settable f => LensLike' f a (Style (V a) (N a)) + markerStyle :: Settable f => LensLike' f a (Style (V a) Double) markerStyle = markerStyleFunction . mapped -- | A version 'lineStyle' with access to the current 'plotColour' when -- 'applyMarkerStyle' is used. - markerStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) (N a)) + markerStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) markerStyleFunction = plotStyle . lens _markerStyle (\p f -> p {_markerStyle = f}) -- | This style is applied to any filled areas in a plot (like -- 'Plots.Types.Bar' or 'Plots.Styles.Ribbon'). This is a less -- general version of 'areaStyleFunction'. - areaStyle :: Settable f => LensLike' f a (Style (V a) (N a)) + areaStyle :: Settable f => LensLike' f a (Style (V a) Double) areaStyle = areaStyleFunction . mapped -- | A version 'areaStyle' with access to the current 'plotColour' when -- 'applyAreaStyle' is used. - areaStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) (N a)) + areaStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) areaStyleFunction = plotStyle . lens _areaStyle (\p f -> p {_areaStyle = f}) -- | This style is applied to text plots. This is a less general -- version of 'textStyleFunction'. - textStyle :: Settable f => LensLike' f a (Style (V a) (N a)) + textStyle :: Settable f => LensLike' f a (Style (V a) Double) textStyle = textStyleFunction . mapped -- | A version 'textStyle' with access to the current 'plotColour' when -- 'applyAreaStyle' is used. - textStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) (N a)) + textStyleFunction :: Functor f => LensLike' f a (Colour Double -> Style (V a) Double) textStyleFunction = plotStyle . lens _textStyle (\p f -> p {_textStyle = f}) -- | This diagram is used as any markers in a plot (like -- 'Plots.Types.Scatter'). The 'markerStyle' will be applied to this -- marker when the plot gets rendered. - plotMarker :: Functor f => LensLike' f a (QDiagram b (V a) (N a) Any) + plotMarker :: Functor f => LensLike' f a (Diagram (V a)) plotMarker = plotStyle . lens _plotMarker (\p f -> p {_plotMarker = f}) -- | A traversal over all the styles ('lineStyle', 'markerStyle', -- 'areaStyle' and 'textStyle') of a 'PlotStyle'. This is a less -- general version of 'plotStyleFunctions'. - plotStyles :: Settable f => LensLike' f a (Style (V a) (N a)) + plotStyles :: Settable f => LensLike' f a (Style (V a) Double) plotStyles = plotStyleFunctions . mapped -- | A version of 'plotStyles' with access to the 'plotColour'. - plotStyleFunctions :: Applicative f => LensLike' f a (Colour Double -> Style (V a) (N a)) + plotStyleFunctions :: Applicative f => LensLike' f a (Colour Double -> Style (V a) Double) plotStyleFunctions = plotStyle . t where t f PlotStyle {..} = PlotStyle @@ -217,7 +221,7 @@ <*> f _textStyle <*> pure _plotMarker -instance HasPlotStyle f (PlotStyle b v n) b where +instance HasPlotStyle f (PlotStyle v) where plotStyle = id -- Applying styles ----------------------------------------------------- @@ -225,48 +229,48 @@ -- | Apply the 'lineStyle' from a 'PlotStyle'. -- -- @ --- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t +-- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t -- @ applyLineStyle - :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) - => a -> t -> t + :: (InSpace v Double t, ApplyStyle t) + => PlotStyle v -> t -> t applyLineStyle (view plotStyle -> sty) = applyStyle $ (sty ^. lineStyleFunction) (sty ^. plotColour) -- | Apply the 'markerStyle' from a 'PlotStyle'. -- -- @ --- applyMarkerStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t +-- applyMarkerStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t -- @ applyMarkerStyle - :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) - => a -> t -> t + :: (InSpace v Double t, ApplyStyle t) + => PlotStyle v -> t -> t applyMarkerStyle (view plotStyle -> sty) = applyStyle $ (sty ^. markerStyleFunction) (sty ^. plotColour) -- | Apply the 'areaStyle from a 'PlotStyle'. -- -- @ --- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t +-- applyLineStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t -- @ applyAreaStyle - :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) - => a -> t -> t + :: (InSpace v Double t, ApplyStyle t) + => PlotStyle v -> t -> t applyAreaStyle (view plotStyle -> sty) = applyStyle $ (sty ^. areaStyleFunction) (sty ^. plotColour) -- | Apply the 'textStyle' from a 'PlotStyle'. -- -- @ --- applyTextStyle :: (InSpace v n t, HasStyle t) => PlotStyle b v n -> t -> t +-- applyTextStyle :: (InSpace v n t, HasStyle t) => PlotStyle v -> t -> t -- @ applyTextStyle - :: (SameSpace a t, HasPlotStyle (Const (PlotStyle b (V a) (N a))) a b, HasStyle t) - => a -> t -> t + :: (InSpace v Double t, ApplyStyle t) + => PlotStyle v -> t -> t applyTextStyle (view plotStyle -> sty) = applyStyle $ (sty ^. textStyleFunction) (sty ^. plotColour) -instance (Metric v, Traversable v, OrderedField n) => Transformable (PlotStyle b v n) where +instance (Metric v, Traversable v) => Transformable (PlotStyle v) where transform t = (plotMarker %~ transform t) . (plotStyles %~ transform t) ------------------------------------------------------------------------ @@ -275,15 +279,15 @@ -- | The 'AxisStyle' determines the 'Style's of the plots in an axis. -- There are various predefined styles to change the look of the plot. -data AxisStyle b v n = AxisStyle ColourMap [PlotStyle b v n] +data AxisStyle v = AxisStyle ColourMap [PlotStyle v] -type instance V (AxisStyle b v n) = v -type instance N (AxisStyle b v n) = n +type instance V (AxisStyle v) = v +type instance N (AxisStyle v) = Double -- | Class of things that have an 'AxisStyle'. -class HasAxisStyle a b | a -> b where +class HasAxisStyle a where -- | Lens onto the 'AxisStyle'. - axisStyle :: Lens' a (AxisStyle b (V a) (N a)) + axisStyle :: Lens' a (AxisStyle (V a)) -- | The 'ColourMap' is used to draw the 'Plots.Axis.ColourBar' and -- render plots like 'Plots.HeatMap'. @@ -293,14 +297,14 @@ -- | Traversal over the 'PlotStyle's in an 'AxisStyle'. There are always -- an infinite number of 'PlotStyle's in an 'AxisStyle'. - axisStyles :: IndexedTraversal' Int a (PlotStyle b (V a) (N a)) + axisStyles :: IndexedTraversal' Int a (PlotStyle (V a)) axisStyles = axisStyle . stys . traversed where stys f (AxisStyle c ss) = f ss <&> \ss' -> AxisStyle c ss' -instance HasAxisStyle (AxisStyle b v n) b where +instance HasAxisStyle (AxisStyle v) where axisStyle = id -instance Applicative f => HasPlotStyle f (AxisStyle b v n) b where +instance Applicative f => HasPlotStyle f (AxisStyle v) where plotStyle = axisStyles ------------------------------------------------------------------------ @@ -327,7 +331,7 @@ -- | Theme using 'funColours' with faded fills and thick lines. -- -- <> -fadedColours :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n +fadedColours :: AxisStyle V2 fadedColours = AxisStyle viridis $ zipWith mkStyle (cycle colours1) (cycle $ map stroke filledMarkers) where @@ -336,10 +340,20 @@ fadeS c = mempty # fc (blend 0.1 white c) # lc c # lwO 1 fillS c = mempty # fc c # lw none +fadedColours3D :: AxisStyle V3 +fadedColours3D = AxisStyle viridis $ + zipWith mkStyle (cycle colours1) shapeMarkers + where + mkStyle c = PlotStyle c lineS fadeS fadeS fillS + lineS c = mempty # lwO 3 :: Style V3 Double + fadeS c = mempty # sc (blend 0.1 white c) # lwO 3 :: Style V3 Double + fillS c = mempty # sc c # lw none :: Style V3 Double + + -- | Theme using 'funColours' with no lines on 'areaStyle. -- -- <> -vividColours :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n +vividColours :: AxisStyle V2 vividColours = AxisStyle viridis $ zipWith mkStyle (cycle colours2) (cycle $ map (scale 1.2 . stroke) filledMarkers) where @@ -351,7 +365,7 @@ -- | Theme without any colours, useful for black and white documents. -- -- <> -blackAndWhite :: (TypeableFloat n, Renderable (Path V2 n) b) => AxisStyle b V2 n +blackAndWhite :: AxisStyle V2 blackAndWhite = AxisStyle greys $ zipWith3 mkStyle (cycle colours) (cycle lineStyles) (cycle $ map stroke filledMarkers) where @@ -397,9 +411,18 @@ -- | Markers which have a filling, used for 'fadedColours' and -- 'vividColours'. +shapeMarkers :: [Diagram V3] +shapeMarkers = scale 11 $ cycle + [ cube + , sphere + , cone + ] + +-- | Markers which have a filling, used for 'fadedColours' and +-- 'vividColours'. filledMarkers :: RealFloat n => [Path V2 n] -filledMarkers = scale 11 . map (centerXY . pathFromTrail) $ cycle - [ circle 0.5 +filledMarkers = scale 11 . map (centerXY . toPath) $ cycle + [ circle 0.5 :: RealFloat n => Trail V2 n , square 1 , triangle 1 , diamond (1 / sqrt 2) @@ -431,27 +454,27 @@ asterisk n x = mconcat . take n . iterate (rotateBy (1/fromIntegral n)) - $ (0 ^& 0) ~~ (0 ^& x) + $ fromVertices [origin, mkP2 0 x] -- | A rotated 'square'. -diamond :: (InSpace V2 n t, TrailLike t) => n -> t -diamond = trailLike . rotateBy (1/8) . square +diamond :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t +diamond = fromLocTrail . rotateBy (1/8) . square -- | A rotated 'plus'. -crossShape :: (InSpace V2 n t, TrailLike t) => n -> t -crossShape = trailLike . rotateBy (1/8) . plus +crossShape :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t +crossShape = fromLocTrail . rotateBy (1/8) . plus -- | Filled in @+@ symbol. -plus :: (InSpace V2 n t, TrailLike t) => n -> t -plus x = trailLike . (`at` mkP2 (x/6) (x/6)) - . wrapTrail . glueLine . mconcat . take 4 - . iterate (rotateBy (1/4)) . onLineSegments init +plus :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t +plus x = fromLocLoop . (`at` mkP2 (x/6) (x/6)) + . glueLine . mconcat . take 4 + . iterate (rotateBy (1/4)) . (^?! _init) $ square (x/3) -- | A filled in five sided start of size x. -star' :: (InSpace V2 n t, TrailLike t) => n -> t -star' x = trailLike . (`at` mkP2 (-x/6) (x/6)) - . wrapTrail . glueLine . mconcat . take 5 +star' :: (InSpace V2 n t, FromTrail t, OrderedField n) => n -> t +star' x = fromLocLoop . (`at` mkP2 (-x/6) (x/6)) + . glueLine . mconcat . take 5 . iterate (rotateBy (-1/5)) $ spoke where spoke = fromOffsets . map r2 $ [(x/6,x/2), (x/6,-x/2)] @@ -588,8 +611,8 @@ (b,_) = M.findMax cm normalise x = (x - a) / (b - a) -toStops :: Fractional n => ColourMap -> [GradientStop n] -toStops = map (\(x,c) -> GradientStop (SomeColor c) (fromRational x)) +toStops :: ColourMap -> [GradientStop] +toStops = map (\(x,c) -> GradientStop (opaque c) (fromRational x)) . colourList -- Colour maps --------------------------------------------------------- diff --git a/src/Plots/Types.hs b/src/Plots/Types.hs --- a/src/Plots/Types.hs +++ b/src/Plots/Types.hs @@ -22,19 +22,19 @@ -- -- This module defines the various types for holding plots: -- --- [@'PlotOptions' b v n@] +-- [@'PlotOptions' v@] -- Generic options all plots have. -- --- [@'PlotMods' b v n@] +-- [@'PlotMods' v@] -- Includes 'PlotOptions' along with modifications to the 'PlotStyle'. -- --- [@'Plot' p b@] +-- [@'Plot' p@] -- A 'rawPlot' @p@ grouped with a 'PlotMods'. -- --- [@'DynamicPlot' b v n@] +-- [@'DynamicPlot' v@] -- A wrapped up 'Plot' so it can be stored in an 'Axis'. -- --- [@'StyledPlot' b v n@] +-- [@'StyledPlot' v@] -- A 'DynamicPlot' with a concrete 'PlotStyle', ready to be rendered. -- -- As well as other things like the 'Plotable' class, 'LegendEntries', @@ -131,12 +131,18 @@ import Data.Ord (comparing) import Data.Orphans () import Data.Typeable -import Diagrams.Prelude as D +import Diagrams.Prelude as D hiding (orient) import Plots.Axis.Scale import Plots.Style import Plots.Util +-- XXX shouldn't need to import these +import Diagrams.Combinators as D +import Geometry.TwoD.Shapes + +import Diagrams.Types + -- Orientation --------------------------------------------------------- data Orientation = Horizontal | Vertical @@ -172,16 +178,16 @@ class HasGap a where -- | The value of the gap when rendering. - gap :: Lens' a (N a) + gap :: Lens' a Double -- | A 'Position' is a point on an axis together with an anchor and a -- direction for the gap. data Placement = Placement { pAt :: V2 Rational , pAnchor :: V2 Rational - , pGapDir :: Direction V2 Rational + , pGapDir :: Direction V2 Double } - deriving (Show, Read, Eq, Ord) + deriving (Show, Eq) -- In the future the axis position may be replaced by a reader-like -- anchor system where you can choose parts of the rendered axis as a -- position. @@ -204,7 +210,7 @@ placementAnchor = placement . lens pAnchor (\p a -> p {pAnchor = a}) -- | The direction to extend the 'gap' when positioning. - gapDirection :: Lens' a (Direction V2 Rational) + gapDirection :: Lens' a (Direction V2 Double) gapDirection = placement . lens pGapDir (\p a -> p {pGapDir = a}) instance HasPlacement Placement where @@ -217,11 +223,11 @@ pInside v = Placement { pAt = v , pAnchor = v - , pGapDir = dirBetween' (P v) origin + , pGapDir = dirBetween' (P $ fromRational <$> v) origin } -- | @dirBetween p q@ returns the directions from @p@ to @q@ -dirBetween' :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n +dirBetween' :: (Metric v, Floating n) => Point v n -> Point v n -> Direction v n dirBetween' p q = direction $ q .-. p @@ -260,12 +266,11 @@ -- | A tool for aligned one object to another. Positions @b@ around the -- bounding box of @a@ by translating @b@. placeAgainst - :: (InSpace V2 n a, SameSpace a b, Enveloped a, - HasOrigin b, Alignable b) + :: (InSpace V2 n a, SameSpace a b, Enveloped a, Enveloped b, HasOrigin b) => a -> Placement -> n -> b -> b placeAgainst a (Placement (V2 px py) (V2 ax ay) d) n b = b # anchor - # moveTo (pos .+^ n *^ fromDirection (fmap fromRational d)) + # moveTo (pos .+^ n *^ fromDirection (realToFrac <$> d)) where pos = mkP2 (lerp' px xu xl) (lerp' py yu yl) anchor = alignBy unitX (fromRational ax) . alignBy unitY (fromRational ay) @@ -280,26 +285,26 @@ -- | Type allowing use of the default legend picture (depending on the -- plot) or a custom legend picture with access to the 'PlotStyle'. -data LegendPic b v n +data LegendPic v = DefaultLegendPic - | CustomLegendPic (PlotStyle b v n -> QDiagram b v n Any) + | CustomLegendPic (PlotStyle v -> Diagram v) -instance Default (LegendPic b v n) where +instance Default (LegendPic v) where def = DefaultLegendPic -- | Data type for holding a legend entry. -data LegendEntry b v n = LegendEntry - { lPic :: LegendPic b v n +data LegendEntry v = LegendEntry + { lPic :: LegendPic v , lText :: String - , lPrecedence :: n + , lPrecedence :: Double } deriving Typeable -- | The picture used in the legend entry. -legendPicture :: Lens' (LegendEntry b v n) (LegendPic b v n) +legendPicture :: Lens' (LegendEntry v) (LegendPic v) legendPicture = lens lPic (\l pic -> l {lPic = pic}) -- | The text used in the legend entry. -legendText :: Lens' (LegendEntry b v n) String +legendText :: Lens' (LegendEntry v) String legendText = lens lText (\l txt -> l {lText = txt}) -- | The order in which the legend entries are rendered. If precedences @@ -307,15 +312,15 @@ -- axis. -- -- Default is @0@. -legendPrecedence :: Lens' (LegendEntry b v n) n +legendPrecedence :: Lens' (LegendEntry v) Double legendPrecedence = lens lPrecedence (\l n -> l {lPrecedence = n}) -type instance V (LegendEntry b v n) = v -type instance N (LegendEntry b v n) = n +type instance V (LegendEntry v) = v +type instance N (LegendEntry v) = Double -- | Make a legend entry with a default 'legendPicture' and -- 'legendPrecedence' 0 using the string as the 'legendText'. -mkLegendEntry :: Num n => String -> LegendEntry b v n +mkLegendEntry :: String -> LegendEntry v mkLegendEntry x = LegendEntry DefaultLegendPic x 0 ------------------------------------------------------------------------ @@ -325,24 +330,24 @@ -- Generic Plot info -- | Data type for holding information all plots must contain. -data PlotOptions b v n = PlotOptions +data PlotOptions v = PlotOptions { poName :: Name , poClipPlot :: Bool - , poLegend :: [LegendEntry b v n] + , poLegend :: [LegendEntry v] , poVisible :: Bool - , poTransform :: Transformation v n + , poTransform :: Transformation v Double -- , poPostPlotBoundingBox :: BoundingBox v n -> BoundingBox v n - -- , poPlotPostProduction :: QDiagram b v n Any -> QDiagram b v n Any + -- , poPlotPostProduction :: QDiagram v Any -> QDiagram v Any } deriving Typeable -type instance V (PlotOptions b v n) = v -type instance N (PlotOptions b v n) = n +type instance V (PlotOptions v) = v +type instance N (PlotOptions v) = Double -- | Class of things that have 'PlotOptions'. -class HasPlotOptions f a b | a -> b where +class HasPlotOptions f a where {-# MINIMAL plotOptions #-} -- | Lens onto the 'PlotOptions'. - plotOptions :: LensLike' f a (PlotOptions b (V a) (N a)) + plotOptions :: LensLike' f a (PlotOptions (V a)) -- | The 'Name' applied to the plot. This gives a way to reference a -- specific plot in a rendered axis. @@ -362,7 +367,7 @@ -- | The legend entries to be used for the current plot. -- -- 'Default' is 'mempty'. - legendEntries :: Functor f => LensLike' f a [LegendEntry b (V a) (N a)] + legendEntries :: Functor f => LensLike' f a [LegendEntry (V a)] legendEntries = plotOptions . lens poLegend (\g a -> g {poLegend = a}) {-# INLINE legendEntries #-} @@ -370,7 +375,7 @@ -- coordinates. -- -- 'Default' is 'mempty'. - plotTransform :: Functor f => LensLike' f a (Transformation (V a) (N a)) + plotTransform :: Functor f => LensLike' f a (Transformation (V a) Double) plotTransform = plotOptions . lens poTransform (\g a -> g {poTransform = a}) {-# INLINE plotTransform #-} @@ -382,7 +387,7 @@ plotVisible = plotOptions . lens poVisible (\po b -> po {poVisible = b}) {-# INLINE plotVisible #-} -instance (Additive v, Num n) => Default (PlotOptions b v n) where +instance (HasBasis v, Foldable v) => Default (PlotOptions v) where def = PlotOptions { poName = mempty , poClipPlot = True @@ -393,25 +398,25 @@ -- , poPlotPostProduction = id } -instance HasPlotOptions f (PlotOptions b v n) b where +instance HasPlotOptions f (PlotOptions v) where plotOptions = id {-# INLINE plotOptions #-} -instance (HasLinearMap v, Num n) => Transformable (PlotOptions b v n) where +instance HasLinearMap v => Transformable (PlotOptions v) where transform = over plotTransform . transform --- instance HasBounds (PlotOptions b v n) v where +-- instance HasBounds (PlotOptions v) v where -- bounds = plotBounds -- | Move origin by applying to @plotTransform@. -instance (Additive v, Num n) => HasOrigin (PlotOptions b v n) where +instance Additive v => HasOrigin (PlotOptions v) where moveOriginTo = over plotTransform . moveOriginTo -instance Qualifiable (PlotOptions b v n) where +instance Qualifiable (PlotOptions v) where n .>> p = over plotName (n .>>) p -- XXX template haskell getting in the way --- instance HasVisibility (PlotOptions b v n) where +-- instance HasVisibility (PlotOptions v) where -- visible = plotVisible -- | Add a 'LegendEntry' to something with 'PlotOptions' using the @@ -419,27 +424,27 @@ -- some typical examples: -- -- @ --- 'key' :: 'String' -> 'State' ('Plot' ('ScatterPlot' v n) b) () --- 'key' :: 'String' -> 'State' ('DynamicPlot' b v n) () --- 'key' :: 'String' -> 'State' ('PlotMods' b v n) () +-- 'key' :: 'String' -> 'State' ('Plot' ('ScatterPlot' v)) () +-- 'key' :: 'String' -> 'State' ('DynamicPlot' v) () +-- 'key' :: 'String' -> 'State' ('PlotMods' v) () -- @ -- -- If you only care about the name of the legend, use 'key'. -key :: (HasPlotOptions Identity a b, MonadState a m, Num (N a)) => String -> m () +key :: (HasPlotOptions Identity a, MonadState a m) => String -> m () key = addLegendEntry . mkLegendEntry -- | Add a 'LegendEntry' to something with 'PlotOptions'. Here are some -- typical examples: -- -- @ --- 'addLegendEntry' :: 'LegendEntry' b v n -> 'State' ('Plot' ('ScatterPlot' v n) b) () --- 'addLegendEntry' :: 'LegendEntry' b v n -> 'State' ('DynamicPlot' b v n) () +-- 'addLegendEntry' :: 'LegendEntry' v -> 'State' ('Plot' ('ScatterPlot' v)) () +-- 'addLegendEntry' :: 'LegendEntry' v -> 'State' ('DynamicPlot' v) () -- @ -- -- If you only care about the name of the legend, use 'key'. addLegendEntry - :: (HasPlotOptions Identity a b, MonadState a m) - => LegendEntry b (V a) (N a) + :: (HasPlotOptions Identity a, MonadState a m) + => LegendEntry (V a) -> m () addLegendEntry l = legendEntries <>= [l] @@ -451,17 +456,17 @@ ------------------------------------------------------------------------ -- | Information from the 'Plots.Axis.Axis' necessary to render a 'Plotable'. -data AxisSpec v n = AxisSpec - { _specBounds :: v (n, n) - , _specTrans :: Transformation v n +data AxisSpec v = AxisSpec + { _specBounds :: v (Double, Double) + , _specTrans :: Transformation v Double , _specScale :: v LogScale , _specColourMap :: ColourMap } makeLenses ''AxisSpec -type instance V (AxisSpec v n) = v -type instance N (AxisSpec v n) = n +type instance V (AxisSpec v) = v +type instance N (AxisSpec v) = Double -- | Scale a number by log10-ing it and linearly scaling it so it's -- within the same range. @@ -472,7 +477,9 @@ where d = b - a -- | Apply log scaling and the transform to a point. -specPoint :: (Applicative v, Additive v, Floating n) => AxisSpec v n -> Point v n -> Point v n +specPoint + :: (Applicative v, Additive v, Foldable v) + => AxisSpec v -> Point v Double -> Point v Double specPoint (AxisSpec bs tr ss _) p = papply tr $ over _Point (scaleNum <$> bs <*> ss <*>) p @@ -481,36 +488,38 @@ ------------------------------------------------------------------------ -- | Class defining how plots should be rendered. -class (Typeable p, Enveloped p) => Plotable p b where +class (Typeable p, Enveloped p, N p ~ Double) => Plotable p where -- | Render a plot according to the 'AxisSpec', using the 'PlotStyle'. renderPlotable - :: InSpace v n p - => AxisSpec v n - -> PlotStyle b v n + :: InSpace v Double p + => AxisSpec v + -> PlotStyle v -> p - -> QDiagram b v n Any + -> Diagram v -- | The default legend picture when the 'LegendPic' is -- 'DefaultLegendPic'. defLegendPic - :: InSpace v n p - => PlotStyle b v n + :: InSpace v Double p + => PlotStyle v -> p - -> QDiagram b v n Any + -> Diagram v defLegendPic = mempty -instance (Typeable b, Typeable v, Metric v, Typeable n, OrderedField n) - => Plotable (QDiagram b v n Any) b where +instance (Typeable v, HasLinearMap v) => Plotable (Diagram v) where renderPlotable s _ dia = dia # transform (s^.specTrans) -instance (TypeableFloat n, Renderable (Path V2 n) b) => Plotable (Path V2 n) b where +strokePathV :: (Typeable v, Metric v, Typeable n, OrderedField n) => Path v n -> QDiagram v n Any +strokePathV path = mkQD (Prim path) (getEnvelope path) mempty mempty + +instance (Typeable v, R1 v, HasLinearMap v) => Plotable (Path v Double) where renderPlotable s sty path - = stroke path + = strokePathV path # transform (s^.specTrans) # applyLineStyle sty defLegendPic sty _ - = (p2 (-10,0) ~~ p2 (10,0)) + = strokePathV (fromVertices [(-10) *^ unitX, 10 *^ unitX]) # applyLineStyle sty ------------------------------------------------------------------------ @@ -527,26 +536,26 @@ hidden = visible . involuted not {-# INLINE hidden #-} -instance HasVisibility (PlotOptions b v n) where +instance HasVisibility (PlotOptions v) where visible = plotVisible -instance HasVisibility (PlotMods b v n) where +instance HasVisibility (PlotMods v) where visible = plotVisible -instance HasVisibility (Plot p b) where +instance HasVisibility (Plot p) where visible = plotVisible -instance HasVisibility (DynamicPlot b v n) where +instance HasVisibility (DynamicPlot v) where visible = plotVisible -instance HasVisibility (StyledPlot b v n) where +instance HasVisibility (StyledPlot v) where visible = plotVisible -- | Set 'visible' to 'False' for the given setter. -- -- @ --- 'hide' 'minorTicks' :: 'State' ('Axis' b v n) () --- 'hide' ('xAxis' . 'gridLines') :: 'State' ('Axis' b v n) () +-- 'hide' 'minorTicks' :: 'State' ('Axis' v) () +-- 'hide' ('xAxis' . 'gridLines') :: 'State' ('Axis' v) () -- @ hide :: (MonadState s m, HasVisibility a) => ASetter' s a -> m () hide l = l . visible .= False @@ -554,8 +563,8 @@ -- | Set 'visible' to 'True' for the given setter. -- -- @ --- 'display' 'minorGridLines' :: 'State' ('Axis' b v n) () --- 'display' 'colourBar' :: 'State' ('Axis' b v n) () +-- 'display' 'minorGridLines' :: 'State' ('Axis' v) () +-- 'display' 'colourBar' :: 'State' ('Axis' v) () -- @ display :: (MonadState s m, HasVisibility a) => ASetter' s a -> m () display l = l . visible .= True @@ -565,20 +574,20 @@ ------------------------------------------------------------------------ -- | A 'PlotOptions' with modifications to a 'PlotStyle'. -data PlotMods b v n - = PlotMods (PlotOptions b v n) (PlotStyle b v n -> PlotStyle b v n) +data PlotMods v + = PlotMods (PlotOptions v) (PlotStyle v -> PlotStyle v) -type instance V (PlotMods b v n) = v -type instance N (PlotMods b v n) = n +type instance V (PlotMods v) = v +type instance N (PlotMods v) = Double -instance Functor f => HasPlotOptions f (PlotMods b v n) b where +instance Functor f => HasPlotOptions f (PlotMods v) where plotOptions f (PlotMods opts sty) = f opts <&> \opts' -> PlotMods opts' sty -instance Settable f => HasPlotStyle f (PlotMods b v n) b where +instance Settable f => HasPlotStyle f (PlotMods v) where plotStyle = sty . mapped where sty f (PlotMods opts s) = f s <&> \s' -> PlotMods opts s' -instance (Additive v, Num n) => Default (PlotMods b v n) where +instance (HasBasis v, Foldable v) => Default (PlotMods v) where def = PlotMods def id ------------------------------------------------------------------------ @@ -587,35 +596,35 @@ -- | A parameterised plot, together with a 'PlotMods'. This type has an -- instance of many classes for modifying specific plots. -data Plot p b = +data Plot p = Plot p - (PlotOptions b (V p) (N p)) - (PlotStyle b (V p) (N p) -> PlotStyle b (V p) (N p)) + (PlotOptions (V p)) + (PlotStyle (V p) -> PlotStyle (V p)) deriving Typeable -type instance V (Plot p b) = V p -type instance N (Plot p b) = N p +type instance V (Plot p) = V p +type instance N (Plot p) = Double -instance Functor f => HasPlotOptions f (Plot p b) b where +instance Functor f => HasPlotOptions f (Plot p) where plotOptions f (Plot p opts sty) = f opts <&> \opts' -> Plot p opts' sty -instance Settable f => HasPlotStyle f (Plot p b) b where +instance Settable f => HasPlotStyle f (Plot p) where plotStyle = sty . mapped where sty f (Plot p opts s) = f s <&> \s' -> Plot p opts s' -instance HasOrientation p => HasOrientation (Plot p b) where +instance HasOrientation p => HasOrientation (Plot p) where orientation = rawPlot . orientation -- | Make a 'Plot' with 'Default' 'PlotOptions'. -mkPlot :: (Additive (V p), Num (N p)) => p -> Plot p b +mkPlot :: (InSpace v Double p, HasBasis v, Foldable v) => p -> Plot p mkPlot p = Plot p def id -- | Lens onto the raw 'Plotable' inside a 'Plot'. -rawPlot :: SameSpace p p' => Lens (Plot p b) (Plot p' b) p p' +rawPlot :: SameSpace p p' => Lens (Plot p) (Plot p') p p' rawPlot f (Plot p opts ps) = f p <&> \p' -> Plot p' opts ps -- | The modifications to the 'PlotOptions' and 'PlotStyle' in a 'Plot'. -plotMods :: Lens' (Plot p b) (PlotMods b (V p) (N p)) +plotMods :: Lens' (Plot p) (PlotMods (V p)) plotMods f (Plot p opts ps) = f (PlotMods opts ps) <&> \(PlotMods opts' ps') -> Plot p opts' ps' @@ -624,38 +633,38 @@ ------------------------------------------------------------------------ -- | A wrapped up 'Plot', used to store plots in an 'Axis'. -data DynamicPlot b v n where - DynamicPlot :: (InSpace v n p, Plotable p b) => Plot p b -> DynamicPlot b v n +data DynamicPlot v where + DynamicPlot :: (InSpace v Double p, Plotable p) => Plot p -> DynamicPlot v deriving Typeable -type instance V (DynamicPlot b v n) = v -type instance N (DynamicPlot b v n) = n +type instance V (DynamicPlot v) = v +type instance N (DynamicPlot v) = Double -- | Prism for a 'DynamicPlot'. -_DynamicPlot :: (Plotable p b, Typeable b) => Prism' (DynamicPlot b (V p) (N p)) (Plot p b) +_DynamicPlot :: Plotable p => Prism' (DynamicPlot (V p)) (Plot p) _DynamicPlot = prism' DynamicPlot (\(DynamicPlot p) -> cast p) -- | Traversal over the dynamic plot without the 'Plotable' constraint -- '_DynamicPlot' has. -dynamicPlot :: forall p b. (Typeable p, Typeable b) - => Traversal' (DynamicPlot b (V p) (N p)) (Plot p b) +dynamicPlot :: forall p. Typeable p => Traversal' (DynamicPlot (V p)) (Plot p) dynamicPlot f d@(DynamicPlot p) = case eq p of Just Refl -> f p <&> \p' -> DynamicPlot p' Nothing -> pure d - where eq :: Typeable a => a -> Maybe (a :~: Plot p b) + where eq :: Typeable a => a -> Maybe (a :~: Plot p) eq _ = eqT -instance Functor f => HasPlotOptions f (DynamicPlot b v n) b where + +instance Functor f => HasPlotOptions f (DynamicPlot v) where plotOptions f (DynamicPlot (Plot p opts sty)) = f opts <&> \opts' -> DynamicPlot (Plot p opts' sty) -instance Settable f => HasPlotStyle f (DynamicPlot b v n) b where +instance Settable f => HasPlotStyle f (DynamicPlot v) where plotStyle = sty . mapped where - sty :: Setter' (DynamicPlot b v n) (PlotStyle b v n -> PlotStyle b v n) + sty :: Setter' (DynamicPlot v) (PlotStyle v -> PlotStyle v) sty f (DynamicPlot (Plot p opts s)) = f s <&> \s' -> DynamicPlot (Plot p opts s') -- | The modifications to the 'PlotOptions' and 'PlotStyle' in a 'DynamicPlot'. -dynamicPlotMods :: Lens' (DynamicPlot b v n) (PlotMods b v n) +dynamicPlotMods :: Lens' (DynamicPlot v) (PlotMods v) dynamicPlotMods f (DynamicPlot (Plot p opts ps)) = f (PlotMods opts ps) <&> \(PlotMods opts' ps') -> DynamicPlot (Plot p opts' ps') @@ -668,32 +677,32 @@ -- with 'styledPlotLegend'. -- -- You can make a 'StyledPlot' with 'styleDynamic' -data StyledPlot b v n where +data StyledPlot v where StyledPlot - :: Plotable p b + :: Plotable p => p - -> PlotOptions b (V p) (N p) - -> PlotStyle b (V p) (N p) - -> StyledPlot b (V p) (N p) + -> PlotOptions (V p) + -> PlotStyle (V p) + -> StyledPlot (V p) -type instance V (StyledPlot b v n) = v -type instance N (StyledPlot b v n) = n +type instance V (StyledPlot v) = v +type instance N (StyledPlot v) = Double -instance Functor f => HasPlotOptions f (StyledPlot b v n) b where +instance Functor f => HasPlotOptions f (StyledPlot v) where plotOptions f (StyledPlot p opts sty) = f opts <&> \opts' -> StyledPlot p opts' sty -instance (Metric v, OrderedField n) => Enveloped (StyledPlot b v n) where +instance HasLinearMap v => Enveloped (StyledPlot v) where getEnvelope (StyledPlot p opts _) = getEnvelope p & transform (poTransform opts) -instance Functor f => HasPlotStyle f (StyledPlot b v n) b where +instance Functor f => HasPlotStyle f (StyledPlot v) where plotStyle f (StyledPlot p opts sty) = f sty <&> StyledPlot p opts -- | Traversal over a raw plot of a styled plot. The type of the plot -- must match for the traversal to be successful. -styledPlot :: forall p b. Typeable p => Traversal' (StyledPlot b (V p) (N p)) p +styledPlot :: forall p. Typeable p => Traversal' (StyledPlot (V p)) p styledPlot f s@(StyledPlot p opts sty) = case eq p of Just Refl -> f p <&> \p' -> StyledPlot p' opts sty @@ -702,21 +711,17 @@ eq _ = eqT -- | Give a 'DynamicPlot' a concrete 'PlotStyle'. -styleDynamic :: PlotStyle b v n -> DynamicPlot b v n -> StyledPlot b v n +styleDynamic :: PlotStyle v -> DynamicPlot v -> StyledPlot v styleDynamic sty (DynamicPlot (Plot p opts styF)) = StyledPlot p opts (styF sty) -- | Render a 'StyledPlot' given an and 'AxisSpec'. -renderStyledPlot - :: TypeableFloat n - => AxisSpec V2 n - -> StyledPlot b V2 n - -> QDiagram b V2 n Any +renderStyledPlot :: HasLinearMap v => AxisSpec v -> StyledPlot v -> Diagram v renderStyledPlot aSpec (StyledPlot p opts sty) = renderPlotable aSpec sty p - & whenever (opts^.hidden) phantom - & whenever (opts^.clipPlot) (clipTo $ specRect aSpec) + & whenever (opts^.hidden) D.phantom + -- & whenever (opts^.clipPlot) (clipTo $ specRect aSpec) XXX ADD CLIPTO XXX -specRect :: TypeableFloat n => AxisSpec V2 n -> Path V2 n +specRect :: AxisSpec V2 -> Path V2 Double specRect aSpec = rect (xU - xL) (yU - yL) # moveTo (mkP2 ((xU+xL)/2) ((yU+yL)/2)) @@ -728,9 +733,7 @@ -- | Get the legend rendered entries from a single styled plot. The -- resulting entries are in no particular order. See also -- 'styledPlotLegends'. -singleStyledPlotLegend - :: StyledPlot b v n - -> [(n, QDiagram b v n Any, String)] -- ^ @(z-order, legend pic, legend text)@ +singleStyledPlotLegend :: StyledPlot v -> [(Double, Diagram v, String)] -- ^ @(z-order, legend pic, legend text)@ singleStyledPlotLegend (StyledPlot p opts sty) = map mk (opts ^. legendEntries) where @@ -741,10 +744,7 @@ CustomLegendPic f -> f sty -- | Render a list of legend entries, in order. -styledPlotLegends - :: Ord n - => [StyledPlot b v n] - -> [(QDiagram b v n Any, String)] -- ^ @[(legend pic, legend text)]@ +styledPlotLegends :: [StyledPlot v] -> [(Diagram v, String)] -- ^ @[(legend pic, legend text)]@ styledPlotLegends = map (\(_,p,t) -> (p,t)) . sortOn (view _1) diff --git a/src/Plots/Types/Bar.hs b/src/Plots/Types/Bar.hs --- a/src/Plots/Types/Bar.hs +++ b/src/Plots/Types/Bar.hs @@ -80,11 +80,13 @@ import Plots.Util import qualified Data.List as List -import Diagrams.Core.Transform (fromSymmetric) -import Linear.V2 (_yx) +-- import Diagrams.Core.Transform (fromSymmetric) +-- import Linear.V2 (_yx) -import Diagrams.Prelude +import Geometry.TwoD.Transform +import Diagrams.Prelude hiding (orient) + -- Single bar ---------------------------------------------------------- -- | Data for a single bar. The bar is drawn as @@ -97,9 +99,9 @@ -- representation of a bar and is not intended to be used directly. -- | Construct a rectangle of size v with the bottom centre at point p. -rectB :: (InSpace V2 n t, TrailLike t) => Point V2 n -> V2 n -> t +rectB :: (InSpace V2 n t, Fractional n, FromTrail t) => Point V2 n -> V2 n -> t rectB p (V2 x y) = - trailLike $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p .-^ V2 (x/2) 0 + fromLocTrail $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p .-^ V2 (x/2) 0 ------------------------------------------------------------------------ -- Bar layout @@ -107,49 +109,49 @@ -- | The way an individual bar plot or a group of bars plots are laid -- out on the axis. -data BarLayout n = BarLayout +data BarLayout = BarLayout { bOrient :: Orientation - , bWidth :: n - , bSpacing :: n - , bStart :: n + , bWidth :: Double + , bSpacing :: Double + , bStart :: Double } deriving Typeable -instance Fractional n => Default (BarLayout n) where +instance Default BarLayout where def = BarLayout Horizontal 0.8 1 1 -type instance N (BarLayout n) = n +type instance N BarLayout = Double -instance HasOrientation (BarLayout n) where +instance HasOrientation BarLayout where orientation = lens bOrient (\bl o -> bl {bOrient = o}) -- | Class of things that have a modifiable 'BarLayout'. class HasOrientation a => HasBarLayout a where -- | Lens onto the 'BarLayout' - barLayout :: Lens' a (BarLayout (N a)) + barLayout :: Lens' a BarLayout -- | The width bar for single / stacked bars or the width of a group -- for grouped bar plot. -- -- Default is @0.8@ - barWidth :: Lens' a (N a) + barWidth :: Lens' a Double barWidth = barLayout . lens bWidth (\bl w -> bl {bWidth = w}) -- | The spacing between each bar or group of bars. -- -- Default is @1@ - barSpacing :: Lens' a (N a) + barSpacing :: Lens' a Double barSpacing = barLayout . lens bSpacing (\bl s -> bl {bSpacing = s}) -- | The distance from the axis to centre of the first bar. -- -- Default is @1@ - barStart :: Lens' a (N a) + barStart :: Lens' a Double barStart = barLayout . lens bStart (\bl x -> bl {bStart = x}) -instance HasBarLayout (BarLayout n) where +instance HasBarLayout BarLayout where barLayout = id -instance HasBarLayout a => HasBarLayout (Plot a b) where +instance HasBarLayout a => HasBarLayout (Plot a) where barLayout = rawPlot . barLayout ------------------------------------------------------------------------ @@ -163,18 +165,18 @@ -- A 'BarPlot' is not intended to be constructed directly, instead use -- one of the helper functions. -data BarPlot n = BarPlot - { bpData :: [(n,n)] - , bpLayout :: BarLayout n +data BarPlot = BarPlot + { bpData :: [(Double,Double)] + , bpLayout :: BarLayout } deriving Typeable -type instance V (BarPlot n) = V2 -type instance N (BarPlot n) = n +type instance V BarPlot = V2 +type instance N BarPlot = Double -instance HasOrientation (BarPlot n) where +instance HasOrientation BarPlot where orientation = barLayout . orientation -instance OrderedField n => Enveloped (BarPlot n) where +instance Enveloped BarPlot where getEnvelope BarPlot {..} = getEnvelope . orient bpLayout _reflectXY id . (id :: Path v n -> Path v n) $ ifoldMap drawBar bpData @@ -182,8 +184,7 @@ drawBar i (a,b) = rectB (mkP2 x a) (V2 (view barWidth bpLayout) (b - a)) where x = view barStart bpLayout + fromIntegral i * view barSpacing bpLayout -instance (TypeableFloat n, Renderable (Path V2 n) b) - => Plotable (BarPlot n) b where +instance Plotable BarPlot where renderPlotable s sty BarPlot {..} = ifoldMap drawBar bpData # orient bpLayout _reflectXY id @@ -205,9 +206,9 @@ | otherwise = rect 4 10 -- The legend bars don't look right if the line width is too big so we limit it - sty' = sty & areaStyle . _lw %~ atMost (local 0.8) + sty' = sty & areaStyle . _lw . mapped %~ atMost (local 0.8) -instance HasBarLayout (BarPlot n) where +instance HasBarLayout BarPlot where barLayout = lens bpLayout (\bp l -> bp {bpLayout = l}) ------------------------------------------------------------------------ @@ -215,11 +216,11 @@ ------------------------------------------------------------------------ -- | Create equidistant bars using the values. -mkBars :: (F.Foldable f, Num n) => BarLayout n -> f n -> BarPlot n +mkBars :: F.Foldable f => BarLayout -> f Double -> BarPlot mkBars bl (F.toList -> ns) = mkFloatingBars bl (map (0,) ns) -- | Create equidistant bars with lower and upper bounds for each bar. -mkFloatingBars :: F.Foldable f => BarLayout n -> f (n,n) -> BarPlot n +mkFloatingBars :: F.Foldable f => BarLayout -> f (Double,Double) -> BarPlot mkFloatingBars bl (F.toList -> ns) = BarPlot { bpData = ns , bpLayout = bl @@ -228,10 +229,9 @@ -- | Create uniform bars from groups of data, placing one group after -- the other. mkRunningBars - :: Num n - => BarLayout n - -> [[(n,n)]] - -> [BarPlot n] + :: BarLayout + -> [[(Double, Double)]] + -> [BarPlot] mkRunningBars bl = snd . foldr f (view barStart bl, []) where f d (x, bs) = (x + dx, mkFloatingBars bl {bStart = x} d : bs) @@ -241,10 +241,9 @@ -- other. The first list will be the same as @mkUniformBars opts (map -- (0,) ys)@, subsequent lists will be placed on top. mkStackedBars - :: Num n - => BarLayout n - -> [[n]] -- values - -> [BarPlot n] + :: BarLayout + -> [[Double]] -- values + -> [BarPlot] mkStackedBars bl = snd . List.mapAccumR f (repeat 0) where -- y0s are the base values for this set of bars, these accumulate @@ -255,11 +254,10 @@ -- | Similar to 'mkMultiStacked' but stack has the same height. mkStackedEqualBars - :: Fractional n - => n -- ^ value each bar reaches - -> BarLayout n - -> [[n]] -- ^ values - -> [BarPlot n] + :: Double -- ^ value each bar reaches + -> BarLayout + -> [[Double]] -- ^ values + -> [BarPlot] mkStackedEqualBars yM bl yss = mkStackedBars bl yss' where -- Multiplier for each bar to reach the desired height. @@ -273,11 +271,10 @@ -- as a single bar when using the 'BarPlotsOpts'. There is an addition -- parameter to adjust the width of each individual bar. mkGroupedBars - :: Fractional n - => n -- ^ width factor of individual bars (1 = touching) - -> BarLayout n - -> [[n]] - -> [BarPlot n] + :: Double -- ^ width factor of individual bars (1 = touching) + -> BarLayout + -> [[Double]] + -> [BarPlot] mkGroupedBars w bl xs = flip imap xs $ \i ns -> mkBars @@ -294,10 +291,10 @@ -- temporary functions that will be in next lib release -_reflectionXY :: (Additive v, R2 v, Num n) => Transformation v n -_reflectionXY = fromSymmetric $ (_xy %~ view _yx) <-> (_xy %~ view _yx) +_reflectionXY :: (HasLinearMap v, R2 v, Num n) => Transformation v n +_reflectionXY = reflectionX <> reflectionY -_reflectXY :: (InSpace v n t, R2 v, Transformable t) => t -> t +_reflectXY :: (InSpace v n t, R2 v, HasLinearMap v, Transformable t) => t -> t _reflectXY = transform _reflectionXY ---------------------------------------------------------------------------------- @@ -321,11 +318,9 @@ -- -- > barExample = renderAxis barAxis barPlot - :: (MonadState (Axis b V2 n) m, - Plotable (BarPlot n) b, - F.Foldable f) - => f n -- ^ bar heights - -> State (Plot (BarPlot n) b) () -- ^ changes to the bars + :: (MonadState (Axis V2) m, F.Foldable f) + => f Double -- ^ bar heights + -> State (Plot BarPlot) () -- ^ changes to the bars -> m () -- ^ changes to the 'Axis' barPlot ns = addPlotable (mkBars def ns) @@ -344,11 +339,9 @@ -- -- > barExample' = renderAxis barAxis' barPlot' - :: (MonadState (Axis b V2 n) m, - Plotable (BarPlot n) b, - F.Foldable f) - => f n -- ^ bar heights - -> m () -- ^ changes to the 'Axis' + :: (MonadState (Axis V2) m, F.Foldable f) + => f Double -- ^ bar heights + -> m () -- ^ changes to the 'Axis' barPlot' ns = addPlotable' (mkBars def ns) -- | A add 'BarPlot' to an 'Axis' while naming the bars. @@ -368,11 +361,9 @@ -- > -- > namedBarExample = renderAxis namedBarAxis namedBarPlot - :: (MonadState (Axis b V2 n) m, - Plotable (BarPlot n) b, - F.Foldable f) - => f (String,n) -- ^ bar heights with name - -> State (Plot (BarPlot n) b) () -- ^ changes to the bars + :: (MonadState (Axis V2) m, F.Foldable f) + => f (String, Double) -- ^ bar heights with name + -> State (Plot BarPlot) () -- ^ changes to the bars -> m () -- ^ changes to the 'Axis' namedBarPlot d s = do addPlot bp @@ -396,20 +387,16 @@ -- -- > namedBarExample' = renderAxis namedBarAxis' namedBarPlot' - :: (MonadState (Axis b V2 n) m, - Plotable (BarPlot n) b, - F.Foldable f) - => f (String,n) -- ^ bar heights with name - -> m () -- ^ add plot to the 'Axis' + :: (MonadState (Axis V2) m, F.Foldable f) + => f (String, Double) -- ^ bar heights with name + -> m () -- ^ add plot to the 'Axis' namedBarPlot' ns = namedBarPlot ns (return ()) -- | Same as 'barPlot' but with lower and upper bounds for the bars. floatingBarPlot - :: (MonadState (Axis b V2 n) m, - Plotable (BarPlot n) b, - F.Foldable f) - => f (n,n) -- ^ bar limits - -> State (Plot (BarPlot n) b) () -- ^ changes to the bars + :: (MonadState (Axis V2) m, F.Foldable f) + => f (Double,Double) -- ^ bar limits + -> State (Plot BarPlot) () -- ^ changes to the bars -> m () floatingBarPlot ns = addPlotable (mkFloatingBars def ns) @@ -442,26 +429,26 @@ -- -- * Add labels to each (group of) bars with 'labelBars'. -- -data MultiBarState b n a = MultiBarState - { mbsLayout :: BarLayout n +data MultiBarState a = MultiBarState + { mbsLayout :: BarLayout -- ^ options for building bar plots - , mbsMods :: [(a, Endo (PlotMods b V2 n))] + , mbsMods :: [(a, Endo (PlotMods V2))] -- ^ the data along with an adjustment to the plot properties , mbsLabels :: [String] -- ^ labels to be placed at the bottom of each bar - , mbsBarFun :: BarLayout n -> [[n]] -> [BarPlot n] + , mbsBarFun :: BarLayout -> [[Double]] -> [BarPlot] -- ^ function used to build bar plots } -type instance N (MultiBarState b n a) = n +type instance N (MultiBarState a) = Double -instance HasOrientation (MultiBarState b n a) where +instance HasOrientation (MultiBarState a) where orientation = barLayout . orientation -instance HasBarLayout (MultiBarState b n a) where +instance HasBarLayout (MultiBarState a) where barLayout = lens mbsLayout (\mbs l -> mbs {mbsLayout = l}) -- > import Plots @@ -492,7 +479,7 @@ -- Adding to axis ------------------------------------------------------ -multiFun :: Lens' (MultiBarState b n a) (BarLayout n -> [[n]] -> [BarPlot n]) +multiFun :: Lens' (MultiBarState a) (BarLayout -> [[Double]] -> [BarPlot]) multiFun = lens mbsBarFun (\mbs f -> mbs {mbsBarFun = f}) -- | Bars that are grouped together such that each group is a single @@ -503,7 +490,7 @@ -- -- <> -groupedBars :: Fractional n => State (MultiBarState b n a) () +groupedBars :: State (MultiBarState a) () groupedBars = groupedBars' 1 -- | Bars that are grouped together such that each group is a single @@ -515,7 +502,7 @@ -- -- <> -- -groupedBars' :: Fractional n => n -> State (MultiBarState b n a) () +groupedBars' :: Double -> State (MultiBarState a) () groupedBars' n = multiFun .= mkGroupedBars n -- | Bars stacked on top of each other. @@ -524,7 +511,7 @@ -- -- <> -- -stackedBars :: Num n => State (MultiBarState b n a) () +stackedBars :: State (MultiBarState a) () stackedBars = multiFun .= mkStackedBars -- | Bars stacked on top of each other where every bar is the given @@ -535,7 +522,7 @@ -- -- <> -- -stackedEqualBars :: Fractional n => n -> State (MultiBarState b n a) () +stackedEqualBars :: Double -> State (MultiBarState a) () stackedEqualBars n = multiFun .= mkStackedEqualBars n -- | Normal 'bars' where each data set follows the last. @@ -544,7 +531,7 @@ -- -- <> -- -runningBars :: Num n => State (MultiBarState b n a) () +runningBars :: State (MultiBarState a) () runningBars = multiFun .= \l xs -> mkRunningBars l (map (map (0,)) xs) -- | Construct multiple bars, grouped together. See 'MultiBarState' for @@ -580,13 +567,10 @@ -- -- > multiBarExample = renderAxis multiBarAxis multiBars - :: (MonadState (Axis b V2 n) m, - Plotable (BarPlot n) b, - F.Foldable f, - F.Foldable g) + :: (MonadState (Axis V2) m, F.Foldable f, F.Foldable g) => f a -- ^ data for multi plot - -> (a -> g n) -- ^ extract bar heights from each data set - -> State (MultiBarState b n a) () -- ^ state to make changes to the plot + -> (a -> g Double) -- ^ extract bar heights from each data set + -> State (MultiBarState a) () -- ^ state to make changes to the plot -> m () -- ^ changes to the 'Axis' multiBars (F.toList -> as) f st = do -- add the plots @@ -614,9 +598,7 @@ -- | Place labels under the centre of each bar using the 'BarLayout' by -- changing that 'axisTickLabels', using the provided string in order. -barLayoutAxisLabels - :: (MonadState (Axis b V2 n) m, Fractional n) - => BarLayout n -> [String] -> m () +barLayoutAxisLabels :: MonadState (Axis V2) m => BarLayout -> [String] -> m () barLayoutAxisLabels bl ls = unless (null ls) $ axes . orient bl _y _x &= do @@ -639,11 +621,11 @@ -- * 'key' - add a legend entry for that group of bars -- onBars - :: (a -> State (PlotMods b V2 n) ()) + :: (a -> State (PlotMods V2) ()) -- ^ Modifier the 'PlotOptions' and 'PlotStyle' for the bars -- associated with the data from @a@. - -> State (MultiBarState b n a) () + -> State (MultiBarState a) () -- ^ Changes to each data set when executing 'multiBars'. onBars f = mods . mapped %= \(a, endo) -> (a, endo <> Endo (execState (f a))) @@ -652,7 +634,7 @@ class HasLabels a where labels :: Lens' a [String] -instance HasLabels (MultiBarState b n a) where +instance HasLabels (MultiBarState a) where labels = lens mbsLabels (\mbs ls -> mbs {mbsLabels = ls}) -- | Labels to use for each bar (or group of bars) along the axis. diff --git a/src/Plots/Types/HeatMap.hs b/src/Plots/Types/HeatMap.hs --- a/src/Plots/Types/HeatMap.hs +++ b/src/Plots/Types/HeatMap.hs @@ -45,13 +45,13 @@ , pixelHeatRender' -- * Heat matrix - , HeatMatrix + , HeatMatrix (..) , heatImage , hmPoints - , hmSize -- * Low level construction , mkHeatMap + , mkHeatSurface , mkHeatMatrix , mkHeatMatrix' @@ -76,8 +76,12 @@ import Plots.Style import Plots.Types +import Diagrams.TwoD.Image + +import Geometry.ThreeD.Shapes + ------------------------------------------------------------------------ --- Heatmap +-- HeatMap ------------------------------------------------------------------------ -- | 2D Array of 'Double's. @@ -196,16 +200,10 @@ -- > myHM = mkHeatMatrix (V2 5 5) f -- > in pixelHeatRender myHM viridis -- -pixelHeatRender - :: (Renderable (DImage n Embedded) b, TypeableFloat n) - => HeatMatrix - -> ColourMap - -> QDiagram b V2 n Any -pixelHeatRender hm cm = - alignBL . image $ DImage (ImageRaster (ImageRGB8 img)) x y mempty +pixelHeatRender :: HeatMatrix -> ColourMap -> Diagram V2 +pixelHeatRender hm cm = alignBL $ imageEmb (ImageRGB8 img) where - img = heatImage hm cm - V2 x y = hmSize hm + img = heatImage hm cm -- | Render an heatmap as an 'ImageRGB8' with @n@ pixels per heat matrix -- point. @@ -221,17 +219,11 @@ -- > myHM = mkHeatMatrix (V2 5 5) f -- > in pixelHeatRender' 10 myHM viridis -- -pixelHeatRender' - :: (Renderable (DImage n Embedded) b, TypeableFloat n) - => Int - -> HeatMatrix - -> ColourMap - -> QDiagram b V2 n Any +pixelHeatRender' :: Int -> HeatMatrix -> ColourMap -> Diagram V2 pixelHeatRender' n hm cm = - scale (1/fromIntegral n) . alignBL . image $ DImage (ImageRaster (ImageRGB8 img)) (x*n) (y*n) mempty + scale (1/fromIntegral n) . alignBL $ imageEmb (ImageRGB8 img) where - img = scaleImage n $ heatImage hm cm - V2 x y = hmSize hm + img = scaleImage n $ heatImage hm cm -- | Scale an image so each pixel takes (n*n) pixels. This can be -- useful for using 'heatImage' on small heat matrices to give a @@ -328,11 +320,7 @@ -- > myHM = mkHeatMatrix (V2 5 5) f -- > in pathHeatRender myHM viridis -- -pathHeatRender - :: (Renderable (Path V2 n) b, TypeableFloat n) - => HeatMatrix - -> ColourMap - -> QDiagram b V2 n Any +pathHeatRender :: HeatMatrix -> ColourMap -> Diagram V2 pathHeatRender hm@(HeatMatrix _ _ a b) cm = ifoldMapOf hmPoints mk hm # lwO 0 where normalise d = (d - a) / (b - a) @@ -355,23 +343,23 @@ -- | A mapping from points in a 2D axis do 'Double's. These 'Double's -- are converted to colours using the axis 'ColourMap'. -data HeatMap b n = HeatMap +data HeatMap v = HeatMap { hMatrix :: HeatMatrix - , hStart :: P2 n - , hSize :: V2 n - , hGridSty :: Style V2 n + , hStart :: P2 Double + , hSize :: V2 Double + , hGridSty :: Style v Double , hGridVisible :: Bool , hLimits :: Maybe (Double,Double) - , hDraw :: HeatMatrix -> ColourMap -> QDiagram b V2 n Any + , hDraw :: HeatMatrix -> ColourMap -> Diagram v } deriving Typeable -type instance V (HeatMap b n) = V2 -type instance N (HeatMap b n) = n +type instance V (HeatMap v) = v +type instance N (HeatMap v) = Double -- | Class of things that let you change the heatmap options. -class HasHeatMap f a b | a -> b where +class HasHeatMap f a where -- | Lens onto the heatmap options. - heatMapOptions :: LensLike' f a (HeatMap b (N a)) + heatMapOptions :: LensLike' f a (HeatMap (V a)) -- | Whether there should be grid lines draw for the heat map. -- @@ -383,19 +371,19 @@ -- visible. -- -- Default is 'mempty'. - heatMapGridStyle :: Functor f => LensLike' f a (Style V2 (N a)) + heatMapGridStyle :: Functor f => LensLike' f a (Style (V a) Double) heatMapGridStyle = heatMapOptions . lens hGridSty (\s b -> (s {hGridSty = b})) -- | The size of each individual square in the heat map. -- -- Default is @'V2' 1 1@. - heatMapSize :: Functor f => LensLike' f a (V2 (N a)) + heatMapSize :: Functor f => LensLike' f a (V2 Double) heatMapSize = heatMapOptions . lens hSize (\s b -> (s {hSize = b})) -- | The size of the full extent of the heat map. -- -- Default is extent of the heat matrix. - heatMapExtent :: (Functor f, Fractional (N a)) => LensLike' f a (V2 (N a)) + heatMapExtent :: Functor f => LensLike' f a (V2 Double) heatMapExtent = heatMapOptions . l where l f hm = f (hSize hm * s) <&> \x -> hm { hSize = x / s } where s = fmap fromIntegral (hmSize $ hMatrix hm) @@ -403,11 +391,11 @@ -- | The starting point at the bottom left corner of the heat map. -- -- Default is 'origin' - heatMapStart :: Functor f => LensLike' f a (P2 (N a)) + heatMapStart :: Functor f => LensLike' f a (P2 Double) heatMapStart = heatMapOptions . lens hStart (\s b -> (s {hStart = b})) -- | The center point of the heat map. - heatMapCentre :: (Functor f, Fractional (N a)) => LensLike' f a (P2 (N a)) + heatMapCentre :: Functor f => LensLike' f a (P2 Double) heatMapCentre = heatMapOptions . l where l f hm = f (hStart hm .+^ v) <&> \p -> hm { hStart = p .-^ v } where v = fmap fromIntegral (hmSize $ hMatrix hm) * hSize hm / 2 @@ -421,26 +409,31 @@ -- 'pixelHeatRender'. -- -- Default is 'pathHeatRender'. - heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> QDiagram b V2 (N a) Any) + heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> Diagram (V a)) heatMapRender = heatMapOptions . lens hDraw (\s b -> (s {hDraw = b})) -instance HasHeatMap f (HeatMap b n) b where +instance HasHeatMap f (HeatMap v) where heatMapOptions = id -instance (Functor f, HasHeatMap f a b) => HasHeatMap f (Plot a b) b where +instance (Functor f, HasHeatMap f a) => HasHeatMap f (Plot a) where heatMapOptions = rawPlot . heatMapOptions -instance OrderedField n => Enveloped (HeatMap b n) where +instance Enveloped (HeatMap V2) where getEnvelope hm = getEnvelope (fromCorners p (p .+^ v)) where p = view heatMapStart hm v = view heatMapExtent hm -instance (Typeable b, TypeableFloat n, Renderable (Path V2 n) b) - => Plotable (HeatMap b n) b where +instance Enveloped (HeatMap V3) where + getEnvelope hm = getEnvelope (fromCorners (v3 p) (v3 $ p .+^ v)) + where p = view heatMapStart hm + v = view heatMapExtent hm + v3 (P (V2 x y)) = P $ V3 x y 0 + +instance Plotable (HeatMap V2) where renderPlotable s _sty HeatMap {..} = transform (s^.specTrans) $ grid <> hDraw matrix' (s^.specColourMap) - # transform (scaleV hSize) + # scaleV hSize # moveTo hStart where --- TODO @@ -456,13 +449,30 @@ -- XXX make better defLegendPic sty HeatMap {..} = square 5 # applyAreaStyle sty -scaleV :: (Additive v, Fractional n) => v n -> Transformation v n -scaleV v = fromLinear f f - where f = (liftU2 (*) v) <-> (\u -> liftU2 (/) u v) +instance Plotable (HeatMap V3) where + renderPlotable s _sty HeatMap {..} = + transform (s^.specTrans) $ + grid <> hDraw matrix' (s^.specColourMap) + # scaleV (v3 hSize) + # moveTo (p3 hStart) + where + v3 (V2 x y) = V3 x y 1 + p3 (P (V2 x y)) = P $ V3 x y 0 + --- TODO + grid = mempty --- | Construct a 'Heatmap' using the given 'HeatMatrix'. -mkHeatMap :: (Renderable (Path V2 n) b, TypeableFloat n) - => HeatMatrix -> HeatMap b n + --- XXX need to give _range to the axis somehow (for colour bar range) + matrix' = case hLimits of + -- Just r@(a,b) -> (r, hMatrix { hmFun = (/ (b - a)) . (+a) . hmFun hMatrix }) + -- Nothing -> normaliseHeatMatrix hMatrix + Just (a,b) -> hMatrix { hmBoundLower = a, hmBoundUpper = b } + Nothing -> hMatrix + + -- XXX make better + defLegendPic sty HeatMap {..} = cube # scale 5 # applyAreaStyle sty + +-- | Construct a 'HeatMap' using the given 'HeatMatrix'. +mkHeatMap :: HeatMatrix -> HeatMap V2 mkHeatMap mat = HeatMap { hMatrix = mat , hStart = origin @@ -473,6 +483,17 @@ , hDraw = pathHeatRender } +mkHeatSurface :: HeatMatrix -> HeatMap V3 +mkHeatSurface mat = HeatMap + { hMatrix = mat + , hStart = origin + , hSize = V2 1 1 + , hGridSty = mempty + , hGridVisible = False + , hLimits = Nothing + , hDraw = undefined + } + -- Adding to axis ------------------------------------------------------ -- | Add a 'HeatMap' plot using the extent of the heatmap and a @@ -500,12 +521,9 @@ heatMap :: (F.Foldable f, F.Foldable g, - TypeableFloat n, - Typeable b, - MonadState (Axis b V2 n) m, - Renderable (Path V2 n) b) + MonadState (Axis V2) m) => f (g Double) - -> State (Plot (HeatMap b n) b) () + -> State (Plot (HeatMap V2)) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' heatMap xss s = do @@ -515,6 +533,21 @@ -- (don't like this way of doing it) colourBarRange .= over both realToFrac (a,b) +heatSurface + :: (F.Foldable f, + F.Foldable g, + MonadState (Axis V3) m) + => f (g Double) + -> State (Plot (HeatMap V3)) () + -- ^ changes to plot options + -> m () -- ^ add plot to 'Axis' +heatSurface xss s = do + let hm@(HeatMatrix _ _ a b) = mkHeatMatrix' xss + addPlotable (mkHeatSurface hm) s + + -- (don't like this way of doing it) + colourBarRange .= over both realToFrac (a,b) + -- | Add a 'HeatMap' plot using the extent of the heatmap and a -- generating function. -- @@ -541,10 +574,7 @@ heatMap' :: (F.Foldable f, F.Foldable g, - TypeableFloat n, - Typeable b, - MonadState (Axis b V2 n) m, - Renderable (Path V2 n) b) + MonadState (Axis V2) m) => f (g Double) -> m () -- ^ add plot to 'Axis' heatMap' xss = heatMap xss (return ()) @@ -574,13 +604,10 @@ -- heatMapIndexed :: (VectorLike V2 Int i, - TypeableFloat n, - Typeable b, - MonadState (Axis b V2 n) m, - Renderable (Path V2 n) b) + MonadState (Axis V2) m) => i -- ^ extent of array -> (i -> Double) -- ^ heat from index - -> State (Plot (HeatMap b n) b) () + -> State (Plot (HeatMap V2)) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' heatMapIndexed i f s = do @@ -616,12 +643,14 @@ -- heatMapIndexed' :: (VectorLike V2 Int i, - TypeableFloat n, - Typeable b, - MonadState (Axis b V2 n) m, - Renderable (Path V2 n) b) + MonadState (Axis V2) m) => i -- ^ extent of array -> (i -> Double) -- ^ heat from index -> m () -- ^ add plot to 'Axis' heatMapIndexed' i f = heatMapIndexed i f (return ()) + +-- heatMapRender :: Functor f => LensLike' f a (HeatMatrix -> ColourMap -> Diagram (V a)) + +-- surfaceRender :: HeatMatrix -> ColourMap -> Diagram V3 +-- surfaceRender hm cm = diff --git a/src/Plots/Types/Histogram.hs b/src/Plots/Types/Histogram.hs --- a/src/Plots/Types/Histogram.hs +++ b/src/Plots/Types/Histogram.hs @@ -64,8 +64,7 @@ import qualified Data.Vector as V import qualified Statistics.Sample.Histogram as Stat -import Diagrams.Core.Transform (fromSymmetric) -import Diagrams.Prelude +import Diagrams.Prelude hiding (orient) import Linear.V2 (_yx) import Plots.Axis @@ -73,38 +72,38 @@ import Plots.Types import Plots.Util +import Geometry.TwoD.Transform -- | Construct a rectangle of size $v$ with the bottom left at point $p$. -rectBL :: (InSpace V2 n t, TrailLike t) => Point V2 n -> V2 n -> t +rectBL :: (InSpace V2 n t, FromTrail t) => Point V2 n -> V2 n -> t rectBL p (V2 x y) = - trailLike $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p + fromLocTrail $ fromOffsets [V2 x 0, V2 0 y, V2 (-x) 0] # closeTrail `at` p ------------------------------------------------------------------------ -- GHistogram plot ------------------------------------------------------------------------ -- | Simple histogram type supporting uniform bins. -data HistogramPlot n = HistogramPlot - { hWidth :: n - , hStart :: n - , hValues :: [n] +data HistogramPlot = HistogramPlot + { hWidth :: Double + , hStart :: Double + , hValues :: [Double] , hOrient :: Orientation } deriving Typeable -type instance V (HistogramPlot n) = V2 -type instance N (HistogramPlot n) = n +type instance V HistogramPlot = V2 +type instance N HistogramPlot = Double -instance OrderedField n => Enveloped (HistogramPlot n) where +instance Enveloped HistogramPlot where getEnvelope HistogramPlot {..} = - -- don't like this redundant code - getEnvelope . orient hOrient _reflectXY id . (id :: Path v n -> Path v n) $ + -- don't like this reduntent code + getEnvelope . orient hOrient _reflectXY id . (id :: Path V2 Double -> Path V2 Double) $ ifoldMap drawBar hValues where drawBar i h = rectBL (mkP2 x 0) (V2 hWidth h) where x = hStart + fromIntegral i * hWidth -instance (TypeableFloat n, Renderable (Path V2 n) b) - => Plotable (HistogramPlot n) b where +instance Plotable HistogramPlot where renderPlotable s sty HistogramPlot {..} = ifoldMap drawBar hValues # orient hOrient _reflectXY id @@ -121,9 +120,9 @@ $ alignB (rect 4 7) ||| alignB (rect 4 10) ||| alignB (rect 4 6) where -- The legend bars don't look right if the line width is too big so we limit it - sty' = sty & areaStyle . _lw %~ atMost (local 0.8) + sty' = sty & areaStyle . _lw . mapped %~ atMost (local 0.8) -instance HasOrientation (HistogramPlot n) where +instance HasOrientation HistogramPlot where orientation = lens hOrient $ \hp o -> hp {hOrient = o} ------------------------------------------------------------------------ @@ -132,23 +131,21 @@ -- | Plot an already computed histogram with equally sized bins. computedHistogram - :: (MonadState (Axis b V2 n) m, - Plotable (HistogramPlot n) b, - F.Foldable f) - => n -- ^ start of first bin - -> n -- ^ width of each bin - -> f n -- ^ heights of the bins - -> State (Plot (HistogramPlot n) b) () + :: (MonadState (Axis V2) m, F.Foldable f) + => Double -- ^ start of first bin + -> Double -- ^ width of each bin + -> f Double -- ^ heights of the bins + -> State (Plot HistogramPlot) () -> m () computedHistogram x0 w xs = addPlotable (mkComputedHistogram x0 w xs) -- | Construct a 'HistogramPlot' from raw histogram data. mkComputedHistogram :: F.Foldable f - => n -- ^ start of first bin - -> n -- ^ width of each bin - -> f n -- ^ heights of the bins - -> HistogramPlot n + => Double -- ^ start of first bin + -> Double -- ^ width of each bin + -> f Double -- ^ heights of the bins + -> HistogramPlot mkComputedHistogram x0 w xs = HistogramPlot x0 w (F.toList xs) Horizontal ---------------------------------------------------------------------------- @@ -192,7 +189,7 @@ -- | The way to normalise the data from a histogram. The default method -- is 'count'. newtype NormalisationMethod = - NM { runNM :: forall n. Fractional n => n -> V.Vector n -> V.Vector n } + NM { runNM :: Double -> V.Vector Double -> V.Vector Double } -- width -> heights -> normalised heights instance Default NormalisationMethod where @@ -255,17 +252,17 @@ -- | Options for binning histogram data. For now only very basic -- histograms building is supported. -data HistogramOptions n = HistogramOptions +data HistogramOptions = HistogramOptions { hBins :: Int - , hRange :: Maybe (n, n) + , hRange :: Maybe (Double, Double) , hNorm :: NormalisationMethod , oOrient :: Orientation } -type instance V (HistogramOptions n) = V2 -type instance N (HistogramOptions n) = n +type instance V HistogramOptions = V2 +type instance N HistogramOptions = Double -instance Default (HistogramOptions n) where +instance Default HistogramOptions where def = HistogramOptions { hBins = 10 , hRange = Nothing @@ -273,12 +270,12 @@ , oOrient = Vertical } -instance HasOrientation (HistogramOptions n) where +instance HasOrientation HistogramOptions where orientation = lens oOrient $ \ho o -> ho {oOrient = o} class HasOrientation a => HasHistogramOptions a where -- | Options for building the histogram from data. - histogramOptions :: Lens' a (HistogramOptions (N a)) + histogramOptions :: Lens' a HistogramOptions -- | The number of bins (bars) to use for the histogram. Must be -- positive. @@ -291,7 +288,7 @@ -- data outside the range is ignored. -- -- 'Default' is 'Nothing'. - binRange :: Lens' a (Maybe (N a, N a)) + binRange :: Lens' a (Maybe (Double, Double)) binRange = histogramOptions . lens hRange (\ho r -> ho {hRange = r}) -- | Should the resulting histogram be normalised so the total area is @@ -301,17 +298,15 @@ normaliseSample :: Lens' a NormalisationMethod normaliseSample = histogramOptions . lens hNorm (\ho b -> ho {hNorm = b}) -instance HasHistogramOptions (HistogramOptions n) where +instance HasHistogramOptions HistogramOptions where histogramOptions = id -instance HasHistogramOptions a => HasHistogramOptions (Plot a b) where +instance HasHistogramOptions a => HasHistogramOptions (Plot a) where histogramOptions = rawPlot . histogramOptions -- | Create a histogram by binning the data using the -- 'HistogramOptions'. -mkHistogramPlot - :: (F.Foldable f, RealFrac n) - => HistogramOptions n -> f n -> HistogramPlot n +mkHistogramPlot :: F.Foldable f => HistogramOptions -> f Double -> HistogramPlot mkHistogramPlot HistogramOptions {..} xs = HistogramPlot { hWidth = w @@ -326,10 +321,9 @@ (a,b) = fromMaybe (range hBins v) hRange -- Taken from Statistics, which was limited to 'Double'. -range :: (Ord n, Fractional n) - => Int -- ^ Number of bins (must be positive). - -> V.Vector n -- ^ Sample data (cannot be empty). - -> (n, n) +range :: Int -- ^ Number of bins (must be positive). + -> V.Vector Double -- ^ Sample data (cannot be empty). + -> (Double, Double) range nBins xs | nBins < 1 = error "Plots.Types.Histogram: invalid bin count" | V.null xs = error "Plots.Types.Histogram: empty sample" @@ -377,40 +371,40 @@ -- -- > histogramExample = renderAxis histogramAxis histogramPlot - :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, F.Foldable f, RealFrac n) - => f n -- ^ data - -> State (Plot (HistogramOptions n) b) () -- ^ changes to plot options + :: (MonadState (Axis V2) m, F.Foldable f) + => f Double -- ^ data + -> State (Plot HistogramOptions) () -- ^ changes to plot options -> m () -- ^ add plot to axis histogramPlot ns s = addPlot (hoPlot & rawPlot %~ \ho -> mkHistogramPlot ho ns) where hoPlot = mkPlot def &~ s -- | Make a 'HistogramPlot' without changes to the plot options. histogramPlot' - :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, F.Foldable f, RealFrac n) - => f n -- ^ data + :: (MonadState (Axis V2) m, F.Foldable f) + => f Double -- ^ data -> m () -- ^ add plot to axis histogramPlot' d = histogramPlot d (return ()) -- | Add a 'HistogramPlot' using a fold over the data. histogramPlotOf - :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, RealFrac n) - => Fold s n -- ^ fold over the data + :: (MonadState (Axis V2) m) + => Fold s Double -- ^ fold over the data -> s -- ^ data to fold - -> State (Plot (HistogramOptions n) b) () -- ^ change to the plot + -> State (Plot HistogramOptions) () -- ^ change to the plot -> m () -- ^ add plot to the 'Axis' histogramPlotOf f s = histogramPlot (toListOf f s) -- | Same as 'histogramPlotOf' without any changes to the plot. histogramPlotOf' - :: (MonadState (Axis b V2 n) m, Plotable (HistogramPlot n) b, RealFrac n) - => Fold s n -> s -> m () + :: MonadState (Axis V2) m + => Fold s Double -> s -> m () histogramPlotOf' f s = histogramPlotOf f s (return ()) -- temporary functions that will be in next lib release -_reflectionXY :: (Additive v, R2 v, Num n) => Transformation v n -_reflectionXY = fromSymmetric $ (_xy %~ view _yx) <-> (_xy %~ view _yx) +_reflectionXY :: (HasLinearMap v, R2 v, Num n) => Transformation v n +_reflectionXY = reflectionX <> reflectionY -_reflectXY :: (InSpace v n t, R2 v, Transformable t) => t -> t +_reflectXY :: (InSpace v n t, HasLinearMap v, R2 v, Transformable t) => t -> t _reflectXY = transform _reflectionXY diff --git a/src/Plots/Types/Line.hs b/src/Plots/Types/Line.hs --- a/src/Plots/Types/Line.hs +++ b/src/Plots/Types/Line.hs @@ -29,8 +29,8 @@ -- * Line plots from points , linePlot , linePlot' - , smoothLinePlot - , smoothLinePlot' + -- , smoothLinePlot + -- , smoothLinePlot' -- * Construction utilities @@ -55,47 +55,46 @@ import Plots.Axis import Plots.Types +import Data.Typeable +import Geometry.Path +import qualified Data.Sequence as S (fromList, singleton) + ------------------------------------------------------------------------ -- Trails and Paths ------------------------------------------------------------------------ +trail2Path :: Located (Trail v n) -> Path v n +trail2Path = Path . S.singleton + -- | Add a 'Trail' as a 'Plot' to an 'Axis'. trailPlot - :: (BaseSpace c ~ v, - Plotable (Path v n) b, - MonadState (Axis b c n) m) - => Trail v n -- ^ trail to plot - -> State (Plot (Path v n) b) () -- ^ changes to plot options + :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) + => Located (Trail v Double) -- ^ trail to plot + -> State (Plot (Path v Double)) () -- ^ changes to plot options -> m () -- ^ add plot to the 'Axis' -trailPlot = pathPlot . toPath +trailPlot = pathPlot . trail2Path -- | Add a 'Trail' as a 'Plot' to an 'Axis' without changes to the plot -- options. trailPlot' - :: (BaseSpace c ~ v, - Plotable (Path v n) b, - MonadState (Axis b c n) m) - => Trail v n -- ^ trail to plot + :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) + => Located (Trail v Double) -- ^ trail to plot -> m () -- ^ add plot to the 'Axis' -trailPlot' = pathPlot' . toPath +trailPlot' = pathPlot' . trail2Path -- | Add a 'Path' as a 'Plot' to an 'Axis'. pathPlot - :: (BaseSpace c ~ v, - Plotable (Path v n) b, - MonadState (Axis b c n) m) - => Path v n -- ^ path to plot - -> State (Plot (Path v n) b) () -- ^ changes to plot options + :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) + => Path v Double -- ^ path to plot + -> State (Plot (Path v Double)) () -- ^ changes to plot options -> m () -- ^ add plot to the 'Axis' pathPlot = addPlotable -- | Add a 'Path' as a 'Plot' to an 'Axis' without changes to the plot -- options. pathPlot' - :: (BaseSpace c ~ v, - Plotable (Path v n) b, - MonadState (Axis b c n) m) - => Path v n -- ^ path to plot + :: (BaseSpace c ~ v, MonadState (Axis c) m, HasLinearMap v, Typeable v, R1 v) + => Path v Double -- ^ path to plot -> m () -- ^ add plot to the 'Axis' pathPlot' = addPlotable' @@ -106,54 +105,56 @@ -- | Add a 'Path' plot from a list of points. linePlot :: (BaseSpace c ~ v, - Metric v, + HasLinearMap v, F.Foldable f, - PointLike v n p, - Plotable (Path v n) b, - MonadState (Axis b c n) m) + R1 v, + PointLike v Double p, + MonadState (Axis c) m) => f p -- ^ points to turn into trail - -> State (Plot (Path v n) b) () -- ^ changes to plot options + -> State (Plot (Path v Double)) () -- ^ changes to plot options -> m () -- ^ add plot to the 'Axis' linePlot = addPlotable . toPath . mkTrail -- | Add a 'Path' plot from a list of points. linePlot' :: (BaseSpace c ~ v, - Metric v, + HasLinearMap v, F.Foldable f, - PointLike v n p, - Plotable (Path v n) b, - MonadState (Axis b c n) m) + R1 v, + PointLike v Double p, + MonadState (Axis c) m) => f p -- ^ points to turn into trail -> m () -- ^ add plot to the 'Axis' linePlot' = addPlotable' . toPath . mkTrail -- | Add a smooth 'Path' plot from a list of points using 'cubicSpline'. -smoothLinePlot - :: (BaseSpace c ~ v, - F.Foldable f, - Metric v, - PointLike v n p, - Plotable (Path v n) b, - Fractional (v n), -- needs fixing in diagrams-lib - MonadState (Axis b c n) m) - => f p -- ^ points to turn into trail - -> State (Plot (Path v n) b) () -- ^ changes to plot options - -> m () -- ^ add plot to the 'Axis' -smoothLinePlot = addPlotable . cubicSpline False . toListOf (folded . unpointLike) +-- smoothLinePlot +-- :: (BaseSpace c ~ v, +-- F.Foldable f, +-- Typeable v, +-- HasLinearMap v, +-- PointLike v Double p, +-- R1 v, +-- Fractional (v Double), -- needs fixing in diagrams-lib +-- MonadState (Axis c) m) +-- => f p -- ^ points to turn into trail +-- -> State (Plot (Path v Double)) () -- ^ changes to plot options +-- -> m () -- ^ add plot to the 'Axis' +-- smoothLinePlot = addPlotable . cubicSpline False . toListOf (folded . unpointLike) -- | Add a smooth 'Path' plot from a list of points using 'cubicSpline' -- without changes to the plot options. -smoothLinePlot' - :: (BaseSpace c ~ v, - F.Foldable f, - PointLike v n p, - Plotable (Path v n) b, - Fractional (v n), -- needs fixing in diagrams-lib - MonadState (Axis b c n) m) - => f p -- ^ points to turn into trail - -> m () -- ^ add plot to the 'Axis' -smoothLinePlot' xs = smoothLinePlot xs (return ()) +-- smoothLinePlot' +-- :: (BaseSpace c ~ v, +-- F.Foldable f, +-- PointLike v Double p, +-- Typeable v, +-- R1 v, +-- Fractional (v Double), -- needs fixing in diagrams-lib +-- MonadState (Axis c) m) +-- => f p -- ^ points to turn into trail +-- -> m () -- ^ add plot to the 'Axis' +-- smoothLinePlot' xs = smoothLinePlot xs (return ()) ------------------------------------------------------------------------ -- Trail and path @@ -173,5 +174,5 @@ -- | Construct a localed trail from a fold over points. mkPathOf :: (PointLike v n p, OrderedField n) => Fold s t -> Fold t p -> s -> Path v n -mkPathOf f1 f2 as = Path $ map (mkTrailOf f2) (toListOf f1 as) +mkPathOf f1 f2 as = Path . S.fromList $ map (mkTrailOf f2) (toListOf f1 as) diff --git a/src/Plots/Types/Pie.hs b/src/Plots/Types/Pie.hs deleted file mode 100644 --- a/src/Plots/Types/Pie.hs +++ /dev/null @@ -1,308 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE StandaloneDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Plots.Types.Line --- Copyright : (C) 2016 Christopher Chalmers --- License : BSD-style (see the file LICENSE) --- Maintainer : Christopher Chalmers --- Stability : experimental --- Portability : non-portable --- --- A pie plot is a circular statistical graphic, which is divided into --- slices to illustrate numerical proportion. --- --- <> --- --- (see 'piePlot' example for code to make this plot) --- ----------------------------------------------------------------------------- - -module Plots.Types.Pie - ( -- * Pie plot - PieState - , piePlot - , piePlot' - , onWedges - , wedgeKeys - - -- * Wedges - , Wedge - , mkWedge - , HasWedge (..) - , wedgePlot - - ) where - -import Control.Monad.State.Lazy - -import Data.Typeable -import qualified Data.Foldable as F -import qualified Data.List as List - -import Diagrams.Coordinates.Isomorphic -import Diagrams.Coordinates.Polar -import Diagrams.Prelude hiding (r2) - -import Plots.Style -import Plots.Types -import Plots.Axis - ------------------------------------------------------------------------- --- Pie wedge ------------------------------------------------------------------------- - --- | Contains information to draw a single wedge of a pie. It is not --- intended to be drawn directly. Instead use 'piePlot'. -data Wedge n = Wedge - { sEndR :: n - , sStartR :: n - , sOffset :: n - , sDir :: Direction V2 n - , sWidth :: Angle n - } deriving Typeable - -type instance V (Wedge n) = V2 -type instance N (Wedge n) = n - -instance RealFloat n => Enveloped (Wedge n) where - getEnvelope Wedge {..} = getEnvelope shape # translate off where - shape - | sStartR == 0 = wedge sEndR sDir sWidth :: Path V2 n - | otherwise = annularWedge sEndR sStartR sDir sWidth - off - | sOffset == 0 = zero - | otherwise = sOffset *^ fromDir (rotate (sWidth ^/ 2) sDir) - -instance (TypeableFloat n, Renderable (Path V2 n) b) - => Plotable (Wedge n) b where - renderPlotable s sty Wedge {..} = - shape - # applyAreaStyle sty - # translate off - # transform (s^.specTrans) - where - shape - | sStartR == 0 = wedge sEndR sDir sWidth - | otherwise = annularWedge sEndR sStartR sDir sWidth - off - | sOffset == 0 = zero - | otherwise = sOffset *^ fromDir (rotate (sWidth ^/ 2) sDir) - - defLegendPic sty Wedge {..} - = square 5 # applyAreaStyle sty - --- | Create a pie wedge with unit radius, starting at direction @d@ with --- width @theta@. -mkWedge - :: Num n - => Direction V2 n -- ^ starting direction - -> Angle n -- ^ width of wedge - -> Wedge n -- ^ resulting wedge -mkWedge d theta = Wedge - { sEndR = 1 - , sStartR = 0 - , sOffset = 0 - , sDir = d - , sWidth = theta - } - -class HasWedge f a where - -- | Description on how to draw a wedge. - pieWedge :: LensLike' f a (Wedge (N a)) - - -- | The outside radius of the wedge. Default is @1@. - wedgeOuterRadius :: Functor f => LensLike' f a (N a) - wedgeOuterRadius = pieWedge . lens sEndR (\p r -> p {sEndR = r}) - - -- | The inside radius of the wedge. Default is $0$. - wedgeInnerRadius :: Functor f => LensLike' f a (N a) - wedgeInnerRadius = pieWedge . lens sStartR (\p r -> p {sStartR = r}) - - -- | The offset of the wedge from the center. - wedgeOffset :: Functor f => LensLike' f a (N a) - wedgeOffset = pieWedge . lens sOffset (\p x -> p {sOffset = x}) - - -- | The width of the wedge, starting from the 'wedgeDirection'. - wedgeWidth :: Functor f => LensLike' f a (Angle (N a)) - wedgeWidth = pieWedge . lens sWidth (\p x -> p {sWidth = x}) - - -- | The inititial direction of the wedge. - wedgeDirection :: Functor f => LensLike' f a (Direction V2 (N a)) - wedgeDirection = pieWedge . lens sDir (\p x -> p {sDir = x}) - -instance HasWedge f (Wedge n) where - pieWedge = id - -instance (Functor f, HasWedge f a) => HasWedge f (Plot a b) where - pieWedge = rawPlot . pieWedge - -instance Applicative f => HasWedge f (PieState b n a) where - pieWedge = stateMods . traversed . _2 . pieWedge - -instance (Applicative f, Typeable b, v ~ V2, Typeable n) - => HasWedge f (DynamicPlot b v n) where - pieWedge = (dynamicPlot :: Traversal' (DynamicPlot b v n) (Plot (Wedge n) b)) - . pieWedge - -instance (v ~ V2, Applicative f, Typeable n) - => HasWedge f (StyledPlot b v n) where - pieWedge = (styledPlot :: Traversal' (StyledPlot b v n) (Wedge n)) - -instance (BaseSpace c ~ V2, Settable f, Typeable n) - => HasWedge f (Axis b c n) where - pieWedge = finalPlots . pieWedge - ------------------------------------------------------------------------- --- Full pie ------------------------------------------------------------------------- - --- | The state used to draw a part chart made of multiple pie wedges. -data PieState b n a = PieState - { psMods :: [(a, Plot (Wedge n) b)] -- non-empty list - } - -type instance V (PieState b n a) = V2 -type instance N (PieState b n a) = n - --- internal lens -stateMods :: Lens' (PieState b n a) [(a, Plot (Wedge n) b)] -stateMods = lens psMods (\ps ms -> ps {psMods = ms}) - --- -- | The direction for the first entry in the pie. Default is 'xDir'. --- startingDirection :: Lens' (PieState b n a) (Direction V2 n) --- startingDirection = lens psStart (\ps d -> ps {psStart = d}) - --- -- | The ending direction of the final wedge. This can be used to make a --- finalDirection :: - --- | Modify the state for each wedge given the data entry. --- --- Some common lenses to use on the 'Wedge': --- --- * 'plotColour' - change the colour of the bars --- --- * 'areaStyle' - modify the style of the bars --- --- * 'key' - add a legend entry for that group of bars --- --- * 'wedgeOffset' - the offset of the wedge from the center --- -onWedges :: (a -> State (Plot (Wedge n) b) ()) -> State (PieState b n a) () -onWedges f = stateMods %= map (\(a, p) -> (a, execState (f a) p)) - --- | Add a legend entry for each item given a function that extracts the --- item's name. -wedgeKeys :: Num n => (a -> String) -> State (PieState b n a) () -wedgeKeys f = onWedges $ \a -> key (f a) - --- | Make a pie plot from a list of data by making a series of wedge --- plots. --- --- === __Example__ --- --- <> --- --- > import Plots --- > --- > pieData = [("red", 3), ("blue", 4), ("green", 2), ("purple", 5)] --- > --- > piePlotAxis :: Axis B Polar Double --- > piePlotAxis = polarAxis &~ do --- > piePlot pieData snd $ wedgeKeys fst --- > hide (axes . traversed) --- --- > piePlotExample = renderAxis piePlotAxis -piePlot - :: (MonadState (Axis b Polar n) m, - Plotable (Wedge n) b, - F.Foldable f) - => f a -- ^ data for each wedge - -> (a -> n) -- ^ extract weight of each wedge - -> State (PieState b n a) () - -> m () -piePlot (F.toList -> as) f st = F.forM_ ps addPlot - where - -- calculate pie widths - ns = map f as - x = F.sum ns - wedges = snd $ List.mapAccumR wedgeAccum xDir as - wedgeAccum d a = (d', wdg) - where theta = (f a / x) @@ turn - d' = d # rotate theta - wdg = mkWedge d theta - - -- run pie state - ps = map snd . psMods $ execState st ps0 - ps0 = PieState { psMods = zip as (map mkPlot wedges) } - --- | Make a pie plot from list of values without any changes. --- --- === __Example__ --- --- <> --- --- > import Plots --- > --- > piePlotAxis' :: Axis B Polar Double --- > piePlotAxis' = polarAxis &~ do --- > piePlot' [1,3,5,2] --- > wedgeInnerRadius .= 0.5 --- > hide (axes . traversed) --- --- > pieExample' = renderAxis piePlotAxis' -piePlot' - :: (MonadState (Axis b Polar n) m, - Plotable (Wedge n) b, - F.Foldable f) - => f n -- ^ weight of each wedge - -> m () -piePlot' ns = piePlot ns id (return ()) - ------------------------------------------------------------------------- --- Wedge ------------------------------------------------------------------------- - --- $ pieplot --- Pie plots display data as wedges and annular wedges. --- Pie plots have the following lenses: --- --- @ --- * 'strokeArc' :: 'Lens'' ('BoxPlot' v n) 'Bool' - False --- @ - --- | Add a single 'PiePlot' to the 'AxisState' from a data set. --- --- === __Example__ --- --- <> --- --- > import Plots --- > --- > wedgePlotAxis :: Axis B Polar Double --- > wedgePlotAxis = polarAxis &~ do --- > wedgePlot xDir (38@@deg) $ key "wedge" --- --- > wedgeExample = renderAxis wedgePlotAxis -wedgePlot - :: (v ~ BaseSpace c, v ~ V2, - PointLike v n (Polar n), - MonadState (Axis b c n) m, - Plotable (Wedge n) b - ) - => Direction V2 n -> Angle n -> State (Plot (Wedge n) b) () -> m () -wedgePlot r theta = addPlotable (mkWedge r theta) - diff --git a/src/Plots/Types/Scatter.hs b/src/Plots/Types/Scatter.hs --- a/src/Plots/Types/Scatter.hs +++ b/src/Plots/Types/Scatter.hs @@ -80,6 +80,8 @@ import Plots.Style import Plots.Types +import Diagrams.Types (mkQD, Prim (..)) + -- config -- > import Plots @@ -89,31 +91,30 @@ -- | A general data type for scatter plots. Allows storing different -- types of data as well as allowing transforms depending on the data. -data ScatterPlot v n where - ScatterPlot :: Typeable a => ScatterOptions v n a -> ScatterPlot v n +data ScatterPlot v where + ScatterPlot :: Typeable a => ScatterOptions v a -> ScatterPlot v deriving Typeable -type instance V (ScatterPlot v n) = v -type instance N (ScatterPlot v n) = n +type instance V (ScatterPlot v) = v +type instance N (ScatterPlot v) = Double -- | A general data type for scatter plots. Allows storing different -- types of data as well as allowing transforms depending on the data. -data ScatterOptions v n a = ScatterOptions +data ScatterOptions v a = ScatterOptions { oData :: [a] - , oPos :: a -> Point v n - , oTr :: a -> Transformation v n - , oSty :: a -> Style v n + , oPos :: a -> Point v Double + , oTr :: a -> Transformation v Double + , oSty :: a -> Style v Double , oLine :: Bool } deriving Typeable -type instance V (ScatterOptions v n a) = v -type instance N (ScatterOptions v n a) = n +type instance V (ScatterOptions v a) = v +type instance N (ScatterOptions v a) = Double -instance (Metric v, OrderedField n) => Enveloped (ScatterPlot v n) where +instance Metric v => Enveloped (ScatterPlot v) where getEnvelope (ScatterPlot (ScatterOptions {..})) = getEnvelope (map oPos oData) -instance (TypeableFloat n, Renderable (Path V2 n) b) - => Plotable (ScatterPlot V2 n) b where +instance Plotable (ScatterPlot V2) where renderPlotable s sty (ScatterPlot (ScatterOptions {..})) = markers <> line where @@ -133,21 +134,44 @@ sty ^. plotMarker & applyMarkerStyle sty +strokeV3 :: Path V3 Double -> Diagram V3 +strokeV3 path = mkQD (Prim path) (getEnvelope path) mempty mempty + +instance Plotable (ScatterPlot V3) where + renderPlotable s sty (ScatterPlot (ScatterOptions {..})) = + markers <> line + where + markers = F.foldMap mk oData # applyMarkerStyle sty + -- + mk a = marker # transform (oTr a) + # applyStyle (oSty a) + # moveTo (specPoint s $ oPos a) + marker = sty ^. plotMarker + -- + line + | not oLine = mempty + | otherwise = strokeV3 (fromVertices points) # applyLineStyle sty + points = map (specPoint s . oPos) oData + + defLegendPic sty (ScatterPlot (ScatterOptions {..})) = + sty ^. plotMarker + & applyMarkerStyle sty + ------------------------------------------------------------------------ -- Generating scatter options ------------------------------------------------------------------------ -- | Low level construction of 'ScatterOptions'. mkScatterOptions - :: (PointLike v n p, F.Foldable f, Fractional n) + :: (PointLike v Double p, F.Foldable f) => f a -> (a -> p) - -> ScatterOptions v n a + -> ScatterOptions v a mkScatterOptions xs pf = ScatterOptions { oData = F.toList xs , oPos = view unpointLike . pf , oTr = mempty - , oSty = const (_Wrapped ## mempty) + , oSty = const mempty , oLine = False } @@ -163,100 +187,100 @@ -- 'lineStyle' from the 'PlotStyle'. connectingLine :: Functor f => LensLike' f a Bool -instance HasConnectingLine f (ScatterOptions v n a) where +instance HasConnectingLine f (ScatterOptions v a) where connectingLine = lens oLine (\o b -> o {oLine = b}) -instance HasConnectingLine f (ScatterPlot v n) where +instance HasConnectingLine f (ScatterPlot v) where connectingLine f (ScatterPlot o@(ScatterOptions {..})) = f oLine <&> \b -> ScatterPlot o {oLine = b} -instance HasConnectingLine f p => HasConnectingLine f (Plot p b) where +instance HasConnectingLine f p => HasConnectingLine f (Plot p) where connectingLine = rawPlot . connectingLine -instance (Applicative f, Typeable b, Typeable v, Typeable n) - => HasConnectingLine f (DynamicPlot b v n) where - connectingLine = (dynamicPlot :: Traversal' (DynamicPlot b v n) (Plot (ScatterPlot v n) b)) +instance (Applicative f, Typeable v) + => HasConnectingLine f (DynamicPlot v) where + connectingLine = (dynamicPlot :: Traversal' (DynamicPlot v) (Plot (ScatterPlot v))) . connectingLine -instance (Applicative f, Typeable v, Typeable n) - => HasConnectingLine f (StyledPlot b v n) where - connectingLine = (styledPlot :: Traversal' (StyledPlot b v n) (ScatterPlot v n)) +instance (Applicative f, Typeable v) + => HasConnectingLine f (StyledPlot v) where + connectingLine = (styledPlot :: Traversal' (StyledPlot v) (ScatterPlot v)) . connectingLine -instance (Settable f, Typeable (BaseSpace c), Typeable n) - => HasConnectingLine f (Axis b c n) where +instance (Settable f, Typeable (BaseSpace c)) + => HasConnectingLine f (Axis c) where connectingLine = finalPlots . connectingLine -- Options ------------------------------------------------------------- class HasScatterOptions f a d where -- | Lens onto the 'ScatterOptions' for a general scatter plot. - gscatterOptions :: LensLike' f a (ScatterOptions (V a) (N a) d) + gscatterOptions :: LensLike' f a (ScatterOptions (V a) d) -- | Apply a transform to the markers using the associated data. - scatterTransform :: Functor f => LensLike' f a (d -> Transformation (V a) (N a)) + scatterTransform :: Functor f => LensLike' f a (d -> Transformation (V a) Double) scatterTransform = gscatterOptions . lens oTr (\o tr -> o {oTr = tr}) -- | Apply a style to the markers using the associated data. - scatterStyle :: Functor f => LensLike' f a (d -> Style (V a) (N a)) + scatterStyle :: Functor f => LensLike' f a (d -> Style (V a) Double) scatterStyle = gscatterOptions . lens oSty (\o sty -> o {oSty = sty}) -- | Change the position of the markers depending on the data. - scatterPosition :: Functor f => LensLike' f a (d -> Point (V a) (N a)) + scatterPosition :: Functor f => LensLike' f a (d -> Point (V a) Double) scatterPosition = gscatterOptions . lens oPos (\o pos -> o {oPos = pos}) -instance d ~ d' => HasScatterOptions f (ScatterOptions v n d) d' where +instance d ~ d' => HasScatterOptions f (ScatterOptions v d) d' where gscatterOptions = id -instance (Applicative f, Typeable v, Typeable n, Typeable d) - => HasScatterOptions f (ScatterPlot v n) d where +instance (Applicative f, Typeable v, Typeable d) + => HasScatterOptions f (ScatterPlot v) d where gscatterOptions f s@(ScatterPlot p) = case eq p of Just Refl -> ScatterPlot <$> f p Nothing -> pure s where - eq :: Typeable a => a -> Maybe (a :~: ScatterOptions v n d) + eq :: Typeable a => a -> Maybe (a :~: ScatterOptions v d) eq _ = eqT -instance (Functor f, HasScatterOptions f p a) => HasScatterOptions f (Plot p b) a where +instance (Functor f, HasScatterOptions f p a) => HasScatterOptions f (Plot p) a where gscatterOptions = rawPlot . gscatterOptions -instance (Applicative f, Typeable b, Typeable v, Typeable n, Typeable a) - => HasScatterOptions f (DynamicPlot b v n) a where +instance (Applicative f, Typeable v, Typeable a) + => HasScatterOptions f (DynamicPlot v) a where gscatterOptions = dynamicPlot . rawPlot -instance (Applicative f, Typeable b, Typeable (BaseSpace c), Typeable n, Typeable a) - => HasScatterOptions f (Axis b c n) a where +instance (Applicative f, Typeable (BaseSpace c), Typeable a) + => HasScatterOptions f (Axis c) a where gscatterOptions = axisPlots . traverse . gscatterOptions -- Pure scatter lenses ------------------------------------------------- -- | Lens onto a scatter plot of points. -scatterOptions :: (InSpace v n a, HasScatterOptions f a (Point v n)) - => LensLike' f a (ScatterOptions v n (Point v n)) +scatterOptions :: (InSpace v Double a, HasScatterOptions f a (Point v Double)) + => LensLike' f a (ScatterOptions v (Point v Double)) scatterOptions = gscatterOptions -- -- | Lens onto a transform of a scatter plot of points. This is a -- -- specialised version of 'scatterTransform' for better type -- -- inference. -- _scatterTransform --- :: (InSpace v n a, PointLike v n p, Functor f, HasScatterOptions f a (Point v n)) --- => LensLike' f a (p -> Transformation v n) +-- :: (InSpace v a, PointLike v p, Functor f, HasScatterOptions f a (Point v)) +-- => LensLike' f a (p -> Transformation v) -- _scatterTransform = scatterTransform . lmapping unpointLike -- -- | Lens onto a transform of a scatter plot of points. This is a -- -- specialised version of 'scatterPosition' for better type inference. -- _scatterPosition --- :: (InSpace v n a, PointLike v n p, Functor f, HasScatterOptions f a (Point v n)) +-- :: (InSpace v a, PointLike v p, Functor f, HasScatterOptions f a (Point v)) -- => LensLike' f a (p -> p) -- _scatterPosition = scatterPos . dimapping unpointLike pointLike -- -- | Lens onto a style function of a scatter plot of points. This is a -- -- specialised version of 'scatterStyle' for better type inference. -- _scatterStyle --- :: (InSpace v n a, PointLike v n p, Functor f, HasScatterOptions f a (Point v n)) --- => LensLike' f a (p -> Style v n) +-- :: (InSpace v a, PointLike v p, Functor f, HasScatterOptions f a (Point v)) +-- => LensLike' f a (p -> Style v) -- _scatterStyle = scatterStyle . lmapping unpointLike ------------------------------------------------------------------------ @@ -275,9 +299,9 @@ -- | Add a 'ScatterPlot' to the 'AxisState' from a data set. -- -- @ --- 'scatterPlot' :: [('Double', 'Double')] -> 'State' ('Plot' ('ScatterOptions' 'V2' 'Double' ('P2' 'Double')) b) () -> 'State' ('Axis' b 'V2' 'Double') () --- 'scatterPlot' :: ['V2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' 'Double' ('P2' 'Double')) b) () -> 'State' ('Axis' b 'V2' 'Double') () --- 'scatterPlot' :: ['P2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' 'Double' ('P2' 'Double')) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'scatterPlot' :: [('Double', 'Double')] -> 'State' ('Plot' ('ScatterOptions' 'V2' ('P2' 'Double')) b) () -> 'State' ('Axis' 'V2') () +-- 'scatterPlot' :: ['V2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' ('P2' 'Double')) b) () -> 'State' ('Axis' 'V2') () +-- 'scatterPlot' :: ['P2' 'Double'] -> 'State' ('Plot' ('ScatterOptions' 'V2' ('P2' 'Double')) b) () -> 'State' ('Axis' 'V2') () -- @ -- -- === __Example__ @@ -289,7 +313,7 @@ -- > mydata2 = mydata1 & each . _1 *~ 0.5 -- > mydata3 = [V2 1.2 2.7, V2 2 5.1, V2 3.2 2.6, V2 3.5 5] -- --- > scatterAxis :: Axis B V2 Double +-- > scatterAxis :: Axis V2 -- > scatterAxis = r2Axis &~ do -- > scatterPlot mydata1 $ key "data 1" -- > scatterPlot mydata2 $ key "data 2" @@ -298,13 +322,12 @@ -- > scatterExample = renderAxis scatterAxis scatterPlot :: (BaseSpace c ~ v, - PointLike v n p, - Typeable n, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, + PointLike v Double p, + MonadState (Axis c) m, + Plotable (ScatterPlot v), F.Foldable f) => f p -- ^ points to plot - -> State (Plot (ScatterOptions v n (Point v n)) b) () + -> State (Plot (ScatterOptions v (Point v Double))) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' scatterPlot xs = gscatterPlot (xs ^.. folded . unpointLike) id @@ -336,10 +359,9 @@ -- > scatterExample' = renderAxis scatterAxis' scatterPlot' :: (BaseSpace c ~ v, - PointLike v n p, - Typeable n, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, + PointLike v Double p, + MonadState (Axis c) m, + Plotable (ScatterPlot v), F.Foldable f) => f p -- ^ points to plot -> m () -- ^ add plot to 'Axis' @@ -348,13 +370,12 @@ -- | Version of 'scatterPlot' that accepts a 'Fold' over the data. scatterPlotOf :: (BaseSpace c ~ v, - PointLike v n p, - Typeable n, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b) + PointLike v Double p, + Plotable (ScatterPlot v), + MonadState (Axis c) m) => Fold s p -- ^ fold over points -> s -- ^ data to fold - -> State (Plot (ScatterOptions v n (Point v n)) b) () -- ^ changes to plot options + -> State (Plot (ScatterOptions v (Point v Double))) () -- ^ changes to plot options -> m () -- ^ add plot to 'Axis' scatterPlotOf f s = scatterPlot (toListOf f s) @@ -362,10 +383,9 @@ -- without any changes to the 'ScatterOptions'. scatterPlotOf' :: (BaseSpace c ~ v, - PointLike v n p, - Typeable n, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b) + PointLike v Double p, + MonadState (Axis c) m, + Plotable (ScatterPlot v)) => Fold s p -- ^ fold over points -> s -- ^ data to fold -> m () -- ^ add plot to axis @@ -376,15 +396,15 @@ ------------------------------------------------------------------------ -- | A bubble plot is a scatter plot using point together with a scalar. -type BubbleOptions v n = ScatterOptions v n (n, Point v n) +type BubbleOptions v = ScatterOptions v (Double, Point v Double) -- | Scatter plots with extra numeric parameter. By default the extra -- parameter is the scale of the marker but this can be changed. -- -- @ --- 'bubblePlot' :: [('Double', ('Double', 'Double'))] -> 'State' ('Plot' ('BubbleOptions' v n) b) () -> 'State' ('Axis' b 'V2' 'Double') () --- 'bubblePlot' :: [('Double', 'V2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v n) b) () -> 'State' ('Axis' b 'V2' 'Double') () --- 'bubblePlot' :: [('Double', 'P2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v n) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'bubblePlot' :: [('Double', ('Double', 'Double'))] -> 'State' ('Plot' ('BubbleOptions' v) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'bubblePlot' :: [('Double', 'V2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v) b) () -> 'State' ('Axis' b 'V2' 'Double') () +-- 'bubblePlot' :: [('Double', 'P2' 'Double')] -> 'State' ('Plot' ('BubbleOptions' v) b) () -> 'State' ('Axis' b 'V2' 'Double') () -- @ -- -- === __Example__ @@ -406,13 +426,12 @@ -- > bubbleExample = renderAxis bubbleAxis bubblePlot :: (BaseSpace c ~ v, - PointLike v n p, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, - Typeable n, + PointLike v Double p, + MonadState (Axis c) m, + Plotable (ScatterPlot v), F.Foldable f) - => f (n, p) -- ^ fold over points with a size - -> State (Plot (BubbleOptions v n) b) () -- ^ changes to the options + => f (Double, p) -- ^ fold over points with a size + -> State (Plot (BubbleOptions v)) () -- ^ changes to the options -> m () -- ^ add plot to 'Axis' bubblePlot xs s = gscatterPlot (xs ^.. folded . mapping unpointLike) snd $ do @@ -428,25 +447,23 @@ -- bubblePlot' :: (v ~ BaseSpace c, - PointLike v n p, - Typeable n, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, + PointLike v Double p, + MonadState (Axis c) m, + Plotable (ScatterPlot v), F.Foldable f) - => f (n, p) -- ^ fold over points with a size + => f (Double, p) -- ^ fold over points with a size -> m () -- ^ add plot to 'Axis' bubblePlot' xs = bubblePlot xs (return ()) -- | Version of 'bubblePlot' using a 'Fold' over the data. bubblePlotOf :: (BaseSpace c ~ v, - PointLike v n p, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, - Typeable n) - => Fold s (n,p) -- ^ fold over the data + PointLike v Double p, + Plotable (ScatterPlot v), + MonadState (Axis c) m) + => Fold s (Double,p) -- ^ fold over the data -> s -- ^ data - -> State (Plot (BubbleOptions v n) b) () + -> State (Plot (BubbleOptions v)) () -- ^ changes to the options -> m () -- ^ add plot to 'Axis' bubblePlotOf f s = bubblePlot (toListOf f s) @@ -455,13 +472,12 @@ -- changes to the 'BubbleOptions'. bubblePlotOf' :: (BaseSpace c ~ v, - PointLike v n p, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, - Typeable n) - => Fold s (n,p) -- ^ fold over the data + PointLike v Double p, + MonadState (Axis c) m, + Plotable (ScatterPlot v)) + => Fold s (Double,p) -- ^ fold over the data -> s -- ^ data - -> State (Plot (BubbleOptions v n) b) () + -> State (Plot (BubbleOptions v)) () -- ^ changes to the options -> m () -- ^ add plot to 'Axis' bubblePlotOf' f s = bubblePlot (toListOf f s) @@ -469,43 +485,43 @@ -- Bubble scatter lenses ----------------------------------------------- -- | LensLike onto into a 'ScatterOptions' made up of a scaler @n@, and --- a point, @'Point' v n@ +-- a point, @'Point' v@ -- -- @ --- 'bubbleOptions' :: 'Lens'' ('Plot' ('BubbleOptions' v n) v) ('BubbleOptions' v n) +-- 'bubbleOptions' :: 'Lens'' ('Plot' ('BubbleOptions' v) v) ('BubbleOptions' v) -- @ -bubbleOptions :: (InSpace v n a, HasScatterOptions f a (n, Point v n)) - => LensLike' f a (BubbleOptions v n) +bubbleOptions :: (InSpace v Double a, HasScatterOptions f a (Double, Point v Double)) + => LensLike' f a (BubbleOptions v) bubbleOptions = gscatterOptions -- | Setter over the transform function for a 'bubblePlot'. Default is 'scale'. -- -- @ --- 'bubbleOptions' :: 'Setter'' ('Plot' ('BubbleOptions' v n) v) (n -> 'Transformation' v n) +-- 'bubbleOptions' :: 'Setter'' ('Plot' ('BubbleOptions' v) v) (n -> 'Transformation' v) -- @ -- -- Note that this is the less general version of @'bubblePlot' . -- 'scatterTransform'@, which would give a 'LensLike' onto @(n, --- 'Point' v n) -> 'Transformation' v n@. +-- 'Point' v) -> 'Transformation' v@. -- bubbleTransform - :: (InSpace v n a, HasScatterOptions f a (n, Point v n), Settable f) - => LensLike' f a (n -> Transformation v n) + :: (InSpace v Double a, HasScatterOptions f a (Double, Point v Double), Settable f) + => LensLike' f a (Double -> Transformation v Double) bubbleTransform = bubbleOptions . scatterTransform . sets nOnly where nOnly f g (n,p) = f (\n' -> g (n', p)) n -- | Setter over the style function for a 'bubblePlot'. Default is 'mempty'. -- -- @ --- 'bubbleStyle' :: 'Setter'' ('Plot' ('BubbleOptions' v n) v) (n -> 'Style' v n) +-- 'bubbleStyle' :: 'Setter'' ('Plot' ('BubbleOptions' v) v) (n -> 'Style' v) -- @ -- -- Note that this is the less general version of @'bubblePlot' . -- 'scatterTransform'@, which would give a 'LensLike' onto @(n, --- 'Point' v n) -> 'Style' v n@. +-- 'Point' v) -> 'Style' v@. -- -bubbleStyle :: (InSpace v n a, Settable f, HasScatterOptions f a (n, Point v n)) - => LensLike' f a (n -> Style v n) +bubbleStyle :: (InSpace v Double a, Settable f, HasScatterOptions f a (Double, Point v Double)) + => LensLike' f a (Double -> Style v Double) bubbleStyle = bubbleOptions . scatterStyle . sets nOnly where nOnly f g (n,p) = f (\n' -> g (n', p)) n @@ -517,14 +533,14 @@ -- the 'scatterTransform' and 'scatterStyle'. gscatterPlot :: (BaseSpace c ~ v, - PointLike v n p, - MonadState (Axis b c n) m, - Plotable (ScatterPlot v n) b, + PointLike v Double p, + MonadState (Axis c) m, Typeable d, + Plotable (ScatterPlot v), F.Foldable f) => f d -- ^ data -> (d -> p) -- ^ extract point from data - -> State (Plot (ScatterOptions v n d) b) () + -> State (Plot (ScatterOptions v d)) () -- ^ options for plot -> m () -- ^ add plot to 'Axis' gscatterPlot xs pf s = addPlot $ over rawPlot ScatterPlot p1 @@ -535,7 +551,7 @@ -- | Helper to traverse over a general scatter plot where the type of d -- is not infered. gscatterOptionsFor - :: (InSpace v n a, HasScatterOptions f a d) - => proxy d -> LensLike' f a (ScatterOptions v n d) + :: (InSpace v Double a, HasScatterOptions f a d) + => proxy d -> LensLike' f a (ScatterOptions v d) gscatterOptionsFor _ = gscatterOptions