diff --git a/Pioneers.cabal b/Pioneers.cabal index af29ed0..ae5865d 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -26,5 +26,8 @@ executable Pioneers transformers >=0.3.0 && <0.4, mtl >=2.1.2, stm >=2.4.2, - vector >=0.10.9 && <0.11 + vector >=0.10.9 && <0.11, + distributive >=0.3.2 && <0.4, + linear >=1.3.1 && <1.4, + lens >=3.10.1 && <3.11 diff --git a/shaders/vertex.shader b/shaders/vertex.shader index 29fa933..12a80cd 100644 --- a/shaders/vertex.shader +++ b/shaders/vertex.shader @@ -2,19 +2,31 @@ //constant projection matrix uniform mat4 fg_ProjectionMatrix; +uniform mat4 fg_ViewMatrix; +uniform mat3 fg_NormalMatrix; //vertex-data in vec4 fg_Color; in vec3 fg_VertexIn; -in vec3 fg_Normal; +in vec3 fg_NormalIn; //output-data for later stages out vec4 fg_SmoothColor; void main() { + vec3 fg_Normal = fg_NormalIn; //vec3(0,1,0); //transform vec3 into vec4, setting w to 1 - vec4 fg_Vertex = vec4(fg_VertexIn.x, fg_VertexIn.y+0.1, fg_VertexIn.z, 1.0); - fg_SmoothColor = fg_Color + 0.001* fg_Normal.xyzx; - gl_Position = fg_ProjectionMatrix * fg_Vertex; + vec4 fg_Vertex = vec4(fg_VertexIn, 1.0); + vec4 light = vec4(1.0,1.0,1.0,1.0); + vec4 dark = vec4(0.0,0.0,0.0,1.0); + //direction to sun from origin + vec3 lightDir = normalize(vec3(5.0,5.0,1.0)); + + + float costheta = dot(normalize(fg_Normal), lightDir); + float a = costheta * 0.5 + 0.5; + + fg_SmoothColor = fg_Color * mix(dark, light, a);// + 0.001* fg_Normal.xyzx; + gl_Position = fg_ProjectionMatrix * fg_ViewMatrix * fg_Vertex; } \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 2ca7206..6921cf3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} module Main (main) where -------------------------------------------------------------------------------- @@ -9,15 +10,18 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.List (intercalate) import Data.Maybe (catMaybes) import Text.PrettyPrint +import Data.Distributive (distribute) +import Foreign (Ptr, castPtr, with) +import Foreign.C (CFloat) +import Linear as L import qualified Graphics.Rendering.OpenGL.GL as GL -import qualified Graphics.Rendering.OpenGL.Raw.Core31 as GLRaw +import Graphics.Rendering.OpenGL.Raw.Core31 import qualified Graphics.UI.GLFW as GLFW -import qualified Data.Vector.Storable as V import Map.Map -import Render.Render (initShader) -import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError) +import Render.Render (initShader, initRendering) +import Render.Misc (up, createFrustum, checkError, lookAt) -------------------------------------------------------------------------------- @@ -43,13 +47,15 @@ data State = State , stateDragStartY :: !Double , stateDragStartXAngle :: !Double , stateDragStartYAngle :: !Double - , stateFrustum :: [GL.GLfloat] + , stateFrustum :: !(M44 CFloat) -- pointer to bindings for locations inside the compiled shader -- mutable because shaders may be changed in the future. + , shdrVertexIndex :: !GL.AttribLocation , shdrColorIndex :: !GL.AttribLocation , shdrNormalIndex :: !GL.AttribLocation - , shdrVertexIndex :: !GL.AttribLocation , shdrProjMatIndex :: !GL.UniformLocation + , shdrViewMatIndex :: !GL.UniformLocation + , shdrModelMatIndex :: !GL.UniformLocation -- the map , stateMap :: !GL.BufferObject , mapVert :: !GL.NumArrayIndices @@ -105,13 +111,13 @@ main = do (fbWidth, fbHeight) <- GLFW.getFramebufferSize win + initRendering --generate map vertices (mapBuffer, vert) <- getMapBufferObject - (ci, ni, vi, pi) <- initShader + (ci, ni, vi, pri, vii, mi) <- initShader let zDistClosest = 10 zDistFarthest = zDistClosest + 20 - zDist = zDistClosest + ((zDistFarthest - zDistClosest) / 2) fov = 90 --field of view near = 1 --near plane far = 100 --far plane @@ -126,8 +132,8 @@ main = do state = State { stateWindowWidth = fbWidth , stateWindowHeight = fbHeight - , stateXAngle = 0 - , stateYAngle = 0 + , stateXAngle = pi/6 + , stateYAngle = pi/2 , stateZAngle = 0 , stateZDist = 10 , stateMouseDown = False @@ -136,10 +142,12 @@ main = do , stateDragStartY = 0 , stateDragStartXAngle = 0 , stateDragStartYAngle = 0 - , shdrColorIndex = ci - , shdrNormalIndex = ni , shdrVertexIndex = vi - , shdrProjMatIndex = pi + , shdrNormalIndex = ni + , shdrColorIndex = ci + , shdrProjMatIndex = pri + , shdrViewMatIndex = vii + , shdrModelMatIndex = mi , stateMap = mapBuffer , mapVert = vert , stateFrustum = frust @@ -210,8 +218,7 @@ charCallback tc win c = atomically $ writeTQueue tc $ EventC -------------------------------------------------------------------------------- runDemo :: Env -> State -> IO () -runDemo env state = do - void $ evalRWST (adjustWindow >> run) env state +runDemo env state = void $ evalRWST (adjustWindow >> run) env state run :: Pioneer () run = do @@ -221,13 +228,12 @@ run = do draw liftIO $ do GLFW.swapBuffers win - GL.flush -- not necessary, but someone recommended it GLFW.pollEvents - GL.finish -- getEvents & process processEvents -- update State + state <- get if stateDragging state then do @@ -238,10 +244,21 @@ run = do (x, y) <- liftIO $ GLFW.getCursorPos win let myrot = (x - sodx) / 2 mxrot = (y - sody) / 2 +-- newXAngle = if newXAngle' > 2*pi then 2*pi else + newXAngle = if newXAngle' > 0.45*pi then 0.45*pi else +-- if newXAngle' < -2*pi then -2*pi else + if newXAngle' < 0 then 0 else + newXAngle' + newXAngle' = sodxa + mxrot/100 + newYAngle = if newYAngle' > pi then newYAngle'-2*pi else + if newYAngle' < -pi then newYAngle'+2*pi else + newYAngle' + newYAngle' = sodya + myrot/100 put $ state - { stateXAngle = sodxa + mxrot - , stateYAngle = sodya + myrot + { stateXAngle = newXAngle + , stateYAngle = newYAngle } +-- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle] else do (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 @@ -249,6 +266,7 @@ run = do { stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot) , stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot) } + {- --modify the state with all that happened in mt time. mt <- liftIO GLFW.getTime @@ -376,37 +394,44 @@ draw :: Pioneer () draw = do env <- ask state <- get - let xa = stateXAngle state - ya = stateYAngle state + let xa = fromRational $ toRational $ stateXAngle state + ya = fromRational $ toRational $ stateYAngle state za = stateZAngle state - (GL.UniformLocation proj) = shdrProjMatIndex state - ci = shdrColorIndex state - ni = shdrNormalIndex state + (GL.UniformLocation proj) = shdrProjMatIndex state + (GL.UniformLocation vmat) = shdrViewMatIndex state vi = shdrVertexIndex state + ni = shdrNormalIndex state + ci = shdrColorIndex state numVert = mapVert state map' = stateMap state frust = stateFrustum state liftIO $ do - GLRaw.glClearDepth 1.0 - GLRaw.glDisable GLRaw.gl_CULL_FACE - --lookAtUniformMatrix4fv (0.0,0.0,0.0) (0, 15, 0) up frust proj 1 + --(vi,GL.UniformLocation proj) <- initShader + GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1 + GL.clear [GL.ColorBuffer, GL.DepthBuffer] + --set up projection (= copy from state) + with (distribute $ frust) $ \ptr -> + glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) -------------- + --set up camera - let fov = 90 - s = recip (tan $ fov * 0.5 * pi / 180) - f = 1000 - n = 1 + let ! cam = lookAt (cpos ^+^ at') at' up - let perspective = V.fromList [ s, 0, 0, 0 - , 0, s, 0, 0 - , 0, 0, -(f/(f - n)), -1 - , 0, 0, -((f*n)/(f-n)), 0 - ] + at' = V3 5 0 5 + upmap = (fromQuaternion $ + axisAngle (V3 0 1 0) (ya::CFloat) :: M33 CFloat) + !* (V3 1 0 0) + crot' = ( + (fromQuaternion $ + axisAngle upmap (xa::CFloat)) + !*! + (fromQuaternion $ + axisAngle (V3 0 1 0) (ya::CFloat)) + ) :: M33 CFloat + cpos = crot' !* (V3 0 0 (-10)) - V.unsafeWith perspective $ \ptr -> GLRaw.glUniformMatrix4fv proj 1 0 ptr - ---------------- + with (distribute $ cam) $ \ptr -> + glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) GL.bindBuffer GL.ArrayBuffer GL.$= Just map' GL.vertexAttribPointer ci GL.$= fgColorIndex diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 2222b96..3bab58f 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Map.Map ( @@ -47,40 +47,38 @@ lineHeight :: GLfloat lineHeight = 0.8660254 numComponents :: Int -numComponents = 4 --color - +3 --normal - +3 --vertex +numComponents = 10 mapStride :: Stride -mapStride = fromIntegral (sizeOf (0.0 :: GLfloat)) * fromIntegral numComponents +mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents) -bufferObjectPtr :: Integral a => a -> Ptr b -bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral +bufferObjectPtr :: Integral a => a -> Ptr GLfloat +bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral -mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a +mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat mapVertexArrayDescriptor count' offset = - VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral numComponents * offset)) + VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) -fgColorIndex :: (IntegerHandling, VertexArrayDescriptor a) +fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first -fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor a) +fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color -fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor a) +fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do map' <- testmap - map' <- return $ generateTriangles map' + ! map' <- return $ P.map (*1) (generateTriangles map') putStrLn $ P.unlines $ P.map show (prettyMap map') len <- return $ fromIntegral $ P.length map' `div` numComponents putStrLn $ P.unwords ["num verts",show len] bo <- genObjectName -- create a new buffer bindBuffer ArrayBuffer $= Just bo -- bind buffer withArray map' $ \buffer -> - bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: Float)*P.length map', + bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: GLfloat)*P.length map', buffer, StaticDraw) checkError "initBuffer" @@ -90,6 +88,51 @@ prettyMap :: [GLfloat] -> [(GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfl prettyMap (a:b:c:d:x:y:z:u:v:w:ms) = (a,b,c,d,x,y,z,u,v,w):(prettyMap ms) prettyMap _ = [] +generateCube :: [GLfloat] +generateCube = [ -- lower plane + -3.0,-3.0,-3.0, + 3.0,-3.0,3.0, + 3.0,-3.0,-3.0, + -3.0,-3.0,-3.0, + -3.0,-3.0,3.0, + 3.0,-3.0,3.0, + -- upper plane + -3.0,3.0,-3.0, + 3.0,3.0,3.0, + 3.0,3.0,-3.0, + -3.0,3.0,-3.0, + -3.0,3.0,3.0, + 3.0,3.0,3.0, + -- left plane + -3.0,-3.0,-3.0, + -3.0,3.0,3.0, + -3.0,-3.0,3.0, + -3.0,-3.0,-3.0, + -3.0,3.0,3.0, + -3.0,3.0,-3.0, + -- right plane + 3.0,-3.0,-3.0, + 3.0,3.0,3.0, + 3.0,-3.0,3.0, + 3.0,-3.0,-3.0, + 3.0,3.0,3.0, + 3.0,3.0,-3.0, + -- front plane + -3.0,-3.0,-3.0, + 3.0,3.0,-3.0, + 3.0,-3.0,-3.0, + -3.0,-3.0,-3.0, + 3.0,3.0,-3.0, + -3.0,3.0,-3.0, + -- back plane + -3.0,-3.0,3.0, + 3.0,3.0,3.0, + 3.0,-3.0,3.0, + -3.0,-3.0,3.0, + 3.0,3.0,3.0, + -3.0,3.0,3.0 + ] + generateTriangles :: PlayMap -> [GLfloat] generateTriangles map' = let ((xl,yl),(xh,yh)) = bounds map' in @@ -161,7 +204,7 @@ coordLookup (x,z) y = if even x then (fromIntegral $ x `div` 2, y, fromIntegral (2 * z) * lineHeight) else - (fromIntegral (x `div` 2) / 2.0, y, fromIntegral (2 * z + 1) * lineHeight) + (fromIntegral (x `div` 2) + 0.5, y, fromIntegral (2 * z + 1) * lineHeight) -- if writing in ASCII-Format transpose so i,j -> y,x @@ -192,14 +235,20 @@ testMapTemplate = T.transpose [ testMapTemplate2 :: [Text] testMapTemplate2 = T.transpose [ - "~~~~~~" + "~~~~~~~~~~~~" ] testmap :: IO PlayMap testmap = do + g <- getStdGen + rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate) + return $ listArray ((0,0),(19,19)) rawMap + +testmap2 :: IO PlayMap +testmap2 = do g <- getStdGen rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2) - return $ listArray ((0,0),(5,0)) rawMap + return $ listArray ((0,0),(9,0)) rawMap parseTemplate :: [Int] -> Text -> [MapEntry] diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index b08a259..c740b3e 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -4,16 +4,17 @@ import Control.Monad import qualified Data.ByteString as B (ByteString) import Foreign.Marshal.Array (allocaArray, pokeArray) +import Foreign.C (CFloat) import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.StateVar import Graphics.Rendering.OpenGL.GL.StringQueries import Graphics.Rendering.OpenGL.GLU.Errors import Graphics.Rendering.OpenGL.Raw.Core31 import System.IO (hPutStrLn, stderr) +import Linear - -up :: (Double, Double, Double) -up = (0.0, 1.0, 1.0) +up :: V3 CFloat +up = V3 0 1 0 checkError :: String -> IO () checkError functionName = get errors >>= mapM_ reportError @@ -58,16 +59,21 @@ createProgramUsing shaders = do linkAndCheck program return program -createFrustum :: Float -> Float -> Float -> Float -> [GLfloat] -createFrustum fov n f rat = - let s = recip (tan $ fov*0.5 * pi / 180) in - - map (fromRational . toRational) [ - rat*s,0,0,0, - 0,rat*s,0,0, - 0,0,-(f/(f-n)), -1, - 0,0,-((f*n)/(f-n)), 1 - ] +createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat +createFrustum fov n' f' rat = + let + f = realToFrac f' + n = realToFrac n' + s = realToFrac $ recip (tan $ fov*0.5 * pi / 180) + (ratw,rath) = if rat > 1 then + (1,1/realToFrac rat) + else + (realToFrac rat,1) + in + V4 (V4 (s/ratw) 0 0 0) + (V4 0 (s/rath) 0 0) + (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) + (V4 0 0 (-1) 0) lookAtUniformMatrix4fv :: (Double, Double, Double) --origin -> (Double, Double, Double) --camera-pos @@ -126,9 +132,23 @@ infixl 5 >< ] _ >< _ = error "non-conformat matrix-multiplication" + +-- from vmath.h +lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat +lookAt eye@(V3 ex ey ez) center up = + V4 + (V4 xx xy xz (-dot x eye)) + (V4 yx yy yz (-dot y eye)) + (V4 zx zy zz (-dot z eye)) + (V4 0 0 0 1) + where + z@(V3 zx zy zz) = normalize (eye ^-^ center) + x@(V3 xx xy xz) = normalize (cross up z) + y@(V3 yx yy yz) = normalize (cross z x) + -- generates 4x4-Projection-Matrix -lookAt :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat] -lookAt at eye up = +lookAt_ :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat] +lookAt_ at eye up = map (fromRational . toRational) [ xx, yx, zx, 0, xy, yy, zy, 0, diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 413c561..98f7d18 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -7,12 +7,13 @@ import Foreign.Storable (sizeOf) import Graphics.Rendering.OpenGL.GL.BufferObjects import Graphics.Rendering.OpenGL.GL.Framebuffer (clearColor) import Graphics.Rendering.OpenGL.GL.ObjectName +import Graphics.Rendering.OpenGL.GL.PerFragment import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.StateVar import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..), vertexAttribArray) import Graphics.Rendering.OpenGL.GL.VertexSpec -import Graphics.Rendering.OpenGL.Raw.Core31.Types (GLfloat) +import Graphics.Rendering.OpenGL.Raw.Core31 import Render.Misc vertexShaderFile :: String @@ -33,7 +34,7 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation) +initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation, UniformLocation, UniformLocation) initShader = do ! vertexSource <- B.readFile vertexShaderFile ! fragmentSource <- B.readFile fragmentShaderFile @@ -49,22 +50,35 @@ initShader = do projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix") checkError "projMat" - colorIndex <- get (attribLocation program "fg_Color") - vertexAttribArray colorIndex $= Enabled - checkError "colorInd" + viewMatrixIndex <- get (uniformLocation program "fg_ViewMatrix") + checkError "viewMat" - normalIndex <- get (attribLocation program "fg_Normal") - vertexAttribArray normalIndex $= Enabled - checkError "normalInd" + modelMatrixIndex <- get (uniformLocation program "fg_ModelMatrix") + checkError "modelMat" vertexIndex <- get (attribLocation program "fg_VertexIn") vertexAttribArray vertexIndex $= Enabled checkError "vertexInd" + normalIndex <- get (attribLocation program "fg_NormalIn") + vertexAttribArray normalIndex $= Enabled + checkError "normalInd" + + colorIndex <- get (attribLocation program "fg_Color") + vertexAttribArray colorIndex $= Enabled + checkError "colorInd" + + att <- get (activeAttribs program) + + putStrLn $ unlines $ "Attributes: ":map show att + putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)] + checkError "initShader" - return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex) + return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex) initRendering :: IO () initRendering = do clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + glCullFace gl_BACK checkError "initRendering" diff --git a/test2.hs b/test2.hs new file mode 100644 index 0000000..fe31cd2 --- /dev/null +++ b/test2.hs @@ -0,0 +1,660 @@ +module Main (main) where + +-------------------------------------------------------------------------------- + +import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue) +import Control.Monad (unless, when, void) +import Control.Monad.RWS.Strict (RWST, ask, asks, evalRWST, get, liftIO, modify, put) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Text.PrettyPrint +import Control.Applicative +import Control.Lens +import Control.Monad (forever) +import Data.Distributive (distribute) +import Foreign (Ptr, castPtr, nullPtr, sizeOf, with) +import Foreign.C (CFloat) + +import Graphics.Rendering.OpenGL (($=)) +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.Rendering.OpenGL.Raw as GL +import qualified Graphics.UI.GLFW as GLFW +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector.Storable as V +import Linear as L +import Linear ((!*!)) + +import Data.IORef + +-------------------------------------------------------------------------------- + +data Env = Env + { envEventsChan :: TQueue Event + , envWindow :: !GLFW.Window + , envGear1 :: !GL.DisplayList + , envGear2 :: !GL.DisplayList + , envGear3 :: !GL.DisplayList + , envZDistClosest :: !Double + , envZDistFarthest :: !Double + } + +data State = State + { stateWindowWidth :: !Int + , stateWindowHeight :: !Int + , stateXAngle :: !Double + , stateYAngle :: !Double + , stateZAngle :: !Double + , stateGearZAngle :: !Double + , stateZDist :: !Double + , stateMouseDown :: !Bool + , stateDragging :: !Bool + , stateDragStartX :: !Double + , stateDragStartY :: !Double + , stateDragStartXAngle :: !Double + , stateDragStartYAngle :: !Double + } + +type Demo = RWST Env () State IO + +-------------------------------------------------------------------------------- + +data Event = + EventError !GLFW.Error !String + | EventWindowPos !GLFW.Window !Int !Int + | EventWindowSize !GLFW.Window !Int !Int + | EventWindowClose !GLFW.Window + | EventWindowRefresh !GLFW.Window + | EventWindowFocus !GLFW.Window !GLFW.FocusState + | EventWindowIconify !GLFW.Window !GLFW.IconifyState + | EventFramebufferSize !GLFW.Window !Int !Int + | EventMouseButton !GLFW.Window !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys + | EventCursorPos !GLFW.Window !Double !Double + | EventCursorEnter !GLFW.Window !GLFW.CursorState + | EventScroll !GLFW.Window !Double !Double + | EventKey !GLFW.Window !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys + | EventChar !GLFW.Window !Char + deriving Show + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +triangleTransformation :: (Epsilon a, Floating a) => a -> M44 a +triangleTransformation = + liftA2 (!*!) triangleTranslation triangleRotation + +-------------------------------------------------------------------------------- +triangleRotation :: (Epsilon a, Floating a) => a -> M44 a +triangleRotation t = + m33_to_m44 $ + fromQuaternion $ + axisAngle (V3 0 1 0) (t * 2) + +triangleTranslation :: Floating a => a -> M44 a +triangleTranslation t = + eye4 & translation .~ V3 (sin t * 2) 0 (-5) + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + let width = 640 + height = 480 + + eventsChan <- newTQueueIO :: IO (TQueue Event) + + withWindow width height "GLFW-b-demo" $ \win -> do + let z = 0 + let vertices = V.fromList [ 0, 1, 0 + , -1, -1, z + , 1, -1, z ] :: V.Vector Float + vertexAttribute = GL.AttribLocation 0 + + cubeVbo <- GL.genObjectName + + GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo + + V.unsafeWith vertices $ \v -> GL.bufferData GL.ArrayBuffer $= + (fromIntegral $ V.length vertices * sizeOf (0 :: Float), v, GL.StaticDraw) + + GL.vertexAttribPointer vertexAttribute $= + (GL.ToFloat, GL.VertexArrayDescriptor 3 GL.Float 0 nullPtr) + + GL.vertexAttribArray vertexAttribute $= GL.Enabled + GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo + + vertexShader <- GL.createShader GL.VertexShader + fragmentShader <- GL.createShader GL.FragmentShader + + GL.shaderSourceBS vertexShader $= Text.encodeUtf8 + (Text.pack $ unlines + [ "#version 130" + , "uniform mat4 projection;" + , "uniform mat4 model;" + , "in vec3 in_Position;" + , "void main(void) {" + , " gl_Position = projection * model * vec4(in_Position, 1.0);" + , "}" + ]) + + GL.shaderSourceBS fragmentShader $= Text.encodeUtf8 + (Text.pack $ unlines + [ "#version 130" + , "out vec4 fragColor;" + , "void main(void) {" + , " fragColor = vec4(1.0,1.0,1.0,1.0);" + , "}" + ]) + + GL.compileShader vertexShader + GL.compileShader fragmentShader + + shaderProg <- GL.createProgram + GL.attachShader shaderProg vertexShader + GL.attachShader shaderProg fragmentShader + GL.attribLocation shaderProg "in_Position" $= vertexAttribute + GL.linkProgram shaderProg + GL.currentProgram $= Just shaderProg + + let fov = 90 + s = recip (tan $ fov * 0.5 * pi / 180) + f = 1000 + n = 1 + + let perspective = V.fromList [ s, 0, 0, 0 + , 0, s, 0, 0 + , 0, 0, -(f/(f - n)), -1 + , 0, 0, -((f*n)/(f-n)), 0 + ] + + GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection") + V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv loc 1 0 ptr + + tr <- newIORef 0 + forever $ do + t <- readIORef tr + + GL.clearColor $= GL.Color4 0.5 0.2 1 1 + GL.clear [GL.ColorBuffer] + + GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "model") + with (distribute $ triangleTransformation t) $ \ptr -> + GL.glUniformMatrix4fv loc 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) + + GL.drawArrays GL.Triangles 0 3 + + GLFW.swapBuffers win + writeIORef tr (t + 0.1) + +-------------------------------------------------------------------------------- + +-- GLFW-b is made to be very close to the C API, so creating a window is pretty +-- clunky by Haskell standards. A higher-level API would have some function +-- like withWindow. + +withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () +withWindow width height title f = do + GLFW.setErrorCallback $ Just simpleErrorCallback + r <- GLFW.init + when r $ do + m <- GLFW.createWindow width height title Nothing Nothing + case m of + (Just win) -> do + GLFW.makeContextCurrent m + f win + GLFW.setErrorCallback $ Just simpleErrorCallback + GLFW.destroyWindow win + Nothing -> return () + GLFW.terminate + where + simpleErrorCallback e s = + putStrLn $ unwords [show e, show s] + +-------------------------------------------------------------------------------- + +-- Each callback does just one thing: write an appropriate Event to the events +-- TQueue. + +errorCallback :: TQueue Event -> GLFW.Error -> String -> IO () +windowPosCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () +windowSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () +windowCloseCallback :: TQueue Event -> GLFW.Window -> IO () +windowRefreshCallback :: TQueue Event -> GLFW.Window -> IO () +windowFocusCallback :: TQueue Event -> GLFW.Window -> GLFW.FocusState -> IO () +windowIconifyCallback :: TQueue Event -> GLFW.Window -> GLFW.IconifyState -> IO () +framebufferSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () +mouseButtonCallback :: TQueue Event -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO () +cursorPosCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO () +cursorEnterCallback :: TQueue Event -> GLFW.Window -> GLFW.CursorState -> IO () +scrollCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO () +keyCallback :: TQueue Event -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO () +charCallback :: TQueue Event -> GLFW.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 + +-------------------------------------------------------------------------------- + +runDemo :: Env -> State -> IO () +runDemo env state = do + printInstructions + void $ evalRWST (adjustWindow >> run) env state + +run :: Demo () +run = do + win <- asks envWindow + + draw + liftIO $ do + GLFW.swapBuffers win + GL.flush -- not necessary, but someone recommended it + GLFW.pollEvents + processEvents + + state <- get + if stateDragging state + then do + let sodx = stateDragStartX state + sody = stateDragStartY state + sodxa = stateDragStartXAngle state + sodya = stateDragStartYAngle state + (x, y) <- liftIO $ GLFW.getCursorPos win + let myrot = (x - sodx) / 2 + mxrot = (y - sody) / 2 + put $ state + { stateXAngle = sodxa + mxrot + , stateYAngle = sodya + myrot + } + else do + (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win + (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 + put $ state + { stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot) + , stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot) + } + + mt <- liftIO GLFW.getTime + modify $ \s -> s + { stateGearZAngle = maybe 0 (realToFrac . (100*)) mt + } + + q <- liftIO $ GLFW.windowShouldClose win + unless q run + +processEvents :: Demo () +processEvents = do + tc <- asks envEventsChan + me <- liftIO $ atomically $ tryReadTQueue tc + case me of + Just e -> do + processEvent e + processEvents + Nothing -> return () + +processEvent :: Event -> Demo () +processEvent ev = + case ev of + (EventError e s) -> do + printEvent "error" [show e, show s] + win <- asks envWindow + liftIO $ GLFW.setWindowShouldClose win True + + (EventWindowPos _ x y) -> + printEvent "window pos" [show x, show y] + + (EventWindowSize _ width height) -> + printEvent "window size" [show width, show height] + + (EventWindowClose _) -> + printEvent "window close" [] + + (EventWindowRefresh _) -> + printEvent "window refresh" [] + + (EventWindowFocus _ fs) -> + printEvent "window focus" [show fs] + + (EventWindowIconify _ is) -> + printEvent "window iconify" [show is] + + (EventFramebufferSize _ width height) -> do + printEvent "framebuffer size" [show width, show height] + modify $ \s -> s + { stateWindowWidth = width + , stateWindowHeight = height + } + adjustWindow + + (EventMouseButton _ mb mbs mk) -> do + printEvent "mouse button" [show mb, show mbs, showModifierKeys mk] + when (mb == GLFW.MouseButton'1) $ do + let pressed = mbs == GLFW.MouseButtonState'Pressed + modify $ \s -> s + { stateMouseDown = pressed + } + unless pressed $ + modify $ \s -> s + { stateDragging = False + } + + (EventCursorPos _ x y) -> do + let x' = round x :: Int + y' = round y :: Int + printEvent "cursor pos" [show x', show y'] + state <- get + when (stateMouseDown state && not (stateDragging state)) $ + put $ state + { stateDragging = True + , stateDragStartX = x + , stateDragStartY = y + , stateDragStartXAngle = stateXAngle state + , stateDragStartYAngle = stateYAngle state + } + + (EventCursorEnter _ cs) -> + printEvent "cursor enter" [show cs] + + (EventScroll _ x y) -> do + let x' = round x :: Int + y' = round y :: Int + printEvent "scroll" [show x', show y'] + env <- ask + modify $ \s -> s + { stateZDist = + let zDist' = stateZDist s + realToFrac (negate $ y / 2) + in curb (envZDistClosest env) (envZDistFarthest env) zDist' + } + adjustWindow + + (EventKey win k scancode ks mk) -> do + printEvent "key" [show k, show scancode, show ks, showModifierKeys mk] + when (ks == GLFW.KeyState'Pressed) $ do + -- Q, Esc: exit + when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $ + liftIO $ GLFW.setWindowShouldClose win True + -- ?: print instructions + when (k == GLFW.Key'Slash && GLFW.modifierKeysShift mk) $ + liftIO printInstructions + -- i: print GLFW information + when (k == GLFW.Key'I) $ + liftIO $ printInformation win + + (EventChar _ c) -> + printEvent "char" [show c] + +adjustWindow :: Demo () +adjustWindow = do + state <- get + let width = stateWindowWidth state + height = stateWindowHeight state + zDist = stateZDist state + + let pos = GL.Position 0 0 + size = GL.Size (fromIntegral width) (fromIntegral height) + h = fromIntegral height / fromIntegral width :: Double + znear = 1 :: Double + zfar = 40 :: Double + xmax = znear * 0.5 :: Double + liftIO $ do + GL.viewport GL.$= (pos, size) + GL.matrixMode GL.$= GL.Projection + GL.loadIdentity + GL.frustum (realToFrac $ -xmax) + (realToFrac xmax) + (realToFrac $ -xmax * realToFrac h) + (realToFrac $ xmax * realToFrac h) + (realToFrac znear) + (realToFrac zfar) + GL.matrixMode GL.$= GL.Modelview 0 + GL.loadIdentity + GL.translate (GL.Vector3 0 0 (negate $ realToFrac zDist) :: GL.Vector3 GL.GLfloat) + +draw :: Demo () +draw = do + env <- ask + state <- get + let gear1 = envGear1 env + gear2 = envGear2 env + gear3 = envGear3 env + xa = stateXAngle state + ya = stateYAngle state + za = stateZAngle state + ga = stateGearZAngle state + liftIO $ do + GL.clear [GL.ColorBuffer, GL.DepthBuffer] + GL.preservingMatrix $ do + GL.rotate (realToFrac xa) xunit + GL.rotate (realToFrac ya) yunit + GL.rotate (realToFrac za) zunit + GL.preservingMatrix $ do + GL.translate gear1vec + GL.rotate (realToFrac ga) zunit + GL.callList gear1 + GL.preservingMatrix $ do + GL.translate gear2vec + GL.rotate (-2 * realToFrac ga - 9) zunit + GL.callList gear2 + GL.preservingMatrix $ do + GL.translate gear3vec + GL.rotate (-2 * realToFrac ga - 25) zunit + GL.callList gear3 + where + gear1vec = GL.Vector3 (-3) (-2) 0 :: GL.Vector3 GL.GLfloat + gear2vec = GL.Vector3 3.1 (-2) 0 :: GL.Vector3 GL.GLfloat + gear3vec = GL.Vector3 (-3.1) 4.2 0 :: GL.Vector3 GL.GLfloat + xunit = GL.Vector3 1 0 0 :: GL.Vector3 GL.GLfloat + yunit = GL.Vector3 0 1 0 :: GL.Vector3 GL.GLfloat + zunit = GL.Vector3 0 0 1 :: GL.Vector3 GL.GLfloat + +getCursorKeyDirections :: GLFW.Window -> IO (Double, Double) +getCursorKeyDirections win = do + x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up + x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down + y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left + y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right + let x0n = if x0 then (-1) else 0 + x1n = if x1 then 1 else 0 + y0n = if y0 then (-1) else 0 + y1n = if y1 then 1 else 0 + return (x0n + x1n, y0n + y1n) + +getJoystickDirections :: GLFW.Joystick -> IO (Double, Double) +getJoystickDirections js = do + maxes <- GLFW.getJoystickAxes js + return $ case maxes of + (Just (x:y:_)) -> (-y, x) + _ -> ( 0, 0) + +isPress :: GLFW.KeyState -> Bool +isPress GLFW.KeyState'Pressed = True +isPress GLFW.KeyState'Repeating = True +isPress _ = False + +-------------------------------------------------------------------------------- + +printInstructions :: IO () +printInstructions = + putStrLn $ render $ + nest 4 ( + text "------------------------------------------------------------" $+$ + text "'?': Print these instructions" $+$ + text "'i': Print GLFW information" $+$ + text "" $+$ + text "* Mouse cursor, keyboard cursor keys, and/or joystick" $+$ + text " control rotation." $+$ + text "* Mouse scroll wheel controls distance from scene." $+$ + text "------------------------------------------------------------" + ) + +printInformation :: GLFW.Window -> IO () +printInformation win = do + version <- GLFW.getVersion + versionString <- GLFW.getVersionString + monitorInfos <- runMaybeT getMonitorInfos + joystickNames <- getJoystickNames + clientAPI <- GLFW.getWindowClientAPI win + cv0 <- GLFW.getWindowContextVersionMajor win + cv1 <- GLFW.getWindowContextVersionMinor win + cv2 <- GLFW.getWindowContextVersionRevision win + robustness <- GLFW.getWindowContextRobustness win + forwardCompat <- GLFW.getWindowOpenGLForwardCompat win + debug <- GLFW.getWindowOpenGLDebugContext win + profile <- GLFW.getWindowOpenGLProfile win + + putStrLn $ render $ + nest 4 ( + text "------------------------------------------------------------" $+$ + text "GLFW C library:" $+$ + nest 4 ( + text "Version:" <+> renderVersion version $+$ + text "Version string:" <+> renderVersionString versionString + ) $+$ + text "Monitors:" $+$ + nest 4 ( + renderMonitorInfos monitorInfos + ) $+$ + text "Joysticks:" $+$ + nest 4 ( + renderJoystickNames joystickNames + ) $+$ + text "OpenGL context:" $+$ + nest 4 ( + text "Client API:" <+> renderClientAPI clientAPI $+$ + text "Version:" <+> renderContextVersion cv0 cv1 cv2 $+$ + text "Robustness:" <+> renderContextRobustness robustness $+$ + text "Forward compatibility:" <+> renderForwardCompat forwardCompat $+$ + text "Debug:" <+> renderDebug debug $+$ + text "Profile:" <+> renderProfile profile + ) $+$ + text "------------------------------------------------------------" + ) + where + renderVersion (GLFW.Version v0 v1 v2) = + text $ intercalate "." $ map show [v0, v1, v2] + + renderVersionString = + text . show + + renderMonitorInfos = + maybe (text "(error)") (vcat . map renderMonitorInfo) + + renderMonitorInfo (name, (x,y), (w,h), vms) = + text (show name) $+$ + nest 4 ( + location <+> size $+$ + fsep (map renderVideoMode vms) + ) + where + location = int x <> text "," <> int y + size = int w <> text "x" <> int h <> text "mm" + + renderVideoMode (GLFW.VideoMode w h r g b rr) = + brackets $ res <+> rgb <+> hz + where + res = int w <> text "x" <> int h + rgb = int r <> text "x" <> int g <> text "x" <> int b + hz = int rr <> text "Hz" + + renderJoystickNames pairs = + vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs + + renderContextVersion v0 v1 v2 = + hcat [int v0, text ".", int v1, text ".", int v2] + + renderClientAPI = text . show + renderContextRobustness = text . show + renderForwardCompat = text . show + renderDebug = text . show + renderProfile = text . show + +type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode]) + +getMonitorInfos :: MaybeT IO [MonitorInfo] +getMonitorInfos = + getMonitors >>= mapM getMonitorInfo + where + getMonitors :: MaybeT IO [GLFW.Monitor] + getMonitors = MaybeT GLFW.getMonitors + + getMonitorInfo :: GLFW.Monitor -> MaybeT IO MonitorInfo + getMonitorInfo mon = do + name <- getMonitorName mon + vms <- getVideoModes mon + MaybeT $ do + pos <- liftIO $ GLFW.getMonitorPos mon + size <- liftIO $ GLFW.getMonitorPhysicalSize mon + return $ Just (name, pos, size, vms) + + getMonitorName :: GLFW.Monitor -> MaybeT IO String + getMonitorName mon = MaybeT $ GLFW.getMonitorName mon + + getVideoModes :: GLFW.Monitor -> MaybeT IO [GLFW.VideoMode] + getVideoModes mon = MaybeT $ GLFW.getVideoModes mon + +getJoystickNames :: IO [(GLFW.Joystick, String)] +getJoystickNames = + catMaybes `fmap` mapM getJoystick joysticks + where + getJoystick js = + fmap (maybe Nothing (\name -> Just (js, name))) + (GLFW.getJoystickName js) + +-------------------------------------------------------------------------------- + +printEvent :: String -> [String] -> Demo () +printEvent cbname fields = + liftIO $ putStrLn $ cbname ++ ": " ++ unwords fields + +showModifierKeys :: GLFW.ModifierKeys -> String +showModifierKeys mk = + "[mod keys: " ++ keys ++ "]" + where + keys = if null xs then "none" else unwords xs + xs = catMaybes ys + ys = [ if GLFW.modifierKeysShift mk then Just "shift" else Nothing + , if GLFW.modifierKeysControl mk then Just "control" else Nothing + , if GLFW.modifierKeysAlt mk then Just "alt" else Nothing + , if GLFW.modifierKeysSuper mk then Just "super" else Nothing + ] + +curb :: Ord a => a -> a -> a -> a +curb l h x + | x < l = l + | x > h = h + | otherwise = x + +-------------------------------------------------------------------------------- + +joysticks :: [GLFW.Joystick] +joysticks = + [ GLFW.Joystick'1 + , GLFW.Joystick'2 + , GLFW.Joystick'3 + , GLFW.Joystick'4 + , GLFW.Joystick'5 + , GLFW.Joystick'6 + , GLFW.Joystick'7 + , GLFW.Joystick'8 + , GLFW.Joystick'9 + , GLFW.Joystick'10 + , GLFW.Joystick'11 + , GLFW.Joystick'12 + , GLFW.Joystick'13 + , GLFW.Joystick'14 + , GLFW.Joystick'15 + , GLFW.Joystick'16 + ] +