Commit before unifying vertex type
This commit is contained in:
@@ -148,8 +148,6 @@ pokeBindFoldable
|
||||
-> IO (PicShads Int)
|
||||
pokeBindFoldable pdata m = do
|
||||
let shads = _pictureShaders pdata
|
||||
--counts = zeroCounts
|
||||
--elist <- foldM (pokeVX' shads) counts m
|
||||
elist <- pokeVerxs (fmap (_vaoVBO . _vshaderVAO) shads) m
|
||||
bindShader shads elist
|
||||
return elist
|
||||
@@ -163,11 +161,8 @@ pokeBindFoldableLayer
|
||||
-> IO (IM.IntMap (PicShads Int))
|
||||
pokeBindFoldableLayer pdata m = do
|
||||
let shads = _pictureShaders pdata
|
||||
|
||||
--slist'' <- fmap toIMLayers $ pokeLayVerxsFold (fmap (_vaoVBO . _vshaderVAO) shads) m
|
||||
slist'' <- pokeLayVerxsFold (fmap (_vaoVBO . _vshaderVAO) shads) m
|
||||
bindShaderLay shads slist''
|
||||
|
||||
return slist''
|
||||
|
||||
renderFoldable
|
||||
@@ -176,19 +171,15 @@ renderFoldable
|
||||
-> IO Word32
|
||||
renderFoldable pdata struct = do
|
||||
pokeStartTicks <- SDL.ticks
|
||||
|
||||
count <- pokeBindFoldable pdata struct
|
||||
let shads = _pictureShaders pdata
|
||||
|
||||
sequence_ (drawShaderLay 0 <$> shads <*> count)
|
||||
|
||||
pokeEndTicks <- SDL.ticks
|
||||
return $ pokeEndTicks - pokeStartTicks
|
||||
------------------------------end renderFoldable
|
||||
|
||||
renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
|
||||
renderLayer i shads counts = sequence_ $ drawShaderLay i <$> shads <*> counts IM.! i
|
||||
where
|
||||
|
||||
pokeTwoOff
|
||||
:: Ptr Float
|
||||
|
||||
+3
-23
@@ -1,9 +1,7 @@
|
||||
module Shader
|
||||
( bindShaderLayer
|
||||
, bindShaderLay
|
||||
( bindShaderLay
|
||||
, bindShaderBuffers
|
||||
, bindShader
|
||||
, bindArrayBuffers
|
||||
, drawShader
|
||||
, freeShaderPointers
|
||||
, drawShaderLay
|
||||
@@ -36,20 +34,8 @@ bindArrayBuffers numVs theVBO = do
|
||||
(fromIntegral $ floatSize * numVs * sum (_vboAttribSizes theVBO))
|
||||
(_vboPtr theVBO)
|
||||
|
||||
bindArrayBuffersLayer' :: Int -> Int -> VBO -> IO ()
|
||||
bindArrayBuffersLayer' lay numVs theVBO = do
|
||||
bindBuffer ArrayBuffer $= Just (_vbo theVBO)
|
||||
bufferSubData
|
||||
ArrayBuffer
|
||||
WriteToBuffer
|
||||
(fromIntegral $ floatSize * stride * numSubElements * lay)
|
||||
(fromIntegral $ floatSize * numVs * stride)
|
||||
(_vboPtr theVBO `plusPtr` (floatSize * stride * numSubElements * lay))
|
||||
where
|
||||
stride = sum $ _vboAttribSizes theVBO
|
||||
|
||||
bindArrayBuffersLayer :: Int -> Int -> VBO -> IO ()
|
||||
bindArrayBuffersLayer numVs lay theVBO = do
|
||||
bindArrayBuffersLayer lay numVs theVBO = do
|
||||
bindBuffer ArrayBuffer $= Just (_vbo theVBO)
|
||||
bufferSubData
|
||||
ArrayBuffer
|
||||
@@ -63,16 +49,10 @@ bindArrayBuffersLayer numVs lay theVBO = do
|
||||
bindShaderLay :: PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
|
||||
bindShaderLay shads = mapM_ (uncurry f) . IM.toList
|
||||
where
|
||||
f lay counts = sequence_ $ bindArrayBuffersLayer' lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
|
||||
f lay counts = sequence_ $ bindArrayBuffersLayer lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
|
||||
|
||||
bindShader :: PicShads VShader -> PicShads Int -> IO ()
|
||||
bindShader shads counts = sequence_ $ bindArrayBuffers <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
|
||||
--bindShader = mapM_ (uncurry (flip bindArrayBuffers) . first (_vaoVBO . _vshaderVAO))
|
||||
|
||||
bindShaderLayer :: [(Int,VShader)] -> [Int] -> IO ()
|
||||
bindShaderLayer = zipWithM_ f
|
||||
where
|
||||
f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _vshaderVAO fs
|
||||
|
||||
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
|
||||
bindShaderBuffers = zipWithM_ f
|
||||
|
||||
+25
-140
@@ -22,78 +22,32 @@ import Foreign
|
||||
import Control.Monad
|
||||
import qualified Control.Foldl as F
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
--import Control.Lens
|
||||
import qualified Data.Vector.Unboxed.Mutable as MV
|
||||
import Control.Monad.Primitive
|
||||
|
||||
pokeVerxs'' :: PicShads VBO -> [Verx] -> IO (PicShads Int)
|
||||
pokeVerxs'' vbos = F.foldM $ F.FoldM
|
||||
(\count vx -> pokeVerx vbos count vx >> return (addCountVerx count vx))
|
||||
(pure $ pure 0)
|
||||
return
|
||||
|
||||
pokeVerxs' :: PicShads VBO -> [Verx] -> IO (MV.MVector (PrimState IO) Int)
|
||||
pokeVerxs' vbos = F.foldM $ F.FoldM
|
||||
(\count vx -> pokeVerx' vbos count vx >> addCountVerx' count vx >> return count)
|
||||
(MV.replicate 6 0)
|
||||
return
|
||||
|
||||
pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
|
||||
pokeVerxs vbos = F.foldM $ F.FoldM
|
||||
(\count vx -> pokeVerx' vbos count vx >> addCountVerx' count vx >> return count)
|
||||
(\count vx -> pokeVerx vbos count vx >> addCountVerx count vx >> return count)
|
||||
(MV.replicate 6 0)
|
||||
vToPicShad
|
||||
|
||||
vToPicShad :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
|
||||
vToPicShad mv = mapM (MV.read mv) $ PicShads 0 1 2 3 4 5
|
||||
vToPicShad mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
|
||||
|
||||
--pokeVerxs vbos vxs0 = go vxs0 (pure 0)
|
||||
-- where
|
||||
-- go [] !count = return count
|
||||
-- go (!vx:vxs) !count = pokeVerx vbos count vx >> (go vxs $! addCountVerx count vx)
|
||||
|
||||
-- this is very brittle, but want to optimise speed if possible here
|
||||
pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO ()
|
||||
pokeVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
|
||||
{-# INLINE pokeVerx #-}
|
||||
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
|
||||
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) (_psPoly offsets * 7 * floatSize)) thePos theCol
|
||||
PolyzV x -> poke34 thePtr thePos theCol
|
||||
>> pokeElemOff thePtr 7 x
|
||||
where
|
||||
thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (_psPolyz offsets * 8 * floatSize)
|
||||
BezV (V4 x y z w) -> poke34 thePtr thePos theCol
|
||||
>> pokeElemOff thePtr 7 x
|
||||
>> pokeElemOff thePtr 8 y
|
||||
>> pokeElemOff thePtr 9 z
|
||||
>> pokeElemOff thePtr 10 w
|
||||
where
|
||||
thePtr = plusPtr (_vboPtr $ _psBez vbos) (_psBez offsets * 11 * floatSize)
|
||||
TextV (V2 x y) -> poke34 thePtr thePos theCol
|
||||
>> pokeElemOff thePtr 7 x
|
||||
>> pokeElemOff thePtr 8 y
|
||||
where
|
||||
thePtr = plusPtr (_vboPtr $ _psText vbos) (_psText offsets * 9 * floatSize)
|
||||
ArcV (V3 x y z) -> poke34 thePtr thePos theCol
|
||||
>> pokeElemOff thePtr 7 x
|
||||
>> pokeElemOff thePtr 8 y
|
||||
>> pokeElemOff thePtr 9 z
|
||||
where
|
||||
thePtr = plusPtr (_vboPtr $ _psArc vbos) (_psArc offsets * 10 * floatSize)
|
||||
EllV -> poke34 (plusPtr (_vboPtr $ _psEll vbos) (_psEll offsets * 7 * floatSize)) thePos theCol
|
||||
|
||||
pokeVerx' :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
|
||||
{-# INLINE pokeVerx' #-}
|
||||
pokeVerx' vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
|
||||
PolyV -> do
|
||||
typeOff <- MV.read offsets 0
|
||||
typeOff <- MV.unsafeRead offsets 0
|
||||
poke34 (plusPtr (_vboPtr $ _psPoly vbos) (typeOff * 7 * floatSize)) thePos theCol
|
||||
PolyzV x -> do
|
||||
typeOff <- MV.read offsets 1
|
||||
typeOff <- MV.unsafeRead offsets 1
|
||||
let thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (typeOff * 8 * floatSize)
|
||||
poke34 thePtr thePos theCol
|
||||
pokeElemOff thePtr 7 x
|
||||
BezV (V4 x y z w) -> do
|
||||
typeOff <- MV.read offsets 2
|
||||
typeOff <- MV.unsafeRead offsets 2
|
||||
let thePtr = plusPtr (_vboPtr $ _psBez vbos) (typeOff * 11 * floatSize)
|
||||
poke34 thePtr thePos theCol
|
||||
pokeElemOff thePtr 7 x
|
||||
@@ -101,20 +55,20 @@ pokeVerx' vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case
|
||||
pokeElemOff thePtr 9 z
|
||||
pokeElemOff thePtr 10 w
|
||||
TextV (V2 x y) -> do
|
||||
typeOff <- MV.read offsets 3
|
||||
typeOff <- MV.unsafeRead offsets 3
|
||||
let thePtr = plusPtr (_vboPtr $ _psText vbos) (typeOff * 9 * floatSize)
|
||||
poke34 thePtr thePos theCol
|
||||
pokeElemOff thePtr 7 x
|
||||
pokeElemOff thePtr 8 y
|
||||
ArcV (V3 x y z) -> do
|
||||
typeOff <- MV.read offsets 4
|
||||
typeOff <- MV.unsafeRead offsets 4
|
||||
let thePtr = plusPtr (_vboPtr $ _psArc vbos) (typeOff * 10 * floatSize)
|
||||
poke34 thePtr thePos theCol
|
||||
pokeElemOff thePtr 7 x
|
||||
pokeElemOff thePtr 8 y
|
||||
pokeElemOff thePtr 9 z
|
||||
EllV -> do
|
||||
typeOff <- MV.read offsets 5
|
||||
typeOff <- MV.unsafeRead offsets 5
|
||||
poke34 (plusPtr (_vboPtr $ _psEll vbos) (typeOff * 7 * floatSize)) thePos theCol
|
||||
|
||||
poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
|
||||
@@ -128,26 +82,9 @@ poke34 ptr (V3 a b c) (V4 d e f g) = do
|
||||
pokeElemOff ptr 5 f
|
||||
pokeElemOff ptr 6 g
|
||||
|
||||
addCountVerx :: PicShads Int -> Verx -> PicShads Int
|
||||
addCountVerx :: MV.MVector (PrimState IO) Int -> Verx -> IO ()
|
||||
{-# INLINE addCountVerx #-}
|
||||
addCountVerx !ps@PicShads
|
||||
{ _psPoly = sPoly
|
||||
, _psPolyz = sPolyz
|
||||
, _psBez = sBez
|
||||
, _psText = sText
|
||||
, _psArc = sArc
|
||||
, _psEll = sEll
|
||||
} !Verx{_vxType=theType} = case theType of
|
||||
PolyV -> ps {_psPoly = sPoly + 1}
|
||||
PolyzV _ -> ps {_psPolyz = sPolyz + 1}
|
||||
BezV _ -> ps {_psBez = sBez + 1}
|
||||
TextV _ -> ps {_psText = sText + 1}
|
||||
ArcV _ -> ps {_psArc = sArc + 1}
|
||||
EllV -> ps {_psEll = sEll + 1}
|
||||
|
||||
addCountVerx' :: MV.MVector (PrimState IO) Int -> Verx -> IO ()
|
||||
{-# INLINE addCountVerx' #-}
|
||||
addCountVerx' v !Verx{_vxType=theType} = case theType of
|
||||
addCountVerx v !Verx{_vxType=theType} = case theType of
|
||||
PolyV -> MV.unsafeModify v (+ 1) 0
|
||||
PolyzV _ -> MV.unsafeModify v (+ 1) 1
|
||||
BezV _ -> MV.unsafeModify v (+ 1) 2
|
||||
@@ -187,43 +124,23 @@ pokePoint3s ptr vals0 = go vals0 0
|
||||
where
|
||||
off i = n*3 + i
|
||||
|
||||
comLayVerx :: PicShads VBO -> IM.IntMap (PicShads Int) -> Verx -> IO (IM.IntMap (PicShads Int))
|
||||
comLayVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO (MV.MVector (PrimState IO) Int)
|
||||
--{-# INLINE comLayVerx #-}
|
||||
comLayVerx vbos counts vx = do
|
||||
poke34 thePtr thePos theCol
|
||||
pokeVerxType thePtr theType
|
||||
return $ addLayCountVerx counts theLayer theType
|
||||
where
|
||||
theLayer = _vxLayer vx
|
||||
layCounts = counts IM.! theLayer
|
||||
theType = _vxType vx
|
||||
thePos = _vxPos vx
|
||||
theCol = _vxCol vx
|
||||
basePtr = _vboPtr $ vboFromType vbos theType
|
||||
layOff = theLayer * numSubElements
|
||||
thePtr = plusPtr basePtr ((intFromType layCounts theType + layOff) * theStride * floatSize)
|
||||
theStride = pokeStride theType
|
||||
|
||||
comLayVerx' :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO (MV.MVector (PrimState IO) Int)
|
||||
--{-# INLINE comLayVerx #-}
|
||||
comLayVerx' vbos counts vx = do
|
||||
theOff <- MV.read counts vecPos
|
||||
theOff <- MV.unsafeRead counts vecPos
|
||||
let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
|
||||
poke34 thePtr thePos theCol
|
||||
pokeVerxType thePtr theType
|
||||
MV.unsafeModify counts (+ 1) vecPos
|
||||
--return $ addLayCountVerx counts theLayer theType
|
||||
return counts
|
||||
where
|
||||
vecPos = theLayer * 6 + typeInt theType
|
||||
theLayer = _vxLayer vx
|
||||
--layCounts = counts IM.! theLayer
|
||||
theType = _vxType vx
|
||||
thePos = _vxPos vx
|
||||
theCol = _vxCol vx
|
||||
basePtr = _vboPtr $ vboFromType vbos theType
|
||||
layOff = theLayer * numSubElements
|
||||
--thePtr = plusPtr basePtr ((intFromType layCounts theType + layOff) * theStride * floatSize)
|
||||
theStride = pokeStride theType
|
||||
|
||||
pokeVerxType :: Ptr Float -> VertexType -> IO ()
|
||||
@@ -246,15 +163,15 @@ typeInt vt = case vt of
|
||||
ArcV{} -> 4
|
||||
EllV -> 5
|
||||
|
||||
intFromType :: PicShads Int -> VertexType -> Int
|
||||
{-# INLINE intFromType #-}
|
||||
intFromType ps vt = case vt of
|
||||
PolyV -> _psPoly ps
|
||||
PolyzV{} -> _psPolyz ps
|
||||
BezV{} -> _psBez ps
|
||||
TextV{} -> _psText ps
|
||||
ArcV{} -> _psArc ps
|
||||
EllV -> _psEll ps
|
||||
--intFromType :: PicShads Int -> VertexType -> Int
|
||||
--{-# INLINE intFromType #-}
|
||||
--intFromType ps vt = case vt of
|
||||
-- PolyV -> _psPoly ps
|
||||
-- PolyzV{} -> _psPolyz ps
|
||||
-- BezV{} -> _psBez ps
|
||||
-- TextV{} -> _psText ps
|
||||
-- ArcV{} -> _psArc ps
|
||||
-- EllV -> _psEll ps
|
||||
|
||||
vboFromType :: PicShads VBO -> VertexType -> VBO
|
||||
{-# INLINE vboFromType #-}
|
||||
@@ -266,34 +183,18 @@ vboFromType ps vt = case vt of
|
||||
ArcV{} -> _psArc ps
|
||||
EllV -> _psEll ps
|
||||
|
||||
pokeLayVerxsFold'' :: PicShads VBO -> [Verx] -> IO (IM.IntMap (PicShads Int))
|
||||
pokeLayVerxsFold'' vbos = F.foldM $ F.FoldM
|
||||
(comLayVerx vbos)
|
||||
(return $ imLayers 0)
|
||||
return
|
||||
|
||||
pokeLayVerxsFold' :: PicShads VBO -> [Verx] -> IO (MV.MVector (PrimState IO) Int)
|
||||
pokeLayVerxsFold' vbos = F.foldM $ F.FoldM
|
||||
(comLayVerx' vbos)
|
||||
(MV.replicate (6*6) 0)
|
||||
return
|
||||
|
||||
pokeLayVerxsFold :: PicShads VBO -> [Verx] -> IO (IM.IntMap (PicShads Int))
|
||||
pokeLayVerxsFold vbos = F.foldM $ F.FoldM
|
||||
(comLayVerx' vbos)
|
||||
(comLayVerx vbos)
|
||||
(MV.replicate (6*6) 0)
|
||||
vToLayPicShad
|
||||
|
||||
vToLayPicShad :: MV.MVector RealWorld Int -> IO (IM.IntMap (PicShads Int))
|
||||
vToLayPicShad mv = foldM f IM.empty [0..5]
|
||||
where
|
||||
f m i = fmap (\ps -> IM.insert i ps m) (vToPicShad $ MV.unsafeSlice (i * 6) 6 mv)
|
||||
|
||||
imLayers :: a -> IM.IntMap (PicShads a)
|
||||
{-# INLINE imLayers #-}
|
||||
imLayers x = IM.fromList $ zip [0..5] $ repeat ps
|
||||
where
|
||||
ps = pure x
|
||||
|
||||
pokeStride :: VertexType -> Int
|
||||
{-# INLINE pokeStride #-}
|
||||
pokeStride PolyV = 7
|
||||
@@ -303,22 +204,6 @@ pokeStride TextV{} = 9
|
||||
pokeStride ArcV{} = 10
|
||||
pokeStride EllV = 7
|
||||
|
||||
addLayCountVerx :: IM.IntMap (PicShads Int) -> Int -> VertexType -> IM.IntMap (PicShads Int)
|
||||
{-# INLINE addLayCountVerx #-}
|
||||
addLayCountVerx m lay vt = case vt of
|
||||
PolyV -> m & ix lay . psPoly +~ 1
|
||||
PolyzV _ -> m & ix lay . psPolyz +~ 1
|
||||
BezV _ -> m & ix lay . psBez +~ 1
|
||||
TextV _ -> m & ix lay . psText +~ 1
|
||||
ArcV _ -> m & ix lay . psArc +~ 1
|
||||
EllV -> m & ix lay . psEll +~ 1
|
||||
--PolyV -> IM.adjust (psPoly +~ 1) lay m
|
||||
--PolyzV _ -> IM.adjust (psPolyz +~ 1) lay m
|
||||
--BezV _ -> IM.adjust (psBez +~ 1) lay m
|
||||
--TextV _ -> IM.adjust (psText +~ 1) lay m
|
||||
--ArcV _ -> IM.adjust (psArc +~ 1) lay m
|
||||
--EllV -> IM.adjust (psEll +~ 1) lay m
|
||||
|
||||
poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
|
||||
poke224s ptr vals0 = go vals0 0
|
||||
where
|
||||
|
||||
Reference in New Issue
Block a user