path: root/Hw8.hs

{-# LANGUAGE TemplateHaskell, OverloadedStrings, ViewPatterns #-}
module Main where 

import Data.Monoid
import Text.Printf
import Control.Applicative
import Control.Monad
import GHC.Exts hiding (Vec4)

import SDL.Vect
import SDL (($=))
import SDL.Image
import Data.Maybe
import Data.Word

import Debug.Trace

import Graphics.Rendering.OpenGL as GL
import qualified SDL
import Graphics.Glyph.GLMath
import Graphics.Glyph.Mat4
import Graphics.GL.Compatibility30

-- import Graphics.UI.SDL.Image
import Graphics.Glyph.Textures
import Graphics.Glyph.Shaders
import Graphics.Glyph.Util
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.GlyphObject

import Control.DeepSeq
import System.Exit
import System.Random hiding (uniform)

import Debug.Trace
import Foreign.Storable
import Foreign.Ptr


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