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
|
{-
OpenGL examples in Haskell.
Copyright (C) 2020 Yann Herklotz
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main 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
]
|
