Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
273 lines (228 sloc) 8.491 kb
{-
SmoothOpenGL3.hs (adapted from freeglut's smooth_opengl3.c example)
Copyright (c) Sven Panne 2009 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file LICENSE
-}
import Control.Monad
import qualified Data.ByteString as B
import Data.List
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.UI.GLUT
import System.Exit
import System.IO
data State = State {
vertexBufferName :: BufferObject,
fgProjectionMatrixIndex :: UniformLocation,
fgColorIndex :: AttribLocation ,
fgVertexIndex :: AttribLocation,
projectionMatrix :: GLmatrix GLfloat }
checkError :: String -> IO ()
checkError functionName = get errors >>= mapM_ reportError
where reportError e =
hPutStrLn stderr (showError e ++ " detected in " ++ functionName)
showError (Error category message) =
"GL error " ++ show category ++ " (" ++ message ++ ")"
varray :: [GLfloat]
varray = [
1, 0, 0, -- red
5, 5, -- lower left
0, 1, 0, -- green
25, 5, -- lower right
0, 0, 1, -- blue
5, 25 ] -- upper left
numColorComponents :: NumComponents
numColorComponents = 3
numVertexComponents :: NumComponents
numVertexComponents = 2
sizeOfComponent :: Int
sizeOfComponent = sizeOf (head varray)
stride :: Stride
stride = fromIntegral sizeOfComponent * fromIntegral (numColorComponents + numVertexComponents)
sizeOfVarray :: Int
sizeOfVarray = length varray * sizeOfComponent
numElements :: NumArrayIndices
numElements = fromIntegral sizeOfVarray `div` fromIntegral stride
initBuffer :: IO BufferObject
initBuffer = do
bufferObject <- genObjectName
bindBuffer ArrayBuffer $= Just bufferObject
withArray varray $ \buffer ->
bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw)
checkError "initBuffer"
return bufferObject
packUtf8 :: String -> B.ByteString
packUtf8 = TE.encodeUtf8 . T.pack
vertexShaderSource :: B.ByteString
vertexShaderSource = packUtf8 . unlines $ [
"#version 140",
"uniform mat4 fg_ProjectionMatrix;",
"in vec4 fg_Color;",
"in vec4 fg_Vertex;",
"smooth out vec4 fg_SmoothColor;",
"void main()",
"{",
" fg_SmoothColor = fg_Color;",
" gl_Position = fg_ProjectionMatrix * fg_Vertex;",
"}" ]
fragmentShaderSource :: B.ByteString
fragmentShaderSource = packUtf8 . unlines $ [
"#version 140",
"smooth in vec4 fg_SmoothColor;",
"out vec4 fg_FragColor;",
"void main(void)",
"{",
" fg_FragColor = fg_SmoothColor;",
"}" ]
checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO ()
checked action getStatus getInfoLog message object = do
action object
status <- get (getStatus object)
unless status $
hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object)
compileAndCheck :: Shader -> IO ()
compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
compileShaderSource :: ShaderType -> B.ByteString -> IO Shader
compileShaderSource st source = do
shader <- createShader st
shaderSourceBS shader $= source
compileAndCheck shader
return shader
linkAndCheck :: Program -> IO ()
linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
createProgramUsing :: [Shader] -> IO Program
createProgramUsing shaders = do
program <- createProgram
attachedShaders program $= shaders
linkAndCheck program
return program
initShader :: IO (UniformLocation, AttribLocation, AttribLocation)
initShader = do
vertexShader <- compileShaderSource VertexShader vertexShaderSource
fragmentShader <- compileShaderSource FragmentShader fragmentShaderSource
program <- createProgramUsing [vertexShader, fragmentShader]
currentProgram $= Just program
projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")
colorIndex <- get (attribLocation program "fg_Color")
vertexAttribArray colorIndex $= Enabled
vertexIndex <- get (attribLocation program "fg_Vertex")
vertexAttribArray vertexIndex $= Enabled
checkError "initShader"
return (projectionMatrixIndex, colorIndex, vertexIndex)
initRendering :: IO ()
initRendering = do
clearColor $= Color4 0 0 0 0
checkError "initRendering"
myInit :: IO State
myInit = do
bufferObject <- initBuffer
(projectionMatrixIndex, colorIndex, vertexIndex) <- initShader
initRendering
m <- newMatrix ColumnMajor (replicate 16 0)
return $ State {
vertexBufferName = bufferObject,
fgProjectionMatrixIndex = projectionMatrixIndex,
fgColorIndex = colorIndex,
fgVertexIndex = vertexIndex,
projectionMatrix = m }
dumpInfo :: IO ()
dumpInfo = do
let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var
dump "Vendor" vendor
dump "Renderer" renderer
dump "Version" glVersion
dump "GLSL" shadingLanguageVersion
checkError "dumpInfo"
bufferObjectPtr :: Integral a => a -> Ptr b
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral
vertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a
vertexArrayDescriptor count offset =
VertexArrayDescriptor count Float stride (bufferObjectPtr (fromIntegral sizeOfComponent * offset))
triangle :: State -> IO ()
triangle state = do
withMatrix (projectionMatrix state) $ \order buffer ->
uniformMatrix4fv (fgProjectionMatrixIndex state) 1 (order == RowMajor) buffer
bindBuffer ArrayBuffer $= Just (vertexBufferName state)
vertexAttribPointer (fgColorIndex state) $=
(ToFloat, vertexArrayDescriptor numColorComponents 0)
vertexAttribPointer (fgVertexIndex state) $=
(ToFloat, vertexArrayDescriptor numVertexComponents numColorComponents)
drawArrays Triangles 0 numElements
checkError "triangle"
-- The OpenGL package offers no interface for glUniformMatrix*fv yet
uniformMatrix4fv :: UniformLocation -> GLsizei -> Bool -> Ptr GLfloat -> IO ()
uniformMatrix4fv location count =
glUniformMatrix4fv (uniformLocationToGLint location) count . marshalGLboolean
where marshalGLboolean x = fromIntegral $ case x of
False -> gl_FALSE
True -> gl_TRUE
-- MEGA HACK because UniformLocation is abstract
uniformLocationToGLint = read . head . tail . words . show
display :: State -> DisplayCallback
display state = do
clear [ ColorBuffer ]
triangle state
flush
checkError "display"
loadOrtho :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> a -> a -> IO ()
loadOrtho m l r b t n f =
fillMatrix m [
[2 / (r - l),
0,
0,
0],
[0,
2 / (t - b),
0,
0],
[0,
0,
-2 / (f - n),
0],
[-(r + l) / (r - l),
-(t + b) / (t - b),
-(f + n) / (f - n),
1 ]]
fillMatrix :: (Matrix m, MatrixComponent a) => m a -> [[a]] -> IO ()
fillMatrix m xs =
withMatrix m $ \order buffer ->
pokeArray buffer . concat . rearrange order $ xs
rearrange :: MatrixOrder -> [[a]] -> [[a]]
rearrange ColumnMajor = id
rearrange RowMajor = transpose
loadOrtho2D :: (Matrix m, MatrixComponent a, Fractional a) => m a -> a -> a -> a -> a -> IO ()
loadOrtho2D m l r b t = loadOrtho m l r b t (-1) 1
reshape :: State -> ReshapeCallback
reshape state size@(Size w h) = do
viewport $= (Position 0 0, size)
let wf = fromIntegral w
hf = fromIntegral h
if w <= h
then loadOrtho2D (projectionMatrix state) 0 30 0 (30 * hf / wf)
else loadOrtho2D (projectionMatrix state) 0 (30 * wf / hf) 0 30
checkError "reshape"
keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
main :: IO ()
main = do
(progName, args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
-- add command line argument "classic" for a pre-3.x context
unless (args == ["classic"]) $ do
initialContextVersion $= (3, 1)
initialContextFlags $= [ ForwardCompatibleContext, DebugContext ]
initialWindowSize $= Size 500 500
initialWindowPosition $= Position 100 100
_ <- createWindow progName
dumpInfo
state <- myInit
displayCallback $= display state
reshapeCallback $= Just (reshape state)
keyboardMouseCallback $= Just keyboard
mainLoop
Jump to Line
Something went wrong with that request. Please try again.