From aa6a5c060fdad190acba114a6fea4b8dd544b7ec Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sat, 17 May 2014 23:19:34 +0200 Subject: [PATCH 1/3] added some helper-functions for handling gamestate --- src/Types.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index cbdba50..7a27ed9 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Types where -import Control.Concurrent.STM (TQueue, TVar) +import Control.Concurrent.STM (TQueue, TVar, readTVar, writeTVar, atomically) import qualified Graphics.Rendering.OpenGL.GL as GL import Graphics.UI.SDL as SDL (Event, Window) import Foreign.C (CFloat) @@ -9,7 +9,8 @@ import qualified Data.HashMap.Strict as Map import Data.Time (UTCTime) import Linear.Matrix (M44) import Linear (V3) -import Control.Monad.RWS.Strict (RWST) +import Control.Monad.RWS.Strict (RWST, liftIO, get) +import Control.Monad (when) import Control.Lens import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject) import Render.Types @@ -188,3 +189,18 @@ $(makeLenses ''Position) $(makeLenses ''Env) $(makeLenses ''UIState) +-- helper-functions for types + +-- | atomically change gamestate on condition +changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers () +changeIfGamestate cond f = do + state <- get + liftIO $ atomically $ do + game' <- readTVar (state ^. game) + when (cond game') (writeTVar (state ^. game) (f game')) + + +-- | atomically change gamestate +changeGamestate :: (GameState -> GameState) -> Pioneers () +changeGamestate = changeIfGamestate (const True) + From ef549eac4de4118075bf9db30091b86da66da374 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sun, 18 May 2014 00:14:19 +0200 Subject: [PATCH 2/3] fixed haddock for UI --- src/UI/UIBase.hs | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/UI/UIBase.hs b/src/UI/UIBase.hs index b2409e2..9ca3cc5 100644 --- a/src/UI/UIBase.hs +++ b/src/UI/UIBase.hs @@ -122,19 +122,19 @@ data EventHandler m = -- A widget becomes mouse-active if no other button is currently pressed and the mouse -- coordinates are within the widget's extent ('isInside') until no button is pressed any -- more. - _onMousePress :: MouseButton -- ^the pressed button - -> Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the possibly altered mouse handler + _onMousePress :: MouseButton -- the pressed button + -> Pixel -- screen position + -> GUIWidget m -- widget the event is invoked on + -> m (GUIWidget m) -- widget after the event and the possibly altered mouse handler , -- |The function 'onMouseReleased' is called when a button is released -- while the widget is mouse-active. -- -- Thus, the mouse is either within the widget or outside while still dragging. - _onMouseRelease :: MouseButton -- ^the released button - -> Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler + _onMouseRelease :: MouseButton -- the released button + -> Pixel -- screen position + -> GUIWidget m -- widget the event is invoked on + -> m (GUIWidget m) -- widget after the event and the altered handler } | -- |Handler to control the functionality of a 'GUIWidget' on mouse movement. @@ -144,22 +144,22 @@ data EventHandler m = -- widget's extent ('isInside') while no button is pressed or when the mouse is inside the -- widget's extent while another button loses its mouse-active state. Triggered after -- '_onMouseEnter'. - _onMouseMove :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler + _onMouseMove :: Pixel -- screen position + -> GUIWidget m -- widget the event is invoked on + -> m (GUIWidget m) -- widget after the event and the altered handler , -- |The function 'onMouseMove' is invoked when the mouse enters the -- widget's extent ('isInside') or when the mouse is inside the -- widget's extent while another button loses its mouse-active state.. - _onMouseEnter :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler + _onMouseEnter :: Pixel -- screen position + -> GUIWidget m -- widget the event is invoked on + -> m (GUIWidget m) -- widget after the event and the altered handler , -- |The function 'onMouseLeave' is invoked when the mouse leaves the -- widget's extent ('isInside') while no other widget is mouse-active. - _onMouseLeave :: Pixel -- ^screen position - -> GUIWidget m -- ^widget the event is invoked on - -> m (GUIWidget m) -- ^widget after the event and the altered handler + _onMouseLeave :: Pixel -- screen position + -> GUIWidget m -- widget the event is invoked on + -> m (GUIWidget m) -- widget after the event and the altered handler } deriving () @@ -196,7 +196,7 @@ data GUIBaseProperties m = BaseProperties -- The default implementations tests if the point is within the rectangle specified by the -- 'getBoundary' function. _isInside :: GUIWidget m - -> Pixel -- ^local coordinates + -> Pixel -- local coordinates -> m Bool , -- |The @_getPriority@ function returns the priority score of a @GUIWidget@. From f6e52d732c2dce1ecd86a9e14c224b8041eaed8c Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Sun, 18 May 2014 07:30:19 +0200 Subject: [PATCH 3/3] haddock & small fix - some haddock in renderer - small fix in gamestate-handling function --- src/Render/Render.hs | 2 +- src/Render/Types.hs | 28 ++++++++++++++++++---------- src/Types.hs | 11 ++++++++--- 3 files changed, 27 insertions(+), 14 deletions(-) diff --git a/src/Render/Render.hs b/src/Render/Render.hs index 59fe4ed..0cd5464 100644 --- a/src/Render/Render.hs +++ b/src/Render/Render.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, InstanceSigs, ExistentialQuantification #-} -module Render.Render where +module Render.Render (initBuffer, initMapShader, initBuffer, initHud, initRendering, render) where import qualified Data.ByteString as B import Foreign.Marshal.Array (withArray) diff --git a/src/Render/Types.hs b/src/Render/Types.hs index 5191322..db778df 100644 --- a/src/Render/Types.hs +++ b/src/Render/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes #-} +-- | Types specific to Rendering-Issues module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where import Linear @@ -12,18 +13,22 @@ import qualified Debug.Trace as D type Distance = Double type Pitch = Double type Yaw = Double - -class GLCamera a where - getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat - moveBy :: a -> (Position -> Position) -> PlayMap -> a - move :: a -> Position -> PlayMap -> a - -type Position = (Double, Double) - type Radius = Double - type Height = Double +-- | a Typclass for different Cameras +class GLCamera a where + -- | Gets the current Camera-Matrix for a given Cam, Distance Pitch and Yaw + getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat + -- | Moves the Camera-Target on a projected 2D-plane + moveBy :: a -> (Position -> Position) -> PlayMap -> a + -- | Moves the Camera-Target to an absoloute position + move :: a -> Position -> PlayMap -> a + +-- | Alias for a camera-position onto the 2d-plane it moves on +type Position = (Double, Double) + +-- | Camera-Type. Either a Camera onto a 2D-flat-map or a spherical map data Camera = Flat Position Height | Sphere Position Radius @@ -35,7 +40,9 @@ createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z)) createSphereCam :: Double -> Double -> Double -> Camera createSphereCam p a = Sphere (p,a) - +-- | our Camera is indeed a GLCamera that we can use +-- +-- TODO: Sphere-Cam still undefined instance GLCamera Camera where getCam (Flat (x',z') y') dist' xa' ya' = lookAt (cpos ^+^ at') at' up @@ -82,6 +89,7 @@ instance GLCamera Camera where y = giveMapHeight map (x,z) move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map +-- | converting spherical to cartesian coordinates sphereToCart :: (Floating a) => a -> a -> a -> V3 a sphereToCart r inc az = V3 (r * (sin inc) * (cos az)) diff --git a/src/Types.hs b/src/Types.hs index 7a27ed9..dae0916 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -192,15 +192,20 @@ $(makeLenses ''UIState) -- helper-functions for types -- | atomically change gamestate on condition -changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers () +changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers Bool changeIfGamestate cond f = do state <- get liftIO $ atomically $ do game' <- readTVar (state ^. game) - when (cond game') (writeTVar (state ^. game) (f game')) + let cond' = cond game' + when cond' (writeTVar (state ^. game) (f game')) + return cond' -- | atomically change gamestate changeGamestate :: (GameState -> GameState) -> Pioneers () -changeGamestate = changeIfGamestate (const True) +changeGamestate = do + --forget implied result - is True anyway + _ <- changeIfGamestate (const True) + return ()