Start reviving this ancient project. (It's pretty cool).

Got it to compile using Stack.

Skybox works, but nothing else really does. I think this is a problem
with how the program is interpreting the surface pixels when
calculating the map terrain and elevation.

I think some TLC is in order.

1 files changed, 56 insertions, 37 deletions

diff --git a/Graphics/SDL/SDLHelp.hs b/Graphics/SDL/SDLHelp.hs
index 75806b2..62bb640 100644
--- a/Graphics/SDL/SDLHelp.hs
+++ b/Graphics/SDL/SDLHelp.hs
@@ -1,13 +1,15 @@
+{-# LANGUAGE OverloadedStrings, LambdaCase, ViewPatterns, RankNTypes #-}
 module Graphics.SDL.SDLHelp where
 
-import Graphics.UI.SDL.Image as SDLImg
-import Graphics.UI.SDL as SDL 
 import Data.Word
 import Control.Monad
 import Graphics.Glyph.Util
 
+import SDL as SDL
+import SDL.Video.Renderer (SurfacePixelFormat(..))
+
+import Graphics.GL.Compatibility30
 import Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL.Raw.Core31
 
 import Foreign.Storable
 import Foreign.Ptr
@@ -28,22 +30,21 @@ data TextureData3D = TextureData3D {
 
 bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData
 bindSurfaceToTexture surf to = do
-    textureBinding Texture2D $= Just to
-    bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
-    putStrLn $ "bpp: " ++! bbp
-    ptr <- surfaceGetPixels surf
-    glTexImage2D gl_TEXTURE_2D 0 bbp (w surf) (h surf) 0 (if bbp == 3 then gl_RGB else gl_RGBA) gl_UNSIGNED_BYTE ptr
-    return $ TextureData (w surf, h surf) to
-    where 
-          w :: (Integral a) => SDL.Surface -> a
-          w = fromIntegral . surfaceGetWidth
-          h :: (Integral a) => SDL.Surface -> a
-          h = fromIntegral . surfaceGetHeight
+  textureBinding Texture2D $= Just to
+  bbp <- return 4 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ SDL.surfacePixels surf)
+  ptr <- SDL.surfacePixels surf
+  (V2 w h) <- SDL.surfaceDimensions surf
+
+  glTexImage2D GL_TEXTURE_2D 0 bbp (fi w) (fi h) 0 (if bbp == 3 then GL_RGB else GL_RGBA) GL_UNSIGNED_BYTE ptr
+  return $ TextureData (fi w, fi h) to
+  where
+    fi :: (Integral a, Integral b) => a -> b
+    fi = fromIntegral
 
 textureFromPointer3D :: Ptr Word8 -> (Int,Int,Int) -> TextureObject -> IO TextureData3D
 textureFromPointer3D ptr (w,h,d) to = do
         textureBinding Texture3D $= Just to
-        glTexImage3D gl_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 gl_RGB gl_UNSIGNED_BYTE ptr
+        glTexImage3D GL_TEXTURE_3D 0 3 (f w) (f h) (f d) 0 GL_RGB GL_UNSIGNED_BYTE ptr
         return $ TextureData3D (w,h,d) to
     where f = fromIntegral
 
@@ -66,9 +67,10 @@ makeTexture = do
 
 getPixel :: Int -> Int -> SDL.Surface -> IO Word32
 getPixel x y surf = do
-    bpp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
-    ptr <- (surfaceGetPixels surf >>= return.castPtr) :: IO (Ptr Word8)
-    let newPtr = ptr `plusPtr` (y * (fromIntegral $ surfaceGetPitch surf)) `plusPtr` (x * bpp)
+    bpp <- return 3 -- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf)
+    ptr <- (surfacePixels surf >>= return.castPtr) :: IO (Ptr Word8)
+    (V2 w h) <- SDL.surfaceDimensions surf
+    let newPtr = ptr `plusPtr` (y * bpp * fromIntegral w) `plusPtr` (x * bpp)
     
     ret <- case bpp of
         -- bytes = R G B A
@@ -105,37 +107,54 @@ wordToPixel word =
 getRGBA :: SDL.Surface -> Int -> Int -> IO (Color4 Word8)
 getRGBA surf x y = liftM wordToPixel $ getPixel x y surf
 
-simpleStartup :: String -> (Int,Int) -> IO Surface
+simpleStartup :: String -> (Int,Int) -> IO SDL.Window
 simpleStartup name' (w,h) = do
-        SDL.init [SDL.InitEverything]
-        SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
-        SDL.setCaption name' name'
-        SDL.getVideoSurface
+  SDL.initialize [SDL.InitVideo]
+  SDL.HintRenderScaleQuality $= SDL.ScaleLinear
+  renderQuality <- SDL.get SDL.HintRenderScaleQuality
+  when (renderQuality /= SDL.ScaleLinear) $
+    putStrLn "Warning: Linear texture filtering not enabled!"
+
+  window <-
+    SDL.createWindow
+      "SDL / OpenGL Example"
+      SDL.defaultWindow
+        { SDL.windowInitialSize = V2 1920 1080,
+          SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
+        }
+  SDL.showWindow window
+
+  _ <- SDL.glCreateContext window
+  return window
 
 defaultReshape :: Int -> Int -> a -> IO a
 defaultReshape w h ret = do
     let size = Size (fromIntegral w) (fromIntegral h)
     viewport $=(Position 0 0, size)
-    _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
+    -- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf]
     return ret
 
-startPipeline :: (Int -> Int -> a -> IO a) -> (Event -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
+startPipeline :: forall a. (Int -> Int -> a -> IO a) -> (SDL.EventPayload -> a -> IO a) -> (a -> IO a) -> (a -> IO a) -> a -> IO ()
 startPipeline reshapeH eventH displayH updateH ini = do
+
     let pumpEvents' res = do
-        ev <- SDL.pollEvent
-        case ev of
-            Quit -> do
-                putStrLn "Exit event."
-                exitSuccess
-            SDL.NoEvent -> return res
-            VideoResize w h -> reshapeH w h res >>= pumpEvents'
-            _ -> eventH ev res >>= pumpEvents'
-    let runPipeline val = do
+          evs <- SDL.pollEvents
+          foldM (\res (SDL.eventPayload -> ev) -> case ev of
+            SDL.QuitEvent -> exitSuccess >> return res
+            _ -> eventH ev res) res evs
+          -- case ev of
+          --     Quit -> do
+          --         putStrLn "Exit event."
+          --         exitSuccess
+          --     SDL.NoEvent -> return res
+          --     VideoResize w h -> reshapeH w h res >>= pumpEvents'
+          --     _ -> eventH ev res >>= pumpEvents'
+        runPipeline val = do
             res <- pumpEvents' val >>= displayH
-            SDL.glSwapBuffers `seq` (updateH res) >>= runPipeline
+            updateH res >>= runPipeline
 
-    -- TODO unhardcode this
-    reshapeH 640 480 ini >>= runPipeline
+    -- -- TODO unhardcode this
+    reshapeH 1920 1080 ini >>= runPipeline
 
 setupTexturing :: TextureData -> UniformLocation -> Int -> IO ()
 setupTexturing (TextureData _ to) tu unit = do