diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index c132cbe2b..e34ece5d3 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -36,8 +36,7 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 & rmExtPmnt ?~ externalButton red (anyLnkInPS 5 & psLnkRoomEff .~ (putWireStart 0 . extractRoomPos) ) --- & rmStartWires .~ IM.fromList [(0,RoomWire 0 0)] - & rmLinkEff .~ [putWireEndInvRmShift 0] + & rmLinkEff .~ [putWireEnd 0] ] ,[UseLabel 0 $ return switchDoorRoom] ] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 04d628850..5c9b7a94c 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -16,6 +16,7 @@ import Dodge.Room.Link import Geometry import qualified IntMapHelp as IM import Tile +import Dodge.RandomHelp import Data.List (nubBy) import Data.Traversable @@ -25,6 +26,7 @@ import Data.Foldable import qualified Control.Foldl as L import Data.Maybe import Data.Function +import Control.Monad.State generateLevelFromRoomList :: [Room] -> World -> World generateLevelFromRoomList gr' w @@ -45,7 +47,12 @@ generateLevelFromRoomList gr' w pairPath = concatMap _rmPath rs zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w rs = map doRoomShift rs' - rs' = zipWith addTile zs gr' + rs' = mapM shuffleRoomPos (zipWith addTile zs gr') & evalState $ _randGen w + +shuffleRoomPos :: RandomGen g => Room -> State g Room +shuffleRoomPos rm = do + newPos <- shuffle $ _rmPos rm + return $ rm & rmPos .~ newPos placeWires :: (World,[Room])-> World placeWires (w,rms) = foldr placeRoomWires w rms diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 82a6fe574..1a37e6ea1 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -29,15 +29,16 @@ posRms :: [ConvexPoly] posRms _ _ [] Empty = return $ Just [] posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) = fmap (finalLinksUpdate rtoadd:) <$> posRms bounds (r,i) ts tseq -posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do +posRms bounds (parent,i) (t@(Node (_,i') _):ts) tseq = do putStr $ "Trying to place room " ++ show i' ++ ": " - tryLinks (0::Int) (_rmLinks $ doRoomShift r) + --tryLinks (0::Int) (_rmLinks $ doRoomShift parent) + tryLinks (0::Int) (_rmLinks parent) where tryLinks _ [] = do putStrLn "all links tried" return Nothing tryLinks j (l:ls) - | clipping = tryLinks (j+1) ls + | clipping = tryLinks (j+1) ls | otherwise = do putStrLn $ "placing at link " ++ show j mayrs <- posRms (convexBounds ++ bounds) newr ts (tseq |> shiftedt') @@ -47,10 +48,11 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do where convexBounds = map pointsToPoly $ _rmBound r' clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) - newr = (lnkEff l $ r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) + newr = (lnkEff l $ parent & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) , i) - (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t - shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l) t + l' = shiftLinkBy (_rmShift parent) l + (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l') t + shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l') t lnkEff :: (Point2,Float) -> Room -> Room lnkEff x rm = case _rmLinkEff rm of diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 2db737a97..3a9a316bf 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -7,6 +7,7 @@ module Dodge.Room.Link ( shiftRoomToLink , shiftRoomShiftToLink , shiftRoomBy + , shiftLinkBy , doRoomShift , randomiseAllLinks , filterLinks diff --git a/src/Dodge/Wire.hs b/src/Dodge/Wire.hs index 5ae564e5c..593901cdf 100644 --- a/src/Dodge/Wire.hs +++ b/src/Dodge/Wire.hs @@ -1,17 +1,12 @@ module Dodge.Wire where import Dodge.LevelGen.Data -import Dodge.Room.Link import Geometry import qualified Data.IntMap.Strict as IM import Control.Lens -putWireEndInvRmShift :: Int -> (Point2,Float) -> Room -> Room -putWireEndInvRmShift i pos rm = - rm & rmEndWires %~ IM.insert i (uncurry RoomWire $ invShiftLinkBy (_rmShift rm) pos) +putWireEnd :: Int -> (Point2,Float) -> Room -> Room +putWireEnd i pos = rmEndWires %~ IM.insert i (uncurry RoomWire pos) putWireStart :: Int -> (Point2,Float) -> Room -> Room -putWireStart i pos rm = rm - & rmStartWires %~ IM.insert i (uncurry RoomWire pos) - - +putWireStart i pos = rmStartWires %~ IM.insert i (uncurry RoomWire pos)