path: root/Resources.hs

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

import Graphics.UI.SDL as SDL 
import Graphics.UI.SDL.Image as SDLImg

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.Rendering.OpenGL.Raw.Core31

import Control.Applicative
import Control.Monad

import Data.Angle
import Data.Function
import Data.Setters
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 TileShow

import Data.Array
import qualified Data.StateVar as SV
import Data.Time.Clock.POSIX
import Control.Concurrent
import Text.Printf
import System.IO

{- Types of terrain which are possible -}
data TileType = Forest | Beach | Water | Grass | Jungle | Mountains | 
                Tundra | Unknown deriving (Enum,Eq)
$(makeShow ''TileType)

{- 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 {
    rSurface :: SDL.Surface,

    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
}

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
}

$(declareSetters ''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
            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.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 $ ((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 $
                setSpeedFactor 0.03 $
                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_g _ _) -> do
            SDL.showCursor False
            SDL.grabInput True
            return res

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

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

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

        _ -> return res
        where oracle = if (mode res == FirstPerson) then 1 else 3

{- 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]
    SDL.flip $ rSurface resources
    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.glSwapBuffers
    time2 <- getPOSIXTime

    let diff = 0.033 - (time2 - time1)
    when (diff > 0) (threadDelay $ round $ diff * 1000000)
    time3 <- getPOSIXTime

    putStr $ printf "FPS: %.2f\r" (realToFrac $ 1/ (time3 - time1) :: Double)

    return 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 ++ "]"
            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
            

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 <- 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 (Seq.length a_seq `div` 3) obj'

    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 <- load "textures/water.jpg" >>= textureFromSurface
    skyTexture <- load "textures/skybox_top.png" >>= textureFromSurface
    skyNightTexture <- load "textures/skybox_top_night.png" >>= textureFromSurface
    location <- get (uniformLocation waterProg "texture")
    skyLocation <- get (uniformLocation waterProg "skytex") 
    skyNightLocation <- get (uniformLocation waterProg "skynight")
    obj <- (liftM (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
            patchVertices SV.$= (4::Int)
            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.Surface -> BuilderM GLfloat b ->
    Seq.Seq GLfloat -> Seq.Seq GLfloat ->
    BuilderM GLfloat a -> Array (Int,Int) Tile ->
    ArrIO.IOArray (Int,Int) GLfloat -> IO Resources
makeResources surf builder forestB jungleB water arr waterarr = do
    hSetBuffering stdout NoBuffering
    let pMatrix' = perspectiveMatrix 50 1.8 0.1 100

    let l_routines = sequence [
            skyboxObject,
            (return $ \_ -> do
                vertexProgramPointSize $= Enabled
                depthFunc $= Just Less),
            buildTerrainObject builder,
            (return $ \_-> do
                blend $= Enabled
                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"
            -- cloudProgram
         ]
    Resources 
        <$> pure surf
        <*> 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

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