126 lines
3.2 KiB
Haskell
126 lines
3.2 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Shape
|
|
( module Shape.Data
|
|
, translateSH
|
|
, emptySH
|
|
, upperPrismPoly
|
|
, upperPrismPolyHalf
|
|
, prismPoly
|
|
, polyCirc
|
|
, translateSHz
|
|
, translateSHf
|
|
, rotateSH
|
|
, scaleSH
|
|
, colorSH
|
|
)
|
|
where
|
|
import Geometry
|
|
import Geometry.Vector3D
|
|
import Shape.Data
|
|
import Color
|
|
|
|
emptySH :: Shape
|
|
{-# INLINE emptySH #-}
|
|
emptySH = mempty
|
|
|
|
polyCirc :: Int -> Float -> [Point2]
|
|
{-# INLINE polyCirc #-}
|
|
polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/fromIntegral 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 = [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 = [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 _ [] = []
|
|
f' (V2 x y) = pairToSV (V3 x y h, black)
|
|
f'' (V2 x y) = pairToSV (V3 x y 0, black)
|
|
|
|
upperPrismPolyHalf
|
|
:: Float -- ^ height, expected to be strictly positive
|
|
-> [Point2]
|
|
-> Shape
|
|
{-# INLINE upperPrismPolyHalf #-}
|
|
upperPrismPolyHalf h ps = [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 _ [] = []
|
|
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 col = overCol $ const col
|
|
|
|
overCol :: (Point4 -> Point4) -> Shape -> Shape
|
|
{-# INLINE overCol #-}
|
|
overCol f = fmap $ overColObj f
|
|
|
|
overPos :: (Point3 -> Point3) -> Shape -> Shape
|
|
{-# INLINE overPos #-}
|
|
overPos f = fmap $ overPosObj f
|
|
|
|
translateSH :: Point3 -> Shape -> Shape
|
|
{-# INLINE translateSH #-}
|
|
translateSH !p = overPos (+.+.+ 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 a = overPos (rotate3 a)
|
|
|
|
scaleSH :: Point3 -> Shape -> Shape
|
|
{-# INLINE scaleSH #-}
|
|
scaleSH (V3 a b c) = overPos (\(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 (map (overColVertex 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 $ map (overPosVertex f) vs
|
|
|
|
overPosVertex :: (Point3 -> Point3) -> ShapeV -> ShapeV
|
|
{-# INLINE overPosVertex #-}
|
|
overPosVertex f (ShapeV a b) = ShapeV (f a) b
|