107 lines
3.5 KiB
Haskell
107 lines
3.5 KiB
Haskell
{-# 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)]
|
|
]
|
|
)
|