247 lines
7.5 KiB
Haskell
247 lines
7.5 KiB
Haskell
module Shader.Poke
|
|
( pokeVerxs
|
|
, pokeLayVerxs
|
|
, pokeArrayOff
|
|
, pokePoint33s
|
|
, pokeShape
|
|
, pokeWallsWindowsFloor
|
|
) where
|
|
import Shader.Data
|
|
import Shader.Parameters
|
|
import Picture.Data
|
|
import Shape.Data
|
|
import Geometry.Data
|
|
|
|
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
|
|
import Foreign
|
|
import qualified Data.Vector as V
|
|
import qualified Data.Vector.Unboxed as UV
|
|
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
|
|
-> Picture
|
|
-> 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 . _shadVAO <$> MV.unsafeRead 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
|
|
|
|
pokeWallsWindowsFloor
|
|
:: Ptr Float
|
|
-> Ptr Float
|
|
-> Ptr Float
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> [ ( (Point2,Point2) , Point4 ) ]
|
|
-> [ ( (Point2,Point2) , Point4 ) ]
|
|
-> [ ( Point3 , Point3 ) ]
|
|
-> IO ()
|
|
pokeWallsWindowsFloor wlptr wiptr flptr counts wls wis fls = do
|
|
VS.mapM_ (pokeW wlptr counts 0) (VS.fromList wls)
|
|
VS.mapM_ (pokeW wiptr counts 1) (VS.fromList wis)
|
|
VS.mapM_ (pokeF flptr counts) (VS.fromList fls)
|
|
|
|
pokeF :: Ptr Float -> UMV.MVector (PrimState IO) Int -> (Point3,Point3) -> IO ()
|
|
pokeF ptr counts (V3 a b c,V3 d e f) = do
|
|
i' <- UMV.unsafeRead counts 2
|
|
let i = i' * 6
|
|
pokeElemOff ptr (i + 0) a
|
|
pokeElemOff ptr (i + 1) b
|
|
pokeElemOff ptr (i + 2) c
|
|
pokeElemOff ptr (i + 3) d
|
|
pokeElemOff ptr (i + 4) e
|
|
pokeElemOff ptr (i + 5) f
|
|
UMV.unsafeModify counts (+1) 2
|
|
|
|
pokeW :: Ptr Float -> UMV.MVector (PrimState IO) Int -> Int -> ((Point2,Point2),Point4) -> IO ()
|
|
pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
|
|
i' <- UMV.unsafeRead counts iv
|
|
let i = i' * 8
|
|
pokeElemOff ptr (i + 0) a
|
|
pokeElemOff ptr (i + 1) b
|
|
pokeElemOff ptr (i + 2) c
|
|
pokeElemOff ptr (i + 3) d
|
|
pokeElemOff ptr (i + 4) e
|
|
pokeElemOff ptr (i + 5) f
|
|
pokeElemOff ptr (i + 6) g
|
|
pokeElemOff ptr (i + 7) h
|
|
UMV.unsafeModify counts (+1) iv
|
|
|
|
pokeShape
|
|
:: Ptr Float
|
|
-> Ptr GLushort
|
|
-> Ptr GLushort
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> [ShapeObj]
|
|
-> IO ()
|
|
pokeShape ptr iptr ieptr counts = VS.mapM_ (pokeShapeObj ptr iptr ieptr counts) . VS.fromList
|
|
|
|
pokeShapeObj
|
|
:: Ptr Float
|
|
-> Ptr GLushort
|
|
-> Ptr GLushort
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> ShapeObj
|
|
-> IO ()
|
|
pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
|
|
TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts
|
|
|
|
pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
|
|
-> Ptr GLushort
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> [ShapeV]
|
|
-> IO ()
|
|
pokeTopPrism size ptr iptr ieptr counts svs = do
|
|
nv <- UMV.unsafeRead counts 0
|
|
-- MP.bindM3 (\_ _ _ -> return ())
|
|
UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! size)
|
|
UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size)
|
|
VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs)
|
|
|
|
pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> Int
|
|
-> IO ()
|
|
pokeTopPrismEdgeIndex nv eiptr counts ioff = do
|
|
nei <- UMV.unsafeRead counts 2
|
|
pokeElemOff eiptr nei (fromIntegral $ nv + ioff)
|
|
UMV.unsafeModify counts (+1) 2
|
|
|
|
pokeTopPrismIndex :: Int -> Ptr GLushort
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> Int
|
|
-> IO ()
|
|
pokeTopPrismIndex nv iptr counts ioff = do
|
|
ni <- UMV.unsafeRead counts 1
|
|
pokeElemOff iptr ni (fromIntegral $ nv + ioff)
|
|
UMV.unsafeModify counts (+1) 1
|
|
|
|
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
|
|
memoTopPrismEdgeIndices = V.generate 10 f
|
|
where
|
|
f n = UV.fromList $ topPrismEdgeIndices (n + 2)
|
|
|
|
memoTopPrismIndices :: V.Vector (UV.Vector Int)
|
|
memoTopPrismIndices = V.generate 10 f
|
|
where
|
|
f n = UV.fromList $ topPrismIndices (n + 2)
|
|
|
|
topPrismEdgeIndices :: Int -> [Int]
|
|
topPrismEdgeIndices n = concatMap f [0..n-1]
|
|
where
|
|
f i = map g
|
|
[ 0 , 2 , 1 , 4
|
|
, 0 , 1 ,-2 , 3
|
|
, 1 , 3 ,-1 , 2
|
|
]
|
|
where
|
|
g j = (2 * i + j) `mod` (2*n)
|
|
|
|
topPrismIndices :: Int -> [Int]
|
|
topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
|
|
++ concatMap f' [1..n-2] -- triangles on bottom face
|
|
-- these should be checked
|
|
++ [2*n-2,2*n-1,1
|
|
,2*n-2,1,0] -- last side triangle (applies mod 2n)
|
|
++ concatMap g [0..n-2] -- other triangles on sides
|
|
where
|
|
f x = [0,2*x,2*x+2]
|
|
f' x = [1,2*x+3,2*x+1]
|
|
g x = [2*x,2*x+1,2*x+3
|
|
,2*x,2*x+3,2*x+2]
|
|
|
|
pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO ()
|
|
pokeJustV ptr counts sh = do
|
|
nv <- UMV.unsafeRead counts 0
|
|
let off i = nv*7 + i
|
|
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
|
|
UMV.unsafeModify counts (+1) 0
|
|
where
|
|
V3 a b c = _svPos sh
|
|
V4 d e f g = _svCol sh
|
|
|
|
pokeLayVerxs
|
|
:: MV.MVector (PrimState IO) FullShader
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> Picture
|
|
-> IO ()
|
|
pokeLayVerxs vbos counts = VS.mapM_ (pokeLayVerx vbos counts) . VS.fromList
|
|
|
|
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 . _shadVAO <$> 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 = VS.foldlM' (pokePoint33 ptr) 0 . VS.fromList
|
|
|
|
pokePoint33 :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
|
|
pokePoint33 ptr n (V3 a b c,V3 d e f) = 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
|
|
return (n+1)
|
|
where
|
|
off i = n*6 + i
|
|
|