240 lines
7.4 KiB
Haskell
240 lines
7.4 KiB
Haskell
module Shader.Poke
|
|
( pokeVerxs
|
|
, pokeLayVerxs
|
|
, pokeArrayOff
|
|
, pokeShape
|
|
, pokeWallsWindowsFloor
|
|
, memoTopPrismEdgeIndices
|
|
) where
|
|
import Geometry.Polygon
|
|
import Shader.Data
|
|
import Shader.Parameters
|
|
import Picture.Data
|
|
import Shape.Data
|
|
import Geometry.Data
|
|
import Control.Monad
|
|
--import ShapePicture
|
|
|
|
import Graphics.GL.Core45
|
|
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 VFSM
|
|
--import Data.Vector.Fusion.Util
|
|
import Control.Monad.Primitive
|
|
--import qualified Control.Monad.Parallel as MP
|
|
|
|
pokeVerxs
|
|
:: MV.MVector (PrimState IO) (FullShader,VBO)
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> Picture
|
|
-> IO ()
|
|
--pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count) . S.each
|
|
pokeVerxs vbos count = VFSM.mapM_ (pokeVerx vbos count) . VFSM.fromList
|
|
|
|
pokeVerx :: MV.MVector (PrimState IO) (FullShader,VBO) -> 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 . snd <$> 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
|
|
-> [ ( (Point2,Point2) , Point4 ) ]
|
|
-> [ ( (Point2,Point2) , Point4 ) ]
|
|
-> [ ( Point3 , Point3 ) ]
|
|
-> IO (Int,Int,Int)
|
|
pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do
|
|
wlcounts1 <- VFSM.foldlM' (pokeW wlptr) 0 (VFSM.fromList wls)
|
|
wlcounts2 <- VFSM.foldlM' (pokeW wiptr) 0 (VFSM.fromList wis)
|
|
flcounts <- VFSM.foldlM' (pokeF flptr) 0 (VFSM.fromList fls)
|
|
return (wlcounts1,wlcounts2,flcounts)
|
|
|
|
pokeF :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
|
|
pokeF ptr i' (V3 a b c,V3 d e f) = do
|
|
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
|
|
return $ i' + 1
|
|
|
|
pokeW :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
|
|
pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
|
|
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
|
|
return $ i' + 1
|
|
|
|
pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort
|
|
-> (Int,Int,Int)
|
|
-> [Surface]
|
|
-> IO (Int,Int,Int)
|
|
pokeShape ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj ptr iptr ieptr) is . VFSM.fromList
|
|
|
|
pokeShapeObj
|
|
:: Ptr Float
|
|
-> Ptr GLushort
|
|
-> Ptr GLushort
|
|
-> (Int,Int,Int)
|
|
-> Surface
|
|
-> IO (Int,Int,Int)
|
|
{-# INLINE pokeShapeObj #-}
|
|
pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
|
|
TopPrism size -> pokeTopPrism midp col (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
|
|
-- TopCylinder size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
|
|
where
|
|
midp = centroidNum shVerts
|
|
|
|
pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort
|
|
-> Ptr GLushort
|
|
-> (Int,Int,Int)
|
|
-> VFSM.Stream IO Point3
|
|
-> IO (Int,Int,Int)
|
|
{-# INLINE pokeTopPrism #-}
|
|
pokeTopPrism cp col size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
|
|
nv' <- VFSM.foldlM' (pokeJustV cp col ptr) nv svs
|
|
nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices
|
|
(memoTopPrismIndices V.! size)
|
|
nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
|
|
(memoTopPrismEdgeIndices V.! size)
|
|
return (nv', nshapeindices', nedgeindices')
|
|
|
|
pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
|
|
-> Int
|
|
-> Int
|
|
-> IO Int
|
|
--{-# INLINE pokeTopPrismEdgeIndex #-}
|
|
pokeTopPrismEdgeIndex nv eiptr nedgeindices ioff = do
|
|
pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff)
|
|
return $ nedgeindices + 1
|
|
|
|
pokeTopPrismIndex :: Int -> Ptr GLushort
|
|
-> Int
|
|
-> Int
|
|
-> IO Int
|
|
--{-# INLINE pokeTopPrismIndex #-}
|
|
pokeTopPrismIndex nv iptr nshapeindices ioff = do
|
|
pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
|
|
return $ nshapeindices + 1
|
|
|
|
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
|
|
memoTopPrismEdgeIndices = V.generate 10
|
|
$ UV.fromList . topPrismEdgeIndices . (+ 2)
|
|
|
|
memoTopPrismIndices :: V.Vector (UV.Vector Int)
|
|
memoTopPrismIndices = V.generate 10
|
|
$ UV.fromList . topPrismIndices . (+ 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]
|
|
|
|
-- consider changing the position to a vec4
|
|
-- and just doing two pokes rather than seven
|
|
-- (especially if adding normal data)
|
|
pokeJustV :: Point3
|
|
-> Point4
|
|
-> Ptr Float
|
|
-> Int
|
|
-> Point3
|
|
-> IO Int
|
|
{-# INLINE pokeJustV #-}
|
|
pokeJustV cp col ptr nv sh = do
|
|
zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1]
|
|
return (nv + 1)
|
|
where
|
|
f i = pokeElemOff ptr (nv*nShapeVerxComp + i)
|
|
V3 x y z = sh
|
|
V4 r g b a = col
|
|
V3 nx ny nz = cp
|
|
|
|
pokeLayVerxs
|
|
:: MV.MVector (PrimState IO) (FullShader ,VBO)
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> Picture
|
|
-> IO ()
|
|
--pokeLayVerxs vbos counts = S.mapM_ (pokeLayVerx vbos counts) . S.each
|
|
pokeLayVerxs vbos counts = VFSM.mapM_ (pokeLayVerx vbos counts) . VFSM.fromList
|
|
|
|
pokeLayVerx :: MV.MVector (PrimState IO) (FullShader,VBO) -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
|
|
--{-# INLINE pokeLayVerx #-}
|
|
pokeLayVerx vbos counts vx = do
|
|
theOff <- UMV.unsafeRead counts vecPos
|
|
basePtr <- _vboPtr . snd <$> 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 * numLayers + sn
|
|
theLayer = layerNum $ _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))
|