From a7ebef90e979e6ab21210b7ce94807bfa04e4dd3 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 15 Mar 2023 17:14:08 +1300
Subject: [PATCH] Prepare atlases for text rendering!

---
 src/Main.hs | 57 ++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 37 insertions(+), 20 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index f6587be..1b1316e 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -29,16 +29,22 @@ import           Stylist.Tree (treeFind)
 import           Data.HTML2CSS (el2stylist)
 
 import           Graphics.Layout.CSS (CSSBox(..), finalizeCSS')
-import           Graphics.Layout.CSS.Internal (placeholderFont, Font'(..), pattern2font)
+import           Graphics.Layout.CSS.Internal (placeholderFont, Font'(..),
+                                                pattern2font, hbScale)
 import           Graphics.Layout.Box as B (zeroBox, PaddedBox(..), Size(..))
-import           Graphics.Layout (boxLayout)
+import           Graphics.Layout (boxLayout, glyphsPerFont)
 import           Graphics.Text.Font.Choose (nameParse)
+import           FreeType.FontConfig (instantiatePattern, bmpAndMetricsForIndex,
+                                      FTFC_Subpixel(..))
 
 import SDL hiding (rotate)
 import Graphics.GL.Core32
 
 import Data.Function (fix)
-import Control.Monad (unless)
+import Control.Monad (unless, forM)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.IntSet as IS
+import qualified Data.Map.Strict as M
 
 import Data.Maybe (fromMaybe)
 import System.Environment (getArgs)
@@ -130,6 +136,9 @@ main = do
     let css' = CSSPseudo.inner $ resolve' pseudofilter css
     let style = CSSTxt.resolve $ inlinePseudos' $ stylize css' $ el2stylist $
             documentRoot $ html page
+    let sysfont = (pattern2font (nameParse "serif") Style.temp { cssFontSize = (12,"pt") }
+                   placeholderFont placeholderFont) { scale = read scale' }
+    let layout0 = boxLayout infbox (finalizeCSS' sysfont style) False
 
     SDL.initializeAll
     let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
@@ -141,20 +150,28 @@ main = do
     w <- createWindow "Typograffiti" wcfg
     _ <- glCreateContext w
 
-    fix $ \loop -> do
-        events <- fmap eventPayload <$> pollEvents
-        glClearColor 0 0 0 1
-        glClear GL_COLOR_BUFFER_BIT
-
-        sz@(V2 dw dh) <- glGetDrawableSize w
-        glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
-
-        let size = B.Size (fromIntegral dw) (fromIntegral dh)
-        let outerbox = zeroBox { B.min = size, B.size = size, B.max = size }
-        let sysfont = (pattern2font (nameParse "serif-12") Style.temp
-                       placeholderFont placeholderFont) { scale = read scale' }
-        let layout = boxLayout outerbox (finalizeCSS' sysfont style) False
-
-        glSwapWindow w
-        unless (QuitEvent `elem` events) loop
-    return ()
+    ft_With_FreeType $ \ft -> runExceptT $ do
+        drawGlyphs <- makeDrawGlyphs
+        atlases <- forM (M.toList $ glyphsPerFont layout0) $ \((pat, size), glyphs) -> do
+            font <- liftIO $ instantiatePattern ft pat (-1, size)
+            atlas <- allocAtlas (liftIO . bmpAndMetricsForIndex font SubpixelDefault)
+                        (map toEnum $ IS.toList glyphs)
+                        (hbScale sysfont, hbScale sysfont)
+            return ((pat, size), atlas)
+        let atlases' = M.fromList atlases
+
+        fix $ \loop -> do
+            events <- fmap eventPayload <$> pollEvents
+            liftIO $ glClearColor 0 0 0 1
+            liftIO $ glClear GL_COLOR_BUFFER_BIT
+
+            sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w
+            liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
+
+            let size = B.Size (fromIntegral dw) (fromIntegral dh)
+            let outerbox = zeroBox { B.min = size, B.size = size, B.max = size }
+            let layout = boxLayout outerbox (finalizeCSS' sysfont style) False
+
+            liftIO $ glSwapWindow w
+            unless (QuitEvent `elem` events) loop
+        return ()
-- 
2.30.2