From 33b1ec5534aaf5b10bd40f73df1a41c3b47e1cc6 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sat, 4 Jan 2014 02:53:12 +0100 Subject: [PATCH 01/11] flickering triangle (rendering cube) --- shaders/fragment.shader | 2 +- shaders/vertex.shader | 8 +++---- src/Main.hs | 10 +------- src/Map/Map.hs | 53 +++++++++++++++++++++++++++++++++++++---- src/Render/Render.hs | 12 ++-------- 5 files changed, 56 insertions(+), 29 deletions(-) diff --git a/shaders/fragment.shader b/shaders/fragment.shader index 576f612..1ef8c2c 100644 --- a/shaders/fragment.shader +++ b/shaders/fragment.shader @@ -9,5 +9,5 @@ out vec4 fg_FragColor; void main(void) { //copy-shader - fg_FragColor = fg_SmoothColor; + fg_FragColor = vec4(0.5,0.5,0.5,1.0);//fg_SmoothColor; } \ No newline at end of file diff --git a/shaders/vertex.shader b/shaders/vertex.shader index 780ea0c..af4183f 100644 --- a/shaders/vertex.shader +++ b/shaders/vertex.shader @@ -4,17 +4,17 @@ uniform mat4 fg_ProjectionMatrix; //vertex-data -in vec4 fg_Color; +//in vec4 fg_Color; in vec3 fg_VertexIn; -in vec3 fg_Normal; +//in vec3 fg_Normal; //output-data for later stages -smooth out vec4 fg_SmoothColor; +//smooth out vec4 fg_SmoothColor; void main() { //transform vec3 into vec4, setting w to 1 vec4 fg_Vertex = vec4(fg_VertexIn, 1.0); - fg_SmoothColor = fg_Color + 0.001* fg_Normal.xyzx; + //fg_SmoothColor = fg_Color + 0.001* fg_Normal.xyzx; gl_Position = fg_ProjectionMatrix * fg_Vertex; } \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 0d49094..db47fb5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -44,8 +44,6 @@ data State = State , stateFrustum :: [GL.GLfloat] -- pointer to bindings for locations inside the compiled shader -- mutable because shaders may be changed in the future. - , shdrColorIndex :: !GL.AttribLocation - , shdrNormalIndex :: !GL.AttribLocation , shdrVertexIndex :: !GL.AttribLocation , shdrProjMatIndex :: !GL.UniformLocation -- the map @@ -105,7 +103,7 @@ main = do --generate map vertices (mapBuffer, vert) <- getMapBufferObject - (ci, ni, vi, pi) <- initShader + (vi, pi) <- initShader let zDistClosest = 10 zDistFarthest = zDistClosest + 20 @@ -134,8 +132,6 @@ main = do , stateDragStartY = 0 , stateDragStartXAngle = 0 , stateDragStartYAngle = 0 - , shdrColorIndex = ci - , shdrNormalIndex = ni , shdrVertexIndex = vi , shdrProjMatIndex = pi , stateMap = mapBuffer @@ -378,8 +374,6 @@ draw = do ya = stateYAngle state za = stateZAngle state (GL.UniformLocation proj) = shdrProjMatIndex state - ci = shdrColorIndex state - ni = shdrNormalIndex state vi = shdrVertexIndex state numVert = mapVert state map' = stateMap state @@ -387,8 +381,6 @@ draw = do liftIO $ do lookAtUniformMatrix4fv (0.0,0.0,0.0) (0, 15, 0) up frust proj 1 GL.bindBuffer GL.ArrayBuffer GL.$= Just map' - GL.vertexAttribPointer ci GL.$= fgColorIndex - GL.vertexAttribPointer ni GL.$= fgNormalIndex GL.vertexAttribPointer vi GL.$= fgVertexIndex GL.drawArrays GL.Triangles 0 numVert diff --git a/src/Map/Map.hs b/src/Map/Map.hs index d613c25..73446ab 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -47,9 +47,7 @@ lineHeight :: GLfloat lineHeight = 0.8660254 numComponents :: Int -numComponents = 4 --color - +3 --normal - +3 --vertex +numComponents = 3 mapStride :: Stride mapStride = fromIntegral (sizeOf (0.0 :: GLfloat)) * fromIntegral numComponents @@ -73,14 +71,14 @@ fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do map' <- testmap - map' <- return $ generateTriangles map' + map' <- return $ generateCube --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(P.head map')), buffer, StaticDraw) + bufferData ArrayBuffer $= (fromIntegral (P.length map' * sizeOf(P.head map')), buffer, StaticDraw) checkError "initBuffer" return (bo,len) @@ -88,6 +86,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 + -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.3, + -- upper plane + -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.3, + -- left plane + -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.3, + -- right plane + 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.3, + -- front plane + -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.3, + -- back plane + -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.3 + ] + generateTriangles :: PlayMap -> [GLfloat] generateTriangles map' = let ((xl,yl),(xh,yh)) = bounds map' in diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 413c561..cd073b0 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -33,7 +33,7 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation) +initShader :: IO (AttribLocation, UniformLocation) initShader = do ! vertexSource <- B.readFile vertexShaderFile ! fragmentSource <- B.readFile fragmentShaderFile @@ -49,20 +49,12 @@ initShader = do projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix") checkError "projMat" - colorIndex <- get (attribLocation program "fg_Color") - vertexAttribArray colorIndex $= Enabled - checkError "colorInd" - - normalIndex <- get (attribLocation program "fg_Normal") - vertexAttribArray normalIndex $= Enabled - checkError "normalInd" - vertexIndex <- get (attribLocation program "fg_VertexIn") vertexAttribArray vertexIndex $= Enabled checkError "vertexInd" checkError "initShader" - return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex) + return (vertexIndex, projectionMatrixIndex) initRendering :: IO () initRendering = do From 42e7bd65ac033e9107ce7e2f627eabc1a6eef177 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 03:10:06 +0100 Subject: [PATCH 02/11] new projection --- Pioneers.cabal | 3 ++- src/Main.hs | 17 ++++++++++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index 1c96d4f..af29ed0 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -25,5 +25,6 @@ executable Pioneers pretty >=1.1, transformers >=0.3.0 && <0.4, mtl >=2.1.2, - stm >=2.4.2 + stm >=2.4.2, + vector >=0.10.9 && <0.11 diff --git a/src/Main.hs b/src/Main.hs index db47fb5..7dfb63d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -11,7 +11,9 @@ import Data.Maybe (catMaybes) import Text.PrettyPrint import qualified Graphics.Rendering.OpenGL.GL as GL +import qualified Graphics.Rendering.OpenGL.Raw as GL import qualified Graphics.UI.GLFW as GLFW +import qualified Data.Vector.Storable as V import Map.Map import Render.Render (initShader) @@ -215,9 +217,7 @@ run = do draw liftIO $ do GLFW.swapBuffers win - GL.flush -- not necessary, but someone recommended it GLFW.pollEvents - GL.finish -- getEvents & process processEvents @@ -379,7 +379,18 @@ draw = do map' = stateMap state frust = stateFrustum state liftIO $ do - lookAtUniformMatrix4fv (0.0,0.0,0.0) (0, 15, 0) up frust proj 1 + GL.clear [GL.ColorBuffer] + 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 + ] + V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr GL.bindBuffer GL.ArrayBuffer GL.$= Just map' GL.vertexAttribPointer vi GL.$= fgVertexIndex From 47de89ca390168ac7f95cfcc0d5d2703887b2984 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 03:14:44 +0100 Subject: [PATCH 03/11] here a triangle works -.- --- src/Map/Map.hs | 72 +++--- test2.hs | 660 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 696 insertions(+), 36 deletions(-) create mode 100644 test2.hs diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 73446ab..7920cba 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -88,47 +88,47 @@ prettyMap _ = [] generateCube :: [GLfloat] generateCube = [ -- lower plane - -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.3, + -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 - -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.3, + -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 - -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.3, + -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 - 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.3, + 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 - -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.3, + -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 - -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.3 + -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] 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 + ] + From fd4d2a0d14ca75e13d2e25eb552190746673c82a Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 14:09:42 +0100 Subject: [PATCH 04/11] TRIANGLEEEEESS!!!!11!! finally. --- shaders/fragment.shader | 2 +- shaders/vertex.shader | 10 ++++++---- src/Main.hs | 22 ++++++++++++++++++++-- src/Map/Map.hs | 37 +++++++++++++++++++------------------ src/Render/Render.hs | 15 +++++++++++++-- 5 files changed, 59 insertions(+), 27 deletions(-) diff --git a/shaders/fragment.shader b/shaders/fragment.shader index 1ef8c2c..576f612 100644 --- a/shaders/fragment.shader +++ b/shaders/fragment.shader @@ -9,5 +9,5 @@ out vec4 fg_FragColor; void main(void) { //copy-shader - fg_FragColor = vec4(0.5,0.5,0.5,1.0);//fg_SmoothColor; + fg_FragColor = fg_SmoothColor; } \ No newline at end of file diff --git a/shaders/vertex.shader b/shaders/vertex.shader index af4183f..8be5177 100644 --- a/shaders/vertex.shader +++ b/shaders/vertex.shader @@ -2,19 +2,21 @@ //constant projection matrix uniform mat4 fg_ProjectionMatrix; +uniform mat4 fg_ModelMatrix; //vertex-data -//in vec4 fg_Color; +in vec4 fg_Color; in vec3 fg_VertexIn; //in vec3 fg_Normal; //output-data for later stages -//smooth out vec4 fg_SmoothColor; +smooth out vec4 fg_SmoothColor; void main() { //transform vec3 into vec4, setting w to 1 vec4 fg_Vertex = vec4(fg_VertexIn, 1.0); - //fg_SmoothColor = fg_Color + 0.001* fg_Normal.xyzx; - gl_Position = fg_ProjectionMatrix * fg_Vertex; + fg_SmoothColor = fg_Color; + // + 0.001* fg_Normal.xyzx; + gl_Position = fg_ProjectionMatrix * fg_ModelMatrix * fg_Vertex; } \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 7dfb63d..81ad896 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -47,7 +47,9 @@ data State = State -- pointer to bindings for locations inside the compiled shader -- mutable because shaders may be changed in the future. , shdrVertexIndex :: !GL.AttribLocation + , shdrColorIndex :: !GL.AttribLocation , shdrProjMatIndex :: !GL.UniformLocation + , shdrModelMatIndex :: !GL.UniformLocation -- the map , stateMap :: !GL.BufferObject , mapVert :: !GL.NumArrayIndices @@ -105,7 +107,7 @@ main = do --generate map vertices (mapBuffer, vert) <- getMapBufferObject - (vi, pi) <- initShader + (ci, vi, pi, mi) <- initShader let zDistClosest = 10 zDistFarthest = zDistClosest + 20 @@ -135,7 +137,9 @@ main = do , stateDragStartXAngle = 0 , stateDragStartYAngle = 0 , shdrVertexIndex = vi + , shdrColorIndex = ci , shdrProjMatIndex = pi + , shdrModelMatIndex = mi , stateMap = mapBuffer , mapVert = vert , stateFrustum = frust @@ -222,6 +226,7 @@ run = do processEvents -- update State + {- state <- get if stateDragging state then do @@ -243,6 +248,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 @@ -373,12 +379,16 @@ draw = do let xa = stateXAngle state ya = stateYAngle state za = stateZAngle state - (GL.UniformLocation proj) = shdrProjMatIndex state + (GL.UniformLocation proj) = shdrProjMatIndex state + (GL.UniformLocation mmat) = shdrModelMatIndex state vi = shdrVertexIndex state + ci = shdrColorIndex state numVert = mapVert state map' = stateMap state frust = stateFrustum state liftIO $ do + --(vi,GL.UniformLocation proj) <- initShader + GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1 GL.clear [GL.ColorBuffer] let fov = 90 s = recip (tan $ fov * 0.5 * pi / 180) @@ -391,7 +401,15 @@ draw = do , 0, 0, -((f*n)/(f-n)), 0 ] V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr + let model = V.fromList [ + 1, 0, 0, 0 + , 0, 0, 1, 0 + , 0, 1, 0, 0 + ,-1, -1, -5, 1 + ] + V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr GL.bindBuffer GL.ArrayBuffer GL.$= Just map' + GL.vertexAttribPointer ci GL.$= fgColorIndex GL.vertexAttribPointer vi GL.$= fgVertexIndex GL.drawArrays GL.Triangles 0 numVert diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 7920cba..a4f01fb 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -47,31 +47,31 @@ lineHeight :: GLfloat lineHeight = 0.8660254 numComponents :: Int -numComponents = 3 +numComponents = 7 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 offset ) --(fromIntegral numComponents * offset)) -fgColorIndex :: (IntegerHandling, VertexArrayDescriptor a) -fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first +fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) +fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 3) --color first -fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor a) +fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color -fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor a) -fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal +fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) +fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 0) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do map' <- testmap - map' <- return $ generateCube --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] @@ -177,9 +177,9 @@ lookupVertex map' x y = --TODO: calculate normals correctly! in [ - cr, cg, cb, 1.0, -- RGBA Color - nx, ny, nz, -- 3 Normal - vx, vy, vz -- 3 Vertex + vx, vy, vz, -- 3 Vertex + cr, cg, cb, 1.0 -- RGBA Color + --nx, ny, nz, -- 3 Normal ] heightLookup :: PlayMap -> (Int,Int) -> GLfloat @@ -202,7 +202,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 @@ -233,14 +233,15 @@ testMapTemplate = T.transpose [ testMapTemplate2 :: [Text] testMapTemplate2 = T.transpose [ - "~~~~~~" + "~~~~~~~~~~~~", + "~SSSSSSSSSS~" ] testmap :: IO PlayMap testmap = do g <- getStdGen rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2) - return $ listArray ((0,0),(5,0)) rawMap + return $ listArray ((0,0),(9,1)) rawMap parseTemplate :: [Int] -> Text -> [MapEntry] diff --git a/src/Render/Render.hs b/src/Render/Render.hs index cd073b0..467d4fc 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -33,7 +33,7 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initShader :: IO (AttribLocation, UniformLocation) +initShader :: IO (AttribLocation, AttribLocation, UniformLocation, UniformLocation) initShader = do ! vertexSource <- B.readFile vertexShaderFile ! fragmentSource <- B.readFile fragmentShaderFile @@ -49,12 +49,23 @@ initShader = do projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix") checkError "projMat" + modelMatrixIndex <- get (uniformLocation program "fg_ModelMatrix") + checkError "modelMat" + + att <- get (activeAttribs program) + vertexIndex <- get (attribLocation program "fg_VertexIn") vertexAttribArray vertexIndex $= Enabled checkError "vertexInd" + colorIndex <- get (attribLocation program "fg_Color") + vertexAttribArray colorIndex $= Enabled + checkError "colorInd" + + putStrLn $ unlines $ "Attributes: ":map show att + checkError "initShader" - return (vertexIndex, projectionMatrixIndex) + return (colorIndex, vertexIndex, projectionMatrixIndex, modelMatrixIndex) initRendering :: IO () initRendering = do From f23b4e38fde60bf0bab4937a00d3d652852cfc6a Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 14:16:10 +0100 Subject: [PATCH 05/11] color!!! --- src/Map/Map.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Map/Map.hs b/src/Map/Map.hs index a4f01fb..0d1b95e 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -57,7 +57,7 @@ bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat mapVertexArrayDescriptor count' offset = - VertexArrayDescriptor count' Float mapStride (bufferObjectPtr offset ) --(fromIntegral numComponents * offset)) + VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 3) --color first From cde5231e6afd35a79e8b21fe9584869895257311 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 14:20:26 +0100 Subject: [PATCH 06/11] whole map.. --- src/Main.hs | 2 +- src/Map/Map.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 81ad896..3909462 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -405,7 +405,7 @@ draw = do 1, 0, 0, 0 , 0, 0, 1, 0 , 0, 1, 0, 0 - ,-1, -1, -5, 1 + ,-5, -10, -10, 1 ] V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr GL.bindBuffer GL.ArrayBuffer GL.$= Just map' diff --git a/src/Map/Map.hs b/src/Map/Map.hs index 0d1b95e..fd22925 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -240,8 +240,8 @@ testMapTemplate2 = T.transpose [ testmap :: IO PlayMap testmap = do g <- getStdGen - rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2) - return $ listArray ((0,0),(9,1)) rawMap + rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate) + return $ listArray ((0,0),(19,19)) rawMap parseTemplate :: [Int] -> Text -> [MapEntry] From 602b20eb6c26e7f730600f7a9628db8ef744dd19 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 16:55:59 +0100 Subject: [PATCH 07/11] it works... --- Pioneers.cabal | 5 +++- shaders/vertex.shader | 15 ++++++++--- src/Main.hs | 60 ++++++++++++++++++++++++++++--------------- src/Map/Map.hs | 25 ++++++++++-------- src/Render/Render.hs | 13 +++++++--- 5 files changed, 80 insertions(+), 38 deletions(-) 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 8be5177..1e2ee66 100644 --- a/shaders/vertex.shader +++ b/shaders/vertex.shader @@ -7,16 +7,25 @@ uniform mat4 fg_ModelMatrix; //vertex-data in vec4 fg_Color; in vec3 fg_VertexIn; -//in vec3 fg_Normal; +in vec3 fg_NormalIn; //output-data for later stages smooth 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, 1.0); - fg_SmoothColor = fg_Color; - // + 0.001* fg_Normal.xyzx; + 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_ModelMatrix * fg_Vertex; } \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 3909462..aa071d7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,13 +2,20 @@ module Main (main) where -------------------------------------------------------------------------------- +import Control.Applicative import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue) +import Control.Lens 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 Data.Distributive (distribute) +import Foreign (Ptr, castPtr, nullPtr, sizeOf, with) +import Foreign.C (CFloat) +import Linear as L +import Linear ((!*!)) import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.Raw as GL @@ -17,7 +24,7 @@ import qualified Data.Vector.Storable as V import Map.Map import Render.Render (initShader) -import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum) +import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError) -------------------------------------------------------------------------------- @@ -48,6 +55,7 @@ data State = State -- mutable because shaders may be changed in the future. , shdrVertexIndex :: !GL.AttribLocation , shdrColorIndex :: !GL.AttribLocation + , shdrNormalIndex :: !GL.AttribLocation , shdrProjMatIndex :: !GL.UniformLocation , shdrModelMatIndex :: !GL.UniformLocation -- the map @@ -107,11 +115,10 @@ main = do --generate map vertices (mapBuffer, vert) <- getMapBufferObject - (ci, vi, pi, mi) <- initShader + (ci, ni, vi, pi, 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 @@ -137,6 +144,7 @@ main = do , stateDragStartXAngle = 0 , stateDragStartYAngle = 0 , shdrVertexIndex = vi + , shdrNormalIndex = ni , shdrColorIndex = ci , shdrProjMatIndex = pi , shdrModelMatIndex = mi @@ -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 @@ -382,6 +389,7 @@ draw = do (GL.UniformLocation proj) = shdrProjMatIndex state (GL.UniformLocation mmat) = shdrModelMatIndex state vi = shdrVertexIndex state + ni = shdrNormalIndex state ci = shdrColorIndex state numVert = mapVert state map' = stateMap state @@ -389,27 +397,39 @@ draw = do liftIO $ do --(vi,GL.UniformLocation proj) <- initShader GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1 - GL.clear [GL.ColorBuffer] + GL.clear [GL.ColorBuffer, GL.DepthBuffer] 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 - ] - V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr - let model = V.fromList [ - 1, 0, 0, 0 - , 0, 0, 1, 0 - , 0, 1, 0, 0 - ,-5, -10, -10, 1 - ] - V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr + + let perspective = V4 (V4 s 0 0 0) + (V4 0 s 0 0) + (V4 0 0 (-(f/(f - n))) (-1)) + (V4 0 0 (-((f*n)/(f-n))) 1) + !*! + V4 (V4 1 0 0 0) + (V4 0 0 1 0) + (V4 0 1 0 0) + (V4 0 0 0 1) + with (distribute $ perspective) $ \ptr -> + GL.glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) + --V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr + let cam = crot !*! ctrans + ctrans = (eye4 & translation .~ V3 (-5) (-10) (-10)) :: M44 CFloat + crot = (m33_to_m44 $ + (fromQuaternion $ + axisAngle (V3 1 0 0) (pi/4)) + !*! + (fromQuaternion $ + axisAngle (V3 0 1 0) (pi/16)) + ) :: M44 CFloat + --V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr + with (distribute $ cam) $ \ptr -> + GL.glUniformMatrix4fv mmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) GL.bindBuffer GL.ArrayBuffer GL.$= Just map' GL.vertexAttribPointer ci GL.$= fgColorIndex + GL.vertexAttribPointer ni GL.$= fgNormalIndex GL.vertexAttribPointer vi GL.$= fgVertexIndex GL.drawArrays GL.Triangles 0 numVert diff --git a/src/Map/Map.hs b/src/Map/Map.hs index fd22925..78595ab 100644 --- a/src/Map/Map.hs +++ b/src/Map/Map.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, BangPatterns #-} module Map.Map ( @@ -47,7 +47,7 @@ lineHeight :: GLfloat lineHeight = 0.8660254 numComponents :: Int -numComponents = 7 +numComponents = 10 mapStride :: Stride mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents) @@ -60,18 +60,18 @@ mapVertexArrayDescriptor count' offset = VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset)) fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) -fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 3) --color first +fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat) -fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 0) --vertex after normal +fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal getMapBufferObject :: IO (BufferObject, NumArrayIndices) getMapBufferObject = do map' <- testmap - map' <- return $ P.map (*1) (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] @@ -177,9 +177,9 @@ lookupVertex map' x y = --TODO: calculate normals correctly! in [ - vx, vy, vz, -- 3 Vertex - cr, cg, cb, 1.0 -- RGBA Color - --nx, ny, nz, -- 3 Normal + cr, cg, cb, 1.0, -- RGBA Color + nx, ny, nz, -- 3 Normal + vx, vy, vz -- 3 Vertex ] heightLookup :: PlayMap -> (Int,Int) -> GLfloat @@ -233,8 +233,7 @@ testMapTemplate = T.transpose [ testMapTemplate2 :: [Text] testMapTemplate2 = T.transpose [ - "~~~~~~~~~~~~", - "~SSSSSSSSSS~" + "~~~~~~~~~~~~" ] testmap :: IO PlayMap @@ -243,6 +242,12 @@ testmap = do 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),(9,0)) rawMap + parseTemplate :: [Int] -> Text -> [MapEntry] parseTemplate (r:rs) t = diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 467d4fc..e3a7e8d 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -33,7 +33,7 @@ initBuffer varray = checkError "initBuffer" return bufferObject -initShader :: IO (AttribLocation, AttribLocation, UniformLocation, UniformLocation) +initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation, UniformLocation) initShader = do ! vertexSource <- B.readFile vertexShaderFile ! fragmentSource <- B.readFile fragmentShaderFile @@ -52,20 +52,25 @@ initShader = do modelMatrixIndex <- get (uniformLocation program "fg_ModelMatrix") checkError "modelMat" - att <- get (activeAttribs program) - 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, vertexIndex, projectionMatrixIndex, modelMatrixIndex) + return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, modelMatrixIndex) initRendering :: IO () initRendering = do From 6cc917708256200cd3e063b7f3a9813b93b7bb67 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 17:57:30 +0100 Subject: [PATCH 08/11] wiered camera --- src/Main.hs | 45 ++++++++++++++++++++++++++++++++------------- src/Render/Misc.hs | 30 +++++++++++++++++++++++++----- 2 files changed, 57 insertions(+), 18 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index aa071d7..7c3707b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,7 +24,7 @@ import qualified Data.Vector.Storable as V import Map.Map import Render.Render (initShader) -import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError) +import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError, lookAt) -------------------------------------------------------------------------------- @@ -233,7 +233,7 @@ run = do processEvents -- update State - {- + state <- get if stateDragging state then do @@ -244,10 +244,19 @@ run = do (x, y) <- liftIO $ GLFW.getCursorPos win let myrot = (x - sodx) / 2 mxrot = (y - sody) / 2 + newXAngle = if newXAngle' > pi then pi else + if newXAngle' < 0 then 0 else + newXAngle' + newXAngle' = sodxa - mxrot/100 + newYAngle = if newYAngle' > 2*pi then newYAngle'-2*pi else + if newYAngle' < 0 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 @@ -255,7 +264,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 @@ -383,8 +392,8 @@ 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 (GL.UniformLocation mmat) = shdrModelMatIndex state @@ -405,8 +414,8 @@ draw = do let perspective = V4 (V4 s 0 0 0) (V4 0 s 0 0) - (V4 0 0 (-(f/(f - n))) (-1)) - (V4 0 0 (-((f*n)/(f-n))) 1) + (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) + (V4 0 0 (-1) 0) !*! V4 (V4 1 0 0 0) (V4 0 0 1 0) @@ -415,15 +424,25 @@ draw = do with (distribute $ perspective) $ \ptr -> GL.glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) --V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr - let cam = crot !*! ctrans - ctrans = (eye4 & translation .~ V3 (-5) (-10) (-10)) :: M44 CFloat + let cam = lookAt (V3 5 0 5) (crot' !* cdist') up + --cdist !*! crot !*! camat + camat = (eye4 & translation .~ V3 (-0.5) (0) (-0.5)) :: M44 CFloat + cdist = (eye4 & translation .~ V3 (0) (0) (-10)) :: M44 CFloat crot = (m33_to_m44 $ (fromQuaternion $ - axisAngle (V3 1 0 0) (pi/4)) + axisAngle (V3 1 0 0) (xa::CFloat)) !*! (fromQuaternion $ - axisAngle (V3 0 1 0) (pi/16)) + axisAngle (V3 0 1 0) (ya::CFloat)) ) :: M44 CFloat + cdist' = V3 (0) (0) (-10) + crot' = ( + (fromQuaternion $ + axisAngle (V3 1 0 0) (xa::CFloat)) + !*! + (fromQuaternion $ + axisAngle (V3 0 1 0) (ya::CFloat)) + ) :: M33 CFloat --V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr with (distribute $ cam) $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index cd306f3..e3f0bff 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 @@ -126,9 +127,28 @@ infixl 5 >< ] _ >< _ = error "non-conformat matrix-multiplication" + +lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat +lookAt at eye@(V3 ex ey ez) up = + V4 + (V4 xx yx zx 0) + (V4 xy yy zy 0) + (V4 xz yz zz 0) + (V4 0 0 0 1) + !*! + V4 + (V4 1 0 0 (-ex)) + (V4 0 1 0 (-ey)) + (V4 0 0 1 (-ez)) + (V4 0 0 0 1) + where + z@(V3 zx zy zz) = normalize (eye ^-^ at) + x@(V3 xx xy xz) = normalize (cross up z) + y@(V3 yx yy yz) = 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, From df9b37429c00a51fc8f9921d5bd7904dc66844a9 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 4 Jan 2014 23:47:07 +0100 Subject: [PATCH 09/11] cameraaaaaaa -.- --- src/Main.hs | 54 ++++++++++++++++++++++++++++++-------------- src/Render/Misc.hs | 17 +++++++------- src/Render/Render.hs | 5 +++- 3 files changed, 50 insertions(+), 26 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 7c3707b..128bf6e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,6 +16,7 @@ import Foreign (Ptr, castPtr, nullPtr, sizeOf, with) import Foreign.C (CFloat) import Linear as L import Linear ((!*!)) +import qualified Debug.Trace as T (trace) import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.Raw as GL @@ -23,7 +24,7 @@ import qualified Graphics.UI.GLFW as GLFW import qualified Data.Vector.Storable as V import Map.Map -import Render.Render (initShader) +import Render.Render (initShader, initRendering) import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError, lookAt) -------------------------------------------------------------------------------- @@ -113,6 +114,7 @@ main = do (fbWidth, fbHeight) <- GLFW.getFramebufferSize win + initRendering --generate map vertices (mapBuffer, vert) <- getMapBufferObject (ci, ni, vi, pi, mi) <- initShader @@ -244,14 +246,14 @@ run = do (x, y) <- liftIO $ GLFW.getCursorPos win let myrot = (x - sodx) / 2 mxrot = (y - sody) / 2 - newXAngle = if newXAngle' > pi then pi else - if newXAngle' < 0 then 0 else + newXAngle = if newXAngle' > 2*pi then 2*pi else + if newXAngle' < -2*pi then -2*pi else newXAngle' - newXAngle' = sodxa - mxrot/100 + newXAngle' = sodxa + mxrot/100 newYAngle = if newYAngle' > 2*pi then newYAngle'-2*pi else if newYAngle' < 0 then newYAngle'+2*pi else newYAngle' - newYAngle' = sodya - myrot/100 + newYAngle' = sodya + myrot/100 put $ state { stateXAngle = newXAngle , stateYAngle = newYAngle @@ -412,20 +414,35 @@ draw = do f = 1000 n = 1 - let perspective = V4 (V4 s 0 0 0) - (V4 0 s 0 0) + let perspective = V4 (V4 (2*s) 0 0 0) + (V4 0 (2*s) 0 0) (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) (V4 0 0 (-1) 0) - !*! - V4 (V4 1 0 0 0) - (V4 0 0 1 0) - (V4 0 1 0 0) - (V4 0 0 0 1) with (distribute $ perspective) $ \ptr -> GL.glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) + + {-let cam = out !*! roty !*! rotx !*! center + out = V4 (V4 1 0 0 0) + (V4 0 1 0 0) + (V4 0 0 1 (-10)) + (V4 0 0 0 1) + rotx = V4 (V4 1 0 0 0) + (V4 0 (cos xa) (-sin xa) 0) + (V4 0 (sin xa) (cos xa) 0) + (V4 0 0 0 1) + roty = V4 (V4 (cos ya) 0 (-sin ya) 0) + (V4 0 1 0 0) + (V4 (sin ya) 0 (cos ya) 0) + (V4 0 0 0 1) + center = V4 (V4 1 0 0 (-x)) + (V4 1 1 0 0 ) + (V4 0 0 1 (-z)) + (V4 0 0 0 1 ) + (x,z) = (5,5)-} --V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr - let cam = lookAt (V3 5 0 5) (crot' !* cdist') up + let cam = lookAt (cpos ^+^ at') at' up --cdist !*! crot !*! camat + cpos = -10 *^ normalize (V3 (sin ya) ((cos ya) * (sin xa)) ((cos ya) * (cos xa))) camat = (eye4 & translation .~ V3 (-0.5) (0) (-0.5)) :: M44 CFloat cdist = (eye4 & translation .~ V3 (0) (0) (-10)) :: M44 CFloat crot = (m33_to_m44 $ @@ -433,17 +450,20 @@ draw = do axisAngle (V3 1 0 0) (xa::CFloat)) !*! (fromQuaternion $ - axisAngle (V3 0 1 0) (ya::CFloat)) + axisAngle (V3 0 1 0) ((ya::CFloat) - pi/2)) ) :: M44 CFloat + at' = V3 5 0 5 cdist' = V3 (0) (0) (-10) crot' = ( (fromQuaternion $ - axisAngle (V3 1 0 0) (xa::CFloat)) + axisAngle (V3 0 1 0) (ya::CFloat)) !*! (fromQuaternion $ - axisAngle (V3 0 1 0) (ya::CFloat)) + axisAngle (V3 1 0 0) (xa::CFloat)) ) :: M33 CFloat - --V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr + --V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr -} + putStrLn $ unwords $ "Cam direction:":map show [cpos] + putStrLn $ unwords $ "Cam at:":map show [cpos ^+^ at'] with (distribute $ cam) $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) GL.bindBuffer GL.ArrayBuffer GL.$= Just map' diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index e3f0bff..d2758dc 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -128,23 +128,24 @@ infixl 5 >< _ >< _ = error "non-conformat matrix-multiplication" +-- from vmath.h lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat -lookAt at eye@(V3 ex ey ez) up = +lookAt eye@(V3 ex ey ez) center up = V4 - (V4 xx yx zx 0) - (V4 xy yy zy 0) - (V4 xz yz zz 0) + (V4 xx yx (-zx) 0) + (V4 xy yy (-zy) 0) + (V4 xz yz (-zz) 0) (V4 0 0 0 1) - !*! + !*! V4 (V4 1 0 0 (-ex)) (V4 0 1 0 (-ey)) (V4 0 0 1 (-ez)) (V4 0 0 0 1) where - z@(V3 zx zy zz) = normalize (eye ^-^ at) - x@(V3 xx xy xz) = normalize (cross up z) - y@(V3 yx yy yz) = cross z x + z@(V3 zx zy zz) = normalize (center ^-^ eye) + x@(V3 xx xy xz) = cross z (normalize up) + y@(V3 yx yy yz) = cross x z -- generates 4x4-Projection-Matrix lookAt_ :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat] diff --git a/src/Render/Render.hs b/src/Render/Render.hs index e3a7e8d..0de816f 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 @@ -75,4 +76,6 @@ initShader = do initRendering :: IO () initRendering = do clearColor $= Color4 0 0 0 0 + depthFunc $= Just Less + glCullFace gl_BACK checkError "initRendering" From ee9a8c455a5fbd13892a69845ccf0cb667707dc8 Mon Sep 17 00:00:00 2001 From: tpajenka Date: Sun, 5 Jan 2014 02:20:49 +0100 Subject: [PATCH 10/11] Misc: lookAt corrected (previous: transformation standard camera -> local camera, now: transformation local camera -> standard camera) --- src/Render/Misc.hs | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index d2758dc..77823b3 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -132,20 +132,14 @@ _ >< _ = error "non-conformat matrix-multiplication" lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat lookAt eye@(V3 ex ey ez) center up = V4 - (V4 xx yx (-zx) 0) - (V4 xy yy (-zy) 0) - (V4 xz yz (-zz) 0) - (V4 0 0 0 1) - !*! - V4 - (V4 1 0 0 (-ex)) - (V4 0 1 0 (-ey)) - (V4 0 0 1 (-ez)) + (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 (center ^-^ eye) - x@(V3 xx xy xz) = cross z (normalize up) - y@(V3 yx yy yz) = cross x z + 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] From df1fdc60d3fa09995023f653ffb0503cf6c3f7d1 Mon Sep 17 00:00:00 2001 From: jbrinkro Date: Sun, 5 Jan 2014 03:38:31 +0100 Subject: [PATCH 11/11] finish my work and be thankful! rotation works in special angles so u cant look under the map --- src/Main.hs | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 128bf6e..35dacb3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -246,12 +246,14 @@ 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 - if newXAngle' < -2*pi then -2*pi else +-- 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' > 2*pi then newYAngle'-2*pi else - if newYAngle' < 0 then newYAngle'+2*pi else + newYAngle = if newYAngle' > pi then newYAngle'-2*pi else + if newYAngle' < -pi then newYAngle'+2*pi else newYAngle' newYAngle' = sodya + myrot/100 put $ state @@ -442,9 +444,8 @@ draw = do --V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr let cam = lookAt (cpos ^+^ at') at' up --cdist !*! crot !*! camat - cpos = -10 *^ normalize (V3 (sin ya) ((cos ya) * (sin xa)) ((cos ya) * (cos xa))) - camat = (eye4 & translation .~ V3 (-0.5) (0) (-0.5)) :: M44 CFloat - cdist = (eye4 & translation .~ V3 (0) (0) (-10)) :: M44 CFloat +-- cpos = -10 *^ normalize (V3 (sin ya) ((cos ya) * (sin xa)) ((cos ya) * (cos xa))) + crot = (m33_to_m44 $ (fromQuaternion $ axisAngle (V3 1 0 0) (xa::CFloat)) @@ -452,18 +453,23 @@ draw = do (fromQuaternion $ axisAngle (V3 0 1 0) ((ya::CFloat) - pi/2)) ) :: M44 CFloat + at' = V3 5 0 5 - cdist' = V3 (0) (0) (-10) + + upmap = (fromQuaternion $ + axisAngle (V3 0 1 0) (ya::CFloat) :: M33 CFloat) + !* (V3 1 0 0) crot' = ( (fromQuaternion $ - axisAngle (V3 0 1 0) (ya::CFloat)) + axisAngle upmap (xa::CFloat)) !*! (fromQuaternion $ - axisAngle (V3 1 0 0) (xa::CFloat)) + axisAngle (V3 0 1 0) (ya::CFloat)) ) :: M33 CFloat + cpos = crot' !* (V3 0 0 (-10)) --V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr -} - putStrLn $ unwords $ "Cam direction:":map show [cpos] - putStrLn $ unwords $ "Cam at:":map show [cpos ^+^ at'] + --putStrLn $ unwords $ "Cam direction:":map show [cpos] + --putStrLn $ unwords $ "Cam at:":map show [cpos ^+^ at'] with (distribute $ cam) $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) GL.bindBuffer GL.ArrayBuffer GL.$= Just map'