loop/src/Shape.hs

{-# LANGUAGE BangPatterns  #-}
module Shape
    ( module Shape.Data
    , translateSH
    , emptySH
    , upperPrismPoly
    , upperPrismPolyHalf
    , prismPoly
    , polyCirc
    , upperBox
    , translateSHz
    , translateSHf
    , rotateSH
    , rotateSHx
    , polyCircx
    , scaleSH
    , colorSH
    , overColSH
--    , overColSHM
    , overPosSH
    , upperCylinder
    ) where
import Geometry
import Shape.Data
import Color

singleShape :: Surface -> Shape
{-# INLINE singleShape #-}
singleShape = (:[])

shMap :: (Surface -> Surface) -> 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 (Surface (TopPrism n) (f upps downps) black)
  where
    n = length upps
    f (a:as) (b:bs) = a:b:f as bs
    f [] _ = []
    f _ [] = []

upperPrismPoly 
    :: Float    -- ^ height, expected to be strictly positive
    -> [Point2] 
    -> Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly h ps = singleShape (Surface (TopPrism n) (f ps) black)
  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 _ = []

upperBox 
    :: Float    -- ^ height, expected to be strictly positive
    -> [Point2] 
    -> Shape
{-# INLINE upperBox #-}
upperBox h ps = singleShape (Surface (FlatFaces 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 _ = []

upperCylinder 
    :: Float    -- ^ height, expected to be strictly positive
    -> [Point2] 
    -> Shape
{-# INLINE upperCylinder #-}
upperCylinder h ps = singleShape (Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) black)
  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 = singleShape (Surface (TopPrism n) (f upps downps) black)
  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)

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) -> Surface -> Surface
{-# INLINE overColObj #-}
overColObj f (Surface st vs col) = Surface st vs (f col)

--overColObjM :: Monad m => (Point4 -> m Point4) -> ShapeObj -> m ShapeObj
--{-# INLINE overColObjM #-}
--overColObjM f (ShapeObj st vs) = ShapeObj st <$> mapM (svCol f) vs

overPosObj :: (Point3 -> Point3) -> Surface -> Surface
{-# INLINE overPosObj #-}
overPosObj f (Surface st vs col) = Surface st (map f vs) col