diff --git a/src/Dodge/Combine/Combinations.hs b/src/Dodge/Combine/Combinations.hs index a4a91f233..1b7148bc8 100644 --- a/src/Dodge/Combine/Combinations.hs +++ b/src/Dodge/Combine/Combinations.hs @@ -57,10 +57,9 @@ itemCombinations = , p [p 2 TUBE,o HARDWARE] launcher , p [p 2 TUBE,o LAUNCHER] (launcherX 2) - , p [p 2 TUBE,o $ LAUNCHERX 2] (launcherX 3) - , po [TRANSMITTER,MINIDISPLAY,LAUNCHER] remoteLauncher - - , po [LIGHTER,PIPE,CAN] flameStick + ] ++ [ p [p 2 TUBE,o $ LAUNCHERX i] (launcherX (i+1)) | i <- [2..9]] + ++ + [ po [LIGHTER,PIPE,CAN] flameStick , po [FLAMESTICK,CAN,PUMP] blowTorch , po [FLAMESTICK,DRUM] flameThrower , po [FLAMETHROWER,DRUM] flameWall @@ -163,7 +162,7 @@ moduleCombinations = amod cts str func = (cts,ItemModule [str] 1 func) homingLaunchers :: [Item] -homingLaunchers = launcher : [launcherX i | i <- [2..3]] +homingLaunchers = launcher : [launcherX i | i <- [2..10]] bulletWeapons :: [Item] bulletWeapons = [bangStick i | i <- [1..9] ] diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 366abd3d3..df3844c18 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -178,6 +178,7 @@ testInventory = IM.fromList $ zip [0..] -- , makeTypeCraftNum 3 DRUM -- , makeTypeCraftNum 3 PUMP -- , makeTypeCraftNum 1 MAGNET + , makeTypeCraftNum 1 TRANSMITTER , makeTypeCraftNum 5 HARDWARE , makeTypeCraftNum 3 SPRING , makeTypeCraftNum 10 CAN @@ -185,7 +186,6 @@ testInventory = IM.fromList $ zip [0..] , makeTypeCraftNum 3 PLANK , makeTypeCraftNum 1 MOTOR , makeTypeCraftNum 5 MICROCHIP --- , makeTypeCraftNum 1 TRANSMITTER -- , makeTypeCraftNum 5 AIUNIT ] stackedInventory :: IM.IntMap Item diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 3b5f66152..6c12c54c1 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -34,9 +34,7 @@ import System.Random initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk [[AnoApplyInt 0 startRoom] --- [[SpecificRoom startRoom'] --- , [SpecificRoom $ rezThenLasTurret] --- , [SpecificRoom $ fmap (return . PassDown) longRoom] +-- , [SpecificRoom $ fmap (return . UseAll) lasTunnelRunnable] , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms] , [SpecificRoom randomChallenges] , [AnoApplyInt 1 lasSensorTurretTest] diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 1515dbf61..4728a9124 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -18,6 +18,7 @@ lockRoomKeyItems = ,(const slowDoorRoomRunPast, return MINIGUN) ,(const longRoomRunPast, takeOne [SNIPERRIFLE,FLATSHIELD]) ,(const glassLessonRunPast, takeOne [LASGUN]) + ,(const $ lasTunnelRunPast 400, return FLATSHIELD) ] itemRooms :: RandomGen g => [(CombineType, State g (SubCompTree Room))] diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 3b5e9073d..b2854018d 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Dodge.PlacementSpot where import Dodge.LevelGen.Data import Geometry @@ -39,7 +40,7 @@ unusedSpotAwayFromLink x = PSPos f (const id) Nothing setFallback :: Placement -> Placement -> Placement setFallback fallback plmnt = plmnt - & plSpot . psFallback .~ Just fallback + & plSpot . psFallback %~ maybe (Just fallback) Just & plIDCont %~ fmap (fmap $ setFallback fallback) unusedOffPathAwayFromLink :: Float -> PlacementSpot @@ -88,7 +89,7 @@ useRoomPosCond t rp _ a = _rpDir rp unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos) -unusedLnkToPS = useRoomPosCond $ \rp -> case rp of +unusedLnkToPS = useRoomPosCond $ \case UnusedLink {} -> True _ -> False diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index f96e45b93..61b13ca32 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -3,6 +3,7 @@ import Dodge.LevelGen.Data import Dodge.PlacementSpot import Dodge.Data import Dodge.Tree +import Dodge.RoomLink import Dodge.Room.Door import Dodge.Room.Room import Dodge.Room.Corridor @@ -11,7 +12,7 @@ import Dodge.Room.Link import Dodge.Room.Foreground --import Dodge.Room.RoadBlock import Dodge.Placement.Instance ---import Dodge.Item.Random +import Dodge.Default.Room --import Dodge.Item.Weapon.BulletGuns --import Dodge.Item.Weapon.Utility --import Dodge.LevelGen.Data @@ -21,7 +22,9 @@ import Geometry import Color import Shape import LensHelp +import Dodge.RandomHelp +import qualified Data.Set as S import Data.Maybe import Data.Tree import Control.Monad.State @@ -51,7 +54,6 @@ lasSensLightAboveDoor wth ps = extTrigLitPos upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True | otherwise = w - lightSensByDoor :: Room -> Room lightSensByDoor rm = rm & rmPmnts .++~ @@ -78,3 +80,48 @@ lasCenSensEdge n = do [ treeFromPost [PassDown doorroom] (UseAll door) , treeFromPost [PassDown door] (UseLabel 0 corridor) ] + +lasTunnel :: RandomGen g => Float -> State g Room +lasTunnel y = do + extraPlmnts <- takeOne + [ [ midWall (rectNSEW 115 90 0 60) + , midWall (rectNSEW 65 40 (-40) 25) + ] + , [ midWall (rectNSEW 125 100 0 25) + , midWall (rectNSEW 80 40 (-40) 0) + , midWall (rectNSEW 80 40 25 60) + ] + ] + return defaultRoom + { _rmPolys = polys + , _rmBound = polys + , _rmLinks = + [outLink (V2 20 (190 + y)) (1.5* pi) + ,outLink (V2 0 (190 + y)) (0.5* pi) + , inLink (V2 (-40) 20) (0.5* pi) + , inLink (V2 60 20) (1.5* pi) + , inLink (V2 10 0) pi + ] + , _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 (240+y)) (1.5*pi) + --, midWall (rectNSEW 65 40 0 25) + , mntLS vShape (V2 60 145) (V3 40 125 90) + , mntLS vShape (V2 (-40) 145) (V3 (-20) 125 90) + ] + ++ extraPlmnts + , _rmName = "lasTunnel" ++ show y + } + where + polys = [rectNSWE (250+y) 0 0 20 + , rectNSWE 145 0 (-40) 60 + ] + +-- a y value of 400 is probably "unrunnable" +lasTunnelRunPast :: RandomGen g => Float -> State g (SubCompTree Room) +lasTunnelRunPast y = do + r <- lasTunnel y + r1 <- takeOne [door,corridor] + r2 <- takeOne [door,corridor] + return $ Node (PassDown r) + [ singleUseAll r1 + , return (UseLabel 0 $ r2 & rmConnectsTo .~ S.singleton InLink) + ] diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index ee1f3d6c8..f22bf0f6b 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -5,7 +5,6 @@ The last link in the list is considered the incoming link, the other links are the outgoing links. -} module Dodge.Room.Link ( shiftRoomShiftToLink - , shiftRoomBy , moveRoomBy , shiftLinkBy , doRoomShift @@ -105,6 +104,7 @@ moveRoomBy shift r = r . (tileX %~ shiftPointBy shift ) ) & rmViewpoints %~ map (shiftPointBy shift) + & rmPos %~ map ( ( rpPos %~ shiftPointBy shift ) . (rpDir +~ snd shift) ) shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room shiftRoomShiftToLink l inlink r diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 140f89571..ab4936499 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -32,10 +32,11 @@ import Dodge.Creature import Geometry import Picture import Data.Tile +import LensHelp import qualified Data.Set as S import qualified Data.IntMap.Strict as IM -import Control.Lens +--import Control.Lens import Control.Monad import Control.Monad.State import System.Random @@ -104,6 +105,7 @@ combineRooms r r' = defaultRoom --, _rmPmnts = map (shiftPlacement $ _rmShift r) (_rmPmnts r) -- ++ map (shiftPlacement $ _rmShift r') (_rmPmnts r') , _rmBound = _rmBound r ++ _rmBound r' + , _rmPos = _rmPos r ++ _rmPos r' , _rmFloor = combineFloors (_rmFloor r) (_rmFloor r') , _rmShift = (V2 0 0 , 0) } @@ -120,20 +122,14 @@ combineFloors f _ = f Add a light and a 'PutNothing' placement. -} quarterRoomTri :: RandomGen g => Float -> State g Room quarterRoomTri w = do - let commonPlacements = - [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) - , sPS (V2 (w-20) (w-20)) pi PutNothing - , sPS (V2 (w-15) (w-25)) pi PutNothing - ] b <- takeOne [ [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70) , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w) - ] ++ commonPlacements - , blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2)) - : commonPlacements + ] + , [blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))] , [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2)) , blockLine (V2 (-29) w) (V2 0 (w/2)) - ] ++ commonPlacements + ] ] pure $ defaultRoom { _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ] @@ -146,26 +142,28 @@ quarterRoomTri w = do ,(V2 0 (w-20),V2 0 0) ,(V2 (55-w) (w-20),V2 0 0) ] - , _rmPmnts = b + , _rmPmnts = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) + , sPS (V2 (w-20) (w-20)) pi PutNothing + , sPS (V2 (w-15) (w-25)) pi PutNothing + ] + , _rmPos = + [ UnusedSpot (V2 (w-20) (w-20)) pi S.empty + , UnusedSpot (V2 (w-15) (w-25)) pi S.empty + ] , _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]] } quarterRoomSquare :: RandomGen g => Float -> State g Room quarterRoomSquare w = do - let commonPlacements = - [ blockLine (V2 (w/2) (w/2)) (V2 0 w) - , sPS (V2 20 (2*w-40)) pi PutNothing - , sPS (V2 25 (2*w-45)) pi PutNothing - ] b <- takeOne [ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w) - ] ++ commonPlacements + ] , [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) , blockLine (V2 (negate w) w ) (V2 0 w) - ] ++ commonPlacements + ] , [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70) , blockLine (V2 0 w) (V2 0 (w*2)) - ] ++ commonPlacements + ] ] pure $ defaultRoom { _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] @@ -185,21 +183,16 @@ quarterRoomSquare w = do ,(V2 0 0,V2 0 (w-40)) -- ,(V2 (20-w) (w-20),V2 (40-w) (w)) ] - , _rmPmnts = b - , _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]] + , _rmPmnts = b ++ + [ blockLine (V2 (w/2) (w/2)) (V2 0 w) + , sPS (V2 20 (2*w-40)) pi PutNothing + , sPS (V2 25 (2*w-45)) pi PutNothing + ] + , _rmPos = [UnusedSpot (V2 20 (2*w-40)) pi S.empty + , UnusedSpot (V2 25 (2*w-45)) pi S.empty + ] + , _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]] } -{- | Replace the first 'PutNothing' with a given 'PSType'. -} -fillNothingPlacement :: PSType -> Room -> Room -fillNothingPlacement pst r = - r & rmPmnts %~ replaceNothingWith pst - where - replaceNothingWith x (Placement (PS p rot) PutNothing _ _: pss) = sPS p rot x : pss - replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss - replaceNothingWith _ [] = [] -{- | Successively fill 'PutNothing' placements with a list of given 'PSType's. --} -fillNothingPlacements :: [PSType] -> Room -> Room -fillNothingPlacements pst r = foldr fillNothingPlacement r pst {- | Randomise the ordering of placements in a room. Useful for randomising the position of generic placements such as 'PutNothing'. -} shufflePlacements :: RandomGen g => Room -> State g Room @@ -211,24 +204,19 @@ shufflePlacements = rmPmnts shuffle Tight corridors, random placements. -} randomFourCornerRoom :: RandomGen g => [Item] -> State g Room randomFourCornerRoom its = do - corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100] - itms <- shuffle its nCrits <- state $ randomR (1,3) - crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] + crits <- takeN nCrits <=< shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] ++ replicate 20 chaseCrit - randomiseAllLinks . fillNothingPlacements (crits ++ map PutFlIt itms) =<< - ( shufflePlacements - . over rmPmnts ( sps0 putLamp :) - . foldr1 combineRooms - $ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2] - ) + randomFourCornerRoomCrsIts crits its {- | A randomly generate room based on four randomly generated corners. Tight corridors. -} randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room randomFourCornerRoomCrsIts crits its = do corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100] itms <- shuffle its - randomiseAllLinks . fillNothingPlacements (map PutCrit crits ++ map PutFlIt itms) =<< + let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms + putcrits = map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crits + randomiseAllLinks . (rmPmnts .++~ (putitms ++ putcrits)) =<< ( shufflePlacements . over rmPmnts ( sps0 putLamp :) . foldr1 combineRooms diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 6b0d07c6c..41bcacd1e 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -1,6 +1,5 @@ {- Connecting rooms designed with a pass-through technique in mind. -} -module Dodge.Room.RoadBlock - where +module Dodge.Room.RoadBlock where import Dodge.Data import Dodge.RoomLink import Geometry @@ -87,18 +86,3 @@ blockedCorridorCloseBlocks = do ] ] return $ corridor & rmPmnts .~ theblocks - -lasTunnel :: Room -lasTunnel = defaultRoom - { _rmPolys = polys - , _rmBound = polys - , _rmLinks = [outLink (V2 20 190) (1.5* pi), inLink (V2 0 20) (0.5* pi)] - , _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 240) (1.5*pi) - , midWall (rectNSEW 65 40 0 25) - , mntLS vShape (V2 50 10) (V3 40 20 50) - ] - } - where - polys = [rectNSWE 250 0 0 20 - , rectNSWE 80 0 0 60 - ] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index a49f69cb8..93adce29a 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -92,7 +92,7 @@ rezBoxThenWeaponRoom = do rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room) rezBoxThenRoom r = do rcol <- rezColor - treeFromTrunk [PassDown $ rezBox rcol,PassDown door] <$> (return $ singleUseAll r) + return $ treeFromTrunk [PassDown $ rezBox rcol,PassDown door] $ singleUseAll r rezBoxThenRooms :: RandomGen g => SubCompTree Room -> State g (SubCompTree Room) rezBoxThenRooms r = do diff --git a/src/Geometry/Polygon.hs b/src/Geometry/Polygon.hs index 4d5dbe052..416c8c36d 100644 --- a/src/Geometry/Polygon.hs +++ b/src/Geometry/Polygon.hs @@ -21,6 +21,17 @@ rectNSWE !n !s !w !e = [V2 w n, V2 w s, V2 e s, V2 e n] rectWH :: Float -> Float -> [Point2] rectWH w h = rectNSWE h (-h) (-w) w +isotriBWH :: Point2 -> Float -> Float -> [Point2] +isotriBWH (V2 x y) w h = [V2 (x-w) y, V2 (x+w) y, V2 x (y+h)] + +-- trapezion +trapezionBWHW :: Point2 -> Float -> Float -> Float -> [Point2] +trapezionBWHW (V2 x y) w1 h w2 = + [ V2 (x-w1) y + , V2 (x+w1) y + , V2 (x+w2) (y+h) + , V2 (x-w2) (y+h)] + rectXH :: Float -> Float -> [Point2] rectXH x h = rectNSWE h (-h) 0 x