diff --git a/src/Main.deprecated.hs b/src/Main.deprecated.hs deleted file mode 100644 index 7cd2f5f..0000000 --- a/src/Main.deprecated.hs +++ /dev/null @@ -1,529 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main where - -import Graphics.UI.Gtk (AttrOp ((:=))) -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.OpenGL as GtkGL - -import qualified Data.Array.IArray as A -import Graphics.Rendering.OpenGL as GL -import qualified Graphics.UI.Gtk.Gdk.EventM as Event - -import Map.Coordinates -import Map.Map - -import Data.IntSet as IS -import Data.IORef -import Data.Maybe (fromMaybe) -import Debug.Trace - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Foreign.Ptr (nullPtr) -import GHC.Conc.Sync (unsafeIOToSTM) -import Prelude as P -import System.IO.Unsafe (unsafePerformIO) -import Foreign.Marshal.Array (allocaArray) -import Render.Misc (dumpInfo) - -data ProgramState = PS { keysPressed :: IntSet - , px :: GLfloat - , py :: GLfloat - , pz :: GLfloat - , heading :: GLfloat - , pitch :: GLfloat - , dx :: GLfloat - , dy :: GLfloat - , dz :: GLfloat - , dheading :: GLfloat - , dpitch :: GLfloat - , showShadowMap :: Bool } - deriving (Show) - -type RenderObject = (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat]) - -(Vertex4 a b c d) .+ (Vertex4 w x y z) = Vertex4 (a+w) (b+x) (c+y) (d+z) -(Vertex4 a b c d) .* e = Vertex4 (a*e) (b*e) (c*e) (d*e) - -animationWaitTime = 3 :: Int -canvasWidth = 1024 :: Int -canvasHeight = 768 :: Int -deltaV = 0.10 -deltaH = 0.5 -deltaP = 0.15 -black = Color3 0 0 0 :: Color3 GLfloat -shadowMapSize :: TextureSize2D -shadowMapSize = TextureSize2D 512 512 - -up :: Vector3 GLdouble -up = Vector3 0 1 0 - -origin :: Vertex3 GLdouble -origin = Vertex3 0 0 0 - -sun = Light 0 - --- TODO: Put render-stuff in render-modul - ---gets Sun position in given format -getSunPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a -getSunPos f = do - Vertex4 x y z _ <- get (position sun) - return $ f (realToFrac x) (realToFrac y) (realToFrac z) - -glTexCoord2f (x,y) = texCoord (TexCoord2 x y :: TexCoord2 GLfloat) -glVertex3f (x,y,z) = vertex (Vertex3 x y z :: Vertex3 GLfloat) -glNormal3f (x,y,z) = normal (Normal3 x y z :: Normal3 GLfloat) - -prepareRenderTile :: PlayMap -> ((Int,Int),MapEntry) -> (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat]) -prepareRenderTile m (c@(cx,cz),(_,t)) = - ( - Vector3 (1.5 * fromIntegral cx) 0.0 - (if even cx then 2 * fromIntegral cz else - 2 * fromIntegral cz - 1) - , - case t of - Water -> Color3 0.5 0.5 1 :: Color3 GLfloat - Grass -> Color3 0.3 0.9 0.1 :: Color3 GLfloat - Sand -> Color3 0.9 0.85 0.7 :: Color3 GLfloat - Mountain -> Color3 0.5 0.5 0.5 :: Color3 GLfloat - ,getTileVertices m c) - -renderTile :: RenderObject -> IO () -renderTile (coord,c,ts) = - preservingMatrix $ do - translate coord - {-color black - lineWidth $= 4.0 - lineSmooth $= Enabled - _ <- renderPrimitive LineLoop $ do - glNormal3f(0.0,0.0,1.0) - mapM vertex ts-} - color c - _ <- renderPrimitive Polygon $ do - glNormal3f(0.0,1.0,0.0) - mapM vertex ts - return () - -drawSphere :: IO () -drawSphere = renderQuadric - (QuadricStyle (Just Smooth) GenerateTextureCoordinates Outside - FillStyle) - (Sphere 2.0 48 48) - -drawObjects :: [RenderObject] -> [RenderObject] -> Bool -> IO () -drawObjects map ent shadowRender = do - textureOn <- get (texture Texture2D) --are textures enabled? - - when shadowRender $ - texture Texture2D $= Disabled --disable textures if we render shadows. - - --draw something throwing shadows - preservingMatrix $ do - pos <- getSunPos Vector3 - translate $ fmap (+ (-15.0)) pos - drawSphere - preservingMatrix $ do - pos <- getSunPos Vector3 - translate $ fmap (+ (-10.0)) pos - drawSphere - --draw sun-indicator - {- preservingMatrix $ do - pos <- getSunPos Vector3 - translate pos - color (Color4 1.0 1.0 0.0 1.0 :: Color4 GLfloat) - drawSphere - --putStrLn $ unwords ["sun at", show pos] - -- -} - --draw map - mapM_ renderTile map - - - when (shadowRender && textureOn == Enabled) $ --reset texture-rendering - texture Texture2D $= Enabled - --- OpenGL polygon-function for drawing stuff. -display :: MVar ProgramState -> PlayMap -> IO () -display state t = - let - -- Todo: have tiles static somewhere .. dont calculate every frame - tiles = P.map (prepareRenderTile t) (A.assocs t) - in - do - ps@PS { - px = px - , py = py - , pz = pz - , pitch = pitch - , heading = heading - , showShadowMap = showShadowMap } - <- readMVar state - loadIdentity - GL.rotate pitch (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat) - GL.rotate heading (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat) - translate (Vector3 (-px) (-py) (-pz)::Vector3 GLfloat) - - generateShadowMap tiles [] - generateTextureMatrix - unless showShadowMap $ do - clear [ ColorBuffer, DepthBuffer ] - preservingMatrix $ do - drawObjects tiles [] False - - return () - -updateCamera :: MVar ProgramState -> IO () -updateCamera state = do - ps@PS { dx = dx - , dy = dy - , dz = dz - , px = px - , py = py - , pz = pz - , pitch = pitch - , heading = heading - , dpitch = dpitch - , dheading = dheading - } - <- takeMVar state - - d@((dx,dy,dz),(heading',pitch')) <- - if any (/= 0.0) [dx,dy,dz,dpitch,dheading] then - preservingMatrix $ do - -- putStrLn $ unwords $ P.map show [dx,dy,dz,dpitch,dheading] - loadIdentity - - -- in direction of current heading and pitch - rotate (-heading) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat) - rotate (-pitch) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat) - - -- perform motion - translate (Vector3 (-dx) (-dy) (-dz)) - - - -- get changes in location components - mat <- get (matrix Nothing) :: IO (GLmatrix GLfloat) - comps <- getMatrixComponents ColumnMajor mat - -- putStrLn $ show $ comps - let [dx', dy', dz', _] = drop 12 comps - (heading', pitch') = (heading + dheading, pitch + dpitch) - return ((dx',dy',dz'),(heading',pitch')) - else - return ((0,0,0),(heading, pitch)) - putMVar state ps { px = px + dx - , py = py + dy - , pz = pz + dz - , pitch = pitch' - , heading = heading' - } - --- Note: preservingViewport is not exception safe, but it doesn't matter here -preservingViewport :: IO a -> IO a -preservingViewport act = do - v <- get viewport - x <- act - viewport $= v - return x - -generateTextureMatrix :: IO () -generateTextureMatrix = do - -- Set up projective texture matrix. We use the Modelview matrix stack and - -- OpenGL matrix commands to make the matrix. - m <- preservingMatrix $ do - loadIdentity - -- resolve overloading, not needed in "real" programs - let translatef = translate :: Vector3 GLfloat -> IO () - scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO () - translatef (Vector3 0.5 0.5 0.0) - scalef 0.5 0.5 1.0 - ortho (-20) 20 (-20) 20 1 100 - lightPos' <- getSunPos Vertex3 - lookAt lightPos' origin up - get (matrix (Just (Modelview 0))) - - [ sx, sy, sz, sw, - tx, ty, tz, tw, - rx, ry, rz, rw, - qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble) - - textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw)) - textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw)) - textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw)) - textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw)) - -generateShadowMap :: [RenderObject] -> [RenderObject] -> IO () -generateShadowMap tiles obj = do - lightPos' <- getSunPos Vertex3 - let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize - shadowMapSize' = Size shadowMapWidth shadowMapHeight - - preservingViewport $ do - viewport $= (Position 0 0, shadowMapSize') - - clear [ ColorBuffer, DepthBuffer ] - - cullFace $= Just Front -- only backsides cast shadows -> less polys - - matrixMode $= Projection - preservingMatrix $ do - loadIdentity - ortho (-20) 20 (-20) 20 10 100 - matrixMode $= Modelview 0 - preservingMatrix $ do - loadIdentity - lookAt lightPos' origin up - drawObjects tiles obj True - matrixMode $= Projection - matrixMode $= Modelview 0 - - copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0 - - cullFace $= Just Back - - when True $ do - let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight) - allocaArray numShadowMapPixels $ \depthImage -> do - let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat - readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent) - (_, Size viewPortWidth _) <- get viewport - windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0) - drawPixels shadowMapSize' (pixelData Luminance) - ---Adjust size to given dimensions -reconfigure :: Int -> Int -> IO (Int, Int) -reconfigure w h = do - -- maintain aspect ratio - let aspectRatio = fromIntegral canvasWidth / fromIntegral canvasHeight - (w1, h1) = (fromIntegral w, fromIntegral w / aspectRatio) - (w2, h2) = (fromIntegral h * aspectRatio, fromIntegral h) - (w', h') = if h1 <= fromIntegral h - then (floor w1, floor h1) - else (floor w2, floor h2) - reshape $ Just (w', h') - return (w', h') - --- Called by reconfigure to fix the OpenGL viewport according to the --- dimensions of the widget, appropriately. -reshape :: Maybe (Int, Int) -> IO () -reshape dims = do - let (width, height) = fromMaybe (canvasWidth, canvasHeight) dims - viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height)) - matrixMode $= Projection - loadIdentity - let (w, h) = if width <= height - then (fromIntegral height, fromIntegral width ) - else (fromIntegral width, fromIntegral height) - -- open, aspect-ratio, near-plane, far-plane - perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 100.0 - matrixMode $= Modelview 0 - loadIdentity - -keyEvent state press = do - code <- Event.eventHardwareKeycode - val <- Event.eventKeyVal - mods <- Event.eventModifier - name <- Event.eventKeyName - liftIO $ do - ps@PS { keysPressed = kp - , dx = dx - , dy = dy - , dz = dz - , px = px - , py = py - , pz = pz - , pitch = pitch - , heading = heading - , dpitch = dpitch - , dheading = dheading - , showShadowMap = showShadowMap } - <- takeMVar state - -- Only process the key event if it is not a repeat - (ps',ret) <- if (fromIntegral code `member` kp && not press) || - (fromIntegral code `notMember` kp && press) - then let - accept a = return (a, True) - deny a = return (a, False) - in do - -- keep list of pressed keys up2date - ps <- return (if not press then - (ps{keysPressed = fromIntegral code `delete` kp}) - else - (ps{keysPressed = fromIntegral code `insert` kp})) - putStrLn $ unwords [name , show val, show code, show ps] -- trace (unwords [name , show val]) -- debugging - -- process keys - case press of - -- on PRESS only - True - | code == 9 -> Gtk.mainQuit >> deny ps - | code == 26 -> accept $ ps { dz = dz + deltaV } - | code == 40 -> accept $ ps { dz = dz - deltaV } - | code == 39 -> accept $ ps { dx = dx + deltaV } - | code == 41 -> accept $ ps { dx = dx - deltaV } - | code == 65 -> accept $ ps { dy = dy - deltaV } - | code == 66 -> accept $ ps { dy = dy + deltaV } - | code == 25 -> accept $ ps { dheading = dheading - deltaH } - | code == 27 -> accept $ ps { dheading = dheading + deltaH } - | code == 42 -> accept $ ps { showShadowMap = not showShadowMap } - | code == 31 -> dumpInfo >> accept ps - | otherwise -> deny ps - -- on RELEASE only - False - | code == 26 -> accept $ ps { dz = dz - deltaV } - | code == 40 -> accept $ ps { dz = dz + deltaV } - | code == 39 -> accept $ ps { dx = dx - deltaV } - | code == 41 -> accept $ ps { dx = dx + deltaV } - | code == 65 -> accept $ ps { dy = dy + deltaV } - | code == 66 -> accept $ ps { dy = dy - deltaV } - | code == 25 -> accept $ ps { dheading = dheading + deltaH } - | code == 27 -> accept $ ps { dheading = dheading - deltaH } - | otherwise -> deny ps - else return (ps, False) - putMVar state ps' - return ret - -main :: IO () -main = do - ! terrain <- testmap - -- create TVar using unsafePerformIO -> currently no other thread -> OK - state <- newMVar PS { keysPressed = IS.empty - , px = 7.5 - , py = 20 - , pz = 15 - , heading = 0 - , pitch = 60 - , dx = 0 - , dy = 0 - , dz = 0 - , dheading = 0 - , dpitch = 0 - , showShadowMap = False } - trace (show terrain) Gtk.initGUI - -- Initialise the Gtk+ OpenGL extension - -- (including reading various command line parameters) - GtkGL.initGL - - -- We need a OpenGL frame buffer configuration to be able to create other - -- OpenGL objects. - glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA, - GtkGL.GLModeDepth, - GtkGL.GLModeDouble] - - -- Create an OpenGL drawing area widget - canvas <- GtkGL.glDrawingAreaNew glconfig - - Gtk.widgetSetSizeRequest canvas canvasWidth canvasHeight - - -- Initialise some GL setting just before the canvas first gets shown - -- (We can't initialise these things earlier since the GL resources that - -- we are using wouldn't heve been setup yet) - Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do - reconfigure canvasWidth canvasHeight - --set up shadow-map - texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0 - (PixelData DepthComponent UnsignedByte nullPtr) - - materialAmbient Front $= Color4 0.4 0.4 0.4 1.0 - materialDiffuse Front $= Color4 0.4 0.4 0.4 1.0 - materialSpecular Front $= Color4 0.8 0.8 0.8 1.0 - materialShininess Front $= 25.0 - - ambient sun $= Color4 0.3 0.3 0.3 1.0 - diffuse sun $= Color4 1.0 1.0 1.0 1.0 - specular sun $= Color4 0.8 0.8 0.8 1.0 - lightModelAmbient $= Color4 0.2 0.2 0.2 1.0 - position sun $= (Vertex4 2.0 1.0 1.3 1.0 :: Vertex4 GLfloat) .* (1/2.5865) .* 45 - spotDirection sun $= (Normal3 (2.0) (1.0) (1.3) :: Normal3 GLfloat) - --spotExponent sun $= 1.0 - --attenuation sun $= (1.0, 0.0, 0.0) - - lighting $= Enabled - light sun $= Enabled - depthFunc $= Just Less - shadeModel $= Smooth - --lightModelLocalViewer $= Enabled - --vertexProgramTwoSide $= Enabled - - clearColor $= Color4 0.0 0.0 0.0 0.0 - drawBuffer $= BackBuffers - colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) - - frontFace $= CCW - cullFace $= Just Back - - texture Texture2D $= Enabled - - textureWrapMode Texture2D S $= (Repeated, ClampToEdge) - textureWrapMode Texture2D T $= (Repeated, ClampToEdge) - textureFilter Texture2D $= ((Linear', Nothing), Linear') - textureCompareMode Texture2D $= Just Lequal - depthTextureMode Texture2D $= Luminance' - - shadeModel $= Smooth - - fog $= Enabled - fogMode $= Linear 45.0 50.0 - fogColor $= Color4 0.5 0.5 0.5 1.0 - fogDistanceMode $= EyeRadial - - - return () - {-clearColor $= (Color4 0.0 0.0 0.0 0.0) - matrixMode $= Projection - loadIdentity - ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0 - depthFunc $= Just Less - drawBuffer $= BackBuffers-} - - -- Set the repaint handler - Gtk.onExpose canvas $ \_ -> do - GtkGL.withGLDrawingArea canvas $ \glwindow -> do - GL.clear [GL.DepthBuffer, GL.ColorBuffer] - display state terrain - GtkGL.glDrawableSwapBuffers glwindow - return True - - -- Setup the animation - Gtk.timeoutAddFull (do - updateCamera state - Gtk.widgetQueueDraw canvas - return True) - Gtk.priorityDefaultIdle animationWaitTime - - -------------------------------- - -- Setup the rest of the GUI: - -- - -- Objects - window <- Gtk.windowNew - button <- Gtk.buttonNew - exitButton <- Gtk.buttonNew - label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!") - vbox <- Gtk.vBoxNew False 4 - - --Wrench them together - - Gtk.set window [ Gtk.containerBorderWidth := 10, - Gtk.containerChild := canvas, - Gtk.windowTitle := "Pioneer" ] - - ------ - -- Events - -- - Gtk.afterClicked button (putStrLn "Hello World") - Gtk.afterClicked exitButton Gtk.mainQuit - Gtk.onDestroy window Gtk.mainQuit - - Gtk.on window Gtk.keyPressEvent $ keyEvent state True - - Gtk.on window Gtk.keyReleaseEvent $ keyEvent state False - - -- "reshape" event handler - Gtk.on canvas Gtk.configureEvent $ Event.tryEvent $ do - (w, h) <- Event.eventSize - (w', h') <- liftIO $ reconfigure w h - liftIO $ Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h'] - - Gtk.widgetShowAll window - Gtk.mainGUI - diff --git a/src/Main.glfw.deprecated.hs b/src/Main.glfw.deprecated.hs deleted file mode 100644 index 55e0915..0000000 --- a/src/Main.glfw.deprecated.hs +++ /dev/null @@ -1,665 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main (main) where - --------------------------------------------------------------------------------- - -import Control.Concurrent.STM (TQueue, atomically, - newTQueueIO, - tryReadTQueue, - writeTQueue) -import Control.Monad (unless, void, when) -import Control.Monad.RWS.Strict (RWST, ask, asks, - evalRWST, get, liftIO, - modify, put) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.Distributive (distribute, collect) -import Data.List (intercalate) -import Data.Maybe (catMaybes) -import Foreign (Ptr, castPtr, with) -import Foreign.C (CFloat) -import Linear as L -import Text.PrettyPrint - -import qualified Graphics.Rendering.OpenGL.GL as GL -import Graphics.Rendering.OpenGL.Raw.Core31 -import qualified Graphics.UI.GLFW as GLFW - -import Map.Map -import Render.Misc (checkError, - createFrustum, getCam, - lookAt, up) -import Render.Render (initRendering, - initShader) -import Control.Lens ((^.),transposeOf) -import Data.Traversable (traverse) - --------------------------------------------------------------------------------- - ---Static Read-Only-State -data Env = Env - { envEventsChan :: TQueue Event - , envWindow :: !GLFW.Window - , envZDistClosest :: !Double - , envZDistFarthest :: !Double - } - ---Mutable State -data State = State - { stateWindowWidth :: !Int - , stateWindowHeight :: !Int - --- IO - , stateXAngle :: !Double - , stateYAngle :: !Double - , stateZDist :: !Double - , stateMouseDown :: !Bool - , stateDragging :: !Bool - , stateDragStartX :: !Double - , stateDragStartY :: !Double - , stateDragStartXAngle :: !Double - , stateDragStartYAngle :: !Double - , statePositionX :: !Double - , statePositionY :: !Double - , 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 - , shdrProjMatIndex :: !GL.UniformLocation - , shdrViewMatIndex :: !GL.UniformLocation - , shdrModelMatIndex :: !GL.UniformLocation - , shdrNormalMatIndex :: !GL.UniformLocation - --- the map - , stateMap :: !GL.BufferObject - , mapVert :: !GL.NumArrayIndices - } - -type Pioneer = 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 - --------------------------------------------------------------------------------- - -main :: IO () -main = do - let width = 640 - height = 480 - - eventsChan <- newTQueueIO :: IO (TQueue Event) - - withWindow width height "Pioneers" $ \win -> do - GLFW.setErrorCallback $ Just $ errorCallback eventsChan - GLFW.setWindowPosCallback win $ Just $ windowPosCallback eventsChan - GLFW.setWindowSizeCallback win $ Just $ windowSizeCallback eventsChan - GLFW.setWindowCloseCallback win $ Just $ windowCloseCallback eventsChan - GLFW.setWindowRefreshCallback win $ Just $ windowRefreshCallback eventsChan - GLFW.setWindowFocusCallback win $ Just $ windowFocusCallback eventsChan - GLFW.setWindowIconifyCallback win $ Just $ windowIconifyCallback eventsChan - GLFW.setFramebufferSizeCallback win $ Just $ framebufferSizeCallback eventsChan - GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback eventsChan - GLFW.setCursorPosCallback win $ Just $ cursorPosCallback eventsChan - GLFW.setCursorEnterCallback win $ Just $ cursorEnterCallback eventsChan - GLFW.setScrollCallback win $ Just $ scrollCallback eventsChan - GLFW.setKeyCallback win $ Just $ keyCallback eventsChan - GLFW.setCharCallback win $ Just $ charCallback eventsChan - - GLFW.swapInterval 1 - - (fbWidth, fbHeight) <- GLFW.getFramebufferSize win - - initRendering - --generate map vertices - (mapBuffer, vert) <- getMapBufferObject - (ci, ni, vi, pri, vii, mi, nmi) <- initShader - - let zDistClosest = 10 - zDistFarthest = zDistClosest + 20 - fov = 90 --field of view - near = 1 --near plane - far = 100 --far plane - ratio = fromIntegral fbWidth / fromIntegral fbHeight - frust = createFrustum fov near far ratio - env = Env - { envEventsChan = eventsChan - , envWindow = win - , envZDistClosest = zDistClosest - , envZDistFarthest = zDistFarthest - } - state = State - { stateWindowWidth = fbWidth - , stateWindowHeight = fbHeight - , stateXAngle = pi/6 - , stateYAngle = pi/2 - , stateZDist = 10 - , statePositionX = 5 - , statePositionY = 5 - , stateMouseDown = False - , stateDragging = False - , stateDragStartX = 0 - , stateDragStartY = 0 - , stateDragStartXAngle = 0 - , stateDragStartYAngle = 0 - , shdrVertexIndex = vi - , shdrNormalIndex = ni - , shdrColorIndex = ci - , shdrProjMatIndex = pri - , shdrViewMatIndex = vii - , shdrModelMatIndex = mi - , shdrNormalMatIndex = nmi - , stateMap = mapBuffer - , mapVert = vert - , stateFrustum = frust - } - runDemo env state - - putStrLn "ended!" - --------------------------------------------------------------------------------- - --- 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 = void $ evalRWST (adjustWindow >> run) env state - -run :: Pioneer () -run = do - win <- asks envWindow - - -- draw Scene - draw - liftIO $ do - GLFW.swapBuffers win - GLFW.pollEvents - -- getEvents & process - processEvents - - -- update State - - state <- get - -- change in camera-angle - 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 - newXAngle = curb (pi/12) (0.45*pi) newXAngle' - newXAngle' = sodxa + mxrot/100 - newYAngle - | newYAngle' > pi = newYAngle' - 2 * pi - | newYAngle' < (-pi) = newYAngle' + 2 * pi - | otherwise = newYAngle' - newYAngle' = sodya + myrot/100 - put $ state - { stateXAngle = newXAngle - , stateYAngle = newYAngle - } --- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle] - else do - (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 - put $ state - { stateXAngle = stateXAngle state + (2 * jxrot) - , stateYAngle = stateYAngle state + (2 * jyrot) - } - - -- get cursor-keys - if pressed - --TODO: Add sin/cos from stateYAngle - (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win - modify $ \s -> - let - multc = cos $ stateYAngle s - mults = sin $ stateYAngle s - in - s { - statePositionX = statePositionX s - 0.2 * kxrot * multc - - 0.2 * kyrot * mults - , statePositionY = statePositionY s + 0.2 * kxrot * mults - - 0.2 * kyrot * multc - } - - {- - --modify the state with all that happened in mt time. - mt <- liftIO GLFW.getTime - modify $ \s -> s - { - } - -} - - q <- liftIO $ GLFW.windowShouldClose win - unless q run - -processEvents :: Pioneer () -processEvents = do - tc <- asks envEventsChan - me <- liftIO $ atomically $ tryReadTQueue tc - case me of - Just e -> do - processEvent e - processEvents - Nothing -> return () - -processEvent :: Event -> Pioneer () -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) - in curb (envZDistClosest env) (envZDistFarthest env) zDist' - } - adjustWindow - - (EventKey win k scancode ks mk) -> do - when (ks == GLFW.KeyState'Pressed) $ do - -- Q, Esc: exit - when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $ - liftIO $ GLFW.setWindowShouldClose win True - -- i: print GLFW information - when (k == GLFW.Key'I) $ - liftIO $ printInformation win - unless (elem k [GLFW.Key'Up - ,GLFW.Key'Down - ,GLFW.Key'Left - ,GLFW.Key'Right - ]) $ do - printEvent "key" [show k, show scancode, show ks, showModifierKeys mk] - - (EventChar _ c) -> - printEvent "char" [show c] - -adjustWindow :: Pioneer () -adjustWindow = do - state <- get - let fbWidth = stateWindowWidth state - fbHeight = stateWindowHeight state - fov = 90 --field of view - near = 1 --near plane - far = 100 --far plane - ratio = fromIntegral fbWidth / fromIntegral fbHeight - frust = createFrustum fov near far ratio - liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) - put $ state { - stateFrustum = frust - } - -draw :: Pioneer () -draw = do - env <- ask - state <- get - let xa = stateXAngle state - ya = stateYAngle state - (GL.UniformLocation proj) = shdrProjMatIndex state - (GL.UniformLocation nmat) = shdrNormalMatIndex state - (GL.UniformLocation vmat) = shdrViewMatIndex state - vi = shdrVertexIndex state - ni = shdrNormalIndex state - ci = shdrColorIndex state - numVert = mapVert state - map' = stateMap state - frust = stateFrustum state - camX = statePositionX state - camY = statePositionY state - zDist = stateZDist state - liftIO $ do - --(vi,GL.UniformLocation proj) <- initShader - GL.clear [GL.ColorBuffer, GL.DepthBuffer] - checkError "foo" - --set up projection (= copy from state) - with (distribute $ frust) $ \ptr -> - glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) - checkError "foo" - - --set up camera - let ! cam = getCam (camX,camY) zDist xa ya - with (distribute $ cam) $ \ptr -> - glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat))) - checkError "foo" - - --set up normal--Mat transpose((model*camera)^-1) - let normal = (case inv33 ((fmap (^._xyz) cam) ^. _xyz) of - (Just a) -> a - Nothing -> eye3) :: M33 CFloat - nmap = (collect (fmap id) normal) :: M33 CFloat --transpose... - - with (distribute $ nmap) $ \ptr -> - glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat))) - - checkError "nmat" - - GL.bindBuffer GL.ArrayBuffer GL.$= Just map' - GL.vertexAttribPointer ci GL.$= fgColorIndex - GL.vertexAttribArray ci GL.$= GL.Enabled - GL.vertexAttribPointer ni GL.$= fgNormalIndex - GL.vertexAttribArray ni GL.$= GL.Enabled - GL.vertexAttribPointer vi GL.$= fgVertexIndex - GL.vertexAttribArray vi GL.$= GL.Enabled - checkError "beforeDraw" - - GL.drawArrays GL.Triangles 0 numVert - checkError "draw" - -getCursorKeyDirections :: GLFW.Window -> IO (Double, Double) -getCursorKeyDirections win = do - y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up - y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down - x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left - x1 <- 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 - --------------------------------------------------------------------------------- - -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] -> Pioneer () -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 - ] diff --git a/src/Main.hs b/src/Main.hs index 259ff7f..73279e8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,17 +1,13 @@ {-# LANGUAGE BangPatterns, DoAndIfThenElse #-} module Main where -import Data.Int (Int8) -import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D) +import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D)) import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..)) -import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D) -import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (textureFilter) -import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget2D(Texture2D)) import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding) -import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..)) +import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter) -- Monad-foo and higher functional stuff -import Control.Monad (unless, void, when, join, liftM) +import Control.Monad (unless, when, join) import Control.Arrow ((***)) -- data consistency/conversion @@ -19,10 +15,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TQueue, newTQueueIO) -import Control.Monad.RWS.Strict (RWST, ask, asks, - evalRWST, get, liftIO, - modify, put) -import Control.Monad.Trans.Class +import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify) import Control.Monad.Trans.State (evalStateT) import Data.Functor ((<$>)) import Data.Distributive (distribute, collect) @@ -31,10 +24,8 @@ import Data.Monoid (mappend) -- FFI import Foreign (Ptr, castPtr, with, sizeOf) import Foreign.C (CFloat) -import Foreign.C.Types (CInt) import Foreign.Marshal.Array (pokeArray) import Foreign.Marshal.Alloc (allocaBytes) -import Data.Word (Word8) -- Math import Control.Lens ((^.), (.~), (%~)) @@ -42,8 +33,6 @@ import qualified Linear as L -- GUI import Graphics.UI.SDL as SDL ---import Graphics.UI.SDL.TTF as TTF ---import Graphics.UI.SDL.TTF.Types -- Render import qualified Graphics.Rendering.OpenGL.GL as GL @@ -54,58 +43,53 @@ import Graphics.GLUtil.BufferObjects (offset0) import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader -- Our modules import Map.Graphics -import Render.Misc (checkError, - createFrustum, getCam, - curb, tryWithTexture, +import Render.Misc (checkError, createFrustum, getCam, curb, genColorData) import Render.Render (initRendering, initMapShader, initHud) import UI.Callbacks -import UI.GUIOverlay import Types import Importer.IQM.Parser import Data.Attoparsec.Char8 (parseTest) import qualified Data.ByteString as B ---import ThirdParty.Flippers - -import qualified Debug.Trace as D (trace) +-- import qualified Debug.Trace as D (trace) -------------------------------------------------------------------------------- testParser :: IO () testParser = do - f <- B.readFile "sample.iqm" + f <- B.readFile "sample.iqm" parseTest (evalStateT parseIQM 0) f -------------------------------------------------------------------------------- main :: IO () -main = do - SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute! +main = + SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --also: InitNoParachute -> faster, without parachute! SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL ,WindowShown -- window should be visible - ,WindowResizable -- and resizable + ,WindowResizable -- and resizable ,WindowInputFocus -- focused (=> active) ,WindowMouseFocus -- Mouse into it --,WindowInputGrabbed-- never let go of input (KB/Mouse) - ] $ \window -> do - withOpenGL window $ do - + ] $ \window' -> do + withOpenGL window' $ do + --Create Renderbuffer & Framebuffer -- We will render to this buffer to copy the result into textures renderBuffer <- GL.genObjectName frameBuffer <- GL.genObjectName GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer - - (Size fbWidth fbHeight) <- glGetDrawableSize window + + (Size fbWidth fbHeight) <- glGetDrawableSize window' initRendering --generate map vertices (mapBuffer, vert) <- getMapBufferObject (mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader - print window + print window' eventQueue <- newTQueueIO :: IO (TQueue Event) putStrLn "foo" now <- getCurrentTime @@ -114,9 +98,9 @@ main = do --TTF.setFontStyle font TTFNormal --TTF.setFontHinting font TTFHNormal - glHud <- initHud - let zDistClosest = 1 - zDistFarthest = zDistClosest + 50 + glHud' <- initHud + let zDistClosest' = 1 + zDistFarthest' = zDistClosest' + 50 --TODO: Move near/far/fov to state for runtime-changability & central storage fov = 90 --field of view near = 1 --near plane @@ -129,7 +113,7 @@ main = do , _left = False , _right = False } - glMap = GLMapState + glMap' = GLMapState { _shdrVertexIndex = vi , _shdrNormalIndex = ni , _shdrColorIndex = ci @@ -147,11 +131,9 @@ main = do } env = Env { _eventsChan = eventQueue - , _windowObject = window - , _zDistClosest = zDistClosest - , _zDistFarthest = zDistFarthest - --, _renderer = renderer - --, envFont = font + , _windowObject = window' + , _zDistClosest = zDistClosest' + , _zDistFarthest = zDistFarthest' } state = State { _window = WindowState @@ -188,8 +170,8 @@ main = do { _arrowsPressed = aks } , _gl = GLState - { _glMap = glMap - , _glHud = glHud + { _glMap = glMap' + , _glHud = glHud' , _glRenderbuffer = renderBuffer , _glFramebuffer = frameBuffer } @@ -203,8 +185,8 @@ main = do putStrLn "init done." uncurry mappend <$> evalRWST (adjustWindow >> run) env state - putStrLn "shutdown complete." - + putStrLn "shutdown complete." + --SDL.glDeleteContext mainGlContext --SDL.destroyRenderer renderer --destroyWindow window @@ -214,31 +196,28 @@ main = do draw :: Pioneers () draw = do state <- get - env <- ask let xa = state ^. camera.xAngle ya = state ^. camera.yAngle - (GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex - (GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex - (GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex - (GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex - (GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex - vi = state ^. gl.glMap.shdrVertexIndex - ni = state ^. gl.glMap.shdrNormalIndex - ci = state ^. gl.glMap.shdrColorIndex - numVert = state ^. gl.glMap.mapVert - map' = state ^. gl.glMap.stateMap - frust = state ^. camera.frustum + (GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex + (GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex + (GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex + (GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex + (GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex + vi = state ^. gl.glMap.shdrVertexIndex + ni = state ^. gl.glMap.shdrNormalIndex + ci = state ^. gl.glMap.shdrColorIndex + numVert = state ^. gl.glMap.mapVert + map' = state ^. gl.glMap.stateMap + frust = state ^. camera.frustum camX = state ^. camera.camPosition._x camY = state ^. camera.camPosition._y zDist' = state ^. camera.zDist tessFac = state ^. gl.glMap.stateTessellationFactor - window = env ^. windowObject - rb = state ^. gl.glRenderbuffer when (state ^. ui . uiHasChanged) prepareGUI liftIO $ do --bind renderbuffer and set sample 0 as target --GL.bindRenderbuffer GL.Renderbuffer GL.$= rb - --GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject + --GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject --checkError "bind renderbuffer" --checkError "clear renderbuffer" @@ -251,7 +230,7 @@ draw = do -- draw map --(vi,GL.UniformLocation proj) <- initShader - + GL.bindFramebuffer GL.Framebuffer GL.$= (state ^. gl.glFramebuffer) GL.bindRenderbuffer GL.Renderbuffer GL.$= (state ^. gl.glRenderbuffer) GL.framebufferRenderbuffer @@ -260,14 +239,14 @@ draw = do GL.Renderbuffer (state ^. gl.glRenderbuffer) textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture) - + GL.framebufferTexture2D GL.Framebuffer (GL.ColorAttachment 0) GL.Texture2D (state ^. gl.glMap.mapTexture) 0 - + -- Render to FrameBufferObject GL.drawBuffers GL.$= [GL.FBOColorAttachment 0] checkError "setup Render-Target" @@ -314,7 +293,8 @@ draw = do checkError "beforeDraw" glPatchParameteri gl_PATCH_VERTICES 3 - glPolygonMode gl_FRONT gl_LINE + + GL.cullFace GL.$= Just GL.Front glDrawArrays gl_PATCHES 0 (fromIntegral numVert) checkError "draw map" @@ -345,11 +325,11 @@ draw = do GL.activeTexture GL.$= GL.TextureUnit 1 textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture) GL.uniform (hud ^. hudBackIndex) GL.$= GL.Index1 (1::GL.GLint) - + GL.bindBuffer GL.ArrayBuffer GL.$= Just (hud ^. hudVBO) GL.vertexAttribPointer (hud ^. hudVertexIndex) GL.$= (GL.ToFloat, vad) GL.vertexAttribArray (hud ^. hudVertexIndex) GL.$= GL.Enabled - + GL.bindBuffer GL.ElementArrayBuffer GL.$= Just (hud ^. hudEBO) GL.drawElements GL.TriangleStrip 4 GL.UnsignedInt offset0 @@ -393,14 +373,14 @@ run = do | newYAngle' < (-pi) = newYAngle' + 2 * pi | otherwise = newYAngle' newYAngle' = sodya + myrot/100 - + modify $ ((camera.xAngle) .~ newXAngle) . ((camera.yAngle) .~ newYAngle) -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement - let + let multc = cos $ state ^. camera.yAngle mults = sin $ state ^. camera.yAngle modx x' = x' - 0.2 * kxrot * multc @@ -419,23 +399,24 @@ run = do -} mt <- liftIO $ do + let double = fromRational.toRational :: (Real a) => a -> Double now <- getCurrentTime diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs - title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"] + title <- return $ unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"] setWindowTitle (env ^. windowObject) title sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds threadDelay sleepAmount return now -- set state with new clock-time modify $ io.clock .~ mt - shouldClose <- return $ state ^. window.shouldClose - unless shouldClose run + shouldClose' <- return $ state ^. window.shouldClose + unless shouldClose' run getArrowMovement :: Pioneers (Int, Int) getArrowMovement = do state <- get - aks <- return $ state ^. (keyboard.arrowsPressed) - let + aks <- return $ state ^. (keyboard.arrowsPressed) + let horz = left' + right' vert = up'+down' left' = if aks ^. left then -1 else 0 @@ -447,7 +428,6 @@ getArrowMovement = do adjustWindow :: Pioneers () adjustWindow = do state <- get - env <- ask let fbWidth = state ^. window.width fbHeight = state ^. window.height fov = 90 --field of view @@ -466,7 +446,7 @@ adjustWindow = do renderBuffer <- GL.genObjectName GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer GL.renderbufferStorage - GL.Renderbuffer -- use the only available renderbuffer + GL.Renderbuffer -- use the only available renderbuffer -- - must be this constant. GL.DepthComponent' -- 32-bit float-rgba-color (GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer @@ -521,7 +501,7 @@ processEvent e = do _ -> return () --liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e] - Keyboard movement _ isRepeated key -> --up/down window(ignored) true/false actualKey + Keyboard movement _ _{-isRepeated-} key -> --up/down window(ignored) true/false actualKey -- need modifiers? use "keyModifiers key" to get them let aks = keyboard.arrowsPressed in case keyScancode key of @@ -551,7 +531,7 @@ processEvent e = do liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor] _ -> return () - MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do + MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do state <- get when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $ modify $ (mouse.isDragging .~ True) @@ -559,10 +539,10 @@ processEvent e = do . (mouse.dragStartY .~ (fromIntegral y)) . (mouse.dragStartXAngle .~ (state ^. camera.xAngle)) . (mouse.dragStartYAngle .~ (state ^. camera.yAngle)) - + modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x)) . (mouse.mousePosition. Types._y .~ (fromIntegral y)) - MouseButton _ mouseId button state (SDL.Position x y) -> + MouseButton _ _{-mouseId-} button state (SDL.Position x y) -> case button of LeftButton -> do let pressed = state == Pressed @@ -577,10 +557,9 @@ processEvent e = do when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y) _ -> return () - MouseWheel _ mouseId hscroll vscroll -> do - env <- ask + MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do state <- get - let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in + let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist') Quit -> modify $ window.shouldClose .~ True -- there is more (joystic, touchInterface, ...), but currently ignored diff --git a/src/PioneerTypes.hs b/src/PioneerTypes.hs index 06027d7..1e28802 100644 --- a/src/PioneerTypes.hs +++ b/src/PioneerTypes.hs @@ -1,4 +1,4 @@ -module PioneerTypes +module PioneerTypes where data Structure = Flag -- Flag @@ -36,7 +36,7 @@ data Structure = Flag -- Flag deriving (Show, Eq) data Amount = Infinite -- Neverending supply - | Finite Int -- Finite supply + | Finite Int -- Finite supply -- Extremely preliminary, expand when needed data Commodity = WoodPlank @@ -54,9 +54,9 @@ data Resource = Coal instance Show Amount where show (Infinite) = "inexhaustable supply" - show (Finite n) = (show n) ++ " left" + show (Finite n) = show n ++ " left" instance Show Commodity where show WoodPlank = "wooden plank" - show Sword = "sword" + show Sword = "sword" show Fish = "fish" diff --git a/src/Render/Misc.hs b/src/Render/Misc.hs index 4a2e705..1c6f092 100644 --- a/src/Render/Misc.hs +++ b/src/Render/Misc.hs @@ -8,7 +8,6 @@ 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 Graphics.UI.SDL.Types (Texture) import System.IO (hPutStrLn, stderr) import Linear @@ -62,7 +61,7 @@ createProgramUsing shaders = do createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat createFrustum fov n' f' rat = - let + let f = realToFrac f' n = realToFrac n' s = realToFrac $ recip (tan $ fov*0.5 * pi / 180) @@ -78,7 +77,7 @@ createFrustum fov n' f' rat = -- from vmath.h lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat -lookAt eye@(V3 ex ey ez) center up = +lookAt eye center up' = V4 (V4 xx xy xz (-dot x eye)) (V4 yx yy yz (-dot y eye)) @@ -86,7 +85,7 @@ lookAt eye@(V3 ex ey ez) center up = (V4 0 0 0 1) where z@(V3 zx zy zz) = normalize (eye ^-^ center) - x@(V3 xx xy xz) = normalize (cross up z) + x@(V3 xx xy xz) = normalize (cross up' z) y@(V3 yx yy yz) = normalize (cross z x) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index d45a9c4..fa2e67c 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -2,8 +2,6 @@ module Render.Render where import qualified Data.ByteString as B -import Data.Array.Storable -import qualified Data.Vector.Storable as V import Foreign.Marshal.Array (withArray) import Foreign.Storable import Graphics.Rendering.OpenGL.GL.BufferObjects @@ -14,13 +12,10 @@ import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.StateVar import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..), - vertexAttribArray, - VertexArrayDescriptor, - DataType(Float)) + vertexAttribArray) import Graphics.Rendering.OpenGL.GL.VertexSpec import Graphics.Rendering.OpenGL.Raw.Core31 import Render.Misc -import Foreign.Ptr (Ptr, wordPtrToPtr) import Types import Graphics.GLUtil.BufferObjects (makeBuffer) @@ -169,7 +164,7 @@ initHud = do , _hudEBO = ebo , _hudProgram = program } - + diff --git a/src/Types.hs b/src/Types.hs index d5d262b..d7c1196 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -3,7 +3,7 @@ module Types where import Control.Concurrent.STM (TQueue) import qualified Graphics.Rendering.OpenGL.GL as GL -import Graphics.UI.SDL as SDL (Event, Window, Texture, Renderer) +import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) import Data.Time (UTCTime) import Linear.Matrix (M44)