dear-imgui.hs/examples/sdl/Image.hs

182 lines
4.9 KiB
Haskell
Raw Normal View History

{-# language BlockArguments #-}
{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
2021-09-12 11:56:43 +00:00
{- | Drawing an DearImGui image using OpenGL textures.
https://github.com/ocornut/imgui/wiki/Image-Loading-and-Displaying-Examples
-}
module Main ( main ) where
import Control.Exception
2021-09-12 11:56:43 +00:00
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (managed, managed_, runManaged)
import DearImGui
import qualified DearImGui.Raw as Raw
import DearImGui.OpenGL3
import DearImGui.SDL
import DearImGui.SDL.OpenGL
import Graphics.GL
import qualified SDL as SDL
-- For the texture creation
import Foreign
import qualified Data.Vector.Storable as VS
2021-09-12 11:56:43 +00:00
data Texture = Texture
{ textureID :: GLuint
, textureWidth :: GLsizei
, textureHeight :: GLsizei
}
2021-09-12 13:20:47 +00:00
deriving (Show)
2021-09-12 11:56:43 +00:00
textureSize :: Texture -> ImVec2
textureSize texture =
ImVec2
(fromIntegral $ textureWidth texture)
(fromIntegral $ textureHeight texture)
-- | Create a texture pointer in GL memory.
create2DTexture :: Int -> Int -> IO Texture
2021-09-12 11:56:43 +00:00
create2DTexture width height =
alloca \ptr -> do
glGenTextures 1 ptr
tID <- peek ptr
2021-09-12 11:56:43 +00:00
return Texture
{ textureID = tID
, textureWidth = fromIntegral width
, textureHeight = fromIntegral height
}
bindTexture :: Texture -> Ptr GLubyte -> IO ()
bindTexture texture dataPtr = do
glEnable GL_TEXTURE_2D
2021-09-12 11:56:43 +00:00
glBindTexture GL_TEXTURE_2D (textureID texture)
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
2021-09-12 11:56:43 +00:00
glTexImage2D
GL_TEXTURE_2D
0
GL_RGB
(textureWidth texture)
(textureHeight texture)
0
GL_RGB
GL_UNSIGNED_BYTE
(castPtr dataPtr)
2021-09-12 13:20:47 +00:00
fill :: Texture -> (GLubyte, GLubyte, GLubyte) -> VS.Vector GLubyte
fill texture (r, g, b) =
2021-09-12 11:56:43 +00:00
VS.generate
2021-09-12 13:20:47 +00:00
(3 * width * height)
2021-09-12 11:56:43 +00:00
(\i ->
case i `mod` 3 of
2021-09-12 13:20:47 +00:00
0 -> r
1 -> g
2 -> b
2021-09-12 11:56:43 +00:00
_ -> error "assert: 3-byte pitch"
)
2021-09-12 13:20:47 +00:00
where
width = fromIntegral (textureWidth texture)
height = fromIntegral (textureHeight texture)
2021-09-12 11:56:43 +00:00
main :: IO ()
main = do
-- Initialize SDL
SDL.initializeAll
runManaged do
-- Create a window using SDL. As we're using OpenGL, we need to enable OpenGL too.
2021-09-12 11:56:43 +00:00
window <- do
let title = "Hello, Dear ImGui!"
let config = SDL.defaultWindow { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL, SDL.windowResizable = True }
managed $ bracket (SDL.createWindow title config) SDL.destroyWindow
-- Create an OpenGL context
2021-09-12 11:56:43 +00:00
glContext <- managed $ bracket (SDL.glCreateContext window) SDL.glDeleteContext
-- Create an ImGui context
2021-09-12 11:56:43 +00:00
_dearContext <- managed $ bracket createContext destroyContext
-- Initialize ImGui's SDL2 backend
2021-09-12 11:56:43 +00:00
managed_ $ bracket_ (sdl2InitForOpenGL window glContext) sdl2Shutdown
-- Initialize ImGui's OpenGL backend
2021-09-12 11:56:43 +00:00
managed_ $ bracket_ openGL3Init do
putStrLn "ImguiOpenGL shut down"
2021-09-12 11:56:43 +00:00
openGL3Shutdown
liftIO do
2021-09-12 13:20:47 +00:00
blueish <- create2DTexture 320 240
VS.unsafeWith (fill blueish (0x00, 0x7F, 0xFF)) $
bindTexture blueish
pinkish <- create2DTexture 240 320
VS.unsafeWith (fill pinkish (0xFF, 0x00, 0x7F)) $
bindTexture pinkish
err <- glGetError
2021-09-12 11:56:43 +00:00
putStrLn $ "Error-code: " ++ show err
2021-09-12 13:20:47 +00:00
print (blueish, pinkish)
mainLoop window (blueish, pinkish) False
2021-09-12 13:20:47 +00:00
mainLoop :: SDL.Window -> (Texture, Texture) -> Bool -> IO ()
mainLoop window textures flag = unlessQuit do
-- Tell ImGui we're starting a new frame
openGL3NewFrame
sdl2NewFrame
newFrame
-- Build the GUI
2021-09-12 13:20:47 +00:00
clicked <- withWindow "Image example" \open ->
if open then do
text "That's an image, click it"
newLine
let texture = if flag then fst textures else snd textures
-- Drawing images require some backend-specific code.
-- Meanwhile, we have to deal with raw binding.
let openGLtextureID = intPtrToPtr $ fromIntegral $ textureID texture
Foreign.with (textureSize texture) \sizePtr ->
Foreign.with (ImVec2 0 0) \uv0Ptr ->
Foreign.with (ImVec2 1 1) \uv1Ptr ->
Foreign.with (ImVec4 1 1 1 1) \tintColPtr ->
Foreign.with (ImVec4 1 1 1 1) \bgColPtr ->
Raw.imageButton openGLtextureID sizePtr uv0Ptr uv1Ptr (-1) bgColPtr tintColPtr
else
pure False
-- Render
glClear GL_COLOR_BUFFER_BIT
2021-09-12 11:56:43 +00:00
DearImGui.render
DearImGui.getDrawData >>= openGL3RenderDrawData
2021-09-12 11:56:43 +00:00
SDL.glSwapWindow window
2021-09-12 13:20:47 +00:00
mainLoop window textures (flag /= clicked)
where
2021-09-12 11:56:43 +00:00
unlessQuit action = do
shouldQuit <- checkEvents
if shouldQuit then pure () else action
checkEvents = do
pollEventWithImGui >>= \case
Nothing ->
return False
Just event ->
(isQuit event ||) <$> checkEvents
isQuit event =
SDL.eventPayload event == SDL.QuitEvent