diff options
Diffstat (limited to 'Hw8.hs')
| -rw-r--r-- | Hw8.hs | 501 |
1 files changed, 501 insertions, 0 deletions
@@ -0,0 +1,501 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Control.Applicative +import Control.Monad + +import Data.Setters +import Data.Maybe +import Data.Word + +import Debug.Trace + +import Graphics.Rendering.OpenGL +import Graphics.Rendering.OpenGL.Raw.Core31 +import Graphics.UI.SDL as SDL +import Graphics.Glyph.GLMath +import Graphics.Glyph.Mat4 + +import Graphics.UI.SDL.Image +import Graphics.Glyph.Textures +import Graphics.Glyph.Shaders +import Graphics.Glyph.Util +import Graphics.Glyph.BufferBuilder + +import Control.DeepSeq +import System.Exit +import System.Random + +import Debug.Trace +import Foreign.Storable +import Foreign.Ptr + +class Drawable a where + -- mvMat -> pMat -> obj -> IO () + draw :: a -> IO () + +data GlyphObject a = GlyphObject { + bufferObject :: BufferObject, -- buffer + compiledData :: (CompiledBuild GLfloat), -- compiled data + vertexAttribute :: AttribLocation, -- vertex attribute + normalAttribute :: (Maybe AttribLocation), -- normal attrib + colorAttribute :: (Maybe AttribLocation), -- color attrib + textureAttribute :: (Maybe AttribLocation), -- texture attrib + resources :: a, -- Resources + setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup + teardownRoutine :: (Maybe (GlyphObject a -> IO ())) -- Tear down +} + +$(declareSetters ''GlyphObject) +makeGlyphObject :: Builder GLfloat x -> + AttribLocation -> + Maybe AttribLocation -> + Maybe AttribLocation -> + Maybe AttribLocation -> + a -> + Maybe (GlyphObject a -> IO ()) -> + Maybe (GlyphObject a -> IO ()) -> + IO (GlyphObject a) + +makeGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear = do + compiled <- compilingBuilder builder + buffer <- createBufferObject ArrayBuffer compiled + return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear + +glyphObjectPrepare :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a +glyphObjectPrepare (GlyphObject a b c d e f g _ i) h = GlyphObject a b c d e f g (Just h) i + +glyphObjectTeardown :: GlyphObject a -> (GlyphObject a -> IO()) -> GlyphObject a +glyphObjectTeardown (GlyphObject a b c d e f g h _) i = GlyphObject a b c d e f g h (Just i) + +instance (Show a) => Show (GlyphObject a) where + show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _) = + "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr ++ + " normalAttr="++!nAttr++" colorAttr="++!cAttr++" textureAttr="++!tAttr++" res="++!res++"]" + +instance Drawable (GlyphObject a) where + draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown) = do + {- Setup whatever we need for the object to draw itself -} + maybe (return ()) (apply obj) setup + + {- Get the array descriptors for the possible + - parts -} + let vad = vertexArrayDescriptor co + let nad = normalArrayDescriptor co + let cad = colorArrayDescriptor co + let tad = textureArrayDescriptor co + + bindBuffer ArrayBuffer $= Just bo + let enabled = catMaybes $ + map liftMaybe [(Just vAttr,Just vad), (nAttr, nad), (cAttr,cad), (tAttr,tad)] + + forM_ enabled $ \(attr, ad) -> do + vertexAttribPointer attr $= (ToFloat, ad) + vertexAttribArray attr $= Enabled + + drawArrays Quads 0 (bufferLength co) + + forM_ enabled $ \(attr, _) -> do + vertexAttribArray attr $= Disabled + + {- Tear down whatever the object needs -} + maybe (return ()) (apply obj) tearDown + where liftMaybe t@(Just a, Just b) = Just (a,b) + liftMaybe _ = Nothing + apply obj f = f obj + +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), + 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) + +$(declareSetters ''Resources) + +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 -> IO Program +loadProgram vert frag = do + shaders <- loadShaders [ + (VertexShader, vert), + (FragmentShader, 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 + +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 + forM_ [ + (-1,-1,0.0), + (-1, 1,0.0), + ( 1, 1,0.0), + ( 1,-1,0.0) + ] $ \(a,b,c) -> do + bVertex3 (a,b,c) + +circle :: GLfloat -> GLfloat -> Builder GLfloat () +circle r step = do + let lst = concat [[(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" >>= (\prog -> do + glo <- makeGlyphObject + <$> (pure $ circle 1 3) + <*> get (attribLocation prog "in_position") + <*> (get (attribLocation prog "in_normal") >>= return . Just) + <*> pure Nothing + <*> (get (attribLocation prog "in_texMapping") >>= return . Just) + <*> 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") + <*> pure Nothing + <*> pure Nothing + + prog2 <- loadBackdropProgram + backDrop <- makeGlyphObject + <$> pure quad + <*> get (attribLocation prog "in_position") + <*> pure Nothing + <*> pure Nothing + <*> pure Nothing + <*> (get (uniformLocation prog2 "texture") >>= \x-> return (prog2,x)) + <*> pure Nothing + <*> pure Nothing + + moonProg <- loadProgram "shaders/moon.vert" "shaders/moon.frag" + moon <- makeGlyphObject + <$> pure (circle 0.2 5) + <*> get (attribLocation moonProg "in_position") + <*> liftM Just (get (attribLocation moonProg "in_normal")) + <*> pure Nothing + <*> liftM Just (get (attribLocation moonProg "in_texMapping")) + <*> 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") + <*> pure Nothing + <*> pure Nothing + + Resources + <$> glo + <*> backDrop + <*> 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 1.0 + ) + +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 :: TextureData -> UniformLocation -> Int -> IO () +setupTexturing (TextureData _ to) tu unit = do + texture Texture2D $= Enabled + activeTexture $= TextureUnit (fromIntegral unit) + textureBinding Texture2D $= Just to + uniform tu $= Index1 (fromIntegral unit::GLint) + printErrors "setupTexturing" + + +display :: SDL.Surface -> Resources -> IO Resources +display surf res = do + clear [ColorBuffer, DepthBuffer] + clearColor $= Color4 0.3 0.3 0.3 1.0 + SDL.flip surf + + depthFunc $= Nothing + draw $ glyphObjectPrepare (backDrop res) $ \obj -> do + let (prg,uni) = (resources obj) + currentProgram $= Just prg + setupTexturing (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 + + vertexProgramPointSize $= Enabled + draw $ glyphObjectPrepare (object res) $ \glo -> do + depthFunc $= Just Less + let bumpMap = if useNoise res then resTexture else earthTex + let uniforms = resources 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 (bumpMap res) (textureU uniforms) 0 + setupTexturing (earthTex res) (earthU uniforms) 1 + setupTexturing (cloudsTex res) (cloudsU uniforms) 2 + setupTexturing (lightsTex res) (lightsU uniforms) 3 + setupTexturing (resTexture res) (randomU uniforms) 4 + setupTexturing (winterTex res) (winterU uniforms) 5 + + draw $ glyphObjectPrepare (moon res) $ \glo -> do + let (prog, texU, lU, mvMatU, pMatU, timeUn,dxUn,dyUn) = resources 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 (moonTex res) texU 0 + setupLighting mvMatrix res lU + + SDL.glSwapBuffers + return res + +digestEvents :: Resources -> IO Resources +digestEvents args = do + ev <- SDL.pollEvent + 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 + 1.0) args + + KeyDown (Keysym SDLK_MINUS _ _) -> + digestEvents $ setDTime (dTime args - 1.0) 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 $ setPMatrix pMatrix' args + +bindSurfaceToTexture :: SDL.Surface -> TextureObject -> IO TextureData +bindSurfaceToTexture surf to = do + textureBinding Texture2D $= Just to + bbp <- liftM fromIntegral (pixelFormatGetBytesPerPixel $ surfaceGetPixelFormat surf) + ptr <- surfaceGetPixels surf + glTexImage2D gl_TEXTURE_2D 0 bbp (w surf) (h surf) 0 (if bbp == 3 then gl_RGB else gl_RGBA) gl_UNSIGNED_BYTE ptr + return $ TextureData (w surf, h surf) to + where + w :: (Integral a) => SDL.Surface -> a + w = fromIntegral . surfaceGetWidth + h :: (Integral a) => SDL.Surface -> a + h = fromIntegral . surfaceGetHeight + +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 + let _printError = get errors >>= mapM_ (putStrLn . ("GL: "++) . show) + let size@(w,h) = (640, 480) + + SDL.init [SDL.InitEverything] + + _ <- SDL.setVideoMode w h 32 [SDL.OpenGL, SDL.Resizable, SDL.DoubleBuf] + screen <- SDL.getVideoSurface + resources <- makeResources + reshape size resources >>= mainloop screen + + where mainloop screen resources = + digestEvents resources >>= display screen >>= (mainloop screen . updateResources) + (+++) = zipWithT3 (+) + updateResources res = + setEyeLocation (zipWithT3 (+) (eyeLocation res) (difEyeLocation res)) $ + setResTime ( resTime res + (dTime res) ) res + + |