{-# LANGUAGE BangPatterns  #-}
module Shape
    ( module Shape.Data
    , translateSH
    , emptySH
    , upperPrismPoly
    , 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..]

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)

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
