aztecs-gl 0.2.1 → 0.3.0

raw patch · 15 files changed

+618/−610 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +1/−3
• aztecs-gl.cabal +7/−6
• src/Aztecs/GL.hs +0/−99
• src/Aztecs/GL/D2.hs +116/−0
• src/Aztecs/GL/D2/Image.hs +67/−0
• src/Aztecs/GL/D2/Image/Internal.hs +18/−0
• src/Aztecs/GL/D2/Shape.hs +253/−0
• src/Aztecs/GL/D2/Sprite.hs +128/−0
• src/Aztecs/GL/Image.hs +0/−66
• src/Aztecs/GL/Image/Internal.hs +0/−18
• src/Aztecs/GL/Internal.hs +27/−12
• src/Aztecs/GL/Material.hs +1/−3
• src/Aztecs/GL/Render.hs +0/−15
• src/Aztecs/GL/Shape.hs +0/−253
• src/Aztecs/GL/Sprite.hs +0/−135

@@ -1,5 +1,3 @@ # Revision history for aztecs-gl -## 0.1.0.0 -- YYYY-mm-dd--* First version. Released on an unsuspecting world.+## [0.1.0](https://github.com/aztecs-hs/aztecs-gl/v0.1.0) - 2026-1-27

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            aztecs-gl-version:         0.2.1+version:         0.3.0 license:         BSD-3-Clause license-file:    LICENSE maintainer:      matt@hunzinger.me@@ -19,14 +19,15 @@ library     exposed-modules:         Aztecs.GL-        Aztecs.GL.Image-        Aztecs.GL.Image.Internal+        Aztecs.GL.D2+        Aztecs.GL.D2.Image+        Aztecs.GL.D2.Image.Internal+        Aztecs.GL.D2.Shape+        Aztecs.GL.D2.Sprite         Aztecs.GL.Internal         Aztecs.GL.Material         Aztecs.GL.Mesh-        Aztecs.GL.Render-        Aztecs.GL.Shape-        Aztecs.GL.Sprite+              hs-source-dirs:   src     default-language: Haskell2010

@@ -1,112 +1,13 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}- module Aztecs.GL   ( -- * OpenGL-    module Aztecs.GL.Image,     module Aztecs.GL.Material,     module Aztecs.GL.Mesh,-    module Aztecs.GL.Render,-    module Aztecs.GL.Shape,-    module Aztecs.GL.Sprite,-    render,      -- * Transform     module Aztecs.Transform,   ) where -import Aztecs-import Aztecs.GL.Image-import Aztecs.GL.Internal import Aztecs.GL.Material import Aztecs.GL.Mesh-import Aztecs.GL.Render-import Aztecs.GL.Shape-import Aztecs.GL.Sprite-import Aztecs.GLFW import Aztecs.Transform-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.Map.Strict as Map-import Graphics.Rendering.OpenGL (($=))-import qualified Graphics.Rendering.OpenGL as GL-import qualified Graphics.UI.GLFW as GLFW-import Prelude hiding (lookup)---- | Render all entities with @Mesh@ or @OfMesh@, @Material@ or @OfMaterial@, and @Transform2D@ components-render :: (MonadIO m) => Access m ()-render = do-  windows <- system . readQuery $ (,) <$> query @_ @Window <*> query @_ @RawWindow-  forM_ windows $ \(window, RawWindow raw _) -> do-    liftIO $ do-      GLFW.makeContextCurrent (Just raw)--      -- Set viewport and clear-      GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral $ windowWidth window) (fromIntegral $ windowHeight window))-      GL.clearColor $= GL.Color4 0 0 0 1-      GL.clear [GL.ColorBuffer]--      -- Set up orthographic projection-      GL.matrixMode $= GL.Projection-      GL.loadIdentity-      GL.ortho 0 (fromIntegral $ windowWidth window) 0 (fromIntegral $ windowHeight window) (-1) 1-      GL.matrixMode $= GL.Modelview 0-      GL.loadIdentity--    -- Get render groups and render each group-    (_, RenderGroups groups) <- renderGroups-    forM_ (Map.toList groups) $ \((meshE, matE), entities) -> do-      mMeshState <- do-        mMeshState <- lookup meshE-        case mMeshState of-          Just ms -> return $ Just ms-          Nothing -> do-            mMesh <- lookup meshE-            case mMesh of-              Just mesh -> do-                ms <- liftIO $ unMesh mesh-                insert meshE $ bundle ms-                return $ Just ms-              Nothing -> return Nothing-      mMatState <- do-        mMatState <- lookup matE-        case mMatState of-          Just ms -> return $ Just ms-          Nothing -> do-            mMat <- lookup matE-            case mMat of-              Just mat -> do-                ms <- liftIO $ unMaterial mat-                insert matE $ bundle ms-                return $ Just ms-              Nothing -> return Nothing-      case (mMeshState, mMatState) of-        (Just meshState, Just matState) -> do-          transforms <- forM entities $ \e -> do-            mTrans <- lookup e-            return (e, mTrans)--          liftIO $ do-            materialPush matState-            forM_ transforms $ \(_, mTrans) ->-              case mTrans of-                Just trans -> renderMeshWithTransform meshState trans-                Nothing -> return ()-            materialPop matState-        _ -> return ()--renderMeshWithTransform :: MeshState -> Transform2D -> IO ()-renderMeshWithTransform md t = do-  let V2 tx ty = transformTranslation t-      V2 sx sy = transformScale t-      rot = transformRotation t-  GL.preservingMatrix $ do-    GL.translate $ GL.Vector3 (realToFrac tx) (realToFrac ty) (0 :: GL.GLfloat)-    GL.rotate (realToFrac rot) $ GL.Vector3 0 0 (1 :: GL.GLfloat)-    GL.scale (realToFrac sx) (realToFrac sy) (1 :: GL.GLfloat)-    meshPush md-    meshPop md

@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.D2+  ( -- * OpenGL+    module Aztecs.GL.D2.Image,+    module Aztecs.GL.Material,+    module Aztecs.GL.Mesh,+    module Aztecs.GL.D2.Shape,+    module Aztecs.GL.D2.Sprite,+    render,++    -- * Transform+    module Aztecs.Transform,+  )+where++import Aztecs+import Aztecs.GL.D2.Image+import Aztecs.GL.D2.Shape+import Aztecs.GL.D2.Sprite+import Aztecs.GL.Internal+import Aztecs.GL.Material+import Aztecs.GL.Mesh+import Aztecs.GLFW+import Aztecs.Transform+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Graphics.Rendering.OpenGL (($=))+import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLFW as GLFW+import Prelude hiding (lookup)++-- | Render all entities with @Mesh@ or @OfMesh@, @Material@ or @OfMaterial@, and @Transform2D@ components+render :: (MonadIO m) => Access m ()+render = do+  windows <- system . readQuery $ (,) <$> query @_ @Window <*> query @_ @RawWindow+  forM_ windows $ \(window, RawWindow raw _) -> do+    liftIO $ do+      GLFW.makeContextCurrent (Just raw)++      -- Set viewport and clear+      GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral $ windowWidth window) (fromIntegral $ windowHeight window))+      GL.clearColor $= GL.Color4 0 0 0 1+      GL.clear [GL.ColorBuffer]++      -- Set up orthographic projection+      GL.matrixMode $= GL.Projection+      GL.loadIdentity+      GL.ortho 0 (fromIntegral $ windowWidth window) 0 (fromIntegral $ windowHeight window) (-1) 1+      GL.matrixMode $= GL.Modelview 0+      GL.loadIdentity++    -- Get render groups and render each group+    (_, RenderGroups groups) <- renderGroups+    forM_ (Map.toList groups) $ \(RenderGroupKey meshE matE, entityEs) -> renderGroup meshE matE entityEs++-- | Render all entities with @Mesh@ or @OfMesh@, @Material@ or @OfMaterial@, and @Transform2D@ components+renderGroup :: (MonadIO m) => EntityID -> EntityID -> Set.Set EntityID -> Access m ()+renderGroup meshE matE entitySet = do+  let entities = Set.toList entitySet+  mMeshState <- do+    mMeshState <- lookup meshE+    case mMeshState of+      Just ms -> return $ Just ms+      Nothing -> do+        mMesh <- lookup meshE+        case mMesh of+          Just mesh -> do+            ms <- liftIO $ unMesh mesh+            insert meshE $ bundle ms+            return $ Just ms+          Nothing -> return Nothing+  mMatState <- do+    mMatState <- lookup matE+    case mMatState of+      Just ms -> return $ Just ms+      Nothing -> do+        mMat <- lookup matE+        case mMat of+          Just mat -> do+            ms <- liftIO $ unMaterial mat+            insert matE $ bundle ms+            return $ Just ms+          Nothing -> return Nothing+  case (mMeshState, mMatState) of+    (Just meshState, Just matState) -> do+      transforms <- forM entities $ \e -> do+        mTrans <- lookup e+        return (e, mTrans)++      liftIO $ do+        materialPush matState+        forM_ transforms $ \(_, mTrans) ->+          case mTrans of+            Just (GlobalTransform trans) -> renderMeshWithTransform meshState trans+            Nothing -> return ()+        materialPop matState+    _ -> return ()++renderMeshWithTransform :: MeshState -> Transform2D -> IO ()+renderMeshWithTransform md t = do+  let V2 tx ty = transformTranslation t+      V2 sx sy = transformScale t+      rot = transformRotation t+  GL.preservingMatrix $ do+    GL.translate $ GL.Vector3 (realToFrac tx) (realToFrac ty) (0 :: GL.GLfloat)+    GL.rotate (realToFrac rot) $ GL.Vector3 0 0 (1 :: GL.GLfloat)+    GL.scale (realToFrac sx) (realToFrac sy) (1 :: GL.GLfloat)+    meshPush md+    meshPop md

@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.GL.D2.Image (Image (..), loadImage, TextureFilter (..)) where++import Aztecs+import Aztecs.GL.D2.Image.Internal+import Aztecs.GL.Internal+import Aztecs.Transform+import qualified Codec.Picture as JP+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString as BS+import qualified Data.Vector.Storable as VS+import Foreign+import Graphics.Rendering.OpenGL (($=))+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Rendering.OpenGL.GL (TextureFilter (..))+import Prelude hiding (lookup)++-- | Image component+data Image = Image+  { -- | Image source data+    imageData :: JP.Image JP.PixelRGBA8,+    -- | Image texture filtering mode+    imageFilter :: !TextureFilter+  }++instance (MonadIO m) => Component m Image where+  componentOnInsert e img = inAnyWindowContext $ do+    let w = JP.imageWidth $ imageData img+        h = JP.imageHeight $ imageData img+        pixels = JP.imageData $ imageData img+        imgData = BS.pack $ VS.toList pixels++    res <- liftIO $ GL.genObjectNames 1+    tex <- case res of+      [tex] -> return tex+      _ -> error "Failed to generate texture object"++    liftIO $ do+      GL.textureBinding GL.Texture2D $= Just tex++      -- Set texture parameters (use Nearest filtering for crisp pixel art)+      GL.textureFilter GL.Texture2D $= ((imageFilter img, Nothing), imageFilter img)+      GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)+      GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)++      -- Upload texture data+      BS.useAsCString imgData $ \ptr -> do+        GL.texImage2D+          GL.Texture2D+          GL.NoProxy+          0+          GL.RGBA8+          (GL.TextureSize2D (fromIntegral w) (fromIntegral h))+          0+          (GL.PixelData GL.RGBA GL.UnsignedByte (castPtr ptr))+      GL.textureBinding GL.Texture2D $= Nothing+    insert e . bundle $ ImageState tex (V2 (fromIntegral w) (fromIntegral h))++loadImage :: FilePath -> IO Image+loadImage path = do+  eImg <- JP.readImage path+  case eImg of+    Left err -> error $ "Failed to load image: " ++ err+    Right dynImg -> let img = JP.convertRGBA8 dynImg in return $ Image img GL.Nearest

@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.GL.D2.Image.Internal (ImageState (..)) where++import Aztecs+import Aztecs.Transform+import Control.Monad+import qualified Graphics.Rendering.OpenGL as GL+import Prelude hiding (lookup)++-- | Image state component+data ImageState = ImageState+  { imageTexture :: !GL.TextureObject,+    imageSize :: !(V2 Float)+  }++instance (Monad m) => Component m ImageState

@@ -0,0 +1,253 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.D2.Shape+  ( -- * Shapes+    Rectangle (..),+    Circle (..),+    Triangle (..),+  )+where++import Aztecs+import Aztecs.GL.Internal+import Aztecs.GL.Mesh+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Vector.Storable as SV+import Foreign.Ptr+import Foreign.Storable+import Graphics.Rendering.OpenGL (($=))+import qualified Graphics.Rendering.OpenGL as GL+import Prelude hiding (lookup)++-- | Rectangle component+data Rectangle = Rectangle+  { rectangleWidth :: !Float,+    rectangleHeight :: !Float+  }+  deriving (Show, Eq)++instance (MonadIO m) => Component m Rectangle where+  componentOnInsert e rect = inParentWindowContext e $ do+    let mesh = compileRectangle rect+    meshE <- spawn $ bundle mesh+    insert e $ bundle (OfMesh meshE)+  componentOnChange e oldRect newRect = when (oldRect /= newRect) . inParentWindowContext e $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        mData <- lookup meshE+        case mData of+          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)+          Nothing -> return ()+        let newMesh = compileRectangle newRect+        meshData <- liftIO $ unMesh newMesh+        insert meshE $ bundle meshData+      Nothing -> do+        let mesh = compileRectangle newRect+        meshE <- spawn $ bundle mesh+        insert e $ bundle (OfMesh meshE)+  componentOnRemove e _ = inParentWindowContext e $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        mData <- lookup meshE+        case mData of+          Just md -> do+            liftIO $ GL.deleteObjectName (meshVbo md)+            despawn meshE+          Nothing -> return ()+        _ <- remove @_ @OfMesh e+        return ()+      Nothing -> return ()++-- | Circle component+data Circle = Circle+  { circleRadius :: !Float,+    circleSegments :: !Int+  }+  deriving (Show, Eq)++instance (MonadIO m) => Component m Circle where+  componentOnInsert e circ = inParentWindowContext e $ do+    let mesh = compileCircle circ+    meshE <- spawn $ bundle mesh+    insert e $ bundle (OfMesh meshE)+  componentOnChange e oldCirc newCirc = when (oldCirc /= newCirc) . inParentWindowContext e $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        mData <- lookup meshE+        case mData of+          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)+          Nothing -> return ()+        let newMesh = compileCircle newCirc+        meshData <- liftIO $ unMesh newMesh+        insert meshE $ bundle meshData+      Nothing -> do+        let mesh = compileCircle newCirc+        meshE <- spawn $ bundle mesh+        insert e $ bundle (OfMesh meshE)+  componentOnRemove e _ = inParentWindowContext e $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        mData <- lookup meshE+        case mData of+          Just md -> do+            liftIO $ GL.deleteObjectName (meshVbo md)+            despawn meshE+          Nothing -> return ()+        _ <- remove @_ @OfMesh e+        return ()+      Nothing -> return ()++-- | Triangle component+data Triangle = Triangle+  { triangleX1 :: !Float,+    triangleY1 :: !Float,+    triangleX2 :: !Float,+    triangleY2 :: !Float,+    triangleX3 :: !Float,+    triangleY3 :: !Float+  }+  deriving (Show, Eq)++instance (MonadIO m) => Component m Triangle where+  componentOnInsert e tri = inParentWindowContext e $ do+    let mesh = compileTriangle tri+    meshE <- spawn $ bundle mesh+    insert e $ bundle (OfMesh meshE)+  componentOnChange e oldTri newTri = when (oldTri /= newTri) . inParentWindowContext e $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        mData <- lookup meshE+        case mData of+          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)+          Nothing -> return ()+        let newMesh = compileTriangle newTri+        meshData <- liftIO $ unMesh newMesh+        insert meshE $ bundle meshData+      Nothing -> do+        let mesh = compileTriangle newTri+        meshE <- spawn $ bundle mesh+        insert e $ bundle (OfMesh meshE)+  componentOnRemove e _ = inParentWindowContext e $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        mData <- lookup meshE+        case mData of+          Just md -> do+            liftIO $ GL.deleteObjectName (meshVbo md)+            despawn meshE+          Nothing -> return ()+        _ <- remove @_ @OfMesh e+        return ()+      Nothing -> return ()++-- | Compile a rectangle into a VBO mesh with texture coordinates+compileRectangle :: Rectangle -> Mesh+compileRectangle (Rectangle w h) =+  let hw = w / 2+      hh = h / 2+      -- Interleaved: x, y, u, v for each vertex (V flipped for OpenGL)+      vertices =+        SV.fromList+          [ -hw,+            -hh,+            0,+            1, -- bottom-left+            hw,+            -hh,+            1,+            1, -- bottom-right+            hw,+            hh,+            1,+            0, -- top-right+            -hw,+            hh,+            0,+            0 -- top-left+          ] ::+          SV.Vector GL.GLfloat+   in compileMeshWithUV vertices GL.Quads++-- | Compile a circle into a VBO mesh+compileCircle :: Circle -> Mesh+compileCircle (Circle radius segments) =+  let angles = [2 * pi * fromIntegral i / fromIntegral segments | i <- [0 .. segments]]+      vertices = SV.fromList $ [0, 0] ++ concatMap (\a -> [radius * cos a, radius * sin a]) angles :: SV.Vector GL.GLfloat+   in compileMesh vertices GL.TriangleFan++-- | Compile a triangle into a VBO mesh+compileTriangle :: Triangle -> Mesh+compileTriangle (Triangle x1 y1 x2 y2 x3 y3) =+  let vertices = SV.fromList [x1, y1, x2, y2, x3, y3] :: SV.Vector GL.GLfloat+   in compileMesh vertices GL.Triangles++-- | Compile vertices into a VBO mesh (position only)+compileMesh :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> Mesh+compileMesh vertices mode = Mesh $ do+  let vertexCount = fromIntegral $ SV.length vertices `div` 2+  vbo <- uploadVbo vertices+  return $ simpleMeshState vbo vertexCount mode++-- | Compile vertices with UV into a VBO mesh (interleaved: x, y, u, v)+compileMeshWithUV :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> Mesh+compileMeshWithUV vertices mode = Mesh $ do+  let vertexCount = fromIntegral $ SV.length vertices `div` 4+  vbo <- uploadVbo vertices+  return $ texturedMeshState vbo vertexCount mode++-- | Upload vertex data to a new VBO+uploadVbo :: SV.Vector GL.GLfloat -> IO GL.BufferObject+uploadVbo vertices = do+  [vbo] <- GL.genObjectNames 1+  GL.bindBuffer GL.ArrayBuffer $= Just vbo+  SV.unsafeWith vertices $ \ptr -> do+    let dataSize = fromIntegral $ SV.length vertices * sizeOf (undefined :: GL.GLfloat)+    GL.bufferData GL.ArrayBuffer $= (dataSize, ptr, GL.StaticDraw)+  GL.bindBuffer GL.ArrayBuffer $= Nothing+  return vbo++-- | Create MeshState for non-textured mesh (position only, stride 0)+simpleMeshState :: GL.BufferObject -> GL.GLint -> GL.PrimitiveMode -> MeshState+simpleMeshState vbo vertexCount mode =+  MeshState+    { meshVbo = vbo,+      meshPush = do+        GL.bindBuffer GL.ArrayBuffer $= Just vbo+        GL.clientState GL.VertexArray $= GL.Enabled+        GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 0 nullPtr+        GL.drawArrays mode 0 vertexCount,+      meshPop = do+        GL.clientState GL.VertexArray $= GL.Disabled+        GL.bindBuffer GL.ArrayBuffer $= Nothing+    }++-- | Create MeshState for textured mesh (interleaved x,y,u,v, stride 16)+texturedMeshState :: GL.BufferObject -> GL.GLint -> GL.PrimitiveMode -> MeshState+texturedMeshState vbo vertexCount mode =+  MeshState+    { meshVbo = vbo,+      meshPush = do+        GL.bindBuffer GL.ArrayBuffer $= Just vbo+        -- Position: 2 floats, stride 16 bytes (4 floats), offset 0+        GL.clientState GL.VertexArray $= GL.Enabled+        GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 16 nullPtr+        -- UV: 2 floats, stride 16 bytes, offset 8 bytes+        GL.clientState GL.TextureCoordArray $= GL.Enabled+        GL.arrayPointer GL.TextureCoordArray $= GL.VertexArrayDescriptor 2 GL.Float 16 (plusPtr nullPtr 8)+        GL.drawArrays mode 0 vertexCount,+      meshPop = do+        GL.clientState GL.TextureCoordArray $= GL.Disabled+        GL.clientState GL.VertexArray $= GL.Disabled+        GL.bindBuffer GL.ArrayBuffer $= Nothing+    }

@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Aztecs.GL.D2.Sprite+  ( -- * Sprites+    Sprite (..),+    sprite,+    spriteMaterial,++    -- * Sprite Sheets+    SpriteSheet (..),+    spriteSheetClip,+  )+where++import Aztecs+import Aztecs.GL.D2.Image.Internal+import Aztecs.GL.D2.Shape+import Aztecs.GL.Internal+import Aztecs.GL.Material+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+-- A sprite references an @Image@ component entity and renders it.+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) $ componentOnInsert e new++-- | Sprite with an @EntityID@ to an @Image@ and the default configuration+sprite :: EntityID -> Sprite+sprite imgE =+  Sprite+    { spriteImage = imgE,+      spriteClip = Nothing,+      spriteScale = V2 1 1+    }++-- | 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 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 ()+  componentOnChange e _ = componentOnInsert e++-- | Calculate the clip rectangle of a @SpriteSheet@+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)

@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.GL.Image (Image (..), loadImage, TextureFilter (..)) where--import Aztecs-import Aztecs.GL.Image.Internal-import Aztecs.GL.Internal-import Aztecs.Transform-import qualified Codec.Picture as JP-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.ByteString as BS-import qualified Data.Vector.Storable as VS-import Foreign-import Graphics.Rendering.OpenGL (($=))-import qualified Graphics.Rendering.OpenGL as GL-import Graphics.Rendering.OpenGL.GL (TextureFilter (..))-import Prelude hiding (lookup)---- | Image component-data Image = Image-  { -- | Image source data-    imageData :: JP.Image JP.PixelRGBA8,-    imageFilter :: !TextureFilter-  }--instance (MonadIO m) => Component m Image where-  componentOnInsert e img = inAnyWindowContext $ do-    let w = JP.imageWidth $ imageData img-        h = JP.imageHeight $ imageData img-        pixels = JP.imageData $ imageData img-        imgData = BS.pack $ VS.toList pixels--    res <- liftIO $ GL.genObjectNames 1-    tex <- case res of-      [tex] -> return tex-      _ -> error "Failed to generate texture object"--    liftIO $ do-      GL.textureBinding GL.Texture2D $= Just tex--      -- Set texture parameters (use Nearest filtering for crisp pixel art)-      GL.textureFilter GL.Texture2D $= ((imageFilter img, Nothing), imageFilter img)-      GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)-      GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)--      -- Upload texture data-      BS.useAsCString imgData $ \ptr -> do-        GL.texImage2D-          GL.Texture2D-          GL.NoProxy-          0-          GL.RGBA8-          (GL.TextureSize2D (fromIntegral w) (fromIntegral h))-          0-          (GL.PixelData GL.RGBA GL.UnsignedByte (castPtr ptr))-      GL.textureBinding GL.Texture2D $= Nothing-    insert e . bundle $ ImageState tex (V2 (fromIntegral w) (fromIntegral h))--loadImage :: FilePath -> IO Image-loadImage path = do-  eImg <- JP.readImage path-  case eImg of-    Left err -> error $ "Failed to load image: " ++ err-    Right dynImg -> let img = JP.convertRGBA8 dynImg in return $ Image img GL.Nearest

@@ -1,18 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Aztecs.GL.Image.Internal (ImageState (..)) where--import Aztecs-import Aztecs.Transform-import Control.Monad-import qualified Graphics.Rendering.OpenGL as GL-import Prelude hiding (lookup)---- | Image state component-data ImageState = ImageState-  { imageTexture :: !GL.TextureObject,-    imageSize :: !(V2 Float)-  }--instance (Monad m) => Component m ImageState

@@ -11,6 +11,7 @@     OfMaterial (..),     MeshState (..),     MaterialState (..),+    RenderGroupKey (..),     RenderGroups (..),     renderGroups,     registerRenderable,@@ -22,8 +23,12 @@ import Aztecs.GLFW import Control.Monad import Control.Monad.IO.Class+import Data.Map (Map) import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Vector as V+import Debug.Trace import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.UI.GLFW as GLFW import Prelude hiding (lookup)@@ -51,7 +56,7 @@ newtype OfMesh = OfMesh {unOfMesh :: EntityID}   deriving (Show, Eq) -instance (Monad m) => Component m OfMesh where+instance (MonadIO m) => Component m OfMesh where   componentOnInsert e (OfMesh meshE) = do     mMat <- lookup e     case mMat of@@ -88,7 +93,7 @@ newtype OfMaterial = OfMaterial {unOfMaterial :: EntityID}   deriving (Show, Eq) -instance (Monad m) => Component m OfMaterial where+instance (MonadIO m) => Component m OfMaterial where   componentOnInsert e (OfMaterial matE) = do     mMesh <- lookup e     case mMesh of@@ -121,13 +126,22 @@           Just _ -> unregisterRenderable e e matE           Nothing -> return () +-- | Unique key for a render group+data RenderGroupKey = RenderGroupKey+  { -- | EntityID of the render group's mesh+    renderGroupKeyMesh :: EntityID,+    -- | EntityID of the render group's material+    renderGroupKeyMaterial :: EntityID+  }+  deriving (Show, Eq, Ord)+ -- | Render groups component-newtype RenderGroups = RenderGroups {unRenderGroups :: Map.Map (EntityID, EntityID) [EntityID]}+newtype RenderGroups = RenderGroups {unRenderGroups :: Map RenderGroupKey (Set EntityID)}   deriving (Show, Eq)  instance (Monad m) => Component m RenderGroups --- | Get or create the RenderGroups singleton+-- | Get or create the @RenderGroups@ singleton renderGroups :: (Monad m) => Access m (EntityID, RenderGroups) renderGroups = do   res <- system . readQuery $ (,) <$> entity <*> query @_ @RenderGroups@@ -139,23 +153,24 @@       return (e, rg)  -- | Register an entity as renderable with the given mesh and material entity IDs-registerRenderable :: (Monad m) => EntityID -> EntityID -> EntityID -> Access m ()+registerRenderable :: (MonadIO m) => EntityID -> EntityID -> EntityID -> Access m () registerRenderable e meshE matE = do+  liftIO $ traceIO $ "[RenderGroups] registerRenderable entity=" ++ show e ++ ", meshE=" ++ show meshE ++ ", matE=" ++ show matE   (rgE, RenderGroups groups) <- renderGroups-  let key = (meshE, matE)-      newGroups = Map.insertWith (++) key [e] groups+  let key = RenderGroupKey meshE matE+      newGroups = Map.insertWith Set.union key (Set.singleton e) groups   insert rgE $ bundle (RenderGroups newGroups)  -- | Unregister an entity from its render group-unregisterRenderable :: (Monad m) => EntityID -> EntityID -> EntityID -> Access m ()+unregisterRenderable :: (MonadIO m) => EntityID -> EntityID -> EntityID -> Access m () unregisterRenderable e meshE matE = do+  liftIO $ traceIO $ "[RenderGroups] unregisterRenderable entity=" ++ show e ++ ", meshE=" ++ show meshE ++ ", matE=" ++ show matE   (rgE, RenderGroups groups) <- renderGroups-  let key = (meshE, matE)+  let key = RenderGroupKey meshE matE       newGroups = Map.update removeEntity key groups       removeEntity es =-        case filter (/= e) es of-          [] -> Nothing-          es' -> Just es'+        let es' = Set.delete e es+         in if Set.null es' then Nothing else Just es'   insert rgE $ bundle (RenderGroups newGroups)  -- | Run an action in this entity's parent window's OpenGL context

@@ -19,7 +19,7 @@ import qualified Graphics.Rendering.OpenGL as GL import Prelude hiding (lookup) --- | Material component - wraps an IO action that produces MaterialState+-- | Material component newtype Material = Material {unMaterial :: IO MaterialState}  instance (MonadIO m) => Component m Material where@@ -34,11 +34,9 @@         case mMeshState of           Just _ -> registerRenderable e e e           Nothing -> return ()-   componentOnChange e _ new = do     matState <- liftIO $ unMaterial new     insert e $ bundle matState-   componentOnRemove e _ = do     mOfMesh <- lookup e     case mOfMesh of

@@ -1,15 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Aztecs.GL.Render-  ( RenderGroups (..),-    renderGroups,-    OfMesh (..),-    OfMaterial (..),-  )-where--import Aztecs.GL.Internal (OfMaterial (..), OfMesh (..), RenderGroups (..), renderGroups)

@@ -1,253 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}--module Aztecs.GL.Shape-  ( -- * Shapes-    Rectangle (..),-    Circle (..),-    Triangle (..),-  )-where--import Aztecs-import Aztecs.GL.Internal-import Aztecs.GL.Mesh-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.Vector.Storable as SV-import Foreign.Ptr-import Foreign.Storable-import Graphics.Rendering.OpenGL (($=))-import qualified Graphics.Rendering.OpenGL as GL-import Prelude hiding (lookup)---- | Rectangle component-data Rectangle = Rectangle-  { rectangleWidth :: !Float,-    rectangleHeight :: !Float-  }-  deriving (Show, Eq)--instance (MonadIO m) => Component m Rectangle where-  componentOnInsert e rect = inParentWindowContext e $ do-    let mesh = compileRectangle rect-    meshE <- spawn $ bundle mesh-    insert e $ bundle (OfMesh meshE)-  componentOnChange e oldRect newRect = when (oldRect /= newRect) . inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (OfMesh meshE) -> do-        mData <- lookup meshE-        case mData of-          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)-          Nothing -> return ()-        let newMesh = compileRectangle newRect-        meshData <- liftIO $ unMesh newMesh-        insert meshE $ bundle meshData-      Nothing -> do-        let mesh = compileRectangle newRect-        meshE <- spawn $ bundle mesh-        insert e $ bundle (OfMesh meshE)-  componentOnRemove e _ = inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (OfMesh meshE) -> do-        mData <- lookup meshE-        case mData of-          Just md -> do-            liftIO $ GL.deleteObjectName (meshVbo md)-            despawn meshE-          Nothing -> return ()-        _ <- remove @_ @OfMesh e-        return ()-      Nothing -> return ()---- | Circle component-data Circle = Circle-  { circleRadius :: !Float,-    circleSegments :: !Int-  }-  deriving (Show, Eq)--instance (MonadIO m) => Component m Circle where-  componentOnInsert e circ = inParentWindowContext e $ do-    let mesh = compileCircle circ-    meshE <- spawn $ bundle mesh-    insert e $ bundle (OfMesh meshE)-  componentOnChange e oldCirc newCirc = when (oldCirc /= newCirc) . inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (OfMesh meshE) -> do-        mData <- lookup meshE-        case mData of-          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)-          Nothing -> return ()-        let newMesh = compileCircle newCirc-        meshData <- liftIO $ unMesh newMesh-        insert meshE $ bundle meshData-      Nothing -> do-        let mesh = compileCircle newCirc-        meshE <- spawn $ bundle mesh-        insert e $ bundle (OfMesh meshE)-  componentOnRemove e _ = inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (OfMesh meshE) -> do-        mData <- lookup meshE-        case mData of-          Just md -> do-            liftIO $ GL.deleteObjectName (meshVbo md)-            despawn meshE-          Nothing -> return ()-        _ <- remove @_ @OfMesh e-        return ()-      Nothing -> return ()---- | Triangle component-data Triangle = Triangle-  { triangleX1 :: !Float,-    triangleY1 :: !Float,-    triangleX2 :: !Float,-    triangleY2 :: !Float,-    triangleX3 :: !Float,-    triangleY3 :: !Float-  }-  deriving (Show, Eq)--instance (MonadIO m) => Component m Triangle where-  componentOnInsert e tri = inParentWindowContext e $ do-    let mesh = compileTriangle tri-    meshE <- spawn $ bundle mesh-    insert e $ bundle (OfMesh meshE)-  componentOnChange e oldTri newTri = when (oldTri /= newTri) . inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (OfMesh meshE) -> do-        mData <- lookup meshE-        case mData of-          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)-          Nothing -> return ()-        let newMesh = compileTriangle newTri-        meshData <- liftIO $ unMesh newMesh-        insert meshE $ bundle meshData-      Nothing -> do-        let mesh = compileTriangle newTri-        meshE <- spawn $ bundle mesh-        insert e $ bundle (OfMesh meshE)-  componentOnRemove e _ = inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (OfMesh meshE) -> do-        mData <- lookup meshE-        case mData of-          Just md -> do-            liftIO $ GL.deleteObjectName (meshVbo md)-            despawn meshE-          Nothing -> return ()-        _ <- remove @_ @OfMesh e-        return ()-      Nothing -> return ()---- | Compile a rectangle into a VBO mesh with texture coordinates-compileRectangle :: Rectangle -> Mesh-compileRectangle (Rectangle w h) =-  let hw = w / 2-      hh = h / 2-      -- Interleaved: x, y, u, v for each vertex (V flipped for OpenGL)-      vertices =-        SV.fromList-          [ -hw,-            -hh,-            0,-            1, -- bottom-left-            hw,-            -hh,-            1,-            1, -- bottom-right-            hw,-            hh,-            1,-            0, -- top-right-            -hw,-            hh,-            0,-            0 -- top-left-          ] ::-          SV.Vector GL.GLfloat-   in compileMeshWithUV vertices GL.Quads---- | Compile a circle into a VBO mesh-compileCircle :: Circle -> Mesh-compileCircle (Circle radius segments) =-  let angles = [2 * pi * fromIntegral i / fromIntegral segments | i <- [0 .. segments]]-      vertices = SV.fromList $ [0, 0] ++ concatMap (\a -> [radius * cos a, radius * sin a]) angles :: SV.Vector GL.GLfloat-   in compileMesh vertices GL.TriangleFan---- | Compile a triangle into a VBO mesh-compileTriangle :: Triangle -> Mesh-compileTriangle (Triangle x1 y1 x2 y2 x3 y3) =-  let vertices = SV.fromList [x1, y1, x2, y2, x3, y3] :: SV.Vector GL.GLfloat-   in compileMesh vertices GL.Triangles---- | Compile vertices into a VBO mesh (position only)-compileMesh :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> Mesh-compileMesh vertices mode = Mesh $ do-  let vertexCount = fromIntegral $ SV.length vertices `div` 2-  vbo <- uploadVbo vertices-  return $ simpleMeshState vbo vertexCount mode---- | Compile vertices with UV into a VBO mesh (interleaved: x, y, u, v)-compileMeshWithUV :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> Mesh-compileMeshWithUV vertices mode = Mesh $ do-  let vertexCount = fromIntegral $ SV.length vertices `div` 4-  vbo <- uploadVbo vertices-  return $ texturedMeshState vbo vertexCount mode---- | Upload vertex data to a new VBO-uploadVbo :: SV.Vector GL.GLfloat -> IO GL.BufferObject-uploadVbo vertices = do-  [vbo] <- GL.genObjectNames 1-  GL.bindBuffer GL.ArrayBuffer $= Just vbo-  SV.unsafeWith vertices $ \ptr -> do-    let dataSize = fromIntegral $ SV.length vertices * sizeOf (undefined :: GL.GLfloat)-    GL.bufferData GL.ArrayBuffer $= (dataSize, ptr, GL.StaticDraw)-  GL.bindBuffer GL.ArrayBuffer $= Nothing-  return vbo---- | Create MeshState for non-textured mesh (position only, stride 0)-simpleMeshState :: GL.BufferObject -> GL.GLint -> GL.PrimitiveMode -> MeshState-simpleMeshState vbo vertexCount mode =-  MeshState-    { meshVbo = vbo,-      meshPush = do-        GL.bindBuffer GL.ArrayBuffer $= Just vbo-        GL.clientState GL.VertexArray $= GL.Enabled-        GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 0 nullPtr-        GL.drawArrays mode 0 vertexCount,-      meshPop = do-        GL.clientState GL.VertexArray $= GL.Disabled-        GL.bindBuffer GL.ArrayBuffer $= Nothing-    }---- | Create MeshState for textured mesh (interleaved x,y,u,v, stride 16)-texturedMeshState :: GL.BufferObject -> GL.GLint -> GL.PrimitiveMode -> MeshState-texturedMeshState vbo vertexCount mode =-  MeshState-    { meshVbo = vbo,-      meshPush = do-        GL.bindBuffer GL.ArrayBuffer $= Just vbo-        -- Position: 2 floats, stride 16 bytes (4 floats), offset 0-        GL.clientState GL.VertexArray $= GL.Enabled-        GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 16 nullPtr-        -- UV: 2 floats, stride 16 bytes, offset 8 bytes-        GL.clientState GL.TextureCoordArray $= GL.Enabled-        GL.arrayPointer GL.TextureCoordArray $= GL.VertexArrayDescriptor 2 GL.Float 16 (plusPtr nullPtr 8)-        GL.drawArrays mode 0 vertexCount,-      meshPop = do-        GL.clientState GL.TextureCoordArray $= GL.Disabled-        GL.clientState GL.VertexArray $= GL.Disabled-        GL.bindBuffer GL.ArrayBuffer $= Nothing-    }

@@ -1,135 +0,0 @@-{-# 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)