{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
module Graphics.Rendering.Chart.Renderable(
Renderable(..),
ToRenderable(..),
PickFn,
Rectangle(..),
RectCornerStyle(..),
rectangleToRenderable,
drawRectangle,
fillBackground,
addMargins,
emptyRenderable,
embedRenderable,
label,
rlabel,
spacer,
spacer1,
setPickFn,
mapMaybePickFn,
mapPickFn,
nullPickFn,
rect_minsize,
rect_fillStyle,
rect_lineStyle,
rect_cornerStyle,
) where
import Control.Monad
import Control.Lens
import Data.Default.Class
import Graphics.Rendering.Chart.Geometry
import Graphics.Rendering.Chart.Drawing
import Graphics.Rendering.Chart.Utils
type PickFn a = Point -> Maybe a
nullPickFn :: PickFn a
nullPickFn :: forall a. PickFn a
nullPickFn = forall a b. a -> b -> a
const forall a. Maybe a
Nothing
data Renderable a = Renderable {
forall a. Renderable a -> BackendProgram RectSize
minsize :: BackendProgram RectSize,
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render :: RectSize -> BackendProgram (PickFn a)
}
deriving (forall a b. a -> Renderable b -> Renderable a
forall a b. (a -> b) -> Renderable a -> Renderable b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Renderable b -> Renderable a
$c<$ :: forall a b. a -> Renderable b -> Renderable a
fmap :: forall a b. (a -> b) -> Renderable a -> Renderable b
$cfmap :: forall a b. (a -> b) -> Renderable a -> Renderable b
Functor)
class ToRenderable a where
toRenderable :: a -> Renderable ()
instance ToRenderable (Renderable a) where
toRenderable :: Renderable a -> Renderable ()
toRenderable = forall (f :: * -> *) a. Functor f => f a -> f ()
void
emptyRenderable :: Renderable a
emptyRenderable :: forall a. Renderable a
emptyRenderable = forall a. RectSize -> Renderable a
spacer (Double
0,Double
0)
spacer :: RectSize -> Renderable a
spacer :: forall a. RectSize -> Renderable a
spacer RectSize
sz = Renderable {
minsize :: BackendProgram RectSize
minsize = forall (m :: * -> *) a. Monad m => a -> m a
return RectSize
sz,
render :: RectSize -> BackendProgram (PickFn a)
render = \RectSize
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PickFn a
nullPickFn
}
spacer1 :: Renderable a -> Renderable b
spacer1 :: forall a b. Renderable a -> Renderable b
spacer1 Renderable a
r = Renderable a
r{ render :: RectSize -> BackendProgram (PickFn b)
render = \RectSize
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PickFn a
nullPickFn }
setPickFn :: PickFn b -> Renderable a -> Renderable b
setPickFn :: forall b a. PickFn b -> Renderable a -> Renderable b
setPickFn PickFn b
pickfn Renderable a
r = Renderable a
r{ render :: RectSize -> BackendProgram (PickFn b)
render = \RectSize
sz -> forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r RectSize
sz forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return PickFn b
pickfn }
mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b
mapMaybePickFn :: forall a b. (a -> Maybe b) -> Renderable a -> Renderable b
mapMaybePickFn a -> Maybe b
f Renderable a
r = Renderable a
r{ render :: RectSize -> BackendProgram (PickFn b)
render = \RectSize
sz -> do PickFn a
pf <- forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r RectSize
sz
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. PickFn a
pf) }
mapPickFn :: (a -> b) -> Renderable a -> Renderable b
mapPickFn :: forall a b. (a -> b) -> Renderable a -> Renderable b
mapPickFn a -> b
f = forall a b. (a -> Maybe b) -> Renderable a -> Renderable b
mapMaybePickFn (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)
addMargins :: (Double,Double,Double,Double)
-> Renderable a
-> Renderable a
addMargins :: forall a.
(Double, Double, Double, Double) -> Renderable a -> Renderable a
addMargins (Double
t,Double
b,Double
l,Double
r) Renderable a
rd = Renderable { minsize :: BackendProgram RectSize
minsize = BackendProgram RectSize
mf, render :: RectSize -> BackendProgram (PickFn a)
render = RectSize -> BackendProgram (PickFn a)
rf }
where
mf :: BackendProgram RectSize
mf = do
(Double
w,Double
h) <- forall a. Renderable a -> BackendProgram RectSize
minsize Renderable a
rd
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
wforall a. Num a => a -> a -> a
+Double
lforall a. Num a => a -> a -> a
+Double
r,Double
hforall a. Num a => a -> a -> a
+Double
tforall a. Num a => a -> a -> a
+Double
b)
rf :: RectSize -> BackendProgram (PickFn a)
rf (Double
w,Double
h) =
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point Double
l Double
t) forall a b. (a -> b) -> a -> b
$ do
PickFn a
pickf <- forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
rd (Double
wforall a. Num a => a -> a -> a
-Double
lforall a. Num a => a -> a -> a
-Double
r,Double
hforall a. Num a => a -> a -> a
-Double
tforall a. Num a => a -> a -> a
-Double
b)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}.
(Point -> Maybe a)
-> (Double, Double, Double, Double) -> RectSize -> Point -> Maybe a
mkpickf PickFn a
pickf (Double
t,Double
b,Double
l,Double
r) (Double
w,Double
h))
mkpickf :: (Point -> Maybe a)
-> (Double, Double, Double, Double) -> RectSize -> Point -> Maybe a
mkpickf Point -> Maybe a
pickf (Double
t',Double
b',Double
l',Double
r') (Double
w,Double
h) (Point Double
x Double
y)
| Double
x forall a. Ord a => a -> a -> Bool
>= Double
l' Bool -> Bool -> Bool
&& Double
x forall a. Ord a => a -> a -> Bool
<= Double
wforall a. Num a => a -> a -> a
-Double
r' Bool -> Bool -> Bool
&& Double
y forall a. Ord a => a -> a -> Bool
>= Double
t' Bool -> Bool -> Bool
&& Double
t' forall a. Ord a => a -> a -> Bool
<= Double
hforall a. Num a => a -> a -> a
-Double
b' = Point -> Maybe a
pickf (Double -> Double -> Point
Point (Double
xforall a. Num a => a -> a -> a
-Double
l') (Double
yforall a. Num a => a -> a -> a
-Double
t'))
| Bool
otherwise = forall a. Maybe a
Nothing
fillBackground :: FillStyle -> Renderable a -> Renderable a
fillBackground :: forall a. FillStyle -> Renderable a -> Renderable a
fillBackground FillStyle
fs Renderable a
r = Renderable a
r{ render :: RectSize -> BackendProgram (PickFn a)
render = RectSize -> BackendProgram (PickFn a)
rf }
where
rf :: RectSize -> BackendProgram (PickFn a)
rf rsize :: RectSize
rsize@(Double
w,Double
h) = do
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle FillStyle
fs forall a b. (a -> b) -> a -> b
$ do
Path
p <- Path -> BackendProgram Path
alignFillPath forall a b. (a -> b) -> a -> b
$ Rect -> Path
rectPath (Point -> Point -> Rect
Rect (Double -> Double -> Point
Point Double
0 Double
0) (Double -> Double -> Point
Point Double
w Double
h))
Path -> BackendProgram ()
fillPath Path
p
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r RectSize
rsize
embedRenderable :: BackendProgram (Renderable a) -> Renderable a
embedRenderable :: forall a. BackendProgram (Renderable a) -> Renderable a
embedRenderable BackendProgram (Renderable a)
ca = Renderable {
minsize :: BackendProgram RectSize
minsize = do { Renderable a
a <- BackendProgram (Renderable a)
ca; forall a. Renderable a -> BackendProgram RectSize
minsize Renderable a
a },
render :: RectSize -> BackendProgram (PickFn a)
render = \ RectSize
r -> do { Renderable a
a <- BackendProgram (Renderable a)
ca; forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
a RectSize
r }
}
label :: FontStyle -> HTextAnchor -> VTextAnchor -> String -> Renderable String
label :: FontStyle
-> HTextAnchor -> VTextAnchor -> String -> Renderable String
label FontStyle
fs HTextAnchor
hta VTextAnchor
vta = FontStyle
-> HTextAnchor
-> VTextAnchor
-> Double
-> String
-> Renderable String
rlabel FontStyle
fs HTextAnchor
hta VTextAnchor
vta Double
0
rlabel :: FontStyle -> HTextAnchor -> VTextAnchor -> Double -> String -> Renderable String
rlabel :: FontStyle
-> HTextAnchor
-> VTextAnchor
-> Double
-> String
-> Renderable String
rlabel FontStyle
fs HTextAnchor
hta VTextAnchor
vta Double
rot String
s = Renderable { minsize :: BackendProgram RectSize
minsize = BackendProgram RectSize
mf, render :: RectSize -> BackendProgram (PickFn String)
render = forall {p}. RectSize -> BackendProgram (p -> Maybe String)
rf }
where
mf :: BackendProgram RectSize
mf = forall a. FontStyle -> BackendProgram a -> BackendProgram a
withFontStyle FontStyle
fs forall a b. (a -> b) -> a -> b
$ do
TextSize
ts <- String -> BackendProgram TextSize
textSize String
s
let sz :: RectSize
sz = (TextSize -> Double
textSizeWidth TextSize
ts, TextSize -> Double
textSizeHeight TextSize
ts)
forall (m :: * -> *) a. Monad m => a -> m a
return (RectSize -> Double
xwid RectSize
sz, RectSize -> Double
ywid RectSize
sz)
rf :: RectSize -> BackendProgram (p -> Maybe String)
rf (Double
w0,Double
h0) = forall a. FontStyle -> BackendProgram a -> BackendProgram a
withFontStyle FontStyle
fs forall a b. (a -> b) -> a -> b
$ do
TextSize
ts <- String -> BackendProgram TextSize
textSize String
s
let sz :: RectSize
sz@(Double
w,Double
h) = (TextSize -> Double
textSizeWidth TextSize
ts, TextSize -> Double
textSizeHeight TextSize
ts)
descent :: Double
descent = TextSize -> Double
textSizeDescent TextSize
ts
xadj :: HTextAnchor -> Double
xadj HTextAnchor
HTA_Left = RectSize -> Double
xwid RectSize
szforall a. Fractional a => a -> a -> a
/Double
2
xadj HTextAnchor
HTA_Centre = Double
w0forall a. Fractional a => a -> a -> a
/Double
2
xadj HTextAnchor
HTA_Right = Double
w0 forall a. Num a => a -> a -> a
- RectSize -> Double
xwid RectSize
szforall a. Fractional a => a -> a -> a
/Double
2
yadj :: VTextAnchor -> Double
yadj VTextAnchor
VTA_Top = RectSize -> Double
ywid RectSize
szforall a. Fractional a => a -> a -> a
/Double
2
yadj VTextAnchor
VTA_Centre = Double
h0forall a. Fractional a => a -> a -> a
/Double
2
yadj VTextAnchor
VTA_Bottom = Double
h0 forall a. Num a => a -> a -> a
- RectSize -> Double
ywid RectSize
szforall a. Fractional a => a -> a -> a
/Double
2
yadj VTextAnchor
VTA_BaseLine = Double
h0 forall a. Num a => a -> a -> a
- RectSize -> Double
ywid RectSize
szforall a. Fractional a => a -> a -> a
/Double
2 forall a. Num a => a -> a -> a
+ Double
descentforall a. Num a => a -> a -> a
*Double
acr
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point Double
0 (-Double
descent)) forall a b. (a -> b) -> a -> b
$
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point (HTextAnchor -> Double
xadj HTextAnchor
hta) (VTextAnchor -> Double
yadj VTextAnchor
vta)) forall a b. (a -> b) -> a -> b
$
forall a. Double -> BackendProgram a -> BackendProgram a
withRotation Double
rot' forall a b. (a -> b) -> a -> b
$ do
Point -> String -> BackendProgram ()
drawText (Double -> Double -> Point
Point (-Double
wforall a. Fractional a => a -> a -> a
/Double
2) (Double
hforall a. Fractional a => a -> a -> a
/Double
2)) String
s
forall (m :: * -> *) a. Monad m => a -> m a
return (\p
_-> forall a. a -> Maybe a
Just String
s)
rot' :: Double
rot' = Double
rot forall a. Fractional a => a -> a -> a
/ Double
180 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi
(Double
cr,Double
sr) = (forall a. Floating a => a -> a
cos Double
rot', forall a. Floating a => a -> a
sin Double
rot')
(Double
acr,Double
asr) = (forall a. Num a => a -> a
abs Double
cr, forall a. Num a => a -> a
abs Double
sr)
xwid :: RectSize -> Double
xwid (Double
w,Double
h) = Double
wforall a. Num a => a -> a -> a
*Double
acr forall a. Num a => a -> a -> a
+ Double
hforall a. Num a => a -> a -> a
*Double
asr
ywid :: RectSize -> Double
ywid (Double
w,Double
h) = Double
wforall a. Num a => a -> a -> a
*Double
asr forall a. Num a => a -> a -> a
+ Double
hforall a. Num a => a -> a -> a
*Double
acr
data RectCornerStyle = RCornerSquare
| RCornerBevel Double
| RCornerRounded Double
data Rectangle = Rectangle {
Rectangle -> RectSize
_rect_minsize :: RectSize,
Rectangle -> Maybe FillStyle
_rect_fillStyle :: Maybe FillStyle,
Rectangle -> Maybe LineStyle
_rect_lineStyle :: Maybe LineStyle,
Rectangle -> RectCornerStyle
_rect_cornerStyle :: RectCornerStyle
}
instance Default Rectangle where
def :: Rectangle
def = Rectangle
{ _rect_minsize :: RectSize
_rect_minsize = (Double
0,Double
0)
, _rect_fillStyle :: Maybe FillStyle
_rect_fillStyle = forall a. Maybe a
Nothing
, _rect_lineStyle :: Maybe LineStyle
_rect_lineStyle = forall a. Maybe a
Nothing
, _rect_cornerStyle :: RectCornerStyle
_rect_cornerStyle = RectCornerStyle
RCornerSquare
}
instance ToRenderable Rectangle where
toRenderable :: Rectangle -> Renderable ()
toRenderable = forall a. Rectangle -> Renderable a
rectangleToRenderable
rectangleToRenderable :: Rectangle -> Renderable a
rectangleToRenderable :: forall a. Rectangle -> Renderable a
rectangleToRenderable Rectangle
rectangle = forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
Renderable BackendProgram RectSize
mf forall {a}. RectSize -> BackendProgram (PickFn a)
rf
where
mf :: BackendProgram RectSize
mf = forall (m :: * -> *) a. Monad m => a -> m a
return (Rectangle -> RectSize
_rect_minsize Rectangle
rectangle)
rf :: RectSize -> BackendProgram (PickFn a)
rf = \RectSize
rectSize -> forall a. Point -> Rectangle -> BackendProgram (PickFn a)
drawRectangle (Double -> Double -> Point
Point Double
0 Double
0)
Rectangle
rectangle{ _rect_minsize :: RectSize
_rect_minsize = RectSize
rectSize }
drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)
drawRectangle :: forall a. Point -> Rectangle -> BackendProgram (PickFn a)
drawRectangle Point
point Rectangle
rectangle = do
forall (m :: * -> *) b a.
Monad m =>
b -> (a -> m b) -> Maybe a -> m b
maybeM () (Point -> RectSize -> FillStyle -> BackendProgram ()
fill Point
point RectSize
size) (Rectangle -> Maybe FillStyle
_rect_fillStyle Rectangle
rectangle)
forall (m :: * -> *) b a.
Monad m =>
b -> (a -> m b) -> Maybe a -> m b
maybeM () (Point -> RectSize -> LineStyle -> BackendProgram ()
stroke Point
point RectSize
size) (Rectangle -> Maybe LineStyle
_rect_lineStyle Rectangle
rectangle)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PickFn a
nullPickFn
where
size :: RectSize
size = Rectangle -> RectSize
_rect_minsize Rectangle
rectangle
fill :: Point -> RectSize -> FillStyle -> BackendProgram ()
fill Point
p RectSize
sz FillStyle
fs =
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle FillStyle
fs forall a b. (a -> b) -> a -> b
$
Path -> BackendProgram ()
fillPath forall a b. (a -> b) -> a -> b
$ Point -> RectSize -> RectCornerStyle -> Path
strokeRectangleP Point
p RectSize
sz (Rectangle -> RectCornerStyle
_rect_cornerStyle Rectangle
rectangle)
stroke :: Point -> RectSize -> LineStyle -> BackendProgram ()
stroke Point
p RectSize
sz LineStyle
ls =
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle LineStyle
ls forall a b. (a -> b) -> a -> b
$
Path -> BackendProgram ()
strokePath forall a b. (a -> b) -> a -> b
$ Point -> RectSize -> RectCornerStyle -> Path
strokeRectangleP Point
p RectSize
sz (Rectangle -> RectCornerStyle
_rect_cornerStyle Rectangle
rectangle)
strokeRectangleP :: Point -> RectSize -> RectCornerStyle -> Path
strokeRectangleP (Point Double
x1 Double
y1) (Double
x2,Double
y2) RectCornerStyle
RCornerSquare =
let (Double
x3,Double
y3) = (Double
x1forall a. Num a => a -> a -> a
+Double
x2,Double
y1forall a. Num a => a -> a -> a
+Double
y2) in Double -> Double -> Path
moveTo' Double
x1 Double
y1
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 Double
y3
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 Double
y3
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 Double
y1
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 Double
y1
strokeRectangleP (Point Double
x1 Double
y1) (Double
x2,Double
y2) (RCornerBevel Double
s) =
let (Double
x3,Double
y3) = (Double
x1forall a. Num a => a -> a -> a
+Double
x2,Double
y1forall a. Num a => a -> a -> a
+Double
y2) in Double -> Double -> Path
moveTo' Double
x1 (Double
y1forall a. Num a => a -> a -> a
+Double
s)
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 (Double
y3forall a. Num a => a -> a -> a
-Double
s)
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x1forall a. Num a => a -> a -> a
+Double
s) Double
y3
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x3forall a. Num a => a -> a -> a
-Double
s) Double
y3
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 (Double
y3forall a. Num a => a -> a -> a
-Double
s)
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 (Double
y1forall a. Num a => a -> a -> a
+Double
s)
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x3forall a. Num a => a -> a -> a
-Double
s) Double
y1
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x1forall a. Num a => a -> a -> a
+Double
s) Double
y1
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 (Double
y1forall a. Num a => a -> a -> a
+Double
s)
strokeRectangleP (Point Double
x1 Double
y1) (Double
x2,Double
y2) (RCornerRounded Double
s) =
let (Double
x3,Double
y3) = (Double
x1forall a. Num a => a -> a -> a
+Double
x2,Double
y1forall a. Num a => a -> a -> a
+Double
y2) in
Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x1forall a. Num a => a -> a -> a
+Double
s) (Double
y3forall a. Num a => a -> a -> a
-Double
s)) Double
s (Double
pi2forall a. Num a => a -> a -> a
*Double
2) Double
pi2
forall a. Semigroup a => a -> a -> a
<> Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x3forall a. Num a => a -> a -> a
-Double
s) (Double
y3forall a. Num a => a -> a -> a
-Double
s)) Double
s Double
pi2 Double
0
forall a. Semigroup a => a -> a -> a
<> Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x3forall a. Num a => a -> a -> a
-Double
s) (Double
y1forall a. Num a => a -> a -> a
+Double
s)) Double
s Double
0 (Double
pi2forall a. Num a => a -> a -> a
*Double
3)
forall a. Semigroup a => a -> a -> a
<> Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x1forall a. Num a => a -> a -> a
+Double
s) (Double
y1forall a. Num a => a -> a -> a
+Double
s)) Double
s (Double
pi2forall a. Num a => a -> a -> a
*Double
3) (Double
pi2forall a. Num a => a -> a -> a
*Double
2)
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 (Double
y3forall a. Num a => a -> a -> a
-Double
s)
pi2 :: Double
pi2 = forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
2
$( makeLenses ''Rectangle )