justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
justin
2025-05-21 22:48:18 +01:00
parent 612ae236df
commit 3efa01bf09
2 changed files with 45 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Prop/Draw.hs
+44 -37
View File
@@ -1,5 +1,9 @@
module Dodge.Prop.Draw where
{-# LANGUAGE LambdaCase #-}
module Dodge.Prop.Draw (
propSPic,
) where
import Control.Lens
import Dodge.Data.Prop
import Geometry.Data
import Geometry.Polygon
@@ -7,13 +11,12 @@ import Picture
import qualified Quaternion as Q
import Shape
import ShapePicture
import Control.Lens
drawProp' :: Prop -> SPic
drawProp' pr = drawProp (_prDraw pr) pr
propSPic :: Prop -> SPic
propSPic pr = drawProp (_prDraw pr) pr
drawProp :: PropDraw -> Prop -> SPic
drawProp pd = case pd of
drawProp = \case
PropDrawSPic spic -> const spic
PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (drawProp pd' pr)
PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh)
@@ -29,11 +32,11 @@ drawGib :: Float -> Prop -> Shape
drawGib x pr = flesh <> skin
where
flesh =
colorSH (dark $ dark red)
$ translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
colorSH (dark $ dark red) $
translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
skin =
colorSH (_prColor pr)
$ translateSH (V3 1 1 (1 - x)) baseCube
colorSH (_prColor pr) $
translateSH (V3 1 1 (1 - x)) baseCube
baseCube = upperPrismPoly Small Typical (2 * x) $ square x
propDrawToggle :: PropDraw -> Prop -> SPic
@@ -42,31 +45,34 @@ propDrawToggle pd pr
| 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)]
]
)
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
)
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)
translateSPz (_prPosZ pr)
. uncurryV translateSPxy (_prPos pr)
. overPosSP (Q.rotate (_prQuat pr))
@@ -79,13 +85,14 @@ drawMovingShapeCol 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)]
]
)
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)]
]
)
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -23,7 +23,7 @@ import ShapePicture
worldSPic :: Configuration -> Universe -> SPic
worldSPic cfig u =
(mempty :!: extraPics cfig u)
<> foldup drawProp' (filtOn _prPos _props)
<> foldup propSPic (filtOn _prPos _props)
<> foldup drawProjectile (filtOn _pjPos _projectiles)
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)