justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity
Files
14f3c8bc5286293d53701b5c509bbf94883b0785
loop/src/Shader/Poke.hs
T

274 lines
8.5 KiB
Haskell
Raw Blame History

module Shader.Poke
( pokeVerxs
-- , pokeSPics
, pokeLayVerxs
, pokeArrayOff
-- , pokePoint33s
, pokeShape
, pokeShape'
, pokeWallsWindowsFloor
) where
import Shader.Data
import Shader.Parameters
import Picture.Data
import Shape.Data
import Geometry.Data
--import ShapePicture
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 Data.Vector.Fusion.Util
import Control.Monad.Primitive
--import qualified Control.Monad.Parallel as MP
import qualified Streaming.Prelude as S
import Streaming
pokeVerxs
:: MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int
-> Picture
-> IO ()
pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count) . S.each
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
-> [ ( (Point2,Point2) , Point4 ) ]
-> [ ( (Point2,Point2) , Point4 ) ]
-> [ ( Point3 , Point3 ) ]
-> IO (Int,Int,Int)
pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do
wlcounts1 <- S.foldM_ (pokeW wlptr) (return 0) return (S.each wls)
wlcounts2 <- S.foldM_ (pokeW wiptr) (return 0) return (S.each wis)
flcounts <- S.foldM_ (pokeF flptr) (return 0) return (S.each 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
--pokeSPics
-- :: MV.MVector (PrimState IO) FullShader
-- -> UMV.MVector (PrimState IO) Int
-- -> Ptr Float -> Ptr GLushort -> Ptr GLushort
-- -> Stream (Of SPic) IO ()
-- -> IO (Int,Int,Int)
--pokeSPics vbos counts ptr iptr ieptr =
-- S.foldM_ (\is (sh,pic) -> pokeLayVerxs vbos counts pic >> pokeShape' ptr iptr ieptr is sh)
-- (return (0,0,0)) return
pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort
-> Stream (Of ShapeObj) IO ()
-> IO (Int,Int,Int)
pokeShape ptr iptr ieptr = S.foldM_ (pokeShapeObj ptr iptr ieptr) (return (0,0,0)) return
--pokeShape' :: Ptr Float -> Ptr GLushort -> Ptr GLushort
-- -> (Int,Int,Int)
-- -> Stream (Of ShapeObj) IO ()
-- -> IO (Int,Int,Int)
--pokeShape' ptr iptr ieptr is = S.foldM_ (pokeShapeObj ptr iptr ieptr) (return is) return
--
pokeShape' :: Ptr Float -> Ptr GLushort -> Ptr GLushort
-> (Int,Int,Int)
-> [ShapeObj]
-> IO (Int,Int,Int)
pokeShape' ptr iptr ieptr is = S.foldM_ (pokeShapeObj ptr iptr ieptr) (return is) return . S.each
pokeShapeObj
:: Ptr Float
-> Ptr GLushort
-> Ptr GLushort
-> (Int,Int,Int)
-> ShapeObj
-> IO (Int,Int,Int)
{-# INLINE pokeShapeObj #-}
pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of
TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts (S.each shVerts)
pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
-> Ptr GLushort
-> (Int,Int,Int)
-> Stream (Of ShapeV) IO ()
-> IO (Int,Int,Int)
{-# INLINE pokeTopPrism #-}
pokeTopPrism size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
nv' <- S.foldM_ (pokeJustV ptr) (return nv) return 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]
pokeJustV :: Ptr Float
-> Int
-> ShapeV
-> IO Int
--{-# INLINE pokeJustV #-}
pokeJustV ptr nv sh = do
-- pokeArray (advancePtr ptr (off 0)) [a,b,c,d,e,f,g]
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
return (nv + 1)
where
off i = nv*7 + i
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 = S.mapM_ (pokeLayVerx vbos counts) . S.each
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 * 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))
--pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
--pokePoint33s ptr = S.foldM_ (pokePoint33 ptr) (return 0) return . S.each
--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
Reference in New Issue View Git Blame Copy Permalink