From a7f2b5f3ead66c468df0db4324e42641db5ad315 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 15 Nov 2021 19:36:31 +0000 Subject: [PATCH] Move toward indexed external placements --- src/Dodge/Floor.hs | 4 ++-- src/Dodge/Layout.hs | 21 ++++++++++++++++++--- src/Dodge/Layout/Tree/Shift.hs | 28 +++++++++++++--------------- src/Dodge/LevelGen/Data.hs | 2 +- src/Dodge/Placements/Button.hs | 7 +++---- src/Dodge/Room/Foreground.hs | 5 ++++- src/Dodge/Room/Start.hs | 8 +++----- src/Geometry.hs | 11 ++++++++++- src/Padding.hs | 9 +++++++++ 9 files changed, 63 insertions(+), 32 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index e34ece5d3..11d59a6d1 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -33,8 +33,8 @@ initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk [[StartRoom] ,[ChainAnos - [[SetLabel 0 $ return $ roomRectAutoLinks 100 100 - & rmExtPmnt ?~ externalButton red + [[SetLabel 0 $ return $ roomRectAutoLinks 200 200 + & rmExtPmnt ?~ triggerSwitch red (anyLnkInPS 5 & psLnkRoomEff .~ (putWireStart 0 . extractRoomPos) ) & rmLinkEff .~ [putWireEnd 0] ] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 5c9b7a94c..b221729ab 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -14,9 +14,13 @@ import Dodge.Bounds import Dodge.Default.Wall import Dodge.Room.Link import Geometry +import Geometry.ConvexPoly import qualified IntMapHelp as IM import Tile import Dodge.RandomHelp +import Color +import Shape +--import Padding import Data.List (nubBy) import Data.Traversable @@ -62,11 +66,22 @@ placeRoomWires rm w = IM.foldr ($) w $ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm) placeWire :: Room -> RoomWire -> RoomWire -> World -> World -placeWire rm (RoomWire p' _) (RoomWire q' _) w = w & foregroundShape %~ (thinHighBar 80 p q <>) +placeWire rm (RoomWire p _) (RoomWire q _) = foregroundShape + %~ ((col $ thinHighBarChain 80 $ map (shiftPointBy rs) doOrdering) <>) where + --TODO use rmWalls for non convex rooms + --rmWalls = foldr cutWalls [] (_rmPolys rm) + doOrdering = orderPolygonAround rmcen (p:q:ps) + col | clockwise = colorSH red + | otherwise = colorSH orange + rmps = concat $ _rmPolys rm + rmcen = centroid rmps + clockwise = isLHS rmcen p q + ps | clockwise = filter leftprightq rmps + | otherwise = filter rightpleftq rmps + leftprightq x = isLHS rmcen p x && isRHS rmcen q x + rightpleftq x = isRHS rmcen p x && isLHS rmcen q x 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 1a37e6ea1..cca4aadee 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -26,33 +26,31 @@ posRms :: [ConvexPoly] -> [Tree RoomInt] -> Seq (Tree RoomInt) -> IO (Maybe [Room]) -posRms _ _ [] Empty = return $ Just [] -posRms bounds (rtoadd,_) [] (Node (r,i) ts :<| tseq) - = fmap (finalLinksUpdate rtoadd:) <$> posRms bounds (r,i) ts tseq -posRms bounds (parent,i) (t@(Node (_,i') _):ts) tseq = do +posRms bounds (parent,_) [] st = case st of + Empty -> return $ Just [] + Node childi ts :<| tseq + -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi ts tseq +posRms bounds parenti (t@(Node (_,i') _):ts) tseq = do putStr $ "Trying to place room " ++ show i' ++ ": " - --tryLinks (0::Int) (_rmLinks $ doRoomShift parent) - tryLinks (0::Int) (_rmLinks parent) + tryLinks 0 (_rmLinks parent) where - tryLinks _ [] = do - putStrLn "all links tried" - return Nothing + parent = fst parenti + tryLinks _ [] = putStrLn "all links tried" >> return Nothing tryLinks j (l:ls) | clipping = tryLinks (j+1) ls | otherwise = do putStrLn $ "placing at link " ++ show j - mayrs <- posRms (convexBounds ++ bounds) newr ts (tseq |> shiftedt') + mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt) case mayrs of - Nothing -> do putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls + Nothing -> 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) - newr = (lnkEff l $ parent & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) - , i) + upr rm = lnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) l' = shiftLinkBy (_rmShift parent) l - (Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l') t - shiftedt' = applyToRoot (first $ shiftRoomShiftToLink l') t + r' = doRoomShift . fst $ rootLabel shiftedt + shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t lnkEff :: (Point2,Float) -> Room -> Room lnkEff x rm = case _rmLinkEff rm of diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 150f9e369..729e55526 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -163,7 +163,7 @@ jps0 pst = Just . Placement (PS (V2 0 0) 0) pst Nothing . intPlPlPl jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing - $ \plmnt -> (f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt) + $ \plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt ps0j :: PSType -> Placement -> Placement ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt) diff --git a/src/Dodge/Placements/Button.hs b/src/Dodge/Placements/Button.hs index 600e89a71..f12d31221 100644 --- a/src/Dodge/Placements/Button.hs +++ b/src/Dodge/Placements/Button.hs @@ -1,5 +1,4 @@ -module Dodge.Placements.Button - where +module Dodge.Placements.Button where import Dodge.Data import Color import Geometry @@ -12,8 +11,8 @@ import Dodge.Placements.LightSource import Data.Maybe import Control.Lens -externalButton :: Color -> PlacementSpot -> Placement -externalButton col ps = plCont ps (PutTrigger (const False)) +triggerSwitch :: Color -> PlacementSpot -> Placement +triggerSwitch col ps = plCont ps (PutTrigger (const False)) $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (oneff $ trigid tp) (offeff $ trigid tp))) (const Nothing) where diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 1b71425f6..b6310a9f3 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -47,8 +47,11 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints thinHighBar :: Float -> Point2 -> Point2 -> Shape thinHighBar = highBar 3 +thinHighBarLoop :: Float -> [Point2] -> Shape +thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs + thinHighBarChain :: Float -> [Point2] -> Shape -thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . loopPairs +thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs thickHighBar :: Float -> Point2 -> Point2 -> Shape thickHighBar = highBar 5 diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index d6d35b1c4..b7493cd55 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -16,7 +16,7 @@ import Data.Tree import Control.Monad.State import Control.Lens import System.Random -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM rezBox :: Room rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 @@ -38,8 +38,6 @@ startRoom = do ] treeFromPost [Left rezBox, Left door] . Right <$> 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)] + (shiftRoomBy (V2 (-20) (-20),0) + ( roomRectAutoLinks w h & rmPmnts %~ (plmnts ++) ) & rmShift .~ (0,0) ) diff --git a/src/Geometry.hs b/src/Geometry.hs index f1e5faa2d..fb22295d5 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -22,6 +22,7 @@ import Geometry.Intersect import Geometry.Bezier import Geometry.Vector import Geometry.LHS +import Geometry.ConvexPoly import Data.Maybe import Data.List @@ -132,7 +133,8 @@ orderAroundFirst (a:as) = a : orderPolygonAround a as -- | Reorder points to be anticlockwise around their center. orderPolygon :: [Point2] -> [Point2] orderPolygon [] = [] -orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps +--orderPolygon ps = orderPolygonAround (1/ fromIntegral (length ps) *.* foldr1 (+.+) ps) ps +orderPolygon ps = orderPolygonAround (centroid ps) ps -- | Adds a point to a convex polygon. -- If the point is inside, returns the original. -- Points ordered anticlockwise, input not checked. @@ -447,6 +449,13 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots n :: Int n = ceiling (a * magV v / ssize) +-- | Given a list of points, returns pairs of points linking the points into a +-- loop. +chainPairs :: [Point2] -> [(Point2,Point2)] +chainPairs [] = error "tried to make chain with empty list of points" +chainPairs [_] = error "tried to make chain with singleton list of points" +chainPairs xs = zip xs $ tail xs + -- | Given a list of points, returns pairs of points linking the points into a -- loop. loopPairs :: [Point2] -> [(Point2,Point2)] diff --git a/src/Padding.hs b/src/Padding.hs index 8b6619cd4..f1aa61ff4 100644 --- a/src/Padding.hs +++ b/src/Padding.hs @@ -6,6 +6,7 @@ module Padding , midPadL , rotU , rotD + , rotListAt ) where leftPad :: Int -> a -> [a] -> [a] @@ -37,3 +38,11 @@ rotD :: [a] -> [a] {-# INLINE rotD #-} rotD [] = [] rotD xs = last xs : init xs + +rotListAt :: Eq a => a -> [a] -> [a] +rotListAt x' xs = f x' xs [] + where + f x (y:ys) zs + | y == x = y:ys ++ zs + | otherwise = f x ys (y:zs) + f _ [] zs = zs