From 24345bb8f326d1c4fb80668e2c7ffbf8bccf2970 Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Date: Sun, 12 Sep 2021 18:41:42 +0300
Subject: [PATCH] Add font utils (#56)

- clearFontAtlas
- addFontDefault
- addFontFromFileTTF
- addFontFromMemoryTTF (raw only)
- buildFontAtlas

Vulkan example updated to use on f the imgui-distributed ttf files.
---
 examples/vulkan/Main.hs  | 29 ++++++++++++++++----
 src/DearImGui.hs         | 26 ++++++++++++++++++
 src/DearImGui/Context.hs |  1 +
 src/DearImGui/Raw.hs     | 59 ++++++++++++++++++++++++++++++++++++++++
 src/DearImGui/Structs.hs |  3 ++
 5 files changed, 112 insertions(+), 6 deletions(-)

diff --git a/examples/vulkan/Main.hs b/examples/vulkan/Main.hs
index d9c435a..0f9dd2a 100644
--- a/examples/vulkan/Main.hs
+++ b/examples/vulkan/Main.hs
@@ -83,6 +83,20 @@ type Handler    = LogMessage -> ResourceT IO ()
 deriving via ( ReaderT Handler (ResourceT IO) )
   instance MonadResource ( LoggingT LogMessage (ResourceT IO) )
 
+gui :: MonadIO m => m ImGui.DrawData
+gui = do
+  -- Prepare frame
+  ImGui.Vulkan.vulkanNewFrame
+  ImGui.SDL.sdl2NewFrame
+  ImGui.newFrame
+
+  -- Run your windows
+  ImGui.showDemoWindow
+
+  -- Process ImGui state into draw commands
+  ImGui.render
+  ImGui.getDrawData
+
 main :: IO ()
 main = runResourceT . ( `runLoggingT` logHandler ) $ app @( LoggingT LogMessage ( ResourceT IO ) )
 
@@ -120,6 +134,12 @@ app = do
     ImGui.createContext
     ImGui.destroyContext
 
+  logDebug "Adding fonts"
+  ImGui.clearFontAtlas
+  _default <- ImGui.addFontDefault
+  _custom <- ImGui.addFontFromFileTTF "imgui/misc/fonts/ProggyTiny.ttf" 10
+  ImGui.buildFontAtlas
+
   let
     preferredFormat :: Vulkan.SurfaceFormatKHR
     preferredFormat =
@@ -341,12 +361,6 @@ app = do
                 pure ( True, False )
               else
                 handleJust vulkanException ( pure . reloadQuit ) do
-                  ImGui.Vulkan.vulkanNewFrame
-                  ImGui.SDL.sdl2NewFrame
-                  ImGui.newFrame
-                  ImGui.showDemoWindow
-                  ImGui.render
-                  drawData <- ImGui.getDrawData
                   let
                     commandBuffer :: Vulkan.CommandBuffer
                     commandBuffer = commandBuffers Boxed.Vector.! fromIntegral nextImageIndex
@@ -355,7 +369,10 @@ app = do
                   Vulkan.resetCommandBuffer commandBuffer Vulkan.zero
                   beginCommandBuffer commandBuffer
                   cmdBeginRenderPass commandBuffer imGuiRenderPass framebuffer clearValues swapchainExtent
+
+                  drawData <- gui
                   ImGui.Vulkan.vulkanRenderDrawData drawData commandBuffer Nothing
+
                   cmdEndRenderPass commandBuffer
                   endCommandBuffer commandBuffer
                   submitCommandBuffer
diff --git a/src/DearImGui.hs b/src/DearImGui.hs
index feabc61..fc08571 100644
--- a/src/DearImGui.hs
+++ b/src/DearImGui.hs
@@ -245,6 +245,13 @@ module DearImGui
   , Raw.wantCaptureMouse
   , Raw.wantCaptureKeyboard
 
+    -- * Fonts
+  , Raw.Font
+  , addFontFromFileTTF
+  , Raw.addFontDefault
+  , Raw.buildFontAtlas
+  , Raw.clearFontAtlas
+
     -- * Types
   , module DearImGui.Enums
   , module DearImGui.Structs
@@ -1664,3 +1671,22 @@ pushStyleVar style valRef = liftIO do
 popStyleVar :: (MonadIO m) => Int -> m ()
 popStyleVar n = liftIO do
   Raw.popStyleVar (fromIntegral n)
+
+
+-- | Load a font from TTF file.
+--
+-- Specify font path and atlas glyph size.
+--
+-- Use 'addFontDefault' if you want to retain built-in font too.
+--
+-- Call 'buildFontAtlas' after adding all the fonts.
+--
+-- Call backend-specific `CreateFontsTexture` before using 'newFrame'.
+addFontFromFileTTF :: MonadIO m => FilePath -> Float -> m (Maybe Raw.Font)
+addFontFromFileTTF font size = liftIO do
+  res@(Raw.Font ptr) <- withCString font \fontPtr ->
+    Raw.addFontFromFileTTF fontPtr (CFloat size)
+  pure $
+    if castPtr ptr == nullPtr
+      then Nothing
+      else Just res
diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs
index 2302bc0..618a2e4 100644
--- a/src/DearImGui/Context.hs
+++ b/src/DearImGui/Context.hs
@@ -34,5 +34,6 @@ imguiContext = mempty
       , ( TypeName "ImVec3", [t| ImVec3 |] )
       , ( TypeName "ImVec4", [t| ImVec4 |] )
       , ( TypeName "ImGuiContext", [t| ImGuiContext |] )
+      , ( TypeName "ImFont", [t| ImFont |] )
       ]
   }
diff --git a/src/DearImGui/Raw.hs b/src/DearImGui/Raw.hs
index c360c0b..66dc547 100644
--- a/src/DearImGui/Raw.hs
+++ b/src/DearImGui/Raw.hs
@@ -209,6 +209,14 @@ module DearImGui.Raw
   , wantCaptureMouse
   , wantCaptureKeyboard
 
+    -- * Fonts in default font atlas
+  , Font(..)
+  , addFontDefault
+  , addFontFromFileTTF
+  , addFontFromMemoryTTF
+  , buildFontAtlas
+  , clearFontAtlas
+
     -- * Types
   , module DearImGui.Enums
   , module DearImGui.Structs
@@ -1514,3 +1522,54 @@ wantCaptureMouse = liftIO do
 wantCaptureKeyboard :: MonadIO m => m Bool
 wantCaptureKeyboard = liftIO do
   (0 /=) <$> [C.exp| bool { GetIO().WantCaptureKeyboard } |]
+
+
+-- | Wraps @ImFont*@.
+newtype Font = Font (Ptr ImFont)
+
+addFontDefault :: MonadIO m => m Font
+addFontDefault = liftIO do
+  Font <$> [C.block|
+    ImFont* {
+      return GetIO().Fonts->AddFontDefault();
+    }
+  |]
+
+addFontFromFileTTF :: MonadIO m => CString -> CFloat -> m Font
+addFontFromFileTTF filenamePtr sizePixels = liftIO do
+  Font <$> [C.block|
+    ImFont* {
+      return GetIO().Fonts->AddFontFromFileTTF(
+        $(char* filenamePtr),
+        $(float sizePixels));
+    }
+  |]
+
+-- | Transfer a buffer with TTF data to font atlas builder.
+addFontFromMemoryTTF :: MonadIO m => CStringLen -> CFloat -> m Font
+addFontFromMemoryTTF (castPtr -> fontDataPtr, fromIntegral -> fontSize) sizePixels = liftIO do
+  Font <$> [C.block|
+    ImFont* {
+      return GetIO().Fonts->AddFontFromMemoryTTF(
+        $(void* fontDataPtr),
+        $(int fontSize),
+        $(float sizePixels)
+      );
+    }
+  |]
+
+buildFontAtlas :: MonadIO m => m ()
+buildFontAtlas = liftIO do
+  [C.block|
+    void {
+      GetIO().Fonts->Build();
+    }
+  |]
+
+clearFontAtlas :: MonadIO m => m ()
+clearFontAtlas = liftIO do
+  [C.block|
+    void {
+      GetIO().Fonts->Clear();
+    }
+  |]
diff --git a/src/DearImGui/Structs.hs b/src/DearImGui/Structs.hs
index 302f56f..f274b69 100644
--- a/src/DearImGui/Structs.hs
+++ b/src/DearImGui/Structs.hs
@@ -74,3 +74,6 @@ instance Storable ImVec4 where
 
 -- | DearImGui context handle.
 data ImGuiContext
+
+-- | Individual font handle.
+data ImFont