99 lines
3.2 KiB
Haskell
99 lines
3.2 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
module Dodge.Prop.Draw (
|
|
propSPic,
|
|
) where
|
|
|
|
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
|
|
|
|
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 -> Prop -> Shape
|
|
drawGib x pr = flesh <> skin
|
|
where
|
|
flesh =
|
|
colorSH (dark $ dark red) $
|
|
translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
|
|
skin =
|
|
colorSH (_prColor pr) $
|
|
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)]
|
|
]
|
|
)
|