diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index d03e8b740..0882f5762 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -2,11 +2,13 @@ module Dodge.Default.Room where import Geometry.Data import Dodge.LevelGen.Data +import qualified Data.IntMap.Strict as IM defaultRoom :: Room defaultRoom = Room { _rmPolys = [] , _rmLinks = [] + , _rmLinkEff = [] , _rmPos = [] , _rmPath = [] , _rmPmnts = [] @@ -20,5 +22,6 @@ defaultRoom = Room , _rmRandPSs = [] , _rmLabel = Nothing , _rmTakeFrom = Nothing - , _rmWires = [] + , _rmStartWires = IM.empty + , _rmEndWires = IM.empty } diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 1cc549d69..125c9dcb7 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -18,6 +18,7 @@ import Dodge.Item.Weapon.Launcher import MonadHelp import Data.Tree import Color +import Dodge.Wire import Control.Lens import Control.Monad.State @@ -25,12 +26,18 @@ import Control.Monad.Loops import System.Random import Data.Sequence hiding (zipWith) import Data.Maybe +import qualified Data.IntMap.Strict as IM + initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk [[StartRoom] - ,[ChainAnos [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 - & rmExtPmnt ?~ externalButton red (anyLnkInPS 5) ] + ,[ChainAnos + [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 + & rmExtPmnt ?~ externalButton red (anyLnkInPS 5) + & rmStartWires .~ IM.fromList [(0,RoomWire 0 0)] + & rmLinkEff .~ [putWireEnd 0] + ] ,[UseLabel 0 $ return switchDoorRoom] ] ] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 2f169a2e8..7e1669f82 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -7,11 +7,10 @@ import Dodge.LevelGen import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.Pathing +import Dodge.Room.Foreground import Dodge.Wall.Zone import Dodge.GameRoom import Dodge.Bounds ---import Dodge.LevelGen.Data -import Dodge.Room.Foreground import Dodge.Default.Wall import Geometry import qualified IntMapHelp as IM @@ -50,11 +49,15 @@ placeWires :: (World,[Room])-> World placeWires (w,rms) = foldr placeRoomWires w rms placeRoomWires :: Room -> World -> World -placeRoomWires rm w = foldr placeWire w (_rmWires rm) +placeRoomWires rm w = IM.foldr ($) w + $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm) -placeWire :: RoomWire -> World -> World -placeWire rw w = case rw of - RoomWire (p,_) (q,_) -> w & foregroundShape %~ (thinHighBar 40 p q <>) +placeWire :: Room -> RoomWire -> RoomWire -> World -> World +placeWire rm (RoomWire p' _) (RoomWire q' _) w = w & foregroundShape %~ (thinHighBar 40 p q <>) + where + rs = _rmShift rm + p = shiftPointBy rs p' + q = shiftPointBy rs q' doPartialPlacements :: ( (IM.IntMap [Placement],World) , [Room] ) -> (World,[Room]) doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 8105eb7fe..c994c24d7 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -8,6 +8,7 @@ import Dodge.LevelGen.Data import Dodge.Room.Link import Dodge.Layout.Tree.Polymorphic import Geometry.ConvexPoly +import Geometry.Data import Data.Tree import Data.Sequence hiding (zipWith) @@ -40,13 +41,18 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do | clipping = tryLinks (j+1) ls | otherwise = do putStrLn $ "placing at link " ++ show j - mayrs <- posRms (convexBounds ++ bounds) useLink ts (tseq |> shiftedt) + mayrs <- posRms (convexBounds ++ bounds) newr ts (tseq |> shiftedt) case mayrs of Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls Just rs -> return (Just rs) where convexBounds = map pointsToPoly $ _rmBound r' clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) - useLink = (r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink (Prelude.length ts)) l :) + newr = (lnkEff l $ r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) , i) shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t + +lnkEff :: (Point2,Float) -> Room -> Room +lnkEff x rm = case _rmLinkEff rm of + (eff:effs) -> eff x $ rm & rmLinkEff .~ effs + _ -> rm diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 3f294a3f5..fa83beaaf 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -48,19 +48,23 @@ placeSpot (w,rm) plmnt = case plmnt of where shift = _rmShift rm +-- this should be tidied up placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement]) placeSpotUsingLink w rm plmnt = case lnks of - ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt) + ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki lnk) (updatePS (f lnk) plmnt) [] -> case fallback of Nothing -> ((w,rm),[plmnt]) Just plmnt' -> placeSpot (w,rm) plmnt' where - uselnk lnki = rm & rmLinks %~ deletei lnki + uselnk lnki lnk = _psLnkRoomEff rps (f' lnk rps) rm & rmLinks %~ deletei lnki rps = _plSpot plmnt fallback = _psLnkFallback rps test = _psLnkTest rps (lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..] $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w + f' x (PSLnk t s _ _) + | t x = s x + f' _ _ = error "wrong type of link: something is wrong" f x (PSLnk t s _ _) | t x = uncurry PS $ s x f _ ps = ps diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 8d39d5b86..8a8611873 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -11,6 +11,7 @@ import Control.Lens import Control.Monad.State import System.Random import Data.Maybe +import qualified Data.IntMap.Strict as IM --import Data.Bifunctor data PSType = PutCrit {_unPutCrit :: Creature} | PutMachine Color [Point2] Machine @@ -119,6 +120,7 @@ assigning no bounds will allow rooms to overlap. data Room = Room { _rmPolys :: [ [Point2] ] , _rmLinks :: [(Point2,Float)] + , _rmLinkEff :: [(Point2,Float) -> Room -> Room] , _rmPos :: [RoomPos] , _rmPath :: [(Point2, Point2)] , _rmPmnts :: [Placement] @@ -132,10 +134,11 @@ data Room = Room , _rmRandPSs :: [State StdGen (Point2,Float)] , _rmLabel :: Maybe Int , _rmTakeFrom :: Maybe Int - , _rmWires :: [RoomWire] + , _rmStartWires :: IM.IntMap RoomWire + , _rmEndWires :: IM.IntMap RoomWire } data RoomWire - = RoomWire (Point2,Float) (Point2,Float) + = RoomWire Point2 Float data RoomPos = OutLink Int Point2 Float | InLink Point2 Float diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs index 1674403e6..53d079175 100644 --- a/src/Dodge/Placements/Button.hs +++ b/src/Dodge/Placements/Button.hs @@ -39,4 +39,3 @@ putLitButtonID' col f subpl changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0 ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 } thePS = PSLnk f id (const id) Nothing - diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 7b714d18e..1b71425f6 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -1,6 +1,5 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Room.Foreground - where +module Dodge.Room.Foreground where import Picture import Geometry import Geometry.Vector3D diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 02dbd95de..ea4284e84 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -16,6 +16,7 @@ import Data.Tree import Control.Monad.State import Control.Lens import System.Random +import qualified Data.IntMap.Strict as IM rezBox :: Room rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 @@ -39,4 +40,6 @@ startRoom = do <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) $ roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) + & rmStartWires .~ IM.fromList [(0,RoomWire (V2 0 0) 0)] + & rmEndWires .~ IM.fromList [(0,RoomWire (V2 (500) 500) 0)] ) diff --git a/src/Dodge/Wire.hs b/src/Dodge/Wire.hs new file mode 100644 index 000000000..7aac2f664 --- /dev/null +++ b/src/Dodge/Wire.hs @@ -0,0 +1,10 @@ +module Dodge.Wire where +import Dodge.LevelGen.Data +import Dodge.Room.Link +import Geometry + +import qualified Data.IntMap.Strict as IM +import Control.Lens + +putWireEnd :: Int -> (Point2,Float) -> Room -> Room +putWireEnd i pos rm = rm & rmEndWires %~ IM.insert i (uncurry RoomWire $ invShiftLinkBy (_rmShift rm) pos)