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

Allow shadow fidelity option, fix bug in rendering box shadows

Browse Source
This commit is contained in:
justin
2023-03-25 17:22:58 +00:00
parent cdc4a84d4b
commit d989acd6f2
26 changed files with 410 additions and 258 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shape.hs
+189 -81
View File
@@ -1,36 +1,52 @@
{-# LANGUAGE BangPatterns #-}
module Shape
( module Shape.Data
, translateSH
, upperPrismPoly
, upperPrismPolyHalf
, prismPoly
, polyCirc
, upperBox
, translateSHz
, translateSHxy
, rotateSH
, rotateSHx
, rotateSHq
, polyCircx
, scaleSH
, colorSH
, overColSH
, overPosSH
, upperCylinder
, upperRounded
, xCylinder
, xCylinder'
) where
import Geometry
import Shape.Data
{-# LANGUAGE BangPatterns #-}
module Shape (
module Shape.Data,
translateSH,
upperPrismPoly,
upperPrismPolyMT,
upperPrismPolySE,
upperPrismPolyST,
upperPrismPolySI,
upperPrismPolySU,
upperPrismPolyTS,
upperBoxMT,
upperBoxST,
upperBoxSU,
upperBoxHalf,
upperPrismPolyHalf,
upperPrismPolyHalfMI,
upperPrismPolyHalfST,
xCylinderST,
prismPoly,
prismBox,
cylinderPoly,
polyCirc,
upperBox,
translateSHz,
translateSHxy,
rotateSH,
rotateSHx,
rotateSHq,
polyCircx,
scaleSH,
colorSH,
overColSH,
overPosSH,
upperCylinder,
upperRounded,
xCylinder',
) where
import Color
import Geometry
import qualified Quaternion as Q
import Shape.Data
-- - approximate a circle by a polygon with n*2 points of radius x
polyCirc :: Int -> Float -> [Point2]
{-# INLINE polyCirc #-}
polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/fromIntegral n..]
polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n * 2) [0, pi / fromIntegral n ..]
-- - approximate a circle around the x axis by a polygon with n*2 points of radius r
polyCircx :: Int -> Float -> [Point3]
@@ -40,83 +56,175 @@ polyCircx n = map (vNormaly . addZ 0) . polyCirc n
-- length of polys must be the same
-- points should be correctly ordered so that
-- polys form a prism-like object with quad faces between them
prismPoly
:: [Point3]
-> [Point3]
-> Shape
prismPoly ::
Size ->
Importance ->
[Point3] ->
[Point3] ->
Shape
{-# INLINE prismPoly #-}
prismPoly upps downps = [Surface (RoundedFaces n) (cp:cp:f upps downps) white FullShadowFidelity]
prismPoly size shads upps downps = [Surface (RoundedFaces n) (cp : cp : f upps downps) white shads size]
where
cp = centroidNum $ upps ++ downps
n = length upps
f (a:as) (b:bs) = a:b:f as bs
f (a : as) (b : bs) = a : b : f as bs
f _ _ = []
upperPrismPoly
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)
xCylinder :: Int -> Float -> Float -> Shape
xCylinder n r x = rotateSHq (V3 0 1 0) (pi/2) . translateSHxy (-r) 0 . upperCylinder x $ polyCirc n r
xCylinder' :: Float -> Float -> Shape
xCylinder' r x = translateSHz r . rotateSHq (V3 0 1 0) (pi/2) . upperCylinder x $
[V2 r r
,V2 (-r/2) (r/2)
,V2 (-r/2) (negate $ r/2)
,V2 r (-r)
]
upperBox
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperBox #-}
upperBox h ps = [Surface (FlatFaces n) (f ps) white FullShadowFidelity]
prismBox ::
Size ->
Importance ->
[Point3] ->
[Point3] ->
Shape
{-# INLINE prismBox #-}
prismBox size shads upps downps = [Surface (FlatFaces n) (f upps downps) white shads size]
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 _ = []
n = length upps
f (a : as) (b : bs) = a : b : f as bs
f _ _ = []
cylinderPoly ::
Size ->
Importance ->
[Point3] ->
[Point3] ->
Shape
{-# INLINE cylinderPoly #-}
cylinderPoly size shads upps downps = [Surface (Cylinder n) (cp1 : cp2 : f upps downps) white shads size]
where
cp1 = centroidNum upps
cp2 = centroidNum downps
n = length upps
f (a : as) (b : bs) = a : b : f as bs
f _ _ = []
upperPrismPolyMT :: Float -> [Point2] -> Shape
upperPrismPolyMT = upperPrismPoly Medium Typical
upperPrismPolySE :: Float -> [Point2] -> Shape
upperPrismPolySE = upperPrismPoly Small Essential
upperPrismPolyST :: Float -> [Point2] -> Shape
upperPrismPolyST = upperPrismPoly Small Typical
upperPrismPolySI :: Float -> [Point2] -> Shape
upperPrismPolySI = upperPrismPoly Small Important
upperPrismPolySU :: Float -> [Point2] -> Shape
upperPrismPolySU = upperPrismPoly Small Unimportant
--upperPrismPolySS :: Float -> [Point2] -> Shape
--upperPrismPolySS = upperPrismPoly Small Superfluous
upperPrismPolyTS :: Float -> [Point2] -> Shape
upperPrismPolyTS = upperPrismPoly Tiny Superfluous
upperPrismPoly ::
-- | height, expected to be strictly positive
Size ->
Importance ->
Float ->
[Point2] ->
Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly size shad h ps = prismPoly size shad (map (addZ h) ps) (map (addZ 0) ps)
xCylinderST :: Float -> Float -> Shape
xCylinderST = xCylinder' Small Typical
xCylinder' :: Size -> Importance -> Float -> Float -> Shape
xCylinder' size shad r x =
translateSHz r . rotateSHq (V3 0 1 0) (pi / 2) . upperCylinder size shad x $
[ V2 r r
, V2 (- r / 2) (r / 2)
, V2 (- r / 2) (negate $ r / 2)
, V2 r (- r)
]
upperBoxMT :: Float -> [Point2] -> Shape
upperBoxMT = upperBox Medium Typical
upperBoxST :: Float -> [Point2] -> Shape
upperBoxST = upperBox Small Typical
upperBoxSU :: Float -> [Point2] -> Shape
upperBoxSU = upperBox Small Unimportant
upperBox ::
-- | height, expected to be strictly positive
Size ->
Importance ->
Float ->
[Point2] ->
Shape
{-# INLINE upperBox #-}
upperBox size shad h ps = prismBox size shad (map (addZ h) ps) (map (addZ 0) ps)
rotateSHq :: Point3 -> Float -> Shape -> Shape
rotateSHq p = overPosSH . Q.rotate . Q.axisAngle p
upperCylinder
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
upperCylinder ::
-- | height, expected to be strictly positive
Size ->
Importance ->
Float ->
[Point2] ->
Shape
{-# INLINE upperCylinder #-}
upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white FullShadowFidelity]
upperCylinder size shad h ps = [Surface (Cylinder n) (addZ (h -0.5) cc : addZ 0.5 cc : f ps) white shad size]
where
cc = V2 0 0
n = length ps
g h' (V2 x y) = V3 x y h'
f (x:xs) = g h x : g 0 x : f xs
f (x : xs) = g h x : g 0 x : f xs
f _ = []
upperRounded
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
upperRounded ::
-- | height, expected to be strictly positive
Size ->
Importance ->
Float ->
[Point2] ->
Shape
{-# INLINE upperRounded #-}
upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white FullShadowFidelity]
upperRounded size shad h ps = [Surface (RoundedFaces n) (addZ h cc : addZ 0 cc : f ps) white shad size]
where
cc = centroid ps
n = length ps
g h' (V2 x y) = V3 x y h'
f (x:xs) = g h x : g 0 x : f xs
f (x : xs) = g h x : g 0 x : f xs
f _ = []
upperPrismPolyHalf
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
upperPrismPolyHalfMI :: Float -> [Point2] -> Shape
upperPrismPolyHalfMI = upperPrismPolyHalf Medium Important
upperPrismPolyHalfST :: Float -> [Point2] -> Shape
upperPrismPolyHalfST = upperPrismPolyHalf Small Typical
upperPrismPolyHalf ::
-- | height, expected to be strictly positive
Size ->
Importance ->
Float ->
[Point2] ->
Shape
{-# INLINE upperPrismPolyHalf #-}
upperPrismPolyHalf h ps = prismPoly upps downps
upperPrismPolyHalf size shad h ps = prismPoly size shad upps downps
where
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
upperBoxHalf ::
-- | height, expected to be strictly positive
Size ->
Importance ->
Float ->
[Point2] ->
Shape
{-# INLINE upperBoxHalf #-}
upperBoxHalf size shad h ps = prismBox size shad upps downps
where
upps = map f ps
downps = map g ps
@@ -157,12 +265,12 @@ rotateSHx = overPosSH . rotate3x
scaleSH :: Point3 -> Shape -> Shape
{-# INLINE scaleSH #-}
scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
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 sfid) = Surface st vs (f col) sfid
overColObj f (Surface st vs col sfid size) = Surface st vs (f col) sfid size
overPosObj :: (Point3 -> Point3) -> Surface -> Surface
{-# INLINE overPosObj #-}
overPosObj f (Surface st vs col sfid) = Surface st (map f vs) col sfid
overPosObj f (Surface st vs col sfid size) = Surface st (map f vs) col sfid size