88 lines
2.9 KiB
Haskell
88 lines
2.9 KiB
Haskell
module Dodge.Prop.Draw
|
|
where
|
|
import Geometry.Polygon
|
|
import Geometry.Data
|
|
import Dodge.Data.Prop
|
|
import ShapePicture
|
|
import Shape
|
|
import Picture
|
|
import qualified Quaternion as Q
|
|
|
|
drawProp' :: Prop -> SPic
|
|
drawProp' pr = drawProp (_prDraw pr) pr
|
|
|
|
drawProp :: PropDraw -> Prop -> SPic
|
|
drawProp pd = case pd of
|
|
PropDrawSPic spic -> const spic
|
|
PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (fst $ drawProp pd' pr)
|
|
PropDrawMovingShapeCol sh -> \pr -> drawMovingShapeCol pr 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 translateSPf (_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)
|
|
$ upperPrismPoly (2*x) $ square x
|
|
skin = colorSH (_prColor pr)
|
|
. translateSH (V3 1 1 (1 - x))
|
|
$ upperPrismPoly (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 = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
|
$ rotateSH (_prRot pr) $ mconcat
|
|
[ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
|
, translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
|
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3
|
|
, translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3
|
|
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
|
|
]
|
|
, mempty
|
|
)
|
|
|
|
drawVerticalLampCover :: Float -> Prop -> SPic
|
|
drawVerticalLampCover h pr =
|
|
( translateSHz h . uncurryV translateSHf (_prPos pr)
|
|
$ rotateSHx (_prRot pr) $ mconcat
|
|
[
|
|
translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
|
|
]
|
|
, mempty
|
|
)
|
|
|
|
drawMovingShape :: Prop -> Shape -> SPic
|
|
drawMovingShape pr = noPic
|
|
. translateSHz (_prPosZ pr)
|
|
. uncurryV translateSHf (_prPos pr)
|
|
. overPosSH (Q.rotate (_prQuat pr))
|
|
|
|
drawMovingShapeCol :: Prop -> Shape -> SPic
|
|
drawMovingShapeCol pr = noPic
|
|
. translateSHz (_prPosZ pr)
|
|
. uncurryV translateSHf (_prPos pr)
|
|
. overPosSH (Q.rotate (_prQuat pr))
|
|
. colorSH (_prColor pr)
|
|
|
|
drawDoubleLampCover :: Float -> Prop -> SPic
|
|
drawDoubleLampCover h pr =
|
|
( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
|
|
$ rotateSH (_prRot pr) $ mconcat
|
|
[ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6
|
|
, upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
|
|
, upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
|
|
, upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)]
|
|
]
|
|
, mempty
|
|
)
|