shaders/map/fragment.shader

@@ -96,8 +96,8 @@ float snoise(vec3 v)
 
 float fog(float dist) {
     dist = max(0,dist - 50);
-    dist = dist * 0.005;
+    dist = dist * 0.05;
-    dist = dist*dist;
+//    dist = dist*dist;
     return 1-exp(-dist);
 }
 

shaders/mapobjects/vertex.shader

@@ -6,8 +6,7 @@ layout(location=2) in vec2 TexCoord;
 uniform mat4 ProjectionMatrix;
 uniform mat4 ViewMatrix;
 uniform mat3 NormalMatrix;
-uniform vec3 PositionOffset = vec3(5.0,2.0,5.0);
+uniform vec3 PositionOffset = vec3(5,2,5);
-uniform vec3 Scale = vec3(1.0,1.0,1.0);
 uniform float TessLevelInner = 1.0; // controlled by keyboard buttons
 uniform float TessLevelOuter = 1.0; // controlled by keyboard buttons
 
@@ -17,7 +16,6 @@ out vec3 vNormal;
 void main () {
    vPosition = Position;
    //gl_Position = vec4(Position,1);
-   //                                                                   component-wise
+   gl_Position = ProjectionMatrix * ViewMatrix * vec4(PositionOffset + Position, 1);
-   gl_Position = ProjectionMatrix * ViewMatrix * vec4(PositionOffset + (Scale * Position), 1);
    vNormal = Normal;
 }

src/Icons/GUIQuad.hs

@@ -1,40 +0,0 @@
-module Icons.GUIQuad (GUIQuad(..), Icon(..), marshalIcon) where
-
-import Data.Word (Word8)
-
-type Coord = (Float, Float)
-type ZIndex = Float
-
-data GUIQuad = GUIQuad Coord Coord ZIndex Icon
-
-data Icon = 
-          Woodcutter
-        | Stonemason
---
-        | CloseButton
-        | NextButton
-        | PreviousButton
-
-numIcons :: Int
-numIcons = 32
-
-sizeIcon :: Float
-sizeIcon = 1.0/(fromIntegral numIcons)
-
-iconToTex :: Icon -> Coord
-iconToTex i =
-    (x,y)
-    where
-        x = (fromIntegral (num `mod` numIcons)) * sizeIcon
-        y = (fromIntegral (num `div` numIcons)) * sizeIcon
-        num = fromIntegral.marshalIcon $ i
-
-
-marshalIcon :: Icon -> Word8
-marshalIcon a = case a of
-    Woodcutter     -> 0
-    Stonemason     -> 1
---
-    CloseButton    -> 32
-    NextButton     -> 33
-    PreviousButton -> 34

src/Main.hs

@@ -117,7 +117,7 @@ main = do
         let camStack' = Map.empty
         glHud' <- initHud
         let zDistClosest'  = 2
-            zDistFarthest' = zDistClosest' + 100
+            zDistFarthest' = zDistClosest' + 10
             --TODO: Move near/far/fov to state for runtime-changability & central storage
             aks = ArrowKeyState {
                   _up       = False
@@ -190,13 +190,12 @@ run = do
         cam <- readTVar (state ^. camera)
         game' <- readTVar (state ^. game)
         let
-            scrollFactor = 1
             multc = cos $ cam ^. yAngle
             mults = sin $ cam ^. yAngle
-            modx x' = x' - kxrot * multc * scrollFactor
+            modx x' = x' - 0.2 * kxrot * multc
-                         - kyrot * mults * scrollFactor
+                         - 0.2 * kyrot * mults
-            mody y' = y' + kxrot * mults * scrollFactor
+            mody y' = y' + 0.2 * kxrot * mults
-                         - kyrot * multc * scrollFactor
+                         - 0.2 * kyrot * multc
         cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam
         writeTVar (state ^. camera) cam'
 
@@ -233,7 +232,7 @@ run = do
         now' <- getCurrentTime
         return (now',tessChange,sleepAmount,ddiff,hasChanged)
     -- set state with new clock-time
-    --liftIO $ putStrLn $ unwords ["clockFactor:",show (state ^. io.tessClockFactor),"\ttc:", show (tc (state ^. gl.glMap.stateTessellationFactor)),"\tframe took ",show frameTime,"ms"]
+    --liftIO $ putStrLn $ unwords ["clockFactor:",show (state ^. io.tessClockFactor),"\ttc:", show (tc (state ^. gl.glMap.stateTessellationFactor)),"\tsleep ",show frameTime,"ms"]
     if hC then
         do
             liftIO $ putStrLn $ unwords ["modifying TessFactor to",show $ tc $ state ^. gl.glMap.stateTessellationFactor]
@@ -274,7 +273,7 @@ adjustWindow = do
         fbHeight = state ^. window.height
         fov           = 90  --field of view
         near          = 1   --near plane
-        far           = 500 --far plane
+        far           = 100 --far plane
         ratio         = fromIntegral fbWidth / fromIntegral fbHeight
         frust         = createFrustum fov near far ratio
     liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)

src/Map/Graphics.hs

@@ -7,8 +7,7 @@ fgColorIndex,
 fgNormalIndex,
 fgVertexIndex,
 mapStride,
-getMapBufferObject,
+getMapBufferObject
-unitLength
 )
 where
 
@@ -40,10 +39,6 @@ type MapEntry = (
                 )
 type GraphicsMap = Array (Int, Int) MapEntry
 
--- | length of 1 Unit in World-Coordinates
-unitLength :: Double
-unitLength = 10.0
-
 -- converts from classical x/z to striped version of a map
 convertToStripeMap :: PlayMap -> PlayMap
 convertToStripeMap mp = array (stripify l, stripify u) (map (stripify *** strp) (assocs mp))
@@ -210,8 +205,6 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
 coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
 coordLookup (x,z) y =
                 if even x then
-                        (f unitLength) *^ V3 (fromIntegral $ x `div` 2) y (fromIntegral (2 * z) * lineHeight)
+                        V3 (fromIntegral $ x `div` 2) y (fromIntegral (2 * z) * lineHeight)
                 else
-                        (f unitLength) *^ V3 (fromIntegral (x `div` 2) + 0.5) y (fromIntegral (2 * z + 1) * lineHeight)
+                        V3 (fromIntegral (x `div` 2) + 0.5) y (fromIntegral (2 * z + 1) * lineHeight)
-                        where
-                            f = fromRational.toRational

src/Map/Map.hs

@@ -1,7 +1,6 @@
 module Map.Map where
 
 import Map.Types
-import Map.Graphics (unitLength)
 
 import Data.Array    (bounds, (!))
 import Data.List     (sort, group)
@@ -45,23 +44,21 @@ giveMapHeight :: PlayMap
              -> (Double, Double)
              -> Double
 giveMapHeight mop (x, z)
-  | outsideMap (x/unitLength,z'/unitLength) = 0.0
+  | outsideMap (x,z') = 0.0
-  | otherwise         = height' --sum $ map (\(p,d) -> hlu p * (d / totald)) tups
+  | otherwise         = height --sum $ map (\(p,d) -> hlu p * (d / totald)) tups
   where
     z' = z * 2/ sqrt 3
-    rx = (x/unitLength)  - (fromIntegral $ floor (x/unitLength ))
+    rx = x  - (fromIntegral $ floor (x +0.5))
-    rz = (z'/unitLength) - (fromIntegral $ floor (z'/unitLength))
+    rz = z' - (fromIntegral $ floor (z'+0.5))
 
-    hoi = map (hlu . clmp . tadd (floor (x/unitLength), floor (z'/unitLength))) mods
+    hoi = map (hlu . clmp . tadd (floor x, floor z')) mods
       where
         mods = [(0,0),(0,1),(1,0),(1,1)]
         tadd (a,b) (c,d) = (a+c,b+d)
 
-    height' = height*unitLength
-
     height = --trace (show [rx,rz] ++ show hoi)
-             (1-rz) * ((1-rx) * (hoi !! 0) + rx * (hoi !! 2))
+             rz     * (rx * (hoi !! 0) + (1-rx) * (hoi !! 2))
-           + rz     * ((1-rx) * (hoi !! 1) + rx * (hoi !! 3))
+           + (1-rz) * (rx * (hoi !! 1) + (1-rx) * (hoi !! 3))
 
     outsideMap :: (Double, Double) -> Bool
     outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop

src/Render/Misc.hs

@@ -68,14 +68,13 @@ createProgramUsing shaders = do
 createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat
 createFrustum fov n' f' rat =
                 let
-                    ff = fromRational.toRational
+                    f = realToFrac f'
-                    f = ff f'
+                    n = realToFrac n'
-                    n = ff n'
+                    s = realToFrac $ recip (tan $ fov*0.5 * pi / 180)
-                    s = ff $ recip (tan $ fov*0.5 * pi / 180)
                     (ratw,rath) = if rat > 1 then
-                                        (1,1/ff rat)
+                                        (1,1/realToFrac rat)
                                   else
-                                        (ff rat,1)
+                                        (realToFrac rat,1)
                 in
                     V4 (V4 (s/ratw)     0            0                   0)
                        (V4    0     (s/rath)         0                   0)

src/Render/Render.hs

@@ -9,9 +9,9 @@ import           Graphics.Rendering.OpenGL.Raw.Core31
 import           Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
 import           Graphics.GLUtil.BufferObjects
 import qualified Linear as L
-import           Control.Lens                               ((^.),(%~))
+import           Control.Lens                               ((^.))
 import           Control.Monad.RWS.Strict             (liftIO)
-import qualified Control.Monad.RWS.Strict as RWS      (get,modify)
+import qualified Control.Monad.RWS.Strict as RWS      (get)
 import           Control.Concurrent.STM               (readTVarIO)
 import           Data.Distributive                    (distribute, collect)
 -- FFI
@@ -166,12 +166,6 @@ initMapShader tessFac (buf, vertDes) = do
    normalMatrixIndex' <- get (uniformLocation objProgram "NormalMatrix")
    checkError "normalMat"
 
-   positionOffsetIndex' <- get (uniformLocation objProgram "PositionOffset")
-   checkError "PositionOffset"
-
-   scaleIndex' <- get (uniformLocation objProgram "Scale")
-   checkError "Scale"
-
    --tessLevelInner' <- get (uniformLocation objProgram "TessLevelInner")
    --checkError "TessLevelInner"
 
@@ -188,10 +182,7 @@ initMapShader tessFac (buf, vertDes) = do
    putStrLn $ unlines $ ["Model-Indices: ", show (texIndex', normalIndex', vertexIndex')]
    
    testobj <- parseIQM "models/holzfaellerHaus1.iqm"
-   cube    <- parseIQM "models/box.iqm"
+   let objs = [MapObject testobj (L.V3 0 10 0) (MapObjectState ())]
-   let objs = [ MapObject testobj (L.V3 20 10 20) (MapObjectState ())
-              , MapObject cube (L.V3 25 5 25) (MapObjectState ())
-              ]
 
    currentProgram $= Nothing
 
@@ -217,8 +208,6 @@ initMapShader tessFac (buf, vertDes) = do
             , shdrMOViewMatIndex   = viewMatrixIndex'
             , shdrMOModelMatIndex  = modelMatrixIndex'
             , shdrMONormalMatIndex = normalMatrixIndex'
-            , shdrMOPositionOffsetIndex = positionOffsetIndex'
-            , shdrMOScaleIndex          = scaleIndex'
             , shdrMOTessInnerIndex = UniformLocation 0 --tessLevelInner'
             , shdrMOTessOuterIndex = UniformLocation 0 --tessLevelOuter'
             }
@@ -296,18 +285,10 @@ initRendering = do
 
 
 -- | renders an IQM-Model at Position with scaling
-renderIQM :: IQM -> L.V3 CFloat -> L.V3 CFloat -> Pioneers ()
+renderIQM :: IQM -> L.V3 CFloat -> L.V3 CFloat -> IO ()
-renderIQM m (L.V3 x y z) (L.V3 sx sy sz) = do
+renderIQM m p@(L.V3 x y z) s@(L.V3 sx sy sz) = do
-    state <- RWS.get
-    let
-        dmo      = state ^. gl.glMap.mapObjectShaderData
-        po       = shdrMOPositionOffsetIndex dmo
-        so       = shdrMOScaleIndex dmo
-    liftIO $ do
     withVAO (vertexArrayObject m) $ do
         withVAA [(AttribLocation 0),(AttribLocation 1)] $ do
-                uniform po $= Vertex3 x y z
-                uniform so $= Vertex3 sx sy sz
             checkError "setting array to enabled"
             bindBuffer ElementArrayBuffer $= Just (triangleBufferObject m)
             checkError "bindBuffer"
@@ -319,8 +300,8 @@ renderIQM m (L.V3 x y z) (L.V3 sx sy sz) = do
             checkError "unbind buffer"
     return ()
 
-renderObject :: MapObject -> Pioneers ()
+renderObject :: MapObject -> IO ()
-renderObject (MapObject model pos _{-state-}) =
+renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) =
     renderIQM model pos (L.V3 1 1 1)
 
 drawMap :: Pioneers ()
@@ -362,7 +343,6 @@ drawMap = do
                 (ColorAttachment 1)          --sample 1
                 Renderbuffer                 --const
                 rb                              --buffer-}
-
 mat44ToGPU :: L.M44 CFloat -> UniformLocation -> String -> IO ()
 mat44ToGPU mat (UniformLocation dest) name = do
         with (distribute mat) $ \ptr ->
@@ -406,14 +386,6 @@ render = do
                                          (Just a) -> a
                                          Nothing  -> L.eye3) :: L.M33 CFloat
         nmap = collect id normal' :: L.M33 CFloat --transpose...
-        camTarget = getCamTarget camPos
-        
-        moveTo :: L.V3 CFloat -> MapObject -> MapObject
-        moveTo p (MapObject o _ s) = MapObject o p s
-
-    -- TODO: remove hack for Target
-    RWS.modify $ gl.glMap.mapObjects %~ (\objs ->
-            head objs : [moveTo camTarget $ objs !! 1])
 
     liftIO $ do
 
@@ -528,7 +500,6 @@ render = do
         mat33ToGPU nmap nmatmo "mapObjects-nmat"
 
         mapM_ renderObject (state ^. gl.glMap.mapObjects)
-    liftIO $ do
         checkError "draw mapobjects"
 
         ---- COMPOSE RENDERING --------------------------------------------

src/Render/Types.hs

@@ -24,8 +24,6 @@ class GLCamera a where
   moveBy :: a -> (Position -> Position) -> PlayMap -> a
   -- | Moves the Camera-Target to an absoloute position
   move   :: a -> Position -> PlayMap -> a
-  -- | Gets the target point of a camera
-  getCamTarget :: a -> V3 CFloat
 
 -- | Alias for a camera-position onto the 2d-plane it moves on
 type Position = (Double, Double)
@@ -90,14 +88,6 @@ instance GLCamera Camera where
 					(x,z) = f (x', z')
 					y     = giveMapHeight map (x,z)
   move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
-  getCamTarget (Flat (x',z') y') =
-        V3 x y z
-        where 
-            x = realToFrac x'
-            y = realToFrac y'
-            z = realToFrac z'
-  getCamTarget (Sphere (inc', az') r') =
-        undefined
 
 -- | converting spherical to cartesian coordinates
 sphereToCart :: (Floating a) => a -> a -> a -> V3 a

src/Types.hs

@@ -9,7 +9,7 @@ import qualified Data.HashMap.Strict                  as Map
 import           Data.Time                            (UTCTime)
 import Linear.Matrix (M44)
 import Linear (V3)
-import Control.Monad.RWS.Strict (RWST, get)
+import Control.Monad.RWS.Strict (RWST, liftIO, get)
 import Control.Monad.Writer.Strict
 --import Control.Monad (when)
 import Control.Lens
@@ -131,8 +131,6 @@ data MapObjectShaderData = MapObjectShaderData
     , shdrMOViewMatIndex   :: !GL.UniformLocation
     , shdrMOModelMatIndex  :: !GL.UniformLocation
     , shdrMONormalMatIndex :: !GL.UniformLocation
-    , shdrMOPositionOffsetIndex :: !GL.UniformLocation
-    , shdrMOScaleIndex          :: !GL.UniformLocation
     , shdrMOTessInnerIndex :: !GL.UniformLocation
     , shdrMOTessOuterIndex :: !GL.UniformLocation
     }

src/UI/Callbacks.hs

@@ -123,7 +123,7 @@ eventCallback e = do
                 state <- get
                 liftIO $ atomically $ do
                     cam <- readTVar (state ^. camera)
-                    let zDist' = (cam ^. zDist) + 4*realToFrac (negate vscroll)
+                    let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
                         zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
                     cam' <- return $ zDist .~ zDist'' $ cam
                     writeTVar (state ^. camera) cam'