Implement poking using Verx lists
This commit is contained in:
@@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{- |
|
||||
Datatypes used to setup and pass data to shaders.
|
||||
-}
|
||||
|
||||
+38
-79
@@ -1,66 +1,38 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE TupleSections
|
||||
, BangPatterns
|
||||
#-}
|
||||
module Shader.Poke
|
||||
( pokeArrayOff
|
||||
, pokeVX
|
||||
, pokeVX'
|
||||
, pokePoint3s
|
||||
, pokePoint33s
|
||||
, pokeVerxs
|
||||
, pokeLayVerxs
|
||||
, pokeWalls
|
||||
, pokeLayVerxsM
|
||||
, poke224s
|
||||
) where
|
||||
import Shader.Data
|
||||
import Shader.Parameters
|
||||
import Picture.Data
|
||||
import Geometry.Data
|
||||
import Layers
|
||||
|
||||
--import Data.Maybe
|
||||
--import Data.List
|
||||
import Foreign
|
||||
--import Control.Monad
|
||||
import Control.Monad
|
||||
--import qualified Control.Foldl as F
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
--import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
|
||||
getterPicShad :: VertexType -> PicShads a -> a
|
||||
--{-# INLINE getterPicShad #-}
|
||||
getterPicShad PolyV = _psPoly
|
||||
getterPicShad PolyzV{} = _psPolyz
|
||||
getterPicShad BezV{} = _psBez
|
||||
getterPicShad TextV{} = _psText
|
||||
getterPicShad ArcV{} = _psArc
|
||||
getterPicShad EllV = _psEll
|
||||
|
||||
setterPicShad :: VertexType -> ASetter (PicShads a) (PicShads a) a a
|
||||
setterPicShad PolyV = psPoly
|
||||
setterPicShad PolyzV{} = psPolyz
|
||||
setterPicShad BezV{} = psBez
|
||||
setterPicShad TextV{} = psText
|
||||
setterPicShad ArcV{} = psArc
|
||||
setterPicShad EllV = psEll
|
||||
|
||||
pokeVX' :: PicShads VShader -> PicShads Int -> Verx -> IO (PicShads Int)
|
||||
pokeVX' shads count vx = do
|
||||
let f = setterPicShad (_vxType vx)
|
||||
g = getterPicShad (_vxType vx)
|
||||
vshad = g shads
|
||||
n = g count
|
||||
theVBO = _vaoVBO $ _vshaderVAO vshad
|
||||
ptr = _vboPtr theVBO
|
||||
stride = _vboStride theVBO
|
||||
pokeArrayOff ptr (stride * n) (toFls' vx)
|
||||
return $ count & f +~ 1
|
||||
|
||||
pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
|
||||
pokeVerxs vbos vxs0 = go vxs0 (pure 0)
|
||||
where
|
||||
go [] count = return count
|
||||
go [] !count = return count
|
||||
go (!vx:vxs) !count = pokeVerx vbos count vx >> (go vxs $! addCountVerx count vx)
|
||||
|
||||
-- this is very brittle, but want to optimise speed if possible here
|
||||
pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO ()
|
||||
{-# INLINE pokeVerx #-}
|
||||
--{-# INLINE pokeVerx #-}
|
||||
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
|
||||
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) (_psPoly offsets * 7 * floatSize)) thePos theCol
|
||||
PolyzV x -> poke34 thePtr thePos theCol
|
||||
@@ -88,7 +60,7 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case t
|
||||
EllV -> poke34 (plusPtr (_vboPtr $ _psEll vbos) (_psEll offsets * 7 * floatSize)) thePos theCol
|
||||
|
||||
poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
|
||||
{-# INLINE poke34 #-}
|
||||
--{-# INLINE poke34 #-}
|
||||
poke34 ptr (V3 a b c) (V4 d e f g) = do
|
||||
pokeElemOff ptr 0 a
|
||||
pokeElemOff ptr 1 b
|
||||
@@ -99,15 +71,15 @@ poke34 ptr (V3 a b c) (V4 d e f g) = do
|
||||
pokeElemOff ptr 6 g
|
||||
|
||||
addCountVerx :: PicShads Int -> Verx -> PicShads Int
|
||||
{-# INLINE addCountVerx #-}
|
||||
addCountVerx ps@PicShads
|
||||
--{-# INLINE addCountVerx #-}
|
||||
addCountVerx !ps@PicShads
|
||||
{ _psPoly = sPoly
|
||||
, _psPolyz = sPolyz
|
||||
, _psBez = sBez
|
||||
, _psText = sText
|
||||
, _psArc = sArc
|
||||
, _psEll = sEll
|
||||
} Verx{_vxType=theType} = case theType of
|
||||
} !Verx{_vxType=theType} = case theType of
|
||||
PolyV -> ps {_psPoly = sPoly + 1}
|
||||
PolyzV _ -> ps {_psPolyz = sPolyz + 1}
|
||||
BezV _ -> ps {_psBez = sBez + 1}
|
||||
@@ -115,31 +87,6 @@ addCountVerx ps@PicShads
|
||||
ArcV _ -> ps {_psArc = sArc + 1}
|
||||
EllV -> ps {_psEll = sEll + 1}
|
||||
|
||||
|
||||
pokeVX :: PicShads VShader -> IM.IntMap (PicShads Int) -> Verx -> IO (IM.IntMap (PicShads Int))
|
||||
pokeVX shads laycounts vx = do
|
||||
let theType = _vxType vx
|
||||
offset = _vxLayer vx
|
||||
counts = laycounts IM.! offset
|
||||
getF = getterPicShad theType
|
||||
vshad = getF shads
|
||||
n = getF counts
|
||||
theVBO = _vaoVBO $ _vshaderVAO vshad
|
||||
ptr = _vboPtr theVBO
|
||||
stride = _vboStride theVBO
|
||||
pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx)
|
||||
return $ laycounts & ix offset . setterPicShad theType +~ 1
|
||||
|
||||
|
||||
toFls' :: Verx -> [Float]
|
||||
toFls' vx = flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)
|
||||
where
|
||||
f (PolyzV x) = [x]
|
||||
f (BezV x) = flat4 x
|
||||
f (TextV x) = flat2 x
|
||||
f (ArcV x) = flat3 x
|
||||
f _ = []
|
||||
|
||||
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
|
||||
--{-# INLINE pokeArrayOff #-}
|
||||
--pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
|
||||
@@ -149,7 +96,7 @@ 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
|
||||
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
|
||||
@@ -164,7 +111,7 @@ 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
|
||||
go ( !(V3 a b c):vals) !n = do
|
||||
pokeElemOff ptr (off 0) a
|
||||
pokeElemOff ptr (off 1) b
|
||||
pokeElemOff ptr (off 2) c
|
||||
@@ -172,15 +119,20 @@ pokePoint3s ptr vals0 = go vals0 0
|
||||
where
|
||||
off i = n*3 + i
|
||||
|
||||
pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (IM.IntMap (PicShads Int))
|
||||
pokeLayVerxs vbos vxs0 = go vxs0 (IM.fromList $ (, pure 0) <$> [0..5])
|
||||
pokeLayVerxsM :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
|
||||
pokeLayVerxsM !vbos = foldM f (pure $ pure 0)
|
||||
where
|
||||
f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
|
||||
|
||||
pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
|
||||
pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0))
|
||||
where
|
||||
go [] count = return count
|
||||
go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx)
|
||||
|
||||
-- this is very brittle, but want to optimise speed if possible here
|
||||
pokeLayVerx :: PicShads VBO -> IM.IntMap (PicShads Int) -> Verx -> IO ()
|
||||
{-# INLINE pokeLayVerx #-}
|
||||
pokeLayVerx :: PicShads VBO -> Layers (PicShads Int) -> Verx -> IO ()
|
||||
--{-# INLINE pokeLayVerx #-}
|
||||
pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vxLayer = theLay} = case theType of
|
||||
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) ((_psPoly offsets + layOff) * 7 * floatSize)) thePos theCol
|
||||
PolyzV x -> poke34 thePtr thePos theCol
|
||||
@@ -208,16 +160,23 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx
|
||||
EllV -> poke34 (plusPtr (_vboPtr $ _psEll vbos) ((_psEll offsets + layOff) * 7 * floatSize)) thePos theCol
|
||||
where
|
||||
layOff = theLay * numSubElements
|
||||
offsets = imoffsets IM.! theLay
|
||||
offsets = getLay theLay imoffsets
|
||||
|
||||
addLayCountVerx :: IM.IntMap (PicShads Int) -> Verx -> IM.IntMap (PicShads Int)
|
||||
{-# INLINE addLayCountVerx #-}
|
||||
addLayCountVerx m vx = IM.adjust f (_vxLayer vx) m
|
||||
addLayCountVerx :: Layers (PicShads Int) -> Verx -> Layers (PicShads Int)
|
||||
--{-# INLINE addLayCountVerx #-}
|
||||
addLayCountVerx !m !vx = case _vxLayer vx of
|
||||
0 -> m & lay0 %~ f
|
||||
1 -> m & lay1 %~ f
|
||||
2 -> m & lay2 %~ f
|
||||
3 -> m & lay3 %~ f
|
||||
4 -> m & lay4 %~ f
|
||||
5 -> m & lay5 %~ f
|
||||
_ -> undefined
|
||||
where
|
||||
f = flip addCountVerx vx
|
||||
|
||||
pokeWalls :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
|
||||
pokeWalls ptr vals0 = go vals0 0
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user