{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Graphics.Rendering.Chart.Plot.Vectors(
PlotVectors(..),
VectorStyle(..),
plotVectorField,
plot_vectors_mapf,
plot_vectors_grid,
plot_vectors_title,
plot_vectors_style,
plot_vectors_scale,
plot_vectors_values,
vector_line_style,
vector_head_style,
) where
import Control.Lens
import Control.Monad
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Data.Tuple
import Data.Colour hiding (over)
import Data.Colour.Names
import Data.Default.Class
import Graphics.Rendering.Chart.Axis
import Graphics.Rendering.Chart.Drawing
import Graphics.Rendering.Chart.Geometry
import Graphics.Rendering.Chart.Plot.Types
data VectorStyle = VectorStyle
{ VectorStyle -> LineStyle
_vector_line_style :: LineStyle
, VectorStyle -> PointStyle
_vector_head_style :: PointStyle
}
$( makeLenses ''VectorStyle )
data PlotVectors x y = PlotVectors
{ PlotVectors x y -> String
_plot_vectors_title :: String
, PlotVectors x y -> VectorStyle
_plot_vectors_style :: VectorStyle
, PlotVectors x y -> Double
_plot_vectors_scale :: Double
, PlotVectors x y -> [(x, y)]
_plot_vectors_grid :: [(x,y)]
, PlotVectors x y -> (x, y) -> (x, y)
_plot_vectors_mapf :: (x,y) -> (x,y)
, PlotVectors x y -> [((x, y), (x, y))]
_plot_vectors_values :: [((x,y),(x,y))]
}
$( makeLenses ''PlotVectors )
mapGrid :: (PlotValue y, PlotValue x)
=> [(x,y)] -> ((x,y) -> (x,y)) -> [((x,y),(x,y))]
mapGrid :: [(x, y)] -> ((x, y) -> (x, y)) -> [((x, y), (x, y))]
mapGrid [(x, y)]
grid (x, y) -> (x, y)
f = [(x, y)] -> [(x, y)] -> [((x, y), (x, y))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(x, y)]
grid ((x, y) -> (x, y)
f ((x, y) -> (x, y)) -> [(x, y)] -> [(x, y)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(x, y)]
grid)
plotVectorField :: (PlotValue x, PlotValue y) => PlotVectors x y -> Plot x y
plotVectorField :: PlotVectors x y -> Plot x y
plotVectorField PlotVectors x y
pv = Plot :: forall x y.
(PointMapFn x y -> BackendProgram ())
-> [(String, Rect -> BackendProgram ())] -> ([x], [y]) -> Plot x y
Plot
{ _plot_render :: PointMapFn x y -> BackendProgram ()
_plot_render = PlotVectors x y -> PointMapFn x y -> BackendProgram ()
forall x y.
(PlotValue x, PlotValue y) =>
PlotVectors x y -> PointMapFn x y -> BackendProgram ()
renderPlotVectors PlotVectors x y
pv
, _plot_legend :: [(String, Rect -> BackendProgram ())]
_plot_legend = [(PlotVectors x y -> String
forall x y. PlotVectors x y -> String
_plot_vectors_title PlotVectors x y
pv, PlotVectors x y -> Rect -> BackendProgram ()
forall x y.
(PlotValue x, PlotValue y) =>
PlotVectors x y -> Rect -> BackendProgram ()
renderPlotLegendVectors PlotVectors x y
pv)]
, _plot_all_points :: ([x], [y])
_plot_all_points = (((x, y) -> x) -> [(x, y)] -> [x]
forall a b. (a -> b) -> [a] -> [b]
map (x, y) -> x
forall a b. (a, b) -> a
fst [(x, y)]
pts, ((x, y) -> y) -> [(x, y)] -> [y]
forall a b. (a -> b) -> [a] -> [b]
map (x, y) -> y
forall a b. (a, b) -> b
snd [(x, y)]
pts)
}
where
pvals :: [((x, y), (x, y))]
pvals = PlotVectors x y -> [((x, y), (x, y))]
forall x y. PlotVectors x y -> [((x, y), (x, y))]
_plot_vectors_values PlotVectors x y
pv
mvals :: [((x, y), (x, y))]
mvals = [(x, y)] -> ((x, y) -> (x, y)) -> [((x, y), (x, y))]
forall y x.
(PlotValue y, PlotValue x) =>
[(x, y)] -> ((x, y) -> (x, y)) -> [((x, y), (x, y))]
mapGrid (PlotVectors x y -> [(x, y)]
forall x y. PlotVectors x y -> [(x, y)]
_plot_vectors_grid PlotVectors x y
pv) (PlotVectors x y -> (x, y) -> (x, y)
forall x y. PlotVectors x y -> (x, y) -> (x, y)
_plot_vectors_mapf PlotVectors x y
pv)
pts :: [(x, y)]
pts = (((x, y), (x, y)) -> [(x, y)]) -> [((x, y), (x, y))] -> [(x, y)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\((x, y)
a,(x, y)
b) -> [(x, y)
a,(x, y)
b]) ([((x, y), (x, y))]
pvals [((x, y), (x, y))] -> [((x, y), (x, y))] -> [((x, y), (x, y))]
forall a. [a] -> [a] -> [a]
++ [((x, y), (x, y))]
mvals)
renderPlotVectors :: (PlotValue x, PlotValue y)
=> PlotVectors x y -> PointMapFn x y -> BackendProgram ()
renderPlotVectors :: PlotVectors x y -> PointMapFn x y -> BackendProgram ()
renderPlotVectors PlotVectors x y
pv PointMapFn x y
pmap = do
let pvals :: [((x, y), (x, y))]
pvals = PlotVectors x y -> [((x, y), (x, y))]
forall x y. PlotVectors x y -> [((x, y), (x, y))]
_plot_vectors_values PlotVectors x y
pv
mvals :: [((x, y), (x, y))]
mvals = [(x, y)] -> ((x, y) -> (x, y)) -> [((x, y), (x, y))]
forall y x.
(PlotValue y, PlotValue x) =>
[(x, y)] -> ((x, y) -> (x, y)) -> [((x, y), (x, y))]
mapGrid (PlotVectors x y -> [(x, y)]
forall x y. PlotVectors x y -> [(x, y)]
_plot_vectors_grid PlotVectors x y
pv) (PlotVectors x y -> (x, y) -> (x, y)
forall x y. PlotVectors x y -> (x, y) -> (x, y)
_plot_vectors_mapf PlotVectors x y
pv)
trans :: [((x, y), (x, y))]
trans = ((x, y), (x, y)) -> ((x, y), (x, y))
forall a a a b a a.
(PlotValue a, PlotValue a, PlotValue a, PlotValue b, PlotValue a,
PlotValue a) =>
((a, a), (a, a)) -> ((a, a), (a, b))
translateToStart (((x, y), (x, y)) -> ((x, y), (x, y)))
-> [((x, y), (x, y))] -> [((x, y), (x, y))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([((x, y), (x, y))]
pvals [((x, y), (x, y))] -> [((x, y), (x, y))] -> [((x, y), (x, y))]
forall a. [a] -> [a] -> [a]
++ [((x, y), (x, y))]
mvals)
pvecs :: [(Point, Point)]
pvecs = ((Point, Point) -> Bool) -> [(Point, Point)] -> [(Point, Point)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Point, Point)
v -> (Point, Point) -> Double
vlen' (Point, Point)
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) ([(Point, Point)] -> [(Point, Point)])
-> [(Point, Point)] -> [(Point, Point)]
forall a b. (a -> b) -> a -> b
$ ASetter ((x, y), (x, y)) (Point, Point) (x, y) Point
-> ((x, y) -> Point) -> ((x, y), (x, y)) -> (Point, Point)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ((x, y), (x, y)) (Point, Point) (x, y) Point
forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (PointMapFn x y -> (x, y) -> Point
forall x y. PointMapFn x y -> (x, y) -> Point
mapXY PointMapFn x y
pmap) (((x, y), (x, y)) -> (Point, Point))
-> [((x, y), (x, y))] -> [(Point, Point)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((x, y), (x, y))]
trans
mgrid :: [Point]
mgrid = Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take Int
2 ([Point] -> [Point]) -> [Point] -> [Point]
forall a b. (a -> b) -> a -> b
$ (Point, Point) -> Point
forall a b. (a, b) -> a
fst ((Point, Point) -> Point) -> [(Point, Point)] -> [Point]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Point)]
pvecs
maxLen :: Double
maxLen = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Point, Point) -> Double
vlen' ((Point, Point) -> Double) -> [(Point, Point)] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Point)]
pvecs
spacing :: Double
spacing = ([Double] -> Int -> Double
forall a. [a] -> Int -> a
!!Int
1) ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Vector -> Double
vlen (Vector -> Double) -> [Vector] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point -> Point -> Vector) -> [Point] -> [Point] -> [Vector]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Point -> Point -> Vector
psub [Point]
mgrid ([Point] -> [Point]
forall a. [a] -> [a]
reverse [Point]
mgrid)) [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double
maxLen]
sfactor :: Double
sfactor = Double
spacingDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
maxLen
afactor :: Double
afactor = Double
sfactor Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
sfactor)Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- PlotVectors x y -> Double
forall x y. PlotVectors x y -> Double
_plot_vectors_scale PlotVectors x y
pv)
tails :: [(Point, Point)]
tails = Double -> (Point, Point) -> (Point, Point)
pscale Double
afactor ((Point, Point) -> (Point, Point))
-> [(Point, Point)] -> [(Point, Point)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Point)]
pvecs
angles :: [Double]
angles = (Vector -> Double
vangle (Vector -> Double)
-> ((Point, Point) -> Vector) -> (Point, Point) -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Point) -> Vector
psub' ((Point, Point) -> Vector)
-> ((Point, Point) -> (Point, Point)) -> (Point, Point) -> Vector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Point) -> (Point, Point)
forall a b. (a, b) -> (b, a)
swap) ((Point, Point) -> Double) -> [(Point, Point)] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Point)]
pvecs
centers :: [Point]
centers = (Point, Point) -> Point
forall a b. (a, b) -> b
snd ((Point, Point) -> Point) -> [(Point, Point)] -> [Point]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Point, Point)]
tails
((Point, Point) -> BackendProgram ())
-> [(Point, Point)] -> BackendProgram ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Double -> (Point, Point) -> BackendProgram ()
drawTail Double
radius) [(Point, Point)]
tails
(Point -> Double -> BackendProgram ())
-> [Point] -> [Double] -> BackendProgram ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Double -> Point -> Double -> BackendProgram ()
drawArrowHead Double
radius) [Point]
centers [Double]
angles
where
psub' :: (Point, Point) -> Vector
psub' = (Point -> Point -> Vector) -> (Point, Point) -> Vector
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Point -> Point -> Vector
psub
vlen' :: (Point, Point) -> Double
vlen' = Vector -> Double
vlen (Vector -> Double)
-> ((Point, Point) -> Vector) -> (Point, Point) -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Point) -> Vector
psub'
pvs :: VectorStyle
pvs = PlotVectors x y -> VectorStyle
forall x y. PlotVectors x y -> VectorStyle
_plot_vectors_style PlotVectors x y
pv
radius :: Double
radius = PointStyle -> Double
_point_radius (PointStyle -> Double) -> PointStyle -> Double
forall a b. (a -> b) -> a -> b
$ VectorStyle -> PointStyle
_vector_head_style VectorStyle
pvs
hs :: Double -> PointStyle
hs Double
angle = VectorStyle -> PointStyle
_vector_head_style VectorStyle
pvs PointStyle -> (PointStyle -> PointStyle) -> PointStyle
forall a b. a -> (a -> b) -> b
& (PointShape -> Identity PointShape)
-> PointStyle -> Identity PointStyle
Lens' PointStyle PointShape
point_shape
((PointShape -> Identity PointShape)
-> PointStyle -> Identity PointStyle)
-> (PointShape -> PointShape) -> PointStyle -> PointStyle
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\(PointShapeArrowHead Double
a) -> Double -> PointShape
PointShapeArrowHead (Double -> PointShape) -> Double -> PointShape
forall a b. (a -> b) -> a -> b
$ Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
angle)
translateToStart :: ((a, a), (a, a)) -> ((a, a), (a, b))
translateToStart (s :: (a, a)
s@(a
x,a
y),(a
vx,a
vy)) = ((a, a)
s,(a -> a -> a
forall a a a.
(PlotValue a, PlotValue a, PlotValue a) =>
a -> a -> a
tr a
x a
vx,a -> a -> b
forall a a a.
(PlotValue a, PlotValue a, PlotValue a) =>
a -> a -> a
tr a
y a
vy))
where tr :: a -> a -> a
tr a
p a
t = Double -> a
forall a. PlotValue a => Double -> a
fromValue (Double -> a) -> Double -> a
forall a b. (a -> b) -> a -> b
$ a -> Double
forall a. PlotValue a => a -> Double
toValue a
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ a -> Double
forall a. PlotValue a => a -> Double
toValue a
t
pscale :: Double -> (Point, Point) -> (Point, Point)
pscale Double
w v :: (Point, Point)
v@(Point
s,Point
_) = (Point
s,Vector -> Point -> Point
translateP (Double -> Vector -> Vector
vscale Double
w (Vector -> Vector)
-> ((Point, Point) -> Vector) -> (Point, Point) -> Vector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point, Point) -> Vector
psub' ((Point, Point) -> Vector) -> (Point, Point) -> Vector
forall a b. (a -> b) -> a -> b
$ (Point, Point) -> (Point, Point)
forall a b. (a, b) -> (b, a)
swap (Point, Point)
v) Point
s)
drawTail :: Double -> (Point, Point) -> BackendProgram ()
drawTail Double
r (Point, Point)
v = LineStyle -> BackendProgram () -> BackendProgram ()
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle (VectorStyle -> LineStyle
_vector_line_style VectorStyle
pvs) (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$
[Point] -> BackendProgram ()
strokePointPath ([Point] -> BackendProgram ()) -> [Point] -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ ((Point, Point)
-> Getting (Endo [Point]) (Point, Point) Point -> [Point]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^..Getting (Endo [Point]) (Point, Point) Point
forall s t a b. Each s t a b => Traversal s t a b
each) (Point, Point)
v'
where
v' :: (Point, Point)
v' = Double -> (Point, Point) -> (Point, Point)
pscale (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
rDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
l) (Point, Point)
v
l :: Double
l = (Point, Point) -> Double
vlen' (Point, Point)
v
drawArrowHead :: Double -> Point -> Double -> BackendProgram ()
drawArrowHead Double
r (Point Double
x Double
y) Double
theta =
Point -> BackendProgram () -> BackendProgram ()
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point (-Double
rDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double -> Double
forall a. Floating a => a -> a
cos Double
theta) (-Double
rDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double -> Double
forall a. Floating a => a -> a
sin Double
theta))
(PointStyle -> Point -> BackendProgram ()
drawPoint (Double -> PointStyle
hs Double
theta) (Double -> Double -> Point
Point Double
x Double
y))
renderPlotLegendVectors :: (PlotValue x, PlotValue y)
=> PlotVectors x y -> Rect -> BackendProgram ()
renderPlotLegendVectors :: PlotVectors x y -> Rect -> BackendProgram ()
renderPlotLegendVectors PlotVectors x y
pv (Rect Point
p1 Point
p2) = do
let y :: Double
y = (Point -> Double
p_y Point
p1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Point -> Double
p_y Point
p2)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
pv' :: PlotVectors x y
pv' = ([(x, y)] -> Identity [(x, y)])
-> PlotVectors x y -> Identity (PlotVectors x y)
forall x y. Lens' (PlotVectors x y) [(x, y)]
plot_vectors_grid (([(x, y)] -> Identity [(x, y)])
-> PlotVectors x y -> Identity (PlotVectors x y))
-> [(x, y)] -> PlotVectors x y -> PlotVectors x y
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
(PlotVectors x y -> PlotVectors x y)
-> PlotVectors x y -> PlotVectors x y
forall a b. (a -> b) -> a -> b
$ ([((x, y), (x, y))] -> Identity [((x, y), (x, y))])
-> PlotVectors x y -> Identity (PlotVectors x y)
forall x y. Lens' (PlotVectors x y) [((x, y), (x, y))]
plot_vectors_values (([((x, y), (x, y))] -> Identity [((x, y), (x, y))])
-> PlotVectors x y -> Identity (PlotVectors x y))
-> [((x, y), (x, y))] -> PlotVectors x y -> PlotVectors x y
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [((Double -> x
forall a. PlotValue a => Double -> a
fromValue (Double -> x) -> Double -> x
forall a b. (a -> b) -> a -> b
$ Point -> Double
p_x Point
p1, Double -> y
forall a. PlotValue a => Double -> a
fromValue Double
y),
(Double -> x
forall a. PlotValue a => Double -> a
fromValue (Double -> x) -> Double -> x
forall a b. (a -> b) -> a -> b
$ Point -> Double
p_x Point
p2, Double -> y
forall a. PlotValue a => Double -> a
fromValue Double
0))]
(PlotVectors x y -> PlotVectors x y)
-> PlotVectors x y -> PlotVectors x y
forall a b. (a -> b) -> a -> b
$ PlotVectors x y
pv
PlotVectors x y -> PointMapFn x y -> BackendProgram ()
forall x y.
(PlotValue x, PlotValue y) =>
PlotVectors x y -> PointMapFn x y -> BackendProgram ()
renderPlotVectors PlotVectors x y
pv' PointMapFn x y
forall a a.
(PlotValue a, PlotValue a) =>
(Limit a, Limit a) -> Point
pmap
where
pmap :: (Limit a, Limit a) -> Point
pmap (LValue a
x,LValue a
y) = Double -> Double -> Point
Point (a -> Double
forall a. PlotValue a => a -> Double
toValue a
x) (a -> Double
forall a. PlotValue a => a -> Double
toValue a
y)
pmap (Limit a, Limit a)
_ = Double -> Double -> Point
Point Double
0 Double
0
instance Default VectorStyle where
def :: VectorStyle
def = VectorStyle :: LineStyle -> PointStyle -> VectorStyle
VectorStyle
{ _vector_line_style :: LineStyle
_vector_line_style = (Double -> AlphaColour Double -> LineStyle
solidLine Double
lw (AlphaColour Double -> LineStyle)
-> AlphaColour Double -> LineStyle
forall a b. (a -> b) -> a -> b
$ Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque Colour Double
forall a. (Ord a, Floating a) => Colour a
blue)
{ _line_cap :: LineCap
_line_cap = LineCap
LineCapSquare }
, _vector_head_style :: PointStyle
_vector_head_style = AlphaColour Double
-> AlphaColour Double
-> Double
-> Double
-> PointShape
-> PointStyle
PointStyle (Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque Colour Double
forall a. (Ord a, Floating a) => Colour a
red) AlphaColour Double
forall a. Num a => AlphaColour a
transparent Double
lw (Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
lw)
(Double -> PointShape
PointShapeArrowHead Double
0)
} where lw :: Double
lw = Double
2
instance Default (PlotVectors x y) where
def :: PlotVectors x y
def = PlotVectors :: forall x y.
String
-> VectorStyle
-> Double
-> [(x, y)]
-> ((x, y) -> (x, y))
-> [((x, y), (x, y))]
-> PlotVectors x y
PlotVectors
{ _plot_vectors_title :: String
_plot_vectors_title = String
""
, _plot_vectors_style :: VectorStyle
_plot_vectors_style = VectorStyle
forall a. Default a => a
def
, _plot_vectors_scale :: Double
_plot_vectors_scale = Double
1
, _plot_vectors_grid :: [(x, y)]
_plot_vectors_grid = []
, _plot_vectors_mapf :: (x, y) -> (x, y)
_plot_vectors_mapf = (x, y) -> (x, y)
forall a. a -> a
id
, _plot_vectors_values :: [((x, y), (x, y))]
_plot_vectors_values = []
}