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
|
--port of https://github.com/bergey/haskell-OpenGL-examples
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module OpenGLExample where
import Control.Monad
import Foreign.C.Types
import SDL.Vect
import qualified Data.ByteString as BS
import qualified Data.Vector.Storable as V
import System.Exit (exitFailure)
import System.IO
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
screenWidth, screenHeight :: CInt
(screenWidth, screenHeight) = (640, 480)
main :: IO ()
main = do
SDL.initialize [SDL.InitVideo]
SDL.HintRenderScaleQuality $= SDL.ScaleLinear
do 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 screenWidth screenHeight,
SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL}
SDL.showWindow window
_ <- SDL.glCreateContext window
(prog, attrib) <- initResources
let loop = do
events <- SDL.pollEvents
let quit = elem SDL.QuitEvent $ map SDL.eventPayload events
GL.clear [GL.ColorBuffer]
draw prog attrib
SDL.glSwapWindow window
unless quit loop
loop
SDL.destroyWindow window
SDL.quit
initResources :: IO (GL.Program, GL.AttribLocation)
initResources = do
-- compile vertex shader
vs <- GL.createShader GL.VertexShader
GL.shaderSourceBS vs $= vsSource
GL.compileShader vs
vsOK <- GL.get $ GL.compileStatus vs
unless vsOK $ do
hPutStrLn stderr "Error in vertex shader\n"
exitFailure
-- Do it again for the fragment shader
fs <- GL.createShader GL.FragmentShader
GL.shaderSourceBS fs $= fsSource
GL.compileShader fs
fsOK <- GL.get $ GL.compileStatus fs
unless fsOK $ do
hPutStrLn stderr "Error in fragment shader\n"
exitFailure
program <- GL.createProgram
GL.attachShader program vs
GL.attachShader program fs
GL.attribLocation program "coord2d" $= GL.AttribLocation 0
GL.linkProgram program
linkOK <- GL.get $ GL.linkStatus program
GL.validateProgram program
status <- GL.get $ GL.validateStatus program
unless (linkOK && status) $ do
hPutStrLn stderr "GL.linkProgram error"
plog <- GL.get $ GL.programInfoLog program
putStrLn plog
exitFailure
GL.currentProgram $= Just program
return (program, GL.AttribLocation 0)
draw :: GL.Program -> GL.AttribLocation -> IO ()
draw program attrib = do
GL.clearColor $= GL.Color4 1 1 1 1
GL.clear [GL.ColorBuffer]
GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight))
GL.currentProgram $= Just program
GL.vertexAttribArray attrib $= GL.Enabled
V.unsafeWith vertices $ \ptr ->
GL.vertexAttribPointer attrib $=
(GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 ptr)
GL.drawArrays GL.Triangles 0 3 -- 3 is the number of vertices
GL.vertexAttribArray attrib $= GL.Disabled
vsSource, fsSource :: BS.ByteString
vsSource = BS.intercalate "\n"
[
"attribute vec2 coord2d; "
, ""
, "void main(void) { "
, " gl_Position = vec4(coord2d, 0.0, 1.0); "
, "}"
]
fsSource = BS.intercalate "\n"
[
""
, "#version 120"
, "void main(void) {"
, "gl_FragColor = vec4((gl_FragCoord.x/640), (gl_FragCoord.y/480), 0, 1);"
, "}"
]
vertices :: V.Vector Float
vertices = V.fromList [ 0.0, 0.8
, -0.8, -0.8
, 0.8, -0.8
]
|
