From c33b23ec7794caa5cf571dd58e9ebc26f5b51231 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 9 May 2023 11:10:30 +1200
Subject: [PATCH] Implement script for rendering pre-shaped text.

---
 app/Shaped.hs      | 72 ++++++++++++++++++++++++++++++++++++++++++++++
 typograffiti.cabal | 10 +++++--
 2 files changed, 80 insertions(+), 2 deletions(-)
 create mode 100644 app/Shaped.hs

diff --git a/app/Shaped.hs b/app/Shaped.hs
new file mode 100644
index 0000000..d7426c6
--- /dev/null
+++ b/app/Shaped.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import System.Environment (getArgs)
+import Typograffiti (makeDrawGlyphs, allocAtlas, TextTransform(..),
+                     AllocatedRendering(..), SpatialTransform(..))
+import Typograffiti.Atlas (glyphRetriever)
+import Control.Monad.Except (liftEither, runExceptT)
+import Control.Monad.IO.Class (MonadIO (..))
+import SDL hiding (rotate)
+import Graphics.GL.Core32
+
+import Data.Function (fix)
+import Data.Text.Lazy (pack)
+import Control.Monad (unless, forM)
+
+import qualified Data.IntSet as IS
+import Data.Int (Int32)
+import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..))
+import FreeType.Core.Base (ft_With_FreeType, ft_With_Face)
+
+main :: IO ()
+main = do
+    SDL.initializeAll
+
+    let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
+        wcfg = defaultWindow {
+            windowInitialSize = V2 640 480,
+            windowGraphicsContext = OpenGLContext openGL,
+            windowResizable = True
+          }
+    w <- createWindow "Typograffiti" wcfg
+    _ <- glCreateContext w
+
+    let ttfName = "assets/Lora-Regular.ttf"
+    args <- getArgs
+    let (fontfile, ppemX, ppemY, infile) = case args of
+            (fontfile:ppem:infile:_)
+                | (ppemX, ',':ppemY) <- break (== ',') ppem ->
+                    (fontfile, read ppemX, read ppemY, infile)
+                | otherwise -> (fontfile, read ppem, read ppem, infile)
+            _ -> (ttfName, 15, 15, "shaped.txt")
+    text <- read <$> readFile infile :: IO [(Int32,Int32,[(GlyphInfo,GlyphPos)])]
+    let glyphs = IS.fromList [fromIntegral $ codepoint info
+            | (_, _, glyphs) <- text, (info, _) <- glyphs]
+
+    atlas' <- ft_With_FreeType $ \ft -> ft_With_Face ft fontfile 0 $ \font -> do
+        let font' = glyphRetriever font
+        runExceptT $ allocAtlas font' (map toEnum $ IS.toList glyphs) (ppemX, ppemY)
+
+    err <- runExceptT $ do
+        drawGlyphs <- makeDrawGlyphs
+        atlas <- liftEither atlas'
+        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)
+
+            forM text $ \(x, y, para) -> do
+                sprite <- drawGlyphs atlas para
+                liftIO $ arDraw sprite [
+                    TextTransformSpatial $ SpatialTransformTranslate $
+                        fromIntegral <$> V2 x y
+                  ] (fromIntegral <$> sz)
+
+            liftIO $ glSwapWindow w
+            unless (QuitEvent `elem` events) loop
+    print err
+    return ()
diff --git a/typograffiti.cabal b/typograffiti.cabal
index 97e84e2..1b27469 100644
--- a/typograffiti.cabal
+++ b/typograffiti.cabal
@@ -33,7 +33,7 @@ library
       Typograffiti.Store
       Typograffiti.Text
       Typograffiti.Rich
-  build-depends:       base >=4.12 && <4.16, linear>=1.20, containers >= 0.6,
+  build-depends:       base >=4.12 && <5, linear>=1.20, containers >= 0.6,
                         freetype2 >= 0.2, gl >= 0.8, mtl >= 2.2, stm >= 2.5, text,
                         vector >= 0.12, harfbuzz-pure >= 1.0.2, bytestring >= 0.10
   hs-source-dirs:      src
@@ -42,7 +42,13 @@ library
 
 executable typograffiti
   main-is:             Main.hs
-  build-depends:       base >=4.12 && <4.16, typograffiti, sdl2 >= 2.5.4, text, gl, mtl
+  build-depends:       base >=4.12 && <5, typograffiti, sdl2 >= 2.5.4, text, gl, mtl
   hs-source-dirs:      app
   default-language:    Haskell2010
 
+executable draw-shaped
+  main-is:             Shaped.hs
+  build-depends:       base >=4.12 && <5, typograffiti, sdl2 >= 2.5.4,
+                       text, gl, mtl, containers, harfbuzz-pure, freetype2
+  hs-source-dirs:      app
+  default-language:    Haskell2010
-- 
2.30.2