259 lines
8.2 KiB
Haskell
259 lines
8.2 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
--{-# LANGUAGE BangPatterns #-}
|
|
module Shader.Poke
|
|
( pokeVerxs
|
|
, pokeLayVerxs
|
|
, pokeArrayOff
|
|
, pokePoint33s
|
|
, poke224s
|
|
, pokeShape
|
|
, pokePoint3s
|
|
) 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.Unboxed.Mutable as UMV
|
|
import qualified Data.Vector.Mutable as MV
|
|
import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
|
import Control.Monad.Primitive
|
|
import Control.Monad
|
|
import Data.Bifoldable
|
|
--import qualified Data.DList as DL
|
|
|
|
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.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
|
|
|
|
pokeShape
|
|
:: Ptr Float -- ^ vertex data pointer
|
|
-> Ptr Float -- ^ edge data pointer
|
|
-> Ptr GLushort -- ^ vertex indices pointer
|
|
-> Ptr GLushort -- ^ edge indices pointer
|
|
-> Shape
|
|
-> IO (Int,Int,Int,Int)
|
|
pokeShape vptr eptr iptr ieptr = bifoldlM
|
|
(pokeShapeObjs vptr iptr ieptr)
|
|
(pokeShapeEs eptr ieptr) (0,0,0,0)
|
|
|
|
pokeShapeObjs
|
|
:: Ptr Float
|
|
-> Ptr GLushort
|
|
-> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeObj] -> IO (Int, Int,Int,Int)
|
|
pokeShapeObjs ptr iptr _ count = VS.foldlM' (pokeShapeObj ptr iptr) count . VS.fromList
|
|
|
|
pokeShapeObj :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeObj -> IO (Int,Int,Int,Int)
|
|
pokeShapeObj ptr iptr counts (ShapeObj shType shVerts) = case shType of
|
|
ListV -> pokeShapeVs ptr iptr counts shVerts
|
|
TopPrism size -> pokeTopPrism size ptr iptr counts shVerts
|
|
|
|
pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int,Int)
|
|
pokeTopPrism size ptr iptr count svs = do
|
|
count' <- pokeTopPrismIndices size iptr count
|
|
VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs)
|
|
|
|
pokeTopPrismIndices :: Int -> Ptr GLushort -> (Int,Int,Int,Int) -> IO (Int,Int,Int,Int)
|
|
pokeTopPrismIndices size iptr (nv,ne,ni,nei) = do
|
|
ni' <- foldM (pokeTopPrismIndex nv iptr) ni (topPrismIndices size)
|
|
return (nv,ne,ni',nei)
|
|
|
|
pokeTopPrismIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int
|
|
pokeTopPrismIndex nv iptr ni ioff = do
|
|
pokeElemOff iptr ni (fromIntegral $ nv + ioff)
|
|
return (ni + 1)
|
|
|
|
pokeShapeVs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [ShapeV] -> IO (Int, Int,Int,Int)
|
|
pokeShapeVs ptr iptr count = VS.foldlM' (pokeShapeV ptr iptr) count . VS.fromList
|
|
|
|
pokeShapeEs :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> [Point3] -> IO (Int,Int,Int,Int)
|
|
pokeShapeEs ptr ieptr count = VS.foldlM' (pokeShapeE ptr ieptr) count . VS.fromList
|
|
|
|
|
|
pokeShapeE :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> Point3 -> IO (Int,Int,Int,Int)
|
|
pokeShapeE eptr ieptr (nv,n,ni,nei) (V3 a b c) = do
|
|
pokeElemOff eptr (n * 3) a
|
|
pokeElemOff eptr (n * 3 + 1) b
|
|
pokeElemOff eptr (n * 3 + 2) c
|
|
pokeElemOff ieptr nei (fromIntegral n)
|
|
return $ (nv,n + 1,ni,nei+1)
|
|
|
|
topPrismIndices :: Int -> [Int]
|
|
topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
|
|
++ [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]
|
|
g x = [2*x,2*x+1,2*x+3
|
|
,2*x,2*x+3,2*x+2]
|
|
|
|
pokeJustV :: Ptr Float -> (Int,Int,Int,Int) -> ShapeV -> IO (Int,Int,Int,Int)
|
|
pokeJustV ptr (nv,ne,ni,nei) sh = 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
|
|
return (nv+1,ne,ni,nei)
|
|
where
|
|
off i = nv*7 + i
|
|
V3 a b c = _svPos sh
|
|
V4 d e f g = _svCol sh
|
|
|
|
pokeShapeV :: Ptr Float -> Ptr GLushort -> (Int,Int,Int,Int) -> ShapeV -> IO (Int,Int,Int,Int)
|
|
pokeShapeV ptr iptr (nv,ne,ni,nei) sh = 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 iptr ni (fromIntegral nv)
|
|
return (nv+1,ne,ni+1,nei)
|
|
where
|
|
off i = nv*7 + i
|
|
V3 a b c = _svPos sh
|
|
V4 d e f g = _svCol sh
|
|
|
|
|
|
pokePoint3s :: Ptr Float -> VS.Stream IO Point3 -> IO Int
|
|
pokePoint3s ptr = VS.foldlM' (pokePoint3 ptr) 0
|
|
|
|
pokePoint3 :: Ptr Float -> Int -> Point3 -> IO Int
|
|
pokePoint3 ptr n (V3 a b c) = do
|
|
pokeElemOff ptr (n * 3) a
|
|
pokeElemOff ptr (n * 3 + 1) b
|
|
pokeElemOff ptr (n * 3 + 2) c
|
|
return $ n + 1
|
|
|
|
pokeLayVerxs
|
|
:: MV.MVector (PrimState IO) FullShader
|
|
-> UMV.MVector (PrimState IO) Int
|
|
-> Picture
|
|
-> 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 . _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))
|
|
|
|
--pokeTwoOff
|
|
-- :: Ptr Float
|
|
-- -> Int
|
|
-- -> (Float,Float)
|
|
-- -> IO ()
|
|
--{-# INLINE pokeTwoOff #-}
|
|
--pokeTwoOff ptr n (x,y) = do
|
|
-- pokeElemOff ptr (2*n+0) x
|
|
-- pokeElemOff ptr (2*n+1) y
|
|
--pokeThreeOff
|
|
-- :: Ptr Float
|
|
-- -> Int
|
|
-- -> (Float,Float,Float)
|
|
-- -> IO ()
|
|
--{-# INLINE pokeThreeOff #-}
|
|
--pokeThreeOff ptr n (x,y,z) = do
|
|
-- pokeElemOff ptr (3*n+0) x
|
|
-- pokeElemOff ptr (3*n+1) y
|
|
-- pokeElemOff ptr (3*n+2) z
|
|
--pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
|
|
--{-# INLINE pokeFourOff #-}
|
|
--pokeFourOff ptr n (x,y,z,w) = do
|
|
-- pokeElemOff ptr (4*n+0) x
|
|
-- pokeElemOff ptr (4*n+1) y
|
|
-- pokeElemOff ptr (4*n+2) z
|
|
-- pokeElemOff ptr (4*n+3) w
|
|
|
|
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
|
|
|
|
pokePoint224 :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
|
|
pokePoint224 ptr n ((V2 a b,V2 c d),V4 e f g h) = 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
|
|
return (n + 1)
|
|
where
|
|
off i = n*8 + i
|
|
|
|
poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
|
|
poke224s ptr = VS.foldlM' (pokePoint224 ptr) 0 . VS.fromList
|