{-# LANGUAGE RecordWildCards, OverloadedStrings, LambdaCase, FlexibleContexts, TemplateHaskell, RankNTypes #-}
module GameEngine.RenderSystem
  ( RenderSystem
  , initRenderSystem
  , loadResources
  , renderScene
  , Renderable(..)
  , Picture(..)
  , Scene(..)
  , BS8.ByteString

  -- resource cache
  , ResourceCache
  , getResourceCache
  , lookupBSPData
  , lookupMD3Data
  , lookupAnimationData
  ) where

import Control.Monad
import Control.Monad.State.Strict
import Data.Vect hiding (Vector)
import Data.Maybe (fromJust, mapMaybe)
import Data.IORef
import Data.List (foldl')
import Data.Hashable
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import qualified Data.Set as Set
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Char8 as BS8
import Codec.Picture
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Digest.CRC32 (crc32)
import Text.Printf
import Lens.Micro.Platform hiding (_4)

import LambdaCube.GL

import qualified GameEngine.Data.BSP as BSP
import qualified GameEngine.Data.MD3 as MD3
import qualified GameEngine.Data.GameCharacter as GCH
import GameEngine.Data.Material hiding (Vec3)
import GameEngine.Graphics.Storage
import GameEngine.Graphics.Frustum
import GameEngine.Graphics.Culling
import GameEngine.Graphics.Quad
import GameEngine.Graphics.MD3
import GameEngine.Graphics.BSP
import GameEngine.Graphics.GameCharacter
import GameEngine.Loader.Zip
import GameEngine.Loader.BSP (readBSP)
import GameEngine.Loader.MD3 (readMD3, readMD3Skin)
import GameEngine.Loader.GameCharacter
import GameEngine.Content
import GameEngine.Scene
import GameEngine.Utils
import GameEngine.Data.MD3

type AnimationCache   = HashMap String GCH.Character
type BSPCache         = HashMap String GPUBSP
type BSPInstanceCache = HashMap String [BSPInstance]
type MD3SkinCache     = HashMap String MD3.MD3Skin
type MD3Cache         = HashMap String GPUMD3
type MD3InstanceCache = HashMap String [MD3Instance]
type QuadCache        = HashMap String [QuadInstance]
type CharacterCache   = HashMap (String,String) [CharacterInstance]
type ShaderCache      = HashSet String
type TextureCache     = HashMap (String,Bool,Bool) TextureData
type AnimatedTexture  = (Float, SetterFun TextureData, Vector TextureData)

{-
  remove IORefs
  traverse renderables
    load resources if necessary
    collect scene materials
  load new textures if necessary
  create new pipeline and storage if necessary
  problematic code: use state or writer monad to collect data
    updateModelCache
    updateRenderCache
-}

data ResourceCache
  = ResourceCache
  { rcBSPCache        :: BSPCache
  , rcMD3Cache        :: MD3Cache
  , rcAnimationCache  :: AnimationCache
  }

getResourceCache :: RenderSystem -> IO ResourceCache
getResourceCache RenderSystem{..} = ResourceCache <$> readIORef rsBSPCache <*> readIORef rsMD3Cache <*> readIORef rsAnimationCache

lookupBSPData :: String -> ResourceCache -> Maybe BSP.BSPLevel
lookupBSPData name ResourceCache{..} = gpubspBSPLevel <$> HashMap.lookup name rcBSPCache

lookupMD3Data :: String -> ResourceCache -> Maybe MD3.MD3Model
lookupMD3Data name ResourceCache{..} = gpumd3Model <$> HashMap.lookup name rcMD3Cache

lookupAnimationData :: String -> ResourceCache -> Maybe GCH.Character
lookupAnimationData name ResourceCache{..} = HashMap.lookup name rcAnimationCache

data RenderSystem
  = RenderSystem
  -- static values
  { rsFileSystem        :: Map String Entry
  , rsShaderMap         :: Map String CommonAttrs
  , rsCheckerTexture    :: TextureData
  , rsWhiteTexture      :: TextureData
  , rsTableTextures     :: TableTextures
  -- resource caches
  , rsAnimationCache    :: IORef AnimationCache
  , rsBSPCache          :: IORef BSPCache
  , rsBSPInstanceCache  :: IORef BSPInstanceCache
  , rsBSPShaderCache    :: IORef ShaderCache
  , rsMD3SkinCache      :: IORef MD3SkinCache
  , rsMD3Cache          :: IORef MD3Cache
  , rsMD3InstanceCache  :: IORef MD3InstanceCache
  , rsMD3ShaderCache    :: IORef ShaderCache
  , rsCharacterCache    :: IORef CharacterCache
  , rsQuadCache         :: IORef QuadCache
  , rsTextureCache      :: IORef TextureCache
  -- renderer pipeline
  , rsRenderer          :: IORef GLRenderer
  , rsStorage           :: IORef GLStorage
  , rsAnimatedTextures  :: IORef [AnimatedTexture]
  }

initRenderSystem :: Map String Entry -> IO RenderSystem
initRenderSystem pk3 = do
  animationCache <- newIORef mempty
  bspCache <- newIORef mempty
  bspInstanceCache <- newIORef mempty
  bspShaderCache <- newIORef mempty
  md3SkinCache <- newIORef mempty
  md3Cache <- newIORef mempty
  md3InstanceCache <- newIORef mempty
  md3ShaderCache <- newIORef mempty
  characterCache <- newIORef mempty
  quadCache <- newIORef mempty
  textureCache <- newIORef mempty
  shMap <- loadShaderMap pk3
  let (inputSchema,_) = createRenderInfo shMap mempty mempty
  storage <- allocStorage inputSchema
  renderer <- fromJust <$> loadQuake3Graphics storage "SimpleGraphics.json"
  rendererRef <- newIORef renderer
  storageRef <- newIORef storage
  animatedTextures <- newIORef []
  -- default textures
  whiteTexture <- uploadTexture2DToGPU' False False False False $ ImageRGB8 $ generateImage (\_ _ -> PixelRGB8 255 255 255) 1 1
  let redBitmap x y = let v = if (x+y) `mod` 2 == 0 then 255 else 0 in PixelRGB8 v v 0
  checkerTexture <- uploadTexture2DToGPU' False False False False $ ImageRGB8 $ generateImage redBitmap 2 2
  tableTextures <- initTableTextures
  initStorageDefaultValues tableTextures storage
  pure $ RenderSystem
    { rsFileSystem        = pk3
    , rsShaderMap         = shMap
    , rsCheckerTexture    = checkerTexture
    , rsWhiteTexture      = whiteTexture
    , rsTableTextures     = tableTextures
    , rsAnimationCache    = animationCache
    , rsBSPCache          = bspCache
    , rsBSPInstanceCache  = bspInstanceCache
    , rsBSPShaderCache    = bspShaderCache
    , rsMD3SkinCache      = md3SkinCache
    , rsMD3Cache          = md3Cache
    , rsMD3InstanceCache  = md3InstanceCache
    , rsMD3ShaderCache    = md3ShaderCache
    , rsCharacterCache    = characterCache
    , rsQuadCache         = quadCache
    , rsTextureCache      = textureCache
    , rsRenderer          = rendererRef
    , rsStorage           = storageRef
    , rsAnimatedTextures  = animatedTextures
    }

loadResources :: RenderSystem -> [Resource] -> [Picture] -> IO ()
loadResources renderSystem resources pictures = do
  -- load new models
  (newMD3Materials,newBSPMaterials,md3Cache,bspCache,_skinCache) <- updateModelCache renderSystem resources pictures
  -- check new materials
  (storage,renderer,md3InstanceCache,bspInstanceCache,characterCache,quadCache) <- updateRenderCache renderSystem newMD3Materials newBSPMaterials
  return ()

loadAnimation :: Map String Entry -> String -> IO GCH.Character
loadAnimation pk3 name = case Map.lookup name pk3 of
  Nothing -> fail $ "file not found: " ++ name
  Just a -> parseCharacter name . BS8.unpack <$> readEntry a >>= \case
    Left message  -> fail message
    Right a -> pure a

loadMD3Skin :: Map String Entry -> String -> IO MD3.MD3Skin
loadMD3Skin pk3 name = case Map.lookup name pk3 of
  Nothing -> fail $ "file not found: " ++ name
  Just a -> readMD3Skin <$> readEntry a

loadMD3 :: Map String Entry -> String -> IO GPUMD3
loadMD3 pk3 name = case Map.lookup name pk3 of
  Nothing -> fail $ "file not found: " ++ name
  Just a -> readMD3 . LB.fromStrict <$> readEntry a >>= uploadMD3

loadBSP :: Map String a -> Map String Entry -> String -> IO GPUBSP
loadBSP shaderMap pk3 name = case Map.lookup name pk3 of
  Nothing -> fail $ "file not found: " ++ name
  Just a -> readBSP . LB.fromStrict <$> readEntry a >>= uploadBSP (Map.keysSet shaderMap)

initStorageDefaultValues :: TableTextures -> GLStorage -> IO ()
initStorageDefaultValues tableTextures storage = do
  let slotU           = uniformSetter storage
      overbrightBits  = 0
  uniformM44F "worldMat" slotU $ mat4ToM44F idmtx
  uniformV3F "entityRGB" slotU $ V3 1 1 1
  uniformFloat "entityAlpha" slotU 1
  uniformFloat "identityLight" slotU $ 1 / (2 ^ overbrightBits)
  setupTableTextures slotU tableTextures

initStorageTextures :: RenderSystem -> GLStorage -> Map String CommonAttrs -> IO ()
initStorageTextures RenderSystem{..} storage usedMaterials = do
  let usedTextures = setNub [ (name,saTexture,saTextureUniform,caNoMipMaps)
                            | (name,CommonAttrs{..}) <- Map.toList usedMaterials
                            , StageAttrs{..} <- caStages
                            ]
      cachedTexture isMip isClamped shaderName imageName = do
        textureCache <- readIORef rsTextureCache
        let key = (imageName,isMip,isClamped)
        case HashMap.lookup key textureCache of
          Just texture -> return texture
          Nothing -> do
            texture <- loadQ3Texture isMip isClamped rsCheckerTexture rsFileSystem shaderName imageName
            writeIORef rsTextureCache $ HashMap.insert key texture textureCache
            return texture
  putStrLn "loading textures:"
  -- load textures
  animatedTextures <- fmap concat $ forM usedTextures $ \(shName,stageTex,texSlotName,noMip) -> do
      let texSetter = uniformFTexture2D (BS8.pack texSlotName) (uniformSetter storage)
          setTex isClamped img = texSetter =<< cachedTexture (not noMip) isClamped shName img
      case stageTex of
          ST_Map img          -> setTex False img >> return []
          ST_ClampMap img     -> setTex True img >> return []
          ST_AnimMap freq imgs   -> do
              txList <- mapM (cachedTexture (not noMip) False shName) imgs
              let txVector = V.fromList txList
              return [(fromIntegral (V.length txVector) / freq,texSetter,txVector)]
          _ -> return []

  writeIORef rsAnimatedTextures animatedTextures

updateModelCache :: RenderSystem -> [Resource] -> [Picture] -> IO (HashSet String,HashSet String,HashMap String GPUMD3,HashMap String GPUBSP,MD3SkinCache)
updateModelCache RenderSystem{..} resources pictures = do
  -- load new animations
  animationCache <- readIORef rsAnimationCache
  let newAnimationNames = setNub [name | R_AnimationCfg name <- resources, not $ HashMap.member name animationCache]
  newAnimations <- forM newAnimationNames $ loadAnimation rsFileSystem
  let animationCache' = animationCache `HashMap.union` HashMap.fromList (zip newAnimationNames newAnimations)
  unless (null newAnimationNames) $ putStrLn $ unlines $ "new animations:" : newAnimationNames
  writeIORef rsAnimationCache animationCache'

  -- load new md3 skins
  skinCache <- readIORef rsMD3SkinCache
  let newSkinNames = setNub [name | R_Skin name <- resources, not $ HashMap.member name skinCache]
  newSkins <- forM newSkinNames $ loadMD3Skin rsFileSystem
  let skinCache' = skinCache `HashMap.union` HashMap.fromList (zip newSkinNames newSkins)
  unless (null newSkinNames) $ putStrLn $ unlines $ "new skins:" : newSkinNames
  writeIORef rsMD3SkinCache skinCache'

  -- load new md3 models
  md3Cache <- readIORef rsMD3Cache
  let newModelNames = setNub [name | R_MD3 name <- resources, not $ HashMap.member name md3Cache]
  newModels <- forM newModelNames $ loadMD3 rsFileSystem
  let md3Cache' = md3Cache `HashMap.union` HashMap.fromList (zip newModelNames newModels)
  unless (null newModelNames) $ putStrLn $ unlines $ "new models:" : newModelNames
  writeIORef rsMD3Cache md3Cache'

  -- load new bsp maps
  bspCache <- readIORef rsBSPCache
  let newBSPNames = setNub [name | R_BSPMap name <- resources, not $ HashMap.member name bspCache]
  newBSPs <- forM newBSPNames $ loadBSP rsShaderMap rsFileSystem
  let bspCache' = bspCache `HashMap.union` HashMap.fromList (zip newBSPNames newBSPs)
  unless (null newBSPNames) $ putStrLn $ unlines $ "new bsp maps:" : newBSPNames
  writeIORef rsBSPCache bspCache'

  -- collect new materials
  md3ShaderCache <- readIORef rsMD3ShaderCache
  bspShaderCache <- readIORef rsBSPShaderCache
  let pictureMaterials  = HashSet.fromList (map pictureShader pictures ++ [name | R_Shader name <- resources])
      skinMaterials     = HashSet.fromList (concatMap Map.elems newSkins)
      newMD3Materials = HashSet.unions (pictureMaterials : skinMaterials : map gpumd3Shaders newModels) `HashSet.difference` md3ShaderCache
      newBSPMaterials = HashSet.unions (map gpubspShaders newBSPs) `HashSet.difference` bspShaderCache
  return (newMD3Materials,newBSPMaterials,md3Cache',bspCache',skinCache')

updateRenderCache :: RenderSystem -> HashSet String -> HashSet String -> IO (GLStorage,GLRenderer,MD3InstanceCache,BSPInstanceCache,CharacterCache,QuadCache)
updateRenderCache renderSystem@RenderSystem{..} newMD3Materials newBSPMaterials
  | HashSet.null newMD3Materials && HashSet.null newBSPMaterials = do
      md3InstanceCache <- readIORef rsMD3InstanceCache
      bspInstanceCache <- readIORef rsBSPInstanceCache
      characterCache <- readIORef rsCharacterCache
      quadCache <- readIORef rsQuadCache
      storage <- readIORef rsStorage
      renderer <- readIORef rsRenderer
      return (storage,renderer,md3InstanceCache,bspInstanceCache,characterCache,quadCache)
  | otherwise = do
      md3ShaderCache <- readIORef rsMD3ShaderCache
      putStrLn $ unlines $ "new md3 materials:" : HashSet.toList newMD3Materials
      let md3ShaderCache' = md3ShaderCache `HashSet.union` newMD3Materials
      writeIORef rsMD3ShaderCache md3ShaderCache'

      bspShaderCache <- readIORef rsBSPShaderCache
      putStrLn $ unlines $ "new bsp materials:" : HashSet.toList newBSPMaterials
      let bspShaderCache' = bspShaderCache `HashSet.union` newBSPMaterials
      writeIORef rsBSPShaderCache bspShaderCache'

      let (inputSchema,usedMaterials) = createRenderInfo rsShaderMap bspShaderCache' md3ShaderCache'
      storage <- allocStorage inputSchema
      -- load new images and set storage texture uniforms
      initStorageTextures renderSystem storage usedMaterials
      initStorageDefaultValues rsTableTextures storage

      writeSampleMaterial usedMaterials
      let filename = show (crc32 . BS8.pack $ show usedMaterials) ++ "_ppl.json"
      compileQuake3GraphicsCached filename >>= \ok -> unless ok $ fail "no renderer"
      renderer <- fromJust <$> loadQuake3Graphics storage filename
      disposeRenderer =<< readIORef rsRenderer
      --renderer <- readIORef rsRenderer
      --setStorage renderer storage
      -- TODO: make sure resources are released
      writeIORef rsStorage storage
      writeIORef rsRenderer renderer
      writeIORef rsMD3InstanceCache mempty
      writeIORef rsBSPInstanceCache mempty
      writeIORef rsCharacterCache mempty
      writeIORef rsQuadCache mempty
      return (storage,renderer,mempty,mempty,mempty,mempty)

data InstanceCache
  = InstanceCache
  { _newMD3        :: !MD3InstanceCache
  , _newBSP        :: !BSPInstanceCache
  , _newCharacter  :: !CharacterCache
  , _newQuad       :: !QuadCache
  , _oldMD3        :: !MD3InstanceCache
  , _oldBSP        :: !BSPInstanceCache
  , _oldCharacter  :: !CharacterCache
  , _oldQuad       :: !QuadCache
  }

makeLenses ''InstanceCache

initCache :: MD3InstanceCache -> BSPInstanceCache -> CharacterCache -> QuadCache -> InstanceCache
initCache = InstanceCache mempty mempty mempty mempty

type RenderM = StateT InstanceCache IO

getInstance :: (Eq k,Hashable k) => Lens' InstanceCache (HashMap k [a]) -> Lens' InstanceCache (HashMap k [a]) -> k -> IO a -> RenderM a
getInstance oldCache newCache name create = HashMap.lookup name <$> use oldCache >>= \case
  Just (model:_) -> do -- use exising instance
    oldCache %= HashMap.adjust tail name
    return model
  _ -> do -- create new instance
    model <- liftIO create
    newCache %= HashMap.insertWith (++) name [model]
    return model

renderScene :: RenderSystem -> Float -> Scene -> IO ()
renderScene a b c = do
  --printTimeDiff "scene process time: " $ do
    renderScene' a b c
  --printTimeDiff "render time: " $ do
    renderFrame =<< readIORef (rsRenderer a)

renderScene' :: RenderSystem -> Float -> Scene -> IO ()
renderScene' renderSystem@RenderSystem{..} effectTime Scene{..} = do
  -- load new models
  let resources = concatMap asResource renderables
  (newMD3Materials,newBSPMaterials,md3Cache,bspCache,skinCache) <- updateModelCache renderSystem resources pictures

  -- check new materials
  (storage,renderer,md3InstanceCache,bspInstanceCache,characterCache,quadCache) <- updateRenderCache renderSystem newMD3Materials newBSPMaterials

  let Camera{..} = camera

  -- create new instances
  let addInstance :: Renderable -> RenderM ()
      addInstance (MD3 position orientation scale rgba name) = do
        MD3Instance{..} <- getInstance oldMD3 newMD3 name $ do
          putStrLn $ "new instance: " ++ name
          addGPUMD3 storage (md3Cache HashMap.! name) mempty ["worldMat","entityRGB","entityAlpha"]
        liftIO $ do
          forM_ md3instanceObject $ \obj -> do
            enableObject obj $ True --((\frame -> boxInFrustum (position + frMins frame + frOrigin frame) (position + frMaxs frame + frOrigin frame) cameraFrustum) . V.head . mdFrames) md3instanceModel  --pointInFrustum position cameraFrustum
            -- set model matrix
            uniformM44F "worldMat" (objectUniformSetter obj) . mat4ToM44F . fromProjective $ toWorldMatrix position orientation scale
            uniformV3F "entityRGB" (objectUniformSetter obj) . vec3ToV3F $ trim rgba
            uniformFloat "entityAlpha" (objectUniformSetter obj) $ _4 rgba

      addInstance (BSPMap name) = do
        BSPInstance{..} <- getInstance oldBSP newBSP name $ do
          -- creates new instance from model cache
          putStrLn $ "new instance: " ++ name
          bspInstance@BSPInstance{..} <- addGPUBSP rsWhiteTexture storage (bspCache HashMap.! name)
          -- set bsp map world matrix
          forM_ bspinstanceSurfaces $ mapM_ (\o -> uniformM44F "worldMat" (objectUniformSetter o) $ mat4ToM44F idmtx)
          return bspInstance
        liftIO $ cullSurfaces bspinstanceBSPLevel cameraPosition cameraFrustum bspinstanceSurfaces

      addInstance (MD3Character position orientation scale rgba name skin) = do
        character <- getInstance oldCharacter newCharacter (name,skin) $ do
          -- creates new instance from model cache
          putStrLn $ printf "new instance: %s %s" name skin
          addCharacterInstance rsFileSystem storage name skin
        liftIO $ setupGameCharacter character effectTime cameraFrustum position orientation scale rgba

      addInstance (MD3New md3Data) = setupMD3Data (one :: Proj4) md3Data

      addInstance _ = pure () -- TODO

      setupMD3Data :: Proj4 -> MD3Data -> RenderM ()
      setupMD3Data baseMat MD3Data{..} = do
        md3Instance@MD3Instance{..} <- getInstance oldMD3 newMD3 md3ModelFile $ do
          putStrLn $ "new instance: " ++ md3ModelFile
          let skin = maybe mempty (skinCache HashMap.!) md3SkinName
          addGPUMD3 storage (md3Cache HashMap.! md3ModelFile) skin ["worldMat","entityRGB","entityAlpha"]
        let localMat = toWorldMatrix md3Position md3Orientation md3Scale .*. baseMat :: Proj4
        -- add md3 to the scene
        liftIO $ do
          case md3Frame of
            Just frameIndex -> setMD3Frame md3Instance frameIndex
            Nothing         -> pure ()
          forM_ md3instanceObject $ \obj -> do
            enableObject obj $ True -- TODO: pointInFrustum md3Position cameraFrustum ; handle md3 collision geometry + local transformations
            -- set model matrix
            uniformM44F "worldMat" (objectUniformSetter obj) . mat4ToM44F $ fromProjective localMat
            uniformV3F "entityRGB" (objectUniformSetter obj) . vec3ToV3F $ trim md3RGBA
            uniformFloat "entityAlpha" (objectUniformSetter obj) $ _4 md3RGBA

        -- handle attachments
        forM_ md3Attachments $ \(GameEngine.Scene.Tag tagName, md3Data) -> do
          let childMat = getTagProj4 md3Instance md3Frame tagName .*. localMat
          setupMD3Data childMat md3Data

      tagToProj4 :: MD3.Tag -> Proj4
      tagToProj4 MD3.Tag{..} = translateAfter4 tgOrigin (orthogonal . toOrthoUnsafe $ tgRotationMat)

      getTagProj4 :: MD3Instance -> Maybe Int -> BS8.ByteString -> Proj4
      getTagProj4 MD3Instance{..} frame name = let tags = MD3.mdTags md3instanceModel in case frame >>= \i -> tags V.!? (i `mod` V.length tags) >>= HashMap.lookup name of
        Nothing   -> idmtx
        Just tag  -> tagToProj4 tag

      addPicture :: Picture -> RenderM ()
      addPicture picture@Picture{..} = do
        quad@QuadInstance{..} <- getInstance oldQuad newQuad pictureShader $ do
          putStrLn $ "new quad instance: " ++ pictureShader
          addQuad storage pictureShader
        liftIO $ do
          let (viewportWidth, viewportHeight) = cameraViewportSize
              viewProj = ortho 0 (fromIntegral viewportWidth) (fromIntegral viewportHeight) 0 0 1
          uniformM44F "viewProj" (objectUniformSetter quadObject) . mat4ToM44F $ transpose viewProj
          updateQuad quad picture
          enableObject quadObject True

  InstanceCache{..} <- execStateT (mapM_ addInstance renderables >> mapM_ addPicture pictures) (initCache md3InstanceCache bspInstanceCache characterCache quadCache)
  writeIORef rsMD3InstanceCache $ HashMap.unionWith (++) md3InstanceCache _newMD3
  writeIORef rsBSPInstanceCache $ HashMap.unionWith (++) bspInstanceCache _newBSP
  writeIORef rsCharacterCache $ HashMap.unionWith (++) characterCache _newCharacter
  writeIORef rsQuadCache $ HashMap.unionWith (++) quadCache _newQuad

  -- hide unused instances
  let hideMD3 :: MD3Instance -> IO ()
      hideMD3 MD3Instance{..} = forM_ md3instanceObject $ flip enableObject False
  forM_ (concat $ HashMap.elems _oldMD3) hideMD3
  forM_ (concat $ HashMap.elems _oldBSP) $ \BSPInstance{..} -> forM_ bspinstanceSurfaces $ mapM_ (flip enableObject False)
  forM_ (concat $ HashMap.elems _oldCharacter) $ \CharacterInstance{..} -> do
    hideMD3 characterinstanceHeadModel
    hideMD3 characterinstanceUpperModel
    hideMD3 characterinstanceLowerModel
  forM_ (concat $ HashMap.elems _oldQuad) $ \QuadInstance{..} -> enableObject quadObject False

  setFrameUniforms effectTime camera storage =<< readIORef rsAnimatedTextures

  --renderFrame renderer

setFrameUniforms :: Float -> Camera -> GLStorage -> [AnimatedTexture] -> IO ()
setFrameUniforms time Camera{..} storage animatedTextures = do
  -- set uniforms
  let uniMap = uniformSetter storage

      rot   = orthogonal $ leftOrthoU cameraOrientation
      view  = fromProjective $ translateBefore4 (neg cameraPosition) rot
      (w,h) = cameraViewportSize

      viewMat     = mat4ToM44F view
      viewProj    = mat4ToM44F $ view .*. cameraProjection
      orientation = mat4ToM44F . fromProjective $ rot

  uniformFloat "time"        uniMap time
  uniformV3F   "viewOrigin"  uniMap $ vec3ToV3F cameraPosition
  uniformM44F  "viewMat"     uniMap viewMat
  uniformM44F  "viewProj"    uniMap viewProj
  uniformM44F  "orientation" uniMap orientation

  setScreenSize storage (fromIntegral w) (fromIntegral h)

  forM_ animatedTextures $ \(animTime,texSetter,v) -> do
    let (_,i) = properFraction (time / animTime)
        idx = floor $ i * fromIntegral (V.length v)
    texSetter $ v V.! idx
