146 lines
3.9 KiB
Haskell
146 lines
3.9 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Shape
|
|
( module Shape.Data
|
|
, translateSH
|
|
, emptySH
|
|
, upperPrismPoly
|
|
, upperPrismPolyHalf
|
|
, prismPoly
|
|
, polyCirc
|
|
, translateSHz
|
|
, translateSHf
|
|
, rotateSH
|
|
, rotateSHx
|
|
, polyCircx
|
|
, scaleSH
|
|
, colorSH
|
|
, overColSH
|
|
-- , overColSHM
|
|
, overPosSH
|
|
) where
|
|
import Geometry
|
|
import Shape.Data
|
|
import Color
|
|
--import qualified Streaming.Prelude as S
|
|
|
|
singleShape :: ShapeObj -> Shape
|
|
{-# INLINE singleShape #-}
|
|
singleShape = (:[])
|
|
|
|
shMap :: (ShapeObj -> ShapeObj) -> Shape -> Shape
|
|
{-# INLINE shMap #-}
|
|
shMap = map
|
|
|
|
emptySH :: Shape
|
|
{-# INLINE emptySH #-}
|
|
emptySH = mempty
|
|
|
|
-- - 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 = singleShape (ShapeObj (TopPrism n) (f upps downps))
|
|
where
|
|
n = length upps
|
|
f (a:as) (b:bs) = g a:g 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))
|
|
where
|
|
n = length ps
|
|
g h' (V2 x y) = pairToSV (V3 x y h', black)
|
|
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 = singleShape (ShapeObj (TopPrism n) (f 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) = pairToSV (V3 (0.5 * x) (0.5 * y) h, black)
|
|
f'' (V2 x y) = pairToSV (V3 x y 0, black)
|
|
|
|
colorSH :: Color -> Shape -> Shape
|
|
{-# INLINE colorSH #-}
|
|
colorSH = overColSH . const
|
|
|
|
overColSH :: (Point4 -> Point4) -> Shape -> Shape
|
|
{-# INLINE overColSH #-}
|
|
overColSH = shMap . overColObj
|
|
|
|
translateSH :: Point3 -> Shape -> Shape
|
|
{-# INLINE translateSH #-}
|
|
translateSH !p = overPosSH (+.+.+ p)
|
|
|
|
translateSHf :: Float -> Float -> Shape -> Shape
|
|
{-# INLINE translateSHf #-}
|
|
translateSHf !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 = shMap . overPosObj
|
|
|
|
rotateSHx :: Float -> Shape -> Shape
|
|
{-# INLINE rotateSHx #-}
|
|
rotateSHx a = overPosSH (rotate3x a)
|
|
|
|
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
|
|
{-# INLINE overColObj #-}
|
|
overColObj f (ShapeObj st vs) = ShapeObj st (fmap (overColVertex f) vs)
|
|
|
|
--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
|
|
{-# 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
|