loop/src/Picture/Preload.hs

{-# LANGUAGE TemplateHaskell #-}
--{-# LANGUAGE Strict #-}
module Picture.Preload
    where

import Codec.Picture
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import qualified Graphics.Rendering.OpenGL as GL

import qualified Data.Vector.Storable as V

import Control.Lens
import Control.Monad

import Foreign

import Shaders

data RenderData = RenderData
    { --_charMap :: Image PixelRGBA8
      _textures :: [TextureObject]
    , _basicShader      :: (Program, [UniformLocation])
    , _textShader       :: (Program, [UniformLocation])
    , _circShader       :: (Program, [UniformLocation])
    , _arcShader        :: (Program, [UniformLocation])
    , _fadeCircleShader :: (Program, [UniformLocation])
    , _backShader       :: (Program, [UniformLocation])
    , _wallShadowShader :: (Program, [UniformLocation])
    , _triVAO :: VAO
    , _lineVAO :: VAO
    , _textVAO :: VAO
    , _circVAO :: VAO
    , _arcVAO  :: VAO
    , _backVAO :: VAO
    , _wallVAO :: VAO
    , _fadeCircVAO :: VAO
    , _wssLightPos :: UniformLocation
    , _dummyVBO :: BufferObject
    , _dummyPtr :: Ptr Float
    }
data VAO = VAO
    { _vao :: VertexArrayObject
    , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
    }

makeLenses ''RenderData
makeLenses ''VAO

floatSize = sizeOf (0.5 :: GLfloat)

setupVAO :: [(GLuint,Int)] -> IO VAO
setupVAO ps = do
    theVAO <- genObjectName
    bindVertexArrayObject $= Just theVAO
    vbos <- forM ps setupArrayBuffer
    ptrs <- forM (zip vbos $ map snd ps) setupVBOPointers
    return $ VAO theVAO ptrs
    
numDrawableElements :: Int
numDrawableElements = 50000

setupVBOPointers :: (BufferObject,Int) -> IO (BufferObject,Ptr Float,Int)
setupVBOPointers (vbo,vsize) = do
    thePtr <- mallocArray (vsize * numDrawableElements)
    return (vbo,thePtr,vsize)

setupArrayBuffer :: (GLuint,Int) -> IO BufferObject
setupArrayBuffer (aloc,i) = do
    vbo <- genObjectName
    bindBuffer ArrayBuffer $= Just vbo
    vertexAttribPointer (AttribLocation aloc) $=
        ( ToFloat
        , VertexArrayDescriptor (fromIntegral i) 
                                Float 
                                (fromIntegral $ floatSize * i) 
                                (bufferOffset 0)
        )
    vertexAttribArray (AttribLocation aloc) $= Enabled
    return vbo


loadTextures :: IO [Image PixelRGBA8]
loadTextures = do
--    echarMap <- readImage "data/texture/smudgedDirt.png"
    echarMap <- readImage "data/texture/charMap.png"
    case echarMap of
        Left err -> do 
            putStrLn err
            return []
        Right charMap -> 
            return [convertRGBA8 charMap]

bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral

preloadRender :: IO RenderData
preloadRender = do
-- compile shader programs
    bs  <- makeSourcedShader "basic"      [VertexShader,FragmentShader]
    ts  <- makeSourcedShader "character"  [VertexShader,GeometryShader,FragmentShader]
    cs  <- makeSourcedShader "circle"     [VertexShader,GeometryShader,FragmentShader]
    as  <- makeSourcedShader "arc"        [VertexShader,GeometryShader,FragmentShader]
    fcs <- makeSourcedShader "fadeCircle" [VertexShader,GeometryShader,FragmentShader]
    bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
    wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]

    wssLightPosUniLoc   <- GL.uniformLocation (fst wss) "lightPos"

--the following vbo is set up to contain one fixed vertex
    dummyvbo <- genObjectName
    dummyptr <- mallocArray numDrawableElements
    pokeArray dummyptr [0..2000]
    bindBuffer ArrayBuffer $= Just dummyvbo
    bufferData ArrayBuffer $= (fromIntegral floatSize, dummyptr, StaticDraw)

-- load charmap as texture
--    Right cmap <- readImage "data/texture/smudgedDirt.png"
    Right cmap <- readImage "data/texture/charMap.png"
    let tex = convertRGBA8 cmap
    chartex <- genObjectName
    textureBinding Texture2D $= Just chartex
    let texData = V.toList $ imageData tex
        wtex = fromIntegral $ imageWidth  tex
        htex = fromIntegral $ imageHeight tex
    withArray texData $ \ptr -> do
        texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 
                        (PixelData RGBA UnsignedByte ptr)
    generateMipmap' Texture2D
    textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)

    Right cmap' <- readImage "data/texture/smudgedDirt.png"
    let dirt = convertRGBA8 cmap'
    dirttex <- genObjectName
    textureBinding Texture2D $= Just dirttex
    let texData' = V.toList $ imageData dirt
        wtex' = fromIntegral $ imageWidth  dirt
        htex' = fromIntegral $ imageHeight dirt
    withArray texData' $ \ptr -> do
        texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex' htex') 0 
                        (PixelData RGBA UnsignedByte ptr)
    generateMipmap' Texture2D
    textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)

    --textureBinding Texture2D $= Just chartex

-- input a list of (attribute location, attrib length) pairs
-- these will have buffers and pointers created
    trivao  <- setupVAO [(0,3),(1,4)]
    linevao <- setupVAO [(0,3),(1,4)]
    textvao <- setupVAO [(0,3),(1,4),(2,3)]
    circvao <- setupVAO [(0,3),(1,4),(2,1)]
    arcvao  <- setupVAO [(0,3),(1,4),(2,4)]
    backgroundvao 
            <- setupVAO [(0,4),(1,2)]
    wallvao <- setupVAO [(0,4),(1,4)]
    fadecircvao 
            <- setupVAO [(0,4)]
    
    return $ RenderData
        { -- _charMap      = convertRGBA8 cmap
         _textures = [chartex,dirttex]
        ,_basicShader  = bs
        , _textShader   = ts
        , _circShader = cs
        , _arcShader = as
        , _fadeCircleShader = fcs
        , _backShader = bgs
        , _wallShadowShader = wss
        , _triVAO  = trivao
        , _textVAO = textvao
        , _circVAO = circvao
        , _arcVAO  = arcvao
        , _lineVAO = linevao
        , _backVAO = backgroundvao
        , _wallVAO = wallvao
        , _fadeCircVAO = fadecircvao
        , _dummyVBO = dummyvbo
        , _dummyPtr = dummyptr
        , _wssLightPos = wssLightPosUniLoc
        }

vaoPointers :: VAO -> [Ptr Float]
vaoPointers = (\(_,ps,_) -> ps) . unzip3 . _vaoBufferTargets

cleanUpRenderPreload :: RenderData -> IO ()
cleanUpRenderPreload pd = do
    mapM_ free $ vaoPointers $ _triVAO  pd
    mapM_ free $ vaoPointers $ _textVAO pd
    mapM_ free $ vaoPointers $ _circVAO pd
    mapM_ free $ vaoPointers $ _arcVAO  pd
    mapM_ free $ vaoPointers $ _lineVAO pd
    free $ _dummyPtr pd