No title

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
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

import qualified Graphics.UI.GLFW as G
import "OpenGLRaw-beta" Graphics.Rendering.OpenGL.Raw.Core.Core43
--import "OpenGLRaw-beta" Graphics.Rendering.OpenGL.Raw.EXT.TextureCompressionS3tc

import Foreign
import Foreign.C.String
--import Foreign.C.Types
import Foreign.Marshal.Alloc (free,mallocBytes)
--import Foreign.Concurrent

import qualified Data.ByteString as B
import Data.ByteString.Char8() 
import Data.ByteString.Unsafe

--import Data.Attoparsec.Binary
--import qualified Data.Attoparsec.Char8 as AC8

--import Data.Bits((.|.))
import Data.Word()


import Control.Concurrent.STM (TQueue, newTQueueIO, writeTQueue, atomically)
import Control.Monad (when,unless)

import Control.Applicative ((<$>))

import Control.Lens
import qualified Data.Vector.Storable (Vector)
import qualified Data.Vector.Storable as V
import qualified Linear as L




data Uniforms = Uniforms { _modelView :: GLint
                         , _projection :: GLint 
                         , _normalMatrix :: GLint
                         , _lightPosition :: GLint
                         , _diffuseMaterial :: GLint
                         , _ambientMaterial :: GLint
                         , _tessLevelInner :: GLint
                         , _tessLevelOuter :: GLint
                         }

$(makeLenses ''Uniforms)





data Event =
    EventError !G.Error !String
  | EventWindowPos !G.Window !Int !Int
  | EventWindowSize !G.Window !Int !Int
  | EventWindowClose !G.Window
  | EventWindowRefresh !G.Window
  | EventWindowFocus !G.Window !G.FocusState
  | EventWindowIconify !G.Window !G.IconifyState
  | EventFramebufferSize !G.Window !Int !Int
  | EventMouseButton !G.Window !G.MouseButton !G.MouseButtonState !G.ModifierKeys
  | EventCursorPos !G.Window !Double !Double
  | EventCursorEnter !G.Window !G.CursorState
  | EventScroll !G.Window !Double !Double
  | EventKey !G.Window !G.Key !Int !G.KeyState !G.ModifierKeys
  | EventChar !G.Window !Char
  deriving Show


data Vector a = Vector {-# UNPACK #-} !(Ptr a)
                       {-# UNPACK #-} !Int

newVector :: Storable a => [a] -> IO (Vector a)
newVector vals = do
  let l = length vals
  ptr <- mallocArray l
  pokeArray ptr vals
  return $ Vector ptr l 

withWindow :: Int -> Int -> String -> (G.Window -> IO ()) -> IO ()
withWindow width height title f = do
  G.setErrorCallback $ Just simpleErrorCallback
  r <- G.init
  when r $ do
    G.windowHint $ G.WindowHint'ContextVersionMajor 4
    G.windowHint $ G.WindowHint'ContextVersionMinor 3
    G.windowHint $ G.WindowHint'Samples 4
    m <- G.createWindow width height title Nothing Nothing
    case m of
      (Just win) -> do
        G.makeContextCurrent m
        glEnable gl_DEPTH_TEST
        glEnable gl_CULL_FACE
        glClearColor 0.0 0.0 0.4 0.0 
        f win
        G.setErrorCallback $ Just simpleErrorCallback
        G.destroyWindow win
      Nothing -> return ()
    G.terminate
  where
    simpleErrorCallback e s =
      putStr $ unwords [show e, show s]

checkShaderProgram :: GLuint -> IO ()
checkShaderProgram prog = do
  infoLogLength <- alloca $ \buf -> do
    glGetProgramiv prog gl_INFO_LOG_LENGTH buf
    peek buf
  infoLog <- alloca $ \len ->
    allocaBytes (fromIntegral infoLogLength) $ \chars -> do
      glGetProgramInfoLog prog infoLogLength len chars
      len' <- fromIntegral <$> peek len
      peekCStringLen (chars,len')
  unless (null infoLog) (print infoLog)
  return ()


loadShader :: FilePath -> GLenum-> IO GLuint
loadShader filePath kind= do
  shaderSrc <- readFile filePath
  shader <- glCreateShader kind
  withCStringLen shaderSrc $ \(src,len) ->
    withArray [src] $ \buf ->
      withArray [fromIntegral len] $ \l ->
        glShaderSource shader 1 buf l
  glCompileShader shader

  ok <- alloca $ \buf -> do
          glGetShaderiv shader gl_COMPILE_STATUS buf
          fmap (> 0) (peek buf)
  infoLogLen <- alloca $ \ptr -> do glGetShaderiv shader gl_INFO_LOG_LENGTH ptr
                                    peek ptr
  infoLog <- alloca $ \len ->
               allocaBytes (fromIntegral infoLogLen) $ \chars -> do 
                 glGetShaderInfoLog shader infoLogLen len chars
                 len' <- fromIntegral <$> peek len
                 peekCStringLen (chars, len')
  unless (null infoLog)
         (mapM_ putStrLn 
                ["Shader info log for '" ++ filePath ++ "':", infoLog, ""])
  unless ok $ glDeleteShader shader
  return shader




--until :: (Monad m) => m Bool -> m a -> m b
--until cond a = 
--  let a' = do 
--    x <- cond 
--    unless x (a >> while cond a')
--  in a'

withGLString :: B.ByteString -> (Ptr GLchar -> IO a) -> IO a
withGLString s action = B.useAsCString s $ action . castPtr



main' :: G.Window -> GLuint -> GLuint -> Uniforms -> Int -> IO ()
main' window program elementBuffer u size = do
  x <- G.windowShouldClose window
  unless x (do
    glUseProgram program


    -- set up all the uniforms.
    let perspective = V.fromList [ 0.25, 0, 0, 0
                                 , 0, 0.25, 0, 0
                                 , 0, 0, 0.25, 0
                                 , 0, 0, 0 , 1
                                 ]
    V.unsafeWith perspective $ \ptr -> glUniformMatrix4fv (u^.modelView) 1 0 ptr
    with (L.V4 0.25 1.0 1 0 :: L.V4 GLfloat) $ \ptr -> glUniform3fv (u^.lightPosition) 1 (castPtr ptr)     
    with (L.eye4 :: L.M44 GLfloat) $ \ptr -> glUniformMatrix4fv (u^.projection) 1 0 (castPtr ptr)
    with (L.eye3 :: L.M33 GLfloat) $ \ptr -> glUniformMatrix3fv (u^.normalMatrix) 1 0 (castPtr ptr)

    glUniform1f (u^.tessLevelInner) 3.0
    glUniform1f (u^.tessLevelOuter) 2.0

    glClear $ gl_COLOR_BUFFER_BIT .|. gl_DEPTH_BUFFER_BIT
    glUniform3f (u^.ambientMaterial) 0.04 0.04 0.04
    glUniform3f (u^.diffuseMaterial) 0 0.75 0.75


    glEnableVertexAttribArray 0
    glBindBuffer gl_ELEMENT_ARRAY_BUFFER elementBuffer
    let stride = fromIntegral $ 3 * sizeOf(undefined::GLfloat)
    glVertexAttribPointer 0 3 gl_FLOAT 0 stride nullPtr
    glPatchParameteri gl_PATCH_VERTICES 3
    glDrawElements gl_PATCHES (fromIntegral size) gl_UNSIGNED_INT nullPtr
    glDisableVertexAttribArray 0
    G.swapBuffers window
    G.pollEvents
    main' window program elementBuffer u size)
  return ()


genBuffers :: GLsizei -> IO (V.Vector GLuint)
genBuffers n = do
  ptr <- mallocBytes $ fromIntegral n * sizeOf (undefined::GLuint)
  glGenBuffers n ptr
  ptr' <- newForeignPtr finalizerFree ptr
  return $ V.unsafeFromForeignPtr0  ptr' (fromIntegral n)

genProgramPipelines :: GLsizei -> IO (V.Vector GLuint)
genProgramPipelines n = do
  ptr <- mallocBytes $ fromIntegral n * sizeOf (undefined::GLuint)
  glGenProgramPipelines n ptr
  ptr' <- newForeignPtr finalizerFree ptr
  return $ V.unsafeFromForeignPtr0  ptr' (fromIntegral n)

writeProgramBinary :: GLuint -> FilePath -> IO (GLsizei,GLenum)
writeProgramBinary program path = alloca $ \ptr -> do
  glGetProgramiv program gl_PROGRAM_BINARY_LENGTH ptr
  len <- peek ptr
  allocaBytes (fromIntegral len) $ \binary ->
    alloca $ \lptr ->
      alloca $ \bfptr -> do
        glGetProgramBinary program len lptr bfptr binary
        -- do I need the Finalizer?
        binary' <- unsafePackCStringFinalizer binary (fromIntegral len) (return ())
        B.writeFile path binary'
        -- should perform sanity check len' = len?
        len' <- peek lptr 
        binaryformat <- peek bfptr
        return (len',binaryformat)

--OpenGL defines no specific binary formats, but does provide a mechanism
--to obtain token values for such formats provided by extensions. The number of
--program binary formats supported can be obtained by querying the value of NUM_-
--PROGRAM_BINARY_FORMATS. The list of specific binary formats supported can be
--obtained by querying the value of PROGRAM_BINARY_FORMATS. The binaryFor-
--mat returned by GetProgramBinary must be present in this list.


getUniformLocation :: GLuint -> B.ByteString -> IO GLint
getUniformLocation prog str = withGLString str $ glGetUniformLocation prog




--data Buffer a where
--  ArrayBuffer :: Buffer Float


--bufferData :: Buffer a -> V.Vector a -> GLenum -> IO () 
---- bufferSubData 


-- use glGetParameter, glGetShaderPrecisionFormat


main :: IO ()
main = do 
  let width = 640
      height = 480

  --contents <- B.readFile "teapot.obj"
  --let (Right obj) = parseOnly objFile contents
  --(Vector ptr len,Vector ptr' len') <- createIndexVBO obj

  --Vector ptr' len' :: Vector GLfloat <- newVector [-1.0,-1.0,0.0,1.0,-1.0,0.0,0.0,1.0,0.0]
  --Vector ptr len :: Vector GLint <- newVector [0,1,2]


  Vector ptr' len' :: Vector GLfloat <- newVector [ 0.000,  0.000,  1.000,
                                                    0.894,  0.000,  0.447,
                                                    0.276,  0.851,  0.447,
                                                   -0.724,  0.526,  0.447,
                                                   -0.724, -0.526,  0.447,
                                                    0.276, -0.851,  0.447,
                                                    0.724,  0.526, -0.447,
                                                   -0.276,  0.851, -0.447,
                                                   -0.894,  0.000, -0.447,
                                                   -0.276, -0.851, -0.447,
                                                    0.724, -0.526, -0.447,
                                                    0.000,  0.000, -1.000 ]

  Vector ptr len  :: Vector GLint <- newVector [ 2, 1, 0,
                                                  3, 2, 0,
                                                  4, 3, 0,
                                                  5, 4, 0,
                                                  1, 5, 0,
                                                  11, 6,  7,
                                                  11, 7,  8,
                                                  11, 8,  9,
                                                  11, 9, 10,
                                                  11, 10, 6,
                                                  1, 2, 6,
                                                  2, 3, 7,
                                                  3, 4, 8,
                                                  4, 5, 9,
                                                  5, 1, 10,
                                                  2,  7, 6,
                                                  3,  8, 7,
                                                  4,  9, 8,
                                                  5, 10, 9,
                                                  1, 6, 10 ]

  eventsChan <- newTQueueIO :: IO (TQueue Event)

  withWindow width height "Braid" $ \win -> do
    G.setErrorCallback $ Just $ errorCallback eventsChan
    G.setWindowPosCallback win $ Just $ windowPosCallback eventsChan
    G.setWindowSizeCallback win $ Just $ windowSizeCallback eventsChan
    G.setWindowCloseCallback win $ Just $ windowCloseCallback eventsChan
    G.setWindowRefreshCallback win $ Just $ windowRefreshCallback eventsChan
    G.setWindowFocusCallback win $ Just $ windowFocusCallback eventsChan
    G.setWindowIconifyCallback win $ Just $ windowIconifyCallback eventsChan
    G.setFramebufferSizeCallback win $ Just $ framebufferSizeCallback eventsChan
    G.setMouseButtonCallback win $ Just $ mouseButtonCallback eventsChan
    G.setCursorPosCallback win $ Just $ cursorPosCallback eventsChan
    G.setCursorEnterCallback win $ Just $ cursorEnterCallback eventsChan
    G.setScrollCallback win $ Just $ scrollCallback eventsChan
    G.setKeyCallback win $ Just $ keyCallback eventsChan
    G.setCharCallback win $ Just $ charCallback eventsChan
    

    -- Generates vertex array object names
    vertexArrayPtr <- malloc
    glGenVertexArrays 1 vertexArrayPtr
    vao <- peek vertexArrayPtr
    -- Bind a new current vertex array object.
    glBindVertexArray vao
    -- Binds an array buffer to the current bound vertex array object.
    vertexBufferPtr <- malloc
    glGenBuffers 1 vertexBufferPtr
    vertexBuffer <- peek vertexBufferPtr
    glBindBuffer gl_ARRAY_BUFFER vertexBuffer  
    glBufferData gl_ARRAY_BUFFER (fromIntegral (len'*sizeOf(0.0::GLfloat))) ptr' gl_STATIC_DRAW
    -- Binds an element array buffer to the current bound vertex array object.
    elementBufferPtr <- malloc
    glGenBuffers 1 elementBufferPtr
    elementBuffer <- peek elementBufferPtr
    glBindBuffer gl_ELEMENT_ARRAY_BUFFER elementBuffer
    glBufferData gl_ELEMENT_ARRAY_BUFFER (fromIntegral (len*sizeOf(1::GLuint))) ptr gl_STATIC_DRAW


    -- verts :: Ptr GLfloat <- newArray [-0.9, -0.9, 0.0, 1.0, -1.0, 0.0, 0.0,  1.0, 0.0]
    -- The array has 9 elements, 4 is the size of GLfloat
    -- glBufferData gl_ARRAY_BUFFER (9*4) verts gl_STATIC_DRAW


    -- vertexShader <- loadShader "simple.vert" gl_VERTEX_SHADER
    -- fragmentShader <- loadShader "simple.frag" gl_FRAGMENT_SHADER


    vertexShader <- loadShader "geodesic.vert" gl_VERTEX_SHADER
    tessellationControlShader <- loadShader "geodesic.tcs" gl_TESS_CONTROL_SHADER 
    tessellationEvaluationShader <- loadShader "geodesic.tes" gl_TESS_EVALUATION_SHADER
    geometryShader <- loadShader "geodesic.geo" gl_GEOMETRY_SHADER
    fragmentShader <- loadShader "geodesic.frag" gl_FRAGMENT_SHADER

    alloca $ \p -> glGetShaderiv vertexShader gl_COMPILE_STATUS p >> peek p >>= print


    shaderProgram <- glCreateProgram
    glAttachShader shaderProgram vertexShader
    glAttachShader shaderProgram tessellationControlShader
    glAttachShader shaderProgram tessellationEvaluationShader
    glAttachShader shaderProgram geometryShader
    glAttachShader shaderProgram fragmentShader
    withGLString "Position" $ glBindAttribLocation shaderProgram 0 
    glLinkProgram shaderProgram

    checkShaderProgram shaderProgram

    pr <- getUniformLocation shaderProgram "Projection"   
    mv <- withGLString "Modelview" $ glGetUniformLocation shaderProgram
    nm <- withGLString "NormalMatrix" $ glGetUniformLocation shaderProgram
    lp <- withGLString "LightPosition" $ glGetUniformLocation shaderProgram
    am <- withGLString "AmbientMaterial" $ glGetUniformLocation shaderProgram
    dm <- withGLString "DiffuseMaterial" $ glGetUniformLocation shaderProgram
    tessi <- withGLString "TessLevelInner" $ glGetUniformLocation shaderProgram
    tesso <- withGLString "TessLevelOuter" $ glGetUniformLocation shaderProgram
 

    print ("Uniform Locations:"::String)
    print mv
    print pr
    print nm
    print lp
    print dm
    print am
    print tessi
    print tesso

    main' win shaderProgram elementBuffer Uniforms {_modelView = mv,
                                                    _projection = pr,
                                                    _normalMatrix = nm,
                                                    _lightPosition = lp,
                                                    _diffuseMaterial = dm,
                                                    _ambientMaterial = am,
                                                    _tessLevelInner = tessi,
                                                    _tessLevelOuter = tesso
                                                    } len



errorCallback :: TQueue Event -> G.Error -> String -> IO ()
windowPosCallback :: TQueue Event -> G.Window -> Int -> Int -> IO ()
windowSizeCallback :: TQueue Event -> G.Window -> Int -> Int -> IO ()
windowCloseCallback :: TQueue Event -> G.Window -> IO ()
windowRefreshCallback :: TQueue Event -> G.Window -> IO ()
windowFocusCallback :: TQueue Event -> G.Window -> G.FocusState -> IO ()
windowIconifyCallback :: TQueue Event -> G.Window -> G.IconifyState -> IO ()
framebufferSizeCallback :: TQueue Event -> G.Window -> Int -> Int -> IO ()
mouseButtonCallback :: TQueue Event -> G.Window -> G.MouseButton -> G.MouseButtonState -> G.ModifierKeys -> IO ()
cursorPosCallback :: TQueue Event -> G.Window -> Double -> Double -> IO ()
cursorEnterCallback :: TQueue Event -> G.Window -> G.CursorState -> IO ()
scrollCallback :: TQueue Event -> G.Window -> Double -> Double -> IO ()
keyCallback :: TQueue Event -> G.Window -> G.Key -> Int -> G.KeyState -> G.ModifierKeys -> IO ()
charCallback :: TQueue Event -> G.Window -> Char -> IO ()

errorCallback tc e s = atomically $ writeTQueue tc $ EventError e s
windowPosCallback tc win x y = atomically $ writeTQueue tc $ EventWindowPos win x y
windowSizeCallback tc win w h = atomically $ writeTQueue tc $ EventWindowSize win w h
windowCloseCallback tc win = atomically $ writeTQueue tc $ EventWindowClose win
windowRefreshCallback tc win = atomically $ writeTQueue tc $ EventWindowRefresh win
windowFocusCallback tc win fa = atomically $ writeTQueue tc $ EventWindowFocus win fa
windowIconifyCallback tc win ia = atomically $ writeTQueue tc $ EventWindowIconify win ia
framebufferSizeCallback tc win w h = atomically $ writeTQueue tc $ EventFramebufferSize win w h
mouseButtonCallback tc win mb mba mk = atomically $ writeTQueue tc $ EventMouseButton win mb mba mk
cursorPosCallback tc win x y = atomically $ writeTQueue tc $ EventCursorPos win x y
cursorEnterCallback tc win ca = atomically $ writeTQueue tc $ EventCursorEnter win ca
scrollCallback tc win x y = atomically $ writeTQueue tc $ EventScroll win x y
keyCallback tc win k sc ka mk = atomically $ writeTQueue tc $ EventKey win k sc ka mk
charCallback tc win c = atomically $ writeTQueue tc $ EventChar win c