{-# 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.GeometryBuilder as GB 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 Data.Word import qualified Data.Array.Storable as SA import qualified Data.Sequence as Seq import Data.Sequence ((><),(|>),(<|)) import qualified Data.Foldable as Fold import Data.Maybe import Debug.Trace import Foreign.Marshal.Array import Foreign.Marshal.Alloc import System.Exit import System.FilePath import System.Random import Models import Debug.Trace import qualified Data.StateVar as SV data CameraPosition = CameraPosition { pEye :: Vec3 GLfloat, pTh :: GLfloat, pPh :: GLfloat } deriving Show data ObjectData = ObjectData Program data Resources = Resources { rSurface :: SDL.Surface, rPosition :: CameraPosition, rDPosition :: CameraPosition, pMatrix :: Mat4 GLfloat, mvMatrix :: Mat4 GLfloat, routines :: [ResourcesClosure -> IO ()], -- object :: GlyphObject (), -- forest :: GlyphObject (), -- jungle :: GlyphObject (), -- waterObj :: GlyphObject (), speed :: Int, timeSpeed :: Int, time :: Int } 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 } $(declareSetters ''Resources) buildMVMatrix :: CameraPosition -> Mat4 GLfloat buildMVMatrix (CameraPosition eye th ph) = let up = if ph' >= 90 && ph' < 270 then Vec3 (0,-1,0) else Vec3 (0,1,0) where ph' = (floor ph::Int) `mod` 360 in let lookat = eye <+> (Vec3 $ toEuclidian (1,th,ph)) in lookAtMatrix eye lookat up 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 + 1) res KeyDown (Keysym SDLK_s _ _) -> return $ setSpeed (speed res - 1) res KeyUp (Keysym SDLK_w _ _) -> return $ setSpeed (speed res - 1) res KeyUp (Keysym SDLK_s _ _) -> return $ setSpeed (speed res + 1) 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 _ -> return res displayHandle :: Resources -> IO Resources displayHandle resources = do let cameraPos@(CameraPosition r th ph) = 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@(r,g,b,a)= ( 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 (Vec3 $ toEuclidian (r,th,ph)) in mapM_ (Prelude.$rc) $ routines resources SDL.glSwapBuffers return resources updateHandle :: Resources -> IO Resources updateHandle res = do return $ 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 fri = fromIntegral x' = (fri $ speed res) `vScale` (V.normalize $ Vec3 $ toEuclidian (1,y, z)) 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" return $ \rc -> do draw $ prepare obj $ \_ -> do cullFace $= Just Front uniform (UniformLocation 5) $= rcMVMatrix rc uniform (UniformLocation 4) $= rcPMatrix rc uniform (UniformLocation 6) $= rcLightPos rc uniform (UniformLocation 7) $= rcNormalMatrix rc uniform (UniformLocation 8) $= rcGlobalAmbient rc cloudProgram :: IO (ResourcesClosure -> IO ()) cloudProgram = do let randarray ptr n stgen = if n == 0 then return () else do let (tmp,stgen') = next stgen putStrLn $ "TMP: " ++! (tmp `mod` 256) poke ptr (fromIntegral $ tmp `mod` 256) randarray (advancePtr ptr 1) (n - 1) stgen' 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 seq obj tex = if Seq.null seq then return ((const.return) ()) else do let bufferIO :: IO BufferObject bufferIO = (newArray . Fold.toList) seq >>= ptrToBuffer ArrayBuffer (Seq.length 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" obj' <- newDefaultGlyphObjectWithClosure treeF () $ \_ -> do currentProgram $= Just forestProg setupTexturing woodTexture (UniformLocation 6) 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)*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) printErrors "forestClosure" putStrLn $ "N trees = " ++! (Seq.length seq `div` 3) let obj'' = setNumInstances (Seq.length seq `div` 3) obj' return $ \rc -> do draw $ (prepare obj'') $ \_ -> do uniform (UniformLocation 5) $= rcMVMatrix rc uniform (UniformLocation 4) $= rcPMatrix rc uniform (UniformLocation 7) $= rcLightPos rc uniform (UniformLocation 8) $= (Index1 $ rcTime rc) uniform (UniformLocation 9) $= rcNormalMatrix rc uniform (UniformLocation 10) $= 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 ) return $ \rc -> do draw $ prepare obj $ \_ -> do cullFace $= Nothing patchVertices SV.$= 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 makeResources :: SDL.Surface -> BuilderM GLfloat b -> Seq.Seq GLfloat -> Seq.Seq GLfloat -> BuilderM GLfloat a -> IO Resources makeResources surf builder forestB jungleB water = do 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)), buildForestObject forestB "tree.obj" "textures/wood_low.png", buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png", buildWaterObject water -- cloudProgram ] Resources <$> pure surf <*> do CameraPosition <$> pure (Vec3 (10,10,2)) <*> pure 0 <*> pure 0 <*> do CameraPosition <$> pure (Vec3 (0,0,0)) <*> pure 0 <*> pure 0 <*> pure pMatrix' <*> pure pMatrix' <*> l_routines <*> pure 0 <*> pure 1 <*> pure 0 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 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 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 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 textureTopNight <- load "textures/skybox_top_night.png" >>= textureFromSurface [lightposU] <- mapM (get . uniformLocation prog) ["lightpos"] topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do setupTexturing textureTop texLoc 2 setupTexturing textureTopNight texLocNight 3 obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc,pmatLoc) $ \_ -> do currentProgram $= Just prog setupTexturing texture texLoc 0 setupTexturing 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 (matLoc,pmatLoc) = getResources this let (CameraPosition _ th ph) = rcCameraPos rc uniform lightposU $= rcLightPos rc uniform pmatLoc $= rcPMatrix rc uniform matLoc $= buildMVMatrix (CameraPosition (Vec3 (0,0,0)) th ph) uniform (UniformLocation 1) $= rcGlobalAmbient rc prepareSkybox :: Mat4 GLfloat -> Mat4 GLfloat -> GlyphObject (Mat4 GLfloat -> Mat4 GLfloat -> IO ()) -> IO () prepareSkybox proj lookat obj = do (getResources obj) proj lookat