152 lines
4.1 KiB
Haskell
152 lines
4.1 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Shape
|
|
( module Shape.Data
|
|
, translateSH
|
|
, upperPrismPoly
|
|
, upperPrismPolyHalf
|
|
, prismPoly
|
|
, polyCirc
|
|
, upperBox
|
|
, translateSHz
|
|
, translateSHxy
|
|
, rotateSH
|
|
, rotateSHx
|
|
, polyCircx
|
|
, scaleSH
|
|
, colorSH
|
|
, overColSH
|
|
, overPosSH
|
|
, upperCylinder
|
|
, upperRounded
|
|
) where
|
|
import Geometry
|
|
import Shape.Data
|
|
import Color
|
|
|
|
-- - 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..]
|
|
|
|
-- - approximate a circle around the x axis by a polygon with n*2 points of radius r
|
|
polyCircx :: Int -> Float -> [Point3]
|
|
polyCircx n = map (vNormaly . addZ 0) . polyCirc n
|
|
|
|
-- very "unsafe": be careful with the inputs
|
|
-- 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
|
|
{-# INLINE prismPoly #-}
|
|
--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 _ _ = []
|
|
|
|
upperPrismPoly
|
|
:: Float -- ^ height, expected to be strictly positive
|
|
-> [Point2]
|
|
-> Shape
|
|
{-# INLINE upperPrismPoly #-}
|
|
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 FullShadowFidelity]
|
|
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 _ = []
|
|
|
|
upperCylinder
|
|
:: Float -- ^ height, expected to be strictly positive
|
|
-> [Point2]
|
|
-> Shape
|
|
{-# INLINE upperCylinder #-}
|
|
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
|
|
g h' (V2 x y) = V3 x y h'
|
|
f (x:xs) = g h x : g 0 x : f xs
|
|
f _ = []
|
|
|
|
upperRounded
|
|
:: Float -- ^ height, expected to be strictly positive
|
|
-> [Point2]
|
|
-> Shape
|
|
{-# INLINE upperRounded #-}
|
|
upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white FullShadowFidelity]
|
|
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 _ = []
|
|
|
|
upperPrismPolyHalf
|
|
:: Float -- ^ height, expected to be strictly positive
|
|
-> [Point2]
|
|
-> Shape
|
|
{-# INLINE upperPrismPolyHalf #-}
|
|
upperPrismPolyHalf h ps = prismPoly 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
|
|
|
|
colorSH :: Color -> Shape -> Shape
|
|
{-# INLINE colorSH #-}
|
|
colorSH = overColSH . const
|
|
|
|
overColSH :: (Point4 -> Point4) -> Shape -> Shape
|
|
{-# INLINE overColSH #-}
|
|
overColSH = map . overColObj
|
|
|
|
translateSH :: Point3 -> Shape -> Shape
|
|
{-# INLINE translateSH #-}
|
|
translateSH !p = overPosSH (+.+.+ p)
|
|
|
|
translateSHxy :: Float -> Float -> Shape -> Shape
|
|
{-# INLINE translateSHxy #-}
|
|
translateSHxy !x !y = translateSH (V3 x y 0)
|
|
|
|
translateSHz :: Float -> Shape -> Shape
|
|
{-# INLINE translateSHz #-}
|
|
translateSHz !z = translateSH (V3 0 0 z)
|
|
|
|
rotateSH :: Float -> Shape -> Shape
|
|
{-# INLINE rotateSH #-}
|
|
rotateSH = overPosSH . rotate3
|
|
|
|
overPosSH :: (Point3 -> Point3) -> Shape -> Shape
|
|
{-# INLINEABLE overPosSH #-}
|
|
overPosSH = map . overPosObj
|
|
|
|
rotateSHx :: Float -> Shape -> Shape
|
|
{-# INLINE rotateSHx #-}
|
|
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))
|
|
|
|
overColObj :: (Point4 -> Point4) -> Surface -> Surface
|
|
{-# INLINE overColObj #-}
|
|
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 sfid) = Surface st (map f vs) col sfid
|