200 lines
6.0 KiB
Haskell
200 lines
6.0 KiB
Haskell
{-# 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 PreloadData = PreloadData
|
|
{ _charMap :: Image PixelRGBA8
|
|
-- , _textures :: [Image PixelRGBA8]
|
|
, _basicShader :: Program
|
|
, _textShader :: Program
|
|
, _circShader :: Program
|
|
, _arcShader :: Program
|
|
, _lineShader :: Program
|
|
, _fadeCircleShader :: Program
|
|
, _basicVAO :: VertexArrayObject
|
|
, _textVAO :: VertexArrayObject
|
|
, _circVAO :: VertexArrayObject
|
|
, _arcVAO :: VertexArrayObject
|
|
, _posVBO :: BufferObject
|
|
, _colVBO :: BufferObject
|
|
, _texVBO :: BufferObject
|
|
, _ptrPosVBO :: Ptr Float
|
|
, _ptrColVBO :: Ptr Float
|
|
, _ptrCharPos :: Ptr Float
|
|
, _ptrCharCol :: Ptr Float
|
|
, _ptrCharTex :: Ptr Float
|
|
, _ptrCircPos :: Ptr Float
|
|
, _ptrCircCol :: Ptr Float
|
|
, _ptrCircSca :: Ptr Float
|
|
, _ptrArcPos :: Ptr Float
|
|
, _ptrArcCol :: Ptr Float
|
|
, _ptrArcSca :: Ptr Float
|
|
, _ptrLinePos :: Ptr Float
|
|
, _ptrLineCol :: Ptr Float
|
|
, _uniWinSize :: UniformLocation
|
|
, _csZoomUni :: UniformLocation
|
|
, _asWinUni :: UniformLocation
|
|
, _asZoomUni :: UniformLocation
|
|
}
|
|
data VAO = VAO
|
|
{ _vao :: VertexArrayObject
|
|
, _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
|
|
}
|
|
|
|
makeLenses ''PreloadData
|
|
|
|
floatSize = sizeOf (0.5 :: GLfloat)
|
|
|
|
setupVAO :: [(BufferObject,GLuint,Int)] -> IO VertexArrayObject
|
|
setupVAO ps = do
|
|
theVAO <- genObjectName
|
|
bindVertexArrayObject $= Just theVAO
|
|
forM_ ps $ \(vbo,aloc,i) -> do
|
|
bindBuffer ArrayBuffer $= Just vbo
|
|
vertexAttribPointer (AttribLocation aloc) $=
|
|
( ToFloat
|
|
, VertexArrayDescriptor (fromIntegral i)
|
|
Float
|
|
(fromIntegral $ floatSize * i)
|
|
(bufferOffset 0)
|
|
)
|
|
vertexAttribArray (AttribLocation aloc) $= Enabled
|
|
return theVAO
|
|
|
|
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
|
|
|
|
doPreload' :: IO PreloadData
|
|
doPreload' = do
|
|
-- compile shader programs
|
|
bs <- makeBasicShader
|
|
ts <- makeTextureShader
|
|
cs <- makeCircleShader
|
|
as <- makeArcShader
|
|
fcs <- makeFadeShader
|
|
|
|
winSizeUni <- GL.uniformLocation cs "winSize"
|
|
zoomUni <- GL.uniformLocation cs "zoom"
|
|
asWinSizeUniLoc <- GL.uniformLocation as "winSize"
|
|
asZoomUniLoc <- GL.uniformLocation as "zoom"
|
|
-- get uniform locations
|
|
|
|
--setup vbos
|
|
--need to be bound before assigning the vertex attribute pointers
|
|
posVBO <- genObjectName
|
|
colVBO <- genObjectName
|
|
texVBO <- genObjectName
|
|
|
|
-- load charmap as texture
|
|
-- Right cmap <- readImage "data/texture/smudgedDirt.png"
|
|
Right cmap <- readImage "data/texture/charMap.png"
|
|
let tex = convertRGBA8 cmap
|
|
texo <- genObjectName
|
|
textureBinding Texture2D $= Just texo
|
|
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)
|
|
|
|
-- setup VAOs: basic vao
|
|
basicVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4)]
|
|
textVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,2)]
|
|
circVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,1)]
|
|
arcVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,4)]
|
|
|
|
-- allocate memory for vertex attributes
|
|
-- for triangles
|
|
ptrPosVBO <- mallocArray (3*3*20000)
|
|
ptrColVBO <- mallocArray (3*4*20000)
|
|
-- for characters
|
|
ptrCharPos <- mallocArray (3*20000)
|
|
ptrCharCol <- mallocArray (4*20000)
|
|
ptrCharTex <- mallocArray (2*20000)
|
|
-- for circles
|
|
ptrCircPos <- mallocArray (3*20000)
|
|
ptrCircCol <- mallocArray (4*20000)
|
|
ptrCircSca <- mallocArray (2*20000)
|
|
-- for lines
|
|
ptrLinePos <- mallocArray (3*20000)
|
|
ptrLineCol <- mallocArray (4*20000)
|
|
-- for arcs
|
|
ptrArcPos <- mallocArray (3*20000)
|
|
ptrArcCol <- mallocArray (4*20000)
|
|
ptrArcSca <- mallocArray (4*20000)
|
|
|
|
return $ PreloadData
|
|
{ _charMap = convertRGBA8 cmap
|
|
, _basicShader = bs
|
|
, _textShader = ts
|
|
, _circShader = cs
|
|
, _arcShader = as
|
|
, _fadeCircleShader = fcs
|
|
, _basicVAO = basicVAO
|
|
, _textVAO = textVAO
|
|
, _circVAO = circVAO
|
|
, _arcVAO = arcVAO
|
|
, _posVBO = posVBO
|
|
, _colVBO = colVBO
|
|
, _texVBO = texVBO
|
|
, _ptrPosVBO = ptrPosVBO
|
|
, _ptrColVBO = ptrColVBO
|
|
, _ptrCharPos = ptrCharPos
|
|
, _ptrCharCol = ptrCharCol
|
|
, _ptrCharTex = ptrCharTex
|
|
, _ptrCircPos = ptrCircPos
|
|
, _ptrCircCol = ptrCircCol
|
|
, _ptrCircSca = ptrCircSca
|
|
, _ptrArcPos = ptrArcPos
|
|
, _ptrArcCol = ptrArcCol
|
|
, _ptrArcSca = ptrArcSca
|
|
, _ptrLinePos = ptrLinePos
|
|
, _ptrLineCol = ptrLineCol
|
|
, _uniWinSize = winSizeUni
|
|
, _csZoomUni = zoomUni
|
|
, _asWinUni = asWinSizeUniLoc
|
|
, _asZoomUni = asZoomUniLoc
|
|
}
|
|
|
|
cleanUpPreload :: PreloadData -> IO ()
|
|
cleanUpPreload pd = do
|
|
free (_ptrPosVBO pd)
|
|
free (_ptrColVBO pd)
|
|
free (_ptrCharPos pd)
|
|
free (_ptrCharCol pd)
|
|
free (_ptrCharTex pd)
|
|
free (_ptrCircPos pd)
|
|
free (_ptrCircCol pd)
|
|
free (_ptrCircSca pd)
|
|
free (_ptrArcPos pd)
|
|
free (_ptrArcCol pd)
|
|
free (_ptrArcSca pd)
|