Add source files, commit before reverting pictures to lists
This commit is contained in:
@@ -0,0 +1,43 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
module Picture.Data
|
||||
where
|
||||
import Data.Monoid
|
||||
import qualified Data.DList as DL
|
||||
import Geometry.Data
|
||||
|
||||
import Control.Lens
|
||||
|
||||
type RGBA = (Float,Float,Float,Float)
|
||||
type Color = (Float,Float,Float,Float)
|
||||
|
||||
data Picture = Scene
|
||||
{ _scPosTri :: DL.DList Point3
|
||||
, _scColTri :: DL.DList RGBA
|
||||
, _scPosChar :: DL.DList Point3
|
||||
, _scColChar :: DL.DList RGBA
|
||||
, _scTexChar :: DL.DList Point2
|
||||
}
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = Scene DL.empty DL.empty DL.empty DL.empty DL.empty
|
||||
|
||||
combineScenes :: Picture -> Picture -> Picture
|
||||
{-# SCC combineScenes #-}
|
||||
--{-# INLINE combineScenes #-}
|
||||
combineScenes sa sb = Scene
|
||||
{ _scPosTri = _scPosTri sa <> _scPosTri sb
|
||||
, _scColTri = _scColTri sa <> _scColTri sb
|
||||
, _scPosChar = _scPosChar sa <> _scPosChar sb
|
||||
, _scColChar = _scColChar sa <> _scColChar sb
|
||||
, _scTexChar = _scTexChar sa <> _scTexChar sb
|
||||
}
|
||||
|
||||
instance Semigroup Picture where
|
||||
(<>) = combineScenes
|
||||
instance Monoid Picture where
|
||||
mempty = blank
|
||||
--mappend = combineScenes
|
||||
|
||||
makeLenses ''Picture
|
||||
@@ -0,0 +1,156 @@
|
||||
{-# 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 Foreign
|
||||
|
||||
import Shaders
|
||||
|
||||
data PreloadData = PreloadData
|
||||
{ _charMap :: Image PixelRGBA8
|
||||
-- , _textures :: [Image PixelRGBA8]
|
||||
, _basicShader :: Program
|
||||
, _textShader :: Program
|
||||
, _fadeCircleShader :: Program
|
||||
, _basicVAO :: VertexArrayObject
|
||||
, _textVAO :: VertexArrayObject
|
||||
, _posVBO :: BufferObject
|
||||
, _colVBO :: BufferObject
|
||||
, _texVBO :: BufferObject
|
||||
, _ptrPosVBO :: Ptr Float
|
||||
, _ptrColVBO :: Ptr Float
|
||||
, _ptrTexVBO :: Ptr Float
|
||||
}
|
||||
|
||||
makeLenses ''PreloadData
|
||||
|
||||
|
||||
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
|
||||
fcs <- makeFadeShader
|
||||
|
||||
--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)
|
||||
|
||||
let vertexSize = sizeOf (0.5 :: GLfloat)
|
||||
firstIndex = 0
|
||||
|
||||
-- setup VAOs: basic vao
|
||||
basicVAO <- genObjectName
|
||||
bindVertexArrayObject $= Just basicVAO
|
||||
|
||||
-- let posAttrib = AttribLocation 0
|
||||
-- colAttrib = AttribLocation 1
|
||||
bindBuffer ArrayBuffer $= Just posVBO
|
||||
vertexAttribPointer (AttribLocation 0) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
|
||||
(bufferOffset (firstIndex * vertexSize))
|
||||
)
|
||||
vertexAttribArray (AttribLocation 0) $= Enabled
|
||||
|
||||
bindBuffer ArrayBuffer $= Just colVBO
|
||||
vertexAttribPointer (AttribLocation 1) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
|
||||
(bufferOffset (firstIndex * vertexSize) )
|
||||
)
|
||||
vertexAttribArray (AttribLocation 1) $= Enabled
|
||||
|
||||
-- setup second vao
|
||||
textVAO <- genObjectName
|
||||
bindVertexArrayObject $= Just textVAO
|
||||
|
||||
bindBuffer ArrayBuffer $= Just posVBO
|
||||
vertexAttribPointer (AttribLocation 0) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
|
||||
(bufferOffset (firstIndex * vertexSize))
|
||||
)
|
||||
vertexAttribArray (AttribLocation 0) $= Enabled
|
||||
|
||||
bindBuffer ArrayBuffer $= Just colVBO
|
||||
vertexAttribPointer (AttribLocation 1) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
|
||||
(bufferOffset (firstIndex * vertexSize) )
|
||||
)
|
||||
vertexAttribArray (AttribLocation 1) $= Enabled
|
||||
|
||||
bindBuffer ArrayBuffer $= Just texVBO
|
||||
vertexAttribPointer (AttribLocation 2) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 2 Float (fromIntegral $ vertexSize * 2)
|
||||
(bufferOffset (firstIndex * vertexSize) )
|
||||
)
|
||||
vertexAttribArray (AttribLocation 2) $= Enabled
|
||||
|
||||
-- allocate memory for vertex attributes
|
||||
ptrPosVBO <- mallocArray (3*3*5000)
|
||||
ptrColVBO <- mallocArray (3*4*5000)
|
||||
ptrTexVBO <- mallocArray (3*2*5000)
|
||||
|
||||
return $ PreloadData
|
||||
{ _charMap = convertRGBA8 cmap
|
||||
, _basicShader = bs
|
||||
, _textShader = ts
|
||||
, _fadeCircleShader = fcs
|
||||
, _basicVAO = basicVAO
|
||||
, _textVAO = textVAO
|
||||
, _posVBO = posVBO
|
||||
, _colVBO = colVBO
|
||||
, _texVBO = texVBO
|
||||
, _ptrPosVBO = ptrPosVBO
|
||||
, _ptrColVBO = ptrColVBO
|
||||
, _ptrTexVBO = ptrTexVBO
|
||||
}
|
||||
|
||||
cleanUpPreload :: PreloadData -> IO ()
|
||||
cleanUpPreload pd = do
|
||||
free (_ptrPosVBO pd)
|
||||
free (_ptrColVBO pd)
|
||||
free (_ptrTexVBO pd)
|
||||
@@ -0,0 +1,96 @@
|
||||
{-# LANGUAGE Strict #-}
|
||||
module Picture.Render
|
||||
where
|
||||
import Control.Lens
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
import Picture.Preload
|
||||
--import Control.Lens
|
||||
|
||||
import Foreign
|
||||
|
||||
import Codec.Picture
|
||||
|
||||
import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth)
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import Data.Foldable
|
||||
import qualified Data.Vector.Storable as V
|
||||
import qualified Data.DList as DL
|
||||
|
||||
import Control.DeepSeq
|
||||
|
||||
concat34 :: (Point3,RGBA) -> [Float]
|
||||
concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a]
|
||||
|
||||
|
||||
toVec2 (x,y) = Vector2 x y
|
||||
toVec3 (x,y,z) = Vector3 x y z
|
||||
toVec4 (x,y,z,w) = Vector4 x y z w
|
||||
|
||||
flat2 (x,y) = DL.fromList [x,y]
|
||||
flat3 (x,y,z) = DL.fromList [x,y,z]
|
||||
flat4 (x,y,z,w) = DL.fromList [x,y,z,w]
|
||||
|
||||
mapFlat :: (NFData b) => (a -> DL.DList b) -> DL.DList a -> [b]
|
||||
mapFlat f = force . DL.toList . foldMap f
|
||||
|
||||
--marshallVs = V.unsafeWith . V.fromList
|
||||
--marshallVs = withArray
|
||||
|
||||
renderPicture' :: PreloadData -> Picture -> IO ()
|
||||
renderPicture' pdata (Scene posTri' colTri' posChar' colChar' texChar') = do
|
||||
let posTri = DL.toList posTri'
|
||||
colTri = DL.toList colTri'
|
||||
posChar = DL.toList posChar'
|
||||
colChar = DL.toList colChar'
|
||||
texChar = DL.toList texChar'
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let firstIndex = 0
|
||||
let vertices :: [Float]
|
||||
vertices = mapFlat flat3 posTri'
|
||||
numVertices = length vertices
|
||||
vertexSize = sizeOf (head vertices)
|
||||
pokeArray (_ptrPosVBO pdata) vertices
|
||||
bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
|
||||
-- marshallVs vertices $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
let colVs = mapFlat flat4 colTri'
|
||||
colVsize = sizeOf $ head colVs
|
||||
pokeArray (_ptrColVBO pdata) colVs
|
||||
bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), _ptrColVBO pdata, StreamDraw)
|
||||
-- marshallVs colVs $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
|
||||
|
||||
-- currentProgram $= Just (_textShader pdata)
|
||||
-- bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
-- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
-- let vertices' = mapFlat flat3 posChar'
|
||||
-- numVertices' = length vertices'
|
||||
-- vertexSize' = sizeOf $ head vertices'
|
||||
-- withArray vertices' $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * vertexSize'), ptr, StreamDraw)
|
||||
-- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
-- let colVsT = mapFlat flat4 colChar'
|
||||
-- colVsTsize = sizeOf $ head colVsT
|
||||
-- withArrayLen colVsT $ \numV' ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * colVsTsize), ptr, StreamDraw)
|
||||
-- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
-- let texVsT = mapFlat flat2 texChar'
|
||||
-- texVsTsize = sizeOf $ head texVsT
|
||||
-- withArrayLen texVsT $ \numV' ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * texVsTsize), ptr, StreamDraw)
|
||||
-- drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')
|
||||
|
||||
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
|
||||
zeroZ :: Point2 -> Point3
|
||||
zeroZ (x,y) = (x,y,0)
|
||||
Reference in New Issue
Block a user