diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 0af0eaa96..c8e7f952d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -43,8 +43,8 @@ import Control.Monad.State import Control.Monad.Loops import System.Random {- | A test level tree. -} -roomTreex :: RandomGen g => State g (Maybe [Room]) -roomTreex = do +initialRoomTree :: RandomGen g => State g (Maybe [Room]) +initialRoomTree = do let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom] let t' = padCorridors struct t = treeFromTrunk @@ -97,4 +97,4 @@ roomTreex = do shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t levx :: RandomGen g => State g [Room] -levx = untilJust roomTreex +levx = untilJust initialRoomTree diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index f95647dc5..ce55b9d77 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -14,25 +14,18 @@ import Data.Maybe --import Data.Graph.Inductive.PatriciaTree import Data.Graph.Inductive.Query.SP import Data.Graph.Inductive.Graph hiding ((&)) -import Control.Monad ---import Control.Monad.State ---import System.Random - --- ok, astar or something like it makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] -makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g' +makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) + na <- walkableNodeNear a + nb <- walkableNodeNear b + sp na nb (_pathGraph w) where - g' = _pathGraph w - nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) - nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) - a' = find (flip (isWalkable a) w . snd) nsa - b' = find (flip (isWalkable b) w . snd) nsb + nodesNear p = concat $ lookLookups (zoneAroundPoint p) (_pathPoints w) + walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] -makePathBetweenPs a b w = mapMaybe (lab g') <$> makePathBetween b a w - where - g' = _pathGraph w +makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween b a w pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index be6b98586..0b5f11a06 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -10,6 +10,7 @@ import Dodge.Room.Procedural import Dodge.Room.Placement import Dodge.Room.Link import Dodge.Room.Corridor +import Dodge.Room.Path import Dodge.LevelGen.Data import Dodge.Creature import Dodge.Creature.State.Data @@ -24,16 +25,17 @@ import System.Random roomGlassOctogon :: Float -- ^ Size -> Room -roomGlassOctogon x = defaultRoom - { _rmPolys = [rectNSWE x (-x) (-x) x - ,rectNSWE 0 (-(x + 40)) (-20) 20 - ] - , _rmLinks = - [(V2 0 x,0) - ,(V2 0 (-(x+40)),pi) +roomGlassOctogon x = createPathGrid $ defaultRoom +--roomGlassOctogon x = defaultRoom + { _rmPolys = + [rectNSWE x (-x) (-x) x + ,rectNSWE 0 (-(x + 40)) (-20) 20 + ] + , _rmLinks = lnks + , _rmPath = linksAndPath lnks + [ ( V2 0 x , V2 0 (-(x+40))) + , ( V2 0 (-(x+40)), V2 0 x) ] - , _rmPath = [(V2 0 x,V2 0 (-(x+40))) - ,(V2 0 (-(x+40)),V2 0 x)] , _rmPS = [sPS (V2 fx fx) 0 putLamp ,sPS (V2 (-fx) fx) 0 putLamp @@ -43,12 +45,16 @@ roomGlassOctogon x = defaultRoom ,crystalLine (V2 x (x/2)) (V2 (x/2) x) ,crystalLine (V2 (x/2) (-x)) (V2 x (negate (x/2))) ,crystalLine (V2 (negate $ x/2) (-x)) (V2 (-x) (negate (x/2))) - ,blockLine (V2 (-40) (40-x)) (V2 40 (40-x)) + ,blockLine (V2 (-40) (50-x)) (V2 40 (50-x)) ] , _rmBound = [rectNSWE x (-x) (-x) x] } where fx = 4 * x / 5 + lnks = + [ (V2 0 x,0) + , (V2 0 (-(x+40)),pi) + ] bossRoom :: RandomGen g => Creature -> State g Room bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (V2 0 100) (negate $ pi/2) (PutCrit cr) :) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 9af544a47..e1af3be3a 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -13,6 +13,7 @@ import Dodge.Data import Dodge.Room.Data import Dodge.Room.Placement import Dodge.Room.Link +import Dodge.Room.Path import Dodge.Default.Room import Dodge.Item.Consumable import Dodge.Item.Equipment @@ -26,9 +27,9 @@ import Geometry import Picture import Data.Tile -import Data.List -import Data.Function (on) -import qualified Data.Tuple.Extra as Tup +--import Data.List +--import Data.Function (on) +--import qualified Data.Tuple.Extra as Tup import qualified Data.Map as M import Control.Lens import Control.Monad @@ -73,29 +74,7 @@ Creates a rectangular room, automatically creates links and pathfinding graph at roomRectAutoLinks :: Float -> Float -> Room roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60) -makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)] -makeGrid x nx y ny - = nub - . concatMap doublePair - . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y) - $ gridPoints x nx y ny -gridPoints :: Float -> Int -> Float -> Int -> [Point2] -gridPoints x nx y ny = [V2 a b | a <- take nx $ scanl (+) 0 $ repeat x - , b <- take ny $ scanl (+) 0 $ repeat y - ] - -makeRect :: Float -> Float -> [(Point2,Point2)] -makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0)) - ,((0,0),(0,y)) - ,((x,y),(x,0)) - ,((x,y),(0,y)) - ] - -linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)] -linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks - where - linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth) {- Combines two rooms into one room. Combines into one big bound, concatenates the rest. -} combineRooms :: Room -> Room -> Room