diff options
Diffstat (limited to 'Graphics/SDL')
| -rw-r--r-- | Graphics/SDL/SDLHelp.hs | 93 |
1 files changed, 56 insertions, 37 deletions
diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs index 75806b2..62bb640 100644 --- a/Graphics/SDL/SDLHelp.hs +++ b/Graphics/SDL/SDLHelp.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns, RankNTypes #-} module Graphics.SDL.SDLHelp where -import Graphics.UI.SDL.Image as SDLImg -import Graphics.UI.SDL as SDL import Data.Word import Control.Monad import Graphics.Glyph.Util +import SDL as SDL +import SDL.Video.Renderer (SurfacePixelFormat(..)) + +import Graphics.GL.Compatibility30 import Graphics.Rendering.OpenGL as GL -import Graphics.Rendering.OpenGL.Raw.Core31 import Foreign.Storable import Foreign.Ptr @@ -28,22 +30,21 @@ data TextureData3D = TextureData3D { bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData bindSurfaceToTexture surf to = do - textureBinding Texture2D $= Just to - bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf) - putStrLn $ "bpp: " ++! bbp - ptr <- surfaceGetPixels surf - glTexImage2D gl_TEXTURE_2D 0 bbp (w surf) (h surf) 0 (if bbp == 3 then gl_RGB else gl_RGBA) gl_UNSIGNED_BYTE ptr - return $ TextureData (w surf, h surf) to - where - w :: (Integral a) => SDL.Surface -> a - w = fromIntegral . surfaceGetWidth - h :: (Integral a) => SDL.Surface -> a - h = fromIntegral . surfaceGetHeight + textureBinding Texture2D $= Just to + bbp <- return 4 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ SDL.surfacePixels surf) + ptr <- SDL.surfacePixels surf + (V2 w h) <- SDL.surfaceDimensions surf + + glTexImage2D GL_TEXTURE_2D 0 bbp (fi w) (fi h) 0 (if bbp == 3 then GL_RGB else GL_RGBA) GL_UNSIGNED_BYTE ptr + return $ TextureData (fi w, fi h) to + where + fi :: (Integral a, Integral b) => a -> b + fi = fromIntegral textureFromPointer3D :: Ptr Word8 -> (Int,Int,Int) -> TextureObject -> IO TextureData3D textureFromPointer3D ptr (w,h,d) to = do textureBinding Texture3D $= Just to - glTexImage3D gl_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 gl_RGB gl_UNSIGNED_BYTE ptr + glTexImage3D GL_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 GL_RGB GL_UNSIGNED_BYTE ptr return $ TextureData3D (w,h,d) to where f = fromIntegral @@ -66,9 +67,10 @@ makeTexture = do getPixel :: Int -> Int -> SDL.Surface -> IO Word32 getPixel x y surf = do - bpp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf) - ptr <- (surfaceGetPixels surf >>= return.castPtr) :: IO (Ptr Word8) - let newPtr = ptr `plusPtr` (y * (fromIntegral $ surfaceGetPitch surf)) `plusPtr` (x * bpp) + bpp <- return 3 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf) + ptr <- (surfacePixels surf >>= return.castPtr) :: IO (Ptr Word8) + (V2 w h) <- SDL.surfaceDimensions surf + let newPtr = ptr `plusPtr` (y * bpp * fromIntegral w) `plusPtr` (x * bpp) ret <- case bpp of -- bytes = R G B A @@ -105,37 +107,54 @@ wordToPixel word = getRGBA :: SDL.Surface -> Int -> Int -> IO (Color4 Word8) getRGBA surf x y = liftM wordToPixel $ getPixel x y surf -simpleStartup :: String -> (Int,Int) -> IO Surface +simpleStartup :: String -> (Int,Int) -> IO SDL.Window simpleStartup name' (w,h) = do - SDL.init [SDL.InitEverything] - SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf] - SDL.setCaption name' name' - SDL.getVideoSurface + SDL.initialize [SDL.InitVideo] + SDL.HintRenderScaleQuality $= SDL.ScaleLinear + renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + putStrLn "Warning: Linear texture filtering not enabled!" + + window <- + SDL.createWindow + "SDL / OpenGL Example" + SDL.defaultWindow + { SDL.windowInitialSize = V2 1920 1080, + SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + } + SDL.showWindow window + + _ <- SDL.glCreateContext window + return window defaultReshape :: Int -> Int -> a -> IO a defaultReshape w h ret = do let size = Size (fromIntegral w) (fromIntegral h) viewport $=(Position 0 0, size) - _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf] + -- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf] return ret -startPipeline :: (Int -> Int -> a -> IO a) -> (Event -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO () +startPipeline :: forall a. (Int -> Int -> a -> IO a) -> (SDL.EventPayload -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO () startPipeline reshapeH eventH displayH updateH ini = do + let pumpEvents' res = do - ev <- SDL.pollEvent - case ev of - Quit -> do - putStrLn "Exit event." - exitSuccess - SDL.NoEvent -> return res - VideoResize w h -> reshapeH w h res >>= pumpEvents' - _ -> eventH ev res >>= pumpEvents' - let runPipeline val = do + evs <- SDL.pollEvents + foldM (\res (SDL.eventPayload -> ev) -> case ev of + SDL.QuitEvent -> exitSuccess >> return res + _ -> eventH ev res) res evs + -- case ev of + -- Quit -> do + -- putStrLn "Exit event." + -- exitSuccess + -- SDL.NoEvent -> return res + -- VideoResize w h -> reshapeH w h res >>= pumpEvents' + -- _ -> eventH ev res >>= pumpEvents' + runPipeline val = do res <- pumpEvents' val >>= displayH - SDL.glSwapBuffers `seq` (updateH res) >>= runPipeline + updateH res >>= runPipeline - -- TODO unhardcode this - reshapeH 640 480 ini >>= runPipeline + -- -- TODO unhardcode this + reshapeH 1920 1080 ini >>= runPipeline setupTexturing :: TextureData -> UniformLocation -> Int -> IO () setupTexturing (TextureData _ to) tu unit = do |