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

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 = [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 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 = [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 = overCol . const

overCol :: (Point4 -> Point4) -> Shape -> Shape
{-# INLINE overCol #-}
overCol = fmap . overColObj

overPosSHI :: (Point3 -> Point3) -> Shape -> Shape
{-# INLINE overPosSHI #-}
overPosSHI = fmap . overPosObj

translateSH :: Point3 -> Shape -> Shape
{-# INLINE translateSH #-}
translateSH !p = overPosSHI (+.+.+ 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 = overPosSHI . rotate3

overPosSH :: (Point3 -> Point3) -> Shape -> Shape
{-# INLINEABLE overPosSH #-}
overPosSH = overPosSHI

rotateSHx :: Float -> Shape -> Shape
{-# INLINE rotateSHx #-}
rotateSHx a = overPosSHI (rotate3x a)

scaleSH :: Point3 -> Shape -> Shape
{-# INLINE scaleSH #-}
scaleSH (V3 a b c) = overPosSHI (\(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