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 Dodge.Data.Prop
import Geometry.Data import Geometry.Data
import Geometry.Polygon import Geometry.Polygon
@@ -7,13 +11,12 @@ import Picture
import qualified Quaternion as Q import qualified Quaternion as Q
import Shape import Shape
import ShapePicture import ShapePicture
import Control.Lens
drawProp' :: Prop -> SPic propSPic :: Prop -> SPic
drawProp' pr = drawProp (_prDraw pr) pr propSPic pr = drawProp (_prDraw pr) pr
drawProp :: PropDraw -> Prop -> SPic drawProp :: PropDraw -> Prop -> SPic
drawProp pd = case pd of drawProp = \case
PropDrawSPic spic -> const spic PropDrawSPic spic -> const spic
PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (drawProp pd' pr) PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (drawProp pd' pr)
PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh) PropDrawMovingShapeCol sh -> (`drawMovingShapeCol` sh)
@@ -29,11 +32,11 @@ drawGib :: Float -> Prop -> Shape
drawGib x pr = flesh <> skin drawGib x pr = flesh <> skin
where where
flesh = flesh =
colorSH (dark $ dark red) colorSH (dark $ dark red) $
$ translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous) translateSHz (negate x) (baseCube & each . sfShadowImportance .~ Superfluous)
skin = skin =
colorSH (_prColor pr) colorSH (_prColor pr) $
$ translateSH (V3 1 1 (1 - x)) baseCube translateSH (V3 1 1 (1 - x)) baseCube
baseCube = upperPrismPoly Small Typical (2 * x) $ square x baseCube = upperPrismPoly Small Typical (2 * x) $ square x
propDrawToggle :: PropDraw -> Prop -> SPic propDrawToggle :: PropDraw -> Prop -> SPic
@@ -42,31 +45,34 @@ propDrawToggle pd pr
| otherwise = drawProp pd pr | otherwise = drawProp pd pr
drawLampCover :: Float -> Prop -> SPic drawLampCover :: Float -> Prop -> SPic
drawLampCover h pr = noPic drawLampCover h pr =
( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $ noPic
rotateSH (_prRot pr) $ ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
mconcat rotateSH (_prRot pr) $
[ aface 1 2 (-1) mconcat
, aface 1 (-1) 2 [ aface 1 2 (-1)
, aface 2 2 (-1) , aface 1 (-1) 2
, aface 2 (-1) 2 , aface 2 2 (-1)
, upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)] , aface 2 (-1) 2
] , upperPrismPoly Small Essential 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)]
) ]
)
where where
aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1 $ rectNSWE 3 s w 3 aface ztran s w = translateSHz ztran . upperPrismPoly Small Essential 1 $ rectNSWE 3 s w 3
drawVerticalLampCover :: Float -> Prop -> SPic drawVerticalLampCover :: Float -> Prop -> SPic
drawVerticalLampCover h pr = noPic drawVerticalLampCover h pr =
( translateSHz h . uncurryV translateSHxy (_prPos pr) . noPic
rotateSHx (_prRot pr) . ( translateSHz h . uncurryV translateSHxy (_prPos pr)
translateSHz (-3) . upperPrismPoly Small Essential 1 $ rectNSWE 2 (-2) (-5) 5 . rotateSHx (_prRot pr)
. translateSHz (-3)
) . upperPrismPoly Small Essential 1
$ rectNSWE 2 (-2) (-5) 5
)
drawMovingShape :: Prop -> SPic -> SPic drawMovingShape :: Prop -> SPic -> SPic
drawMovingShape pr = drawMovingShape pr =
translateSPz (_prPosZ pr) translateSPz (_prPosZ pr)
. uncurryV translateSPxy (_prPos pr) . uncurryV translateSPxy (_prPos pr)
. overPosSP (Q.rotate (_prQuat pr)) . overPosSP (Q.rotate (_prQuat pr))
@@ -79,13 +85,14 @@ drawMovingShapeCol pr =
. colorSH (_prColor pr) . colorSH (_prColor pr)
drawDoubleLampCover :: Float -> Prop -> SPic drawDoubleLampCover :: Float -> Prop -> SPic
drawDoubleLampCover h pr = noPic drawDoubleLampCover h pr =
( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $ noPic
rotateSH (_prRot pr) $ ( translateSHz (h -2.5) . uncurryV translateSHxy (_prPos pr) $
mconcat rotateSH (_prRot pr) $
[ upperPrismPoly Small Essential 5 $ rectNSWE 6 5 (-6) 6 mconcat
, upperPrismPoly Small Essential 5 $ rectNSWE (-5) (-6) (-6) 6 [ upperPrismPoly Small Essential 5 $ rectNSWE 6 5 (-6) 6
, upperPrismPoly Small Essential 1 [V2 0 (-1), V2 6 5, V2 (-6) 5] , 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]
] , 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 :: Configuration -> Universe -> SPic
worldSPic cfig u = worldSPic cfig u =
(mempty :!: extraPics cfig u) (mempty :!: extraPics cfig u)
<> foldup drawProp' (filtOn _prPos _props) <> foldup propSPic (filtOn _prPos _props)
<> foldup drawProjectile (filtOn _pjPos _projectiles) <> foldup drawProjectile (filtOn _pjPos _projectiles)
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks) <> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes) <> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)