-- | Provide definition for some higher level objects (only slightly)

module Graphics.Rasterific.ComplexPrimitive( rectangle
                                           , roundedRectangle
                                           , circle
                                           , ellipse
                                           ) where

import Control.Applicative( empty, (<|>) )
import Control.Exception( throw, ArithException( .. ) )

import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^*) )
import Graphics.Rasterific.Line
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.Types

isCoordValid :: RealFloat a => a -> Maybe ArithException
isCoordValid :: a -> Maybe ArithException
isCoordValid a
v
  | a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
v = ArithException -> Maybe ArithException
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArithException
Overflow
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
v Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
v = ArithException -> Maybe ArithException
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArithException
Denormal
  | Bool
otherwise = Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a
empty

isPointValid :: RealFloat a => V2 a -> Maybe ArithException
isPointValid :: V2 a -> Maybe ArithException
isPointValid (V2 a
x a
y) = a -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid a
x Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid a
y

-- | Generate a list of primitive representing a circle.

--

-- > fill $ circle (V2 100 100) 75

--

-- <<docimages/fill_circle.png>>

--

circle :: Point -- ^ Circle center in pixels

       -> Float -- ^ Circle radius in pixels

       -> [Primitive]
circle :: Point -> Float -> [Primitive]
circle Point
p Float
r
  | Just ArithException
ex <- Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
r Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Point -> Maybe ArithException
forall a. RealFloat a => V2 a -> Maybe ArithException
isPointValid Point
p = ArithException -> [Primitive]
forall a e. Exception e => e -> a
throw ArithException
ex
circle Point
center Float
radius =
    CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive)
-> (CubicBezier -> CubicBezier) -> CubicBezier -> Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
mv (CubicBezier -> Primitive) -> [CubicBezier] -> [Primitive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CubicBezier]
cubicBezierCircle
  where
    mv :: Point -> Point
mv Point
p = (Point
p Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
radius) Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
center

-- | Generate a list of primitive representing an ellipse.

--

-- > fill $ ellipse (V2 100 100) 75 30

--

-- <<docimages/fill_ellipse.png>>

--

ellipse :: Point -> Float -> Float -> [Primitive]
ellipse :: Point -> Float -> Float -> [Primitive]
ellipse Point
c Float
rx Float
ry
  | Just ArithException
ex <- Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
rx Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
ry Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Point -> Maybe ArithException
forall a. RealFloat a => V2 a -> Maybe ArithException
isPointValid Point
c = ArithException -> [Primitive]
forall a e. Exception e => e -> a
throw ArithException
ex
ellipse Point
center Float
rx Float
ry =
    CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive)
-> (CubicBezier -> CubicBezier) -> CubicBezier -> Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
mv (CubicBezier -> Primitive) -> [CubicBezier] -> [Primitive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CubicBezier]
cubicBezierCircle
  where
    mv :: Point -> Point
mv (V2 Float
x Float
y) = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry) Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
center

-- | Generate a list of primitive representing a

-- rectangle

--

-- > fill $ rectangle (V2 30 30) 150 100

--

-- <<docimages/fill_rect.png>>

--

rectangle :: Point -- ^ Corner upper left

          -> Float -- ^ Width in pixel

          -> Float -- ^ Height in pixel

          -> [Primitive]
rectangle :: Point -> Float -> Float -> [Primitive]
rectangle Point
p Float
w Float
h
  | Just ArithException
ex <- Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
w Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
h Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Point -> Maybe ArithException
forall a. RealFloat a => V2 a -> Maybe ArithException
isPointValid Point
p = ArithException -> [Primitive]
forall a e. Exception e => e -> a
throw ArithException
ex
rectangle p :: Point
p@(V2 Float
px Float
py) Float
w Float
h =
  Line -> Primitive
LinePrim (Line -> Primitive) -> [Line] -> [Primitive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point] -> [Line]
lineFromPath
    [ Point
p, Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) Float
py, Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h), Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
px (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h), Point
p ]

-- | Generate a list of primitive representing a rectangle

-- with rounded corner.

--

-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10

--

-- <<docimages/fill_roundedRectangle.png>>

--

roundedRectangle :: Point -- ^ Corner upper left

                 -> Float -- ^ Width in pixel

                 -> Float -- ^ Height in pixel.

                 -> Float -- ^ Radius along the x axis of the rounded corner. In pixel.

                 -> Float -- ^ Radius along the y axis of the rounded corner. In pixel.

                 -> [Primitive]
roundedRectangle :: Point -> Float -> Float -> Float -> Float -> [Primitive]
roundedRectangle Point
p Float
w Float
h Float
rx Float
ry
  | Just ArithException
ex <- Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
w
        Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
h
        Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
rx
        Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Float -> Maybe ArithException
forall a. RealFloat a => a -> Maybe ArithException
isCoordValid Float
ry
        Maybe ArithException
-> Maybe ArithException -> Maybe ArithException
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Point -> Maybe ArithException
forall a. RealFloat a => V2 a -> Maybe ArithException
isPointValid Point
p = ArithException -> [Primitive]
forall a e. Exception e => e -> a
throw ArithException
ex
roundedRectangle (V2 Float
px Float
py) Float
w Float
h Float
rx Float
ry =
    [ CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive)
-> (CubicBezier -> CubicBezier) -> CubicBezier -> Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xFar Float
yNear) (CubicBezier -> Primitive) -> CubicBezier -> Primitive
forall a b. (a -> b) -> a -> b
$ CubicBezier
cornerTopR
    , Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xFar Float
py) (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xNear Float
py)
    , CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive)
-> (CubicBezier -> CubicBezier) -> CubicBezier -> Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ry)) (CubicBezier -> Primitive) -> CubicBezier -> Primitive
forall a b. (a -> b) -> a -> b
$ CubicBezier
cornerTopL
    , Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
px Float
yNear) (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
px Float
yFar)
    , CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive)
-> (CubicBezier -> CubicBezier) -> CubicBezier -> Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx) Float
yFar) (CubicBezier -> Primitive) -> CubicBezier -> Primitive
forall a b. (a -> b) -> a -> b
$ CubicBezier
cornerBottomL
    , Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xNear (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h)) (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xFar (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h))
    , CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive)
-> (CubicBezier -> CubicBezier) -> CubicBezier -> Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
xFar Float
yFar) (CubicBezier -> Primitive) -> CubicBezier -> Primitive
forall a b. (a -> b) -> a -> b
$ CubicBezier
cornerBottomR
    , Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) Float
yFar) (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w) Float
yNear)
    ]
  where
   xNear :: Float
xNear = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
rx
   xFar :: Float
xFar = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
rx

   yNear :: Float
yNear = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ry
   yFar :: Float
yFar = Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
h Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ry

   (CubicBezier
cornerBottomR :
    CubicBezier
cornerTopR     :
    CubicBezier
cornerTopL  :
    CubicBezier
cornerBottomL:[CubicBezier]
_) = (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform (\(V2 Float
x Float
y) -> Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
rx) (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
ry)) (CubicBezier -> CubicBezier) -> [CubicBezier] -> [CubicBezier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CubicBezier]
cubicBezierCircle