{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}

module Resources where

import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Angle
import Data.Array
import qualified Data.Array.IO as ArrIO
import qualified Data.Foldable as Fold
import Data.Function
import Data.Maybe
import qualified Data.Sequence as Seq
import qualified Data.StateVar as SV
import Data.Time.Clock.POSIX
import Debug.Trace
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Graphics.GL.Compatibility30
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Glyph.GLMath as V
import Graphics.Glyph.GlyphObject
import Graphics.Glyph.Mat4
import Graphics.Glyph.ObjLoader
import Graphics.Glyph.Shaders
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL as GL
import Graphics.SDL.SDLHelp
import qualified SDL
import qualified SDL.Image
import System.Exit
import System.IO
import System.Random hiding (uniform)
import Text.Printf

{- Types of terrain which are possible -}
data TileType
  = Forest
  | Beach
  | Water
  | Grass
  | Jungle
  | Mountains
  | Tundra
  | Unknown
  deriving (Enum, Eq)

instance Show TileType where
  show = \case
    Forest -> "F"
    Beach -> "B"
    Water -> "W"
    Grass -> "G"
    Jungle -> "J"
    Mountains -> "M"
    Tundra -> "T"
    Unknown -> "?"

{- A tile has 2 things, a type and
 - elevation, however, the term tile is
 - a litte misleading, it is really a point. -}
data Tile = Tile
  { tileType :: TileType,
    elevation :: Int
  }
  deriving (Show)

{- Position of the camera as described by
 - polar coordinates -}
data CameraPosition = CameraPosition
  { pEye :: Vec3 GLfloat,
    pTh :: GLfloat,
    pPh :: GLfloat
  }
  deriving (Show)

{- The central data type for rendering
 - the scene. Contains the 'global' information -}
data Resources = Resources
  { rWindow :: SDL.Window,
    rPosition :: CameraPosition,
    rDPosition :: CameraPosition,
    pMatrix :: Mat4 GLfloat,
    mvMatrix :: Mat4 GLfloat,
    routines :: [ResourcesClosure -> IO ()],
    timeSpeed :: Int,
    time :: Int,
    heightMap :: Array (Int, Int) Tile,
    positionUpdate :: (Resources -> IO Resources),
    {- Smaller if in first person -}
    speedFactor :: GLfloat,
    {- Higher if shift is held -}
    speedMultiplier :: GLfloat,
    {- Direction -}
    speedDirection :: Vec3 GLfloat,
    dDown :: GLfloat,
    waterArray :: ArrIO.IOArray (Int, Int) GLfloat,
    headBob :: GLfloat,
    mode :: CameraMode,
    threadDiff :: Double
  }

setHeadBob :: GLfloat -> Resources -> Resources
setHeadBob f r = r {headBob = f}

setThreadDiff :: Double -> Resources -> Resources
setThreadDiff f r = r {threadDiff = f}

setRSurface :: SDL.Window -> Resources -> Resources
setRSurface x r = r {rWindow = x}

setRPosition :: CameraPosition -> Resources -> Resources
setRPosition x r = r {rPosition = x}

setRDPosition :: CameraPosition -> Resources -> Resources
setRDPosition x r = r {rDPosition = x}

setPMatrix :: Mat4 GLfloat -> Resources -> Resources
setPMatrix x r = r {pMatrix = x}

setMvMatrix :: Mat4 GLfloat -> Resources -> Resources
setMvMatrix x r = r {mvMatrix = x}

setRoutines :: [ResourcesClosure -> IO ()] -> Resources -> Resources
setRoutines x r = r {routines = x}

setSpeedDirection :: Vec3 GLfloat -> Resources -> Resources
setSpeedDirection x r = r {speedDirection = x}

setTimeSpeed :: Int -> Resources -> Resources
setTimeSpeed x r = r {timeSpeed = x}

setTime :: Int -> Resources -> Resources
setTime x r = r {time = x}

setHeightMap :: Array (Int, Int) Tile -> Resources -> Resources
setHeightMap x r = r {heightMap = x}

setPositionUpdate :: (Resources -> IO Resources) -> Resources -> Resources
setPositionUpdate x r = r {positionUpdate = x}

setSpeedFactor :: GLfloat -> Resources -> Resources
setSpeedFactor x r = r {speedFactor = x}

setDDown :: GLfloat -> Resources -> Resources
setDDown x r = r {dDown = x}

setWaterArray :: ArrIO.IOArray (Int, Int) GLfloat -> Resources -> Resources
setWaterArray x r = r {waterArray = x}

getSpeed :: Resources -> GLfloat
getSpeed res = speedFactor res * speedMultiplier res * norm (speedDirection res)

cameraForward :: CameraPosition -> Vec3 GLfloat
cameraForward (CameraPosition _ th ph) = Vec3 $ toEuclidian (1, th, ph)

cameraUp :: CameraPosition -> Vec3 GLfloat
cameraUp (CameraPosition _ _ ph) =
  if ph' >= 90 && ph' < 270 then Vec3 (0, -1, 0) else Vec3 (0, 1, 0)
  where
    ph' = (floor ph :: Int) `mod` 360

cameraRight :: CameraPosition -> Vec3 GLfloat
cameraRight cam = cameraUp cam × cameraForward cam

getVelocity :: Resources -> Vec3 GLfloat
getVelocity res =
  let dir = speedDirection res
      camdir = cameraForward $ rPosition res
      truedir = coordinateConvert camdir (Vec3 (0, 1, 0)) dir
   in getSpeed res `vScale` maybeNormalize truedir

data CameraMode = Oracle | FirstPerson deriving (Eq)

{- Central data type for rendering each frame -}
data ResourcesClosure = ResourcesClosure
  { rcMVMatrix :: Mat4 GLfloat,
    rcPMatrix :: Mat4 GLfloat,
    rcLightPos :: Vec4 GLfloat,
    rcTime :: GLfloat,
    rcNormalMatrix :: Mat3 GLfloat,
    rcGlobalAmbient :: Vec4 GLfloat,
    rcCameraPos :: CameraPosition,
    rcCameraLocation :: Vec3 GLfloat,
    rcResources :: Resources
  }

{- A function that makes the resources data first
 - person -}
firstPerson :: Resources -> IO Resources
firstPerson res =
  let camera@(CameraPosition (Vec3 (x, curh, y)) th ph) = rPosition res
      (_, (w, h)) = bounds $ heightMap res
      (!!!) arr (x', y') = if x' < 0 || y' < 0 || x' > w || y' > h then -1000 else elevation (arr ! (x', y'))
      h1 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor x, floor y))
      h2 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor x, floor (y + 1)))
      h3 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor (x + 1), floor y))
      h4 = ((/ 10.0) . fromIntegral) (heightMap res !!! (floor (x + 1), floor (y + 1)))
      u = x - (int $ (floor x :: Int))
      v = y - (int $ (floor y :: Int))
      mixu1 = mix h3 h1 u
      mixu2 = mix h4 h2 u
      newh = mix mixu2 mixu1 v
      droph = curh - dDown res
      speed = getSpeed res
      jitter = (max 0 $ speed - 0.029) ** 0.1 / 2
      dy = sin (headBob res * 2) * jitter
      dx = realToFrac $ cos (headBob res) * jitter
   in do
        return $
          ((setHeadBob . (+ jitter)) <..> headBob) $
            if (newh + 0.3 > droph)
              then
                setSpeedFactor 0.03 $
                  setRPosition (CameraPosition (Vec3 (x, newh + 0.2, y)) (th + (asin dx) * speed * 15) (ph - (asin dy) * speed * 15)) $
                    setDDown 0 res
              else
                setRPosition (CameraPosition (Vec3 (x, droph, y)) th ph) $
                  setDDown (dDown res + 0.03) res

{- A function which will explode if a uniform
 - does not exist for the shader given, otherwis,
 - it will return a list of uniform locations -}
getUniformsSafe :: Program -> [String] -> IO [UniformLocation]
getUniformsSafe prog uniforms =
  forM uniforms $ \a_uniform -> do
    tmp <- get $ uniformLocation prog a_uniform
    case tmp of
      UniformLocation (-1) -> do
        putStrLn $ "No uniform with name: " ++ a_uniform
        exitWith (ExitFailure 112)
      _ -> return tmp

{- Builds an model view matrix given the
 - camera position of the scene -}
buildMVMatrix :: CameraPosition -> Mat4 GLfloat
buildMVMatrix camera@(CameraPosition eye _ _) =
  let lookat = eye <+> cameraForward camera
   in lookAtMatrix eye lookat (cameraUp camera)

{- Called after each frame to crunch throught the
 - events -}
eventHandle :: SDL.EventPayload -> Resources -> IO Resources
eventHandle event = case event of
  SDL.KeyboardEvent e ->
    case (SDL.keyboardEventKeyMotion e, SDL.keysymScancode (SDL.keyboardEventKeysym e)) of
      (SDL.Pressed, SDL.ScancodeW) -> setPh 2
      (SDL.Released, SDL.ScancodeW) -> setPh 0
      (SDL.Pressed, SDL.ScancodeA) -> setTh (-2)
      (SDL.Released, SDL.ScancodeA) -> setTh 0
      (SDL.Pressed, SDL.ScancodeS) -> setPh (-2)
      (SDL.Released, SDL.ScancodeS) -> setPh 0
      (SDL.Pressed, SDL.ScancodeD) -> setTh 2
      (SDL.Released, SDL.ScancodeD) -> setTh 0
      (SDL.Pressed, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 1))
      (SDL.Released, SDL.ScancodeI) -> return . setSpeedDirection (Vec3 (0, 0, 0))
      (SDL.Pressed, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, -1))
      (SDL.Released, SDL.ScancodeK) -> return . setSpeedDirection (Vec3 (0, 0, 0))
      -- Pressing the 'q' enters first-person-mode
      (SDL.Pressed, SDL.ScancodeQ) ->
        return
          . appAll
            [ setPositionUpdate firstPerson,
              setSpeedFactor 0.1,
              \res -> res {dDown = negate $ (\(Vec3 (_, y, _)) -> y) $ resourcesVelocity res}
            ]
      (SDL.Pressed, SDL.ScancodeE) ->
        return
          . appAll
            [ setPositionUpdate return,
              setSpeedFactor 1,
              \res -> res {dDown = 0}
            ]
      (SDL.Pressed, SDL.ScancodeSpace) ->
        return
          . appAll
            [ setSpeedFactor 0.05,
              \res -> res {dDown = -0.2}
            ]
      (SDL.Pressed, SDL.ScancodeLShift) -> \res -> return $ res {speedMultiplier = 4}
      (SDL.Released, SDL.ScancodeLShift) -> \res -> return $ res {speedMultiplier = 1}
      --  KeyDown (Keysym SDLK_LSHIFT _ _) -> do
      --      return $ setSpeedMultiplier 4 res

      --  KeyUp (Keysym SDLK_LSHIFT _ _) -> do
      --      return $ setSpeedMultiplier 1 res
      --     KeyUp (Keysym SDLK_e _ _) ->
      --         return $
      --             setPositionUpdate return $
      --             setSpeedFactor 1 $
      --                 if speed res > 0 then setSpeed 1 res else res

      _ -> return
  _ -> return
  where
    appAll :: [a -> a] -> a -> a
    appAll (f : fs) a = appAll fs (f a)
    appAll [] a = a

    setPh i res =
      let (CameraPosition eye th ph) = rDPosition res
       in return $ setRDPosition (CameraPosition eye th i) res
    setTh i res =
      let (CameraPosition eye th ph) = rDPosition res
       in return $ setRDPosition (CameraPosition eye i ph) res

-- eventHandle :: SDL.Event -> Resources -> IO Resources
-- eventHandle event res = do
-- let (CameraPosition eye th ph) = rDPosition res
-- let (CameraPosition peye pth pph) = rPosition res
-- case event of
--     KeyDown (Keysym SDLK_ESCAPE _ _) -> exitSuccess

--     KeyDown (Keysym SDLK_EQUALS _ _) ->
--         return $ (setTimeSpeed <..> ((+1).timeSpeed)) res
--     KeyDown (Keysym SDLK_MINUS _ _) ->
--         return $ (setTimeSpeed <..> ((subtract 1).timeSpeed)) res

--     KeyDown (Keysym SDLK_UP _ _) ->
--         return $ setRDPosition (CameraPosition eye th (ph+1)) res
--     KeyDown (Keysym SDLK_DOWN _ _) ->
--         return $ setRDPosition (CameraPosition eye th (ph-1)) res
--     KeyDown (Keysym SDLK_RIGHT _ _) ->
--         return $ setRDPosition (CameraPosition eye (th+1) ph) res
--     KeyDown (Keysym SDLK_LEFT _ _) ->
--         return $ setRDPosition (CameraPosition eye (th-1) ph) res

--     KeyUp (Keysym SDLK_UP _ _) ->
--         return $ setRDPosition (CameraPosition eye th (ph-1)) res
--     KeyUp (Keysym SDLK_DOWN _ _) ->
--         return $ setRDPosition (CameraPosition eye th (ph+1)) res
--     KeyUp (Keysym SDLK_RIGHT _ _) ->
--         return $ setRDPosition (CameraPosition eye (th-1) ph) res
--     KeyUp (Keysym SDLK_LEFT _ _) ->
--         return $ setRDPosition (CameraPosition eye (th+1) ph) res

--     MouseMotion _ _ x y -> do
--         return $ setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res

--     KeyDown (Keysym SDLK_w _ _) ->
--         return $ setSpeed (speed res + speedFactor res) res
--     KeyDown (Keysym SDLK_s _ _) ->
--         return $ setSpeed (speed res - speedFactor res) res
--     KeyUp (Keysym SDLK_w _ _) ->
--         return $ setSpeed 0 res
--     KeyUp (Keysym SDLK_s _ _) ->
--         return $ setSpeed 0 res

--     KeyUp (Keysym SDLK_q _ _) ->
--         let getY (Vec3 (_,y,_)) = y in
--         return $
--             setPositionUpdate firstPerson $
--             setSpeedFactor 0.1 $
--                 (setDDown <..> (negate . getY . resourcesVelocity)) res
--     KeyUp (Keysym SDLK_e _ _) ->
--         return $
--             setPositionUpdate return $
--             setSpeedFactor 1 $
--                 if speed res > 0 then setSpeed 1 res else res

--     KeyUp (Keysym SDLK_f _ _) -> do
--         ret <- reshape 1920 1080 res
--         SDL.toggleFullscreen $ rSurface ret
--         SDL.showCursor False
--         SDL.grabInput True
--         return ret
--     KeyUp (Keysym SDLK_g _ _) -> do
--         SDL.showCursor False
--         SDL.grabInput True
--         return res

--     KeyDown (Keysym SDLK_SPACE _ _) -> do
--         return $ setDDown (-0.3) res
--  MouseMotion _ _ x y -> do
--      return $
--          setRPosition (CameraPosition peye (pth+(fromIntegral x/30.0)) (pph-(fromIntegral y/30.0))) res

--  KeyDown (Keysym SDLK_w _ _) ->
--      return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
--  KeyDown (Keysym SDLK_s _ _) ->
--      return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
--  KeyDown (Keysym SDLK_d _ _) ->
--      return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res
--  KeyDown (Keysym SDLK_a _ _) ->
--      return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res

--  KeyUp (Keysym SDLK_w _ _) ->
--      return $ ((setSpeedDirection.(<->Vec3 (0,0,1))) <..> speedDirection) res
--  KeyUp (Keysym SDLK_s _ _) ->
--      return $ ((setSpeedDirection.(<+>Vec3 (0,0,1))) <..> speedDirection) res
--  KeyUp (Keysym SDLK_d _ _) ->
--      return $ ((setSpeedDirection.(<->Vec3 (1,0,0))) <..> speedDirection) res
--  KeyUp (Keysym SDLK_a _ _) ->
--      return $ ((setSpeedDirection.(<+>Vec3 (1,0,0))) <..> speedDirection) res

--  KeyUp (Keysym SDLK_q _ _) ->
--      let getY (Vec3 (_,y,_)) = y in
--      return $
--          setPositionUpdate firstPerson $
--          setMode FirstPerson $
--              (setDDown <..> (negate . getY . resourcesVelocity)) res
--  KeyUp (Keysym SDLK_e _ _) ->
--      return $
--          setPositionUpdate return $
--          setSpeedFactor 1 $
--          setMode Oracle res

--  KeyUp (Keysym SDLK_f _ _) -> do
--      ret <- reshape 1920 1080 res
--      SDL.toggleFullscreen $ rSurface ret
--      SDL.showCursor False
--      SDL.grabInput True
--      return ret
--  KeyUp (Keysym SDLK_c _ _) -> do
--      SDL.showCursor True
--      SDL.grabInput False
--      return res
--  KeyUp (Keysym SDLK_g _ _) -> do
--      SDL.showCursor False
--      SDL.grabInput True
--      return res

--  KeyDown (Keysym SDLK_SPACE _ _) -> do
--      return $
--          setDDown (-0.2) $
--          setSpeedFactor 0.05 res

--  KeyDown (Keysym SDLK_LSHIFT _ _) -> do
--      return $ setSpeedMultiplier 4 res

--  KeyUp (Keysym SDLK_LSHIFT _ _) -> do
--      return $ setSpeedMultiplier 1 res

--     KeyDown (Keysym SDLK_LSHIFT _ _) -> do
--         return $ (setSpeed <..> ((*3) . speed)) res
--     KeyUp (Keysym SDLK_LSHIFT _ _) -> do
--         return $ (setSpeed <..> ((/3) . speed)) res

--     _ -> return res

{- Callback for the display -}
displayHandle :: Resources -> IO Resources
displayHandle resources = do
  time1 <- getPOSIXTime
  let cameraPos@(CameraPosition loc _ _) = rPosition resources
  let lighty = ((/ 10) . fromIntegral . time) resources
  let logist c = (1 / (1 + 2.71828 ** (- c * x))) * 0.9 + 0.1
        where
          x = sine $ Degrees (lighty)
  let globalAmbient :: (GLfloat, GLfloat, GLfloat, GLfloat)
      globalAmbient = (logist 2 + 0.1, logist 10, (logist 15) + 0.1, (sine . Degrees) lighty)
  let lightPos =
        Vec4
          ( 50,
            1000000 * (sine . Degrees $ lighty),
            -1000000 * (cosine . Degrees . (/ 10) . fromIntegral . time) resources,
            1
          )
  let l_mvMatrix = buildMVMatrix $ cameraPos
  let normalMatrix = glslModelViewToNormalMatrix l_mvMatrix

  clearColor $= Color4 0 0 0 0
  clear [ColorBuffer, DepthBuffer]
  printErrors "Display"

  let rc =
        ResourcesClosure
          l_mvMatrix
          (pMatrix resources)
          (l_mvMatrix `glslMatMul` lightPos)
          (fromIntegral $ time resources)
          (normalMatrix)
          (Vec4 globalAmbient)
          cameraPos
          loc
          resources
   in mapM_ (Prelude.$ rc) $ routines resources

  SDL.glSwapWindow (rWindow resources)
  time2 <- getPOSIXTime

  let diff = threadDiff resources - (realToFrac $ time2 - time1)
  when (diff > 0) (threadDelay $ round $ diff * 1000000)
  time3 <- getPOSIXTime
  let fps = realToFrac $ 1 / (time3 - time1) :: Double

  putStr $ printf "FPS: %.2f\r" fps

  return $
    if'
      (fps < 30)
      ((setThreadDiff . (subtract 0.0001)) <..> threadDiff)
      ((setThreadDiff . (+ 0.0001)) <..> threadDiff)
      resources

cameraToEuclidian :: CameraPosition -> Vec3 GLfloat
cameraToEuclidian (CameraPosition _ ph th) = V.normalize $ Vec3 $ toEuclidian (1, ph, th)

resourcesVelocity :: Resources -> Vec3 GLfloat
resourcesVelocity res = getSpeed res `vScale` cameraToEuclidian (rPosition res)

resourcesUnderWater :: Resources -> IO Bool
resourcesUnderWater res = do
  let (CameraPosition (Vec3 (x, ch, y)) _ _) = rPosition res
  (_, (w, h)) <- ArrIO.getBounds $ waterArray res
  if x < 0 || y < 0 || x > int w || y > int h
    then return False
    else do
      height <- ArrIO.readArray (waterArray res) (floor x, floor y)
      return (height > ch && height >= 0)

updateHandle :: Resources -> IO Resources
updateHandle res = do
  (positionUpdate res) $
    setRPosition (rPosition res `cAdd` rDPosition res) $
      let new = ((+) `on` (Prelude.$ res)) timeSpeed time
       in setTime new res
  where
    (CameraPosition x y z) `cAdd` (CameraPosition _ y' z') =
      let x' = getVelocity res
       in CameraPosition (x <+> x') (y + y') (z + z')

reshape :: Int -> Int -> Resources -> IO Resources
reshape w h res =
  defaultReshape w h () >> do
    let pMatrix' = perspectiveMatrix 50 (fromIntegral w / fromIntegral h) 0.1 10000
    return $ setPMatrix pMatrix' res

loadProgramSafe' ::
  ( IsShaderSource a,
    IsShaderSource b,
    IsShaderSource c
  ) =>
  a ->
  b ->
  Maybe c ->
  IO Program
loadProgramSafe' s1 s2 s3 = do
  progMaybe <- loadProgramSafe s1 s2 s3
  when (isNothing progMaybe) $ exitWith (ExitFailure 111)
  return $ fromJust progMaybe

loadProgramFullSafe' ::
  ( IsShaderSource tc,
    IsShaderSource te,
    IsShaderSource g,
    IsShaderSource v,
    IsShaderSource f
  ) =>
  Maybe (tc, te) ->
  Maybe g ->
  v ->
  f ->
  IO Program
loadProgramFullSafe' a b c d = do
  progMaybe <- loadProgramFullSafe a b c d
  when (isNothing progMaybe) $ exitWith (ExitFailure 111)
  return $ fromJust progMaybe

buildTerrainObject :: BuilderM GLfloat b -> IO (ResourcesClosure -> IO ())
buildTerrainObject builder = do
  let terrainList =
        map
          ("terrain/" ++)
          [ "forest.png",
            "beach.png",
            "oceanfloor.png",
            "grass.png",
            "jungle.png",
            "mountains.png",
            "tundra.png"
          ]
  print terrainList
  terrainProg <- loadProgramSafe' "shaders/basic.vert" "shaders/basic.frag" (Nothing :: Maybe String)
  lst <- forM (zip [0 .. 7 :: Int] $ terrainList ++ repeat "terrain/unknown.png") $ \(idx, str) -> do
    location <- get $ uniformLocation terrainProg $ "textures[" ++! idx ++ "]"
    SDL.Image.load str >>= textureFromSurface >>= return . (,) location

  let (dx, dy) = (mapT2 $ (1 /) . fromIntegral) (mapT2 maximum (unzip $ map (textureSize . snd) lst))
  dXlocation <- get $ uniformLocation terrainProg "dX"
  dYlocation <- get $ uniformLocation terrainProg "dY"
  putStrLn $ "(dx,dy)=" ++! (dx, dy)
  obj <- newDefaultGlyphObjectWithClosure builder () $ \_ -> do
    currentProgram $= Just terrainProg
    forM_ (zip [0 ..] lst) $ \(i, (loc, td)) ->
      setupTexturing td loc i
    uniform dXlocation $= Index1 (dx :: GLfloat)
    uniform dYlocation $= Index1 (dy :: GLfloat)
    printErrors "terrainObjectClosure"

  [lightposU, globalAmbientU, pjMatrixU, mvMatrixU, normalMatrixU, fogU] <-
    getUniformsSafe terrainProg ["lightPos", "globalAmbient", "pjMatrix", "mvMatrix", "normalMatrix", "fog"]
  return $ \rc -> do
    draw $
      prepare obj $ \_ -> do
        cullFace $= Just Front
        uniform mvMatrixU $= rcMVMatrix rc
        uniform pjMatrixU $= rcPMatrix rc
        uniform lightposU $= rcLightPos rc
        uniform normalMatrixU $= rcNormalMatrix rc
        uniform globalAmbientU $= rcGlobalAmbient rc
        bool <- (resourcesUnderWater $ rcResources rc)
        if bool
          then uniform fogU $= Index1 (0.9 :: GLfloat)
          else uniform fogU $= Index1 (0.0 :: GLfloat)

-- cloudProgram :: IO (ResourcesClosure -> IO ())
-- cloudProgram = do
--     let builder =
--             forM_ simpleCube $ \(x,y,z) -> do
--                 bColor4 (x,y,z,0)
--                 bVertex3 (x,y+20,z)
--     program <- loadProgramSafe' "shaders/clouds.vert" "shaders/clouds.frag" noShader
--
--     stgen <- newStdGen
--     array3D <- SA.newListArray ((0,0,0,0),(3,64,64,64)) (map (fromIntegral . (`mod`256)) $ (randoms stgen::[Int]))
--
--     SA.withStorableArray array3D $ \ptr3D -> do
--         density <- makeTexture3D >>= textureFromPointer3D ptr3D (64,64,64)
--
--         obj' <- newDefaultGlyphObjectWithClosure builder () $ \_ -> do
--                     currentProgram $= Just program
--         [mvMatU, pMatU, densityU, globalAmbientU,lightposU] <- mapM (get . uniformLocation program)
--             ["mvMatrix","pMatrix","density","globalAmbient","lightpos"]
--         return $ \rc -> do
--             draw $ prepare obj' $ \_ -> do
--                 cullFace $= Nothing
--                 uniform mvMatU $= rcMVMatrix rc
--                 uniform pMatU $= rcPMatrix rc
--                 uniform globalAmbientU $= rcGlobalAmbient rc
--                 uniform lightposU $= rcLightPos rc
--                 setupTexturing3D density densityU 0

buildSnowVal :: Array (Int, Int) Tile -> StdGen -> BuilderM GLfloat ()
buildSnowVal arr gen =
  let (_, (w, h)) = bounds arr
      run :: [Int] -> (Int, Int) -> BuilderM GLfloat [Int]
      run rs (x, y) = do
        let (seed : npart : t) = rs
            nStdGen = mkStdGen seed
            height = elevation (arr ! (x, y))
        when (tileType (arr ! (x, y)) == Tundra) $
          forM_ (take (npart `mod` 50) $ chunkList3 $ randomRs (0 :: GLfloat, 1) nStdGen) $ \(a, b, c) -> do
            let (x', y') = (int x + a, int y + b)
            bVertex3 (x', c * 100, y')
            bColor4 (int $ height `div` 10, 1, 0, 0)

        return t
   in foldM_ run (randoms gen) [(x, y) | x <- [1 .. w], y <- [1 .. h]]

buildSnowObject :: Array (Int, Int) Tile -> StdGen -> IO (ResourcesClosure -> IO ())
buildSnowObject arr gen = do
  snowProgram <- loadProgramSafe' "shaders/snow.vert" "shaders/snow.frag" (Just "shaders/snow.geom")
  obj <-
    liftM (flip setPrimitiveMode Ex.Points) $
      newDefaultGlyphObjectWithClosure (buildSnowVal arr gen) () $ \_ -> do
        currentProgram $= Just snowProgram

  [globalAmbientU, pjMatrixU, mvMatrixU, timeU] <-
    getUniformsSafe snowProgram ["globalAmbient", "pjMatrix", "mvMatrix", "time"]
  return $ \rc -> do
    draw $
      (prepare obj) $ \_ -> do
        uniform mvMatrixU $= rcMVMatrix rc
        uniform pjMatrixU $= rcPMatrix rc
        uniform timeU $= (Index1 $ (rcTime rc / 75))
        uniform globalAmbientU $= rcGlobalAmbient rc

buildForestObject :: Seq.Seq GLfloat -> String -> String -> IO (ResourcesClosure -> IO ())
buildForestObject a_seq obj tex =
  if Seq.null a_seq
    then return ((const . return) ())
    else do
      let bufferIO :: IO BufferObject
          bufferIO = (newArray . Fold.toList) a_seq >>= ptrToBuffer ArrayBuffer (Seq.length a_seq * 4)

      !buffer <- bufferIO
      (log', file) <- loadObjFile obj :: IO ([String], ObjectFile GLfloat)
      mapM_ putStrLn log'
      let !treeF = trace "build tree" $ (basicBuildObject file :: BuilderM GLfloat ())

      forestProg <-
        loadProgramSafe'
          "shaders/forest.vert"
          "shaders/forest.frag"
          noShader

      woodTexture <- SDL.Image.load tex >>= textureFromSurface
      let (dx, dy) = (mapT2 $ (1 /) . fromIntegral) (textureSize woodTexture)
      dXlocation <- get $ uniformLocation forestProg "dX"
      dYlocation <- get $ uniformLocation forestProg "dY"

      [textureU, lightU, globalAmbientU, pjMatrixU, mvMatrixU, timeU, normalMatrixU] <-
        getUniformsSafe forestProg ["texture", "light", "globalAmbient", "pjMatrix", "mvMatrix", "time", "normalMatrix"]

      obj' <- newDefaultGlyphObjectWithClosure treeF () $ \_ -> do
        currentProgram $= Just forestProg
        setupTexturing woodTexture textureU 0
        uniform dXlocation $= (Index1 $ (dx :: GLfloat))
        uniform dYlocation $= (Index1 $ (dy :: GLfloat))

        bindBuffer ArrayBuffer $= Just buffer

        let declareAttr location nelem' offset = do
              vertexAttribPointer location
                $= ( ToFloat,
                     VertexArrayDescriptor
                       nelem'
                       Float
                       (fromIntegral $ (3 + 3 + 2 + 1 + 1) * sizeOf (0 :: GLfloat))
                       (wordPtrToPtr offset)
                   )
              vertexAttribArray location $= Enabled
              vertexAttributeDivisor location SV.$= 1

        declareAttr (AttribLocation 10) 3 0
        declareAttr (AttribLocation 11) 3 (3 * 4)
        declareAttr (AttribLocation 12) 2 (6 * 4)
        declareAttr (AttribLocation 13) 1 (8 * 4)
        declareAttr (AttribLocation 14) 1 (9 * 4)

        printErrors "forestClosure"
      putStrLn $ "N trees = " ++! (Seq.length a_seq `div` 3)
      let obj'' = setNumInstances obj' (Seq.length a_seq `div` 3)

      return $ \rc -> do
        draw $
          (prepare obj'') $ \_ -> do
            uniform mvMatrixU $= rcMVMatrix rc
            uniform pjMatrixU $= rcPMatrix rc
            uniform lightU $= rcLightPos rc
            uniform timeU $= (Index1 $ rcTime rc)
            uniform normalMatrixU $= rcNormalMatrix rc
            uniform globalAmbientU $= rcGlobalAmbient rc

buildWaterObject :: BuilderM GLfloat a -> IO (ResourcesClosure -> IO ())
buildWaterObject builder = do
  waterProg <-
    loadProgramFullSafe'
      (Just ("shaders/water.tcs", "shaders/water.tes"))
      noShader
      "shaders/water.vert"
      "shaders/water.frag"
  waterTexture <- SDL.Image.load "textures/water.jpg" >>= textureFromSurface
  skyTexture <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
  skyNightTexture <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface
  location <- get (uniformLocation waterProg "texture")
  skyLocation <- get (uniformLocation waterProg "skytex")
  skyNightLocation <- get (uniformLocation waterProg "skynight")
  obj <-
    ( liftM (flip setPrimitiveMode Ex.Patches) $
        newDefaultGlyphObjectWithClosure builder () $ \_ -> do
          currentProgram $= Just waterProg
          setupTexturing waterTexture location 0
          setupTexturing skyTexture skyLocation 1
          setupTexturing skyNightTexture skyNightLocation 2
      )
  [fogU] <- getUniformsSafe waterProg ["fog"]
  return $ \rc -> do
    draw $
      prepare obj $ \_ -> do
        cullFace $= Nothing
        GL.patchVertices $= 4
        uniform (UniformLocation 4) $= rcPMatrix rc
        uniform (UniformLocation 5) $= rcMVMatrix rc
        uniform (UniformLocation 7) $= rcNormalMatrix rc
        uniform (UniformLocation 8) $= rcLightPos rc
        uniform (UniformLocation 9) $= Index1 (rcTime rc / 20.0)
        uniform (UniformLocation 10) $= rcGlobalAmbient rc
        bool <- (resourcesUnderWater $ rcResources rc)
        if bool
          then uniform fogU $= Index1 (0.9 :: GLfloat)
          else uniform fogU $= Index1 (0.0 :: GLfloat)

makeResources ::
  SDL.Window ->
  BuilderM GLfloat b ->
  Seq.Seq GLfloat ->
  Seq.Seq GLfloat ->
  BuilderM GLfloat a ->
  Array (Int, Int) Tile ->
  ArrIO.IOArray (Int, Int) GLfloat ->
  IO Resources
makeResources window builder forestB jungleB water arr waterarr = do
  hSetBuffering stdout NoBuffering
  let pMatrix' = perspectiveMatrix 50 1.8 0.1 100

  stdgen <- newStdGen
  let l_routines =
        sequence
          [ skyboxObject,
            ( return $ \_ -> do
                vertexProgramPointSize $= Enabled
                depthFunc $= Just Less
            ),
            buildTerrainObject builder,
            ( return $ \_ -> do
                blend $= Disabled
                cullFace $= Just Back
                blendFunc $= (GL.SrcAlpha, OneMinusSrcAlpha)
            ),
            buildWaterObject water,
            buildForestObject forestB "tree.obj" "textures/wood_low.png",
            buildForestObject jungleB "jungletree.obj" "textures/jungle_tree.png"
            -- buildSnowObject arr stdgen
            -- cloudProgram
          ]
  Resources
    <$> pure window
    <*> do
      CameraPosition
        <$> pure (Vec3 (10, 10, -10))
        <*> pure 0
        <*> pure 0
    <*> do
      CameraPosition
        <$> pure (Vec3 (0, 0, 0))
        <*> pure 0
        <*> pure 0
    <*> pure pMatrix'
    <*> pure pMatrix'
    <*> l_routines
    <*> pure 1
    <*> pure 0
    <*> pure arr
    <*> pure return
    <*> pure 1
    <*> pure 1
    <*> pure (Vec3 (0, 0, 0))
    <*> pure 0
    <*> pure waterarr
    <*> pure 0
    <*> pure Oracle
    <*> pure 0.033

printErrors :: String -> IO ()
printErrors ctx =
  get errors >>= mapM_ (putStrLn . (("GL[" ++ ctx ++ "]: ") ++) . show)

skyboxSides :: GLfloat -> BuilderM GLfloat ()
skyboxSides dist = do
  let q =
        trianglesFromQuads $
          -- back
          [ (bTexture2 (0, 0), bVertex3 (- dist, dist, - dist)),
            (bTexture2 (0.25, 0), bVertex3 (dist, dist, - dist)),
            (bTexture2 (0.25, 1), bVertex3 (dist, - dist, - dist)),
            (bTexture2 (0, 1), bVertex3 (- dist, - dist, - dist))
          ]
            ++
            -- front
            [ (bTexture2 (0.75, 0), bVertex3 (- dist, dist, dist)),
              (bTexture2 (0.5, 0), bVertex3 (dist, dist, dist)),
              (bTexture2 (0.5, 1), bVertex3 (dist, - dist, dist)),
              (bTexture2 (0.75, 1), bVertex3 (- dist, - dist, dist))
            ]
            ++
            -- right
            [ (bTexture2 (0.75, 1), bVertex3 (- dist, - dist, dist)),
              (bTexture2 (0.75, 0), bVertex3 (- dist, dist, dist)),
              (bTexture2 (1.0, 0), bVertex3 (- dist, dist, - dist)),
              (bTexture2 (1.0, 1), bVertex3 (- dist, - dist, - dist))
            ]
            ++
            -- left
            [ (bTexture2 (0.5, 1), bVertex3 (dist, - dist, dist)),
              (bTexture2 (0.5, 0), bVertex3 (dist, dist, dist)),
              (bTexture2 (0.25, 0), bVertex3 (dist, dist, - dist)),
              (bTexture2 (0.25, 1), bVertex3 (dist, - dist, - dist))
            ]
   in mapM_ (uncurry (>>)) q

skyboxTop :: GLfloat -> BuilderM GLfloat ()
skyboxTop dist = do
  mapM_ (uncurry (>>)) $
    trianglesFromQuads
      [ (bTexture2 (1, 0), bVertex3 (- dist, dist, dist)),
        (bTexture2 (1, 1), bVertex3 (dist, dist, dist)),
        (bTexture2 (0, 1), bVertex3 (dist, dist, - dist)),
        (bTexture2 (0, 0), bVertex3 (- dist, dist, - dist))
      ]

skyboxObject :: IO (ResourcesClosure -> IO ())
skyboxObject = do
  prog <- loadProgramSafe' "shaders/sky.vert" "shaders/sky.frag" (Nothing :: Maybe String)
  texLoc <- get $ uniformLocation prog "texture"
  texLocNight <- get $ uniformLocation prog "night_tex"
  matLoc <- get $ uniformLocation prog "mvMatrix"
  pmatLoc <- get $ uniformLocation prog "pjMatrix"

  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
  l_texture <- SDL.Image.load "textures/skybox_sides.png" >>= textureFromSurface
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
  l_texture2 <- SDL.Image.load "textures/skybox_sides_night.png" >>= textureFromSurface
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
  l_textureTop <- SDL.Image.load "textures/skybox_top.png" >>= textureFromSurface
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $ fromIntegral GL_CLAMP_TO_EDGE
  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $ fromIntegral GL_CLAMP_TO_EDGE
  l_textureTopNight <- SDL.Image.load "textures/skybox_top_night.png" >>= textureFromSurface

  [lightposU, multU] <-
    mapM
      (get . uniformLocation prog)
      ["lightpos", "mult"]
  topObj <- newDefaultGlyphObjectWithClosure (skyboxTop 1) () $ \_ -> do
    setupTexturing l_textureTop texLoc 2
    setupTexturing l_textureTopNight texLocNight 3

  obj <- newDefaultGlyphObjectWithClosure (skyboxSides 1) (matLoc, pmatLoc) $ \_ -> do
    currentProgram $= Just prog
    setupTexturing l_texture texLoc 0
    setupTexturing l_texture2 texLocNight 1
    printErrors "Skybox"

  let obj' = teardown obj $ \_ -> do
        draw topObj

  return $ \rc -> do
    depthFunc $= Nothing
    cullFace $= Nothing
    draw $
      prepare obj' $ \this -> do
        let (l_matLoc, l_pmatLoc) = getResources this
        let (CameraPosition _ th ph) = rcCameraPos rc
        uniform lightposU $= rcLightPos rc
        uniform l_pmatLoc $= rcPMatrix rc
        uniform l_matLoc $= buildMVMatrix (CameraPosition (Vec3 (0, 0, 0)) th ph)
        uniform (UniformLocation 1) $= rcGlobalAmbient rc
        bool <- (resourcesUnderWater $ rcResources rc)
        if bool
          then uniform multU $= Index1 (0.0 :: GLfloat)
          else uniform multU $= Index1 (1.0 :: GLfloat)

prepareSkybox :: Mat4 GLfloat -> Mat4 GLfloat -> GlyphObject (Mat4 GLfloat -> Mat4 GLfloat -> IO ()) -> IO ()
prepareSkybox proj lookat obj = do
  (getResources obj) proj lookat