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

Simplify Prop drawing

Browse Source
This commit is contained in:
justin
2025-10-25 13:54:40 +01:00
parent ff03efc41f
commit 7585531dd1
9 changed files with 73 additions and 201 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Prop.hs
+2 -19
View File
@@ -14,7 +14,7 @@ import ShapePicture.Data
data Prop = ShapeProp
{ _prPos :: Point2
, _prDraw :: PropDraw
, _prDraw :: SPic
, _prUpdate :: PropUpdate
, _prID :: Int
, _prRot :: Float
@@ -22,10 +22,7 @@ data Prop = ShapeProp
}
data DebrisType
= Gib
{ _gibSize :: Float
, _gibColor :: Color
}
= Gib { _gibSize :: Float , _gibColor :: Color }
| BlockDebris {_bdColor :: Color}
data Debris = DebrisChunk
@@ -36,15 +33,6 @@ data Debris = DebrisChunk
, _dbSpin :: Q.Quaternion Float
}
data PropDraw
= PropDrawFlatTranslate SPic
| PropDoubleLampCover Float
| PropVerticalLampCover Float
| PropLampCover Float
-- | PropDrawGib Float
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data PropUpdate
= PropUpdateId
| PropUpdateAnd PropUpdate PropUpdate
@@ -56,21 +44,16 @@ data PropUpdate
| PropUpdateWhen WdBl PropUpdate
| PropUpdateIf WdBl PropUpdate PropUpdate
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data PrWdLsLs
= PrWdLsId
| PrWdLsSetPosition WdP2f Point3
| PrWdLsSetColor Point3
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''Prop
makeLenses ''Debris
makeLenses ''DebrisType
deriveJSON defaultOptions ''DebrisType
deriveJSON defaultOptions ''Debris
deriveJSON defaultOptions ''PropDraw
deriveJSON defaultOptions ''PrWdLsLs
deriveJSON defaultOptions ''PropUpdate
deriveJSON defaultOptions ''Prop
src/Dodge/Default/Prop.hs
+1 -1
View File
@@ -7,7 +7,7 @@ defaultProp :: Prop
defaultProp =
ShapeProp
{ _prPos = V2 0 0
, _prDraw = PropDrawFlatTranslate mempty
, _prDraw = mempty
, _prID = 0
, _prUpdate = PropUpdateId
, _prToggle = True
src/Dodge/Placement/Instance.hs
-2
View File
@@ -1,7 +1,6 @@
module Dodge.Placement.Instance
( module Dodge.Placement.Instance.Door
, module Dodge.Placement.Instance.LightSource
, module Dodge.Placement.Instance.LightSource.Cover
, module Dodge.Placement.Instance.Wall
, module Dodge.Placement.Instance.Tank
, module Dodge.Placement.Instance.Button
@@ -14,7 +13,6 @@ module Dodge.Placement.Instance
where
import Dodge.Placement.Instance.Door
import Dodge.Placement.Instance.Tank
import Dodge.Placement.Instance.LightSource.Cover
import Dodge.Placement.Instance.LightSource
import Dodge.Placement.Instance.LightSource.Flicker
import Dodge.Placement.Instance.Wall
src/Dodge/Placement/Instance/LightSource.hs
+1 -1
View File
@@ -57,7 +57,7 @@ moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition
, _prRot = 0
, _prUpdate = PropUpdateId
, --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh
_prDraw = PropDrawFlatTranslate $ noPic sh
_prDraw = noPic sh
, _prToggle = True
}
src/Dodge/Placement/Instance/LightSource/Cover.hs
-43
View File
@@ -1,43 +0,0 @@
module Dodge.Placement.Instance.LightSource.Cover where
import Dodge.Data.Prop
import Dodge.Data.WorldEffect
import Dodge.Default.Prop
import Geometry.Data
lampCover :: Float -> Prop
lampCover h =
ShapeProp
{ _prPos = V2 0 0
, _prID = 0
, _prRot = 0
, _prUpdate = PropRotate 0.15
, _prDraw = PropLampCover h
, _prToggle = True
}
lampCoverWhen :: WdBl -> Point2 -> Float -> Prop
lampCoverWhen cond pos h =
defaultProp
{ _prPos = pos
, _prUpdate = PropSetToggleAnd cond (PropRotate 0.15)
, _prDraw = PropLampCover h
, _prToggle = True
}
doubleLampCover :: Float -> Prop
doubleLampCover h =
defaultProp
{ _prPos = V2 0 0
, _prUpdate = PropRotate 0.15
, _prDraw = PropDoubleLampCover h
}
-- on the current (27/9/21) version of shadow stencilling, this glitches
-- slightly when the shadow rotates towards the screen
verticalLampCover :: Float -> Prop
verticalLampCover h =
defaultProp
{ _prUpdate = PropRotate 0.15
, _prDraw = PropVerticalLampCover h
}
src/Dodge/Prop/Draw.hs
+7 -62
View File
@@ -1,11 +1,12 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Prop.Draw (
propSPic,
debrisSPic,
) where
import Dodge.Block.Debris
import Control.Lens
import Dodge.Block.Debris
import Dodge.Data.Prop
import Geometry.Data
import Geometry.Polygon
@@ -15,21 +16,17 @@ import Shape
import ShapePicture
propSPic :: Prop -> SPic
propSPic pr = drawProp (_prDraw pr) pr
propSPic pr = drawProp pr
debrisSPic :: Debris -> SPic
debrisSPic db = translateSP (_dbPos db) . overPosSP (Q.rotate (_dbRot db)) $
case db ^. dbType of
case db ^. dbType of
Gib x col -> noPic $ drawGib x col
BlockDebris m -> noPic . colorSH m $ cubeShape 4
drawProp :: PropDraw -> Prop -> SPic
drawProp = \case
PropDoubleLampCover h -> drawDoubleLampCover h
PropVerticalLampCover h -> drawVerticalLampCover h
PropLampCover h -> drawLampCover h
PropDrawFlatTranslate x -> \pr ->
uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) x
drawProp :: Prop -> SPic
drawProp pr =
uncurryV translateSPxy (_prPos pr) $ rotateSP (_prRot pr) $ pr ^. prDraw
drawGib :: Float -> Color -> Shape
drawGib x col = flesh <> skin
@@ -42,55 +39,3 @@ drawGib x col = flesh <> skin
translateSH (V3 1 1 (1 - x)) baseCube
baseCube = upperPrismPoly Small Typical (2 * x) $ square x
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)]
]
)
src/Dodge/Room/LongDoor.hs
+2 -9
View File
@@ -52,8 +52,8 @@ twinSlowDoorRoom w h x =
[ pContID (PS (V2 0 (h -5)) pi) (PutButton $ makeButton col NoWorldEffect) $
\btid -> jsps0J (putSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) $
ps0 (putSlideDr (thedoor btid) thewall 1 (V2 (- x) 1) (V2 (- x) h)) $
\did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $
\lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
\_ -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $
\_ -> Nothing -- jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight
]
, _rmBound = ps
, _rmName = "twinSlowDoorRoom"
@@ -63,13 +63,6 @@ twinSlowDoorRoom w h x =
--thewall = switchWallCol red
thewall = defaultDoorWall
wlSpeed = 0.5
addColorChange lsid drid =
over prUpdate $
PropUpdateAnd $
PropUpdateIf
(WdBlDoorMoving drid)
(PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0)))
(PropUpdateLS lsid (PrWdLsSetColor 0.7))
lampheight = 41
ps =
[ rectNSWE h 0 (- w) w
src/Dodge/Room/Tutorial.hs
+2 -2
View File
@@ -46,7 +46,8 @@ tutAnoTree = do
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward airlock90
-- , return $ tToBTree "cor" $ return $ cleatOnward airlock90
, return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward airlock0
, return $ tToBTree "cor" $ return $ cleatOnward corridor
@@ -62,7 +63,6 @@ tutAnoTree = do
, return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor