Merge branch 'master' into iqm

Conflicts:
	src/Render/Types.hs

src/Main.hs

@@ -12,8 +12,8 @@ import           Control.Arrow                        ((***))
 
 -- data consistency/conversion
 import           Control.Concurrent                   (threadDelay)
-import           Control.Concurrent.STM               (TQueue,
+import           Control.Concurrent.STM               (TQueue, newTQueueIO, atomically)
-                                                       newTQueueIO)
+import           Control.Concurrent.STM.TVar          (newTVarIO, writeTVar, readTVar)
 
 import           Control.Monad.RWS.Strict             (ask, evalRWST, get, liftIO, modify)
 import           Data.Functor                         ((<$>))
@@ -94,16 +94,26 @@ main =
         --font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
         --TTF.setFontStyle font TTFNormal
         --TTF.setFontHinting font TTFHNormal
-
+        let
-        glHud' <- initHud
-        let zDistClosest'  = 2
-            zDistFarthest' = zDistClosest' + 10
-            --TODO: Move near/far/fov to state for runtime-changability & central storage
             fov           = 90  --field of view
             near          = 1   --near plane
             far           = 500 --far plane
             ratio         = fromIntegral fbWidth / fromIntegral fbHeight
             frust         = createFrustum fov near far ratio
+        cam' <- newTVarIO CameraState
+                        { _xAngle              = pi/6
+                        , _yAngle              = pi/2
+                        , _zDist               = 10
+                        , _frustum             = frust
+                        , _camObject           = createFlatCam 25 25 curMap
+                        }
+        game' <- newTVarIO GameState
+                        { _currentMap          = curMap
+                        }
+        glHud' <- initHud
+        let zDistClosest'  = 2
+            zDistFarthest' = zDistClosest' + 10
+            --TODO: Move near/far/fov to state for runtime-changability & central storage
             (guiMap, guiRoots) = createGUI
             aks = ArrowKeyState {
                   _up       = False
@@ -123,17 +133,11 @@ main =
                         , _height              = fbHeight
                         , _shouldClose         = False
                         }
-              , _camera              = CameraState
-                        { _xAngle              = pi/6
-                        , _yAngle              = pi/2
-                        , _zDist               = 10
-                        , _frustum             = frust
-                        , _camObject           = createFlatCam 25 25 curMap
-                        }
               , _io                  = IOState
                         { _clock               = now
                         , _tessClockFactor     = 0
                         }
+              , _camera              = cam'
               , _mouse               = MouseState
                         { _isDown              = False
                         , _isDragging          = False
@@ -155,9 +159,7 @@ main =
                         , _glRenderbuffer      = renderBuffer
                         , _glFramebuffer       = frameBuffer
                         }
-              , _game                = GameState
+              , _game                = game'
-                        { _currentMap          = curMap
-                        }
               , _ui                  = UIState
                         { _uiHasChanged        = True
                         , _uiMap = guiMap
@@ -207,20 +209,26 @@ run = do
                   | otherwise          = newYAngle'
               newYAngle' = sodya + myrot/100
 
-          modify $ ((camera.xAngle) .~ newXAngle)
+          liftIO $ atomically $ do
-                 . ((camera.yAngle) .~ newYAngle)
+              cam <- readTVar (state ^. camera)
+              cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
+              writeTVar (state ^. camera) cam'
 
     -- get cursor-keys - if pressed
     --TODO: Add sin/cos from stateYAngle
     (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
-    let
+    liftIO $ atomically $ do
-        multc = cos $ state ^. camera.yAngle
+        cam <- readTVar (state ^. camera)
-        mults = sin $ state ^. camera.yAngle
+        game' <- readTVar (state ^. game)
-        modx x' = x' - 0.2 * kxrot * multc
+        let
-                     - 0.2 * kyrot * mults
+            multc = cos $ cam ^. yAngle
-        mody y' = y' + 0.2 * kxrot * mults
+            mults = sin $ cam ^. yAngle
-                     - 0.2 * kyrot * multc
+            modx x' = x' - 0.2 * kxrot * multc
-    modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (state ^. game.currentMap))
+                         - 0.2 * kyrot * mults
+            mody y' = y' + 0.2 * kxrot * mults
+                         - 0.2 * kyrot * multc
+        cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam
+        writeTVar (state ^. camera) cam'
 
     {-
     --modify the state with all that happened in mt time.
@@ -290,7 +298,10 @@ adjustWindow = do
         ratio         = fromIntegral fbWidth / fromIntegral fbHeight
         frust         = createFrustum fov near far ratio
     liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
-    modify $ camera.frustum .~ frust
+    liftIO $ atomically $ do
+        cam <- readTVar (state ^. camera)
+        cam' <- return $ frustum .~ frust $ cam
+        writeTVar (state ^. camera) cam'
     rb <- liftIO $ do
                    -- bind ints to CInt for lateron.
                    let fbCWidth  = (fromInteger.toInteger) fbWidth

src/Map/Creation.hs

@@ -2,21 +2,10 @@ module Map.Creation
 where
 
 import Map.Types
--- import Map.Map unused (for now)
 
 import Data.Array
 import System.Random
 
--- preliminary
-infix 5 ->-
-(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
-f ->- g = g . f
-
--- also preliminary
-infix 5 -<-
-(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
-f -<- g = f . g
-
 -- entirely empty map, only uses the minimal constructor
 mapEmpty :: PlayMap
 mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]]
@@ -57,17 +46,6 @@ gauss3Dgeneral :: Floating q =>
                   -> q -- ^ elevation on coordinate in question
 gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int)))))
 
--- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15
-gauss3D :: Floating q =>
-           q     -- ^ X-Coordinate
-           -> q  -- ^ Z-Coordinate
-           -> q  -- ^ elevation on coordinate in quesion
-gauss3D = gauss3Dgeneral 15 100.0 100.0 15.0 15.0
-
--- 2D Manhattan distance
-mnh2D :: (Int,Int) -> (Int,Int) -> Int
-mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
-
 -- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome
 --   (like Deserts on Grass-Islands or Grass on Deserts)
 --
@@ -75,9 +53,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
 heightToTerrain :: MapType -> YCoord -> TileType
 heightToTerrain GrassIslandMap y
                 | y < 0.1   = Ocean
-                | y < 0.2     = Beach
+                | y < 0.2   = Beach
-                | y < 1     = Grass
+                | y < 1.5   = Grass
-                | y < 3    = Hill
+                | y < 3     = Hill
                 | otherwise = Mountain
 heightToTerrain _ _ = undefined
 
@@ -98,8 +76,8 @@ gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
   where
     gs  = map mkStdGen (map (*seed) [1..])
     c   = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
-    amp = head $ randomRs ((2.0, 5.0) :: (Float, Float)) (gs !! 2)
+    amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
-    sig = head $ randomRs ((1.0, 15.0) :: (Float, Float)) (gs !! 3)
+    sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
     htt = heightToTerrain
 
     -- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map

src/Map/Graphics.hs

@@ -30,9 +30,8 @@ import Linear
 import Control.Arrow         ((***))
 
 import Map.Types
-import Map.Creation
 
-type Height = Float
+type Height = Double
 
 type MapEntry = (
                 Height,

src/Map/Map.hs

@@ -1,11 +1,9 @@
 module Map.Map where
 
 import Map.Types
-import Map.Creation
 
-import Data.Function (on)
 import Data.Array    (bounds, (!))
-import Data.List     (sort, sortBy, group)
+import Data.List     (sort, group)
 
 -- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
 unsafeGiveNeighbours :: (Int, Int)  -- ^ original coordinates
@@ -40,54 +38,54 @@ giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
 
 -- | Calculates the height of any given point on the map.
 -- Does not add camera distance to ground to that.
--- 
--- This ueses barycentric coordinate stuff. Wanna read more?
--- http://en.wikipedia.org/wiki/Barycentric_coordinate_system_%28mathematics%29
--- http://www.alecjacobson.com/weblog/?p=1596
---
 giveMapHeight :: PlayMap
-              -> (Float, Float)  -- ^ Coordinates on X/Z-axes 
+             -> (Double, Double)
-              -> Float           -- ^ Terrain Height at that position
+             -> Double
-giveMapHeight mp (x,z) = let [a,b,c] = getTrianglePoints [tff,tfc,tcf,tcc]
+giveMapHeight mop (x, z)
-                             ar = area (fi a) (fi b) (fi c)
+  | outsideMap (x,z') = 0.0
-                             λa = area (fi b) (fi c) (x, z) / ar
+  | otherwise         = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups
-                             λb = area (fi a) (fi c) (x, z) / ar
-                             λc = area (fi a) (fi b) (x, z) / ar
-                         in  (λa * hlu a) + (λb * hlu b) + (λc * hlu c)
   where
+    z' = z * 2/(sqrt 3)
 
-    fi :: (Int, Int) -> (Float, Float)
+    outsideMap :: (Double, Double) -> Bool
-    fi (m, n) = (fromIntegral m, fromIntegral n)
+    outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
+                              fr = fromIntegral
+                          in  mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d)
 
-    -- Height LookUp
+    -- Height LookUp on PlayMap
-    hlu :: (Int, Int) -> Float
+    hlu :: (Int, Int) -> Double
-    hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mp ! (k,j) in y
+    hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
 
-    ff  = (floor   x, floor   z) :: (Int, Int)
+    -- reference Points
-    fc  = (floor   x, ceiling z) :: (Int, Int)
+    refs :: [(Int, Int)]
-    cf  = (ceiling x, floor   z) :: (Int, Int)
+    refs = remdups $ map clmp $ map (tadd (floor x, floor z')) mods
-    cc  = (ceiling x, ceiling z) :: (Int, Int)
+      where
+        mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)]
+        tadd (a,b) (c,d) = (a+b,c+d)
 
-    tff = (ff, dist (x,z) ff)
+    -- tupels with reference point and distance
-    tfc = (fc, dist (x,z) fc)
+    tups = map (\t -> (t, dist (x,z') t)) refs
-    tcf = (cf, dist (x,z) cf)
-    tcc = (cc, dist (x,z) cc)
 
-    getTrianglePoints :: [((Int,Int), Float)] -> [(Int,Int)]
+    -- total distance of all for reference point from the point in question
-    getTrianglePoints = ((take 3) . (map fst) . (sortBy (compare `on` snd)))
+    totald = sum $ map (\(_,d) -> d) tups
 
-    dist :: (Float, Float) -> (Int, Int) -> Float
+    -- clamp, as she is programmed
-    dist (x1,z1) (x2,z2) = let x' = x1 - fromIntegral x2
+    clamp :: (Ord a) => a -> a -> a -> a
-                               z' = z1 - fromIntegral z2
+    clamp mn mx = max mn . min mx
-                           in  sqrt $ x'*x' + z'*z'
 
-    -- Heron's Formula: http://en.wikipedia.org/wiki/Heron%27s_formula
+    -- clamp for tupels
-    area :: (Float, Float) -> (Float, Float) -> (Float, Float) -> Float
+    clmp :: (Int, Int) -> (Int, Int)
-    area (x1,z1) (x2,z2) (x3,z3) = let a = sqrt $ (x1-x2)*(x1-x2) + (z1-z2)*(z1-z2)
+    clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop
-                                       b = sqrt $ (x2-x3)*(x2-x3) + (z2-z3)*(z2-z3)
+                 in  ((clamp (xmin+2) (xmax-2) a),(clamp (zmin+2) (zmax-2) b))
-                                       c = sqrt $ (x1-x3)*(x1-x3) + (z1-z3)*(z1-z3)
+
-                                       s = (a+b+c)/2 
+    -- Real distance on PlayMap
-                                   in  sqrt $ s * (s-a) * (s-b) * (s-c)
+    dist :: (Double, Double) -> (Int, Int) -> Double
+    dist (x1,z1) pmp = let xf = x1 - realx 
+                           zf = z1 - realz
+                       in  sqrt $ xf*xf + zf*zf
+      where
+        realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
+        realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
 
 -- removing duplicates in O(n log n), losing order and adding Ord requirement
 remdups :: Ord a => [a] -> [a]

src/Map/Types.hs

@@ -7,9 +7,9 @@ type PlayMap = Array (Xindex, Zindex) Node
 
 type Xindex  = Int
 type Zindex  = Int
-type XCoord  = Float
+type XCoord  = Double
-type ZCoord  = Float
+type ZCoord  = Double
-type YCoord  = Float
+type YCoord  = Double
 
 data MapType    = GrassIslandMap
                 | DesertMap

src/Render/Render.hs

@@ -12,6 +12,8 @@ import qualified Linear as L
 import           Control.Lens                               ((^.))
 import           Control.Monad.RWS.Strict             (liftIO)
 import qualified Control.Monad.RWS.Strict as RWS      (get)
+import           Control.Concurrent.STM.TVar          (readTVarIO)
+import           Control.Concurrent.STM               (atomically)
 import           Data.Distributive                    (distribute, collect)
 -- FFI
 import           Foreign                              (Ptr, castPtr, with)
@@ -384,11 +386,12 @@ drawMap = do
 render :: Pioneers ()
 render = do
     state <- RWS.get
-    let xa       = state ^. camera.xAngle
+    cam <- liftIO $ readTVarIO (state ^. camera)
-        ya       = state ^. camera.yAngle
+    let xa       = cam ^. xAngle
-        frust    = state ^. camera.Types.frustum
+        ya       = cam ^. yAngle
-        camPos   = state ^. camera.camObject
+        frust    = cam ^. Types.frustum
-        zDist'   = state ^. camera.zDist
+        camPos   = cam ^. camObject
+        zDist'   = cam ^. zDist
         d        = state ^. gl.glMap.mapShaderData
         (UniformLocation proj)  = shdrProjMatIndex d
         (UniformLocation nmat)  = shdrNormalMatIndex d

src/Render/Types.hs

@@ -29,7 +29,7 @@ data Camera = Flat Position Height
 
 -- | create a Flatcam-Camera starting at given x/z-Coordinates
 createFlatCam :: Double -> Double -> PlayMap -> Camera
-createFlatCam x z map' = Flat (x,z) (float2Double $ giveMapHeight map' (double2Float x,double2Float z))
+createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
 
 -- | create a Flatcam-Camera starting at given pitch/azimuth/radius
 createSphereCam :: Double -> Double -> Double -> Camera
@@ -40,7 +40,7 @@ instance GLCamera Camera where
   getCam (Flat (x',z') y') dist' xa' ya' =
         lookAt (cpos ^+^ at') at' up
                      where
-                        at'   = V3 x (y+1) z
+                        at'   = V3 x (y+2) z
                         cpos  = crot !* (V3 0 0 (-dist))
                         crot  = (
                                 (fromQuaternion $ axisAngle upmap (xa::CFloat))
@@ -76,11 +76,10 @@ instance GLCamera Camera where
                         xa    = realToFrac xa'
                         ya    = realToFrac ya'
   moveBy (Sphere (inc, az) r) f map = undefined
-  moveBy (Flat (x', z') y) f map = Flat (x,z) (float2Double y)
+  moveBy (Flat (x', z') y) f map = Flat (x,z) y
 				where
 					(x,z) = f (x', z')
-					y = giveMapHeight map (fc x,fc z)
+					y     = giveMapHeight map (x,z)
-					fc = double2Float
   move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
 
 sphereToCart :: (Floating a) => a -> a -> a -> V3 a

src/Types.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Types where
 
-import           Control.Concurrent.STM               (TQueue)
+import           Control.Concurrent.STM               (TQueue, TVar)
 import qualified Graphics.Rendering.OpenGL.GL         as GL
 import           Graphics.UI.SDL                      as SDL (Event, Window)
 import           Foreign.C                            (CFloat)
@@ -161,12 +161,12 @@ data UIState = UIState
 
 data State = State
     { _window              :: !WindowState
-    , _camera              :: !CameraState
+    , _camera              :: TVar CameraState
     , _io                  :: !IOState
     , _mouse               :: !MouseState
     , _keyboard            :: !KeyboardState
     , _gl                  :: !GLState
-    , _game                :: !GameState
+    , _game                :: TVar GameState
     , _ui                  :: !UIState
     }
 

src/UI/Callbacks.hs

@@ -13,6 +13,8 @@ import           Data.Maybe
 import           Foreign.Marshal.Array                (pokeArray)
 import           Foreign.Marshal.Alloc                (allocaBytes)
 import qualified Graphics.UI.SDL                      as SDL
+import           Control.Concurrent.STM.TVar          (readTVar, readTVarIO, writeTVar)
+import           Control.Concurrent.STM               (atomically)
 
 
 import Render.Misc                                    (curb,genColorData)
@@ -105,11 +107,13 @@ eventCallback e = do
                 state <- get
                 if state ^. mouse.isDown && not (state ^. mouse.isDragging)
                   then
+                    do
+                    cam <- liftIO $ readTVarIO (state ^. camera)
                     modify $ (mouse.isDragging .~ True)
                            . (mouse.dragStartX .~ fromIntegral x)
                            . (mouse.dragStartY .~ fromIntegral y)
-                           . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
+                           . (mouse.dragStartXAngle .~ (cam ^. xAngle))
-                           . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
+                           . (mouse.dragStartYAngle .~ (cam ^. yAngle))
                     else mouseMoveHandler (x, y)
                 modify $ (mouse.mousePosition. Types._x .~ fromIntegral x)
                        . (mouse.mousePosition. Types._y .~ fromIntegral y)
@@ -134,8 +138,13 @@ eventCallback e = do
             SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
                 do
                 state <- get
-                let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
+                liftIO $ atomically $ do
-                  modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
+                    cam <- readTVar (state ^. camera)
+                    let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
+                        zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
+                    cam' <- return $ zDist .~ zDist'' $ cam
+                    writeTVar (state ^. camera) cam'
+                  
             -- there is more (joystic, touchInterface, ...), but currently ignored
             SDL.Quit -> modify $ window.shouldClose .~ True
             _ ->  liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
@@ -340,4 +349,4 @@ copyGUI tex (vX, vY) widget = do
                         mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
 
 --TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
---TODO: Maybe queues are better?
+--TODO: Maybe queues are better?