packages feed

aztecs-gl 0.1.1 → 0.2.0

raw patch · 10 files changed

+867/−230 lines, 10 filesdep +JuicyPixelsdep +bytestringdep +containers

Dependencies added: JuicyPixels, bytestring, containers

Files

aztecs-gl.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            aztecs-gl-version:         0.1.1+version:         0.2.0 license:         BSD-3-Clause license-file:    LICENSE maintainer:      matt@hunzinger.me@@ -17,7 +17,17 @@     location: https://github.com/aztecs-hs/aztecs-gl.git  library-    exposed-modules:  Aztecs.GL+    exposed-modules:+        Aztecs.GL+        Aztecs.GL.Image+        Aztecs.GL.Image.Internal+        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     ghc-options:      -Wall@@ -26,7 +36,10 @@         aztecs >=0.17,         aztecs-glfw >=0.2,         aztecs-transform >=0.3.2,+        bytestring >=0.10,+        containers >=0.6,         GLFW-b >=1,+        JuicyPixels >=3.3,         OpenGL >=3,         vector >=0.10
src/Aztecs/GL.hs view
@@ -1,21 +1,17 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}  module Aztecs.GL-  ( -- * Colors-    Color (..),--    -- * Meshes-    Mesh (..),--    -- * Shapes-    Rectangle (..),-    Circle (..),-    Triangle (..),--    -- * Rendering+  ( -- * 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@@ -24,240 +20,93 @@ where  import Aztecs-import Aztecs.GLFW (RawWindow (..), Window (..))+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.Vector.Storable as SV-import Foreign.Ptr-import Foreign.Storable+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) --- | RGBA Color-data Color = Color-  { colorR :: !Float,-    colorG :: !Float,-    colorB :: !Float,-    colorA :: !Float-  }-  deriving (Show, Eq)--instance (Monad m) => Component m Color---- | Mesh component-data Mesh = Mesh-  { meshVBO :: !GL.BufferObject,-    meshVertexCount :: !GL.NumArrayIndices,-    meshPrimitiveMode :: !GL.PrimitiveMode-  }-  deriving (Show, Eq)--instance (Monad m) => Component m Mesh--inParentWindowContext :: (MonadIO m) => EntityID -> Access m () -> Access m ()-inParentWindowContext e action = do-  res <- lookup e-  case res of-    Just (Parent parentE) -> do-      res' <- lookup parentE-      case res' of-        Just (RawWindow raw _) -> do-          liftIO . GLFW.makeContextCurrent $ Just raw-          action-        Nothing -> return ()-    Nothing -> return ()---- | 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-    mesh <- liftIO $ compileRectangle rect-    insert e $ bundle mesh-  componentOnChange e oldRect newRect = when (oldRect /= newRect) . inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (Mesh vbo _ _) -> liftIO $ GL.deleteObjectName vbo-      Nothing -> return ()-    mesh <- liftIO $ compileRectangle newRect-    insert e $ bundle mesh-  componentOnRemove e _ = inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (Mesh vbo _ _) -> do-        liftIO $ GL.deleteObjectName vbo-        _ <- remove @_ @Mesh 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-    mesh <- liftIO $ compileCircle circ-    insert e $ bundle mesh-  componentOnChange e oldCirc newCirc = when (oldCirc /= newCirc) . inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (Mesh vbo _ _) -> liftIO $ GL.deleteObjectName vbo-      Nothing -> return ()-    mesh <- liftIO $ compileCircle newCirc-    insert e $ bundle mesh-  componentOnRemove e _ = inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (Mesh vbo _ _) -> do-        liftIO $ GL.deleteObjectName vbo-        _ <- remove @_ @Mesh 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-    mesh <- liftIO $ compileTriangle tri-    insert e $ bundle mesh-  componentOnChange e oldTri newTri = when (oldTri /= newTri) . inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (Mesh vbo _ _) -> liftIO $ GL.deleteObjectName vbo-      Nothing -> return ()-    mesh <- liftIO $ compileTriangle newTri-    insert e $ bundle mesh-  componentOnRemove e _ = inParentWindowContext e $ do-    mMesh <- lookup e-    case mMesh of-      Just (Mesh vbo _ _) -> do-        liftIO $ GL.deleteObjectName vbo-        _ <- remove @_ @Mesh e-        return ()-      Nothing -> return ()---- | Compile a rectangle into a VBO mesh-compileRectangle :: Rectangle -> IO Mesh-compileRectangle (Rectangle w h) = do-  let hw = w / 2-      hh = h / 2-      vertices = SV.fromList [-hw, -hh, hw, -hh, hw, hh, -hw, hh] :: SV.Vector GL.GLfloat-  compileMesh vertices GL.Quads---- | Compile a circle into a VBO mesh-compileCircle :: Circle -> IO Mesh-compileCircle (Circle radius segments) = do-  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-  compileMesh vertices GL.TriangleFan---- | Compile a triangle into a VBO mesh-compileTriangle :: Triangle -> IO Mesh-compileTriangle (Triangle x1 y1 x2 y2 x3 y3) = do-  let vertices = SV.fromList [x1, y1, x2, y2, x3, y3] :: SV.Vector GL.GLfloat-  compileMesh vertices GL.Triangles---- | Compile vertices into a VBO mesh-compileMesh :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> IO Mesh-compileMesh vertices mode = do-  let vertexCount = fromIntegral $ SV.length vertices `div` 2--  -- Create and bind VBO-  [vbo] <- GL.genObjectNames 1-  GL.bindBuffer GL.ArrayBuffer $= Just vbo--  -- Upload vertex data-  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 $ Mesh vbo vertexCount mode---- | Render all @Mesh@ components that are descendants of @Window@s+-- | 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 <*> query @_ @Children-  mapM_ go windows-  where-    go (window, RawWindow raw _, children) = do-      liftIO $ do-        GLFW.makeContextCurrent (Just raw)+  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 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-      mapM_ go' $ unChildren children-    go' e = do-      meshRes <- lookup e-      transformRes <- lookup e-      colorRes <- lookup e-      let res = (,,) <$> meshRes <*> transformRes <*> colorRes-      case res of-        Just (mesh, trans, color) -> liftIO $ renderMesh (mesh, trans, color)-        Nothing -> return ()+      -- 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 -      childrenRes <- lookup e-      case childrenRes of-        Just (Children cs) -> mapM_ go' cs-        Nothing -> return ()+    -- 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) --- | Render a mesh with transform and color-renderMesh :: (Mesh, Transform2D, Color) -> IO ()-renderMesh (Mesh vbo vertexCount mode, t, color) = do+          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-    -- Apply transform     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)--    -- Set color-    GL.color $ GL.Color4 (realToFrac $ colorR color) (realToFrac $ colorG color) (realToFrac $ colorB color) (realToFrac $ colorA color :: GL.GLfloat)--    -- Bind VBO and set up vertex pointer-    GL.bindBuffer GL.ArrayBuffer $= Just vbo-    GL.vertexAttribPointer (GL.AttribLocation 0)-      $= (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 nullPtr)-    GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled--    -- Also set up the legacy vertex pointer for fixed-function pipeline-    GL.clientState GL.VertexArray $= GL.Enabled-    GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 0 nullPtr--    -- Draw-    GL.drawArrays mode 0 vertexCount--    -- Cleanup-    GL.clientState GL.VertexArray $= GL.Disabled-    GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Disabled-    GL.bindBuffer GL.ArrayBuffer $= Nothing+    meshPush md+    meshPop md
+ src/Aztecs/GL/Image.hs view
@@ -0,0 +1,66 @@+{-# 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
+ src/Aztecs/GL/Image/Internal.hs view
@@ -0,0 +1,18 @@+{-# 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
+ src/Aztecs/GL/Internal.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Internal+  ( inParentWindowContext,+    inAnyWindowContext,+    OfMesh (..),+    OfMaterial (..),+    MeshState (..),+    MaterialState (..),+    RenderGroups (..),+    renderGroups,+    registerRenderable,+    unregisterRenderable,+  )+where++import Aztecs+import Aztecs.GLFW+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import qualified Graphics.Rendering.OpenGL as GL+import qualified Graphics.UI.GLFW as GLFW+import Prelude hiding (lookup)++-- | Mesh data component+data MeshState = MeshState+  { meshVbo :: !GL.BufferObject,+    meshPush :: !(IO ()),+    meshPop :: !(IO ())+  }++instance (Monad m) => Component m MeshState++-- | Material state component+data MaterialState = MaterialState+  { -- | Push the material state before rendering+    materialPush :: !(IO ()),+    -- | Pop the material state after rendering+    materialPop :: !(IO ())+  }++instance (Monad m) => Component m MaterialState++-- | OfMesh component that references an entity with a @Mesh@ component+newtype OfMesh = OfMesh {unOfMesh :: EntityID}+  deriving (Show, Eq)++instance (Monad m) => Component m OfMesh where+  componentOnInsert e (OfMesh meshE) = do+    mMat <- lookup e+    case mMat of+      Just (OfMaterial matE) -> registerRenderable e meshE matE+      Nothing -> do+        mMatState <- lookup @_ @MaterialState e+        case mMatState of+          Just _ -> registerRenderable e meshE e+          Nothing -> return ()+  componentOnChange e (OfMesh oldMeshE) (OfMesh newMeshE) = when (oldMeshE /= newMeshE) $ do+    mMat <- lookup e+    case mMat of+      Just (OfMaterial matE) -> do+        unregisterRenderable e oldMeshE matE+        registerRenderable e newMeshE matE+      Nothing -> do+        mMatState <- lookup @_ @MaterialState e+        case mMatState of+          Just _ -> do+            unregisterRenderable e oldMeshE e+            registerRenderable e newMeshE e+          Nothing -> return ()+  componentOnRemove e (OfMesh meshE) = do+    mMat <- lookup e+    case mMat of+      Just (OfMaterial matE) -> unregisterRenderable e meshE matE+      Nothing -> do+        mMatState <- lookup @_ @MaterialState e+        case mMatState of+          Just _ -> unregisterRenderable e meshE e+          Nothing -> return ()++-- | OfMaterial component that references an entity with a @Material@ component+newtype OfMaterial = OfMaterial {unOfMaterial :: EntityID}+  deriving (Show, Eq)++instance (Monad m) => Component m OfMaterial where+  componentOnInsert e (OfMaterial matE) = do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> registerRenderable e meshE matE+      Nothing -> do+        mMeshState <- lookup @_ @MeshState e+        case mMeshState of+          Just _ -> registerRenderable e e matE+          Nothing -> return ()+  componentOnChange e (OfMaterial oldMatE) (OfMaterial newMatE) = when (oldMatE /= newMatE) $ do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> do+        unregisterRenderable e meshE oldMatE+        registerRenderable e meshE newMatE+      Nothing -> do+        mMeshState <- lookup @_ @MeshState e+        case mMeshState of+          Just _ -> do+            unregisterRenderable e e oldMatE+            registerRenderable e e newMatE+          Nothing -> return ()+  componentOnRemove e (OfMaterial matE) = do+    mMesh <- lookup e+    case mMesh of+      Just (OfMesh meshE) -> unregisterRenderable e meshE matE+      Nothing -> do+        mMeshState <- lookup @_ @MeshState e+        case mMeshState of+          Just _ -> unregisterRenderable e e matE+          Nothing -> return ()++-- | Render groups component+newtype RenderGroups = RenderGroups {unRenderGroups :: Map.Map (EntityID, EntityID) [EntityID]}+  deriving (Show, Eq)++instance (Monad m) => Component m RenderGroups++-- | Get or create the RenderGroups singleton+renderGroups :: (Monad m) => Access m (EntityID, RenderGroups)+renderGroups = do+  res <- system . readQuery $ (,) <$> entity <*> query @_ @RenderGroups+  case V.uncons res of+    Just ((e, rg), _) -> return (e, rg)+    Nothing -> do+      let rg = RenderGroups Map.empty+      e <- spawn $ bundle rg+      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 e meshE matE = do+  (rgE, RenderGroups groups) <- renderGroups+  let key = (meshE, matE)+      newGroups = Map.insertWith (++) key [e] groups+  insert rgE $ bundle (RenderGroups newGroups)++-- | Unregister an entity from its render group+unregisterRenderable :: (Monad m) => EntityID -> EntityID -> EntityID -> Access m ()+unregisterRenderable e meshE matE = do+  (rgE, RenderGroups groups) <- renderGroups+  let key = (meshE, matE)+      newGroups = Map.update removeEntity key groups+      removeEntity es =+        case filter (/= e) es of+          [] -> Nothing+          es' -> Just es'+  insert rgE $ bundle (RenderGroups newGroups)++-- | Run an action in this entity's parent window's OpenGL context+inParentWindowContext :: (MonadIO m) => EntityID -> Access m () -> Access m ()+inParentWindowContext e action = do+  res <- lookup e+  case res of+    Just (Parent parentE) -> do+      res' <- lookup parentE+      case res' of+        Just (RawWindow raw _) -> do+          liftIO . GLFW.makeContextCurrent $ Just raw+          action+        Nothing -> return ()+    Nothing -> return ()++-- | Run an action in any available window context+inAnyWindowContext :: (MonadIO m) => Access m () -> Access m ()+inAnyWindowContext action = do+  windows <- system . readQuery $ query @_ @RawWindow+  case V.uncons windows of+    Just (RawWindow raw _, _) -> do+      liftIO . GLFW.makeContextCurrent $ Just raw+      action+    Nothing -> return ()
+ src/Aztecs/GL/Material.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Material+  ( -- * Materials+    OfMaterial (..),+    Material (..),+    color,+  )+where++import Aztecs+import Aztecs.GL.Internal+import Control.Monad.IO.Class+import Graphics.Rendering.OpenGL (($=))+import qualified Graphics.Rendering.OpenGL as GL+import Prelude hiding (lookup)++-- | Material component - wraps an IO action that produces MaterialState+newtype Material = Material {unMaterial :: IO MaterialState}++instance (MonadIO m) => Component m Material where+  componentOnInsert e mat = do+    matState <- liftIO $ unMaterial mat+    insert e $ bundle matState+    mOfMesh <- lookup e+    case mOfMesh of+      Just (OfMesh meshE) -> registerRenderable e meshE e+      Nothing -> do+        mMeshState <- lookup @_ @MeshState e+        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+      Just (OfMesh meshE) -> unregisterRenderable e meshE e+      Nothing -> do+        mMeshState <- lookup @_ @MeshState e+        case mMeshState of+          Just _ -> unregisterRenderable e e e+          Nothing -> return ()++-- | Create a solid color material renderer from RGBA values+color :: Float -> Float -> Float -> Float -> Material+color r g b a =+  Material . return $+    MaterialState+      { materialPush = do+          GL.texture GL.Texture2D $= GL.Disabled+          GL.color $ GL.Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a :: GL.GLfloat),+        materialPop = return ()+      }
+ src/Aztecs/GL/Mesh.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Mesh+  ( -- * Meshes+    OfMesh (..),+    Mesh (..),+  )+where++import Aztecs+import Aztecs.GL.Internal+import Control.Monad.IO.Class+import Prelude hiding (lookup)++-- | Mesh component+newtype Mesh = Mesh {unMesh :: IO MeshState}++instance (MonadIO m) => Component m Mesh where+  componentOnInsert e mesh = do+    meshState <- liftIO $ unMesh mesh+    insert e $ bundle meshState+    mOfMat <- lookup e+    case mOfMat of+      Just (OfMaterial matE) -> registerRenderable e e matE+      Nothing -> do+        mMatState <- lookup @_ @MaterialState e+        case mMatState of+          Just _ -> registerRenderable e e e+          Nothing -> return ()++  componentOnRemove e _ = do+    mOfMat <- lookup e+    case mOfMat of+      Just (OfMaterial matE) -> unregisterRenderable e e matE+      Nothing -> do+        mMatState <- lookup @_ @MaterialState e+        case mMatState of+          Just _ -> unregisterRenderable e e e+          Nothing -> return ()
+ src/Aztecs/GL/Render.hs view
@@ -0,0 +1,15 @@+{-# 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)
+ src/Aztecs/GL/Shape.hs view
@@ -0,0 +1,253 @@+{-# 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+    }
+ src/Aztecs/GL/Sprite.hs view
@@ -0,0 +1,136 @@+{-# 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+    liftIO $ print "Sprite changed"+    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)