Fix wall bug, refactor placements

This commit is contained in:
2021-09-30 15:35:35 +01:00
parent eb393708c4
commit c88f88004d
17 changed files with 54 additions and 80 deletions
+1 -6
View File
@@ -3,6 +3,7 @@ module Dodge.LightSources.Fitting
import Dodge.LightSources.Lamp
import Dodge.LevelGen.Data
import Dodge.Room.Foreground
import Dodge.Placement
import Geometry
wallMount :: Point2 -> Point3 -> Placement
@@ -66,9 +67,3 @@ wallMountV wallpos lamppos@(V3 x y z)
extendAway :: Point2 -> Point2 -> Point2
extendAway p x = p +.+ safeNormalizeV (p -.- x)
jsps0 :: PSType -> Maybe Placement
jsps0 pst = Just $ sPS (V2 0 0) 0 pst
place0 :: PSType -> (Int -> Maybe Placement) -> Placement
place0 pst = Placement (PS (V2 0 0) 0 pst)
+3 -4
View File
@@ -86,9 +86,9 @@ lampCover h = ShapeProp
, _prDraw = drawLampCover h
, _prToggle = True
}
lampCoverWhen :: (World -> Bool) -> Float -> Prop
lampCoverWhen cond h = ShapeProp
{ _pjPos = V2 0 0
lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop
lampCoverWhen cond pos h = ShapeProp
{ _pjPos = pos
, _pjID = 0
, _pjRot = 0
, _pjUpdate = setToggle cond `chain` rotateProp 0.15
@@ -138,7 +138,6 @@ drawLampCover h pr | not (_prToggle pr) = mempty
, translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2 3 (-1)
, translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
--, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
, upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
]
, mempty