module Graphics.Rendering.Plot.Light.Internal (FigureData(..), Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameFromPoints, width, height, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint, Axis(..), svgHeader, rectCentered, circle, line, tick, ticks, axis, toPlot, text, polyline, filledPolyline, filledBand, candlestick, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, (-.), pointRange, movePoint, moveLabeledPointV2, moveLabeledPointV2Frames, toSvgFrame, toSvgFrameLP, e1, e2) where
import Data.Monoid ((<>))
import qualified Data.Foldable as F (toList)
import Data.List
import Control.Monad (forM, forM_)
import Data.Scientific (Scientific, toRealFloat)
import qualified Data.Text as T
import Text.Blaze.Svg
import Text.Blaze.Svg11 ((!))
import qualified Text.Blaze.Svg11 as S hiding (style)
import qualified Text.Blaze.Svg11.Attributes as SA hiding (rotate)
import Text.Blaze.Svg.Renderer.String (renderSvg)
import qualified Data.Colour as C
import qualified Data.Colour.Names as C
import qualified Data.Colour.SRGB as C
import GHC.Real
import Graphics.Rendering.Plot.Light.Internal.Geometry
data FigureData a = FigureData {
figWidth :: a
, figHeight :: a
, figLeftMFrac :: a
, figRightMFrac :: a
, figTopMFrac :: a
, figBottomMFrac :: a
, figLabelFontSize :: Int
} deriving (Eq, Show)
svgHeader :: Real a => Frame a -> Svg -> Svg
svgHeader fd =
S.docTypeSvg
! SA.version "1.1"
! SA.width (vd $ width fd)
! SA.height (vd $ height fd)
! SA.viewbox (vds [xmin fd, ymin fd, xmax fd, ymax fd])
rectCentered :: (Show a, RealFrac a) =>
Point a
-> a
-> a
-> a
-> Maybe (C.Colour Double)
-> Maybe (C.Colour Double)
-> Svg
rectCentered (Point x0 y0) wid hei sw scol fcol = S.g ! SA.transform (S.translate x0c y0c) $
S.rect ! SA.width (vd wid) ! SA.height (vd hei) ! colourFillOpt fcol ! colourStrokeOpt scol ! SA.strokeWidth (vd sw) where
x0c = x0 (wid / 2)
y0c = y0 (hei / 2)
line :: (Show a, RealFrac a) =>
Point a
-> Point a
-> a
-> LineStroke_ a
-> C.Colour Double
-> Svg
line (Point x1 y1) (Point x2 y2) sw Continuous col = S.line ! SA.x1 (vd x1) ! SA.y1 (vd y1) ! SA.x2 (vd x2) ! SA.y2 (vd y2) ! SA.stroke (colourAttr col ) ! SA.strokeWidth (vd sw)
line (Point x1 y1) (Point x2 y2) sw (Dashed d) col = S.line ! SA.x1 (vd x1) ! SA.y1 (vd y1) ! SA.x2 (vd x2) ! SA.y2 (vd y2) ! SA.stroke (colourAttr col ) ! SA.strokeWidth (vd sw) ! strokeDashArray d
strokeDashArray :: Real a => [a] -> S.Attribute
strokeDashArray sz = SA.strokeDasharray (S.toValue str) where
str = intercalate ", " $ map (show . real) sz
data LineStroke_ a = Continuous | Dashed [a] deriving (Eq, Show)
tick :: (Show a, RealFrac a) => Axis -> a -> a -> C.Colour Double -> Point a -> Svg
tick ax len sw col (Point x y) = line (Point x1 y1) (Point x2 y2) sw Continuous col where
lh = len / 2
(x1, y1, x2, y2)
| ax == Y = (x, ylh, x, y+lh)
| otherwise = (xlh, y, x+lh, y)
labeledTick
:: (Show a, RealFrac a) =>
Axis
-> a
-> a
-> C.Colour Double
-> Int
-> a
-> TextAnchor_
-> (t -> T.Text)
-> V2 a
-> LabeledPoint t a
-> Svg
labeledTick ax len sw col fontsize lrot tanchor flab vlab (LabeledPoint p label) = do
tick ax len sw col p
text lrot fontsize col tanchor (flab label) vlab p
ticks :: (Foldable t, Show a, RealFrac a) =>
Axis
-> a
-> a
-> C.Colour Double
-> t (Point a)
-> Svg
ticks ax len sw col ps = forM_ ps (tick ax len sw col)
labeledTicks ax len sw col fontsize lrot tanchor flab vlab ps =
forM_ ps (labeledTick ax len sw col fontsize lrot tanchor flab vlab)
axis :: (Functor t, Foldable t, Show a, RealFrac a) =>
Point a
-> Axis
-> a
-> a
-> C.Colour Double
-> a
-> LineStroke_ a
-> Int
-> a
-> TextAnchor_
-> (l -> T.Text)
-> V2 a
-> t (LabeledPoint l a)
-> Svg
axis o@(Point ox oy) ax len sw col tickLenFrac ls fontsize lrot tanchor flab vlab ps = do
line o pend sw ls col
labeledTicks (otherAxis ax) (tickLenFrac * len) sw col fontsize lrot tanchor flab vlab (moveLabeledPoint f <$> ps)
where
pend | ax == X = Point (ox + len) oy
| otherwise = Point ox (oy + len)
f | ax == X = setPointY oy
| otherwise = setPointX ox
toPlot
:: (Functor t, Foldable t, Show a, RealFrac a) =>
FigureData a
-> (l -> T.Text)
-> (l -> T.Text)
-> a
-> a
-> a
-> C.Colour Double
-> (t (LabeledPoint l a) -> t (LabeledPoint l a))
-> (t (LabeledPoint l a) -> t (LabeledPoint l a))
-> (t (LabeledPoint l a) -> Svg)
-> t (LabeledPoint l a)
-> Svg
toPlot fd flabelx flabely rotx roty sw col1 tickXf tickYf plotf dat = do
axis oSvg X (right left) sw col1 0.05 Continuous fontsize rotx TAEnd flabelx (V2 (10) 0) (tickXf dat')
axis oSvg Y (top bot) sw col1 0.05 Continuous fontsize roty TAEnd flabely (V2 (10) 0) (tickYf dat')
plotf dat'
where
fontsize = figLabelFontSize fd
wfig = figWidth fd
hfig = figHeight fd
(left, right) = (figLeftMFrac fd * wfig, figRightMFrac fd * wfig)
(top, bot) = (figTopMFrac fd * hfig, figBottomMFrac fd * hfig)
oTo = Point left top
p2To = Point right bot
from = frameFromPoints $ _lp <$> dat
to = mkFrame oTo p2To
dat' = toSvgFrameLP from to False <$> dat
oSvg = Point left bot
text :: (Show a, Real a) =>
a
-> Int
-> C.Colour Double
-> TextAnchor_
-> T.Text
-> V2 a
-> Point a
-> Svg
text rot fontsize col ta te (V2 vx vy) (Point x y) = S.text_ (S.toMarkup te) ! SA.x (vd vx) ! SA.y (vd vy) ! SA.transform (S.translate (real x) (real y) <> S.rotate (real rot)) ! SA.fontSize (vi fontsize) ! SA.fill (colourAttr col) ! textAnchor ta
data TextAnchor_ = TAStart | TAMiddle | TAEnd deriving (Eq, Show)
textAnchor :: TextAnchor_ -> S.Attribute
textAnchor TAStart = SA.textAnchor (vs "start")
textAnchor TAMiddle = SA.textAnchor (vs "middle")
textAnchor TAEnd = SA.textAnchor (vs "end")
circle
:: (Real a1, Real a) =>
Point a1
-> a
-> a
-> Maybe (C.Colour Double)
-> Maybe (C.Colour Double)
-> Svg
circle (Point x y) r sw scol fcol =
S.circle ! SA.cx (vd x) ! SA.cy (vd y) ! SA.r (vd r) ! colourFillOpt fcol ! colourStrokeOpt scol ! SA.strokeWidth (vd sw)
polyline :: (Foldable t, Show a1, Show a, RealFrac a, RealFrac a1) =>
t (Point a)
-> a1
-> LineStroke_ a
-> StrokeLineJoin_
-> C.Colour Double
-> Svg
polyline lis sw Continuous slj col = S.polyline ! SA.points (S.toValue $ unwords $ map show $ F.toList lis) ! SA.fill none ! SA.stroke (colourAttr col ) ! SA.strokeWidth (vd sw) ! strokeLineJoin slj
polyline lis sw (Dashed d) slj col = S.polyline ! SA.points (S.toValue $ unwords $ map show $ F.toList lis) ! SA.fill none ! SA.stroke (colourAttr col ) ! SA.strokeWidth (vd sw) ! strokeLineJoin slj ! strokeDashArray d
none :: S.AttributeValue
none = S.toValue ("none" :: String)
colourFillOpt :: Maybe (C.Colour Double) -> S.Attribute
colourFillOpt Nothing = SA.fill none
colourFillOpt (Just c) = SA.fill (colourAttr c)
colourStrokeOpt :: Maybe (C.Colour Double) -> S.Attribute
colourStrokeOpt Nothing = SA.stroke none
colourStrokeOpt (Just c) = SA.stroke (colourAttr c)
filledPolyline :: (Foldable t, Show a, Real o) =>
C.Colour Double
-> o
-> t (Point a)
-> Svg
filledPolyline col opac lis = S.polyline ! SA.points (S.toValue $ unwords $ map show $ F.toList lis) ! SA.fill (colourAttr col) ! SA.fillOpacity (vd opac)
filledBand :: (Foldable t, Real o, Show a) =>
C.Colour Double
-> o
-> (LabeledPoint l a -> a)
-> (LabeledPoint l a -> a)
-> t (LabeledPoint l a)
-> Svg
filledBand col opac ftop fbot lis0 = filledPolyline col opac (lis1 <> lis2) where
lis = F.toList lis0
f1 lp = setPointY (ftop lp) $ _lp lp
f2 lp = setPointY (fbot lp) $ _lp lp
lis1 = f1 <$> lis
lis2 = f2 <$> reverse lis
candlestick
:: (Show a, RealFrac a) =>
(LabeledPoint l a -> Bool)
-> (LabeledPoint l a -> a)
-> (LabeledPoint l a -> a)
-> (LabeledPoint l a -> a)
-> (LabeledPoint l a -> a)
-> a
-> a
-> C.Colour Double
-> C.Colour Double
-> C.Colour Double
-> LabeledPoint l a
-> Svg
candlestick fdec fboxmin fboxmax fmin fmax wid sw col1 col2 colstroke lp = do
line pmin pmax sw Continuous colstroke
rectCentered p wid hei sw (Just colstroke) (Just col)
where
p = _lp lp
pmin = setPointY (fmin lp) p
pmax = setPointY (fmax lp) p
hei = fboxmax lp fboxmin lp
col | fdec lp = col1
| otherwise = col2
data StrokeLineJoin_ = Miter | Round | Bevel | Inherit deriving (Eq, Show)
strokeLineJoin :: StrokeLineJoin_ -> S.Attribute
strokeLineJoin slj = SA.strokeLinejoin (S.toValue str) where
str | slj == Miter = "miter" :: String
| slj == Round = "round"
| slj == Bevel = "bevel"
| otherwise = "inherit"
toSvgFrame ::
Fractional a =>
Frame a
-> Frame a
-> Bool
-> Point a
-> Point a
toSvgFrame from to fliplr p = pointFromV2 v' where
v' = frameToFrame from to fliplr True (v2fromPoint p)
toSvgFrameLP ::
Fractional a => Frame a -> Frame a -> Bool -> LabeledPoint l a -> LabeledPoint l a
toSvgFrameLP from to fliplr (LabeledPoint p lab) = LabeledPoint (toSvgFrame from to fliplr p) lab
colourAttr :: C.Colour Double -> S.AttributeValue
colourAttr = S.toValue . C.sRGB24show
vs :: String -> S.AttributeValue
vs x = S.toValue (x :: String)
vi :: Int -> S.AttributeValue
vi = S.toValue
vd0 :: Double -> S.AttributeValue
vd0 = S.toValue
vd :: Real a => a -> S.AttributeValue
vd = vd0 . real
real :: (Real a, Fractional b) => a -> b
real = fromRational . toRational
vds :: Real a => [a] -> S.AttributeValue
vds = S.toValue . unwords . map (show . real)