diff --git a/src/Dodge/Graph.hs b/src/Dodge/Graph.hs index 7410b7764..1eaa11bbf 100644 --- a/src/Dodge/Graph.hs +++ b/src/Dodge/Graph.hs @@ -4,6 +4,7 @@ module Dodge.Graph , incidenceToFunction , pairsToIncidence , graphToEdges + , graphToIncidence ) where -- this deserves tests import Data.List.Extra @@ -34,3 +35,8 @@ graphToEdges :: forall a b . F.Gr a b -> [(a,a)] graphToEdges g = map (bimap f f) $ F.edges g where f n = fromJust . lookup n $ F.labNodes g + +graphToIncidence :: forall a b . F.Gr a b -> [(a,Int)] +graphToIncidence g = map f $ F.labNodes g + where + f (n,p) = (p,length $ F.neighbors g n) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 67cdd2b62..74ace23fe 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -128,7 +128,7 @@ gameRoomsFromRooms = map f , _grDir = snd . last $ _rmLinks rm , _grName = _rmName rm } - closePoints x y = dist x y < 1 + closePoints x y = roundPoint2 x == roundPoint2 y floorsFromRooms :: [Room] -> [(Point3,Point3)] floorsFromRooms = concatMap (concatMap tToRender . _rmFloor) diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index eb983ec06..1c9d33574 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -70,15 +70,17 @@ customMouseCursor w = testPic :: World -> Picture testPic _ = [] --- where --- thepic = setDepth 20 . color green . polygon $ rectNSEW 5 (-5) (-5) (5) ---testPic _ = blank ---testPic w = + drawPathing :: World -> Picture drawPathing w | _debug_pathing (_config w) - = color green . pictures . map (flip thickLine 5 . tflat2) . graphToEdges $ _pathGraph w + = -- setLayer 5 $ + (color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr) + <> concatMap dispInc (graphToIncidence gr) | otherwise = [] + where + dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n + gr = _pathGraph w viewBoundaries :: World -> Picture viewBoundaries w | _debug_view_boundaries (_config w) diff --git a/src/Dodge/Room/AddTile.hs b/src/Dodge/Room/AddTile.hs index 6bce770aa..a310f0a12 100644 --- a/src/Dodge/Room/AddTile.hs +++ b/src/Dodge/Room/AddTile.hs @@ -5,6 +5,8 @@ import Tile import Geometry import Control.Lens +import Data.List +import Data.Function addTile :: Float -> Room -> Room addTile z r @@ -12,4 +14,4 @@ addTile z r | otherwise = r & rmFloor .~ [makeTileFromPoly poly z] where rp = _rmPolys r - poly = orderPolygon . convexHull $ concat rp + poly = orderPolygon . convexHullSafe . nubBy ((==) `on` roundPoint2) $ concat rp diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 38c91d87c..727832053 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -75,14 +75,20 @@ combineRooms :: Room -> Room -> Room combineRooms r r' = defaultRoom { _rmPolys = _rmPolys r ++ _rmPolys r' , _rmLinks = _rmLinks r ++ _rmLinks r' - , _rmPath = (_rmPath r ) - ++ (_rmPath r') + , _rmPath = map clampPath $ _rmPath r + ++ _rmPath r' , _rmPS = map (shiftPlacement $ _rmShift r) (_rmPS r) ++ map (shiftPlacement $ _rmShift r') (_rmPS r') , _rmBound = _rmBound r ++ _rmBound r' , _rmFloor = _rmFloor r ++ _rmFloor r' , _rmShift = (V2 0 0 , 0) } +-- not that this assumes that any link paths are integral +clampPath :: (Point2,Point2) -> (Point2, Point2) +clampPath = bimap f f + where + f (V2 x y) = V2 (g x) (g y) + g = (fromIntegral :: Int -> Float) . floor {- Randomly generate a top fourth of a room possibly with a wall. Add a light and a 'PutNothing' placement. -} quarterRoomFlat :: RandomGen g => Float -> State g Room