Sprite.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Aztecs.GL.Sprite
  ( -- * Sprites
    Sprite (..),
    sprite,
    spriteMaterial,

    -- * Sprite Sheets
    SpriteSheet (..),
  )
where

import Aztecs
import Aztecs.GL.Image.Internal
import Aztecs.GL.Internal
import Aztecs.GL.Material
import Aztecs.GL.Shape
import Aztecs.Transform
import Control.Monad
import Control.Monad.IO.Class
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import Prelude hiding (lookup)

-- | Sprite component
data Sprite = Sprite
  { -- | Image component entity ID
    spriteImage :: !EntityID,
    -- | Clip rectangle of the sprite in the texture (top, left, width, height).
    -- If 'Nothing', uses full image.
    spriteClip :: Maybe (V4 Float),
    -- | Scale to apply to UV coordinates
    spriteScale :: !(V2 Float)
  }
  deriving (Eq)

instance (MonadIO m) => Component m Sprite where
  componentOnInsert e s = do
    mImageState <- lookup $ spriteImage s
    case mImageState of
      Just imgState@(ImageState _ imgSize@(V2 w h)) ->
        let (rectW, rectH) = case spriteClip s of
              Just (V4 _ _ clipW clipH) -> (clipW, clipH)
              Nothing -> (w, h)
         in insert e $ bundle (spriteMaterial s imgState imgSize) <> bundle (Rectangle rectW rectH)
      Nothing -> return ()
  componentOnChange e old new = when (old /= new) $ do
    mImageState <- lookup $ spriteImage new
    case mImageState of
      Just imgState@(ImageState _ imgSize@(V2 w h)) ->
        let (rectW, rectH) = case spriteClip new of
              Just (V4 _ _ clipW clipH) -> (clipW, clipH)
              Nothing -> (w, h)
         in insert e $ bundle (spriteMaterial new imgState imgSize) <> bundle (Rectangle rectW rectH)
      Nothing -> return ()

sprite :: EntityID -> Sprite
sprite imgE =
  Sprite
    { spriteImage = imgE,
      spriteClip = Nothing,
      spriteScale = V2 1 1
    }

-- | Create a sprite material with UV offset and scale based on sprite fields
spriteMaterial :: Sprite -> ImageState -> V2 Float -> Material
spriteMaterial s (ImageState tex _) (V2 imgW imgH) =
  let V2 scaleU scaleV = spriteScale s
      -- Calculate UV offset and scale based on clip rectangle
      (uvOffsetU, uvOffsetV, uvScaleU, uvScaleV) = case spriteClip s of
        Just (V4 top left clipW clipH) ->
          ( left / imgW,
            top / imgH,
            (clipW / imgW) * scaleU,
            (clipH / imgH) * scaleV
          )
        Nothing ->
          (0, 0, scaleU, scaleV)
   in Material $
        pure
          MaterialState
            { materialPush = do
                GL.texture GL.Texture2D $= GL.Enabled
                GL.textureBinding GL.Texture2D $= Just tex
                GL.textureFunction $= GL.Replace
                GL.color $ GL.Color4 1 1 1 (1 :: GL.GLfloat)

                -- Apply UV transform via texture matrix
                GL.matrixMode $= GL.Texture
                GL.loadIdentity
                GL.translate $ GL.Vector3 (realToFrac uvOffsetU) (realToFrac uvOffsetV) (0 :: GL.GLfloat)
                GL.scale (realToFrac uvScaleU) (realToFrac uvScaleV) (1 :: GL.GLfloat)
                GL.matrixMode $= GL.Modelview 0,
              materialPop = do
                -- Reset texture matrix
                GL.matrixMode $= GL.Texture
                GL.loadIdentity
                GL.matrixMode $= GL.Modelview 0

                GL.texture GL.Texture2D $= GL.Disabled
                GL.textureBinding GL.Texture2D $= Nothing
            }

-- | Sprite sheet component that controls a @Sprite@ on the same entity
data SpriteSheet = SpriteSheet
  { spriteSheetFrameIndex :: !(V2 Int),
    spriteSheetFrameSize :: !(V2 Int),
    spriteSheetFrameOffset :: !(V2 Int),
    spriteSheetFrameGap :: !(V2 Int)
  }

instance (MonadIO m) => Component m SpriteSheet where
  componentOnInsert = spriteSheetHook
  componentOnChange e _ = spriteSheetHook e

spriteSheetHook :: (MonadIO m) => EntityID -> SpriteSheet -> Access m ()
spriteSheetHook e sheet = do
  mSprite <- lookup e
  case mSprite of
    Just s ->
      let clip = spriteSheetClip sheet
       in insert e $ bundle s {spriteClip = Just clip}
    Nothing -> return ()

spriteSheetClip :: SpriteSheet -> V4 Float
spriteSheetClip sheet =
  let V2 frameX frameY = spriteSheetFrameIndex sheet
      V2 frameW frameH = spriteSheetFrameSize sheet
      V2 offsetX offsetY = spriteSheetFrameOffset sheet
      V2 gapX gapY = spriteSheetFrameGap sheet
      left = offsetX + frameX * (frameW + gapX)
      top = offsetY + frameY * (frameH + gapY)
   in V4 (fromIntegral top) (fromIntegral left) (fromIntegral frameW) (fromIntegral frameH)