path: root/Resources.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
module Resources where

import qualified SDL
import qualified SDL.Image

import Foreign.Storable
import Foreign.Ptr
import Foreign.Marshal.Array

import Graphics.Glyph.GLMath as V
import Graphics.Glyph.GlyphObject
import Graphics.Glyph.ObjLoader
import Graphics.Glyph.Shaders
import Graphics.SDL.SDLHelp
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Mat4
import Graphics.Glyph.Util
import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Rendering.OpenGL as GL
import Graphics.GL.Compatibility30

import Control.Applicative
import Control.Monad

import Data.Angle
import Data.Function
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold
import Data.Maybe
import Debug.Trace

import System.Exit
import qualified Data.Array.IO as ArrIO

import Data.Array
import qualified Data.StateVar as SV
import Data.Time.Clock.POSIX
import Control.Concurrent
import Text.Printf
import System.IO
import System.Random hiding (uniform)
import qualified SDL

{- Types of terrain which are possible -}
data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | 
                Tundra | Unknown deriving (Enum,Eq)
instance Show TileType where
   show = \case
     Forest -> "F"
     Beach  -> "B"
     Water -> "W"
     Grass -> "G"
     Jungle -> "J"
     Mountains -> "M"
     Tundra -> "T"
     Unknown -> "?"

{- A tile has 2 things, a type and
 - elevation, however, the term tile is
 - a litte misleading, it is really a point. -}
data Tile = Tile {
    tileType :: TileType,
    elevation :: Int
} deriving Show

{- Position of the camera as described by
 - polar coordinates -}
data CameraPosition = CameraPosition {
    pEye :: Vec3 GLfloat,
    pTh :: GLfloat,
    pPh :: GLfloat
} deriving Show

{- The central data type for rendering
 - the scene. Contains the 'global' information -}
data Resources = Resources {
    rWindow :: SDL.Window,

    rPosition :: CameraPosition,
    rDPosition :: CameraPosition,

    pMatrix :: Mat4 GLfloat,
    mvMatrix :: Mat4 GLfloat,

    routines :: [ResourcesClosure -> IO ()],

    timeSpeed :: Int,
    time :: Int,

    heightMap :: Array (Int,Int) Tile,
    positionUpdate :: (Resources -> IO Resources),

    {- Smaller if in first person -}
    speedFactor :: GLfloat,
    {- Higher if shift is held -}
    speedMultiplier :: GLfloat,
    {- Direction -}
    speedDirection :: Vec3 GLfloat,

    dDown :: GLfloat,
    waterArray :: ArrIO.IOArray (Int,Int) GLfloat,
    headBob :: GLfloat,
    mode :: CameraMode,
    threadDiff :: Double
}

setHeadBob :: GLfloat -> Resources -> Resources
setHeadBob f r = r { headBob = f }

setThreadDiff :: Double -> Resources -> Resources
setThreadDiff f r = r { threadDiff = f }

setRSurface :: SDL.Window -> Resources -> Resources
setRSurface x r = r { rWindow = x }

setRPosition :: CameraPosition -> Resources -> Resources
setRPosition x r = r { rPosition = x }

setRDPosition :: CameraPosition -> Resources -> Resources
setRDPosition x r = r { rDPosition = x }

setPMatrix :: Mat4 GLfloat -> Resources -> Resources
setPMatrix x r = r { pMatrix = x }

setMvMatrix :: Mat4 GLfloat -> Resources -> Resources
setMvMatrix x r = r { mvMatrix = x }

setRoutines :: [ResourcesClosure -> IO ()] -> Resources -> Resources
setRoutines x r = r { routines = x }

setSpeedDirection :: Vec3 GLfloat -> Resources -> Resources
setSpeedDirection x r = r { speedDirection = x }

setTimeSpeed :: Int -> Resources -> Resources
setTimeSpeed x r = r { timeSpeed = x }

setTime :: Int -> Resources -> Resources
setTime x r = r { time = x }

setHeightMap :: Array (Int,Int) Tile -> Resources -> Resources
setHeightMap x r = r { heightMap = x }

setPositionUpdate :: (Resources -> IO Resources) -> Resources -> Resources
setPositionUpdate x r = r { positionUpdate = x }

setSpeedFactor :: GLfloat -> Resources -> Resources
setSpeedFactor x r = r { speedFactor = x }

setDDown :: GLfloat -> Resources -> Resources
setDDown x r = r { dDown = x }

setWaterArray :: ArrIO.IOArray (Int,Int) GLfloat -> Resources -> Resources
setWaterArray x r = r { waterArray = x }

getSpeed :: Resources -> GLfloat
getSpeed res =speedFactor res * speedMultiplier res * norm (speedDirection res)

cameraForward :: CameraPosition -> Vec3 GLfloat
cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1,th,ph)

cameraUp :: CameraPosition -> Vec3 GLfloat
cameraUp (CameraPosition _ _ ph) = 
    if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0)
            where ph' = (floor ph::Int) `mod` 360

cameraRight :: CameraPosition -> Vec3 GLfloat
cameraRight cam = cameraUp cam × cameraForward cam


getVelocity :: Resources -> Vec3 GLfloat
getVelocity res =
    let dir = speedDirection res
        camdir = cameraForward $ rPosition res
        truedir = coordinateConvert camdir (Vec3 (0,1,0)) dir in
    getSpeed res `vScale` maybeNormalize truedir

data CameraMode = Oracle | FirstPerson deriving Eq

{- Central data type for rendering each frame -}
data ResourcesClosure = ResourcesClosure {
      rcMVMatrix :: Mat4 GLfloat
    , rcPMatrix  :: Mat4 GLfloat
    , rcLightPos :: Vec4 GLfloat
    , rcTime     :: GLfloat
    , rcNormalMatrix  :: Mat3 GLfloat
    , rcGlobalAmbient :: Vec4 GLfloat
    , rcCameraPos :: CameraPosition
    , rcCameraLocation :: Vec3 GLfloat
    , rcResources :: Resources
}

{- A function that makes the resources data first
 - person -}
firstPerson :: Resources -> IO Resources
firstPerson res =
    let camera@(CameraPosition (Vec3 (x,curh,y)) th ph) = rPosition res
        (_,(w,h)) = bounds $ heightMap res
        (!!!) arr (x',y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x',y'))
        h1 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor y) )
        h2 = ((/10.0).fromIntegral) (heightMap res !!! (floor x, floor (y+1)) )
        h3 = ((/10.0).fromIntegral) (heightMap res !!! (floor (x+1), floor y) )
        h4 = ((/10.0).fromIntegral) (heightMap res !!! (floor (x+1), floor (y+1)))
        u = x - (int $ (floor x::Int))
        v = y - (int $ (floor y::Int))
        mixu1 = mix h3 h1 u
        mixu2 = mix h4 h2 u
        newh = mix mixu2 mixu1 v
        droph = curh - dDown res
        speed = getSpeed res
        jitter = (max 0 $ speed - 0.029) ** 0.1 / 2
        dy = sin (headBob res*2) * jitter
        dx = realToFrac $ cos (headBob res) * jitter 
        in do
    return $ ((setHeadBob.(+ jitter)) <..> headBob) $
        if (newh+0.3 > droph) then
            setSpeedFactor 0.03 $
            setRPosition (CameraPosition (Vec3 (x,newh+0.2,y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $
                    setDDown 0 res
            else
                setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $
                        setDDown (dDown res + 0.03) res

{- A function which will explode if a uniform
 - does not exist for the shader given, otherwis,
 - it will return a list of uniform locations -}
getUniformsSafe :: Program -> [String] -> IO [UniformLocation]
getUniformsSafe prog uniforms =
    forM uniforms $ \a_uniform -> do
        tmp <- get $ uniformLocation prog a_uniform
        case tmp of
            UniformLocation (-1) -> do
                putStrLn $ "No uniform with name: "++a_uniform
                exitWith (ExitFailure 112)
            _ ->  return tmp

{- Builds an model view matrix given the
 - camera position of the scene -}
buildMVMatrix :: CameraPosition -> Mat4 GLfloat
buildMVMatrix camera@(CameraPosition eye _ _) =
    let lookat = eye <+> cameraForward camera in
        lookAtMatrix eye lookat (cameraUp camera)

{- Called after each frame to crunch throught the
 - events -}
eventHandle :: SDL.EventPayload -> Resources -> IO Resources
eventHandle event = case event of
    SDL.KeyboardEvent e ->
      case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
        (SDL.Pressed, SDL.ScancodeW) -> setPh 2
        (SDL.Released, SDL.ScancodeW) -> setPh 0
        (SDL.Pressed, SDL.ScancodeA) -> setTh (-2)
        (SDL.Released, SDL.ScancodeA) -> setTh 0
        (SDL.Pressed, SDL.ScancodeS) -> setPh (-2)
        (SDL.Released, SDL.ScancodeS) -> setPh 0
        (SDL.Pressed, SDL.ScancodeD) -> setTh 2
        (SDL.Released, SDL.ScancodeD) -> setTh 0
        (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1))
        (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0))
        (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1))
        (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0))

        -- Pressing the 'q' enters first-person-mode
        (SDL.Pressed, SDL.ScancodeQ) -> return . appAll
           [setPositionUpdate firstPerson,
            setSpeedFactor 0.1,
            \res -> res { dDown = negate $ (\(Vec3 (_,y,_)) -> y) $ resourcesVelocity res}]

        (SDL.Pressed, SDL.ScancodeE) -> return . appAll
          [setPositionUpdate return,
           setSpeedFactor 1,
           \res -> res { dDown = 0 }]

        (SDL.Pressed, SDL.ScancodeSpace) -> return . appAll
          [setSpeedFactor 0.05,
           \res -> res { dDown = -0.2 }]

        (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 4 }

        (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res { speedMultiplier = 1 }
          
    --  KeyDown (Keysym SDLK_LSHIFT _ _) -> do
    --      return $ setSpeedMultiplier 4 res

    --  KeyUp (Keysym SDLK_LSHIFT _ _) -> do
    --      return $ setSpeedMultiplier 1 res
    --     KeyUp (Keysym SDLK_e _ _) ->
    --         return $
    --             setPositionUpdate return $
    --             setSpeedFactor 1 $
    --                 if speed res > 0 then setSpeed 1 res else res
              
        _ -> return
    _ -> return

    where
      appAll :: [a -> a] -> a -> a
      appAll (f:fs) a = appAll fs (f a)
      appAll [] a = a

      setPh i res =
        let (CameraPosition eye th ph) = rDPosition res in
              return $ setRDPosition (CameraPosition eye th i) res
      setTh i res =
        let (CameraPosition eye th ph) = rDPosition res in
              return $ setRDPosition (CameraPosition eye i ph) res

-- eventHandle :: SDL.Event -> Resources -> IO Resources
-- eventHandle event res = do
    -- let (CameraPosition eye th ph) = rDPosition res
    -- let (CameraPosition peye pth pph) = rPosition res
    -- case event of
    --     KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess

    --     KeyDown (Keysym SDLK_EQUALS _ _) ->
    --         return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
    --     KeyDown (Keysym SDLK_MINUS _ _) ->
    --         return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res

    --     KeyDown (Keysym SDLK_UP _ _) ->
    --         return $ setRDPosition (CameraPosition eye th (ph+1)) res
    --     KeyDown (Keysym SDLK_DOWN _ _) ->
    --         return $ setRDPosition (CameraPosition eye th (ph-1)) res
    --     KeyDown (Keysym SDLK_RIGHT _ _) ->
    --         return $ setRDPosition (CameraPosition eye (th+1) ph) res
    --     KeyDown (Keysym SDLK_LEFT _ _) ->
    --         return $ setRDPosition (CameraPosition eye (th-1) ph) res

    --     KeyUp (Keysym SDLK_UP _ _) ->
    --         return $ setRDPosition (CameraPosition eye th (ph-1)) res
    --     KeyUp (Keysym SDLK_DOWN _ _) ->
    --         return $ setRDPosition (CameraPosition eye th (ph+1)) res
    --     KeyUp (Keysym SDLK_RIGHT _ _) ->
    --         return $ setRDPosition (CameraPosition eye (th-1) ph) res
    --     KeyUp (Keysym SDLK_LEFT _ _) ->
    --         return $ setRDPosition (CameraPosition eye (th+1) ph) res

    --     MouseMotion _ _ x y -> do
    --         return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res

    --     KeyDown (Keysym SDLK_w _ _) ->
    --         return $ setSpeed (speed res + speedFactor res) res
    --     KeyDown (Keysym SDLK_s _ _) ->
    --         return $ setSpeed (speed res - speedFactor res) res
    --     KeyUp (Keysym SDLK_w _ _) ->
    --         return $ setSpeed 0 res
    --     KeyUp (Keysym SDLK_s _ _) ->
    --         return $ setSpeed 0 res

    --     KeyUp (Keysym SDLK_q _ _) ->
    --         let getY (Vec3 (_,y,_)) = y in
    --         return $
    --             setPositionUpdate firstPerson $
    --             setSpeedFactor 0.1 $
    --                 (setDDown <..> (negate . getY . resourcesVelocity)) res
    --     KeyUp (Keysym SDLK_e _ _) ->
    --         return $
    --             setPositionUpdate return $
    --             setSpeedFactor 1 $
    --                 if speed res > 0 then setSpeed 1 res else res

    --     KeyUp (Keysym SDLK_f _ _) -> do
    --         ret <- reshape 1920 1080 res
    --         SDL.toggleFullscreen $ rSurface ret
    --         SDL.showCursor False
    --         SDL.grabInput True
    --         return ret
    --     KeyUp (Keysym SDLK_g _ _) -> do
    --         SDL.showCursor False
    --         SDL.grabInput True
    --         return res

    --     KeyDown (Keysym SDLK_SPACE _ _) -> do
    --         return $ setDDown (-0.3) res
    --  MouseMotion _ _ x y -> do
    --      return $
    --          setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res

    --  KeyDown (Keysym SDLK_w _ _) ->
    --      return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
    --  KeyDown (Keysym SDLK_s _ _) ->
    --      return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
    --  KeyDown (Keysym SDLK_d _ _) ->
    --      return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
    --  KeyDown (Keysym SDLK_a _ _) ->
    --      return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res

    --  KeyUp (Keysym SDLK_w _ _) ->
    --      return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
    --  KeyUp (Keysym SDLK_s _ _) ->
    --      return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
    --  KeyUp (Keysym SDLK_d _ _) ->
    --      return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
    --  KeyUp (Keysym SDLK_a _ _) ->
    --      return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res

    --  KeyUp (Keysym SDLK_q _ _) ->
    --      let getY (Vec3 (_,y,_)) = y in
    --      return $
    --          setPositionUpdate firstPerson $
    --          setMode FirstPerson $
    --              (setDDown <..> (negate . getY . resourcesVelocity)) res
    --  KeyUp (Keysym SDLK_e _ _) ->
    --      return $
    --          setPositionUpdate return $
    --          setSpeedFactor 1 $
    --          setMode Oracle res

    --  KeyUp (Keysym SDLK_f _ _) -> do
    --      ret <- reshape 1920 1080 res
    --      SDL.toggleFullscreen $ rSurface ret
    --      SDL.showCursor False
    --      SDL.grabInput True
    --      return ret
    --  KeyUp (Keysym SDLK_c _ _) -> do
    --      SDL.showCursor True
    --      SDL.grabInput False
    --      return res
    --  KeyUp (Keysym SDLK_g _ _) -> do
    --      SDL.showCursor False
    --      SDL.grabInput True
    --      return res

    --  KeyDown (Keysym SDLK_SPACE _ _) -> do
    --      return $ 
    --          setDDown (-0.2) $
    --          setSpeedFactor 0.05 res

    --  KeyDown (Keysym SDLK_LSHIFT _ _) -> do
    --      return $ setSpeedMultiplier 4 res

    --  KeyUp (Keysym SDLK_LSHIFT _ _) -> do
    --      return $ setSpeedMultiplier 1 res

    --     KeyDown (Keysym SDLK_LSHIFT _ _) -> do
    --         return $ (setSpeed <..> ((*3) . speed)) res
    --     KeyUp (Keysym SDLK_LSHIFT _ _) -> do
    --         return $ (setSpeed <..> ((/3) . speed)) res

    --     _ -> return res

{- Callback for the display -}
displayHandle :: Resources -> IO Resources
displayHandle resources = do
    time1 <- getPOSIXTime
    let cameraPos@(CameraPosition loc _ _) = rPosition resources
    let lighty = ((/10) . fromIntegral . time) resources
    let logist c =  (1 / (1 + 2.71828**(-c*x))) * 0.9 + 0.1
            where x = sine $ Degrees (lighty)
    let globalAmbient::(GLfloat,GLfloat,GLfloat,GLfloat)
        globalAmbient = ( logist 2+0.1, logist 10, (logist 15) + 0.1,(sine.Degrees) lighty)
    let lightPos = Vec4( 50,
                         1000000 * (sine.Degrees $ lighty),
                         -1000000 * (cosine.Degrees . (/10) . fromIntegral . time) resources,
                         1 )
    let l_mvMatrix = buildMVMatrix $ cameraPos
    let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix

    clearColor $= Color4 0 0 0 0
    clear [ColorBuffer, DepthBuffer]
    printErrors "Display"


    let rc = ResourcesClosure l_mvMatrix
                (pMatrix resources)
                (l_mvMatrix `glslMatMul` lightPos)
                (fromIntegral $ time resources)
                (normalMatrix)
                (Vec4 globalAmbient)
                cameraPos
                loc
                resources

                in mapM_ (Prelude.$rc) $ routines resources

    SDL.glSwapWindow (rWindow resources)
    time2 <- getPOSIXTime

    let diff = threadDiff resources - (realToFrac $ time2 - time1)
    when (diff > 0) (threadDelay $ round $ diff * 1000000)
    time3 <- getPOSIXTime
    let fps = realToFrac $ 1 / (time3 - time1) :: Double

    putStr $ printf "FPS: %.2f\r" fps

    return $
        if' (fps < 30)
            ((setThreadDiff.(subtract 0.0001)) <..> threadDiff)
            ((setThreadDiff.(+0.0001)) <..> threadDiff) resources

cameraToEuclidian :: CameraPosition -> Vec3 GLfloat
cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1,ph,th)

resourcesVelocity :: Resources -> Vec3 GLfloat
resourcesVelocity res = getSpeed res `vScale` cameraToEuclidian (rPosition res)

resourcesUnderWater :: Resources -> IO Bool
resourcesUnderWater res = do
    let (CameraPosition (Vec3 (x,ch,y)) _ _) = rPosition res
    (_,(w,h)) <- ArrIO.getBounds $ waterArray res
    if x < 0 || y < 0 || x > int w || y > int h then return False else do
        height <- ArrIO.readArray (waterArray res) (floor x, floor y)
        return (height > ch && height >= 0)

updateHandle :: Resources -> IO Resources
updateHandle res = do
   (positionUpdate res) $ setRPosition (rPosition res `cAdd` rDPosition res) $
            let new = ((+) `on` (Prelude.$ res)) timeSpeed time  in
                setTime new res
   where (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
           let x' = getVelocity res in
            CameraPosition (x <+> x') (y + y') (z + z')

reshape :: Int -> Int -> Resources -> IO Resources
reshape w h res =
    defaultReshape w h () >> do
        let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 10000
        return $ setPMatrix pMatrix' res

loadProgramSafe' ::
    (IsShaderSource a,
     IsShaderSource b,
     IsShaderSource c) => a -> b -> Maybe c -> IO Program
loadProgramSafe' s1 s2 s3 = do
    progMaybe <- loadProgramSafe s1 s2 s3
    when (isNothing progMaybe) $ exitWith (ExitFailure 111)
    return $ fromJust progMaybe

loadProgramFullSafe' :: 
    (IsShaderSource tc, IsShaderSource te,
     IsShaderSource g, IsShaderSource v,
     IsShaderSource f) => Maybe (tc, te) -> Maybe g -> v -> f -> IO Program
loadProgramFullSafe' a b c d = do
    progMaybe <- loadProgramFullSafe a b c d
    when (isNothing progMaybe) $ exitWith (ExitFailure 111)
    return $ fromJust progMaybe

buildTerrainObject :: BuilderM GLfloat b -> IO (ResourcesClosure -> IO ())
buildTerrainObject builder = do
    let terrainList = map ("terrain/"++)
         [ "forest.png", "beach.png",
           "oceanfloor.png", "grass.png",
           "jungle.png", "mountains.png",
           "tundra.png" ]
    print terrainList
    terrainProg <- loadProgramSafe' "shaders/basic.vert" "shaders/basic.frag" (Nothing::Maybe String)
    lst <- forM (zip [0..7::Int] $ terrainList ++ repeat "terrain/unknown.png") $ \(idx,str) -> do
            location <- get $ uniformLocation terrainProg $ "textures[" ++! idx ++ "]"
            SDL.Image.load str >>= textureFromSurface >>= return . (,) location

    let (dx,dy) = (mapT2 $ (1/).fromIntegral) (mapT2 maximum (unzip $ map (textureSize.snd) lst));
    dXlocation <- get $ uniformLocation terrainProg "dX"
    dYlocation <- get $ uniformLocation terrainProg "dY"
    putStrLn $ "(dx,dy)=" ++! (dx,dy)
    obj <- newDefaultGlyphObjectWithClosure builder () $ \_ -> do
                    currentProgram $= Just terrainProg
                    forM_ (zip [0..] lst) $ \(i,(loc,td)) ->
                        setupTexturing td loc i
                    uniform dXlocation $= Index1 (dx::GLfloat)
                    uniform dYlocation $= Index1 (dy::GLfloat)
                    printErrors "terrainObjectClosure"

    [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU, fogU]
        <- getUniformsSafe terrainProg ["lightPos","globalAmbient","pjMatrix","mvMatrix","normalMatrix","fog"]
    return $ \rc -> do
        draw $ prepare obj $ \_ -> do
            cullFace $= Just Front
            uniform mvMatrixU $= rcMVMatrix rc
            uniform pjMatrixU $= rcPMatrix rc
            uniform lightposU $= rcLightPos rc
            uniform normalMatrixU $= rcNormalMatrix rc
            uniform globalAmbientU $= rcGlobalAmbient rc
            bool <- (resourcesUnderWater $ rcResources rc)
            if bool then
                uniform fogU $= Index1 (0.9::GLfloat) else
                uniform fogU $= Index1 (0.0::GLfloat)

-- cloudProgram :: IO (ResourcesClosure -> IO ())
-- cloudProgram = do
--     let builder =
--             forM_ simpleCube $ \(x,y,z) -> do
--                 bColor4 (x,y,z,0)
--                 bVertex3 (x,y+20,z)
--     program <- loadProgramSafe' "shaders/clouds.vert" "shaders/clouds.frag" noShader
-- 
--     stgen <- newStdGen
--     array3D <- SA.newListArray ((0,0,0,0),(3,64,64,64)) (map (fromIntegral . (`mod`256)) $ (randoms stgen::[Int]))
-- 
--     SA.withStorableArray array3D $ \ptr3D -> do
--         density <- makeTexture3D >>= textureFromPointer3D ptr3D (64,64,64)
-- 
--         obj' <- newDefaultGlyphObjectWithClosure builder () $ \_ -> do
--                     currentProgram $= Just program
--         [mvMatU, pMatU, densityU, globalAmbientU,lightposU] <- mapM (get . uniformLocation program)
--             ["mvMatrix","pMatrix","density","globalAmbient","lightpos"]
--         return $ \rc -> do
--             draw $ prepare obj' $ \_ -> do
--                 cullFace $= Nothing
--                 uniform mvMatU $= rcMVMatrix rc
--                 uniform pMatU $= rcPMatrix rc
--                 uniform globalAmbientU $= rcGlobalAmbient rc
--                 uniform lightposU $= rcLightPos rc
--                 setupTexturing3D density densityU 0
            
buildSnowVal :: Array (Int,Int) Tile -> StdGen -> BuilderM GLfloat ()
buildSnowVal arr gen =
    let (_,(w,h)) = bounds arr
        run :: [Int] -> (Int,Int) -> BuilderM GLfloat [Int]
        run rs (x,y) = do
            let (seed:npart:t) = rs
                nStdGen = mkStdGen seed
                height = elevation (arr ! (x,y))
            when (tileType (arr ! (x,y)) == Tundra) $
                forM_ (take (npart`mod`50) $ chunkList3 $ randomRs (0::GLfloat,1) nStdGen ) $ \(a,b,c) -> do
                    let (x',y') = (int x + a, int y + b)
                    bVertex3 (x',c*100,y')
                    bColor4 (int $ height `div` 10,1, 0, 0)

            return t
        in

        foldM_ run (randoms gen) [(x,y) | x <- [1..w], y <- [1..h]]

buildSnowObject :: Array (Int,Int) Tile -> StdGen -> IO (ResourcesClosure -> IO ())
buildSnowObject arr gen = do
    snowProgram <- loadProgramSafe' "shaders/snow.vert" "shaders/snow.frag" (Just "shaders/snow.geom")
    obj <-
        liftM (flip setPrimitiveMode Ex.Points) $
        newDefaultGlyphObjectWithClosure (buildSnowVal arr gen) () $ \_ -> do
            currentProgram $= Just snowProgram 

    [globalAmbientU,pjMatrixU,mvMatrixU,timeU] <-
        getUniformsSafe snowProgram ["globalAmbient","pjMatrix","mvMatrix","time"]
    return $ \rc -> do
        draw $ (prepare obj) $ \_ -> do
            uniform mvMatrixU $= rcMVMatrix rc
            uniform pjMatrixU $= rcPMatrix rc
            uniform timeU $= (Index1 $ (rcTime rc/75))
            uniform globalAmbientU $= rcGlobalAmbient rc

buildForestObject :: Seq.Seq GLfloat -> String -> String -> IO (ResourcesClosure -> IO ())
buildForestObject a_seq obj tex =
    if Seq.null a_seq then return ((const.return) ()) else do
    let bufferIO :: IO BufferObject
        bufferIO = (newArray . Fold.toList) a_seq >>= ptrToBuffer ArrayBuffer (Seq.length a_seq * 4)
    
    !buffer <- bufferIO
    (log',file) <- loadObjFile obj :: IO ([String],ObjectFile GLfloat)
    mapM_ putStrLn log'
    let !treeF = trace "build tree" $ (basicBuildObject file :: BuilderM GLfloat ())

    forestProg <- loadProgramSafe' 
        "shaders/forest.vert" "shaders/forest.frag" noShader

    woodTexture <- SDL.Image.load tex >>= textureFromSurface
    let (dx,dy) = (mapT2 $ (1/).fromIntegral) (textureSize woodTexture)
    dXlocation <- get $ uniformLocation forestProg "dX"
    dYlocation <- get $ uniformLocation forestProg "dY"

    [textureU,lightU,globalAmbientU,pjMatrixU,mvMatrixU,timeU,normalMatrixU] <-
        getUniformsSafe forestProg ["texture","light","globalAmbient","pjMatrix","mvMatrix","time","normalMatrix"]

    obj' <- newDefaultGlyphObjectWithClosure treeF () $ \_ -> do
                currentProgram $= Just forestProg
                setupTexturing woodTexture textureU 0
                uniform dXlocation $= (Index1 $ (dx::GLfloat))
                uniform dYlocation $= (Index1 $ (dy::GLfloat))

                bindBuffer ArrayBuffer $= Just buffer

                let declareAttr location nelem' offset = do
                            vertexAttribPointer location $=
                                (ToFloat, VertexArrayDescriptor
                                    nelem' Float (fromIntegral $ (3+3+2+1+1)*sizeOf (0::GLfloat))
                                    (wordPtrToPtr offset))
                            vertexAttribArray location $= Enabled
                            vertexAttributeDivisor location SV.$= 1

                declareAttr (AttribLocation 10) 3 0
                declareAttr (AttribLocation 11) 3 (3*4)
                declareAttr (AttribLocation 12) 2 (6*4)
                declareAttr (AttribLocation 13) 1 (8*4)
                declareAttr (AttribLocation 14) 1 (9*4)

                printErrors "forestClosure"
    putStrLn $ "N trees = " ++! (Seq.length a_seq `div` 3)
    let obj'' = setNumInstances obj' (Seq.length a_seq `div` 3)

    return $ \rc -> do
        draw $ (prepare obj'') $ \_ -> do
            uniform mvMatrixU $= rcMVMatrix rc
            uniform pjMatrixU $= rcPMatrix rc
            uniform lightU $= rcLightPos rc
            uniform timeU $= (Index1 $ rcTime rc)
            uniform normalMatrixU $= rcNormalMatrix rc
            uniform globalAmbientU $= rcGlobalAmbient rc

buildWaterObject :: BuilderM GLfloat a -> IO (ResourcesClosure -> IO ())
buildWaterObject builder = do
    waterProg <- loadProgramFullSafe' 
         (Just ("shaders/water.tcs","shaders/water.tes"))
         noShader "shaders/water.vert" "shaders/water.frag"
    waterTexture <- SDL.Image.load "textures/water.jpg" >>= textureFromSurface
    skyTexture <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
    skyNightTexture <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
    location <- get (uniformLocation waterProg "texture")
    skyLocation <- get (uniformLocation waterProg "skytex") 
    skyNightLocation <- get (uniformLocation waterProg "skynight")
    obj <- (liftM (flip setPrimitiveMode Ex.Patches) $ newDefaultGlyphObjectWithClosure builder () $ \_ -> do
                currentProgram $= Just waterProg
                setupTexturing waterTexture location 0
                setupTexturing skyTexture skyLocation 1
                setupTexturing skyNightTexture skyNightLocation 2
            )
    [fogU] <- getUniformsSafe waterProg ["fog"]
    return $ \rc -> do
        draw $ prepare obj $ \_ -> do
            cullFace $= Nothing
            GL.patchVertices $= 4
            uniform (UniformLocation 4) $= rcPMatrix rc 
            uniform (UniformLocation 5) $= rcMVMatrix rc
            uniform (UniformLocation 7) $= rcNormalMatrix rc
            uniform (UniformLocation 8) $= rcLightPos rc
            uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0);
            uniform (UniformLocation 10) $= rcGlobalAmbient rc
            bool <- (resourcesUnderWater $ rcResources rc)
            if bool then
                uniform fogU $= Index1 (0.9::GLfloat) else
                uniform fogU $= Index1 (0.0::GLfloat)
    

makeResources :: SDL.Window -> BuilderM GLfloat b ->
    Seq.Seq GLfloat -> Seq.Seq GLfloat ->
    BuilderM GLfloat a -> Array (Int,Int) Tile ->
    ArrIO.IOArray (Int,Int) GLfloat -> IO Resources
makeResources window builder forestB jungleB water arr waterarr = do
    hSetBuffering stdout NoBuffering
    let pMatrix' = perspectiveMatrix 50 1.8 0.1 100

    stdgen <- newStdGen
    let l_routines = sequence [
            skyboxObject,
            (return $ \_ -> do
                vertexProgramPointSize $= Enabled
                depthFunc $= Just Less),
            buildTerrainObject builder,
            (return $ \_-> do
                blend $= Disabled
                cullFace $= Just Back
                blendFunc $= (GL.SrcAlpha,OneMinusSrcAlpha)),
            buildWaterObject water,
            buildForestObject forestB "tree.obj" "textures/wood_low.png",
            buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png"
            -- buildSnowObject arr stdgen
            -- cloudProgram
         ]
    Resources 
        <$> pure window
        <*> do CameraPosition
                <$> pure (Vec3 (10,10,-10))
                <*> pure 0
                <*> pure 0
        <*> do CameraPosition
                <$> pure (Vec3 (0,0,0))
                <*> pure 0
                <*> pure 0
        <*> pure pMatrix'
        <*> pure pMatrix'
        <*> l_routines
        <*> pure 1
        <*> pure 0
        <*> pure arr
        <*> pure return
        <*> pure 1
        <*> pure 1
        <*> pure (Vec3 (0,0,0))
        <*> pure 0
        <*> pure waterarr
        <*> pure 0
        <*> pure Oracle
        <*> pure 0.033

printErrors :: String -> IO ()
printErrors ctx =
    get errors >>= mapM_ (putStrLn . (("GL["++ctx++"]: ")++) . show)

skyboxSides :: GLfloat -> BuilderM GLfloat ()
skyboxSides dist = do
    let q = trianglesFromQuads $
                -- back
                [(bTexture2(0,0),    bVertex3 (-dist,  dist, -dist)),
                 (bTexture2(0.25,0), bVertex3 ( dist,  dist, -dist)),
                 (bTexture2(0.25,1), bVertex3 ( dist, -dist, -dist)),
                 (bTexture2(0,1),    bVertex3 (-dist, -dist, -dist))] ++
                
                -- front
                [(bTexture2(0.75,0),    bVertex3 (-dist,  dist, dist)),
                 (bTexture2(0.5,0),   bVertex3 ( dist,  dist, dist)),
                 (bTexture2(0.5,1),   bVertex3 ( dist, -dist, dist)),
                 (bTexture2(0.75,1),    bVertex3 (-dist, -dist, dist))] ++

                -- right
                [(bTexture2(0.75,1),    bVertex3 (-dist, -dist,  dist)),
                 (bTexture2(0.75,0),   bVertex3 (-dist,  dist,  dist)),
                 (bTexture2(1.0,0),   bVertex3 (-dist,  dist, -dist)),
                 (bTexture2(1.0,1),    bVertex3 (-dist, -dist, -dist))] ++

                -- left
                [(bTexture2(0.5,1),    bVertex3 ( dist, -dist,  dist)),
                 (bTexture2(0.5,0),    bVertex3 ( dist,  dist,  dist)),
                 (bTexture2(0.25,0) ,    bVertex3 ( dist,  dist, -dist)),
                 (bTexture2(0.25,1) ,    bVertex3 ( dist, -dist, -dist))]

            in
        mapM_ (uncurry (>>)) q
skyboxTop :: GLfloat -> BuilderM GLfloat ()
skyboxTop dist = do
        mapM_ (uncurry (>>)) $
            trianglesFromQuads
                [(bTexture2(1,0),   bVertex3 ( -dist, dist,  dist)),
                 (bTexture2(1,1),   bVertex3 (  dist, dist,  dist)),
                 (bTexture2(0,1),   bVertex3 (  dist, dist, -dist)),
                 (bTexture2(0,0),   bVertex3 ( -dist, dist, -dist))]

skyboxObject :: IO (ResourcesClosure -> IO ())
skyboxObject = do
    prog <- loadProgramSafe' "shaders/sky.vert" "shaders/sky.frag" (Nothing::Maybe String)
    texLoc <- get $ uniformLocation prog "texture"
    texLocNight <- get $ uniformLocation prog "night_tex"
    matLoc <- get $ uniformLocation prog "mvMatrix"
    pmatLoc <- get $ uniformLocation prog "pjMatrix"

    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
    l_texture <- SDL.Image.load "textures/skybox_sides.png" >>= textureFromSurface
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
    l_texture2 <- SDL.Image.load "textures/skybox_sides_night.png" >>= textureFromSurface
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
    l_textureTop <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
    l_textureTopNight <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface

    [lightposU,multU] <- mapM (get . uniformLocation prog) 
                    ["lightpos","mult"]
    topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do
        setupTexturing l_textureTop texLoc 2
        setupTexturing l_textureTopNight texLocNight 3

    obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do
             currentProgram $= Just prog
             setupTexturing l_texture texLoc 0
             setupTexturing l_texture2 texLocNight 1
             printErrors "Skybox"

    let obj' = teardown obj $ \_ -> do
                 draw topObj

    return $ \rc -> do
        depthFunc $= Nothing
        cullFace $= Nothing
        draw $ prepare obj' $ \this -> do
            let (l_matLoc,l_pmatLoc) = getResources this
            let (CameraPosition _ th ph) = rcCameraPos rc
            uniform lightposU $= rcLightPos rc
            uniform l_pmatLoc $= rcPMatrix rc
            uniform l_matLoc $= buildMVMatrix (CameraPosition (Vec3 (0,0,0)) th ph)
            uniform (UniformLocation 1) $= rcGlobalAmbient rc
            bool <- (resourcesUnderWater $ rcResources rc)
            if bool then
                uniform multU $= Index1 (0.0::GLfloat) else
                uniform multU $= Index1 (1.0::GLfloat)
                
    

prepareSkybox :: Mat4 GLfloat -> Mat4 GLfloat -> GlyphObject (Mat4 GLfloat -> Mat4 GLfloat -> IO ()) -> IO ()
prepareSkybox proj lookat obj = do
    (getResources obj) proj lookat