{-# LANGUAGE LambdaCase #-}
module Dodge.Prop.Draw (
    propSPic,
    debrisSPic,
) where

import Dodge.Block.Debris
import Control.Lens
import Dodge.Data.Prop
import Geometry.Data
import Geometry.Polygon
import Picture
import qualified Quaternion as Q
import Shape
import ShapePicture

propSPic :: Prop -> SPic
propSPic pr = drawProp (_prDraw pr) pr

debrisSPic :: Debris -> SPic
debrisSPic db = translateSP (_dbPos db) . overPosSP (Q.rotate (_dbRot db)) $
     case db ^. dbType of
        Gib x col -> noPic $ drawGib x col
        BlockDebris m -> noPic . colorSH m $ cubeShape 4

drawProp :: PropDraw -> Prop -> SPic
drawProp = \case
    PropDrawSPic spic -> const spic
--    PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (drawProp pd' pr)
--    PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh)
    PropDoubleLampCover h -> drawDoubleLampCover h
    PropVerticalLampCover h -> drawVerticalLampCover h
    PropLampCover h -> drawLampCover h
    PropDrawToggle pd' -> propDrawToggle pd'
--    PropDrawGib x -> noPic . drawGib x
    PropDrawFlatTranslate x -> \pr ->
        uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr

drawGib :: Float -> Color -> Shape
drawGib x col = flesh <> skin
  where
    flesh =
        colorSH (dark $ dark red) $
            translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
    skin =
        colorSH col $
            translateSH (V3 1 1 (1 - x)) baseCube
    baseCube = upperPrismPoly Small Typical (2 * x) $ square x

propDrawToggle :: PropDraw -> Prop -> SPic
propDrawToggle pd pr
    | not (_prToggle pr) = mempty
    | otherwise = drawProp pd pr

drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr =
    noPic
        ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
            rotateSH (_prRot pr) $
                mconcat
                    [ aface 1 2 (-1)
                    , aface 1 (-1) 2
                    , aface 2 2 (-1)
                    , aface 2 (-1) 2
                    , upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)]
                    ]
        )
  where
    aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1 $ rectNSWE 3 s w 3

drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr =
    noPic
        ( translateSHz h . uncurryV translateSHxy (_prPos pr)
            . rotateSHx (_prRot pr)
            . translateSHz (-3)
            . upperPrismPoly Small Essential 1
            $ rectNSWE 2 (-2) (-5) 5
        )

--drawMovingShape :: Prop -> SPic -> SPic
--drawMovingShape pr =
--    translateSPz (_prPosZ pr)
--        . uncurryV translateSPxy (_prPos pr)
--        . overPosSP (Q.rotate (_prQuat pr))

--drawMovingShapeCol :: Prop -> Shape -> SPic
--drawMovingShapeCol pr =
--    noPic
--        . translateSHz (_prPosZ pr)
--        . uncurryV translateSHxy (_prPos pr)
--        . overPosSH (Q.rotate (_prQuat pr))
--        . colorSH (_prColor pr)

drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr =
    noPic
        ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
            rotateSH (_prRot pr) $
                mconcat
                    [ upperPrismPoly Small Essential 5 $ rectNSWE 6 5 (-6) 6
                    , upperPrismPoly Small Essential 5 $ rectNSWE (-5) (-6) (-6) 6
                    , upperPrismPoly Small Essential 1 [V2 0 (-1), V2 6 5, V2 (-6) 5]
                    , upperPrismPoly Small Essential 1 [V2 0 1, V2 (-6) (-5), V2 6 (-5)]
                    ]
        )