134 lines
3.8 KiB
Haskell
134 lines
3.8 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
module Shader.Poke
|
|
( pokeVerxs
|
|
, pokeLayVerxs
|
|
, pokeArrayOff
|
|
, pokePoint3s
|
|
, pokePoint33s
|
|
, poke224s
|
|
) where
|
|
import Shader.Data
|
|
import Shader.Parameters
|
|
import Picture.Data
|
|
import Geometry.Data
|
|
|
|
import Foreign
|
|
import qualified Data.Vector.Unboxed.Mutable as UMV
|
|
import qualified Data.Vector.Mutable as MV
|
|
import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
|
import Control.Monad.Primitive
|
|
|
|
pokeVerxs
|
|
:: MV.MVector (PrimState IO) FullShader
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> [Verx]
|
|
-> IO ()
|
|
pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs
|
|
|
|
pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
|
|
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
|
|
typeOff <- UMV.unsafeRead offsets sn
|
|
basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.read vbos sn
|
|
let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
|
|
poke34 thePtr thePos theCol
|
|
pokeArrayOff thePtr 7 ext
|
|
UMV.unsafeModify offsets (+1) sn
|
|
where
|
|
sn = _unShadNum theShadNum
|
|
|
|
pokeLayVerxs
|
|
:: MV.MVector (PrimState IO) FullShader
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> [Verx]
|
|
-> IO ()
|
|
pokeLayVerxs vbos counts vxs = VS.mapM_ (pokeLayVerx vbos counts) $ VS.fromList vxs
|
|
|
|
pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
|
|
--{-# INLINE pokeLayVerx #-}
|
|
pokeLayVerx vbos counts vx = do
|
|
theOff <- UMV.unsafeRead counts vecPos
|
|
basePtr <- _vboPtr . _vaoVBO . _shaderVAO <$> MV.unsafeRead vbos sn
|
|
let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
|
|
poke34 thePtr thePos theCol
|
|
pokeArrayOff thePtr 7 (_vxExt vx)
|
|
UMV.unsafeModify counts (+ 1) vecPos
|
|
where
|
|
sn = _unShadNum (_vxShadNum vx)
|
|
vecPos = theLayer * 6 + sn
|
|
theLayer = _vxLayer vx
|
|
thePos = _vxPos vx
|
|
theCol = _vxCol vx
|
|
layOff = theLayer * numSubElements
|
|
theStride = pokeStride sn
|
|
|
|
pokeStride :: Int -> Int
|
|
{-# INLINE pokeStride #-}
|
|
pokeStride 0 = 7
|
|
pokeStride 1 = 8
|
|
pokeStride 2 = 11
|
|
pokeStride 3 = 9
|
|
pokeStride 4 = 10
|
|
pokeStride 5 = 7
|
|
pokeStride _ = undefined
|
|
|
|
|
|
poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
|
|
{-# INLINE poke34 #-}
|
|
poke34 ptr (V3 a b c) (V4 d e f g) = do
|
|
pokeElemOff ptr 0 a
|
|
pokeElemOff ptr 1 b
|
|
pokeElemOff ptr 2 c
|
|
pokeElemOff ptr 3 d
|
|
pokeElemOff ptr 4 e
|
|
pokeElemOff ptr 5 f
|
|
pokeElemOff ptr 6 g
|
|
|
|
pokeArrayOff :: Ptr Float -> Int -> [Float] -> IO ()
|
|
{-# INLINE pokeArrayOff #-}
|
|
pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))
|
|
|
|
pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
|
|
pokePoint33s ptr vals0 = go vals0 0
|
|
where
|
|
go [] n = return n
|
|
go ( (V3 a b c,V3 d e f):vals) !n = do
|
|
pokeElemOff ptr (off 0) a
|
|
pokeElemOff ptr (off 1) b
|
|
pokeElemOff ptr (off 2) c
|
|
pokeElemOff ptr (off 3) d
|
|
pokeElemOff ptr (off 4) e
|
|
pokeElemOff ptr (off 5) f
|
|
go vals (n+1)
|
|
where
|
|
off i = n*6 + i
|
|
|
|
pokePoint3s :: Ptr Float -> [Point3] -> IO Int
|
|
pokePoint3s ptr vals0 = go vals0 0
|
|
where
|
|
go [] n = return n
|
|
go ( V3 a b c:vals) !n = do
|
|
pokeElemOff ptr (off 0) a
|
|
pokeElemOff ptr (off 1) b
|
|
pokeElemOff ptr (off 2) c
|
|
go vals (n+1)
|
|
where
|
|
off i = n*3 + i
|
|
|
|
poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
|
|
poke224s ptr vals0 = go vals0 0
|
|
where
|
|
go [] n = return n
|
|
go (((V2 a b,V2 c d),V4 e f g h):vals) !n = do
|
|
pokeElemOff ptr (off 0) a
|
|
pokeElemOff ptr (off 1) b
|
|
pokeElemOff ptr (off 2) c
|
|
pokeElemOff ptr (off 3) d
|
|
pokeElemOff ptr (off 4) e
|
|
pokeElemOff ptr (off 5) f
|
|
pokeElemOff ptr (off 6) g
|
|
pokeElemOff ptr (off 7) h
|
|
go vals (n+1)
|
|
where
|
|
off i = n*8 + i
|