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

-- - 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 = [Surface (TopPrism n) (f upps downps) white FullShadowFidelity]
prismPoly upps downps = [Surface (RoundedFaces n) (cp:cp:f upps downps) white FullShadowFidelity]
  where
    cp = centroidNum $ upps ++ downps
    n = length upps
    f (a:as) (b:bs) = a:b:f as bs
    f _ _ = []

upperPrismPoly 
    :: Float    -- ^ height, expected to be strictly positive
    -> [Point2] 
    -> Shape
{-# INLINE upperPrismPoly #-}
upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)

upperBox 
    :: Float    -- ^ height, expected to be strictly positive
    -> [Point2] 
    -> Shape
{-# INLINE upperBox #-}
upperBox h ps = [Surface (FlatFaces n) (f ps) white FullShadowFidelity]
  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 = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white FullShadowFidelity]
  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 _ = []

upperRounded 
    :: Float    -- ^ height, expected to be strictly positive
    -> [Point2] 
    -> Shape
{-# INLINE upperRounded #-}
upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white FullShadowFidelity]
  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 = prismPoly upps downps
  where
    upps = map f ps
    downps = map g ps
    f (V2 x y) = V3 (0.5 * x) (0.5 * y) h
    g (V2 x y) = V3 x y 0

colorSH :: Color -> Shape -> Shape
{-# INLINE colorSH #-}
colorSH = overColSH . const

overColSH :: (Point4 -> Point4) -> Shape -> Shape
{-# INLINE overColSH #-}
overColSH = map . overColObj

translateSH :: Point3 -> Shape -> Shape
{-# INLINE translateSH #-}
translateSH !p = overPosSH (+.+.+ p)

translateSHxy :: Float -> Float -> Shape -> Shape
{-# INLINE translateSHxy #-}
translateSHxy !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 = map . overPosObj

rotateSHx :: Float -> Shape -> Shape
{-# INLINE rotateSHx #-}
rotateSHx = overPosSH . rotate3x

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 sfid) = Surface st vs (f col) sfid

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