aztecs-gl-text (empty) → 0.1.0
raw patch · 9 files changed
+780/−0 lines, 9 filesdep +OpenGLdep +aztecsdep +aztecs-gl
Dependencies added: OpenGL, aztecs, aztecs-gl, aztecs-gl-text, base, containers, freetype2, linear, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +29/−0
- aztecs-gl-text.cabal +48/−0
- src/Aztecs/GL/Text.hs +8/−0
- src/Aztecs/GL/Text/Font.hs +50/−0
- src/Aztecs/GL/Text/Font/Internal.hs +82/−0
- src/Aztecs/GL/Text/Label.hs +470/−0
- src/Aztecs/GL/Text/Label/Internal.hs +86/−0
- test/Main.hs +4/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Revision history for aztecs-gl-text++## [0.1.0](https://github.com/aztecs-hs/aztecs-gl-text/v0.1.0) - 2026-1-27
+ 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-text.cabal view
@@ -0,0 +1,48 @@+cabal-version: 3.0+name: aztecs-gl-text+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 text rendering for Aztecs+description: OpenGL text 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-text.git++library+ exposed-modules:+ Aztecs.GL.Text+ Aztecs.GL.Text.Font+ Aztecs.GL.Text.Font.Internal+ Aztecs.GL.Text.Label+ Aztecs.GL.Text.Label.Internal++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.2 && <5,+ aztecs >=0.17,+ aztecs-gl >=0.3,+ containers >=0.6,+ freetype2 >=0.2,+ linear >=1,+ OpenGL >=3,+ vector >=0.10++test-suite aztecs-gl-text-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-text
+ src/Aztecs/GL/Text.hs view
@@ -0,0 +1,8 @@+module Aztecs.GL.Text+ ( module Aztecs.GL.Text.Font,+ module Aztecs.GL.Text.Label,+ )+where++import Aztecs.GL.Text.Font+import Aztecs.GL.Text.Label
+ src/Aztecs/GL/Text/Font.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Text.Font+ ( -- * Fonts+ Font (..),+ )+where++import Aztecs+import Aztecs.GL.Internal+import Aztecs.GL.Text.Label.Internal+import Control.Monad+import Control.Monad.IO.Class+import Data.IORef+import qualified Data.Map.Strict as Map+import Debug.Trace+import FreeType.Core.Base+import Prelude hiding (lookup)++-- | Font component - loads and holds a FreeType font face+newtype Font = Font+ { -- | Path to the font file+ fontFilePath :: FilePath+ }+ deriving (Show, Eq)++instance (MonadIO m) => Component m Font where+ componentOnInsert e font = do+ liftIO $ traceIO $ "[Font] componentOnInsert called for entity " ++ show e+ inAnyWindowContext $ do+ liftIO $ traceIO $ "[Font] Inside inAnyWindowContext for entity " ++ show e+ (_, fc) <- fontCache+ -- Load the FreeType face (size will be set per-label)+ face <- liftIO $ loadFontFace fc (fontFilePath font)+ liftIO $ traceIO $ "[Font] FontState created for entity " ++ show e+ insert e $ bundle FontState {fontStateFace = face}++loadFontFace :: FontCache -> FilePath -> IO FT_Face+loadFontFace fc path = do+ faces <- readIORef (fontCacheFaces fc)+ case Map.lookup path faces of+ Just face -> return face+ Nothing -> do+ face <- ft_New_Face (fontCacheLibrary fc) path 0+ modifyIORef (fontCacheFaces fc) $ Map.insert path face+ return face
+ src/Aztecs/GL/Text/Font/Internal.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Text.Font.Internal+ ( -- * Label State+ LabelState (..),+ GlyphInfo (..),++ -- * Font State+ FontState (..),++ -- * Font Cache+ FontCache (..),+ fontCache,+ )+where++import Aztecs+import Control.Monad.IO.Class+import Data.IORef+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+import FreeType.Core.Base+import qualified Graphics.Rendering.OpenGL as GL+import Prelude hiding (lookup)++-- | Information about a rendered glyph+data GlyphInfo = GlyphInfo+ { glyphTexture :: !GL.TextureObject,+ glyphWidth :: !Int,+ glyphHeight :: !Int,+ glyphBearingX :: !Int,+ glyphBearingY :: !Int,+ glyphAdvance :: !Int+ }+ deriving (Show, Eq)++-- | Label state component+data LabelState = LabelState+ { labelGlyphs :: ![GlyphInfo],+ labelTotalWidth :: !Float,+ labelTotalHeight :: !Float+ }++instance (Monad m) => Component m LabelState++-- | Font state component+newtype FontState = FontState {fontStateFace :: FT_Face}++instance (Monad m) => Component m FontState++-- | Font cache singleton that holds FreeType resources+data FontCache = FontCache+ { fontCacheLibrary :: !FT_Library,+ fontCacheFaces :: !(IORef (Map FilePath FT_Face)),+ fontCacheGlyphs :: !(IORef (Map FilePath (Map Char GlyphInfo)))+ }++instance (Monad m) => Component m FontCache++-- | Get or create the @FontCache@ singleton+fontCache :: (MonadIO m) => Access m (EntityID, FontCache)+fontCache = do+ res <- system . readQuery $ (,) <$> entity <*> query @_ @FontCache+ case V.uncons res of+ Just ((e, fc), _) -> return (e, fc)+ Nothing -> do+ fc <- liftIO initFontCache+ e <- spawn $ bundle fc+ return (e, fc)++-- | Initialize the FreeType library and create a new font cache+initFontCache :: IO FontCache+initFontCache = do+ lib <- ft_Init_FreeType+ facesRef <- newIORef Map.empty+ glyphsRef <- newIORef Map.empty+ return $ FontCache lib facesRef glyphsRef
+ src/Aztecs/GL/Text/Label.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Text.Label+ ( -- * Labels+ Label (..),+ LabelStyle (..),+ defaultLabelStyle,+ )+where++import Aztecs+import Aztecs.GL.Internal+import Aztecs.GL.Material+import Aztecs.GL.Mesh+import Aztecs.GL.Text.Label.Internal+import Control.Exception (catch)+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.Vector.Storable as SV+import Foreign+import FreeType.Core.Base+import FreeType.Core.Types+import FreeType.Exception (FtError)+import FreeType.Format.Multiple+import Graphics.Rendering.OpenGL (($=))+import qualified Graphics.Rendering.OpenGL as GL+import Linear+import Prelude hiding (lookup)++-- | Label styling options+data LabelStyle = LabelStyle+ { -- | Font size in pixels+ labelFontSize :: !Int,+ -- | Text color (RGBA)+ labelColor :: !(V4 Float),+ -- | Font weight (100-900, where 400 is normal, 700 is bold)+ labelFontWeight :: !Int,+ -- | Whether to render in italic style+ labelItalic :: !Bool+ }+ deriving (Eq)++-- | Default label style with given font entity+defaultLabelStyle :: LabelStyle+defaultLabelStyle =+ LabelStyle+ { labelFontSize = 16,+ labelColor = V4 1 1 1 1,+ labelFontWeight = 400,+ labelItalic = False+ }++-- | Label component+data Label = Label+ { -- | Text content+ labelText :: !String,+ -- | Entity ID of the @Font@ component to use+ labelFont :: !EntityID,+ -- | Text styling+ labelStyle :: !LabelStyle+ }+ deriving (Eq)++instance (MonadIO m) => Component m Label where+ componentOnInsert e lbl = inAnyWindowContext $ do+ let style = labelStyle lbl+ text = labelText lbl+ fontE = labelFont lbl+ fontSize = labelFontSize style+ V4 r g b a = labelColor style++ -- Look up the font state from the font entity+ mFontState <- lookup fontE+ case mFontState of+ Just fontState -> do+ -- Set the font size for this label+ liftIO $ ft_Set_Pixel_Sizes (fontStateFace fontState) 0 (fromIntegral fontSize)++ -- Set variable font weight+ let weight = labelFontWeight style+ italic = labelItalic style+ liftIO $ setVariableFontWeight (fontStateFace fontState) weight++ -- Get glyphs for the text and create a texture atlas+ (glyphs, atlasInfo) <- liftIO $ getGlyphsAndAtlasIOFromFace (fontStateFace fontState) text weight italic++ -- Calculate total dimensions+ let totalWidth = sum $ map (fromIntegral . glyphAdvance) glyphs+ totalHeight = maximum' $ map (fromIntegral . glyphHeight) glyphs++ -- Store label state (including atlas texture for cleanup)+ insert e $+ bundle+ LabelState+ { labelGlyphs = glyphs,+ labelTotalWidth = totalWidth,+ labelTotalHeight = totalHeight,+ labelAtlasTexture = atlasTexture atlasInfo+ }++ -- Build mesh+ let mesh = compileLabelMesh glyphs atlasInfo++ -- Build material+ let mat = labelMaterial (atlasTexture atlasInfo) r g b a++ -- Insert references to mesh and material+ insert e $ bundle mesh <> bundle mat+ Nothing -> return ()++ componentOnChange e old newLabel = when (old /= newLabel) $ inAnyWindowContext $ do+ -- Now recreate resources with new label+ let style = labelStyle newLabel+ text = labelText newLabel+ fontE = labelFont newLabel+ fontSize = labelFontSize style+ V4 r g b a = labelColor style++ mFontState <- lookup fontE+ case mFontState of+ Just fontState -> do+ liftIO $ ft_Set_Pixel_Sizes (fontStateFace fontState) 0 (fromIntegral fontSize)++ let weight = labelFontWeight style+ italic = labelItalic style+ liftIO $ setVariableFontWeight (fontStateFace fontState) weight++ (glyphs, atlasInfo) <- liftIO $ getGlyphsAndAtlasIOFromFace (fontStateFace fontState) text weight italic++ let totalWidth = sum $ map (fromIntegral . glyphAdvance) glyphs+ totalHeight = maximum' $ map (fromIntegral . glyphHeight) glyphs++ -- Update label state in place+ insert e $+ bundle+ LabelState+ { labelGlyphs = glyphs,+ labelTotalWidth = totalWidth,+ labelTotalHeight = totalHeight,+ labelAtlasTexture = atlasTexture atlasInfo+ }++ -- Create new mesh and material data, and UPDATE in place (don't remove/re-insert)+ let mesh = compileLabelMesh glyphs atlasInfo+ meshData <- liftIO $ unMesh mesh+ insert e $ bundle meshData -- Update MeshState in place+ let mat = labelMaterial (atlasTexture atlasInfo) r g b a+ matData <- liftIO $ unMaterial mat+ insert e $ bundle matData -- Update MaterialState in place+ Nothing -> return ()++ componentOnRemove e _ = inAnyWindowContext $ do+ -- Delete atlas texture from label state+ mLabelState <- lookup e+ case mLabelState of+ Just ls -> liftIO $ GL.deleteObjectName (labelAtlasTexture ls)+ Nothing -> return ()++ -- Delete VBO from mesh state+ mMeshState <- lookup @_ @MeshState e+ case mMeshState of+ Just ms -> liftIO $ GL.deleteObjectName (meshVbo ms)+ Nothing -> return ()++ -- Remove all components+ _ <- remove @_ @Mesh e+ _ <- remove @_ @MeshState e+ _ <- remove @_ @Material e+ _ <- remove @_ @MaterialState e+ _ <- remove @_ @LabelState e+ return ()++-- | Maximum helper that handles empty lists+maximum' :: (Ord a, Num a) => [a] -> a+maximum' [] = 0+maximum' xs = maximum xs++-- | Set the weight axis for a variable font+-- The 'wght' axis tag is 0x77676874 in FreeType+setVariableFontWeight :: FT_Face -> Int -> IO ()+setVariableFontWeight face weight = do+ -- Try to set the weight - this will silently fail for non-variable fonts+ let weightFixed = fromIntegral weight * 65536 -- Convert to 16.16 fixed point+ -- The weight axis is typically the first axis in variable fonts+ -- We use ft_Set_Var_Design_Coordinates with just the weight value+ -- FreeType will throw an error for non-variable fonts, which we catch+ ft_Set_Var_Design_Coordinates face [weightFixed] `catch` handleError+ where+ handleError :: FtError -> IO ()+ handleError _ = return () -- Silently ignore errors (non-variable fonts)++-- | Atlas info for a label's text+data AtlasInfo = AtlasInfo+ { atlasTexture :: !GL.TextureObject,+ atlasGlyphUVs :: ![(Float, Float, Float, Float)] -- (u0, v0, u1, v1) for each glyph+ }++-- | Get glyphs and create a texture atlas for the text using a pre-loaded font face+getGlyphsAndAtlasIOFromFace :: FT_Face -> String -> Int -> Bool -> IO ([GlyphInfo], AtlasInfo)+getGlyphsAndAtlasIOFromFace face text weight italic = do+ -- Render all glyphs and collect their bitmap data+ glyphData <- forM text $ \char -> do+ glyph <- renderGlyphMetrics face char weight italic+ bitmapData <- getGlyphBitmapData face char weight italic+ return (glyph, bitmapData)++ let glyphs = map fst glyphData+ bitmaps = map snd glyphData++ -- Calculate atlas dimensions (simple horizontal layout)+ let atlasWidth' = sum $ map (\(w, _, _) -> max 1 w) bitmaps+ atlasHeight' = maximum' $ map (\(_, h, _) -> max 1 h) bitmaps+ atlasW = max 1 atlasWidth'+ atlasH = max 1 atlasHeight'++ -- Create the atlas texture+ [tex] <- GL.genObjectNames 1+ GL.textureBinding GL.Texture2D $= Just tex+ GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')+ GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.ClampToEdge)+ GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.ClampToEdge)++ -- Allocate atlas buffer (RGBA for proper blending)+ atlasBuffer <- mallocBytes (atlasW * atlasH * 4)+ -- Clear to transparent black+ forM_ [0 .. atlasW * atlasH * 4 - 1] $ \i ->+ pokeByteOff atlasBuffer i (0 :: Word8)++ -- Copy each glyph into the atlas and calculate UVs+ let copyGlyphs :: [(Int, Int, Ptr Word8)] -> Int -> [(Float, Float, Float, Float)] -> IO [(Float, Float, Float, Float)]+ copyGlyphs [] _ uvs = return (reverse uvs)+ copyGlyphs ((w, h, buf) : rest) xOffset uvs = do+ -- Copy glyph bitmap to atlas (convert grayscale to RGBA)+ when (w > 0 && h > 0) $+ forM_ [0 .. h - 1] $ \row ->+ forM_ [0 .. w - 1] $ \col -> do+ let srcIdx = row * w + col+ dstIdx = (row * atlasW + (xOffset + col)) * 4+ alpha <- peekByteOff buf srcIdx :: IO Word8+ -- Set RGBA (white with alpha from glyph)+ pokeByteOff atlasBuffer dstIdx (255 :: Word8) -- R+ pokeByteOff atlasBuffer (dstIdx + 1) (255 :: Word8) -- G+ pokeByteOff atlasBuffer (dstIdx + 2) (255 :: Word8) -- B+ pokeByteOff atlasBuffer (dstIdx + 3) alpha -- A++ -- Free the copied bitmap buffer+ free buf++ -- Calculate UV coordinates for this glyph+ let u0 = fromIntegral xOffset / fromIntegral atlasW+ v0 = 0+ u1 = fromIntegral (xOffset + w) / fromIntegral atlasW+ v1 = fromIntegral h / fromIntegral atlasH++ copyGlyphs rest (xOffset + max 1 w) ((u0, v0, u1, v1) : uvs)++ uvs <- copyGlyphs bitmaps 0 []++ -- Upload atlas to GPU+ GL.rowAlignment GL.Unpack $= 1+ GL.texImage2D+ GL.Texture2D+ GL.NoProxy+ 0+ GL.RGBA8+ (GL.TextureSize2D (fromIntegral atlasW) (fromIntegral atlasH))+ 0+ (GL.PixelData GL.RGBA GL.UnsignedByte atlasBuffer)++ free atlasBuffer+ GL.textureBinding GL.Texture2D $= Nothing++ return (glyphs, AtlasInfo tex uvs)++-- | Get raw bitmap data for a glyph (width, height, buffer pointer)+-- Note: weight parameter is reserved for future synthetic bold implementation+getGlyphBitmapData :: FT_Face -> Char -> Int -> Bool -> IO (Int, Int, Ptr Word8)+getGlyphBitmapData face char _weight italic = do+ let charCode = fromIntegral $ fromEnum char+ glyphIndex <- ft_Get_Char_Index face charCode++ -- Apply italic transformation via FT_Set_Transform if needed+ when italic $ do+ let shear = 0.2 :: Double -- ~12 degree slant+ matrix =+ FT_Matrix+ { mXx = 0x10000,+ mXy = round (shear * 0x10000),+ mYx = 0,+ mYy = 0x10000+ }+ ft_Set_Transform face (Just matrix) Nothing++ ft_Load_Glyph face glyphIndex FT_LOAD_RENDER++ -- Reset transform after loading+ when italic $ ft_Set_Transform face Nothing Nothing++ faceRec <- peek face+ let glyphSlot = frGlyph faceRec+ slotRec <- peek glyphSlot++ let bitmap = gsrBitmap slotRec+ width = fromIntegral $ bWidth bitmap+ height = fromIntegral $ bRows bitmap+ buffer = bBuffer bitmap+ pitch = fromIntegral $ bPitch bitmap++ -- Copy the bitmap data since FreeType may overwrite it+ if width > 0 && height > 0+ then do+ bufCopy <- mallocBytes (width * height)+ forM_ [0 .. height - 1] $ \row -> do+ let srcOffset = row * pitch+ dstOffset = row * width+ copyBytes (plusPtr bufCopy dstOffset) (plusPtr buffer srcOffset) width+ return (width, height, bufCopy)+ else do+ emptyBuf <- mallocBytes 1+ pokeByteOff emptyBuf 0 (0 :: Word8)+ return (0, 0, emptyBuf)++-- | Render a glyph and get its metrics+-- Note: weight parameter is reserved for future synthetic bold implementation+renderGlyphMetrics :: FT_Face -> Char -> Int -> Bool -> IO GlyphInfo+renderGlyphMetrics face char _weight italic = do+ let charCode = fromIntegral $ fromEnum char+ glyphIndex <- ft_Get_Char_Index face charCode++ -- Apply italic transformation via FT_Set_Transform if needed+ when italic $ do+ let shear = 0.2 :: Double -- ~12 degree slant+ matrix =+ FT_Matrix+ { mXx = 0x10000,+ mXy = round (shear * 0x10000),+ mYx = 0,+ mYy = 0x10000+ }+ ft_Set_Transform face (Just matrix) Nothing++ ft_Load_Glyph face glyphIndex FT_LOAD_RENDER++ -- Reset transform after loading+ when italic $ ft_Set_Transform face Nothing Nothing++ -- Get glyph slot from face+ faceRec <- peek face+ let glyphSlot = frGlyph faceRec+ slotRec <- peek glyphSlot++ let bitmap = gsrBitmap slotRec+ width = fromIntegral $ bWidth bitmap+ height = fromIntegral $ bRows bitmap++ let metrics = gsrMetrics slotRec+ bitmapLeft = fromIntegral (gmHoriBearingX metrics) `div` 64+ bitmapTop = fromIntegral (gmHoriBearingY metrics) `div` 64+ advanceX = fromIntegral (gmHoriAdvance metrics) `div` 64++ -- We don't need individual textures anymore, just return glyph metrics+ -- Use a dummy texture object since we use atlas textures instead+ return $+ GlyphInfo+ { glyphTexture = GL.TextureObject 0,+ glyphWidth = width,+ glyphHeight = height,+ glyphBearingX = bitmapLeft,+ glyphBearingY = bitmapTop,+ glyphAdvance = advanceX+ }++-- | Compile mesh for rendering label glyphs+compileLabelMesh :: [GlyphInfo] -> AtlasInfo -> Mesh+compileLabelMesh glyphs atlasInfo = Mesh $ do+ [vbo] <- GL.genObjectNames 1+ GL.bindBuffer GL.ArrayBuffer $= Just vbo++ -- Generate vertices for all glyphs with atlas UVs+ let vertices = generateLabelVertices glyphs (atlasGlyphUVs atlasInfo) 0+ SV.unsafeWith (SV.fromList vertices) $ \ptr -> do+ let size = fromIntegral $ length vertices * sizeOf (undefined :: GL.GLfloat)+ GL.bufferData GL.ArrayBuffer $= (size, ptr, GL.StaticDraw)++ GL.bindBuffer GL.ArrayBuffer $= Nothing++ let numQuads = length glyphs+ vertexCount = fromIntegral $ numQuads * 6+ return $+ 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 GL.Triangles 0 vertexCount,+ meshPop = do+ GL.clientState GL.TextureCoordArray $= GL.Disabled+ GL.clientState GL.VertexArray $= GL.Disabled+ GL.bindBuffer GL.ArrayBuffer $= Nothing+ }++-- | Generate vertices for label glyphs (position + UV)+generateLabelVertices :: [GlyphInfo] -> [(Float, Float, Float, Float)] -> Float -> [GL.GLfloat]+generateLabelVertices [] _ _ = []+generateLabelVertices _ [] _ = []+generateLabelVertices (g : gs) ((u0, v0, u1, v1) : uvs) xOffset =+ let w = fromIntegral $ glyphWidth g+ h = fromIntegral $ glyphHeight g+ bx = fromIntegral $ glyphBearingX g+ by = fromIntegral $ glyphBearingY g+ x = xOffset + bx+ y = by - h++ -- Two triangles for the quad, using atlas UVs+ quadVerts =+ [ -- First triangle (bottom-left, bottom-right, top-right)+ x,+ y,+ u0,+ v1, -- bottom-left+ x + w,+ y,+ u1,+ v1, -- bottom-right+ x + w,+ y + h,+ u1,+ v0, -- top-right+ -- Second triangle (bottom-left, top-right, top-left)+ x,+ y,+ u0,+ v1, -- bottom-left+ x + w,+ y + h,+ u1,+ v0, -- top-right+ x,+ y + h,+ u0,+ v0 -- top-left+ ]+ nextOffset = xOffset + fromIntegral (glyphAdvance g)+ in map realToFrac quadVerts ++ generateLabelVertices gs uvs nextOffset++-- | Create material for rendering label with color tint+labelMaterial :: GL.TextureObject -> Float -> Float -> Float -> Float -> Material+labelMaterial tex r g b a =+ Material . pure $+ MaterialState+ { materialPush = do+ GL.blend $= GL.Enabled+ GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)+ GL.texture GL.Texture2D $= GL.Enabled+ GL.textureBinding GL.Texture2D $= Just tex+ GL.color $ GL.Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a :: GL.GLfloat),+ materialPop = do+ GL.textureBinding GL.Texture2D $= Nothing+ GL.texture GL.Texture2D $= GL.Disabled+ GL.blend $= GL.Disabled+ }
+ src/Aztecs/GL/Text/Label/Internal.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Aztecs.GL.Text.Label.Internal+ ( -- * Label State+ LabelState (..),+ GlyphInfo (..),++ -- * Font State+ FontState (..),++ -- * Font Cache+ FontCache (..),+ fontCache,+ )+where++import Aztecs+import Control.Monad.IO.Class+import Data.IORef+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import qualified Data.Vector as V+-- FreeType bindings+import FreeType.Core.Base+import qualified Graphics.Rendering.OpenGL as GL+import Prelude hiding (lookup)++-- | Information about a rendered glyph+data GlyphInfo = GlyphInfo+ { glyphTexture :: !GL.TextureObject,+ glyphWidth :: !Int,+ glyphHeight :: !Int,+ glyphBearingX :: !Int,+ glyphBearingY :: !Int,+ glyphAdvance :: !Int+ }+ deriving (Show, Eq)++-- | Label rendering state component (internal)+data LabelState = LabelState+ { labelGlyphs :: ![GlyphInfo],+ labelTotalWidth :: !Float,+ labelTotalHeight :: !Float,+ labelAtlasTexture :: !GL.TextureObject+ }++instance (Monad m) => Component m LabelState++-- | Font state component (internal) - holds loaded FreeType face+newtype FontState = FontState+ { fontStateFace :: FT_Face+ }++instance (Monad m) => Component m FontState++-- | Font cache singleton that holds FreeType resources+data FontCache = FontCache+ { fontCacheLibrary :: !FT_Library,+ fontCacheFaces :: !(IORef (Map FilePath FT_Face)),+ fontCacheGlyphs :: !(IORef (Map FilePath (Map Char GlyphInfo)))+ }++instance (Monad m) => Component m FontCache++-- | Get or create the @FontCache@ singleton+fontCache :: (MonadIO m) => Access m (EntityID, FontCache)+fontCache = do+ res <- system . readQuery $ (,) <$> entity <*> query @_ @FontCache+ case V.uncons res of+ Just ((e, fc), _) -> return (e, fc)+ Nothing -> do+ fc <- liftIO initFontCache+ e <- spawn $ bundle fc+ return (e, fc)++-- | Initialize the FreeType library and create a new font cache+initFontCache :: IO FontCache+initFontCache = do+ lib <- ft_Init_FreeType+ facesRef <- newIORef Map.empty+ glyphsRef <- newIORef Map.empty+ return $ FontCache lib facesRef glyphsRef
+ test/Main.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."