Allow for random choice between placements in different rooms
This commit is contained in:
@@ -22,6 +22,7 @@ import Shape
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
|
||||
import Data.Maybe
|
||||
import System.Random
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
@@ -34,23 +35,34 @@ placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
|
||||
placeSpot (w,rm) plmnt = case plmnt of
|
||||
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
|
||||
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
|
||||
Placement{} ->
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
newplmnt = plmnt & plMID ?~ i
|
||||
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
|
||||
where
|
||||
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
|
||||
in (wr,newplmnt:newplmnts)
|
||||
-- (placeSpot (w',rm)) (_plIDCont plmnt i)
|
||||
Placement{} -> placePlainPSSpot w rm plmnt shift
|
||||
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
|
||||
RandomPlacement rplmnt -> placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
|
||||
where
|
||||
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
|
||||
RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm
|
||||
PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), [])
|
||||
where
|
||||
shift = _rmShift rm
|
||||
|
||||
placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld
|
||||
placePickOne i pl rm w = w & gPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))]
|
||||
|
||||
placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement])
|
||||
placeRandomPlacement rplmnt w rm = placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
|
||||
where
|
||||
(plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
|
||||
|
||||
placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement])
|
||||
placePlainPSSpot w rm plmnt shift =
|
||||
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
|
||||
newplmnt = plmnt & plMID ?~ i
|
||||
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
|
||||
where
|
||||
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
|
||||
in (wr,newplmnt:newplmnts)
|
||||
|
||||
-- this should be tidied up
|
||||
placeSpotUsingLink :: GenWorld -> Room -> Placement
|
||||
placeSpotUsingLink :: GenWorld
|
||||
-> Room
|
||||
-> Placement
|
||||
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
|
||||
-> (RoomPos -> Room -> Room)
|
||||
-> Maybe Placement
|
||||
@@ -66,44 +78,47 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
|
||||
Nothing -> second (pos:) <$> searchedPoss poss
|
||||
Just (ps,rmpos) -> Just ( ps,rmpos:poss)
|
||||
|
||||
placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot)
|
||||
placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot)
|
||||
-> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
|
||||
placeSpotRoomRand rm i f plmnt w =
|
||||
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w)
|
||||
in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)
|
||||
|
||||
|
||||
|
||||
-- the Int here is some id that is assigned when the placement is placed
|
||||
placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
|
||||
placeSpotID ps pt w = case pt of
|
||||
PutTrigger cond -> placeNewInto triggers cond w
|
||||
PutMod modi -> plNewUpID modifications mdID modi w
|
||||
PutProp prop -> plNewUpID props pjID (mvProp p rot prop) w
|
||||
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
|
||||
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
|
||||
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
|
||||
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
|
||||
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
|
||||
PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
|
||||
RandPS rgen -> evaluateRandPS rgen ps w
|
||||
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
|
||||
PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
|
||||
PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
|
||||
PutBlock bm (hp:hps) wl ps' -> placeBlock (map doShift ps') hp wl hps bm w
|
||||
PutBlock{} -> error "messed up block placement somehow"
|
||||
PutTrigger cnd -> placeNewInto triggers cnd w
|
||||
PutMod mdi -> plNewUpID modifications mdID mdi w
|
||||
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w
|
||||
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
|
||||
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
|
||||
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
|
||||
PutMachine col pps mc -> placeMachine col (map doShift pps) mc p rot w
|
||||
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
|
||||
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
|
||||
RandPS rgn -> evaluateRandPS rgn ps w
|
||||
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
|
||||
PutCoord cp -> placeNewInto coordinates (doShift cp) w
|
||||
PutSlideDr pth col f a b spd
|
||||
-> placeSlideDoor pth col f (doShift a) (doShift b) spd w
|
||||
PutBlock bm hp hps wl ps'
|
||||
-> placeBlock (map doShift ps') hp wl hps bm w
|
||||
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
|
||||
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
|
||||
PutForeground sh -> (0,w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
||||
PutNothing -> (0,w)
|
||||
PutID i -> (i, w)
|
||||
PutWorldUpdate f -> (0,w & gWorld %~ f ps)
|
||||
PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
|
||||
PutShape sh -> placeShape sh p rot w
|
||||
PutNothing -> (0,w)
|
||||
PutID i -> (i, w)
|
||||
PutWorldUpdate f -> (0,w & gWorld %~ f ps)
|
||||
where
|
||||
p@(V2 px py) = _psPos ps
|
||||
p' = V3 px py 0
|
||||
rot = _psRot ps
|
||||
doShift = shiftPointBy (p,rot)
|
||||
|
||||
placeShape :: Shape -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
|
||||
placeShape sh p rot w =
|
||||
(0, w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
|
||||
|
||||
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int,GenWorld)
|
||||
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w)
|
||||
where
|
||||
@@ -114,7 +129,6 @@ placeWallPoly ps wl = gWorld %~ (rmCrossPaths . over walls (addWalls ps wl))
|
||||
where
|
||||
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
|
||||
|
||||
|
||||
addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
addWalls qs wl wls = foldr (addPane wl) wls pairs
|
||||
where
|
||||
@@ -134,7 +148,7 @@ placeNewInto :: ALens' World (IM.IntMap a)
|
||||
-> (Int,GenWorld)
|
||||
placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x)
|
||||
where
|
||||
i = IM.newKey $ (_gWorld w) ^# l
|
||||
i = IM.newKey $ _gWorld w ^# l
|
||||
|
||||
-- | place an new object into an intmap and update its id
|
||||
plNewUpID :: ALens' World (IM.IntMap a)
|
||||
@@ -144,7 +158,7 @@ plNewUpID :: ALens' World (IM.IntMap a)
|
||||
-> (Int,GenWorld)
|
||||
plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i))
|
||||
where
|
||||
i = IM.newKey $ (_gWorld w) ^# l
|
||||
i = IM.newKey $ _gWorld w ^# l
|
||||
|
||||
mvProp :: Point2 -> Float -> Prop -> Prop
|
||||
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
|
||||
|
||||
Reference in New Issue
Block a user