justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor shapes, prepare for different normals at single vertex pos

Browse Source
This commit is contained in:
justin
2023-03-15 21:43:00 +00:00
parent 989140d46e
commit 249262b2b6
7 changed files with 114 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files
shader/lighting/texture.frag
-1
View File
@@ -13,7 +13,6 @@ void main() {
vec3 norm = normbit.xyz - pos;
float y1 = float(normbit.w == 0 ? 1 : dot(normalize(norm), normalize(distVec)));
float y = float(y1 > 0 ? 1 : 0);
// float y = float(normbit.w == 1 ? 1 : 0);
float dist = dot(distVec, distVec);
if (dist > rad) {
discard;
src/Dodge/Render/Shadow.hs
+72 -72
View File
@@ -3,19 +3,19 @@ module Dodge.Render.Shadow where
--import Data.Vector.Unboxed as UV
--import Dodge.Data.Universe
import Control.Lens
--import Control.Lens
import Data.Preload.Render
import qualified Data.Vector as V
--import qualified Data.Vector as V
--import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
import Foreign
--import Foreign
import Geometry
--import Graphics.GL.Core45
import Linear.V3 (cross)
--import Linear.V3 (cross)
--import Shader.Data
--import Shader.ExtraPrimitive
--import Shader.Parameters
import Shape.Data
--
drawCPUShadows :: RenderData -> Shape -> Point3 -> Float -> IO ()
drawCPUShadows _ _ _ _ = return ()
--drawCPUShadows pdata s pos rad = do
@@ -35,71 +35,71 @@ drawCPUShadows _ _ _ _ = return ()
-- (fromIntegral i)
-- return ()
pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int
pokeShapeShad pos r theptr i so = do
let vs = V.fromList $ map _svPos (_shVs so)
is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2)
V.foldM' (pokeShadEdge pos r theptr vs) i is
--pokeShapeShad :: Point3 -> Float -> Ptr Float -> Int -> ShapeObj -> IO Int
--pokeShapeShad pos r theptr i so = do
-- let vs = V.fromList $ map _svPos (_shVs so)
-- is = memoTopPrismEdges V.! (so ^. shType . prismSize - 2)
-- V.foldM' (pokeShadEdge pos r theptr vs) i is
pokeShadEdge ::
Point3 ->
Float ->
Ptr Float ->
V.Vector Point3 ->
Int ->
(Int, Int, Int, Int) ->
IO Int
pokeShadEdge pos _ ptr vxs i (a, b, x, y) = do
let p0 = vxs V.! a
p1 = vxs V.! b
--mid = 0.5 * (p0 + p1)
n0a = vxs V.! x
n1a = vxs V.! y -- this should almost certainly be done with backpermute
n0 = cross (p1 - p0) (n0a - p0)
n1 = cross (p0 - p1) (n1a - p1)
lightdir = p0 - pos
shift' p = p + (10000 *.*.* (p - pos))
-- projNear p =
-- shiftNear p =
if dotV3 n0 lightdir * dotV3 n1 lightdir <= 0
then do
let p2 = shift' p0
p3 = shift' p1
if dotV3 n0 lightdir > 0
then
pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2
>>= pokeV3 ptr p0
>>= pokeV3 ptr p2
>>= pokeV3 ptr p3
else
pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3
>>= pokeV3 ptr p1
>>= pokeV3 ptr p3
>>= pokeV3 ptr p2
else return i
pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int
pokeV3 ptr (V3 x y z) i = do
pokeElemOff ptr (3 * i) x
pokeElemOff ptr (3 * i + 1) y
pokeElemOff ptr (3 * i + 2) z
return (i + 1)
memoTopPrismEdges :: V.Vector (V.Vector (Int, Int, Int, Int))
memoTopPrismEdges =
V.generate 10 $
V.fromList . topPrismEdges . (+ 2)
topPrismEdges :: Int -> [(Int, Int, Int, Int)]
topPrismEdges n = concatMap f [0 .. n -1]
where
f i =
map
h
[ (0, 2, 1, 4)
, (0, 1, -2, 3)
, (1, 3, -1, 2)
]
where
h (a, b, c, d) = (g a, g b, g c, g d)
g j = (2 * i + j) `mod` (2 * n)
--pokeShadEdge ::
-- Point3 ->
-- Float ->
-- Ptr Float ->
-- V.Vector Point3 ->
-- Int ->
-- (Int, Int, Int, Int) ->
-- IO Int
--pokeShadEdge pos _ ptr vxs i (a, b, x, y) = do
-- let p0 = vxs V.! a
-- p1 = vxs V.! b
-- --mid = 0.5 * (p0 + p1)
-- n0a = vxs V.! x
-- n1a = vxs V.! y -- this should almost certainly be done with backpermute
-- n0 = cross (p1 - p0) (n0a - p0)
-- n1 = cross (p0 - p1) (n1a - p1)
-- lightdir = p0 - pos
-- shift' p = p + (10000 *.*.* (p - pos))
-- -- projNear p =
-- -- shiftNear p =
-- if dotV3 n0 lightdir * dotV3 n1 lightdir <= 0
-- then do
-- let p2 = shift' p0
-- p3 = shift' p1
-- if dotV3 n0 lightdir > 0
-- then
-- pokeV3 ptr p0 i >>= pokeV3 ptr p1 >>= pokeV3 ptr p2
-- >>= pokeV3 ptr p0
-- >>= pokeV3 ptr p2
-- >>= pokeV3 ptr p3
-- else
-- pokeV3 ptr p1 i >>= pokeV3 ptr p0 >>= pokeV3 ptr p3
-- >>= pokeV3 ptr p1
-- >>= pokeV3 ptr p3
-- >>= pokeV3 ptr p2
-- else return i
--
--pokeV3 :: Ptr Float -> Point3 -> Int -> IO Int
--pokeV3 ptr (V3 x y z) i = do
-- pokeElemOff ptr (3 * i) x
-- pokeElemOff ptr (3 * i + 1) y
-- pokeElemOff ptr (3 * i + 2) z
-- return (i + 1)
--
--memoTopPrismEdges :: V.Vector (V.Vector (Int, Int, Int, Int))
--memoTopPrismEdges =
-- V.generate 10 $
-- V.fromList . topPrismEdges . (+ 2)
--
--topPrismEdges :: Int -> [(Int, Int, Int, Int)]
--topPrismEdges n = concatMap f [0 .. n -1]
-- where
-- f i =
-- map
-- h
-- [ (0, 2, 1, 4)
-- , (0, 1, -2, 3)
-- , (1, 3, -1, 2)
-- ]
-- where
-- h (a, b, c, d) = (g a, g b, g c, g d)
-- g j = (2 * i + j) `mod` (2 * n)
src/Dodge/Room/Foreground.hs
+1 -1
View File
@@ -144,7 +144,7 @@ putShape sh =
--shapePoints :: Shape -> Stream (Of Point2) Identity ()
--shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
shapePoints :: Shape -> [Point2]
shapePoints = concatMap (map (stripZ . _svPos) . _shVs)
shapePoints = concatMap (map stripZ . _sfVs)
shapeBounds :: Shape -> (Float, Float, Float, Float)
shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints
src/Shader/Poke.hs
+15 -16
View File
@@ -85,7 +85,7 @@ pokeW ptr i' ((V2 a b,V2 c d),V4 e f g h) = do
pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort
-> (Int,Int,Int)
-> [ShapeObj]
-> [Surface]
-> IO (Int,Int,Int)
pokeShape ptr iptr ieptr is = VFSM.foldlM' (pokeShapeObj ptr iptr ieptr) is . VFSM.fromList
@@ -94,22 +94,23 @@ pokeShapeObj
-> Ptr GLushort
-> Ptr GLushort
-> (Int,Int,Int)
-> ShapeObj
-> Surface
-> IO (Int,Int,Int)
{-# INLINE pokeShapeObj #-}
pokeShapeObj ptr iptr ieptr counts (ShapeObj shtype shVerts) = case shtype of
TopPrism size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
TopPrism size -> pokeTopPrism midp col (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
-- TopCylinder size -> pokeTopPrism midp (size - 2) ptr iptr ieptr counts (VFSM.fromList shVerts)
where
midp = centroidNum $ map _svPos shVerts
midp = centroidNum shVerts
pokeTopPrism :: Point3 -> Int -> Ptr Float -> Ptr GLushort
pokeTopPrism :: Point3 -> Point4 -> Int -> Ptr Float -> Ptr GLushort
-> Ptr GLushort
-> (Int,Int,Int)
-> VFSM.Stream IO ShapeV
-> VFSM.Stream IO Point3
-> IO (Int,Int,Int)
{-# INLINE pokeTopPrism #-}
pokeTopPrism cp size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
nv' <- VFSM.foldlM' (pokeJustV cp ptr) nv svs
pokeTopPrism cp col size ptr iptr ieptr (nv,nshapeindices,nedgeindices) svs = do
nv' <- VFSM.foldlM' (pokeJustV cp col ptr) nv svs
nshapeindices' <- UV.foldM' (pokeTopPrismIndex nv iptr) nshapeindices
(memoTopPrismIndices V.! size)
nedgeindices' <- UV.foldM' (pokeTopPrismEdgeIndex nv ieptr) nedgeindices
@@ -170,22 +171,20 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
-- and just doing two pokes rather than seven
-- (especially if adding normal data)
pokeJustV :: Point3
-> Point4
-> Ptr Float
-> Int
-> ShapeV
-> Point3
-> IO Int
{-# INLINE pokeJustV #-}
pokeJustV cp ptr nv sh = do
pokeJustV cp col ptr nv sh = do
zipWithM_ f [0..] [x,y,z,1,r,g,b,a,nx,ny,nz,1]
return (nv + 1)
where
f i = pokeElemOff ptr (nv*nShapeVerxComp + i)
V3 x y z = _svPos sh
V4 r g b a = _svCol sh
V3 x y z = sh
V4 r g b a = col
V3 nx ny nz = cp
--nx = x
--ny = y
--nz = z - 1
pokeLayVerxs
:: MV.MVector (PrimState IO) (FullShader ,VBO)
src/Shape.hs
+13 -22
View File
@@ -22,11 +22,11 @@ import Geometry
import Shape.Data
import Color
singleShape :: ShapeObj -> Shape
singleShape :: Surface -> Shape
{-# INLINE singleShape #-}
singleShape = (:[])
shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
shMap :: (Surface -> Surface) -> Shape -> Shape
{-# INLINE shMap #-}
shMap = map
@@ -52,23 +52,22 @@ prismPoly
-> [Point3]
-> Shape
{-# INLINE prismPoly #-}
prismPoly upps downps = singleShape (ShapeObj (TopPrism n) (f upps downps))
prismPoly upps downps = singleShape (Surface (TopPrism n) (f upps downps) black)
where
n = length upps
f (a:as) (b:bs) = g a:g b:f as bs
f (a:as) (b:bs) = a:b:f as bs
f [] _ = []
f _ [] = []
g p = ShapeV p black
upperPrismPoly
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly h ps = singleShape (ShapeObj (TopPrism n) (f ps))
upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black)
where
n = length ps
g h' (V2 x y) = pairToSV (V3 x y h', black)
g h' (V2 x y) = V3 x y h'
f (x:xs) = g h x : g 0 x : f xs
f _ = []
@@ -77,15 +76,15 @@ upperPrismPolyHalf
-> [Point2]
-> Shape
{-# INLINE upperPrismPolyHalf #-}
upperPrismPolyHalf h ps = singleShape (ShapeObj (TopPrism n) (f upps downps))
upperPrismPolyHalf h ps = singleShape (Surface (TopPrism n) (f upps downps) black)
where
n = length ps
upps = map f' ps
downps = map f'' ps
f (a:as) (b:bs) = a:b:f as bs
f _ _ = []
f' (V2 x y) = pairToSV (V3 (0.5 * x) (0.5 * y) h, black)
f'' (V2 x y) = pairToSV (V3 x y 0, black)
f' (V2 x y) = (V3 (0.5 * x) (0.5 * y) h)
f'' (V2 x y) = (V3 x y 0)
colorSH :: Color -> Shape -> Shape
{-# INLINE colorSH #-}
@@ -123,22 +122,14 @@ scaleSH :: Point3 -> Shape -> Shape
{-# INLINE scaleSH #-}
scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
overColObj :: (Point4 -> Point4) -> ShapeObj -> ShapeObj
overColObj :: (Point4 -> Point4) -> Surface -> Surface
{-# INLINE overColObj #-}
overColObj f (ShapeObj st vs) = ShapeObj st (fmap (overColVertex f) vs)
overColObj f (Surface st vs col) = Surface st vs (f col)
--overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
--{-# INLINE overColObjM #-}
--overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs
overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
{-# INLINE overColVertex #-}
overColVertex f (ShapeV a b) = ShapeV a (f b)
overPosObj :: (Point3 -> Point3) -> ShapeObj -> ShapeObj
overPosObj :: (Point3 -> Point3) -> Surface -> Surface
{-# INLINE overPosObj #-}
overPosObj f (ShapeObj st vs) = ShapeObj st $ fmap (overPosVertex f) vs
overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
{-# INLINE overPosVertex #-}
overPosVertex f (ShapeV a b) = ShapeV (f a) b
overPosObj f (Surface st vs col) = Surface st (map f vs) col
src/Shape/Data.hs
+10 -21
View File
@@ -18,38 +18,27 @@ shVfromList = id
{-# INLINE shEfromList #-}
shEfromList = id
newtype ShapeType = TopPrism { _prismSize :: Int }
deriving newtype (Eq, Ord, Show, Read)
data ShapeType = TopPrism { _prismSize :: Int }
-- | Surface { _surfaceSize :: Int}
deriving (Eq, Ord, Show, Read)
--deriving stock Generic
--deriving anyclass Flat
data ShapeObj = ShapeObj
{ _shType :: ShapeType
, _shVs :: [ShapeV]
data Surface = Surface
{ _sfType :: ShapeType
, _sfVs :: [Point3]
, _sfColor :: Point4
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
-- edges are given by four consecutive points
data ShapeV = ShapeV
{ _svPos :: Point3
, _svCol :: Point4
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
pairToSV :: (Point3, Point4) -> ShapeV
{-# INLINE pairToSV #-}
pairToSV = uncurry ShapeV
makeLenses ''ShapeV
makeLenses ''ShapeObj
makeLenses ''Surface
makeLenses ''ShapeType
type Shape = [ShapeObj]
type Shape = [Surface]
nShapeVerxComp :: Int
nShapeVerxComp = 12
deriveJSON defaultOptions ''ShapeType
deriveJSON defaultOptions ''ShapeV
deriveJSON defaultOptions ''ShapeObj
deriveJSON defaultOptions ''Surface
src/ShapePicture.hs
+3 -3
View File
@@ -21,7 +21,7 @@ import Geometry
import Data.Bifunctor
import Control.Lens
shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
shMap :: (Surface -> Surface) -> Shape -> Shape
shMap = map
-- should all this be inlined/inlinable?
@@ -63,12 +63,12 @@ rotateSP a = bimap (rotateSH a) (rotate a)
mirrorSPxz :: SPic -> SPic
{-# INLINE mirrorSPxz #-}
mirrorSPxz = bimap (shMap (over shVs reverse) . overPosSH flipy) mirrorxz
mirrorSPxz = bimap (shMap (over sfVs reverse) . overPosSH flipy) mirrorxz
where
flipy (V3 x y z) = V3 x (negate y) z
mirrorSPyz :: SPic -> SPic
{-# INLINE mirrorSPyz #-}
mirrorSPyz = bimap (shMap (over shVs reverse) . overPosSH flipx) mirroryz
mirrorSPyz = bimap (shMap (over sfVs reverse) . overPosSH flipx) mirroryz
where
flipx (V3 x y z) = V3 (negate x) y z