{-# LANGUAGE LambdaCase #-}
module Graphics.NanoVG.Picture
(
Shape (..)
, Radius
, Point
, Center
, Angle
, circle
, line
, rectangle
, arc
, shapes
, translateS
, rotateS
, scaleS
, scaleS'
, scaleSx
, scaleSy
, hole
, Picture
, mapShape
, stroke
, fill
, pictures
, translateP
, rotateP
, scaleP
, scaleP'
, scalePx
, scalePy
, render
, asWindow
) where
import Control.Exception.Safe
import Data.Foldable
import Graphics.NanoVG.Window (Window (..))
import qualified NanoVG as NVG
type Radius = Float
type Point = (Float, Float)
type Center = Point
type Angle = Float
newtype Shape = Shape
{ unShape :: NVG.Context -> IO ()
}
withState :: NVG.Context -> IO () -> IO () -> IO ()
withState ctx t = bracket_ (NVG.save ctx *> t) (NVG.restore ctx)
circle :: Center -> Radius -> Shape
circle (x, y) r = Shape $ \ctx -> NVG.circle ctx (realToFrac x) (realToFrac y) (realToFrac r)
line :: Point -> Point -> Shape
line (ax, ay) (bx, by) = Shape $ \ctx -> do
NVG.moveTo ctx (realToFrac ax) (realToFrac ay)
NVG.lineTo ctx (realToFrac bx) (realToFrac by)
rectangle :: Point -> Point -> Shape
rectangle (ax, ay) (bx, by) = Shape $ \ctx ->
NVG.rect ctx (realToFrac $ min ax bx) (realToFrac $ min ay by)
(realToFrac $ abs $ ax - bx) (realToFrac $ abs $ ay - by)
arc :: Center -> Radius -> Angle -> Angle -> Shape
arc (x, y) r a0 a1 = Shape $ \ctx ->
NVG.arc ctx (realToFrac x) (realToFrac y) (realToFrac r) (realToFrac a0) (realToFrac a1) NVG.CCW
shapes :: [Shape] -> Shape
shapes ss = Shape $ \ctx -> traverse_ (`unShape` ctx) ss
translateS :: Float -> Float -> Shape -> Shape
translateS x y s = Shape $ \ctx ->
withState ctx (NVG.translate ctx (realToFrac x) (realToFrac y)) $
unShape s ctx
rotateS :: Center -> Angle -> Shape -> Shape
rotateS (x, y) a s = Shape $ \ctx ->
withState ctx
(NVG.translate ctx fx fy *>
NVG.rotate ctx fa *>
NVG.translate ctx (-fx) (-fy))
(unShape s ctx)
where
(fx, fy, fa) = (realToFrac x, realToFrac y, realToFrac a)
scaleS :: Center -> Angle -> Float -> Shape -> Shape
scaleS (x, y) a k s = Shape $ \ctx ->
withState ctx
(NVG.translate ctx fx fy *>
NVG.rotate ctx fa *>
NVG.scale ctx fk 1 *>
NVG.rotate ctx (-fa) *>
NVG.translate ctx (-(fx*fk)) (-fy))
(unShape s ctx)
where
(fx, fy, fa, fk) = (realToFrac x, realToFrac y, realToFrac a, realToFrac k)
scaleSx :: Center -> Float -> Shape -> Shape
scaleSx (x, y) = scaleS (x, y) 0
scaleSy :: Center -> Float -> Shape -> Shape
scaleSy (x, y) = scaleS (x, y) (pi/2)
scaleS' :: Center -> Float -> Shape -> Shape
scaleS' c k = scaleSx c k . scaleSy c k
hole :: Shape -> Shape
hole s = Shape $ \ctx -> do
unShape s ctx
NVG.pathWinding ctx $ fromIntegral $ fromEnum NVG.CW
data Picture =
Stroke NVG.Color Shape
| Fill NVG.Color Shape
| Pictures [Picture]
mapShape :: (Shape -> Shape) -> Picture -> Picture
mapShape f = \case
Stroke c s -> Stroke c $ f s
Fill c s -> Fill c $ f s
Pictures ss -> Pictures $ mapShape f <$> ss
translateP :: Float -> Float -> Picture -> Picture
translateP x y = mapShape $ translateS x y
rotateP :: Center -> Angle -> Picture -> Picture
rotateP c a = mapShape $ rotateS c a
scaleP :: Center -> Angle -> Float -> Picture -> Picture
scaleP c a k = mapShape $ scaleS c a k
scalePx :: Center -> Float -> Picture -> Picture
scalePx c = scaleP c 0
scalePy :: Center -> Float -> Picture -> Picture
scalePy c = scaleP c (pi/2)
scaleP' :: Center -> Float -> Picture -> Picture
scaleP' c k = scalePx c k . scalePy c k
stroke :: NVG.Color -> Shape -> Picture
stroke = Stroke
fill :: NVG.Color -> Shape -> Picture
fill = Fill
pictures :: [Picture] -> Picture
pictures = Pictures
render :: NVG.Context -> Picture -> IO ()
render ctx = \case
Stroke col s -> do
NVG.beginPath ctx
withState ctx (NVG.strokeColor ctx col *> NVG.strokeWidth ctx 1) $
unShape s ctx *> NVG.stroke ctx
Fill col s -> do
NVG.beginPath ctx
withState ctx (NVG.fillColor ctx col) $
unShape s ctx *> NVG.fill ctx
Pictures ss ->
traverse_ (render ctx) ss
asWindow :: IO Picture -> Window ()
asWindow g = Window
{ winInit = \_ -> pure ()
, winRender = \_ ctx -> g >>= render ctx
, winAfterRender = \_ _ -> pure ()
}