From 4ecf62ac9e5f20cf25435f405f1c6dda888c7d3d Mon Sep 17 00:00:00 2001
From: jpwidera <30520224+jpwidera@users.noreply.github.com>
Date: Fri, 17 Sep 2021 10:09:22 +0200
Subject: [PATCH] Implement ImGuiListClipper (#100)

* Added DearImGui.Raw.ImGuiListClipper
* Added the DearImGui.withListClipper bracket
* Added dependency for `vector`
* Added the test in the Main.hs
---
 Main.hs                          |  16 ++++
 dear-imgui.cabal                 |   4 +-
 src/DearImGui.hs                 |  94 +++++++++++++++++++
 src/DearImGui/Context.hs         |   1 +
 src/DearImGui/Raw/ListClipper.hs | 149 +++++++++++++++++++++++++++++++
 src/DearImGui/Structs.hs         |   3 +
 6 files changed, 266 insertions(+), 1 deletion(-)
 create mode 100644 src/DearImGui/Raw/ListClipper.hs

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