diff --git a/Main.hs b/Main.hs index 7094595..1ea1428 100644 --- a/Main.hs +++ b/Main.hs @@ -7,6 +7,7 @@ module Main (main) where import Control.Monad import Data.IORef +import qualified Data.Vector as Vector import DearImGui import DearImGui.OpenGL3 import DearImGui.SDL @@ -131,6 +132,21 @@ loop window checked color slider r pos size' selected tab1Ref tab2Ref = do endChild + text "ListClipper" + withChildOpen "##fixed" (ImVec2 0 200) True ImGuiWindowFlags_None do + let lotsOfItems = Vector.generate 50 (mappend "Item " . show) + withListClipper Nothing lotsOfItems text + + text "ListClipper, Haskell-powered" + withChildOpen "##infinite" (ImVec2 0 200) True ImGuiWindowFlags_None do + let infiniteItems = map (mappend "Item " . show) [0 :: Int ..] + withListClipper Nothing infiniteItems text + + text "Ethereal ListClipper" + withChildOpen "##ethereal" (ImVec2 0 200) True ImGuiWindowFlags_None do + withListClipper Nothing (ClipRange (0 :: Int) 1000) $ + text . mappend "Item " . show + plotHistogram "A histogram" [ 10, 10, 20, 30, 90 ] colorPicker3 "Test" color diff --git a/dear-imgui.cabal b/dear-imgui.cabal index 902a57b..bfd8d7a 100644 --- a/dear-imgui.cabal +++ b/dear-imgui.cabal @@ -93,6 +93,7 @@ library DearImGui DearImGui.Raw DearImGui.Raw.DrawList + DearImGui.Raw.ListClipper other-modules: DearImGui.Context DearImGui.Enums @@ -117,6 +118,7 @@ library , inline-c-cpp , StateVar , unliftio + , vector if flag(opengl2) exposed-modules: @@ -241,7 +243,7 @@ executable test if (!flag(examples) || !flag(sdl) || !flag(opengl2)) buildable: False else - build-depends: base, sdl2, gl, dear-imgui + build-depends: base, sdl2, gl, dear-imgui, vector executable glfw main-is: Main.hs diff --git a/src/DearImGui.hs b/src/DearImGui.hs index af2621e..c2f8955 100644 --- a/src/DearImGui.hs +++ b/src/DearImGui.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -255,6 +256,11 @@ module DearImGui -- * Utilities + -- ** ListClipper + , withListClipper + , ClipItems(..) + , ClipRange(..) + -- ** Miscellaneous , Raw.getBackgroundDrawList , Raw.getForegroundDrawList @@ -298,7 +304,12 @@ import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (bracket, bracket_) import qualified DearImGui.Raw as Raw +import qualified DearImGui.Raw.ListClipper as Raw.ListClipper +-- vector +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU -- | Get the compiled version string e.g. "1.80 WIP" (essentially the value for -- @IMGUI_VERSION@ from the compiled version of @imgui.cpp@). @@ -1698,3 +1709,86 @@ addFontFromFileTTF font size = liftIO do if castPtr ptr == nullPtr then Nothing else Just res + +-- | Clips a large list of items +-- +-- The requirements on @a@ are that they are all of the same height. +withListClipper :: (ClipItems t a, MonadUnliftIO m) => Maybe Float -> t a -> (a -> m ()) -> m () +withListClipper itemHeight items action = + bracket + (liftIO $ throwIfNull "withListClipper: ListClipper allocation failed" Raw.ListClipper.new) + Raw.ListClipper.delete + step + where + itemHeight' = maybe (-1.0) CFloat itemHeight + itemCount' = maybe maxBound fromIntegral (itemCount items) + + step clipper = do + Raw.ListClipper.begin clipper itemCount' itemHeight' + go clipper + + go clipper = do + doStep <- Raw.ListClipper.step clipper + when doStep do + let + startIndex = fromIntegral $ Raw.ListClipper.displayStart clipper + endIndex = fromIntegral $ Raw.ListClipper.displayEnd clipper + stepItems action $ + clipItems startIndex endIndex items + + go clipper + +-- | Containers usable with 'ListClipper'. +class ClipItems t a where + itemCount :: t a -> Maybe Int + clipItems :: Int -> Int -> t a -> t a + stepItems :: Monad m => (a -> m ()) -> t a -> m () + +-- | Unbounded stream of items. +instance ClipItems [] a where + itemCount = const Nothing + + clipItems displayStart displayEnd = + take (displayEnd - displayStart) . drop displayStart + + stepItems = mapM_ + +instance ClipItems V.Vector a where + itemCount = Just . V.length + + clipItems displayStart displayEnd = + V.slice displayStart (displayEnd - displayStart) + + stepItems = V.mapM_ + +instance Storable a => ClipItems VS.Vector a where + itemCount = Just . VS.length + + clipItems displayStart displayEnd = + VS.slice displayStart (displayEnd - displayStart) + + stepItems = VS.mapM_ + +instance VU.Unbox a => ClipItems VU.Vector a where + itemCount = Just . VU.length + + clipItems displayStart displayEnd = + VU.slice displayStart (displayEnd - displayStart) + + stepItems = VU.mapM_ + +-- | ClipList helper for arbitrary unmaterialized ranges. +data ClipRange a = ClipRange a a + deriving (Eq, Ord, Show) + +instance (Ord a, Enum a, Num a) => ClipItems ClipRange a where + itemCount (ClipRange _begin end) = + Just $ fromEnum end + + clipItems clipBegin clipEnd (ClipRange oldBegin oldEnd) = + ClipRange + (toEnum $ max clipBegin $ fromEnum oldBegin) + (toEnum $ min clipEnd $ fromEnum oldEnd) + + stepItems action (ClipRange start end) = + mapM_ action [start .. end - 1] diff --git a/src/DearImGui/Context.hs b/src/DearImGui/Context.hs index 6d75f34..73e9068 100644 --- a/src/DearImGui/Context.hs +++ b/src/DearImGui/Context.hs @@ -37,5 +37,6 @@ imguiContext = mempty , ( TypeName "ImDrawList", [t| ImDrawList |] ) , ( TypeName "ImGuiContext", [t| ImGuiContext |] ) , ( TypeName "ImFont", [t| ImFont |] ) + , ( TypeName "ImGuiListClipper", [t| ImGuiListClipper |] ) ] } diff --git a/src/DearImGui/Raw/ListClipper.hs b/src/DearImGui/Raw/ListClipper.hs new file mode 100644 index 0000000..7bbe1ff --- /dev/null +++ b/src/DearImGui/Raw/ListClipper.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +{-| Helper: Manually clip large list of items. + +If you are submitting lots of evenly spaced items and you have a random access to the list, +you can perform coarse clipping based on visibility to save yourself from processing those items at all. + +The clipper calculates the range of visible items and advance the cursor to compensate for the non-visible items we have skipped. + +Dear ImGui already clips items based on their bounds but it needs to measure text size to do so, +whereas manual coarse clipping before submission makes this cost and your own data fetching/submission cost almost null. + +Usage: + +@ +clipper <- ListClipper.new +ListClipper.begin clipper 1000 -- We have 1000 elements, evenly spaced. +whileTrue (ListClipper.step clipper) $ + start <- ListClipper.displayStart clipper + end <- ListClipper.displayEnd clipper + for_ [start .. end] \ix -> + ImGui.text $ "line number " <> show ix +@ + +Generally what happens is: + +* Clipper lets you process the first element (DisplayStart = 0, DisplayEnd = 1) regardless of it being visible or not. +* User code submit one element. +* Clipper can measure the height of the first element +* Clipper calculate the actual range of elements to display based on the current clipping rectangle, + position the cursor before the first visible element. +* User code submit visible elements. +-} + +module DearImGui.Raw.ListClipper + ( ListClipper + , new + , delete + , begin + , displayStart + , displayEnd + , step + ) + where + +import Control.Monad.IO.Class + ( MonadIO, liftIO ) +import Foreign hiding (new) +import Foreign.C +import System.IO.Unsafe (unsafePerformIO) + +-- dear-imgui +import DearImGui.Context + ( imguiContext ) +import DearImGui.Structs + ( ImGuiListClipper ) + +-- inline-c +import qualified Language.C.Inline as C + +-- inline-c-cpp +import qualified Language.C.Inline.Cpp as Cpp + +C.context (Cpp.cppCtx <> C.bsCtx <> imguiContext) +C.include "imgui.h" +Cpp.using "namespace ImGui" + + +-- | @ImGuiListClipper@ object handle. +type ListClipper = Ptr ImGuiListClipper + + +-- | Create a new 'ListClipper' instance. +new :: (MonadIO m) => m ListClipper +new = liftIO do + [C.block| + ImGuiListClipper* { + return IM_NEW(ImGuiListClipper); + } + |] + +-- | Destroy 'ListClipper' instance. +delete :: (MonadIO m) => ListClipper -> m () +delete clipper = liftIO do + [C.block| + void { + IM_DELETE($(ImGuiListClipper* clipper)); + } + |] + + +-- | ListClipper setup +-- +-- @items_count@: Use 'maxBound' if you don't know how many items you have +-- (in which case the cursor won't be advanced in the final step). +-- +-- @items_height@: Use -1.0f to be calculated automatically on first step. +-- Otherwise pass in the distance between your items, typically +-- 'getTextLineHeightWithSpacing' or 'getFrameHeightWithSpacing'. +-- +-- Wraps @ListClipper::Begin()@. +begin :: (MonadIO m) => ListClipper -> CInt -> CFloat -> m () +begin clipper items_count items_height = liftIO do + [C.block| + void { + $(ImGuiListClipper* clipper)->Begin($(int items_count), $(float items_height)); + } + |] + +-- | An accessor for @ListClipper::Begin@ +displayStart :: ListClipper -> CInt +displayStart clipper = unsafePerformIO do + [C.exp| + int { + $(ImGuiListClipper* clipper)->DisplayStart + } + |] + +-- | An accessor for @ListClipper::DisplayStart@ +displayEnd :: ListClipper -> CInt +displayEnd clipper = unsafePerformIO + [C.exp| + int { + $(ImGuiListClipper* clipper)->DisplayEnd + } + |] + + +-- | Call until it returns 'False'. +-- +-- The 'displayStart'/'displayEnd' fields will be set and you can process/draw those items. +-- +-- Wraps @ListClipper::Step()@. +step :: (MonadIO m) => ListClipper -> m Bool +step clipper = liftIO do + (0 /=) <$> [C.block| + bool { + return $(ImGuiListClipper* clipper)->Step(); + } + |] diff --git a/src/DearImGui/Structs.hs b/src/DearImGui/Structs.hs index 77dd4b9..061cb49 100644 --- a/src/DearImGui/Structs.hs +++ b/src/DearImGui/Structs.hs @@ -83,5 +83,8 @@ data ImFont -- | Opaque DrawList handle. data ImDrawList +-- | 'DearImGui.Raw.ListClipper.ListClipper' pointer tag. +data ImGuiListClipper + -- | 32-bit unsigned integer (often used to store packed colors). type ImU32 = Word32