{-# 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
drawTexture ::
Texture ->
Int ->
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)
line ::
Int ->
Int ->
Int ->
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
rectangle ::
Int ->
Int ->
Int ->
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)
circle ::
Int ->
Int ->
Double ->
Int ->
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 ()
setColor ::
Int ->
Int ->
Int ->
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