Graphics.hs

{-# 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 (Applicative, Functor, Monad, MonadIO, MonadState TwirlContext)

runTwirlMonad :: TwirlMonad a -> TwirlContext -> IO (a, TwirlContext)
runTwirlMonad (TwirlMonad action) initialState = runStateT action initialState

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

data FillMode
  = Fill
  | Hollow

loadTexture :: FilePath -> TwirlMonad Texture
loadTexture path = do
  renderer <- gets renderer
  SDL.Image.loadTexture renderer path

decodeTexture :: ByteString -> TwirlMonad Texture
decodeTexture texture = do
  renderer <- gets renderer
  SDL.Image.decodeTexture renderer 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 x y = do
  context <- get
  textureInfo <- SDL.queryTexture texture
  _ <-
    SDL.copy
      (renderer context)
      texture
      Nothing
      (Just (Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (SDL.textureWidth textureInfo) (SDL.textureHeight textureInfo))))
  return ()

data Quad = Quad
  { quadRectangle :: Rectangle CInt
  , quadTexture :: Texture
  }
  deriving (Eq)

mkQuad :: Texture -> Int -> Int -> Int -> Int -> Quad
mkQuad texture x y w h =
  Quad{quadRectangle = Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (fromIntegral w) (fromIntegral h)), quadTexture = texture}

quadWidth :: Quad -> Int
quadWidth Quad{quadRectangle = Rectangle _ (V2 w _)} = fromIntegral w

quadHeight :: Quad -> Int
quadHeight Quad{quadRectangle = Rectangle _ (V2 _ h)} = fromIntegral h

drawQuad :: Quad -> Int -> Int -> Int -> Int -> Bool -> Bool -> TwirlMonad ()
drawQuad Quad{quadRectangle, quadTexture} x y sx sy flipX flipY = do
  renderer <- gets renderer
  let Rectangle _ (V2 w h) = quadRectangle
  SDL.copyEx renderer quadTexture (Just quadRectangle) (Just $ Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (w * fromIntegral sx) (h * fromIntegral sy))) 0 Nothing (V2 flipX 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 x1 y1 x2 y2 = do
  let point1 = P $ V2 (fromIntegral x1 :: CInt) (fromIntegral y1 :: CInt)
      point2 = P $ V2 (fromIntegral x2 :: CInt) (fromIntegral y2 :: CInt)
  context <- get
  SDL.drawLine (renderer context) point1 point2

polyLine :: [(Int, Int)] -> TwirlMonad ()
polyLine coordinates = do
  context <- get
  let points = fromList $ map (\(x, y) -> P $ V2 (fromIntegral x) (fromIntegral y)) coordinates
  SDL.drawLines (renderer context) 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 x y width height fillMode = do
  rend <- gets renderer
  let pos = P $ V2 (fromIntegral x) (fromIntegral y)
      dimensions = V2 (fromIntegral width) (fromIntegral height)
      rect = Rectangle pos dimensions
  case fillMode of
    Fill -> SDL.fillRect rend $ Just rect
    Hollow -> SDL.drawRect rend (Just 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 x y radius segments fill = do
  let points = generate (segments + 1) arcPoint
  context <- get
  SDL.drawLines (renderer context) points
  case fill of
    Fill -> fillPolygon points
    Hollow -> return ()
 where
  arcPoint i =
    let theta = fromIntegral i / fromIntegral segments * 2 * pi
        x' = radius * cos theta
        y' = radius * sin theta
     in P $ V2 (fromIntegral $ round x' + x) (fromIntegral $ round y' + y)

intersectionX :: CInt -> Point V2 CInt -> Point V2 CInt -> Maybe CInt
intersectionX y (P (V2 x1 y1)) (P (V2 x2 y2))
  | y1 == y2 = Nothing
  | (y1 <= y && y <= y2) || (y2 <= y && y <= y1) =
      let a :: Double
          a =
            (fromIntegral x1 - fromIntegral x2)
              / (fromIntegral y1 - fromIntegral y2)
       in Just $
            round $ fromIntegral y * a - fromIntegral y1 * a + fromIntegral x1
  | otherwise = Nothing

fillPolygon :: Vector (Point V2 CInt) -> TwirlMonad ()
fillPolygon points = do
  let (P (V2 _ maxY)) = maximumBy comparePointY points
      (P (V2 _ minY)) = minimumBy comparePointY points
  mapM_ (scanLine (toList points)) [minY .. maxY]
 where
  comparePointY (P (V2 _ y)) (P (V2 _ y2)) = compare y y2

scanLine :: [Point V2 CInt] -> CInt -> TwirlMonad ()
scanLine points y = do
  let xs = findXs points y
  paintScans y xs
 where
  findXs pts y' =
    let polygonLines = zip pts (tail pts)
     in nub $
          foldl
            ( \xs (p1, p2) ->
                case intersectionX y' p1 p2 of
                  Just x -> x : xs
                  Nothing -> xs
            )
            []
            polygonLines
  paintScans :: CInt -> [CInt] -> TwirlMonad ()
  paintScans y' (x1 : x2 : xs) = do
    context <- get
    SDL.drawLine (renderer context) (P (V2 x1 y')) (P (V2 x2 y'))
    paintScans y xs
  paintScans _ [_] = return ()
  paintScans _ [] = 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 r g b a = do
  context <- get
  SDL.rendererDrawColor (renderer context)
    $= V4 (fromIntegral r) (fromIntegral g) (fromIntegral b) (fromIntegral a)

setLogicalSize :: Int -> Int -> TwirlMonad ()
setLogicalSize w h = do
  renderer <- gets renderer
  SDL.rendererLogicalSize renderer $= Just (V2 (fromIntegral w) (fromIntegral h))

setWindowSize :: Int -> Int -> TwirlMonad ()
setWindowSize w h = do
  window <- gets window
  SDL.windowSize window $= V2 (fromIntegral w) (fromIntegral h)

setWindowMode :: WindowMode -> TwirlMonad ()
setWindowMode mode = do
  window <- gets window
  SDL.setWindowMode window mode

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

loadDefaultFont :: MonadIO m => m Font
loadDefaultFont = Font.decode defaultFontData 16

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

setFont :: Font -> TwirlMonad ()
setFont newFont =
  modify (\context -> context{font = newFont})

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

renderText :: Text -> TwirlMonad RenderedText
renderText text = do
  context <- get
  color <- SDL.get $ SDL.rendererDrawColor $ renderer context
  renderedSurface <- Font.solid (font context) color text
  surfaceDimensions <- SDL.surfaceDimensions renderedSurface
  texture <- SDL.createTextureFromSurface (renderer context) renderedSurface
  pure $ RenderedText surfaceDimensions texture

printRenderedText :: RenderedText -> Int -> Int -> TwirlMonad ()
printRenderedText RenderedText{dimensions, texture} x y = do
  context <- get
  SDL.copy (renderer context) texture Nothing (Just $ Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) dimensions)

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

setWindowTitle :: Text -> TwirlMonad ()
setWindowTitle title = do
  window <- gets window
  windowTitle window $= title