1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns, RankNTypes #-}
module Graphics.SDL.SDLHelp where
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 Foreign.Storable
import Foreign.Ptr
import Data.Bits
import System.IO.Unsafe
import System.Endian
import System.Exit
data TextureData = TextureData {
textureSize :: (Int,Int),
textureObject :: TextureObject } deriving Show
data TextureData3D = TextureData3D {
textureSize3D :: (Int,Int,Int),
textureObject3D :: TextureObject } deriving Show
bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
bindSurfaceToTexture surf to = do
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
return $ TextureData3D (w,h,d) to
where f = fromIntegral
textureFromSurface :: SDL.Surface -> IO TextureData
textureFromSurface surf = makeTexture >>= (bindSurfaceToTexture surf >=> return)
makeTexture3D :: IO TextureObject
makeTexture3D = do
texobj <- liftM head $ genObjectNames 1
textureBinding Texture3D $= Just texobj
textureFilter Texture3D $= ((Linear', Nothing), Linear')
return texobj
makeTexture :: IO TextureObject
makeTexture = do
texobj <- liftM head $ genObjectNames 1
textureBinding Texture2D $= Just texobj
textureFilter Texture2D $= ((Linear', Nothing), Linear')
return texobj
getPixel :: Int -> Int -> SDL.Surface -> IO Word32
getPixel x y surf = do
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
1 -> liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word8)
2 -> liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word16)
3 -> do
ord1 <- liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word16)
ord2 <- liftM fromIntegral $ peek (castPtr (newPtr `plusPtr` 2) :: Ptr Word8)
return $ ((ord1 `shiftL` 16) + (ord2 `shiftL` 8)) + 0xFF
4 -> do
liftM fromIntegral $ peek (castPtr newPtr :: Ptr Word32)
_ -> error "Unrecognized format"
return $ toBE32 ret
getPixelUnsafe :: Int -> Int -> SDL.Surface -> Word32
getPixelUnsafe x y surf = unsafePerformIO $ getPixel x y surf
rgbToWord :: Word8 -> Word8 -> Word8 -> Word32
rgbToWord r g b =
let tW32 x = (fromIntegral x) :: Word32 in
( (tW32 r) `shiftL` 24) +
( (tW32 g) `shiftL` 16) +
( (tW32 b) `shiftL` 8) +
0xFF
wordToPixel :: Word32 -> Color4 Word8
wordToPixel word =
Color4 (fromIntegral $ word .&. 0xFF)
(fromIntegral $ (word `shiftR` 8) .&. 0xFF)
(fromIntegral $ (word `shiftR` 16) .&. 0xFF)
(fromIntegral $ (word `shiftR` 24) .&. 0xFF)
getRGBA :: SDL.Surface -> Int -> Int -> IO (Color4 Word8)
getRGBA surf x y = liftM wordToPixel $ getPixel x y surf
simpleStartup :: String -> (Int,Int) -> IO SDL.Window
simpleStartup name' (w,h) = do
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]
return ret
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
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
updateH res >>= runPipeline
-- -- TODO unhardcode this
reshapeH 1920 1080 ini >>= runPipeline
setupTexturing :: TextureData -> UniformLocation -> Int -> IO ()
setupTexturing (TextureData _ to) tu unit = do
texture Texture2D $= Enabled
activeTexture $= TextureUnit (fromIntegral unit)
textureBinding Texture2D $= Just to
uniform tu $= Index1 (fromIntegral unit::GLint)
setupTexturing3D :: TextureData3D -> UniformLocation -> Int -> IO ()
setupTexturing3D (TextureData3D _ to) tu unit = do
texture Texture3D $= Enabled
activeTexture $= TextureUnit (fromIntegral unit)
textureBinding Texture3D $= Just to
uniform tu $= Index1 (fromIntegral unit::GLint)
|
