Merge with master

Pioneers.cabal

@@ -1,6 +1,6 @@
 name:           Pioneers
 version:        0.1
-cabal-version:  >=1.2
+cabal-version:  >= 1.16
 build-type:     Simple
 author:         sdressel
 
@@ -16,6 +16,9 @@ executable Pioneers
                    Map.Graphics,
                    Map.Creation,
                    Map.StaticMaps,
+                   IQM.Types,
+                   IQM.TestMain,
+                   IQM.Parser,
                    Render.Misc,
                    Render.Render,
                    Render.RenderObject,
@@ -32,14 +35,16 @@ executable Pioneers
                    text >=0.11,
                    array >=0.4,
                    random >=1.0.1,
-                   transformers >=0.3.0 && <0.4,
+                   transformers >=0.3.0,
                    mtl >=2.1.2,
                    stm >=2.4.2,
                    vector >=0.10.9 && <0.11,
-                   distributive >=0.3.2 && <0.4,
+                   distributive >=0.3.2,
-                   linear >=1.3.1 && <1.4,
+                   linear >=1.3.1, 
-                   lens >=3.10.1 && <3.11,
+                   lens >=4.0,
                    SDL2 >= 0.1.0,
-                   time >=1.4.0 && <1.5,
+                   time >=1.4.0,
-                   GLUtil >= 0.7
+                   GLUtil >= 0.7,
+                   attoparsec >= 0.11.2
+  Default-Language: Haskell2010
 

src/Importer/IQM/Parser.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Importer.IQM.Parser where
+
+import Importer.IQM.Types
+import Data.Attoparsec.ByteString.Char8
+import Data.Attoparsec.ByteString
+import Data.ByteString.Char8 (pack)
+import Data.ByteString (split, null)
+import Data.Word
+import Data.Int
+import Unsafe.Coerce
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+import Control.Monad
+
+import Prelude as P hiding (take, null)
+
+w8ToInt :: Integral a => a -> a -> a
+w8ToInt i add = 256*i + add
+
+parseNum :: (Integral a, Integral b) => [a] -> b
+parseNum = (foldl1 w8ToInt) . map fromIntegral
+
+int16 :: CParser Int16
+int16 = do
+        ret <- lift $ do
+                         a <- anyWord8 :: Parser Word8
+                         b <- anyWord8 :: Parser Word8
+                         return $ parseNum [b,a]
+        modify (+2)
+        return ret
+                  
+int32 :: CParser Int32
+int32 = do
+        ret <- lift $ do
+                         a <- anyWord8 :: Parser Word8
+                         b <- anyWord8 :: Parser Word8
+                         c <- anyWord8 :: Parser Word8
+                         d <- anyWord8 :: Parser Word8
+                         return $ parseNum [d,c,b,a]
+        modify (+4)
+        return $ ret
+
+readHeader :: CParser IQMHeader
+readHeader = do
+         _ <- lift $ string (pack "INTERQUAKEMODEL\0")
+         v <- int32
+         -- when v /= 2 then --TODO: error something 
+         size' <- int32
+         flags' <- int32
+         num_text' <- int32
+         ofs_text' <- int32         
+         num_meshes' <- int32
+         ofs_meshes' <- int32         
+         num_vertexarrays' <- int32
+         num_vertexes' <- int32         
+         ofs_vertexarrays' <- int32
+         num_triangles' <- int32         
+         ofs_triangles' <- int32
+         ofs_adjacency' <- int32         
+         num_joints' <- int32
+         ofs_joints' <- int32         
+         num_poses' <- int32
+         ofs_poses' <- int32         
+         num_anims' <- int32
+         ofs_anims' <- int32         
+         num_frames' <- int32
+         num_framechannels' <- int32         
+         ofs_frames' <- int32
+         ofs_bounds' <- int32         
+         num_comment' <- int32
+         ofs_comment' <- int32         
+         num_extensions' <- int32
+         ofs_extensions' <- int32
+         return IQMHeader { version = v
+                , filesize           = size'
+                , flags              = flags'
+                , num_text           = num_text'
+                , ofs_text           = ofs_text'
+                , num_meshes         = num_meshes'
+                , ofs_meshes         = ofs_meshes'
+                , num_vertexarrays   = num_vertexarrays'
+                , num_vertexes       = num_vertexes'
+                , ofs_vertexarrays   = ofs_vertexarrays'
+                , num_triangles      = num_triangles'
+                , ofs_triangles      = ofs_triangles'
+                , ofs_adjacency      = ofs_adjacency'
+                , num_joints         = num_joints'
+                , ofs_joints         = ofs_joints'
+                , num_poses          = num_poses'
+                , ofs_poses          = ofs_poses'
+                , num_anims          = num_anims'
+                , ofs_anims          = ofs_anims'
+                , num_frames         = num_frames'
+                , num_framechannels  = num_framechannels'
+                , ofs_frames         = ofs_frames'
+                , ofs_bounds         = ofs_bounds'
+                , num_comment        = num_comment'
+                , ofs_comment        = ofs_comment'
+                , num_extensions     = num_extensions'
+                , ofs_extensions     = ofs_extensions'
+                }
+
+readMesh :: CParser IQMMesh
+readMesh = do
+        name <- int32
+        mat <- int32
+        fv <- int32
+        nv <- int32
+        ft <- int32
+        nt <- int32
+        return IQMMesh
+                { meshName              = if name == 0 then Nothing else Just (Mesh name)
+                , meshMaterial          = mat
+                , meshFirstVertex       = fv
+                , meshNumVertexes       = nv
+                , meshFirstTriangle     = ft
+                , meshNumTriangles      = nt
+                }
+
+readMeshes :: Int -> CParser [IQMMesh]
+readMeshes 1 = do
+        m <- readMesh
+        return [m]
+readMeshes n = do
+        m <- readMesh
+        ms <- readMeshes (n-1)
+        return $ m:ms
+
+(.-) :: forall a a1 a2.
+              (Num a, Integral a2, Integral a1) =>
+              a1 -> a2 -> a
+(.-) a b = (fromIntegral a) - (fromIntegral b)
+
+infix 5 .-
+
+skipToCounter :: Integral a => a -> CParser ()
+skipToCounter a = do
+                        let d = fromIntegral a
+			c <- get
+                        when (d < c) $ fail "wanting to skip to counter already passed"
+			_ <- lift $ take $ d .- c
+			put d
+
+parseIQM :: CParser IQM
+parseIQM = do
+        put 0 							--start at offset 0
+        h <- readHeader						--read header
+        skipToCounter $ ofs_text h				--skip 0-n bytes to get to text
+        text <- lift . take . fromIntegral $ num_text h         --read texts
+	modify . (+) . fromIntegral $ num_text h                --put offset forward
+        skipToCounter $ ofs_meshes h                            --skip 0-n bytes to get to meshes
+        meshes' <- readMeshes (fromIntegral (num_meshes h))     --read meshes
+        return IQM
+                { header = h
+                , texts = filter (not.null) (split (unsafeCoerce '\0') text)
+                , meshes = meshes'
+                }
+                

src/Importer/IQM/Types.hs

@@ -0,0 +1,62 @@
+module Importer.IQM.Types where
+
+import Data.Int
+import Data.ByteString
+import Data.Attoparsec.ByteString.Char8
+import Control.Monad.Trans.State.Lazy (StateT)
+
+newtype Mesh = Mesh Int32 deriving (Show, Eq)
+type CParser a = StateT Int64 Parser a
+
+-- Int32 or Int64 - depending on implementation. Format just specifies "uint".
+-- 4-Byte indicates Int32
+
+-- | ofs_* fields are relative tot he beginning of the iqmheader struct
+--   ofs_* fields are set to 0 when data is empty
+--   ofs_* fields are aligned at 4-byte-boundaries
+data IQMHeader = IQMHeader
+                { version            :: Int32 -- ^ Must be 2
+                , filesize           :: Int32
+                , flags              :: Int32
+                , num_text           :: Int32
+                , ofs_text           :: Int32
+                , num_meshes         :: Int32
+                , ofs_meshes         :: Int32
+                , num_vertexarrays   :: Int32
+                , num_vertexes       :: Int32
+                , ofs_vertexarrays   :: Int32
+                , num_triangles      :: Int32
+                , ofs_triangles      :: Int32
+                , ofs_adjacency      :: Int32
+                , num_joints         :: Int32
+                , ofs_joints         :: Int32
+                , num_poses          :: Int32
+                , ofs_poses          :: Int32
+                , num_anims          :: Int32
+                , ofs_anims          :: Int32
+                , num_frames         :: Int32
+                , num_framechannels  :: Int32
+                , ofs_frames         :: Int32
+                , ofs_bounds         :: Int32
+                , num_comment        :: Int32
+                , ofs_comment        :: Int32
+                , num_extensions     :: Int32 -- ^ stored as linked list, not as array.
+                , ofs_extensions     :: Int32
+                } deriving (Show, Eq)
+ 
+ 
+data IQMMesh = IQMMesh
+                { meshName              :: Maybe Mesh
+                , meshMaterial          :: Int32
+                , meshFirstVertex       :: Int32
+                , meshNumVertexes       :: Int32
+                , meshFirstTriangle     :: Int32
+                , meshNumTriangles      :: Int32
+                } deriving (Show, Eq)
+                
+data IQM = IQM
+        { header                :: IQMHeader
+        , texts                 :: [ByteString]
+        , meshes                :: [IQMMesh]
+        } deriving (Show, Eq)
+        

src/Main.deprecated.hs

@@ -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
-

src/Main.glfw.deprecated.hs

@@ -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
-  ]

src/Main.hs

@@ -1,20 +1,13 @@
 {-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
 module Main where
 
-import Data.Int (Int8)
+import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
-import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D)
 import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
-import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D)
-import Control.Monad (liftM)
-import Foreign.Marshal.Array (pokeArray)
-import Foreign.Marshal.Alloc (allocaBytes)
-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)
+import           Control.Monad                        (unless, when, join)
 import           Control.Arrow                        ((***))
 
 -- data consistency/conversion
@@ -22,25 +15,24 @@ import           Control.Concurrent                   (threadDelay)
 import           Control.Concurrent.STM               (TQueue,
                                                        newTQueueIO)
 
-import           Control.Monad.RWS.Strict             (RWST, ask, asks,
+import           Control.Monad.RWS.Strict             (ask, evalRWST, get, liftIO, modify)
-                                                       evalRWST, get, liftIO,
+import           Control.Monad.Trans.State            (evalStateT)
-                                                       modify, put)
+import           Data.Functor                         ((<$>))
 import           Data.Distributive                    (distribute, collect)
+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           Data.Word                            (Word8)
+import           Foreign.Marshal.Alloc                (allocaBytes)
 
 -- Math
 import           Control.Lens                         ((^.), (.~), (%~))
-import           Linear                               as L
+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
@@ -51,42 +43,39 @@ import           Graphics.GLUtil.BufferObjects        (offset0)
 import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
 -- Our modules
 import           Map.Graphics
-import           Render.Misc                          (checkError,
+import           Render.Misc                          (checkError, createFrustum, getCam, curb,
-                                                       createFrustum, getCam,
-                                                       curb, tryWithTexture,
                                                        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"
+        parseTest (evalStateT parseIQM 0) f
+
+--------------------------------------------------------------------------------
+
 main :: IO ()
-main = do
+main =
-        SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute!
+    SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --also: InitNoParachute -> faster, without parachute!
-{-        (window, renderer) <- SDL.createWindowAndRenderer (Size 1024 600) [WindowOpengl     -- we want openGL
-                                                                             ,WindowShown      -- window should be visible
-                                                                             ,WindowResizable  -- and resizable 
-                                                                             ,WindowInputFocus -- focused (=> active)
-                                                                             ,WindowMouseFocus -- Mouse into it
-                                                                             --,WindowInputGrabbed-- never let go of input (KB/Mouse)
-                                                                             ] -}
       SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl     -- we want openGL
                                                                              ,WindowShown      -- window should be visible
                                                                              ,WindowResizable  -- and resizable
                                                                              ,WindowInputFocus -- focused (=> active)
                                                                              ,WindowMouseFocus -- Mouse into it
                                                                              --,WindowInputGrabbed-- never let go of input (KB/Mouse)
-                                                                             ] $ \window -> do
+                                                                             ] $ \window' -> do
-        --mainGlContext <- SDL.glCreateContext window 
+       withOpenGL window' $ do
-        withOpenGL window $ do
-        --TTF.withInit $ do
 
         --Create Renderbuffer & Framebuffer
         -- We will render to this buffer to copy the result into textures
@@ -95,12 +84,12 @@ main = do
         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
-        putStrLn $ show window
+        print window'
         eventQueue <- newTQueueIO :: IO (TQueue Event)
         putStrLn "foo"
         now <- getCurrentTime
@@ -109,9 +98,9 @@ main = do
         --TTF.setFontStyle font TTFNormal
         --TTF.setFontHinting font TTFHNormal
 
-        glHud <- initHud
+        glHud' <- initHud
-        let zDistClosest  = 1
+        let zDistClosest'  = 1
-            zDistFarthest = zDistClosest + 50
+            zDistFarthest' = zDistClosest' + 50
             --TODO: Move near/far/fov to state for runtime-changability & central storage
             fov           = 90  --field of view
             near          = 1   --near plane
@@ -124,7 +113,7 @@ main = do
                 , _left     = False
                 , _right    = False
             }
-            glMap = GLMapState
+            glMap' = GLMapState
                 { _shdrVertexIndex      = vi
                 , _shdrNormalIndex      = ni
                 , _shdrColorIndex       = ci
@@ -142,11 +131,9 @@ main = do
                 }
             env = Env
               { _eventsChan      = eventQueue
-              , _windowObject    = window
+              , _windowObject    = window'
-              , _zDistClosest    = zDistClosest
+              , _zDistClosest    = zDistClosest'
-              , _zDistFarthest   = zDistFarthest
+              , _zDistFarthest   = zDistFarthest'
-              --, _renderer        = renderer 
-              --, envFont          = font
               }
             state = State
               { _window              = WindowState
@@ -160,8 +147,8 @@ main = do
                         , _zDist               = 10
                         , _frustum             = frust
                         , _camPosition         = Types.Position
-                                       { Types._x    = 25
+                                       { Types.__x    = 25
-                                       , Types._y    = 25
+                                       , Types.__y    = 25
                                        }
                         }
               , _io                  = IOState
@@ -175,16 +162,16 @@ main = do
                         , _dragStartXAngle     = 0
                         , _dragStartYAngle     = 0
                         , _mousePosition       = Types.Position
-                                         { Types._x  = 5
+                                         { Types.__x  = 5
-                                         , Types._y  = 5
+                                         , Types.__y  = 5
                                          }
                         }
               , _keyboard            = KeyboardState
                         { _arrowsPressed       = aks
                         }
               , _gl                  = GLState
-                        { _glMap               = glMap
+                        { _glMap               = glMap'
-                        , _glHud               = glHud
+                        , _glHud               = glHud'
                         , _glRenderbuffer      = renderBuffer
                         , _glFramebuffer       = frameBuffer
                         }
@@ -197,7 +184,8 @@ main = do
               }
 
         putStrLn "init done."
-        void $ evalRWST (adjustWindow >> run) env state
+        uncurry mappend <$> evalRWST (adjustWindow >> run) env state
+        putStrLn "shutdown complete."
 
         --SDL.glDeleteContext mainGlContext
         --SDL.destroyRenderer renderer
@@ -208,7 +196,6 @@ 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
@@ -222,16 +209,11 @@ draw = do
         numVert  = state ^. gl.glMap.mapVert
         map'     = state ^. gl.glMap.stateMap
         frust    = state ^. camera.frustum
-        camX     = state ^. camera.camPosition.x
+        camX     = state ^. camera.camPosition._x
-        camY     = state ^. camera.camPosition.y
+        camY     = state ^. camera.camPosition._y
         zDist'   = state ^. camera.zDist
         tessFac  = state ^. gl.glMap.stateTessellationFactor
-        window   = env ^. windowObject
+    when (state ^. ui . uiHasChanged) prepareGUI
-        rb       = state ^. gl.glRenderbuffer
-    if state ^. ui.uiHasChanged then
-        prepareGUI
-    else
-        return ()
     liftIO $ do
         --bind renderbuffer and set sample 0 as target
         --GL.bindRenderbuffer GL.Renderbuffer GL.$= rb
@@ -278,23 +260,23 @@ draw = do
         checkError "setting up buffer"
         --set up projection (= copy from state)
         with (distribute frust) $ \ptr ->
-              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+              glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
         checkError "copy projection"
 
         --set up camera
         let ! cam = getCam (camX,camY) zDist' xa ya
         with (distribute cam) $ \ptr ->
-              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
+              glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
         checkError "copy cam"
 
         --set up normal--Mat transpose((model*camera)^-1)
-        let normal = (case inv33 (fmap (^. _xyz) cam ^. _xyz) of
+        let normal = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
                                              (Just a) -> a
-                                             Nothing  -> eye3) :: M33 CFloat
+                                             Nothing  -> L.eye3) :: L.M33 CFloat
-            nmap = collect id normal :: M33 CFloat --transpose...
+            nmap = collect id normal :: L.M33 CFloat --transpose...
 
         with (distribute nmap) $ \ptr ->
-              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat)))
+              glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))
 
         checkError "nmat"
 
@@ -311,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"
@@ -379,8 +362,8 @@ run = do
               sody  = state ^. mouse.dragStartY
               sodxa = state ^. mouse.dragStartXAngle
               sodya = state ^. mouse.dragStartYAngle
-              x'    = state ^. mouse.mousePosition.x
+              x'    = state ^. mouse.mousePosition._x
-              y'    = state ^. mouse.mousePosition.y
+              y'    = state ^. mouse.mousePosition._y
               myrot = (x' - sodx) / 2
               mxrot = (y' - sody) / 2
               newXAngle  = curb (pi/12) (0.45*pi) newXAngle'
@@ -404,8 +387,8 @@ run = do
                      - 0.2 * kyrot * mults
         mody y' = y' + 0.2 * kxrot * mults
                      - 0.2 * kyrot * multc
-    modify $ (camera.camPosition.x %~ modx)
+    modify $ (camera.camPosition._x %~ modx)
-           . (camera.camPosition.y %~ mody)
+           . (camera.camPosition._y %~ mody)
 
     {-
     --modify the state with all that happened in mt time.
@@ -416,17 +399,18 @@ 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
+    shouldClose' <- return $ state ^. window.shouldClose
-    unless shouldClose run
+    unless shouldClose' run
 
 getArrowMovement :: Pioneers (Int, Int)
 getArrowMovement = do
@@ -444,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
@@ -510,15 +493,15 @@ processEvent e = do
                     Closing ->
                             modify $ window.shouldClose .~ True
                     Resized {windowResizedTo=size} -> do
-                            modify $ (window.width  .~ (sizeWidth  size))
+                            modify $ (window . width .~ sizeWidth size)
-                                   . (window.height .~ (sizeHeight size))
+                                   . (window . height .~ sizeHeight size)
                             adjustWindow
                     SizeChanged ->
                             adjustWindow
                     _ ->
                         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
@@ -548,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)
@@ -557,9 +540,9 @@ processEvent e = do
                            . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
                            . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
 
-                modify $ (mouse.mousePosition. Types.x .~ (fromIntegral x))
+                modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
-                       . (mouse.mousePosition. Types.y .~ (fromIntegral y))
+                       . (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
@@ -574,8 +557,7 @@ processEvent e = do
                         when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
                     _ ->
                         return ()
-            MouseWheel _ mouseId hscroll vscroll -> do
+            MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do
-                env <- ask
                 state <- get
                 let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
                   modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')

src/Map/Graphics.hs

@@ -12,6 +12,10 @@ getMapBufferObject
 where
 
 import Data.Array.IArray
+<<<<<<< HEAD
+=======
+import Data.Text as T
+>>>>>>> master
 import Prelude as P
 
 --import Graphics.Rendering.OpenGL.GL
@@ -31,8 +35,12 @@ import Linear
 import Map.Types
 import Map.StaticMaps
 
+<<<<<<< HEAD
 type MapEntry = ( Float,     -- Height
                   TileType )
+=======
+type Height = Float
+
 
 type GraphicsMap = Array (Int, Int) MapEntry
 

src/PioneerTypes.hs

@@ -54,7 +54,7 @@ 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"

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
@@ -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)
 
 

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,
+                                                             vertexAttribArray)
-                                                             VertexArrayDescriptor,
-                                                             DataType(Float))
 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)
@@ -53,18 +48,20 @@ initBuffer varray =
            return bufferObject
 
 initMapShader :: IO (
-                      Program           -- ^ the GLSL-Program
+                      Program           -- the GLSL-Program
-                      , AttribLocation  -- ^ color
+                      , AttribLocation  -- color
-                      , AttribLocation  -- ^ normal
+                      , AttribLocation  -- normal
-                      , AttribLocation  -- ^ vertex
+                      , AttribLocation  -- vertex
-                      , UniformLocation -- ^ ProjectionMat
+                      , UniformLocation -- ProjectionMat
-                      , UniformLocation -- ^ ViewMat
+                      , UniformLocation -- ViewMat
-                      , UniformLocation -- ^ ModelMat
+                      , UniformLocation -- ModelMat
-                      , UniformLocation -- ^ NormalMat
+                      , UniformLocation -- NormalMat
-                      , UniformLocation -- ^ TessLevelInner
+                      , UniformLocation -- TessLevelInner
-                      , UniformLocation -- ^ TessLevelOuter
+                      , UniformLocation -- TessLevelOuter
-                      , TextureObject   -- ^ Texture where to draw into
+                      , TextureObject   -- Texture where to draw into
-                      )
+                      ) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat,
+                        --    ModelMat, NormalMat, TessLevelInner, TessLevelOuter,
+                        --    Texture where to draw into)
 initMapShader = do
    ! vertexSource <- B.readFile mapVertexShaderFile
    ! tessControlSource <- B.readFile mapTessControlShaderFile
@@ -143,7 +140,7 @@ initHud = do
    texIndex <- get (uniformLocation program "tex[1]")
    checkError "ui-tex"
 
-   -- | simple triangle over the whole screen.
+   -- simple triangle over the whole screen.
    let vertexBufferData = reverse [-1, -1, 1, -1, -1, 1, 1, 1] :: [GLfloat]
 
    vertexIndex <- get (attribLocation program "position")

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)
@@ -26,8 +26,8 @@ data Env = Env
 --Mutable State
 
 data Position = Position
-    { _x                   :: !Double
+    { __x                   :: !Double
-    , _y                   :: !Double
+    , __y                   :: !Double
     }
 
 data WindowState = WindowState