loop/src/Shape.hs

{-# LANGUAGE BangPatterns #-}

module Shape (
    module Shape.Data,
    translateSH,
    upperPrismPoly,
    upperPrismPolyMT,
    upperPrismPolySE,
    upperPrismPolyST,
    upperPrismPolySI,
    upperPrismPolySU,
    upperPrismPolyTS,
    upperBoxMT,
    upperBoxST,
    upperBoxSU,
    upperBoxHalf,
    upperPrismPolyHalf,
    upperPrismPolyHalfMI,
    upperPrismPolyHalfST,
    xCylinderST,
    prismPoly,
    prismBox,
    cylinderPoly,
    polyCirc,
    upperBox,
    translateSHz,
    translateSHxy,
    rotateSH,
    rotateSHx,
    rotateSHq,
    polyCircx,
    scaleSH,
    colorSH,
    overColSH,
    overPosSH,
    upperCylinder,
    upperRounded,
    xCylinder',
) where

import Color
import Geometry
import qualified Quaternion as Q
import Shape.Data

-- - 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 ::
    Size ->
    Importance ->
    [Point3] ->
    [Point3] ->
    Shape
{-# INLINE prismPoly #-}
prismPoly size shads upps downps = [Surface (RoundedFaces n) (cp : cp : f upps downps) white shads size]
  where
    cp = centroidNum $ upps ++ downps
    n = length upps
    f (a : as) (b : bs) = a : b : f as bs
    f _ _ = []

prismBox ::
    Size ->
    Importance ->
    [Point3] ->
    [Point3] ->
    Shape
{-# INLINE prismBox #-}
prismBox size shads upps downps = [Surface (FlatFaces n) (f upps downps) white shads size]
  where
    n = length upps
    f (a : as) (b : bs) = a : b : f as bs
    f _ _ = []

cylinderPoly ::
    Size ->
    Importance ->
    [Point3] ->
    [Point3] ->
    Shape
{-# INLINE cylinderPoly #-}
cylinderPoly size shads upps downps = [Surface (Cylinder n) (cp1 : cp2 : f upps downps) white shads size]
  where
    cp1 = centroidNum upps
    cp2 = centroidNum downps
    n = length upps
    f (a : as) (b : bs) = a : b : f as bs
    f _ _ = []

upperPrismPolyMT :: Float -> [Point2] -> Shape
upperPrismPolyMT = upperPrismPoly Medium Typical

upperPrismPolySE :: Float -> [Point2] -> Shape
upperPrismPolySE = upperPrismPoly Small Essential

upperPrismPolyST :: Float -> [Point2] -> Shape
upperPrismPolyST = upperPrismPoly Small Typical

upperPrismPolySI :: Float -> [Point2] -> Shape
upperPrismPolySI = upperPrismPoly Small Important

upperPrismPolySU :: Float -> [Point2] -> Shape
upperPrismPolySU = upperPrismPoly Small Unimportant

--upperPrismPolySS :: Float -> [Point2] -> Shape
--upperPrismPolySS = upperPrismPoly Small Superfluous

upperPrismPolyTS :: Float -> [Point2] -> Shape
upperPrismPolyTS = upperPrismPoly Tiny Superfluous

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

xCylinderST :: Float -> Float -> Shape
xCylinderST = xCylinder' Small Typical

xCylinder' :: Size -> Importance -> Float -> Float -> Shape
xCylinder' size shad r x =
    translateSHz r . rotateSHq (V3 0 1 0) (pi / 2) . upperCylinder size shad x $
        [ V2 r r
        , V2 (- r / 2) (r / 2)
        , V2 (- r / 2) (negate $ r / 2)
        , V2 r (- r)
        ]

upperBoxMT :: Float -> [Point2] -> Shape
upperBoxMT = upperBox Medium Typical

upperBoxST :: Float -> [Point2] -> Shape
upperBoxST = upperBox Small Typical

upperBoxSU :: Float -> [Point2] -> Shape
upperBoxSU = upperBox Small Unimportant

upperBox ::
    -- | height, expected to be strictly positive
    Size ->
    Importance ->
    Float ->
    [Point2] ->
    Shape
{-# INLINE upperBox #-}
upperBox size shad h ps = prismBox size shad (map (addZ h) ps) (map (addZ 0) ps)

rotateSHq :: Point3 -> Float -> Shape -> Shape
rotateSHq p = overPosSH . Q.rotate . Q.axisAngle p

upperCylinder ::
    -- | height, expected to be strictly positive
    Size ->
    Importance ->
    Float ->
    [Point2] ->
    Shape
{-# INLINE upperCylinder #-}
upperCylinder size shad h ps = [Surface (Cylinder n) (addZ (h -0.5) cc : addZ 0.5 cc : f ps) white shad size]
  where
    cc = V2 0 0
    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 ::
    -- | height, expected to be strictly positive
    Size ->
    Importance ->
    Float ->
    [Point2] ->
    Shape
{-# INLINE upperRounded #-}
upperRounded size shad h ps = [Surface (RoundedFaces n) (addZ h cc : addZ 0 cc : f ps) white shad size]
  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 _ = []

upperPrismPolyHalfMI :: Float -> [Point2] -> Shape
upperPrismPolyHalfMI = upperPrismPolyHalf Medium Important

upperPrismPolyHalfST :: Float -> [Point2] -> Shape
upperPrismPolyHalfST = upperPrismPolyHalf Small Typical

upperPrismPolyHalf ::
    -- | height, expected to be strictly positive
    Size ->
    Importance ->
    Float ->
    [Point2] ->
    Shape
{-# INLINE upperPrismPolyHalf #-}
upperPrismPolyHalf size shad h ps = prismPoly size shad 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

upperBoxHalf ::
    -- | height, expected to be strictly positive
    Size ->
    Importance ->
    Float ->
    [Point2] ->
    Shape
{-# INLINE upperBoxHalf #-}
upperBoxHalf size shad h ps = prismBox size shad 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 size) = Surface st vs (f col) sfid size

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