Add support for group placements
This commit is contained in:
+66
-52
@@ -37,56 +37,66 @@ import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
||||
placeSpots :: [PlacementSpot] -> World -> World
|
||||
placeSpots pss w = foldr placeSpot w pss
|
||||
placeSpots :: [Placement] -> World -> World
|
||||
placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements
|
||||
where
|
||||
(singlePlacements, groupedPlacements) = partition isSPS pss
|
||||
isSPS (SinglePlacement {}) = True
|
||||
isSPS _ = False
|
||||
gplmnts = groupBy ((==) `on` _groupPlacementID) $ sortOn _groupPlacementID groupedPlacements
|
||||
w' = foldr updateGroup w gplmnts
|
||||
|
||||
{- | OK, this is perhaps slightly impenetrable.
|
||||
- The idea is that for a list of collected group placements, we first update
|
||||
- the world for each placement and update the placements into PSTypes.
|
||||
- This is the mapAccumR step.
|
||||
- After this, for each placement we apply the group placement function to
|
||||
- the psType using a zipWith, and taking all the pstypes as a paramenter,
|
||||
- then successively update the world using a foldr. -}
|
||||
updateGroup :: [Placement] -> World -> World
|
||||
updateGroup ps w =
|
||||
let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
|
||||
fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
|
||||
in foldr ($) w' fs
|
||||
|
||||
updateSpot :: World -> PlacementSpot -> (World, PSType)
|
||||
updateSpot w ps = case _psType ps of
|
||||
PutButton bt -> undefined
|
||||
PutCrit cr -> placeUpdateCr cr p rot w
|
||||
where
|
||||
p = _psPos ps
|
||||
rot = _psRot ps
|
||||
|
||||
placeSpot :: PlacementSpot -> World -> World
|
||||
placeSpot ps w = case ps of
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutButton bt}
|
||||
-> placeBt bt p rot w
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutFlIt itm}
|
||||
-> placeFlIt itm p rot w
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutCrit cr}
|
||||
-> placeCr cr p rot w
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec}
|
||||
-> placeLS ls dec p rot w
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp}
|
||||
-> placePressPlate pp p rot w
|
||||
PS {_psType = RandPS rgen}
|
||||
-> placeSpot (set psType evaluatedType ps) (set randGen g w)
|
||||
placeSpot ps w = case _psType ps of
|
||||
PutButton bt -> placeBt bt p rot w
|
||||
PutFlIt itm -> placeFlIt itm p rot w
|
||||
PutCrit cr -> placeCr cr p rot w
|
||||
PutLS ls dec -> placeLS ls dec p rot w
|
||||
PutPressPlate pp -> placePressPlate pp p rot w
|
||||
RandPS rgen -> placeSpot (set psType evaluatedType ps) (set randGen g w)
|
||||
where
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutDoor col f pss}
|
||||
-> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
|
||||
(evaluatedType, g) = runState rgen (_randGen w)
|
||||
PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
|
||||
where
|
||||
mapBoth fn (x,y) = (fn x, fn y)
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutDoubleDoor col f a b}
|
||||
-> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b}
|
||||
-> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps}
|
||||
-> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b}
|
||||
-> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PutBlock (hp:hps) col ps -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
|
||||
PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b}
|
||||
-> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
|
||||
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutLineBlock wl width depth a b}
|
||||
PutLineBlock wl width depth a b
|
||||
-> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
|
||||
|
||||
PS {_psPos = p, _psRot = rot, _psType = PutWall { _pwPoly = ps, _pwWall = wl }}
|
||||
-> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
|
||||
where (q:qs) = map (shiftPointBy (p,rot)) ps
|
||||
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
|
||||
|
||||
PutWall { _pwPoly = ps, _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w
|
||||
where
|
||||
(q:qs) = map (shiftPointBy (p,rot)) ps
|
||||
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
|
||||
_ -> w
|
||||
where
|
||||
p = _psPos ps
|
||||
rot = _psRot ps
|
||||
|
||||
-- TODO: remove this typeclass
|
||||
class Shiftable a where
|
||||
@@ -109,7 +119,6 @@ instance Shiftable PlacementSpot where
|
||||
translateS p' (PS p r x) = PS (p +.+ p') r x
|
||||
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
|
||||
|
||||
|
||||
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
|
||||
|
||||
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
@@ -117,6 +126,7 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
|
||||
where
|
||||
(p:ps) = orderPolygon qs
|
||||
pairs = zip (ps ++ [p]) (p:ps)
|
||||
|
||||
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
|
||||
{ _wlLine = (p0,p1)
|
||||
@@ -124,15 +134,11 @@ addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
|
||||
})
|
||||
wls
|
||||
|
||||
|
||||
placeBt bt p rot w = over buttons addBT w
|
||||
where
|
||||
addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
|
||||
|
||||
{-
|
||||
Creates a floor item at a given point.
|
||||
Assigns an id correctly.
|
||||
-}
|
||||
{- Creates a floor item at a given point.
|
||||
Assigns an id correctly. -}
|
||||
placeFlIt
|
||||
:: Item
|
||||
-> Point2 -- ^ Position
|
||||
@@ -150,13 +156,21 @@ placeFlIt itm p rot = floorItems %~
|
||||
) fis
|
||||
|
||||
placePressPlate pp p rot w = over pressPlates addPP w
|
||||
where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
|
||||
where
|
||||
addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
|
||||
|
||||
placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
|
||||
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
|
||||
where
|
||||
cid = newKey (_creatures w)
|
||||
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
|
||||
|
||||
placeCr :: Creature -> Point2 -> Float -> World -> World
|
||||
placeCr crF p rot w = over creatures addCr w
|
||||
where addCr crs = IM.insert (newKey crs)
|
||||
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
|
||||
crs
|
||||
where
|
||||
addCr crs = IM.insert (newKey crs)
|
||||
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
|
||||
crs
|
||||
|
||||
placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
|
||||
placeLS ls dec p rot w = over lightSources addLS
|
||||
|
||||
Reference in New Issue
Block a user