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

Working (but slow) shadow shapes

Browse Source
This commit is contained in:
justin
2021-09-17 23:12:51 +01:00
parent 294e01479a
commit 6ac53c052c
16 changed files with 167 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shape.hs
+56 -10
View File
@@ -5,7 +5,8 @@ module Shape
)
where
import Geometry
--import Geometry.Vector3D
import Geometry.Vector3D
import Geometry.ConvexPoly
import Shape.Data
import Color
@@ -13,6 +14,39 @@ empty :: Shape
{-# INLINE empty #-}
empty = Shape [] []
flatCirc :: Float -> Shape
flatCirc = flatPoly . polyCirc
polyCirc :: Float -> [Point2]
{-# INLINE polyCirc #-}
polyCirc x = map (\a -> rotateV a (V2 x 0)) $ take 8 [0,pi/4..]
prismPoly
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE prismPoly #-}
prismPoly h ps = Shape
{ _shVertices = topFace ++ bottomFace ++ sideFaces
, _shEdges = topEdges ++ bottomEdges ++ sideEdges
}
where
topFace = polyToTris $ map f' ps
f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black }
f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
bottomFace = polyToTris $ map f $ reverse ps
sideFaces = map addCol $ concat
$ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
addCol x = ShapeV {_svPos = x, _svCol = black}
extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
topEdges = concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
V2 xcen ycen = centroid ps
bottomEdges = concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
makeBottomEdge (V2 x' y') (V2 x y) = [V3 x y 0,V3 x' y' 0,V3 x y h,V3 xcen ycen 0]
sideEdges = concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
flatPoly :: [Point2] -> Shape
flatPoly ps = Shape
{ _shVertices = polyToTris $ map f ps
@@ -23,12 +57,16 @@ flatPoly ps = Shape
g (V2 x y) (V2 a b) =
[ V3 x y 0
, V3 a b 0
, V3 x y (-1)
, V3 a b 1
, V3 x y 0 - n
, V3 a b 0 - n
]
where
n = addZ 0 $ vNormal (V2 (a-x) (b-y))
-- where
--n =
colorSh :: Color -> Shape -> Shape
colorSh col = overCol $ const col
colorSH :: Color -> Shape -> Shape
colorSH col = overCol $ const col
overCol :: (Point4 -> Point4) -> Shape -> Shape
overCol f Shape{_shVertices=vs,_shEdges=es} = Shape
@@ -42,11 +80,20 @@ overPos f Shape{_shVertices=vs,_shEdges=es} = Shape
,_shEdges = map f es
}
translateSh :: Point3 -> Shape -> Shape
translateSh !p = overPos (+p)
translateSH :: Point3 -> Shape -> Shape
translateSH !p = overPos (+p)
scale :: Point3 -> Shape -> Shape
scale !p = overPos (*p)
translateSHf :: Float -> Float -> Shape -> Shape
translateSHf x y = translateSH (V3 x y 0)
translateSHz :: Float -> Shape -> Shape
translateSHz z = translateSH (V3 0 0 z)
rotateSH :: Float -> Shape -> Shape
rotateSH a = overPos (rotate3 a)
scaleSH :: Point3 -> Shape -> Shape
scaleSH !p = overPos (*p)
overColVertex :: (Point4 -> Point4) -> ShapeV -> ShapeV
overColVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
@@ -59,4 +106,3 @@ overPosVertex f ShapeV{_svPos=pos,_svCol=col} = ShapeV
{_svPos = f pos
,_svCol = col
}