-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Chart.Renderable
-- Copyright   :  (c) Tim Docker 2006, 2014
-- License     :  BSD-style (see chart/COPYRIGHT)
--
-- This module contains the definition of the 'Renderable' type, which
-- is a composable drawing element, along with assorted functions to
-- them.
--
{-# 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.Monoid
import Data.Default.Class

import Graphics.Rendering.Chart.Geometry
import Graphics.Rendering.Chart.Drawing
import Graphics.Rendering.Chart.Utils

-- | A function that maps a point in device coordinates to some value.
--
--   Perhaps it might be generalised from Maybe a to
--   (MonadPlus m ) => m a in the future.
type PickFn a = Point -> Maybe a

nullPickFn :: PickFn a
nullPickFn :: PickFn a
nullPickFn = Maybe a -> PickFn a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing

-- | A Renderable is a record of functions required to layout a
--   graphic element.
data Renderable a = Renderable {

   -- | Calculate the minimum size of the renderable.
   Renderable a -> BackendProgram RectSize
minsize :: BackendProgram RectSize,

   -- | Draw the renderable with a rectangle, which covers
   --   the origin to a given point.
   --
   --   The resulting "pick" function  maps a point in the image to a value.
   Renderable a -> RectSize -> BackendProgram (PickFn a)
render  :: RectSize -> BackendProgram (PickFn a)
}
  deriving (a -> Renderable b -> Renderable a
(a -> b) -> Renderable a -> Renderable b
(forall a b. (a -> b) -> Renderable a -> Renderable b)
-> (forall a b. a -> Renderable b -> Renderable a)
-> Functor Renderable
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
<$ :: a -> Renderable b -> Renderable a
$c<$ :: forall a b. a -> Renderable b -> Renderable a
fmap :: (a -> b) -> Renderable a -> Renderable b
$cfmap :: forall a b. (a -> b) -> Renderable a -> Renderable b
Functor)

-- | A type class abtracting the conversion of a value to a Renderable.
class ToRenderable a where
  toRenderable :: a -> Renderable ()

instance ToRenderable (Renderable a) where
  toRenderable :: Renderable a -> Renderable ()
toRenderable = Renderable a -> Renderable ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void

emptyRenderable :: Renderable a
emptyRenderable :: Renderable a
emptyRenderable = RectSize -> Renderable a
forall a. RectSize -> Renderable a
spacer (Double
0,Double
0)

-- | Create a blank renderable with a specified minimum size.
spacer :: RectSize -> Renderable a 
spacer :: RectSize -> Renderable a
spacer RectSize
sz  = Renderable :: forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
Renderable {
   minsize :: BackendProgram RectSize
minsize = RectSize -> BackendProgram RectSize
forall (m :: * -> *) a. Monad m => a -> m a
return RectSize
sz,
   render :: RectSize -> BackendProgram (PickFn a)
render  = \RectSize
_ -> PickFn a -> BackendProgram (PickFn a)
forall (m :: * -> *) a. Monad m => a -> m a
return PickFn a
forall a. PickFn a
nullPickFn
}


-- | Create a blank renderable with a minimum size the same as
--   some other renderable.
spacer1 :: Renderable a -> Renderable b
spacer1 :: Renderable a -> Renderable b
spacer1 Renderable a
r  = Renderable a
r{ render :: RectSize -> BackendProgram (PickFn b)
render  = \RectSize
_ -> PickFn b -> BackendProgram (PickFn b)
forall (m :: * -> *) a. Monad m => a -> m a
return PickFn b
forall a. PickFn a
nullPickFn }

-- | Replace the pick function of a renderable with another.
setPickFn :: PickFn b -> Renderable a -> Renderable b
setPickFn :: PickFn b -> Renderable a -> Renderable b
setPickFn PickFn b
pickfn Renderable a
r = Renderable a
r{ render :: RectSize -> BackendProgram (PickFn b)
render  = \RectSize
sz -> Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r RectSize
sz BackendProgram (PickFn a)
-> BackendProgram (PickFn b) -> BackendProgram (PickFn b)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PickFn b -> BackendProgram (PickFn b)
forall (m :: * -> *) a. Monad m => a -> m a
return PickFn b
pickfn }

-- | Map a function over the result of a renderable's pickfunction, keeping only 'Just' results.
mapMaybePickFn :: (a -> Maybe b) -> Renderable a -> Renderable b
mapMaybePickFn :: (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 <- Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r RectSize
sz
                                           PickFn b -> BackendProgram (PickFn b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Maybe b) -> Maybe b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe b) -> Maybe b)
-> (Point -> Maybe (Maybe b)) -> PickFn b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe b) -> Maybe a -> Maybe (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe b
f (Maybe a -> Maybe (Maybe b))
-> PickFn a -> Point -> Maybe (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PickFn a
pf) }

-- | Map a function over result of a renderable's pickfunction.
mapPickFn :: (a -> b) -> Renderable a -> Renderable b
mapPickFn :: (a -> b) -> Renderable a -> Renderable b
mapPickFn a -> b
f = (a -> Maybe b) -> Renderable a -> Renderable b
forall a b. (a -> Maybe b) -> Renderable a -> Renderable b
mapMaybePickFn (b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> (a -> b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

-- | Add some spacing at the edges of a renderable.
addMargins :: (Double,Double,Double,Double) -- ^ The spacing to be added.
           -> Renderable a                  -- ^ The source renderable.
           -> Renderable a
addMargins :: (Double, Double, Double, Double) -> Renderable a -> Renderable a
addMargins (Double
t,Double
b,Double
l,Double
r) Renderable a
rd = Renderable :: forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
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) <- Renderable a -> BackendProgram RectSize
forall a. Renderable a -> BackendProgram RectSize
minsize Renderable a
rd
        RectSize -> BackendProgram RectSize
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
lDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
r,Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
tDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
b)

    rf :: RectSize -> BackendProgram (PickFn a)
rf (Double
w,Double
h) = 
        Point -> BackendProgram (PickFn a) -> BackendProgram (PickFn a)
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point Double
l Double
t) (BackendProgram (PickFn a) -> BackendProgram (PickFn a))
-> BackendProgram (PickFn a) -> BackendProgram (PickFn a)
forall a b. (a -> b) -> a -> b
$ do
          PickFn a
pickf <- Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
rd (Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
lDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r,Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
tDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b)
          PickFn a -> BackendProgram (PickFn a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PickFn a
-> (Double, Double, Double, Double) -> RectSize -> PickFn a
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 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
l' Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
r' Bool -> Bool -> Bool
&& Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
t' Bool -> Bool -> Bool
&& Double
t' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b' = Point -> Maybe a
pickf (Double -> Double -> Point
Point (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
l') (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
t'))
        | Bool
otherwise                                     = Maybe a
forall a. Maybe a
Nothing

-- | Overlay a renderable over a solid background fill.
fillBackground :: FillStyle -> Renderable a -> Renderable a
fillBackground :: 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
      FillStyle -> BackendProgram () -> BackendProgram ()
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle FillStyle
fs (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ do
        Path
p <- Path -> BackendProgram Path
alignFillPath (Path -> BackendProgram Path) -> Path -> BackendProgram Path
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
      Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
r RectSize
rsize

-- | Helper function for using a renderable, when we generate it
--   in the BackendProgram monad.
embedRenderable :: BackendProgram (Renderable a) -> Renderable a
embedRenderable :: BackendProgram (Renderable a) -> Renderable a
embedRenderable BackendProgram (Renderable a)
ca = Renderable :: forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
Renderable {
   minsize :: BackendProgram RectSize
minsize = do { Renderable a
a <- BackendProgram (Renderable a)
ca; Renderable a -> BackendProgram RectSize
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; Renderable a -> RectSize -> BackendProgram (PickFn a)
forall a. Renderable a -> RectSize -> BackendProgram (PickFn a)
render Renderable a
a RectSize
r }
}


----------------------------------------------------------------------
-- Labels

-- | Construct a renderable from a text string, aligned with the axes.
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

-- | Construct a renderable from a text string, rotated wrt to axes. The angle
--   of rotation is in degrees, measured clockwise from the horizontal.
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 :: forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
Renderable { minsize :: BackendProgram RectSize
minsize = BackendProgram RectSize
mf, render :: RectSize -> BackendProgram (PickFn String)
render = RectSize -> BackendProgram (PickFn String)
forall p. RectSize -> BackendProgram (p -> Maybe String)
rf }
  where
    mf :: BackendProgram RectSize
mf = FontStyle -> BackendProgram RectSize -> BackendProgram RectSize
forall a. FontStyle -> BackendProgram a -> BackendProgram a
withFontStyle FontStyle
fs (BackendProgram RectSize -> BackendProgram RectSize)
-> BackendProgram RectSize -> BackendProgram RectSize
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)
       RectSize -> BackendProgram RectSize
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) = FontStyle
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a. FontStyle -> BackendProgram a -> BackendProgram a
withFontStyle FontStyle
fs (BackendProgram (p -> Maybe String)
 -> BackendProgram (p -> Maybe String))
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
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
szDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
          xadj HTextAnchor
HTA_Centre = Double
w0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
          xadj HTextAnchor
HTA_Right  = Double
w0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- RectSize -> Double
xwid RectSize
szDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
    
          yadj :: VTextAnchor -> Double
yadj VTextAnchor
VTA_Top      = RectSize -> Double
ywid RectSize
szDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
          yadj VTextAnchor
VTA_Centre   = Double
h0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
          yadj VTextAnchor
VTA_Bottom   = Double
h0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- RectSize -> Double
ywid RectSize
szDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
          yadj VTextAnchor
VTA_BaseLine = Double
h0 Double -> Double -> Double
forall a. Num a => a -> a -> a
- RectSize -> Double
ywid RectSize
szDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
descentDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
acr

      Point
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point Double
0 (-Double
descent)) (BackendProgram (p -> Maybe String)
 -> BackendProgram (p -> Maybe String))
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a b. (a -> b) -> a -> b
$ 
        Point
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a. Point -> BackendProgram a -> BackendProgram a
withTranslation (Double -> Double -> Point
Point (HTextAnchor -> Double
xadj HTextAnchor
hta) (VTextAnchor -> Double
yadj VTextAnchor
vta)) (BackendProgram (p -> Maybe String)
 -> BackendProgram (p -> Maybe String))
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a b. (a -> b) -> a -> b
$ 
          Double
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a. Double -> BackendProgram a -> BackendProgram a
withRotation Double
rot' (BackendProgram (p -> Maybe String)
 -> BackendProgram (p -> Maybe String))
-> BackendProgram (p -> Maybe String)
-> BackendProgram (p -> Maybe String)
forall a b. (a -> b) -> a -> b
$ do
            Point -> String -> BackendProgram ()
drawText (Double -> Double -> Point
Point (-Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) String
s
            (p -> Maybe String) -> BackendProgram (p -> Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (\p
_-> String -> Maybe String
forall a. a -> Maybe a
Just String
s)  -- PickFn String
            
    rot' :: Double
rot'      = Double
rot Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
180 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
    (Double
cr,Double
sr)   = (Double -> Double
forall a. Floating a => a -> a
cos Double
rot', Double -> Double
forall a. Floating a => a -> a
sin Double
rot')
    (Double
acr,Double
asr) = (Double -> Double
forall a. Num a => a -> a
abs Double
cr, Double -> Double
forall a. Num a => a -> a
abs Double
sr)

    xwid :: RectSize -> Double
xwid (Double
w,Double
h) = Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
acr Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
asr
    ywid :: RectSize -> Double
ywid (Double
w,Double
h) = Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
asr Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
acr

----------------------------------------------------------------------
-- Rectangles

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 :: RectSize
-> Maybe FillStyle
-> Maybe LineStyle
-> RectCornerStyle
-> Rectangle
Rectangle
    { _rect_minsize :: RectSize
_rect_minsize     = (Double
0,Double
0)
    , _rect_fillStyle :: Maybe FillStyle
_rect_fillStyle   = Maybe FillStyle
forall a. Maybe a
Nothing
    , _rect_lineStyle :: Maybe LineStyle
_rect_lineStyle   = Maybe LineStyle
forall a. Maybe a
Nothing
    , _rect_cornerStyle :: RectCornerStyle
_rect_cornerStyle = RectCornerStyle
RCornerSquare
    }

instance ToRenderable Rectangle where
  toRenderable :: Rectangle -> Renderable ()
toRenderable = Rectangle -> Renderable ()
forall a. Rectangle -> Renderable a
rectangleToRenderable

rectangleToRenderable :: Rectangle -> Renderable a
rectangleToRenderable :: Rectangle -> Renderable a
rectangleToRenderable Rectangle
rectangle = BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
forall a.
BackendProgram RectSize
-> (RectSize -> BackendProgram (PickFn a)) -> Renderable a
Renderable BackendProgram RectSize
mf RectSize -> BackendProgram (PickFn a)
forall a. RectSize -> BackendProgram (PickFn a)
rf
  where
    mf :: BackendProgram RectSize
mf = RectSize -> BackendProgram RectSize
forall (m :: * -> *) a. Monad m => a -> m a
return (Rectangle -> RectSize
_rect_minsize Rectangle
rectangle)
    rf :: RectSize -> BackendProgram (PickFn a)
rf = \RectSize
rectSize -> Point -> Rectangle -> BackendProgram (PickFn a)
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 }

-- | Draw the specified rectangle such that its top-left vertex is placed at
--   the given position
drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)
drawRectangle :: Point -> Rectangle -> BackendProgram (PickFn a)
drawRectangle Point
point Rectangle
rectangle = do
  ()
-> (FillStyle -> BackendProgram ())
-> Maybe FillStyle
-> BackendProgram ()
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)
  ()
-> (LineStyle -> BackendProgram ())
-> Maybe LineStyle
-> BackendProgram ()
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)
  PickFn a -> BackendProgram (PickFn a)
forall (m :: * -> *) a. Monad m => a -> m a
return PickFn a
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 = 
          FillStyle -> BackendProgram () -> BackendProgram ()
forall a. FillStyle -> BackendProgram a -> BackendProgram a
withFillStyle FillStyle
fs (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ 
            Path -> BackendProgram ()
fillPath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
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 = 
          LineStyle -> BackendProgram () -> BackendProgram ()
forall a. LineStyle -> BackendProgram a -> BackendProgram a
withLineStyle LineStyle
ls (BackendProgram () -> BackendProgram ())
-> BackendProgram () -> BackendProgram ()
forall a b. (a -> b) -> a -> b
$ 
            Path -> BackendProgram ()
strokePath (Path -> BackendProgram ()) -> Path -> BackendProgram ()
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
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
x2,Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
y2) in Double -> Double -> Path
moveTo' Double
x1 Double
y1
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 Double
y3
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 Double
y3
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 Double
y1
                                      Path -> Path -> Path
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
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
x2,Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
y2) in Double -> Double -> Path
moveTo' Double
x1 (Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s)
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 (Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s)
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s) Double
y3
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s) Double
y3
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 (Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s)
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x3 (Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s)
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s) Double
y1
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s) Double
y1
                                      Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 (Double
y1Double -> Double -> Double
forall 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
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
x2,Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
y2) in
            Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s) (Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s)) Double
s (Double
pi2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2) Double
pi2
            Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s) (Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s)) Double
s Double
pi2 Double
0
            Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s) (Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s)) Double
s Double
0 (Double
pi2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
3)
            Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Point -> Double -> Double -> Double -> Path
arcNeg (Double -> Double -> Point
Point (Double
x1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s) (Double
y1Double -> Double -> Double
forall a. Num a => a -> a -> a
+Double
s)) Double
s (Double
pi2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
3) (Double
pi2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2)
            Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Double -> Double -> Path
lineTo' Double
x1 (Double
y3Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
s)
      
      pi2 :: Double
pi2 = Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2

$( makeLenses ''Rectangle )