{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} module Main where import Control.Applicative -- import Graphics.UI.SDL.Image import Control.DeepSeq import Control.Monad import Data.Maybe import Data.Monoid import Data.Word import Debug.Trace import Foreign.Ptr import Foreign.Storable import GHC.Exts hiding (Vec4) import Graphics.GL.Compatibility30 import Graphics.Glyph.BufferBuilder import Graphics.Glyph.GLMath import Graphics.Glyph.GlyphObject import Graphics.Glyph.Mat4 import Graphics.Glyph.Shaders import Graphics.Glyph.Textures import Graphics.Glyph.Util import Graphics.Rendering.OpenGL as GL import SDL (($=)) import qualified SDL import SDL.Image import SDL.Vect import System.Exit import System.Random hiding (uniform) import Text.Printf data Uniforms = Uniforms { dxU :: UniformLocation, dyU :: UniformLocation, textureU :: UniformLocation, earthU :: UniformLocation, cloudsU :: UniformLocation, timeU :: UniformLocation, lightsU :: UniformLocation, randomU :: UniformLocation, winterU :: UniformLocation } deriving (Show) data TextureData = TextureData { textureSize :: (Int, Int), textureObject :: TextureObject } deriving (Show) data Resources = Resources { object :: GlyphObject Uniforms, backDrop :: GlyphObject (Program, UniformLocation), satelites :: GlyphObject ( Program, UniformLocation, -- noise UniformLocation, -- mvMat UniformLocation, -- pMat UniformLocation, -- time UniformLocation -- light ), moon :: GlyphObject ( Program, UniformLocation, UniformLocation, UniformLocation, UniformLocation, UniformLocation, UniformLocation, UniformLocation ), resTexture :: TextureData, earthTex :: TextureData, cloudsTex :: TextureData, lightsTex :: TextureData, winterTex :: TextureData, spaceTex :: TextureData, moonTex :: TextureData, program :: Program, lightU :: UniformLocation, pU :: UniformLocation, mvU :: UniformLocation, normalMatU :: UniformLocation, resTime :: GLfloat, pMatrix :: Mat4 GLfloat, eyeLocation :: (GLfloat, GLfloat, GLfloat), difEyeLocation :: (GLfloat, GLfloat, GLfloat), lightPos :: (GLfloat, GLfloat, GLfloat), useNoise :: Bool, dTime :: GLfloat } deriving (Show) makeTexture :: IO TextureObject makeTexture = do texobj <- liftM head $ genObjectNames 1 textureBinding Texture2D $= Just texobj textureFilter Texture2D $= ((Linear', Nothing), Linear') return texobj enumEq :: Enum a => a -> a -> Bool enumEq a = (fromEnum a ==) . fromEnum enumNeq :: Enum a => a -> a -> Bool enumNeq a = not . enumEq a loadProgram :: String -> String -> Maybe String -> IO Program loadProgram vert frag geom = do shaders <- loadShaders $ catMaybes [ Just (VertexShader, vert), Just (FragmentShader, frag), geom >>= return . (,) GeometryShader ] -- mapM_ (putStrLn . fst) shaders (linklog, maybeProg) <- createShaderProgram (workingShaders shaders) when (isNothing maybeProg) $ do putStrLn "Failed to link program" putStrLn linklog exitWith (ExitFailure 111) (return . fromJust) maybeProg loadBackdropProgram :: IO Program loadBackdropProgram = do shaders <- loadShaders [ (VertexShader, "shaders/space.vert"), (FragmentShader, "shaders/space.frag") ] mapM_ (putStrLn . fst) shaders (linklog, maybeProg) <- createShaderProgram (workingShaders shaders) when (isNothing maybeProg) $ do putStrLn "Failed to link program" putStrLn linklog exitWith (ExitFailure 111) (return . fromJust) maybeProg quad :: Builder GLfloat () quad = do let lst = [ (-1, -1, 0.0), (-1, 1, 0.0), (1, 1, 0.0) ] let neg (a, b, c) = (- a, - b, - c) forM_ lst bVertex3 forM_ lst (bVertex3 . neg) circle :: GLfloat -> GLfloat -> Builder GLfloat () circle r step = do let fromQuad (a, b, c, d) = [a, b, c, b, c, d] let lst = concat [ fromQuad ( (r, th - step, ph - step), (r, th + step, ph - step), (r, th + step, ph + step), (r, th - step, ph + step) ) | th <- [0, step .. 359 - step], ph <- [-90, -90 + step .. 89 - step] ] mapM_ (doUv >&> ((bNormal3 >&> bVertex3) . toEuclidian)) lst where doUv (_, th, ph) = bTexture2 (1 - th / 360.0, 1 - (ph / 180.0 + 0.5)) makeResources :: IO Resources makeResources = let pMatrix' = perspectiveMatrix 50 1.8 0.1 100 in loadProgram "shaders/normal.vert" "shaders/textured.frag" Nothing >>= ( \prog -> do glo <- newDefaultGlyphObject (circle 1 3) <$> do Uniforms <$> get (uniformLocation prog "dX") <*> get (uniformLocation prog "dY") <*> get (uniformLocation prog "texture") <*> get (uniformLocation prog "earth") <*> get (uniformLocation prog "clouds") <*> get (uniformLocation prog "time") <*> get (uniformLocation prog "lights") <*> get (uniformLocation prog "random") <*> get (uniformLocation prog "winter") prog2 <- loadBackdropProgram backDrop <- newDefaultGlyphObject quad <$> ( get (uniformLocation prog2 "texture") >>= \x -> return (prog2, x) ) moonProg <- loadProgram "shaders/moon.vert" "shaders/moon.frag" Nothing moon <- newDefaultGlyphObject (circle 0.2 5) <$> do (,,,,,,,) <$> pure moonProg <*> get (uniformLocation moonProg "texture") <*> get (uniformLocation moonProg "lightPos") <*> get (uniformLocation moonProg "mvMat") <*> get (uniformLocation moonProg "pMat") <*> get (uniformLocation moonProg "time") <*> get (uniformLocation moonProg "dX") <*> get (uniformLocation moonProg "dY") stgen1 <- newStdGen stgen2 <- newStdGen stgen3 <- newStdGen let run = (\(x, y, _) -> bTexture2 (1.0 / x, 1.0 / y)) >&> bVertex3 satelitesProg <- loadProgram "shaders/satelites.vert" "shaders/satelites.frag" (Just "shaders/satelites.geom") satelites <- newDefaultGlyphObject ( do mapM_ run $ sortWith (\(a, _, _) -> - a) $ take 200000 $ zip3 (randoms stgen1) (randoms stgen2) (randoms stgen3) ) <$> do (,,,,,) <$> pure satelitesProg <*> get (uniformLocation satelitesProg "noiseTexture") <*> get (uniformLocation satelitesProg "mvMatrix") <*> get (uniformLocation satelitesProg "pMatrix") <*> get (uniformLocation satelitesProg "time") <*> get (uniformLocation satelitesProg "light") Resources <$> glo <*> backDrop <*> liftM (\s -> s {primitiveMode = Points}) satelites <*> moon <*> (makeTexture >>= genRandomTexture) <*> (load ("textures/earth.png") >>= textureFromSurface) <*> (load ("textures/clouds.png") >>= textureFromSurface) <*> (load ("textures/lights.png") >>= textureFromSurface) <*> (load ("textures/winter.png") >>= textureFromSurface) <*> (load ("textures/space.png") >>= textureFromSurface) <*> (load ("textures/moon.png") >>= textureFromSurface) <*> pure prog <*> get (uniformLocation prog "light") <*> get (uniformLocation prog "pMat") <*> get (uniformLocation prog "mvMat") <*> get (uniformLocation prog "normalMat") <*> pure 0 <*> pure pMatrix' <*> pure (5, 45.1, 0.1) <*> pure (0, 0, 0) <*> pure (20, 0.1, 0.1) <*> pure False <*> pure 0.1 ) printErrors :: String -> IO () printErrors ctx = get errors >>= mapM_ (putStrLn . (("GL[" ++ ctx ++ "]: ") ++) . show) setupMvp :: Mat4 GLfloat -> Resources -> IO () setupMvp mvMatrix res = do -- putStrLn ("lookAt: " ++! (Vec3 . toEuclidian $ eyeLocation res) ++ " " -- ++! (Vec3 (0,0,0)) ++ " " ++! (Vec3 (0,1,0))) -- print mvMatrix _ <- (uniform (pU res) $= pMatrix res) t <- (uniform (mvU res) $= mvMatrix) return t setupLighting :: Mat4 GLfloat -> Resources -> UniformLocation -> IO () setupLighting mvMat res lu = let (+++) = zipWithT3 (+) (a, b, c) = (toEuclidian $ lightPos res) Vec4 (x, y, z, _) = mvMat `glslMatMul` Vec4 (a, b, c, 1) normalMat = toNormalMatrix mvMat in do -- putStrLn $ "Multiply "++!(a,b,c)++" by\n"++!mvMat++"\nyeilds "++!(x,y,z) uniform lu $= (Vertex3 x y z) case normalMat of Just mat -> uniform (normalMatU res) $= mat _ -> putStrLn "Normal matrix could not be computed" setupTexturing :: String -> TextureData -> UniformLocation -> Int -> IO () setupTexturing v (TextureData _ to) tu unit = do texture Texture2D $= Enabled activeTexture $= TextureUnit (fromIntegral unit) textureBinding Texture2D $= Just to uniform tu $= Index1 (fromIntegral unit :: GLint) display :: SDL.Window -> Resources -> IO Resources display win res = do clear [ColorBuffer, DepthBuffer] clearColor $= Color4 0.3 0.3 0.3 1.0 depthFunc $= Nothing draw $ prepare (backDrop res) $ \obj -> do let (prg, uni) = (getResources obj) currentProgram $= Just prg setupTexturing "space" (spaceTex res) uni 0 currentProgram $= Just (program res) let (_, _, ph) = eyeLocation res let up = if ph' >= 90 && ph' < 270 then Vec3 (0, -1, 0) else Vec3 (0, 1, 0) where ph' = (floor ph :: Int) `mod` 360 let mvMatrix = lookAtMatrix (Vec3 . toEuclidian $ eyeLocation res) (Vec3 (0, 0, 0)) up blend $= Disabled vertexProgramPointSize $= Enabled draw $ prepare (object res) $ \glo -> do depthFunc $= Just Less let bumpMap = if useNoise res then resTexture else earthTex let uniforms = getResources glo let (w, h) = mapT2 fromIntegral (textureSize $ bumpMap res) uniform (dxU uniforms) $= Index1 (1.0 / w :: GLfloat) uniform (dyU uniforms) $= Index1 (1.0 / h :: GLfloat) uniform (timeU uniforms) $= Index1 (resTime res) setupMvp mvMatrix res setupLighting mvMatrix res (lightU res) setupTexturing "bump" (bumpMap res) (textureU uniforms) 0 setupTexturing "earth" (earthTex res) (earthU uniforms) 1 setupTexturing "clouds" (cloudsTex res) (cloudsU uniforms) 2 setupTexturing "lights" (lightsTex res) (lightsU uniforms) 3 setupTexturing "res" (resTexture res) (randomU uniforms) 4 setupTexturing "winter" (winterTex res) (winterU uniforms) 5 draw $ prepare (moon res) $ \glo -> do let (prog, texU, lU, mvMatU, pMatU, timeUn, dxUn, dyUn) = getResources glo let (w, h) = mapT2 fromIntegral (textureSize $ moonTex res) let time = resTime res currentProgram $= Just prog uniform mvMatU $= (mvMatrix ==> Vec4 (10 * gsin (time / 10), 0, 10 * gcos (time / 10), 0)) uniform pMatU $= (pMatrix res) uniform timeUn $= Index1 time uniform dxUn $= Index1 (1.0 / w :: GLfloat) uniform dyUn $= Index1 (1.0 / w :: GLfloat) setupTexturing "moon" (moonTex res) texU 0 setupLighting mvMatrix res lU blend $= Enabled blendFunc $= (GL.SrcAlpha, OneMinusSrcAlpha) draw $ prepare (satelites res) $ \glo -> do let (prog, texU, mvMatU, pMatU, timeUn, light) = getResources glo let time = resTime res currentProgram $= Just prog uniform mvMatU $= mvMatrix uniform pMatU $= pMatrix res uniform timeUn $= Index1 time setupLighting mvMatrix res light setupTexturing "res" (resTexture res) texU 0 -- SDL.glSwapBuffers SDL.glSwapWindow win return res digestEvents :: Resources -> IO Resources digestEvents res = do evs <- SDL.pollEvents let (quit, res') = foldl ( \(q, res) ev -> case ev of SDL.QuitEvent -> (True, res) SDL.KeyboardEvent e -> (\(q, f) -> (q, f res)) $ ( q, case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of (SDL.Pressed, SDL.ScancodeW) -> diff $ set3 0.2 (SDL.Released, SDL.ScancodeW) -> diff $ set3 0 (SDL.Pressed, SDL.ScancodeA) -> diff $ set2 (-0.2) (SDL.Released, SDL.ScancodeA) -> diff $ set2 0 (SDL.Pressed, SDL.ScancodeS) -> diff $ set3 (-0.2) (SDL.Released, SDL.ScancodeS) -> diff $ set3 0 (SDL.Pressed, SDL.ScancodeD) -> diff $ set2 0.2 (SDL.Released, SDL.ScancodeD) -> diff $ set2 0 (SDL.Pressed, SDL.ScancodeI) -> diff $ set1 (-0.1) (SDL.Released, SDL.ScancodeI) -> diff $ set1 0 (SDL.Pressed, SDL.ScancodeK) -> diff $ set1 0.1 (SDL.Released, SDL.ScancodeK) -> diff $ set1 0 _ -> id ) _ -> (q, res) ) (False, res) (map SDL.eventPayload evs) when quit $ exitSuccess return res' where diff tup res = res {difEyeLocation = tup (difEyeLocation res)} set1 x (_, y, z) = (x, y, z) set2 y (x, _, z) = (x, y, z) set3 z (x, y, _) = (x, y, z) (+++) = zipWithT3 (+) -- ev <- SDL.pollEvent -- return args -- case ev of -- SDL.NoEvent -> return args -- VideoResize w h -> reshape (w,h) args >>= digestEvents -- KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess -- KeyDown (Keysym SDLK_RIGHT _ _) -> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,1,0)) args -- KeyDown (Keysym SDLK_LEFT _ _) -> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,-1,0)) args -- KeyUp (Keysym SDLK_LEFT _ _)-> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,1,0)) args -- KeyUp (Keysym SDLK_RIGHT _ _)-> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,-1,0)) args -- KeyDown (Keysym SDLK_UP _ _) -> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0, 1)) args -- KeyDown (Keysym SDLK_DOWN _ _) -> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0,-1)) args -- KeyUp (Keysym SDLK_UP _ _)-> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0,-1)) args -- KeyUp (Keysym SDLK_DOWN _ _)-> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0,0, 1)) args -- KeyDown (Keysym SDLK_w _ _) -> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (-0.1,0,0)) args -- KeyDown (Keysym SDLK_s _ _) -> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0.1,0,0)) args -- KeyUp (Keysym SDLK_w _ _)-> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (0.1,0,0)) args -- KeyUp (Keysym SDLK_s _ _)-> -- digestEvents $ setDifEyeLocation (difEyeLocation args +++ (-0.1,0,0)) args -- KeyDown (Keysym SDLK_n _ _) -> -- digestEvents $ (Prelude.flip setUseNoise args.not.useNoise) args -- KeyDown (Keysym SDLK_EQUALS _ _) -> -- digestEvents $ setDTime (dTime args + 0.1) args -- KeyDown (Keysym SDLK_MINUS _ _) -> -- digestEvents $ setDTime (dTime args - 0.1) args -- Quit -> exitSuccess -- _ -> digestEvents args -- where -- (+++) = zipWithT3 (+) reshape :: (Int, Int) -> Resources -> IO Resources reshape (w, h) args = do let size = Size (fromIntegral w) (fromIntegral h) let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 100 viewport $= (Position 0 0, size) -- _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf] return $ args {pMatrix = pMatrix'} bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData bindSurfaceToTexture surf to = do textureBinding Texture2D $= Just to bbp <- return 3 -- 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 textureFromSurface :: SDL.Surface -> IO TextureData textureFromSurface surf = makeTexture >>= (bindSurfaceToTexture surf >=> return) genRandomTexture :: TextureObject -> IO TextureData genRandomTexture to = -- putStrLn ("takeShot") let nextColor gen = let (g1, gen') = next gen in let (g2, gen'') = next gen' in let (g3, gen''') = next gen'' in let (g4, gen'''') = next gen''' in ((g1, g2, g3, g4), gen'''') in do stgen <- newStdGen mPix <- newPixelsFromListRGBA (1024, 1024) (randomTup $ randoms stgen) attachPixelsToTexture mPix to return $ TextureData (1024, 1024) to where randomTup (a : b : c : d : xs) = (a, b, c, d) : randomTup xs main :: IO () main = do SDL.initialize [SDL.InitVideo] SDL.HintRenderScaleQuality $= SDL.ScaleLinear renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ putStrLn "Warning: Linear texture filtering not enabled!" putStrLn "1" window <- SDL.createWindow "SDL / OpenGL Example" SDL.defaultWindow { SDL.windowInitialSize = V2 1920 1080, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL } putStrLn "2" SDL.showWindow window putStrLn "3" _ <- SDL.glCreateContext window resources <- makeResources reshape (1920, 1080) resources >>= mainloop window where mainloop win resources = digestEvents resources >>= display win >>= (mainloop win . updateResources) (+++) = zipWithT3 (+) updateResources res = res { resTime = (resTime res + (dTime res)), eyeLocation = zipWithT3 (+) (eyeLocation res) (difEyeLocation res) }