module Graphics.Rendering.Plot.Light.Internal (FigureData(..), Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameFromPoints, width, height, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint, labelPoint, Axis(..), svgHeader, rect, 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])
rect :: (Show a, RealFrac a) =>
Point a
-> a
-> a
-> a
-> Maybe (C.Colour Double)
-> Maybe (C.Colour Double)
-> Svg
rect (Point x0 y0) wid hei sw scol fcol = S.rect ! SA.x (vd x0) ! SA.y (vd y0) ! SA.width (vd wid) ! SA.height (vd hei) ! colourFillOpt fcol ! colourStrokeOpt scol ! SA.strokeWidth (vd sw)
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
-> Maybe (t (LabeledPoint l a))
-> Maybe (t (LabeledPoint l a))
-> (t (LabeledPoint l a) -> Svg)
-> t (LabeledPoint l a)
-> Svg
toPlot fd flabelx flabely rotx roty sw col1 tickxe tickye plotf dat = do
axis oSvg X (right left) sw col1 0.05 Continuous fontsize rotx TAEnd flabelx (V2 (10) 0) tickx
axis oSvg Y (top bot) sw col1 0.05 Continuous fontsize roty TAEnd flabely (V2 (10) 0) ticky
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
datf = toSvgFrameLP from to False
dat' = datf <$> dat
tickDefault ti d = case ti of Just t -> datf <$> t
Nothing -> d
tickx = tickDefault tickxe dat'
ticky = tickDefault tickye 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)