diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for keid-dearimgui +## 0.1.3.2 + +- Add `Render.ImGui.askWindowBox`, a helper to get a `Box` using dear-imgui coordinates. +- Add `Render.ImGui.Window`: + - a set of helpers to produce ImGui windows with the requested propeties and run actions inside them. + - and also a bridge to the experimental `geomancy-layout` "views" layout. + ## 0.1.3.1 - Update for dear-imgui-2.3.0. diff --git a/keid-ui-dearimgui.cabal b/keid-ui-dearimgui.cabal --- a/keid-ui-dearimgui.cabal +++ b/keid-ui-dearimgui.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: keid-ui-dearimgui -version: 0.1.3.1 +version: 0.1.3.2 synopsis: DearImGui elements for Keid engine. category: Game Engine author: IC Rainbow @@ -25,6 +25,7 @@ library exposed-modules: Render.ImGui + Render.ImGui.Window other-modules: Paths_keid_ui_dearimgui hs-source-dirs: @@ -63,6 +64,8 @@ , binary , bytestring , dear-imgui >=2.3.0 && <2.4 + , geomancy + , geomancy-layout , keid-core >=0.1.8.0 , resourcet , rio >=0.1.12.0 diff --git a/src/Render/ImGui.hs b/src/Render/ImGui.hs --- a/src/Render/ImGui.hs +++ b/src/Render/ImGui.hs @@ -15,23 +15,32 @@ , mkDrawData , draw + + , rootLayout + , layout + , askWindowBox ) where import RIO import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, register) +import Data.Type.Equality (type (~)) import DearImGui qualified as ImGui import DearImGui.FontAtlas qualified as FontAtlas import DearImGui.GLFW (glfwNewFrame, glfwShutdown) import DearImGui.GLFW.Vulkan (glfwInitForVulkan) import DearImGui.Vulkan (InitInfo(..)) import DearImGui.Vulkan qualified as ImGui +import Engine.Setup.Window qualified as Window import Engine.Stage.Component qualified as Stage -import Engine.Types (GlobalHandles(..), StageRIO) +import Engine.Types (GlobalHandles(..), StageFrameRIO, StageRIO, askWindowSize) import Engine.Vulkan.Types (HasRenderPass(..), HasSwapchain(..), Queues(..), getDevice, getMultisample) +import Engine.Worker qualified as Worker +import Geomancy.Layout.Box as Box +import Geomancy.Layout.View as View +import RIO.App (appEnv) import Resource.Region qualified as Region import Resource.Vulkan.DescriptorPool qualified as DescriptorPool -import RIO.App (appEnv) import Vulkan.Core10 qualified as Vk import Vulkan.Exception (VulkanException(..)) import Vulkan.NamedType (type (:::)) @@ -206,3 +215,20 @@ void $! allocate swapchain (getRP rps) subpassIx rAllocateP swapchain rps } + +-- | Run a full-screen layout using ImGui coordinates (origin at top-left) +{-# INLINE rootLayout #-} +rootLayout + :: (LayoutView stuff, Placed stuff ~ StageFrameRIO rp p rr st ()) + => View () stuff + -> StageFrameRIO rp p rr st () +rootLayout viewTree = do + root <- askWindowBox + View.foldWith id root viewTree + +-- | Get a window box using ImGui coordinates (origin at top-left) +{-# INLINE askWindowBox #-} +askWindowBox :: StageFrameRIO rp p rr st Box +askWindowBox = do + Window.Size{window} <- mapRIO fst askWindowSize >>= Worker.getOutputData + pure Box{size=window, position=window/2} diff --git a/src/Render/ImGui/Window.hs b/src/Render/ImGui/Window.hs new file mode 100644 --- /dev/null +++ b/src/Render/ImGui/Window.hs @@ -0,0 +1,130 @@ +module Render.ImGui.Window + ( Window(..) + , pack + , toView + , setNextWindowBox + , run + ) where + +import RIO + +import Data.Bits ((.|.)) +import Data.ByteString.Unsafe (unsafeInit, unsafeUseAsCString) +import DearImGui.Raw qualified as Raw +import Foreign (castPtr, free, new, nullPtr, peek, with) +import Foreign.C.Types (CFloat(..)) +import Geomancy (Vec2, vec2) +import Geomancy.Layout.Box (Box(..)) +import Geomancy.Layout.View as LV +import GHC.OverloadedLabels (IsLabel(..)) +import GHC.Records (HasField(..)) +import GHC.TypeLits (KnownSymbol, symbolVal) + +data Window = Window + { name0 :: ByteString -- ^ NUL-terminated UTF-8 encoded name for less copying. + , contentSize :: Maybe Vec2 -- ^ Set content size (~ scrollable client area, which enforce the range of scrollbars). Not including window decorations (title bar, menu bar, etc.) nor WindowPadding. + , sizeConstraints :: Maybe (Vec2, Vec2) -- ^ Set size limits. use -1,-1 on either X/Y axis to preserve the current size. Sizes will be rounded down. + , collapsed :: Maybe Bool -- ^ Set collapsed state. + , focus :: Bool -- ^ Set focus state. + , scroll :: Maybe Vec2 -- ^ Set scrolling value (use < 0.0f to not affect a given axis). + , bgAlpha :: Maybe Float -- ^ Set background color alpha. helper to easily override the Alpha component of ImGuiCol_WindowBg, ChildBg, PopupBg. you may also use ImGuiWindowFlags_NoBackground. + , flags :: Raw.ImGuiWindowFlags -- ^ Set window flags. + , onClose :: Maybe (IO ()) -- ^ Allow window to be closed and set a callback. + } + +instance HasField "name" Window Text where + getField Window{name0} = decodeUtf8Lenient (unsafeInit name0) + +instance IsString Window where + fromString = pack . fromString + +instance KnownSymbol label => IsLabel label Window where + fromLabel = base{flags = base.flags .|. Raw.ImGuiWindowFlags_NoTitleBar} + where + base = pack . fromString . ("##" ++) . symbolVal $ Proxy @label + +pack :: Text -> Window +pack name = Window + { name0 = encodeUtf8 $ name <> "\0" + , contentSize = Nothing + , sizeConstraints = Nothing + , collapsed = Nothing + , scroll = Nothing + , focus = False + , bgAlpha = Nothing + , flags = Raw.ImGuiWindowFlags_NoSavedSettings + , onClose = Nothing + } + +{- | ImGui windows as Views + +@ +hstack_ -- Split-screen with equally-sized windows + [ Window.toView "Hi" $ ImGui.text "hi" -- title and default options + , Window.toView #AnonWithID $ ImGui.text "hi" -- empty title with a hidden ID (and default options) + , Window.toView example $ ImGui.text "hi" -- reusable window value + ] +@ +-} +toView :: Window -> m () -> View () (Windowed m) +toView config action = LV.view_ Windowed{..} + +data Windowed m = Windowed + { config :: Window + , action :: m () + } + +instance MonadUnliftIO m => LayoutView (Windowed m) where + type Placed (Windowed m) = m () + placeView box Windowed{..} = do + setNextWindowBox box + let + flags = + config.flags .|. + Raw.ImGuiWindowFlags_NoMove .|. + Raw.ImGuiWindowFlags_NoResize .|. + Raw.ImGuiWindowFlags_NoCollapse + run (config{flags}) action + +run :: MonadUnliftIO m => Window -> m () -> m () +run window action = do + liftIO do + for_ window.contentSize \size -> + with size $ Raw.setNextWindowContentSize . castPtr + for_ (window.sizeConstraints <|> (Just (-1, -1))) \(minSize, maxSize) -> + with minSize \minPtr -> + with maxSize \maxPtr -> + Raw.setNextWindowSizeConstraints (castPtr minPtr) (castPtr maxPtr) + for_ window.collapsed $ \collapsed -> + Raw.setNextWindowCollapsed (bool 0 1 collapsed) Raw.ImGuiCond_Always + when window.focus Raw.setNextWindowFocus + for_ window.scroll \scroll -> + with scroll $ Raw.setNextWindowScroll . castPtr + for_ window.bgAlpha $ + Raw.setNextWindowBgAlpha . CFloat + + bracket + ( liftIO do + open_ <- for window.onClose \callback -> (callback,) <$> new 1 + unsafeUseAsCString window.name0 \namePtr -> + (open_,) <$> Raw.begin namePtr (Just $ maybe nullPtr snd open_) (Just window.flags) + ) + ( \(open_, _) -> liftIO do + case open_ of + Just (callback, openPtr) | openPtr /= nullPtr -> do + stillOpen <- peek openPtr + Raw.end + free openPtr + when (stillOpen == 0) callback + _ -> Raw.end + ) + (\(_openPtr, visible) -> when visible action) + +{-# INLINE setNextWindowBox #-} +setNextWindowBox :: MonadIO m => Box -> m () +setNextWindowBox box = liftIO do + with box.position \pos -> + with (vec2 0.5 0.5) \pivot -> + Raw.setNextWindowPos (castPtr pos) Raw.ImGuiCond_Always (Just $ castPtr pivot) + with box.size \size -> + Raw.setNextWindowSize (castPtr size) Raw.ImGuiCond_Always