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

Commit before unifying positions

Browse Source
This commit is contained in:
justin
2021-11-03 19:01:19 +00:00
parent 903a79cf85
commit f45d19a787
7 changed files with 54 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen.hs
+8 -6
View File
@@ -26,12 +26,12 @@ placeSpot :: World -> ((Point2,Float) , Placement) -> World
placeSpot w (shift, plmnt@Placement{}) =
let (i,w') = placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w
in maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
placeSpot w (shift, PlacementPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
placeSpot w (shift, PlacementUsingPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
shiftPlacement :: (Point2,Float) -> Placement -> Placement
shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
(fmap (fmap $ shiftPlacement shift) f)
shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p)
(fmap (shiftPlacement shift) f)
shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
@@ -59,10 +59,7 @@ placeSpotID ps pt w = case pt of
PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
PutBlock{} -> error "messed up block placement somehow"
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
where
qs = map doShift ps'
rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w)
PutID i -> (i, w)
@@ -72,6 +69,11 @@ placeSpotID ps pt w = case pt of
rot = _psRot ps
doShift = shiftPointBy (p,rot)
placeWallPoly :: [Point2] -> Wall -> World -> World
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
where
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
shiftPointBy :: (Point2,Float) -> Point2 -> Point2
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p