Allow for random choice between placements in different rooms
This commit is contained in:
@@ -15,8 +15,8 @@ putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a
|
||||
|
||||
putDoubleDoorThen :: Bool -> Color -> (World -> Bool)
|
||||
-> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
|
||||
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
|
||||
$ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) Nothing $ const mayp
|
||||
putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDr pathing col cond a half speed)
|
||||
$ Placement (PS (V2 0 0) 0) ( PutSlideDr pathing col cond b half speed) Nothing $ const mayp
|
||||
where
|
||||
half = 0.5 *.* (a +.+ b)
|
||||
|
||||
@@ -33,8 +33,8 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a)
|
||||
|
||||
switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
|
||||
switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeSwitch col red id id)
|
||||
$ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
|
||||
$ sps0 (PutSlideDoor False col (cond btid) drb drc 2)
|
||||
$ \btid -> jsps0J (PutSlideDr False col (cond btid) dra drc 2)
|
||||
$ sps0 (PutSlideDr False col (cond btid) drb drc 2)
|
||||
where
|
||||
drc = 0.5 *.* (dra +.+ drb)
|
||||
cond btid w' = _btState (_buttons w' IM.! btid) == BtOn
|
||||
|
||||
@@ -20,7 +20,7 @@ mntLSOn
|
||||
-> Maybe Color -- ^ describing a possible color override for the shape
|
||||
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
|
||||
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
|
||||
= ps0jPushPS (PutForeground . setCol $ shapeF wallp lsp)
|
||||
= ps0jPushPS (PutShape . setCol $ shapeF wallp lsp)
|
||||
. pt0 (PutLS $ ls {_lsPos = lsp'})
|
||||
where
|
||||
lsp' = lsp -.-.- V3 x y 1
|
||||
@@ -106,20 +106,20 @@ unusedLnkToPS rp _ = case rp of
|
||||
|
||||
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
|
||||
spanLSLightI ls h a b = ps0j (PutLS ls {_lsPos = V3 x y h})
|
||||
$ sps0 $ PutForeground $ thinHighBar h a b
|
||||
$ sps0 $ PutShape $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanLS :: LightSource -> Point2 -> Point2 -> Placement
|
||||
spanLS ls a b = Placement (PS (V2 x y) 0) (PutLS ls) Nothing
|
||||
$ const $ Just $ sps0 $ PutForeground $ thinHighBar h a b
|
||||
$ const $ Just $ sps0 $ PutShape $ thinHighBar h a b
|
||||
where
|
||||
V3 _ _ h = _lsPos ls + 5
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
|
||||
spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y (h-5)) 0)
|
||||
$ sps0 $ PutForeground $ thinHighBar h a b
|
||||
$ sps0 $ PutShape $ thinHighBar h a b
|
||||
where
|
||||
V2 x y = 0.5 *.* (a +.+ b)
|
||||
|
||||
|
||||
@@ -12,7 +12,7 @@ import Color
|
||||
|
||||
roundTank :: Color -> Float -> Float -> Placement
|
||||
roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutForeground $ colorSH col $
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 thecircle
|
||||
<> foldMap toprail ( take 8 [0,pi/4..])
|
||||
)
|
||||
@@ -23,7 +23,7 @@ roundTank col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
|
||||
roundTankCross :: Color -> Float -> Float -> Placement
|
||||
roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutForeground $ colorSH col $
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 thecircle
|
||||
<> thinHighBar 31 (V2 20 0) (V2 (-20) 0)
|
||||
<> thinHighBar 31 (V2 0 20) (V2 0 (-20))
|
||||
@@ -34,7 +34,7 @@ roundTankCross col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
|
||||
tankRectCross :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRectCross w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutForeground $ colorSH col $
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 therect
|
||||
<> thinHighBar 31 (V2 w 0) (V2 (-w) 0)
|
||||
<> thinHighBar 31 (V2 0 h) (V2 0 (-h))
|
||||
@@ -49,7 +49,7 @@ tankSquareCross = tankRectCross 20 20
|
||||
|
||||
tankRect :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRect w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutForeground $ colorSH col
|
||||
(PutShape $ colorSH col
|
||||
$ upperPrismPoly 31 therect
|
||||
<> foldMap f [(w',-w',h',h'),(w',-w',-h',-h'),(w',w',h',-h'),(-w',-w',h',-h')]
|
||||
)
|
||||
@@ -65,7 +65,7 @@ tankSquare = tankRect 20 20
|
||||
|
||||
tankRectEmboss :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRectEmboss w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutForeground $ colorSH col $
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 therect
|
||||
<> embossingR
|
||||
<> rotateSH pi embossingR
|
||||
@@ -84,7 +84,7 @@ tankSquareEmboss = tankRectEmboss 20 20
|
||||
|
||||
tankRectEmboss4 :: Float -> Float -> Color -> Float -> Float -> Placement
|
||||
tankRectEmboss4 w h col x y = shiftPlacement (V2 x y,0) $ ps0j
|
||||
(PutForeground $ colorSH col $
|
||||
(PutShape $ colorSH col $
|
||||
upperPrismPoly 31 therect
|
||||
<> foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)]
|
||||
)
|
||||
|
||||
@@ -11,7 +11,7 @@ import Data.List
|
||||
import Control.Lens
|
||||
|
||||
heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement
|
||||
heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly h ps)
|
||||
heightWallPS spot h ps = psj spot (PutShape . colorSH col $ upperPrismPoly h ps)
|
||||
$ sps spot $ PutWall ps theWall
|
||||
where
|
||||
col = _wlColor defaultWall
|
||||
@@ -22,7 +22,7 @@ heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly
|
||||
}
|
||||
|
||||
heightWall :: Float -> [Point2] -> Placement
|
||||
heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps)
|
||||
heightWall h ps = ps0j (PutShape . colorSH col $ upperPrismPoly h ps)
|
||||
$ sps0 $ PutWall ps theWall
|
||||
where
|
||||
col = _wlColor defaultWall
|
||||
@@ -33,7 +33,7 @@ heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps)
|
||||
}
|
||||
|
||||
midWall :: [Point2] -> Placement
|
||||
midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps)
|
||||
midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps)
|
||||
$ sps0 $ PutWall ps theWall
|
||||
where
|
||||
col = _wlColor defaultWall
|
||||
@@ -47,7 +47,7 @@ midWall ps = ps0j (PutForeground . colorSH col $ upperPrismPoly 50 ps)
|
||||
singleBlock :: Point2 -> [Placement]
|
||||
singleBlock a =
|
||||
[sPS a 0
|
||||
$ PutBlock StoneBlock [5,20,20] baseBlockPane
|
||||
$ PutBlock StoneBlock 5 [20,20] baseBlockPane
|
||||
$ reverse
|
||||
$ square 10
|
||||
]
|
||||
|
||||
@@ -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 ))
|
||||
|
||||
@@ -73,7 +73,7 @@ placeLineBlock
|
||||
-> GenWorld
|
||||
-> (Int, GenWorld)
|
||||
placeLineBlock basePane bm blockWidth depth a b gw = ( 0
|
||||
, gw & gWorld .~ (removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls)
|
||||
, gw & gWorld .~ removePathsCrossing a b (foldr insertWall (insertBlocks w) listWalls)
|
||||
)
|
||||
where
|
||||
w = _gWorld gw
|
||||
|
||||
@@ -17,3 +17,4 @@ shiftPlacement shift plmnt = case plmnt of
|
||||
PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
|
||||
(fmap (shiftPlacement shift) f)
|
||||
RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
|
||||
PickOnePlacement i pl -> PickOnePlacement i (shiftPlacement shift pl)
|
||||
|
||||
Reference in New Issue
Block a user