{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}

module Twirl.Graphics (
  line
  , polyLine
  , rectangle
  , circle
  , drawTexture
  , loadTexture
  , decodeTexture
  , setColor
  , setLogicalSize
  , setWindowSize
  , WindowMode (..)
  , setWindowMode
  , Texture
  , Quad
  , mkQuad
  , quadWidth
  , quadHeight
  , drawQuad
  , TwirlMonad
  , TwirlContext (..)
  , FillMode (..)
  , loadFont
  , loadDefaultFont
  , PointSize
  , setFont
  , printText
  , runTwirlMonad
  , setWindowTitle
) where

import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State (MonadState, StateT, get, gets, modify, runStateT)
import Data.ByteString (ByteString)
import Data.FileEmbed (embedFile)
import Data.List (nub)
import Data.Text (Text)
import Data.Vector.Storable hiding (
  foldl
  , length
  , map
  , mapM_
  , modify
  , tail
  , (++)
 )
import Foreign.C.Types
import SDL (Point (..), Rectangle (..), Renderer, Texture, V2 (..), V4 (..), Window, WindowMode (..), windowTitle, ($=))
import qualified SDL
import SDL.Font (Font, PointSize)
import qualified SDL.Font as Font
import qualified SDL.Image

newtype TwirlMonad a = TwirlMonad (StateT TwirlContext IO a) deriving (Functor TwirlMonad
Functor TwirlMonad
-> (forall a. a -> TwirlMonad a)
-> (forall a b.
    TwirlMonad (a -> b) -> TwirlMonad a -> TwirlMonad b)
-> (forall a b c.
    (a -> b -> c) -> TwirlMonad a -> TwirlMonad b -> TwirlMonad c)
-> (forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b)
-> (forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad a)
-> Applicative TwirlMonad
forall a. a -> TwirlMonad a
forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad a
forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b
forall a b. TwirlMonad (a -> b) -> TwirlMonad a -> TwirlMonad b
forall a b c.
(a -> b -> c) -> TwirlMonad a -> TwirlMonad b -> TwirlMonad c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad a
$c<* :: forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad a
*> :: forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b
$c*> :: forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b
liftA2 :: forall a b c.
(a -> b -> c) -> TwirlMonad a -> TwirlMonad b -> TwirlMonad c
$cliftA2 :: forall a b c.
(a -> b -> c) -> TwirlMonad a -> TwirlMonad b -> TwirlMonad c
<*> :: forall a b. TwirlMonad (a -> b) -> TwirlMonad a -> TwirlMonad b
$c<*> :: forall a b. TwirlMonad (a -> b) -> TwirlMonad a -> TwirlMonad b
pure :: forall a. a -> TwirlMonad a
$cpure :: forall a. a -> TwirlMonad a
Applicative, (forall a b. (a -> b) -> TwirlMonad a -> TwirlMonad b)
-> (forall a b. a -> TwirlMonad b -> TwirlMonad a)
-> Functor TwirlMonad
forall a b. a -> TwirlMonad b -> TwirlMonad a
forall a b. (a -> b) -> TwirlMonad a -> TwirlMonad 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 -> TwirlMonad b -> TwirlMonad a
$c<$ :: forall a b. a -> TwirlMonad b -> TwirlMonad a
fmap :: forall a b. (a -> b) -> TwirlMonad a -> TwirlMonad b
$cfmap :: forall a b. (a -> b) -> TwirlMonad a -> TwirlMonad b
Functor, Applicative TwirlMonad
Applicative TwirlMonad
-> (forall a b.
    TwirlMonad a -> (a -> TwirlMonad b) -> TwirlMonad b)
-> (forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b)
-> (forall a. a -> TwirlMonad a)
-> Monad TwirlMonad
forall a. a -> TwirlMonad a
forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b
forall a b. TwirlMonad a -> (a -> TwirlMonad b) -> TwirlMonad b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> TwirlMonad a
$creturn :: forall a. a -> TwirlMonad a
>> :: forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b
$c>> :: forall a b. TwirlMonad a -> TwirlMonad b -> TwirlMonad b
>>= :: forall a b. TwirlMonad a -> (a -> TwirlMonad b) -> TwirlMonad b
$c>>= :: forall a b. TwirlMonad a -> (a -> TwirlMonad b) -> TwirlMonad b
Monad, Monad TwirlMonad
Monad TwirlMonad
-> (forall a. IO a -> TwirlMonad a) -> MonadIO TwirlMonad
forall a. IO a -> TwirlMonad a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> TwirlMonad a
$cliftIO :: forall a. IO a -> TwirlMonad a
MonadIO, MonadState TwirlContext)

runTwirlMonad :: TwirlMonad a -> TwirlContext -> IO (a, TwirlContext)
runTwirlMonad :: forall a. TwirlMonad a -> TwirlContext -> IO (a, TwirlContext)
runTwirlMonad (TwirlMonad StateT TwirlContext IO a
action) TwirlContext
initialState = StateT TwirlContext IO a -> TwirlContext -> IO (a, TwirlContext)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT TwirlContext IO a
action TwirlContext
initialState

data TwirlContext = TwirlContext
  { TwirlContext -> Renderer
renderer :: Renderer
  , TwirlContext -> Window
window :: Window
  , TwirlContext -> Font
font :: Font
  }

data FillMode
  = Fill
  | Hollow

loadTexture :: FilePath -> TwirlMonad Texture
loadTexture :: FilePath -> TwirlMonad Texture
loadTexture FilePath
path = do
  Renderer
renderer <- (TwirlContext -> Renderer) -> TwirlMonad Renderer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Renderer
renderer
  Renderer -> FilePath -> TwirlMonad Texture
forall (m :: * -> *).
MonadIO m =>
Renderer -> FilePath -> m Texture
SDL.Image.loadTexture Renderer
renderer FilePath
path

decodeTexture :: ByteString -> TwirlMonad Texture
decodeTexture :: ByteString -> TwirlMonad Texture
decodeTexture ByteString
texture = do
  Renderer
renderer <- (TwirlContext -> Renderer) -> TwirlMonad Renderer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Renderer
renderer
  Renderer -> ByteString -> TwirlMonad Texture
forall (m :: * -> *).
MonadIO m =>
Renderer -> ByteString -> m Texture
SDL.Image.decodeTexture Renderer
renderer ByteString
texture

-- |Draw a texture
--
-- The texture position is specified as its top-left corner's position
drawTexture ::
  -- |The texture to draw
  Texture ->
  -- |X coordinate of the texture's top-left corner
  Int ->
  -- |Y coordinate of the texture's top-left corner
  Int ->
  TwirlMonad ()
drawTexture :: Texture -> Int -> Int -> TwirlMonad ()
drawTexture Texture
texture Int
x Int
y = do
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  TextureInfo
textureInfo <- Texture -> TwirlMonad TextureInfo
forall (m :: * -> *). MonadIO m => Texture -> m TextureInfo
SDL.queryTexture Texture
texture
  ()
_ <-
    Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy
      (TwirlContext -> Renderer
renderer TwirlContext
context)
      Texture
texture
      Maybe (Rectangle CInt)
forall a. Maybe a
Nothing
      (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just (Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
Rectangle (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (TextureInfo -> CInt
SDL.textureWidth TextureInfo
textureInfo) (TextureInfo -> CInt
SDL.textureHeight TextureInfo
textureInfo))))
  () -> TwirlMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

data Quad = Quad
  { Quad -> Rectangle CInt
quadRectangle :: Rectangle CInt
  , Quad -> Texture
quadTexture :: Texture
  }
  deriving (Quad -> Quad -> Bool
(Quad -> Quad -> Bool) -> (Quad -> Quad -> Bool) -> Eq Quad
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Quad -> Quad -> Bool
$c/= :: Quad -> Quad -> Bool
== :: Quad -> Quad -> Bool
$c== :: Quad -> Quad -> Bool
Eq)

mkQuad :: Texture -> Int -> Int -> Int -> Int -> Quad
mkQuad :: Texture -> Int -> Int -> Int -> Int -> Quad
mkQuad Texture
texture Int
x Int
y Int
w Int
h =
  Quad{quadRectangle :: Rectangle CInt
quadRectangle = Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
Rectangle (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)), quadTexture :: Texture
quadTexture = Texture
texture}

quadWidth :: Quad -> Int
quadWidth :: Quad -> Int
quadWidth Quad{quadRectangle :: Quad -> Rectangle CInt
quadRectangle = Rectangle Point V2 CInt
_ (V2 CInt
w CInt
_)} = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
w

quadHeight :: Quad -> Int
quadHeight :: Quad -> Int
quadHeight Quad{quadRectangle :: Quad -> Rectangle CInt
quadRectangle = Rectangle Point V2 CInt
_ (V2 CInt
_ CInt
h)} = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
h

drawQuad :: Quad -> Int -> Int -> Int -> Int -> Bool -> Bool -> TwirlMonad ()
drawQuad :: Quad -> Int -> Int -> Int -> Int -> Bool -> Bool -> TwirlMonad ()
drawQuad Quad{Rectangle CInt
quadRectangle :: Rectangle CInt
quadRectangle :: Quad -> Rectangle CInt
quadRectangle, Texture
quadTexture :: Texture
quadTexture :: Quad -> Texture
quadTexture} Int
x Int
y Int
sx Int
sy Bool
flipX Bool
flipY = do
  Renderer
renderer <- (TwirlContext -> Renderer) -> TwirlMonad Renderer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Renderer
renderer
  let Rectangle Point V2 CInt
_ (V2 CInt
w CInt
h) = Rectangle CInt
quadRectangle
  Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> CDouble
-> Maybe (Point V2 CInt)
-> V2 Bool
-> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> CDouble
-> Maybe (Point V2 CInt)
-> V2 Bool
-> m ()
SDL.copyEx Renderer
renderer Texture
quadTexture (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
quadRectangle) (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just (Rectangle CInt -> Maybe (Rectangle CInt))
-> Rectangle CInt -> Maybe (Rectangle CInt)
forall a b. (a -> b) -> a -> b
$ Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
Rectangle (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (CInt
w CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sx) (CInt
h CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sy))) CDouble
0 Maybe (Point V2 CInt)
forall a. Maybe a
Nothing (Bool -> Bool -> V2 Bool
forall a. a -> a -> V2 a
V2 Bool
flipX Bool
flipY)

-- |Draw a line from one point to another
line ::
  -- |X coordinate of one end of the line
  Int ->
  -- |Y coordinate of one end of the line
  Int ->
  -- |X coordinate of the other end of the line
  Int ->
  -- |Y coordinate of the other end of the line
  Int ->
  TwirlMonad ()
line :: Int -> Int -> Int -> Int -> TwirlMonad ()
line Int
x1 Int
y1 Int
x2 Int
y2 = do
  let point1 :: Point V2 CInt
point1 = V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x1 :: CInt) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y1 :: CInt)
      point2 :: Point V2 CInt
point2 = V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x2 :: CInt) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y2 :: CInt)
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  Renderer -> Point V2 CInt -> Point V2 CInt -> TwirlMonad ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Renderer -> Point V2 CInt -> Point V2 CInt -> m ()
SDL.drawLine (TwirlContext -> Renderer
renderer TwirlContext
context) Point V2 CInt
point1 Point V2 CInt
point2

polyLine :: [(Int, Int)] -> TwirlMonad ()
polyLine :: [(Int, Int)] -> TwirlMonad ()
polyLine [(Int, Int)]
coordinates = do
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  let points :: Vector (Point V2 CInt)
points = [Point V2 CInt] -> Vector (Point V2 CInt)
forall a. Storable a => [a] -> Vector a
fromList ([Point V2 CInt] -> Vector (Point V2 CInt))
-> [Point V2 CInt] -> Vector (Point V2 CInt)
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Point V2 CInt) -> [(Int, Int)] -> [Point V2 CInt]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
x, Int
y) -> V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) [(Int, Int)]
coordinates
  Renderer -> Vector (Point V2 CInt) -> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Vector (Point V2 CInt) -> m ()
SDL.drawLines (TwirlContext -> Renderer
renderer TwirlContext
context) Vector (Point V2 CInt)
points

-- |Draw an axis aligned rectangle
rectangle ::
  -- |X coordinate of the rectangle
  Int ->
  -- |Y coordinate of the rectangle
  Int ->
  -- |Width of the rectangle
  Int ->
  -- |Height of the rectangle
  Int ->
  FillMode ->
  TwirlMonad ()
rectangle :: Int -> Int -> Int -> Int -> FillMode -> TwirlMonad ()
rectangle Int
x Int
y Int
width Int
height FillMode
fillMode = do
  Renderer
rend <- (TwirlContext -> Renderer) -> TwirlMonad Renderer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Renderer
renderer
  let pos :: Point V2 CInt
pos = V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
      dimensions :: V2 CInt
dimensions = CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)
      rect :: Rectangle CInt
rect = Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
Rectangle Point V2 CInt
pos V2 CInt
dimensions
  case FillMode
fillMode of
    FillMode
Fill -> Renderer -> Maybe (Rectangle CInt) -> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Maybe (Rectangle CInt) -> m ()
SDL.fillRect Renderer
rend (Maybe (Rectangle CInt) -> TwirlMonad ())
-> Maybe (Rectangle CInt) -> TwirlMonad ()
forall a b. (a -> b) -> a -> b
$ Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
rect
    FillMode
Hollow -> Renderer -> Maybe (Rectangle CInt) -> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Maybe (Rectangle CInt) -> m ()
SDL.drawRect Renderer
rend (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just Rectangle CInt
rect)

-- |Draw a circle
--
-- The drawn shape is not actually a circle, but rather a polygon consisting
-- of a number of segments. Larger value results in a smoother circle,
-- but is slower to draw.
circle ::
  -- |X coordinate of the top-left "corner" of the circle
  Int ->
  -- |Y coordinate of the top-left "corner" of the circle
  Int ->
  -- |Radius of the circle
  Double ->
  -- |How many segments the circle should be made of
  Int ->
  -- |Whether to draw the circle hollow or filled
  FillMode ->
  TwirlMonad ()
circle :: Int -> Int -> Double -> Int -> FillMode -> TwirlMonad ()
circle Int
x Int
y Double
radius Int
segments FillMode
fill = do
  let points :: Vector (Point V2 CInt)
points = Int -> (Int -> Point V2 CInt) -> Vector (Point V2 CInt)
forall a. Storable a => Int -> (Int -> a) -> Vector a
generate (Int
segments Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Point V2 CInt
forall {a} {p}. (Num a, Integral p) => p -> Point V2 a
arcPoint
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  Renderer -> Vector (Point V2 CInt) -> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer -> Vector (Point V2 CInt) -> m ()
SDL.drawLines (TwirlContext -> Renderer
renderer TwirlContext
context) Vector (Point V2 CInt)
points
  case FillMode
fill of
    FillMode
Fill -> Vector (Point V2 CInt) -> TwirlMonad ()
fillPolygon Vector (Point V2 CInt)
points
    FillMode
Hollow -> () -> TwirlMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
 where
  arcPoint :: p -> Point V2 a
arcPoint p
i =
    let theta :: Double
theta = p -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
segments Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi
        x' :: Double
x' = Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
theta
        y' :: Double
y' = Double
radius Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
theta
     in V2 a -> Point V2 a
forall (f :: * -> *) a. f a -> Point f a
P (V2 a -> Point V2 a) -> V2 a -> Point V2 a
forall a b. (a -> b) -> a -> b
$ a -> a -> V2 a
forall a. a -> a -> V2 a
V2 (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
x' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round Double
y' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y)

intersectionX :: CInt -> Point V2 CInt -> Point V2 CInt -> Maybe CInt
intersectionX :: CInt -> Point V2 CInt -> Point V2 CInt -> Maybe CInt
intersectionX CInt
y (P (V2 CInt
x1 CInt
y1)) (P (V2 CInt
x2 CInt
y2))
  | CInt
y1 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
y2 = Maybe CInt
forall a. Maybe a
Nothing
  | (CInt
y1 CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
y Bool -> Bool -> Bool
&& CInt
y CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
y2) Bool -> Bool -> Bool
|| (CInt
y2 CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
y Bool -> Bool -> Bool
&& CInt
y CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
y1) =
      let a :: Double
          a :: Double
a =
            (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x2)
              Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y2)
       in CInt -> Maybe CInt
forall a. a -> Maybe a
Just (CInt -> Maybe CInt) -> CInt -> Maybe CInt
forall a b. (a -> b) -> a -> b
$
            Double -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> CInt) -> Double -> CInt
forall a b. (a -> b) -> a -> b
$ CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x1
  | Bool
otherwise = Maybe CInt
forall a. Maybe a
Nothing

fillPolygon :: Vector (Point V2 CInt) -> TwirlMonad ()
fillPolygon :: Vector (Point V2 CInt) -> TwirlMonad ()
fillPolygon Vector (Point V2 CInt)
points = do
  let (P (V2 CInt
_ CInt
maxY)) = (Point V2 CInt -> Point V2 CInt -> Ordering)
-> Vector (Point V2 CInt) -> Point V2 CInt
forall a. Storable a => (a -> a -> Ordering) -> Vector a -> a
maximumBy Point V2 CInt -> Point V2 CInt -> Ordering
forall {a}. Ord a => Point V2 a -> Point V2 a -> Ordering
comparePointY Vector (Point V2 CInt)
points
      (P (V2 CInt
_ CInt
minY)) = (Point V2 CInt -> Point V2 CInt -> Ordering)
-> Vector (Point V2 CInt) -> Point V2 CInt
forall a. Storable a => (a -> a -> Ordering) -> Vector a -> a
minimumBy Point V2 CInt -> Point V2 CInt -> Ordering
forall {a}. Ord a => Point V2 a -> Point V2 a -> Ordering
comparePointY Vector (Point V2 CInt)
points
  (CInt -> TwirlMonad ()) -> [CInt] -> TwirlMonad ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Point V2 CInt] -> CInt -> TwirlMonad ()
scanLine (Vector (Point V2 CInt) -> [Point V2 CInt]
forall a. Storable a => Vector a -> [a]
toList Vector (Point V2 CInt)
points)) [CInt
minY .. CInt
maxY]
 where
  comparePointY :: Point V2 a -> Point V2 a -> Ordering
comparePointY (P (V2 a
_ a
y)) (P (V2 a
_ a
y2)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
y a
y2

scanLine :: [Point V2 CInt] -> CInt -> TwirlMonad ()
scanLine :: [Point V2 CInt] -> CInt -> TwirlMonad ()
scanLine [Point V2 CInt]
points CInt
y = do
  let xs :: [CInt]
xs = [Point V2 CInt] -> CInt -> [CInt]
findXs [Point V2 CInt]
points CInt
y
  CInt -> [CInt] -> TwirlMonad ()
paintScans CInt
y [CInt]
xs
 where
  findXs :: [Point V2 CInt] -> CInt -> [CInt]
findXs [Point V2 CInt]
pts CInt
y' =
    let polygonLines :: [(Point V2 CInt, Point V2 CInt)]
polygonLines = [Point V2 CInt]
-> [Point V2 CInt] -> [(Point V2 CInt, Point V2 CInt)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Point V2 CInt]
pts ([Point V2 CInt] -> [Point V2 CInt]
forall a. [a] -> [a]
tail [Point V2 CInt]
pts)
     in [CInt] -> [CInt]
forall a. Eq a => [a] -> [a]
nub ([CInt] -> [CInt]) -> [CInt] -> [CInt]
forall a b. (a -> b) -> a -> b
$
          ([CInt] -> (Point V2 CInt, Point V2 CInt) -> [CInt])
-> [CInt] -> [(Point V2 CInt, Point V2 CInt)] -> [CInt]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
            ( \[CInt]
xs (Point V2 CInt
p1, Point V2 CInt
p2) ->
                case CInt -> Point V2 CInt -> Point V2 CInt -> Maybe CInt
intersectionX CInt
y' Point V2 CInt
p1 Point V2 CInt
p2 of
                  Just CInt
x -> CInt
x CInt -> [CInt] -> [CInt]
forall a. a -> [a] -> [a]
: [CInt]
xs
                  Maybe CInt
Nothing -> [CInt]
xs
            )
            []
            [(Point V2 CInt, Point V2 CInt)]
polygonLines
  paintScans :: CInt -> [CInt] -> TwirlMonad ()
  paintScans :: CInt -> [CInt] -> TwirlMonad ()
paintScans CInt
y' (CInt
x1 : CInt
x2 : [CInt]
xs) = do
    TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
    Renderer -> Point V2 CInt -> Point V2 CInt -> TwirlMonad ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Renderer -> Point V2 CInt -> Point V2 CInt -> m ()
SDL.drawLine (TwirlContext -> Renderer
renderer TwirlContext
context) (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 CInt
x1 CInt
y')) (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 CInt
x2 CInt
y'))
    CInt -> [CInt] -> TwirlMonad ()
paintScans CInt
y [CInt]
xs
  paintScans CInt
_ [CInt
_] = () -> TwirlMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  paintScans CInt
_ [] = () -> TwirlMonad ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |Set the drawing colour for the next 'TwirlMonad's
setColor ::
  -- | Red channel value in the interval @[0,255]@
  Int ->
  -- | Green channel value in the interval @[0,255]@
  Int ->
  -- | Blue channel value in the interval @[0,255]@
  Int ->
  -- | Alpha value in the interval @[0,255]@
  Int ->
  TwirlMonad ()
setColor :: Int -> Int -> Int -> Int -> TwirlMonad ()
setColor Int
r Int
g Int
b Int
a = do
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor (TwirlContext -> Renderer
renderer TwirlContext
context)
    StateVar (V4 Word8) -> V4 Word8 -> TwirlMonad ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
V4 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
g) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b) (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a)

setLogicalSize :: Int -> Int -> TwirlMonad ()
setLogicalSize :: Int -> Int -> TwirlMonad ()
setLogicalSize Int
w Int
h = do
  Renderer
renderer <- (TwirlContext -> Renderer) -> TwirlMonad Renderer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Renderer
renderer
  Renderer -> StateVar (Maybe (V2 CInt))
SDL.rendererLogicalSize Renderer
renderer StateVar (Maybe (V2 CInt)) -> Maybe (V2 CInt) -> TwirlMonad ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= V2 CInt -> Maybe (V2 CInt)
forall a. a -> Maybe a
Just (CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h))

setWindowSize :: Int -> Int -> TwirlMonad ()
setWindowSize :: Int -> Int -> TwirlMonad ()
setWindowSize Int
w Int
h = do
  Window
window <- (TwirlContext -> Window) -> TwirlMonad Window
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Window
window
  Window -> StateVar (V2 CInt)
SDL.windowSize Window
window StateVar (V2 CInt) -> V2 CInt -> TwirlMonad ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)

setWindowMode :: WindowMode -> TwirlMonad ()
setWindowMode :: WindowMode -> TwirlMonad ()
setWindowMode WindowMode
mode = do
  Window
window <- (TwirlContext -> Window) -> TwirlMonad Window
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Window
window
  Window -> WindowMode -> TwirlMonad ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
mode

loadFont :: (MonadIO m) => FilePath -> PointSize -> m Font
loadFont :: forall (m :: * -> *). MonadIO m => FilePath -> Int -> m Font
loadFont = FilePath -> Int -> m Font
forall (m :: * -> *). MonadIO m => FilePath -> Int -> m Font
Font.load

loadDefaultFont :: MonadIO m => m Font
loadDefaultFont :: forall (m :: * -> *). MonadIO m => m Font
loadDefaultFont = ByteString -> Int -> m Font
forall (m :: * -> *). MonadIO m => ByteString -> Int -> m Font
Font.decode ByteString
defaultFontData Int
16

defaultFontData :: ByteString
defaultFontData :: ByteString
defaultFontData = $(embedFile "PixelOperator.ttf")

setFont :: Font -> TwirlMonad ()
setFont :: Font -> TwirlMonad ()
setFont Font
newFont =
  (TwirlContext -> TwirlContext) -> TwirlMonad ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TwirlContext
context -> TwirlContext
context{font :: Font
font = Font
newFont})

data RenderedText = RenderedText
  { RenderedText -> V2 CInt
dimensions :: !(V2 CInt)
  , RenderedText -> Texture
texture :: !Texture
  }

renderText :: Text -> TwirlMonad RenderedText
renderText :: Text -> TwirlMonad RenderedText
renderText Text
text = do
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  V4 Word8
color <- StateVar (V4 Word8) -> TwirlMonad (V4 Word8)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get (StateVar (V4 Word8) -> TwirlMonad (V4 Word8))
-> StateVar (V4 Word8) -> TwirlMonad (V4 Word8)
forall a b. (a -> b) -> a -> b
$ Renderer -> StateVar (V4 Word8)
SDL.rendererDrawColor (Renderer -> StateVar (V4 Word8))
-> Renderer -> StateVar (V4 Word8)
forall a b. (a -> b) -> a -> b
$ TwirlContext -> Renderer
renderer TwirlContext
context
  Surface
renderedSurface <- Font -> V4 Word8 -> Text -> TwirlMonad Surface
forall (m :: * -> *).
MonadIO m =>
Font -> V4 Word8 -> Text -> m Surface
Font.solid (TwirlContext -> Font
font TwirlContext
context) V4 Word8
color Text
text
  V2 CInt
surfaceDimensions <- Surface -> TwirlMonad (V2 CInt)
forall (m :: * -> *). MonadIO m => Surface -> m (V2 CInt)
SDL.surfaceDimensions Surface
renderedSurface
  Texture
texture <- Renderer -> Surface -> TwirlMonad Texture
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Renderer -> Surface -> m Texture
SDL.createTextureFromSurface (TwirlContext -> Renderer
renderer TwirlContext
context) Surface
renderedSurface
  RenderedText -> TwirlMonad RenderedText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedText -> TwirlMonad RenderedText)
-> RenderedText -> TwirlMonad RenderedText
forall a b. (a -> b) -> a -> b
$ V2 CInt -> Texture -> RenderedText
RenderedText V2 CInt
surfaceDimensions Texture
texture

printRenderedText :: RenderedText -> Int -> Int -> TwirlMonad ()
printRenderedText :: RenderedText -> Int -> Int -> TwirlMonad ()
printRenderedText RenderedText{V2 CInt
dimensions :: V2 CInt
dimensions :: RenderedText -> V2 CInt
dimensions, Texture
texture :: Texture
texture :: RenderedText -> Texture
texture} Int
x Int
y = do
  TwirlContext
context <- TwirlMonad TwirlContext
forall s (m :: * -> *). MonadState s m => m s
get
  Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> TwirlMonad ()
forall (m :: * -> *).
MonadIO m =>
Renderer
-> Texture
-> Maybe (Rectangle CInt)
-> Maybe (Rectangle CInt)
-> m ()
SDL.copy (TwirlContext -> Renderer
renderer TwirlContext
context) Texture
texture Maybe (Rectangle CInt)
forall a. Maybe a
Nothing (Rectangle CInt -> Maybe (Rectangle CInt)
forall a. a -> Maybe a
Just (Rectangle CInt -> Maybe (Rectangle CInt))
-> Rectangle CInt -> Maybe (Rectangle CInt)
forall a b. (a -> b) -> a -> b
$ Point V2 CInt -> V2 CInt -> Rectangle CInt
forall a. Point V2 a -> V2 a -> Rectangle a
Rectangle (V2 CInt -> Point V2 CInt
forall (f :: * -> *) a. f a -> Point f a
P (V2 CInt -> Point V2 CInt) -> V2 CInt -> Point V2 CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)) V2 CInt
dimensions)

printText :: Text -> Int -> Int -> TwirlMonad ()
printText :: Text -> Int -> Int -> TwirlMonad ()
printText Text
text Int
x Int
y = do
  RenderedText
rendered <- Text -> TwirlMonad RenderedText
renderText Text
text
  RenderedText -> Int -> Int -> TwirlMonad ()
printRenderedText RenderedText
rendered Int
x Int
y

setWindowTitle :: Text -> TwirlMonad ()
setWindowTitle :: Text -> TwirlMonad ()
setWindowTitle Text
title = do
  Window
window <- (TwirlContext -> Window) -> TwirlMonad Window
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TwirlContext -> Window
window
  Window -> StateVar Text
windowTitle Window
window StateVar Text -> Text -> TwirlMonad ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Text
title