{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Plots.Axis.Scale
(
AxisScaling
, ScaleMode (..)
, UniformScaleStrategy (..)
, Extending (..)
, noExtend
, HasAxisScaling (..)
, LogScale (..)
, logNumber
, logPoint
, logDeform
, calculateBounds
, calculateScaling
) where
import Control.Applicative
import Control.Lens
import Data.Bool
import Data.Default
import Data.Distributive
import Data.Maybe
import qualified Data.Foldable as F
import Diagrams
import Linear
data ScaleMode
= AutoScale
| NoScale
| Stretch
| UniformScale UniformScaleStrategy
deriving (Show, Read)
data UniformScaleStrategy
= AutoUniformScale
| UnitOnly
| ChangeVerticalLimits
| ChangeHorizontalLimits
deriving (Show, Read)
data AxisScaling n = Scaling
{ asRatio :: Maybe n
, asMode :: ScaleMode
, asEnlarge :: Extending n
, asBoundMin :: Maybe n
, asBoundMax :: Maybe n
, asSize :: Maybe n
, asLogScale :: LogScale
, asBackupBoundMax :: n
, asBackupBoundMin :: n
}
type instance N (AxisScaling n) = n
instance Fractional n => Default (AxisScaling n) where
def = Scaling
{ asRatio = Nothing
, asMode = AutoScale
, asEnlarge = RelativeExtend 0.1
, asBoundMin = Nothing
, asBoundMax = Nothing
, asLogScale = def
, asSize = Just 400
, asBackupBoundMax = 5
, asBackupBoundMin = -5
}
data Extending n
= AbsoluteExtend n
| RelativeExtend n
deriving (Show, Ord, Eq, Functor)
noExtend :: Num n => Extending n
noExtend = AbsoluteExtend 0
class HasAxisScaling f a where
axisScaling :: LensLike' f a (AxisScaling (N a))
scaleAspectRatio :: Functor f => LensLike' f a (Maybe (N a))
scaleAspectRatio = axisScaling . lens asRatio (\as r -> as {asRatio = r})
scaleMode :: Functor f => LensLike' f a ScaleMode
scaleMode = axisScaling . lens asMode (\as r -> as {asMode = r})
logScale :: Functor f => LensLike' f a LogScale
logScale = axisScaling . lens asLogScale (\as r -> as {asLogScale = r})
axisExtend :: Functor f => LensLike' f a (Extending (N a))
axisExtend = axisScaling . lens asEnlarge (\as r -> as {asEnlarge = r})
boundMin :: Functor f => LensLike' f a (Maybe (N a))
boundMin = axisScaling . lens asBoundMin (\as b -> as {asBoundMin = b})
boundMax :: Functor f => LensLike' f a (Maybe (N a))
boundMax = axisScaling . lens asBoundMax (\as b -> as {asBoundMax = b})
renderSize :: Functor f => LensLike' f a (Maybe (N a))
renderSize = axisScaling . lens asSize (\as s -> as {asSize = s})
asSizeSpec :: (HasLinearMap v, Num n, Ord n) => Lens' (v (AxisScaling n)) (SizeSpec v n)
asSizeSpec = column renderSize . iso mkSizeSpec getSpec
instance HasAxisScaling f (AxisScaling n) where
axisScaling = id
calculateBounds
:: OrderedField n
=> AxisScaling n
-> Maybe (n, n)
-> (n, n)
calculateBounds Scaling {..} mInferred = (l', u') where
l' = l & whenever (isNothing asBoundMin) (subtract x)
& whenever (asLogScale == LogAxis) (max 1e-6)
u' = u & whenever (isNothing asBoundMax) (+ x)
x = case asEnlarge of
AbsoluteExtend a -> a
RelativeExtend a -> (u - l) * a
l = fromMaybe asBackupBoundMin $ asBoundMin <|> lI
u = fromMaybe asBackupBoundMax $ asBoundMax <|> uI
lI = preview (folded . _1) mInferred
uI = preview (folded . _2) mInferred
calculateScaling
:: (HasLinearMap v, OrderedField n, Applicative v)
=> v (AxisScaling n)
-> BoundingBox v n
-> (v (n,n), Transformation v n, Transformation v n)
calculateScaling aScaling bb = (bounds, aspectScaling, sizeScaling) where
bounds = calculateBounds <$> aScaling <*> distribute inferred
inferred = view _Point . uncurry (liftA2 (,)) <$> getCorners bb
aspectScaling
| anyOf (folded . scaleAspectRatio) isJust aScaling
= vectorScaling $ view (scaleAspectRatio . non 1) <$> aScaling
| otherwise = inv $ vectorScaling v
sizeScaling = requiredScaling szSpec v'
v = uncurry (flip (-)) <$> bounds
v' = apply aspectScaling v
szSpec = view asSizeSpec aScaling
vectorScaling :: (Additive v, Fractional n) => v n -> Transformation v n
vectorScaling v = fromLinear f f
where f = liftI2 (*) v <-> liftI2 (flip (/)) v
whenever :: Bool -> (a -> a) -> a -> a
whenever b f = bool id f b
data LogScale = LinearAxis | LogAxis
deriving (Show, Eq)
instance Default LogScale where
def = LinearAxis
logNumber :: Floating a => LogScale -> a -> a
logNumber LinearAxis = id
logNumber LogAxis = log
{-# INLINE logNumber #-}
logPoint :: (Additive v, Floating n) => v LogScale -> Point v n -> Point v n
logPoint v = _Point %~ liftI2 logNumber v
{-# INLINE logPoint #-}
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)