path: root/Hw8.hs

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