Implement poking using Verx lists

This commit is contained in:
jgk
2021-07-30 20:04:55 +02:00
parent 834464db51
commit d7649b951b
12 changed files with 109 additions and 155 deletions
+4 -2
View File
@@ -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
View File
@@ -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
View File
@@ -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.
+6 -6
View File
@@ -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
View File
@@ -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
View File
@@ -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
View File
@@ -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
View File
@@ -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
View File
@@ -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
View File
@@ -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
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{- |
Datatypes used to setup and pass data to shaders.
-}
+38 -79
View File
@@ -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