aztecs-gl (empty) → 0.1.0

raw patch · 5 files changed

+331/−0 lines, 5 filesdep +GLFW-bdep +OpenGLdep +aztecs

Dependencies added: GLFW-b, OpenGL, aztecs, aztecs-gl, aztecs-glfw, aztecs-transform, base, vector

Files

CHANGELOG.md +5/−0
LICENSE +29/−0
aztecs-gl.cabal +41/−0
src/Aztecs/GL.hs +252/−0
test/Main.hs +4/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for aztecs-gl
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,29 @@+Copyright (c) 2026, Matt Hunzinger
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ aztecs-gl.cabal view

@@ -0,0 +1,41 @@+cabal-version:   3.0+name:            aztecs-gl+version:         0.1.0+license:         BSD-3-Clause+license-file:    LICENSE+maintainer:      matt@hunzinger.me+author:          Matt Hunzinger+homepage:        https://github.com/aztecs-hs/aztecs+synopsis:        OpenGL rendering for Aztecs+description:     OpenGL rendering for the Aztecs game engine and ECS+category:        Game Engine+build-type:      Simple+extra-doc-files: CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/aztecs-hs/aztecs-gl.git++library+    exposed-modules:  Aztecs.GL+    hs-source-dirs:   src+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.2 && <5,+        aztecs >=0.17,+        aztecs-glfw >=0.2,+        aztecs-transform >=0.3.2,+        GLFW-b >=1,+        OpenGL >=3,+        vector >=0.10++test-suite aztecs-gl-test+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.2 && <5,+        aztecs-gl

+ src/Aztecs/GL.hs view

@@ -0,0 +1,252 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL+  ( -- * Colors+    Color (..),++    -- * Shapes+    Rectangle (..),+    Circle (..),+    Triangle (..),++    -- * Rendering+    render,+    module Aztecs.Transform,+  )+where++import Aztecs+import Aztecs.GLFW (RawWindow (..), Window (..))+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 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 :: (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)++        -- 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 ()++-- | Render a mesh with transform and color+renderMesh :: (Mesh, Transform2D, Color) -> IO ()+renderMesh (Mesh vbo vertexCount mode, t, color) = 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

+ test/Main.hs view

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."