{-# 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