plot-light 0.1.0.7 → 0.1.0.8

raw patch · 9 files changed

+374/−147 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• plot-light.cabal +3/−1
• src/Data/TimeSeries.hs +14/−0
• src/Data/TimeSeries/Forex.hs +1/−10
• src/Graphics/Rendering/Plot/Light.hs +11/−13
• src/Graphics/Rendering/Plot/Light/IO/Text.hs +1/−0
• src/Graphics/Rendering/Plot/Light/Internal.hs +62/−69
• src/Graphics/Rendering/Plot/Light/Internal/Geometry.hs +96/−42
• src/Graphics/Rendering/Plot/Light/PlotTypes/TimeSeries.hs +57/−12
• test/LibSpec.hs +129/−0

@@ -1,5 +1,5 @@ name:                plot-light-version:             0.1.0.7+version:             0.1.0.8 synopsis:            A lightweight plotting library, exporting to SVG description:         A lightweight plotting library, exporting to SVG homepage:            https://github.com/ocramz/plot-light@@ -28,6 +28,7 @@                        Graphics.Rendering.Plot.Light.PlotTypes.Scatter                        Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries                        Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries.Candlestick+                       Data.TimeSeries                        Data.TimeSeries.Forex                        Graphics.Rendering.Plot.Light.Internal.Geometry   build-depends:       base >= 4.7 && < 5@@ -63,6 +64,7 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs+  other-modules:       LibSpec   build-depends:       base                      , plot-light                      , hspec

@@ -0,0 +1,14 @@+module Data.TimeSeries where++import Data.Time++-- | An instant, defined by date (Day) and TimeOfDay+data Tick = Tick Day TimeOfDay+  deriving (Eq, Show, Ord)++-- | A point in a time series+data TsPoint a =+  Tsp {+    _tick :: Tick,+    _val :: a+    } deriving (Eq, Show)

@@ -1,7 +1,7 @@ module Data.TimeSeries.Forex where -import Data.Time + data FxRow a  = FxRow {     rateOpen :: a   , rateHigh :: a@@ -10,13 +10,4 @@                } deriving (Eq, Show)  --- | An instant, defined by date (Day) and TimeOfDay-data Tick = Tick Day TimeOfDay-  deriving (Eq, Show, Ord) --- | A point in a time series-data TsPoint a =-  Tsp {-    _tick :: Tick,-    _val :: a-    } deriving (Eq, Show)

@@ -11,7 +11,7 @@ -- -- == Usage ----- To use this project you just need `import Graphics.Rendering.Plot.Light`. If GHC complains of name clashes you can import the module in "qualified" form.+-- To use this project you just need @import Graphics.Rendering.Plot.Light@. If GHC complains of name clashes you can import the module in "qualified" form. -- -- If you wish to try out the examples in this page, you will need to have these additional import statements: --@@ -35,28 +35,26 @@   Mat2(..), DiagMat2(..), diagMat2,   -- ** Primitive elements   origin, e1, e2,-  -- ** Vector operations +  -- ** Vector norm operations    norm2, normalize2,   -- ** Vector construction   v2fromEndpoints, v2fromPoint,   -- ** Operations on points-  movePoint, moveLabeledPointV2, fromUnitSquare, toUnitSquare,+  movePoint, moveLabeledPointV2, (-.),+  -- ** Operations on vectors+  frameToFrame,   -- ** Typeclasses   AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..)   ) where --- import Data.Foldable-import qualified Data.Text as T+-- import qualified Data.Text as T -import Text.Blaze.Svg--- import Text.Blaze.Svg11 ((!), mkPath, rotate, translate, l, m)--- import qualified Text.Blaze.Svg11 as S--- import qualified Text.Blaze.Svg11.Attributes as A-import Text.Blaze.Svg.Renderer.String (renderSvg)+-- import Text.Blaze.Svg+-- 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 qualified Data.Colour as C+-- import qualified Data.Colour.Names as C+-- import qualified Data.Colour.SRGB as C  import Graphics.Rendering.Plot.Light.Internal 

@@ -9,6 +9,7 @@ import Data.Time (Day, TimeOfDay) import qualified Attoparsec.Time as AT +import Data.TimeSeries import Data.TimeSeries.Forex  

@@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-}-module Graphics.Rendering.Plot.Light.Internal (Frame(..), Point(..), LabeledPoint(..), Axis(..), svgHeader, rectCentered, circle, line, tick, ticks, axis, text, polyline, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, movePoint, moveLabeledPointV2, fromUnitSquare, toUnitSquare, e1, e2) where+module Graphics.Rendering.Plot.Light.Internal (Frame(..), mkFrame, mkFrameOrigin, frameToFrame, frameFromDataset, Point(..), mkPoint, LabeledPoint(..), mkLabeledPoint,  Axis(..), svgHeader, rectCentered, circle, line, tick, ticks, axis, text, polyline, strokeLineJoin, LineStroke_(..), StrokeLineJoin_(..), TextAnchor_(..), V2(..), Mat2(..), DiagMat2(..), diagMat2, AdditiveGroup(..), VectorSpace(..), Hermitian(..), LinearMap(..), MultiplicativeSemigroup(..), MatrixGroup(..), Eps(..), norm2, normalize2, v2fromEndpoints, v2fromPoint, origin, (-.), movePoint, moveLabeledPointV2, moveLabeledPointV2Frames, e1, e2) where  import Data.Monoid ((<>)) import qualified Data.Foldable as F (toList) import Data.List-import Control.Arrow ((&&&), (***))+-- import Control.Arrow ((&&&), (***)) import Control.Monad (forM, forM_)-import Data.Semigroup (Min(..), Max(..))+-- import Data.Semigroup (Min(..), Max(..)) import Data.Scientific (Scientific, toRealFloat)  -- import Data.Foldable@@ -30,13 +30,13 @@   -- | Create the SVG header from a `Frame`-svgHeader :: Frame Int -> Svg -> Svg+svgHeader :: Real a => Frame a -> Svg -> Svg svgHeader fd =   S.docTypeSvg   ! SA.version "1.1"-  ! SA.width (vi $ width fd)-  ! SA.height (vi $ height fd)-  ! SA.viewbox (vis [xmin fd, ymin fd, xmax fd, ymax fd])+  ! SA.width (vd $ width fd)+  ! SA.height (vd $ height fd)+  ! SA.viewbox (vds [xmin fd, ymin fd, xmax fd, ymax fd])   @@ -83,56 +83,74 @@   -tick :: (Show a, RealFrac a) => Axis -> a -> a -> C.Colour Double -> LineStroke_ a -> Point a -> Svg-tick ax len sw col ls (Point x y) = line (Point x1 y1) (Point x2 y2) sw ls col where+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, y-lh, x, y+lh)     | otherwise = (x-lh, y, x+lh, y) -tickX, tickY :: (Show a, RealFrac a) =>-     a               -- ^ Length-  -> a               -- ^ Stroke width-  -> C.Colour Double -- ^ Stroke colour-  -> LineStroke_ a-  -> Point a         -- ^ Center coordinates-  -> Svg-tickX = tick X-tickY = tick Y +labeledTick+  :: (Show a, RealFrac a) =>+     Axis+     -> a                 -- ^ Length+     -> a                 -- ^ Stroke width+     -> C.Colour Double+     -> Int               -- ^ Font size+     -> a                 -- ^ Label angle+     -> TextAnchor_     +     -> (t -> T.Text)     -- ^ Label rendering+     -> V2 a              -- ^ Label shift +     -> LabeledPoint t a+     -> Svg+labeledTick ax len sw col fontsize lrot tanchor flab vlab (LabeledPoint p label) = do+  let ls = Continuous+  tick ax len sw col p+  text lrot fontsize col tanchor (flab label) vlab p++ -- | An array of axis-aligned identical segments (to be used as axis tickmarks), with centers given by the array of `Point`s ticks :: (Foldable t, Show a, RealFrac a) =>                Axis                -- ^ Axis                 -> a                -- ^ Length                         -> a                -- ^ Stroke width                -> C.Colour Double  -- ^ Stroke colour-               -> LineStroke_ a                -> t (Point a)      -- ^ Center coordinates                -> Svg-ticks ax len sw col ls ps = forM_ ps (tick ax len sw col ls)+ticks ax len sw col ps = forM_ ps (tick ax len sw col)  --- | An axis with tickmarks+labeledTicks ax len sw col fontsize lrot tanchor flab vlab ps =+  forM_ ps (labeledTick ax len sw col fontsize lrot tanchor flab vlab)++-- | A plot axis with labeled tickmarks ----- > > putStrLn $ renderSvg $ axis X 200 2 C.red 0.05 (Point 150 10) Continuous [Point 50 1, Point 60 1, Point 70 1]--- > <line x1="50.0" y1="10.0" x2="250.0" y2="10.0" stroke="#ff0000" stroke-width="2.0" /><line x1="50.0" y1="5.0" x2="50.0" y2="15.0" stroke="#ff0000" stroke-width="2.0" /><line x1="60.0" y1="5.0" x2="60.0" y2="15.0" stroke="#ff0000" stroke-width="2.0" /><line x1="70.0" y1="5.0" x2="70.0" y2="15.0" stroke="#ff0000" stroke-width="2.0" />+-- > > putStrLn $ renderSvg $ axis (Point 0 50) X 200 2 C.red 0.05 Continuous 15 (-45) TAEnd T.pack (V2 (-10) 0) [LabeledPoint (Point 50 1) "bla", LabeledPoint (Point 60 1) "asdf"]+-- <line x1="0.0" y1="50.0" x2="200.0" y2="50.0" stroke="#ff0000" stroke-width="2.0" /><line x1="50.0" y1="45.0" x2="50.0" y2="55.0" stroke="#ff0000" stroke-width="2.0" /><text x="-10.0" y="0.0" transform="translate(50.0 50.0)rotate(-45.0)" font-size="15" fill="#ff0000" text-anchor="end">bla</text><line x1="60.0" y1="45.0" x2="60.0" y2="55.0" stroke="#ff0000" stroke-width="2.0" /><text x="-10.0" y="0.0" transform="translate(60.0 50.0)rotate(-45.0)" font-size="15" fill="#ff0000" text-anchor="end">asdf</text> axis :: (Functor t, Foldable t, Show a, RealFrac a) =>-              Axis               -- ^ Axis (i.e. either `X` or `Y`)-              -> a               -- ^ Length+              Point a            -- ^ Origin coordinates+              -> Axis            -- ^ Axis (i.e. either `X` or `Y`)+              -> a               -- ^ Length of the axis               -> a               -- ^ Stroke width               -> C.Colour Double -- ^ Stroke colour-              -> a               -- ^ Tick length fraction (w.r.t axis length)-              -> Point a         -- ^ Axis center coordinate-              -> LineStroke_ a-              -> t (Point a)     -- ^ Tick center coordinates+              -> a               -- ^ The tick length is a fraction of the axis length+              -> LineStroke_ a   -- ^ Stroke type+              -> Int               -- ^ Label font size+              -> a               -- ^ Label rotation angle+              -> TextAnchor_     -- ^ How to anchor a text label to the axis+              -> (l -> T.Text)   -- ^ How to render the tick label+              -> V2 a            -- ^ Offset the label+              -> t (LabeledPoint l a)     -- ^ Tick center coordinates               -> Svg-axis ax len sw col tickLenFrac p@(Point x y) ls ps = do-  tick ax len sw col ls p-  ticks (otherAxis ax) (tickLenFrac * len) sw col ls (f <$> ps)-  where-    f | ax == X = setPointY y-      | otherwise = setPointX x-+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   -- * text@@ -150,14 +168,15 @@ -- > > putStrLn $ renderSvg $ text (-45) C.green TAEnd "blah" (V2 (- 10) 0) (Point 250 0) -- > <text x="-10.0" y="0.0" transform="translate(250.0 0.0)rotate(-45.0)" fill="#008000" text-anchor="end">blah</text> text :: (Show a, Real a) =>-        a               -- ^ Rotation angle of the frame +        a               -- ^ Rotation angle of the frame+     -> Int             -- ^ Font size      -> C.Colour Double -- ^ Font colour-     -> TextAnchor_+     -> TextAnchor_     -- ^ How to anchor a text label to the axis      -> T.Text          -- ^ Text       -> V2 a            -- ^ Displacement w.r.t. rotated frame      -> Point a         -- ^ Reference frame origin of the text box      -> Svg-text rot 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.fill (colourAttr col) ! textAnchor ta+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  -- | Specify at which end should the text be anchored to its current point data TextAnchor_ = TAStart | TAMiddle | TAEnd deriving (Eq, Show)@@ -195,8 +214,8 @@ polyline :: (Foldable t, Show a1, Show a, RealFrac a, RealFrac a1) =>             t (Point a)     -- ^ Data          -> a1              -- ^ Stroke width-         -> LineStroke_ a-         -> StrokeLineJoin_  +         -> LineStroke_ a   -- ^ Stroke type +         -> StrokeLineJoin_ -- ^ Stroke join type           -> C.Colour Double -- ^ Stroke colour          -> 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@@ -245,14 +264,9 @@ vs :: String -> S.AttributeValue vs x = S.toValue (x :: String) --- Int- vi :: Int -> S.AttributeValue vi = S.toValue --- | For use e.g. in `viewbox`-vis :: [Int] -> S.AttributeValue-vis = S.toValue . unwords . map show  -- Double vd0 :: Double -> S.AttributeValue@@ -264,37 +278,16 @@ real :: (Real a, Fractional b) => a -> b real = fromRational . toRational -showd :: Real a => a -> String-showd = show . real --- vds :: [Double] -> S.AttributeValue--- vds = S.toValue . unwords . map show+vds :: Real a => [a] -> S.AttributeValue+vds = S.toValue . unwords . map (show . real)     --- -- Float--- vf :: Float -> S.AttributeValue--- vf = S.toValue --- vfs :: [Float] -> S.AttributeValue--- vfs = S.toValue . unwords . map show --------- main :: IO ()--- main = do---   let a = renderSvg svgDoc---   putStrLn a---- svgDoc :: S.Svg--- svgDoc = S.docTypeSvg ! A.version "1.1" ! A.width "150" ! A.height "100" ! A.viewbox "0 0 3 2" $ do---     S.g ! A.transform makeTransform $ do---       -- S.rect ! A.width "1" ! A.height "2" ! A.fill "#008d46"---       -- S.rect ! A.width "1" ! A.height "2" ! A.fill "#ffffff" --       S.rect ! A.width "1" ! A.height "2" ! A.fill "#d2232c" --       -- S.path ! A.d makePath 

@@ -5,8 +5,10 @@ -} module Graphics.Rendering.Plot.Light.Internal.Geometry where -import Data.Monoid ((<>))+-- import Data.Monoid ((<>)) ++ -- | A `Point` defines a point in R2 data Point a = Point { _px :: a,                        _py :: a } deriving (Eq)@@ -34,6 +36,9 @@    _lplabel :: l    } deriving (Eq, Show) +mkLabeledPoint :: Point a -> l -> LabeledPoint l a+mkLabeledPoint = LabeledPoint+ moveLabeledPoint :: (Point a -> Point b) -> LabeledPoint l a -> LabeledPoint l b moveLabeledPoint f (LabeledPoint p l) = LabeledPoint (f p) l @@ -43,6 +48,30 @@    _fpmax :: Point a    } deriving (Eq, Show) +mkFrame :: Point a -> Point a -> Frame a+mkFrame = Frame++-- | Build a frame rooted at the origin (0, 0)+mkFrameOrigin :: Num a => a -> a -> Frame a+mkFrameOrigin w h = Frame origin (Point w h)+++-- | Create a `Frame` from a container of `LabeledPoint`s `P`, i.e. construct two points `p1` and `p2` such that :+--+-- p1 := inf(x,y) P+-- p2 := sup(x,y) P+frameFromDataset ::+  (Functor t, Ord a, Foldable t) => t (LabeledPoint l a) -> Frame a+frameFromDataset ds = mkFrame (Point mx my) (Point mmx mmy)+  where+    xcoord = _px . _lp <$> ds+    ycoord = _py . _lp <$> ds+    mmx = maximum xcoord +    mmy = maximum ycoord +    mx = minimum xcoord +    my = minimum ycoord+    + -- | Frame corner coordinates xmin, xmax, ymin, ymax :: Frame a -> a xmin = _px . _fpmin@@ -67,21 +96,9 @@   --- * Dataset  --- data Dataset l a = Dataset---   {---     dsdat :: [LabeledPoint l a]---   , dsframe ::Frame a---   } deriving (Eq, Show) --- instance Monoid (Dataset l a) where-----     @@ -92,7 +109,7 @@ -- | Vectors form a monoid w.r.t. vector addition instance Num a => Monoid (V2 a) where   mempty = V2 0 0-  (V2 a b) `mappend` (V2 c d) = V2 (a + b) (c + d)+  (V2 a b) `mappend` (V2 c d) = V2 (a + c) (b + d)  -- | Additive group : -- @@ -173,14 +190,25 @@ instance Num a => LinearMap (Mat2 a) (V2 a) where   (Mat2 a00 a01 a10 a11) #> (V2 vx vy) = V2 (a00 * vx + a01 * vy) (a10 * vx + a11 * vy) --- | Create a diagonal matrix-diagMat2 :: Num a => a -> a -> Mat2 a-diagMat2 rx ry = Mat2 rx 0 0 ry + -- | Diagonal matrices in R2 behave as scaling transformations data DiagMat2 a = DMat2 a a deriving (Eq, Show) +-- | Diagonal matrices form a monoid w.r.t. matrix multiplication and have the identity matrix as neutral element+instance Num a => Monoid (DiagMat2 a) where+  mempty = DMat2 1 1+  mappend = (##) +-- | Matrices form a monoid w.r.t. matrix multiplication and have the identity matrix as neutral element+instance Num a => Monoid (Mat2 a) where+  mempty = Mat2 1 0 0 1+  mappend = (##)++-- | Create a diagonal matrix+diagMat2 :: Num a => a -> a -> DiagMat2 a+diagMat2 = DMat2+ -- | The class of invertible linear transformations class LinearMap m v => MatrixGroup m v where   -- | Inverse matrix action on a vector@@ -209,37 +237,66 @@ moveLabeledPointV2 = moveLabeledPoint . movePoint  --- | The vector translation from a `Point` contained in a `Frame` onto the unit square+++fromFrame :: Fractional a => Frame a -> V2 a -> V2 a+fromFrame from v = mfrom <\> (v ^-^ vfrom) where+  vfrom = v2fromPoint (_fpmin from) -- min.point vector of `from`+  mfrom = diagMat2 (width from) (height from) -- rescaling matrix of `from`++toFrame :: Num a => Frame a -> V2 a -> V2 a+toFrame to v01 = (mto #> v01) ^+^ vto where+  vto = v2fromPoint (_fpmin to)     -- min.point vector of `to`+  mto = diagMat2 (width to) (height to)       -- rescaling matrix of `to`+++++-- | Given two frames `F1` and `F2`, returns a function `f` that maps an arbitrary vector `v` that points within `F1` to one contained within `F2`. ----- NB: we do not check that `p` is actually contained within the frame. This has to be supplied correctly by the user-toUnitSquare :: (Fractional a, MatrixGroup (Mat2 a) (V2 a)) =>-    Frame a -> Point a -> Point a-toUnitSquare from p = movePoint vmove p+-- 1. map `v` into a unit square vector `v01` with an affine transformation+--+-- 2. (optional) map `v01` into another point in the unit square via a linear rescaling+--+-- 3. map `v01'` onto `F2` with a second affine transformation+--+-- NB: we do not check that `v` is actually contained within the `F1`. This has to be supplied correctly by the user.+frameToFrame :: (Fractional a, LinearMap m (V2 a)) =>+                      Frame a  -- ^ Initial frame+                   -> Frame a  -- ^ Final frame+                   -> m        -- ^ Optional rescaling in [0,1] x [0,1]+                   -> V2 a     -- ^ Optional shift +                   -> V2 a     -- ^ Initial vector+                   -> V2 a+frameToFrame from to mopt vopt v = toFrame to v01'   where-    mm = diagMat2 (width from) (height from)-    o1 = _fpmin from-    vmove = mm <\> (p -. o1)+    v01 = fromFrame from v+    v01' = (mopt #> v01) ^+^ vopt --- | The vector translation from a `Point` `p` contained in the unit square onto a `Frame`------ NB: we do not check that `p` is actually contained in [0,1] x [0,1], This has to be supplied correctly by the user-fromUnitSquare :: Num a => Frame a -> Point a -> Point a-fromUnitSquare to p = movePoint vmove p+moveLabeledPointV2Frames ::+  (LinearMap m (V2 a), Fractional a) =>+     Frame a          -- ^ Initial frame+  -> Frame a          -- ^ Final frame+  -> m                -- ^ Optional rescaling in [0,1] x [0,1]+  -> V2 a             -- ^ Optional shift+  -> LabeledPoint l a -- ^ Initial `LabeledPoint`+  -> LabeledPoint l a+moveLabeledPointV2Frames from to mopt vopt lp = moveLabeledPointV2 vmove lp   where-    mm = diagMat2 (width to) (height to)-    vo = v2fromPoint (_fpmin to)-    vmove = (mm #> v2fromPoint p) ^+^ vo+    vlp = v2fromPoint $ _lp lp -- vector associated with starting point+    vmove = frameToFrame from to mopt vopt vlp -- frame translation vector  --- * HasFrame : things which have a bounding box -class HasFrame v where-  type UnitInterval v :: *-  type FrameType v :: *-  fromFrame :: v -> UnitInterval v-  toFrame :: UnitInterval v -> v +-- -- * HasFrame : things which have a bounding box +-- class HasFrame v where+--   type UnitInterval v :: *+--   type FrameType v :: *+--   fromFrame :: v -> UnitInterval v+--   toFrame :: UnitInterval v -> v  + -- | X-aligned unit vector e1 :: Num a => V2 a e1 = V2 1 0@@ -271,6 +328,3 @@   --- class Located v where---   type Coords v :: *---   position :: v -> Coords v

@@ -1,45 +1,90 @@+{-# language OverloadedStrings #-}+{-# language FlexibleContexts #-} module Graphics.Rendering.Plot.Light.PlotTypes.TimeSeries where  import GHC.Real import Data.Fixed (Pico) import Data.Time+import Data.Scientific+ import qualified Data.Text as T  import Graphics.Rendering.Plot.Light.Internal-import Data.TimeSeries.Forex+import Data.TimeSeries +-- For debugging+import Text.Blaze.Svg+import qualified Data.Colour as C+import qualified Data.Colour.Names as C+import Text.Blaze.Svg.Renderer.String (renderSvg) + -- | Compute the plotting coordinates of a timeseries point  -- | Preprocess the dataset for plotting  -- 1. Remap the figure data to fit within the FigData ranges, expressed in pixels -- 2. Flip the data along the y axis since the origin in SVG is the top-left corner of the screen +-- tsAxis :: (Num a, LinearMap (DiagMat2 a) (V2 a), RealFrac a, Show a,+--                    Foldable t, Functor t) =>+--                   (a -> a)+--                   -> a+--                   -> a+--                   -> a+--                   -> C.Colour Double+--                   -> a+--                   -> t (TsPoint a)+--                   -> Svg+tsAxis fval wFig hFig sw col rot ps = dat' -- axis origin X wFig sw col 0.01 Continuous rot TAEnd T.pack (V2 (-10) 0) dat'+  where+    lpFun = tspToLP fval (\t _ -> show t)+    dat = lpFun <$> ps+    frameFrom = frameFromDataset dat+    frameTo = mkFrameOrigin wFig hFig+    dat' = moveLabeledPointV2Frames frameFrom frameTo (mempty :: DiagMat2 Scientific) (V2 0 0) <$> dat    --- * Helpers+nth xss n = reverse $ go xss n [] where+  go (_:xs) i l | i>0  = go xs (i-1) l+  go (x:xs) i l | i==0 = go xs n (x : l)+  go [] _ l = l --- | Create a Tick from valid (year, month, day, hour, minute, second)-mkTick :: Integer -> Int -> Int -> Int -> Int -> Pico -> Maybe Tick-mkTick yy mm dd hr mi se = do-   tim <- makeTimeOfDayValid hr mi se-   let d = fromGregorian yy mm dd-   return $ Tick d tim +   +-- * Helpers -tspToTuple :: (a -> b) -> TsPoint a -> (Float, b)-tspToTuple f tsp = (tickToFloat tsp, f $ _val tsp)+-- | Create a `LabeledPoint` from a time series point (`TsPoint`). The `_tick` (time axis) field will be used for the x coordinate, whereas both fields of TsPoint may be used to create the label field.+--+-- NB : The coordinates of the resulting LabelPoint still live in the original data space; they must be rescaled to fit in the figure viewport+tspToLP :: Fractional a => +     (t -> a)+  -> (Tick -> t -> l)+  -> TsPoint t+  -> LabeledPoint l a+tspToLP fy g = LabeledPoint <$> pf <*> lf where+  pf = Point <$> tickToFractional <*> fy . _val+  lf = g <$> _tick <*> _val   -tickToFloat :: TsPoint a -> Float-tickToFloat = fromRational . fromTick . _tick+  +tickToFractional :: Fractional b => TsPoint a -> b+tickToFractional = fromRational . fromTick . _tick  -- | Map a Tick onto the rationals fromTick :: Tick -> Rational fromTick (Tick d t) = fromIntegral (toModifiedJulianDay d) + timeOfDayToDayFraction t      ++++-- | Create a Tick from valid (year, month, day, hour, minute, second)+mkTick :: Integer -> Int -> Int -> Int -> Int -> Pico -> Maybe Tick+mkTick yy mm dd hr mi se = do+   tim <- makeTimeOfDayValid hr mi se+   let d = fromGregorian yy mm dd+   return $ Tick d tim  

@@ -0,0 +1,129 @@+{-# language FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}+module LibSpec where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Graphics.Rendering.Plot.Light++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  describe "Graphics.Rendering.Plot.Light" $ do+    -- it "works" $ +    --   True `shouldBe` True+    prop "V2 : additive group [Float]" $ \(v :: V2r Float) ->+      prop_V2_additiveGroup v `shouldBe` True+    prop "V2 : additive group [Double]" $ \(v :: V2 Double) ->+      prop_V2_additiveGroup v `shouldBe` True+    prop "Mat2 : multiplicative group [Float]: m <\\> (m #> v) ~= v" $+      \(PropDiagMatVec (m :: DiagMat2r Float) v ) -> prop_multMatGroup m v `shouldBe` True+    prop "Mat2 : multiplicative group [Double]: m <\\> (m #> v) ~= v" $+      \(PropDiagMatVec (m :: DiagMat2r Double) v ) -> prop_multMatGroup m v `shouldBe` True+    it "Frame : frameToFrame works" $ do+      let from = Frame (Point 5 1) (Point 8 3) :: Frame Double+          to = Frame (Point 1 2) (Point 4 4)+          v1 = v2fromPoint $ Point 7 2+          mopt = diagMat2 1 1 :: DiagMat2 Double+          vopt = V2 0 0 +          v2 = frameToFrame from to mopt vopt v1+          p2 = movePoint v2 origin+      -- p2 `shouldBe` Point 3 3+      norm2 (p2 -. Point 3 3) ~= 0 `shouldBe` True+      +++++++++++-- * Properties++prop_V2_additiveGroup+  :: (Eps v, VectorSpace v, Num (Scalar v)) => v -> Bool+prop_V2_additiveGroup v =+  v ^+^ zero ~= v  &&+  (v ^+^ v) ~= (2 .* v) &&+  (v ^-^ v) ~= zero++prop_multMatGroup :: (MatrixGroup m v, Eps v) => m -> v -> Bool+prop_multMatGroup m v = m <\> (m #> v) ~= v+++++data PropMatVec a = PropMatVec (Mat2r a) (V2r a) deriving (Eq, Show)+instance Arbitrary (PropMatVec Float) where+  arbitrary = PropMatVec <$> arbitrary <*> arbitrary++data PropDiagMatVec a = PropDiagMatVec (DiagMat2r a) (V2r a) deriving (Eq, Show)+instance Arbitrary (PropDiagMatVec Float) where+  arbitrary = PropDiagMatVec <$> arbitrary <*> arbitrary++instance Arbitrary (PropDiagMatVec Double) where+  arbitrary = PropDiagMatVec <$> arbitrary <*> arbitrary++++++-- * Newtypes and their Arbitrary instances+++-- | Float+type V2r a = V2 a+type Mat2r a = Mat2 a+type DiagMat2r a = DiagMat2 a++instance Arbitrary (V2r Float) where+  arbitrary = genV2++instance Arbitrary (Mat2r Float) where+  arbitrary = genMat2++instance Arbitrary (DiagMat2r Float) where+  arbitrary = genDiagMat2nz+++-- | Double+instance Arbitrary (V2r Double) where+  arbitrary = genV2++instance Arbitrary (Mat2r Double) where+  arbitrary = genMat2++instance Arbitrary (DiagMat2r Double) where+  arbitrary = genDiagMat2nz++++++-- helpers++sized2 :: (Int -> Int -> Gen a) -> Gen a+sized2 f = sized $ \i -> sized $ \j -> f i j+++genV2 :: (Arbitrary a, Num a) => Gen (V2 a)+genV2 = V2 <$> arbitrary <*> arbitrary++genDiagMat2 :: (Arbitrary a, Num a) => Gen (DiagMat2 a)+genDiagMat2 = DMat2 <$> arbitrary <*> arbitrary++genDiagMat2nz :: (Num a, Arbitrary a, Ord a) => Gen (DiagMat2 a)+genDiagMat2nz = do+  d1 <- arbitrary `suchThat` (> 0)+  d2 <- arbitrary `suchThat` (> 0)  +  pure (DMat2 d1 d2)++genMat2 :: (Arbitrary a, Num a) => Gen (Mat2 a)+genMat2 = Mat2 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+