Implement poking using Verx lists
This commit is contained in:
@@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
|
||||
{-# LANGUAGE StrictData
|
||||
, TemplateHaskell
|
||||
#-}
|
||||
--{-# OPTIONS_GHC -Wno-unused-top-binds #-}
|
||||
module Data.Preload.Render
|
||||
where
|
||||
import Shader.Data
|
||||
|
||||
+4
-10
@@ -45,27 +45,21 @@ doDrawing pdata w = do
|
||||
let rot = _cameraRot w
|
||||
camzoom = _cameraZoom w
|
||||
trans = _cameraCenter w
|
||||
wins = (V2 (getWindowX w) (getWindowY w))
|
||||
wins = V2 (getWindowX w) (getWindowY w)
|
||||
(wallPointsCol,windowPoints) = wallsAndWindows w
|
||||
lightPoints = lightsForGloom w
|
||||
viewFroms = _cameraViewFrom w
|
||||
pic = worldPictures w
|
||||
-- bind as much data into vbos as feasible at this point
|
||||
-- poke wall points and colors
|
||||
--pokeArray (_vboPointer . _vaoVBO . _shaderVAO $ _wallTextureShader pdata) $ wallsToList wallPointsCol
|
||||
--let nWalls = length wallPointsCol
|
||||
nWalls <- pokeWalls (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
|
||||
--poke
|
||||
|
||||
-- poke silhouette vertex data
|
||||
nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
|
||||
nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata)
|
||||
(_foregroundEdgeVerx w)
|
||||
|
||||
-- poke foreground geometry and floor
|
||||
let addC (V2 xx yy) = (V3 xx yy 0)
|
||||
nsurfVs <- pokePoint3s (shadVBOptr $ _lightingSurfaceShader pdata)
|
||||
$ polyToTris (map addC $ screenPolygon w)
|
||||
++ concatMap polyToGeoRender' (foregroundPics w)
|
||||
++ concatMap polyToGeoRender (foregroundPics w)
|
||||
|
||||
-- bind wall points, silhouette data, surface geometry
|
||||
uncurry bindShaderBuffers $ unzip
|
||||
@@ -213,7 +207,7 @@ renderWindows
|
||||
-> [((Point2,Point2),Point4)] -- ^ List: wall positions and color
|
||||
-> IO ()
|
||||
renderWindows pdata wps = do
|
||||
n <- pokeWalls (shadVBOptr $ _wallBlankShader pdata) wps
|
||||
n <- poke224s (shadVBOptr $ _wallBlankShader pdata) wps
|
||||
bindShaderBuffers [_wallBlankShader pdata] [n]
|
||||
currentProgram $= Just (_shaderProgram $ _wallBlankShader pdata)
|
||||
cullFace $= Just Back
|
||||
|
||||
+3
-3
@@ -255,10 +255,10 @@ anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
|
||||
-- split a list into triples, forms triangles from a polygon
|
||||
polyToTris :: [s] -> [s]
|
||||
{-# INLINE polyToTris #-}
|
||||
polyToTris (a:as) = f a as
|
||||
polyToTris (a:as) = go a as
|
||||
where
|
||||
f x (y:z:ys) = x : y : z : f x (z:ys)
|
||||
f _ _ = []
|
||||
go !x (y:z:ys) = x : y : z : go x (z:ys)
|
||||
go _ _ = []
|
||||
polyToTris _ = []
|
||||
|
||||
-- | Return n equidistant points on a circle with a radius of 600.
|
||||
|
||||
@@ -22,12 +22,12 @@ V2 x1 y1 +.+ V2 x2 y2 =
|
||||
{- | 2D coordinate-wise subtraction. -}
|
||||
(-.-) :: Point2 -> Point2 -> Point2
|
||||
{-# INLINE (-.-) #-}
|
||||
(-.-) = (-)
|
||||
--(x1, y1) -.- (x2, y2) =
|
||||
-- let
|
||||
-- !x = x1 - x2
|
||||
-- !y = y1 - y2
|
||||
-- in (x, y)
|
||||
--(-.-) = (-)
|
||||
V2 x1 y1 -.- V2 x2 y2 =
|
||||
let
|
||||
!x = x1 - x2
|
||||
!y = y1 - y2
|
||||
in V2 x y
|
||||
{- | 2D scalar multiplication. -}
|
||||
(*.*) :: Float -> Point2 -> Point2
|
||||
{-# INLINE (*.*) #-}
|
||||
|
||||
+1
-1
@@ -3,6 +3,6 @@ module Music
|
||||
import qualified SDL.Mixer as Mix
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
data MusicData = MusicData
|
||||
newtype MusicData = MusicData
|
||||
{ _loadedMusic :: IM.IntMap Mix.Music
|
||||
}
|
||||
|
||||
+35
-30
@@ -1,6 +1,9 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TupleSections
|
||||
, BangPatterns
|
||||
#-}
|
||||
module Picture
|
||||
( module Picture.Data
|
||||
, blank
|
||||
, polygon
|
||||
, polygonZ
|
||||
, polygonCol
|
||||
@@ -62,8 +65,9 @@ import Picture.Data
|
||||
--import Graphics.Rendering.OpenGL (lineWidth, ($=))
|
||||
import Control.Lens
|
||||
|
||||
black :: RGBA
|
||||
black = (V4 0 0 0 1)
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = []
|
||||
|
||||
polygon :: [Point2] -> Picture
|
||||
{-# INLINE polygon #-}
|
||||
@@ -79,9 +83,9 @@ polygonZ ps z = map (f . zeroZ) $ polyToTris ps
|
||||
|
||||
polygonCol :: [(Point2,RGBA)] -> Picture
|
||||
{-# INLINE polygonCol #-}
|
||||
polygonCol vs = map f $ polyToTris vs
|
||||
polygonCol vs = polyToTris $ map f vs
|
||||
where
|
||||
f ((V2 x y),col) = Verx (V3 x y 0) col PolyV 0
|
||||
f (V2 x y,col) = Verx (V3 x y 0) col PolyV 0
|
||||
|
||||
poly3 :: [Point3] -> Picture
|
||||
{-# INLINE poly3 #-}
|
||||
@@ -99,14 +103,13 @@ bezierQuad cola colc ra rc a b c
|
||||
| a == b && b == c = blank
|
||||
| a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
|
||||
| otherwise = bzhelp
|
||||
[-- ( (0,0) , cola, (0,0), (0,0) )
|
||||
(aIn, cola, (V2 (fa aIn) (fc aIn)) , (V2 1 0) )
|
||||
,(aIn, cola, (V2 (fa aIn) (fc aIn)) , (V2 1 0) )
|
||||
,(cIn, colc, (V2 (fa cIn) (fc cIn)) , (V2 0 1) )
|
||||
,( aX, cola, (V2 1 0) , (V2 (fa' aX) (fc' aX)) )
|
||||
,( cX, colc, (V2 0 1) , (V2 (fa' cX) (fc' cX)) )
|
||||
,( bX, colb, (V2 0 0) , (V2 (fa' bX) (fc' bX)) )
|
||||
,( bX, colb, (V2 0 0) , (V2 (fa' bX) (fc' bX)) )
|
||||
[(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 )
|
||||
,(aIn, cola, V2 (fa aIn) (fc aIn) , V2 1 0 )
|
||||
,(cIn, colc, V2 (fa cIn) (fc cIn) , V2 0 1 )
|
||||
,( aX, cola, V2 1 0 , V2 (fa' aX) (fc' aX) )
|
||||
,( cX, colc, V2 0 1 , V2 (fa' cX) (fc' cX) )
|
||||
,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) )
|
||||
,( bX, colb, V2 0 0 , V2 (fa' bX) (fc' bX) )
|
||||
]
|
||||
where
|
||||
colb = mixColors 0.5 0.5 cola colc
|
||||
@@ -131,7 +134,7 @@ bezierQuad cola colc ra rc a b c
|
||||
bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
|
||||
bzhelp = map f
|
||||
where
|
||||
f ((V2 x y),col,(V2 a b),(V2 c d)) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0
|
||||
f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0
|
||||
|
||||
-- given a one and two zeros of a linear function over x and y,
|
||||
-- determine the function
|
||||
@@ -154,12 +157,12 @@ color c = map $ overCol (const c)
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
translate3 a b (V3 x y z) = V3 (x+a) (y+b) z
|
||||
translate3 !a !b !(V3 x y z) = V3 (x+a) (y+b) z
|
||||
|
||||
translate :: Float -> Float -> Picture -> Picture
|
||||
--{-# INLINE translate #-}
|
||||
--translate x y = map $ second $ overPos (translate3 x y)
|
||||
translate x y = map $ overPos (translate3 x y)
|
||||
translate !x !y = map $! overPos $! translate3 x y
|
||||
|
||||
setDepth :: Float -> Picture -> Picture
|
||||
--{-# INLINE setDepth #-}
|
||||
@@ -311,20 +314,22 @@ withAlpha :: Float -> RGBA -> RGBA
|
||||
{-# INLINE withAlpha #-}
|
||||
withAlpha a (V4 x y z a') = (V4 x y z (a*a'))
|
||||
|
||||
red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color
|
||||
red = toV4 (1,0,0,1)
|
||||
green = toV4 (0,1,0,1)
|
||||
blue = toV4 (0,0,1,1)
|
||||
yellow = toV4 (1,1,0,1)
|
||||
cyan = toV4 (0,1,1,1)
|
||||
magenta = toV4 (1,0,1,1)
|
||||
rose = toV4 (1,0,0.5,1)
|
||||
violet = toV4 (0.5,0,1,1)
|
||||
azure = toV4 (0,0.5,1,1)
|
||||
aquamarine= toV4 (0,1,0.5,1)
|
||||
chartreuse= toV4 (0.5,1,0,1)
|
||||
orange = toV4 (1,0.5,0,1)
|
||||
white = toV4 (1,1,1,1)
|
||||
red,green,blue,yellow,cyan,magenta,rose
|
||||
,violet,azure,aquamarine,chartreuse,orange,white,black::Color
|
||||
red = V4 1 0 0 1
|
||||
green = V4 0 1 0 1
|
||||
blue = V4 0 0 1 1
|
||||
yellow = V4 1 1 0 1
|
||||
cyan = V4 0 1 1 1
|
||||
magenta = V4 1 0 1 1
|
||||
rose = V4 1 0 0.5 1
|
||||
violet = V4 0.5 0 1 1
|
||||
azure = V4 0 0.5 1 1
|
||||
aquamarine= V4 0 1 0.5 1
|
||||
chartreuse= V4 0.5 1 0 1
|
||||
orange = V4 1 0.5 0 1
|
||||
white = V4 1 1 1 1
|
||||
black = V4 0 0 0 1
|
||||
|
||||
|
||||
mixColors :: Float -> Float -> Color -> Color -> Color
|
||||
|
||||
+5
-11
@@ -1,13 +1,13 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
--{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Picture.Data
|
||||
where
|
||||
import Geometry.Data
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq
|
||||
import Data.Foldable
|
||||
import Control.Lens
|
||||
--import GHC.Generics (Generic)
|
||||
--import Control.DeepSeq
|
||||
--import Data.Foldable
|
||||
--import qualified Data.List as L
|
||||
--import Data.Monoid
|
||||
--import Data.Traversable
|
||||
@@ -15,7 +15,6 @@ import Data.Foldable
|
||||
--import qualified Data.Sequence as Se
|
||||
--import qualified Data.DList as DL
|
||||
--import qualified Data.Vector as V
|
||||
import Control.Lens
|
||||
--import Control.Monad
|
||||
|
||||
data Verx = Verx
|
||||
@@ -32,10 +31,9 @@ data VertexType
|
||||
| ArcV !Point3
|
||||
| EllV
|
||||
|
||||
type RGBA = Point4
|
||||
type RGBA = Point4
|
||||
type Color = Point4
|
||||
|
||||
|
||||
flat2 :: V2 a -> [a]
|
||||
flat2 (V2 x y) = [x,y]
|
||||
flat3 :: V3 a -> [a]
|
||||
@@ -57,8 +55,4 @@ tflat4 (x,y,z,w) = [x,y,z,w]
|
||||
|
||||
type Picture = [Verx]
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = []
|
||||
|
||||
makeLenses ''Verx
|
||||
|
||||
+2
-2
@@ -96,5 +96,5 @@ polysToPic = pictures . concatMap polyToPics
|
||||
polyToEdges :: Polyhedra -> [(Point3,Point3,Point3,Point3)]
|
||||
polyToEdges = constructEdges . map (map fst) . _pyFaces
|
||||
|
||||
polyToGeoRender' :: Polyhedra -> [Point3]
|
||||
polyToGeoRender' = concatMap (polyToTris . map fst) . _pyFaces
|
||||
polyToGeoRender :: Polyhedra -> [Point3]
|
||||
polyToGeoRender = concatMap (polyToTris . map fst) . _pyFaces
|
||||
|
||||
+5
-7
@@ -12,6 +12,7 @@ import Picture.Data
|
||||
import Geometry.Data
|
||||
--import Polyhedra.Data
|
||||
--import Polyhedra
|
||||
import Layers
|
||||
|
||||
--import Control.Lens
|
||||
import Control.Monad
|
||||
@@ -20,7 +21,7 @@ import Foreign hiding (rotate)
|
||||
import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
|
||||
--import Data.Foldable
|
||||
--import Data.Tuple.Extra
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
--import qualified Data.IntMap.Strict as IM
|
||||
import qualified SDL
|
||||
|
||||
divideSize :: Int -> Size -> Size
|
||||
@@ -160,12 +161,10 @@ pokeBindFoldableLayer
|
||||
-- :: Foldable f
|
||||
:: RenderData
|
||||
-> [Verx]
|
||||
-> IO (IM.IntMap (PicShads Int))
|
||||
-> IO (Layers (PicShads Int))
|
||||
pokeBindFoldableLayer pdata m = do
|
||||
let shads = _pictureShaders pdata
|
||||
--slist' = (IM.fromList ((,) <$> [0..6] <*> [zeroCounts])) :: IM.IntMap (PicShads Int)
|
||||
|
||||
--slist'' <- foldM (pokeVX shads) slist' m
|
||||
slist'' <- pokeLayVerxs (fmap (_vaoVBO . _vshaderVAO) shads) m
|
||||
bindShaderLay shads slist''
|
||||
|
||||
@@ -187,9 +186,8 @@ renderFoldable pdata struct = do
|
||||
return $ pokeEndTicks - pokeStartTicks
|
||||
------------------------------end renderFoldable
|
||||
|
||||
renderLayer :: Int -> PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
|
||||
renderLayer i shads counts =
|
||||
mapM_ (uncurry $ drawShaderLay i) ((,) <$> shads <*> counts IM.! i)
|
||||
renderLayer :: Int -> PicShads VShader -> Layers (PicShads Int) -> IO ()
|
||||
renderLayer i shads counts = sequence_ $ drawShaderLay i <$> shads <*> getLay i counts
|
||||
|
||||
pokeTwoOff
|
||||
:: Ptr Float
|
||||
|
||||
+5
-4
@@ -13,13 +13,14 @@ module Shader
|
||||
import Shader.Data
|
||||
import Shader.Parameters
|
||||
import Shader.ExtraPrimitive
|
||||
import Layers
|
||||
--import MatrixHelper
|
||||
|
||||
import Foreign
|
||||
import Control.Monad
|
||||
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
|
||||
import Graphics.GL.Core43
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
--import qualified Data.IntMap.Strict as IM
|
||||
--import Data.Bifunctor
|
||||
--import Text.RawString.QQ
|
||||
--import Linear.Matrix
|
||||
@@ -59,10 +60,10 @@ bindArrayBuffersLayer numVs lay theVBO = do
|
||||
where
|
||||
stride = sum $ _vboAttribSizes theVBO
|
||||
|
||||
bindShaderLay :: PicShads VShader -> IM.IntMap (PicShads Int) -> IO ()
|
||||
bindShaderLay shads = mapM_ f . IM.toList
|
||||
bindShaderLay :: PicShads VShader -> Layers (PicShads Int) -> IO ()
|
||||
bindShaderLay shads = sequenceLayers_ f
|
||||
where
|
||||
f (lay,counts) = sequence_ $ bindArrayBuffersLayer' lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
|
||||
f lay counts = sequence_ $ bindArrayBuffersLayer' lay <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
|
||||
|
||||
bindShader :: PicShads VShader -> PicShads Int -> IO ()
|
||||
bindShader shads counts = sequence_ $ bindArrayBuffers <$> counts <*> (_vaoVBO . _vshaderVAO <$> shads)
|
||||
|
||||
@@ -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