diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 5cf6802f6..d384c34c8 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -55,7 +55,7 @@ doPartialPlacement im rm w = case _rmPartialPmnt rm of Nothing -> w Just fi -> case _rmTakeFrom rm of Nothing -> w - Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i)) + Just i -> fst $ fst $ placeSpot (w,rm) (fi (im IM.! i)) doExtendedPlacements :: [Room] -> World -> (IM.IntMap Int, World) doExtendedPlacements rms w = foldr doExtendedPlacement (IM.empty,w) rms @@ -65,10 +65,10 @@ doExtendedPlacement rm (im,w) = case _rmExtendedPmnt rm of Nothing -> (im,w) Just _ -> case _rmLabel rm of Nothing -> (im,w) - Just _ -> undefined + Just i -> undefined doRoomPlacements :: World -> Room -> World -doRoomPlacements w rm = fst $ foldl' placeSpot (w,rm) $ _rmPmnts rm +doRoomPlacements w rm = fst $ foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm setupWorldBounds :: World -> World setupWorldBounds w = w diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index c2240f448..291013eed 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -28,13 +28,20 @@ import Control.Monad.State import Control.Lens import qualified Data.IntSet as IS -placeSpot :: (World,Room) -> Placement -> (World,Room) +-- when placing a placement, we update the world and the room and assign an id +-- to the placement +placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement]) placeSpot (w,rm) plmnt = case plmnt of Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w Placement{_plSpot = PSLnk{}} -> placeSpotUsingLink w rm plmnt Placement{} -> let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w - in maybe (w',rm) (placeSpot (w',rm)) (_plIDCont plmnt i) + newplmnt = plmnt & plMID .~ Just 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) PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt' where @@ -42,11 +49,11 @@ placeSpot (w,rm) plmnt = case plmnt of where shift = _rmShift rm -placeSpotUsingLink :: World -> Room -> Placement -> (World, Room) +placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement]) placeSpotUsingLink w rm plmnt = case lnks of ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt) [] -> case fallback of - Nothing -> (w,rm) + Nothing -> ((w,rm),[plmnt]) Just plmnt' -> placeSpot (w,rm) plmnt' where uselnk lnki = rm & rmLinks %~ deletei lnki @@ -61,7 +68,7 @@ placeSpotUsingLink w rm plmnt = case lnks of invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot) -placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room) +placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement]) placeSpotRoomRand rm i plmnt w = let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 5459e32c4..da8f91937 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -9,6 +9,7 @@ import Shape.Data import Control.Lens import Control.Monad.State import System.Random +import Data.Maybe data PSType = PutCrit {_unPutCrit :: Creature} | PutMachine Color [Point2] Machine | PutLS LightSource @@ -39,8 +40,8 @@ data PlacementSpot data Placement = Placement { _plSpot :: PlacementSpot , _plType :: PSType - , _plID :: Maybe Int - , _plIDCont :: Int -> Maybe Placement + , _plMID :: Maybe Int + , _plIDCont :: Placement -> Maybe Placement } | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position | RandomPlacement {_unRandomPlacement :: State StdGen Placement} @@ -48,6 +49,9 @@ data Placement = Placement spNoID :: PlacementSpot -> PSType -> Placement spNoID ps pst = Placement ps pst Nothing (const Nothing) +pContID :: PlacementSpot -> PSType -> (Int -> Maybe Placement) -> Placement +pContID ps pt = Placement ps pt Nothing . intPlPlPl + sPS :: Point2 -> Float -> PSType -> Placement sPS p a pt = Placement (PS p a) pt Nothing (const Nothing) @@ -67,10 +71,13 @@ jsps0J :: PSType -> Placement -> Maybe Placement jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing $ \_ -> Just plm ps0 :: PSType -> (Int -> Maybe Placement) -> Placement -ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing +ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl + +intPlPlPl :: (Int -> Maybe Placement) -> Placement -> (Maybe Placement) +intPlPlPl f = f . fromJust . _plMID jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement -jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing +jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl ps0j :: PSType -> Placement -> Placement ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt) diff --git a/src/Dodge/Placements/Door.hs b/src/Dodge/Placements/Door.hs index eb1d7a1c7..a29b15be7 100644 --- a/src/Dodge/Placements/Door.hs +++ b/src/Dodge/Placements/Door.hs @@ -31,7 +31,7 @@ putAutoDoor a b = PlacementUsingPos (addZ 0 a) cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement -switchDoor btpos btrot dra drb col = Placement (PS btpos btrot) (PutButton $ makeSwitch col red id id) Nothing +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) where diff --git a/src/Dodge/Placements/Sensor.hs b/src/Dodge/Placements/Sensor.hs index c6dc41503..e116b887b 100644 --- a/src/Dodge/Placements/Sensor.hs +++ b/src/Dodge/Placements/Sensor.hs @@ -15,7 +15,7 @@ import Data.Either damageSensor :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage -> Point2 -> Float -> Placement -damageSensor damF p r = Placement (PS p r) ( PutLS theLS) Nothing +damageSensor damF p r = pContID (PS p r) ( PutLS theLS) $ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine { _mcDraw = sensorSPic , _mcUpdate = sensorUpdate damF diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index efe12ee4a..d6a43936b 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -27,7 +27,7 @@ airlock0 = defaultRoom , _rmLinks = lnks , _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] , _rmPmnts = - [Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) Nothing + [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id) $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2 $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing ,spanLightI (V2 (-2) 30) (V2 (-2) 70) @@ -49,7 +49,7 @@ airlockSimple = defaultRoom , _rmLinks = lnks , _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks , _rmPmnts = - [ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) Nothing + [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) $ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps) $ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps) ] @@ -78,7 +78,7 @@ airlockZ = defaultRoom -- ,(V2 40 0,V2 0 40) -- ] , _rmPmnts = - [ Placement (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) Nothing + [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) $ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) $ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) , sps0 $ PutWall (rectNSEW 70 50 120 60) defaultWall @@ -118,7 +118,7 @@ airlock90 = defaultRoom ,(V2 40 0,V2 0 40) ] , _rmPmnts = - [ Placement (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) Nothing + [pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss ,mountLightV (V2 20 20) (V3 70 70 50) ] @@ -146,7 +146,7 @@ airlockCrystal = defaultRoom , _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ] , _rmPath = [ ] , _rmPmnts = - [ Placement (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) Nothing + [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) $ \btid -> jsps0 $ PutDoor col (cond btid) pss , crystalLine (V2 0 70) (V2 40 70) , mountLightV (V2 150 70) (V3 110 70 70) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 122a9f4fc..3556ffe32 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -39,7 +39,7 @@ twinSlowDoorRoom w h x = defaultRoom ] , _rmPath = [] , _rmPmnts = - [ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) Nothing + [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) $ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed) $ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed) $ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0)) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 6e14dafe3..ef77436c7 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -237,7 +237,7 @@ centerVaultRoom w h d = do where col = dim $ dim $ bright red theDoor = - [ Placement (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) Nothing + [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2) $ sPS (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 21 0) (V2 0 0) 2) ]