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

Use rounded shapes instead of TopPrism

Browse Source
This commit is contained in:
justin
2023-03-17 01:05:41 +00:00
parent 539cbe8b18
commit 6425ef3f0a
7 changed files with 73 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shape.hs
+14 -20
View File
@@ -41,8 +41,10 @@ prismPoly
-> [Point3]
-> Shape
{-# INLINE prismPoly #-}
prismPoly upps downps = [Surface (TopPrism n) (f upps downps) white]
--prismPoly upps downps = [Surface (TopPrism n) (f upps downps) white FullShadowFidelity]
prismPoly upps downps = [Surface (RoundedFaces n) (cp:cp:f upps downps) white FullShadowFidelity]
where
cp = centroidNum $ upps ++ downps
n = length upps
f (a:as) (b:bs) = a:b:f as bs
f _ _ = []
@@ -52,19 +54,14 @@ upperPrismPoly
-> [Point2]
-> Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly h ps = [Surface (TopPrism n) (f ps) white]
where
n = length ps
g h' (V2 x y) = V3 x y h'
f (x:xs) = g h x : g 0 x : f xs
f _ = []
upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)
upperBox
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperBox #-}
upperBox h ps = [Surface (FlatFaces n) (f ps) white]
upperBox h ps = [Surface (FlatFaces n) (f ps) white FullShadowFidelity]
where
n = length ps
g h' (V2 x y) = V3 x y h'
@@ -76,7 +73,7 @@ upperCylinder
-> [Point2]
-> Shape
{-# INLINE upperCylinder #-}
upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white]
upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white FullShadowFidelity]
where
cc = centroid ps
n = length ps
@@ -89,7 +86,7 @@ upperRounded
-> [Point2]
-> Shape
{-# INLINE upperRounded #-}
upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white]
upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white FullShadowFidelity]
where
cc = centroid ps
n = length ps
@@ -102,15 +99,12 @@ upperPrismPolyHalf
-> [Point2]
-> Shape
{-# INLINE upperPrismPolyHalf #-}
upperPrismPolyHalf h ps = [Surface (TopPrism n) (f upps downps) white]
upperPrismPolyHalf h ps = prismPoly upps downps
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) = V3 (0.5 * x) (0.5 * y) h
f'' (V2 x y) = V3 x y 0
upps = map f ps
downps = map g ps
f (V2 x y) = V3 (0.5 * x) (0.5 * y) h
g (V2 x y) = V3 x y 0
colorSH :: Color -> Shape -> Shape
{-# INLINE colorSH #-}
@@ -150,8 +144,8 @@ scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
overColObj :: (Point4 -> Point4) -> Surface -> Surface
{-# INLINE overColObj #-}
overColObj f (Surface st vs col) = Surface st vs (f col)
overColObj f (Surface st vs col sfid) = Surface st vs (f col) sfid
overPosObj :: (Point3 -> Point3) -> Surface -> Surface
{-# INLINE overPosObj #-}
overPosObj f (Surface st vs col) = Surface st (map f vs) col
overPosObj f (Surface st vs col sfid) = Surface st (map f vs) col sfid