diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/aztecs-gl-text.cabal b/aztecs-gl-text.cabal new file mode 100644 --- /dev/null +++ b/aztecs-gl-text.cabal @@ -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 diff --git a/src/Aztecs/GL/Text.hs b/src/Aztecs/GL/Text.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/GL/Text.hs @@ -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 diff --git a/src/Aztecs/GL/Text/Font.hs b/src/Aztecs/GL/Text/Font.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/GL/Text/Font.hs @@ -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 diff --git a/src/Aztecs/GL/Text/Font/Internal.hs b/src/Aztecs/GL/Text/Font/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/GL/Text/Font/Internal.hs @@ -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 diff --git a/src/Aztecs/GL/Text/Label.hs b/src/Aztecs/GL/Text/Label.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/GL/Text/Label.hs @@ -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 + } diff --git a/src/Aztecs/GL/Text/Label/Internal.hs b/src/Aztecs/GL/Text/Label/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/GL/Text/Label/Internal.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."