Generalise path generation for arbitrary rooms

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])
+initialRoomTree :: RandomGen g => State g (Maybe [Room])
-roomTreex = do
+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

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
+    nodesNear p = concat $ lookLookups (zoneAroundPoint p) (_pathPoints w)
-    nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w)
+    walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
-    nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w)
-    a' = find (flip (isWalkable a) w . snd) nsa
-    b' = find (flip (isWalkable b) w . snd) nsb
 
 makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
-makePathBetweenPs a b w = mapMaybe (lab g') <$> makePathBetween b a w
+makePathBetweenPs a b w = mapMaybe (lab $ _pathGraph w) <$> makePathBetween b a w
-  where 
-    g'  = _pathGraph w
 
 pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
 pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w

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
+roomGlassOctogon x = createPathGrid $ defaultRoom
-    { _rmPolys = [rectNSWE x (-x) (-x) x
+--roomGlassOctogon x = defaultRoom
+    { _rmPolys = 
+        [rectNSWE x (-x) (-x) x
         ,rectNSWE 0 (-(x + 40)) (-20) 20
         ]
-    , _rmLinks = 
+    , _rmLinks = lnks
-        [(V2 0 x,0)
+    , _rmPath  = linksAndPath lnks  
-        ,(V2 0 (-(x+40)),pi)
+        [ ( 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) :)

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.List
-import Data.Function (on)
+--import Data.Function (on)
-import qualified Data.Tuple.Extra as Tup
+--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