diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index d69d4be81..5912ccd66 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -3,8 +3,10 @@ module Dodge.Layout where import Dodge.Data import Dodge.LevelGen +import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.Pathing +import Dodge.Placements.Spot import Dodge.Base import Dodge.Zone import Dodge.GameRoom @@ -25,7 +27,7 @@ import Tile import Polyhedra import Polyhedra.Data -import Data.List (nubBy) +import Data.List (nubBy, partition,mapAccumR) import Control.Monad.State import Control.Lens import System.Random @@ -50,10 +52,25 @@ generateLevelFromRoomList gr w where path = pairsToGraph dist pairPath pairPath = concatMap _rmPath rs - plmnts = concatMap (\r -> map (_rmShift r ,) (_rmPS r)) rs - rs = zipWith addTile zs rs' + plmnts = concatMap (\r -> map (_rmShift r ,) (assignPlacementSpots r)) rs + rs = zipWith addTile zs . evalState gr $ _randGen w zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w - rs' = evalState gr $ _randGen w + +assignPlacementSpots :: Room -> [Placement] +assignPlacementSpots rm = plmnts ++ plmnts' + where + (lnkplmnts, plmnts) = partition islnk (_rmPS rm) + islnk Placement{_placementSpot=PSLnk{}} = True + islnk _ = False + (_,plmnts') = mapAccumR f (_rmLinks rm) lnkplmnts + f lnks plmnt = + let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks + thepair = _psLinkShift (_placementSpot plmnt) x + in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt) + +updatePSLnkUsing :: (Point2,Float) -> PlacementSpot -> PlacementSpot +updatePSLnkUsing pf PSLnk{_psLinkShift=f} = uncurry PS $ f pf +updatePSLnkUsing _ ps = ps setupWorldBounds :: World -> World setupWorldBounds w = w @@ -106,10 +123,10 @@ wallsFromTree t = wallsFromRooms :: [Room] -> IM.IntMap Wall wallsFromRooms = -- divideWalls . - IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls + IM.fromList . zipWith f [0..] . removeInverseWalls . foldl' (flip cutWalls) [] . concatMap _rmPolys where - f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i} + f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i}) gameRoomsFromRooms :: [Room] -> [GameRoom] gameRoomsFromRooms = map f diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 7b97c2c2d..679e9f565 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -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 diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 851b0ef6e..13eb61e45 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -28,16 +28,17 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutNothing | PutID { _putID :: Int} -- maybe there is a monadic implementation of this? -data PlacementSpot = PS - { _psPos :: Point2 - , _psRot :: Float - } +data PlacementSpot + = PS { _psPos :: Point2 , _psRot :: Float } + | PSLnk { _psLinkTest :: (Point2,Float) -> Bool + , _psLinkShift :: (Point2,Float) -> (Point2,Float) + } data Placement = Placement { _placementSpot :: PlacementSpot , _psType :: PSType , _idPlacement :: Int -> Maybe Placement } - | PlacementPos Point3 (Point3 -> Placement) + | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position sPS :: Point2 -> Float -> PSType -> Placement sPS p a pt = Placement (PS p a) pt (const Nothing) @@ -58,7 +59,7 @@ jsps0J :: PSType -> Placement -> Maybe Placement jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst $ \_ -> Just plm ps0 :: PSType -> (Int -> Maybe Placement) -> Placement -ps0 pst = Placement (PS (V2 0 0) 0) pst +ps0 = Placement (PS (V2 0 0) 0) jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement jps0 pst = Just . Placement (PS (V2 0 0) 0) pst diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs index a994d2ad8..b52fd47c5 100644 --- a/src/Dodge/Placements/Button.hs +++ b/src/Dodge/Placements/Button.hs @@ -8,6 +8,7 @@ import Dodge.LevelGen.Data import Dodge.Default import Dodge.LevelGen.Switch import Dodge.Placements.LightSource +import Dodge.Placements.Spot import Control.Lens @@ -20,3 +21,12 @@ putLitButtonID col p a subpl = mountLightAID ls p'' (addZ 40 p') p'' = p +.+ 10 *.* vNormal (unitVectorAtAngle a) changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0 ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 } + +putLitButtonID' :: Color -> ((Point2,Float) -> Bool) -> (Int -> Maybe Placement) -> Placement +putLitButtonID' col f subpl = setLocalPS thePS $ mountLightAID ls 0 (V3 20 0 40) + $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = 0, _btRot = 0}) + subpl + where + changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0 + ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 } + thePS = PSLnk f id diff --git a/src/Dodge/Placements/Door.hs b/src/Dodge/Placements/Door.hs index efb2ac2f4..2c685c994 100644 --- a/src/Dodge/Placements/Door.hs +++ b/src/Dodge/Placements/Door.hs @@ -17,15 +17,15 @@ 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)) $ const mayp + $ Placement (PS (V2 0 0) 0) ( PutSlideDoor pathing col cond b half speed) $ const mayp where half = 0.5 *.* (a +.+ b) putAutoDoor :: Point2 -> Point2 -> Placement -putAutoDoor a b = PlacementPos (addZ 0 a) - $ \az -> PlacementPos (addZ 0 b) +putAutoDoor a b = PlacementUsingPos (addZ 0 a) + $ \az -> PlacementUsingPos (addZ 0 b) $ \bz -> putDoubleDoor True (dim yellow) (cond az bz) a b 3 where cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 5ee3140df..4fa23f8ac 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -61,7 +61,7 @@ airlock90 = defaultRoom ,(V2 40 0,V2 0 40) ] , _rmPS = - [ Placement (PS (V2 120 120) (3 * pi/4)) ((PutButton $ makeSwitch col red id id)) + [ Placement (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) ] @@ -89,7 +89,7 @@ airlockCrystal = defaultRoom , _rmLinks = [(V2 20 130,0) ,(V2 20 0 ,pi) ] , _rmPath = [ ] , _rmPS = - [ Placement (PS (V2 145 70) (pi/2)) ( (PutButton $ makeSwitch col red id id)) + [ Placement (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 4b73950b8..59771c3c9 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -115,6 +115,7 @@ addButtonSlowDoor x h rm = do belowH y = (sndV2 . fst) y < h - 40 aboveH y = (sndV2 . fst) y > h + 40 butDoor bpos brot = putLitButtonID col bpos brot + --butDoor bpos brot = putLitButtonID' col (const True) $ \btid -> Just $ putDoubleDoor False col (cond' btid) (V2 0 h) (V2 x h) 2 col = dim $ light red cond' btid w = w ^? buttons . ix btid . btState /= Just BtOff