diff options
Diffstat (limited to 'Hw8.hs')
| -rw-r--r-- | Hw8.hs | 796 |
1 files changed, 412 insertions, 384 deletions
@@ -1,78 +1,80 @@ -{-# LANGUAGE TemplateHaskell, OverloadedStrings, ViewPatterns #-} -module Main where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where -import Data.Monoid -import Text.Printf import Control.Applicative -import Control.Monad -import GHC.Exts hiding (Vec4) +-- import Graphics.UI.SDL.Image -import SDL.Vect -import SDL (($=)) -import SDL.Image +import Control.DeepSeq +import Control.Monad import Data.Maybe +import Data.Monoid import Data.Word - import Debug.Trace - -import Graphics.Rendering.OpenGL as GL -import qualified SDL +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.GL.Compatibility30 - --- import Graphics.UI.SDL.Image -import Graphics.Glyph.Textures import Graphics.Glyph.Shaders +import Graphics.Glyph.Textures import Graphics.Glyph.Util -import Graphics.Glyph.BufferBuilder -import Graphics.Glyph.GlyphObject - -import Control.DeepSeq +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 -import Debug.Trace -import Foreign.Storable -import Foreign.Ptr - - -data Uniforms = Uniforms { - dxU :: UniformLocation, +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), + } + 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, @@ -87,19 +89,20 @@ data Resources = Resources { normalMatU :: UniformLocation, resTime :: GLfloat, pMatrix :: Mat4 GLfloat, - eyeLocation :: (GLfloat,GLfloat,GLfloat), + eyeLocation :: (GLfloat, GLfloat, GLfloat), difEyeLocation :: (GLfloat, GLfloat, GLfloat), - lightPos :: (GLfloat,GLfloat,GLfloat), + lightPos :: (GLfloat, GLfloat, GLfloat), useNoise :: Bool, dTime :: GLfloat -} deriving (Show) + } + deriving (Show) makeTexture :: IO TextureObject makeTexture = do - texobj <- liftM head $ genObjectNames 1 - textureBinding Texture2D $= Just texobj - textureFilter Texture2D $= ((Linear', Nothing), Linear') - return texobj + 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 @@ -109,365 +112,390 @@ 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 + 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) + 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) + when (isNothing maybeProg) $ do + putStrLn "Failed to link program" + putStrLn linklog + exitWith (ExitFailure 111) - (return . fromJust) maybeProg + (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) + 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)) - - + 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 + 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) + get errors >>= mapM_ (putStrLn . (("GL[" ++ ctx ++ "]: ") ++) . show) -setupMvp :: Mat4 GLfloat ->Resources -> IO () +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 + 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) + 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" - + 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) - + 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 + 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 $ + 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 (+) + 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' } + 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 + 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 + 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 + -- 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 @@ -481,8 +509,10 @@ main = do window <- SDL.createWindow "SDL / OpenGL Example" - SDL.defaultWindow {SDL.windowInitialSize = V2 1920 1080, - SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL} + SDL.defaultWindow + { SDL.windowInitialSize = V2 1920 1080, + SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + } putStrLn "2" SDL.showWindow window putStrLn "3" @@ -490,14 +520,12 @@ main = do _ <- 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) - } - - + 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) + } |