justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Fix backtracking bug

Browse Source
This commit is contained in:
justin
2021-11-23 19:09:39 +00:00
parent 6e4b36fd82
commit a66ea1d922
6 changed files with 49 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+1 -1
View File
@@ -36,7 +36,7 @@ initialAnoTree :: RandomGen g => Tree [Annotation g]
initialAnoTree = padSucWithCorridors $ treeFromTrunk
[[AnoApplyInt 0 startRoom]
, [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
-- , [AnoApplyInt 1 lasSensorTurretTest]
, [AnoApplyInt 1 lasSensorTurretTest]
-- ,[ChainAnos
-- [[SetLabel 0 $ return $ roomRectAutoLinks 200 200
-- & rmExtPmnt ?~ triggerSwitchSPicLight (drawSwitchWire red red)
src/Dodge/Layout.hs
+3 -3
View File
@@ -169,13 +169,13 @@ gameRoomFromRoom rm = GameRoom
,p -.- 10 *.* unitVectorAtAngle a
]
unpos (UsedOutLink _ p a) = doubleShift p a
unpos (UsedInLink p a) = doubleShift p a
unpos (UsedInLink _ p a) = doubleShift p a
unpos _ = []
undir (UsedOutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedInLink _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir (UsedInLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
undir _ = Nothing
closePoints x y = roundPoint2 x == roundPoint2 y
getDir (UsedInLink _ a:_) = a + snd (_rmShift rm)
getDir (UsedInLink _ _ a:_) = a + snd (_rmShift rm)
getDir (_:xs) = getDir xs
getDir _ = 0 -- fallback
src/Dodge/LevelGen/Data.hs
+1 -1
View File
@@ -99,7 +99,7 @@ data RoomWire
WallWire Point2 Float Float
data RoomPos
= UsedOutLink Int Point2 Float
| UsedInLink Point2 Float
| UsedInLink Int Point2 Float
| UnusedLink Point2 Float
| PosPl Point2 Float
| LabPos Int RoomPos
src/Dodge/Room/Link.hs
+9 -9
View File
@@ -118,14 +118,14 @@ shiftRoomBy shift r = r
. (tileX %~ shiftPointBy shift )
)
& rmViewpoints %~ map (shiftPointBy shift)
shiftRoomShiftToLink :: (Point2,Float) -> Room -> Room
shiftRoomShiftToLink l r
= shiftRoomShiftBy l
. shiftRoomShiftBy (V2 0 0 , pi-a)
$ shiftRoomShiftBy (V2 0 0 -.- p , 0)
r
where
(p,a) = head $ _rmInLinks r
--shiftRoomShiftToLink :: (Point2,Float) -> Room -> Room
--shiftRoomShiftToLink l r
-- = shiftRoomShiftBy l
-- . shiftRoomShiftBy (V2 0 0 , pi-a)
-- $ shiftRoomShiftBy (V2 0 0 -.- p , 0)
-- r
-- where
-- (p,a) = head $ _rmInLinks r
shiftRoomShiftToLink' :: (Point2,Float) -> (Point2,Float) -> Room -> Room
shiftRoomShiftToLink' l inlink r
@@ -156,7 +156,7 @@ finalLinksUpdate :: Room -> Room
finalLinksUpdate rm = case _rmInLinks rm of
(_:_) -> rm
& rmInLinks %~ tail
& rmPos %~ ( (uncurry UsedInLink (head inlnks) :)
& rmPos %~ ( (uncurry (UsedInLink 0) (head inlnks) :)
. (map (uncurry UnusedLink) (outlnks ++ tail inlnks) ++) )
_ -> rm
where
src/Dodge/RoomPos.hs
+1 -1
View File
@@ -5,7 +5,7 @@ import Geometry
extractRoomPos :: RoomPos -> (Point2,Float)
extractRoomPos rp = case rp of
UsedOutLink _ p a -> (p,a)
UsedInLink p a -> (p,a)
UsedInLink _ p a -> (p,a)
UnusedLink p a -> (p,a)
PosPl p a -> (p,a)
LabPos _ rp' -> extractRoomPos rp'
src/Dodge/Tree/Shift.hs
+34 -8
View File
@@ -20,7 +20,7 @@ import Control.Lens hiding (Empty, (<|) , (|>))
type RoomInt = (Room,Int)
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room])
positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty
positionRoomsFromTree (Node (r,i) ts) = printHeader >> posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty
posRms :: [ConvexPoly]
-> RoomInt
@@ -31,12 +31,12 @@ posRms :: [ConvexPoly]
posRms bounds (parent,_) _ [] st = case st of
Empty -> return $ Just [parent]
Node childi ts :<| tseq
-> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq
-> fmap (parent:) <$> posRms bounds childi 0 ts tseq
posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
printInfo parenti numChild childi
printInfoCheckNum parenti numChild childi
tryParentLinks (0::Int) (_rmOutLinks parent)
where
tryParentLinks _ [] = putStrLn "all link pairs tried" >> return Nothing
tryParentLinks _ [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
tryParentLinks j (l:ls) = do
tryChildLinks (0::Int) (_rmInLinks $ fst childi)
where
@@ -46,15 +46,33 @@ posRms bounds parenti@(parent,_) numChild (t@(Node childi _):ts) tseq = do
| otherwise = do
putStrLn $ show j ++ "-"++show numinlink
mayrs <- posRms (convexBounds ++ bounds)
(first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
return mayrs
(first updateparent parenti) (numChild + 1) ts (tseq |> shiftedt)
case mayrs of
Just rms -> return $ Just rms
Nothing -> printInfo parenti numChild childi
>> tryChildLinks (numinlink+1) ils
where
convexBounds = map pointsToPoly $ _rmBound r'
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds)
upr rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
updateparent rm = doLnkEff l $ rm & rmOutLinks %~ delete l & rmPos %~ (uncurry (UsedOutLink numChild) l :)
l' = shiftLinkBy (_rmShift parent) l
r' = doRoomShift . fst $ rootLabel shiftedt
shiftedt = applyToRoot (first $ shiftRoomShiftToLink' l' il) t
updatechild rm = rm & rmInLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) il:)
. (map (uncurry UnusedLink) (_rmOutLinks rm ++ newInLinks) ++) )
where
newInLinks = delete il $ _rmInLinks rm
shiftedt = applyToRoot (first $ updatechild . shiftRoomShiftToLink' l' il) t
printColumns :: [Int] -> [String] -> IO ()
printColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printColumns is strs
printColumns _ strs = putStrLn $ concat strs
theColumns :: [String] -> IO ()
theColumns = printColumns [20,5,20,20]
printHeader :: IO ()
printHeader = theColumns ["Parent","Cnum","Child","Link pair"]
printInfo :: RoomInt -> Int -> RoomInt -> IO ()
printInfo (parentrm,parenti) childn (childrm,childi) = do
@@ -63,6 +81,14 @@ printInfo (parentrm,parenti) childn (childrm,childi) = do
++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
where
rpns x s = rightPadNoSquash x ' ' s
printInfoCheckNum :: RoomInt -> Int -> RoomInt -> IO ()
printInfoCheckNum p 0 c = printInfo p 0 c
printInfoCheckNum _ childn (childrm,childi) = do
putStr $ rpns 20 ("")
++ rpns 5 (show childn ++ " ")
++ rpns 20 (_rmName childrm ++ "-" ++ show childi )
where
rpns x s = rightPadNoSquash x ' ' s
doLnkEff :: (Point2,Float) -> Room -> Room
doLnkEff x rm = case _rmLinkEff rm of