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

Fix incorrect creation of unused links pos

Browse Source
This commit is contained in:
justin
2022-03-08 09:48:45 +00:00
parent 59e6f433ff
commit 8179a2aa4f
8 changed files with 35 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+5 -4
View File
@@ -37,8 +37,9 @@ randomPadCorridors (Node x xs) = do
return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
{- | Add a corridor to a random out-link of a room. -}
roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room)
roomThenCorridor theRoom = fmap (\r -> Node (PassDown theRoom) [(pure . UseAll) r])
(randomiseOutLinks corridor)
roomThenCorridor theRoom = fmap
(\r -> Node (PassDown theRoom) [(pure . UseAll) r])
(shuffleLinks corridor)
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree :: RandomGen g => [Annotation g] -> State g (SubCompTree Room)
@@ -62,7 +63,7 @@ anoToRoomTree anos = case anos of
[OrAno as] -> do
a <- takeOne as
anoToRoomTree a
[Corridor] -> pure . UseAll <$> randomiseOutLinks corridor
[Corridor] -> pure . UseAll <$> shuffleLinks corridor
[AirlockAno] -> airlock >>= roomThenCorridor
[FirstWeapon] -> do
branchWP <- branchRectWith weaponRoom
@@ -77,4 +78,4 @@ anoToRoomTree anos = case anos of
_ -> do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
fmap (pure . UseAll) . randomiseOutLinks $ roomRectAutoLinks w h
fmap (pure . UseAll) . shuffleLinks $ roomRectAutoLinks w h
src/Dodge/LevelGen/Data.hs
+3 -2
View File
@@ -50,7 +50,7 @@ data PlacementSpot
, _psRandShift :: (Point2,Float) -> PlacementSpot
}
data Placement
= Placement
= Placement
{ _plSpot :: PlacementSpot
, _plType :: PSType
, _plMID :: Maybe Int
@@ -207,7 +207,8 @@ psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt)
-- the NoShiftCont is necessary when shifting then combining rooms
ps0jPushPS :: PSType -> Placement -> Placement
ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p)
ps0jPushPS pst plmnt = Placement (PSNoShiftCont (V2 0 0) 0) pst Nothing
$ \p -> Just $ plmnt & plSpot .~ _plSpot p
addPlmnt :: Placement -> Placement -> Placement
addPlmnt pl pl2 = case pl2 of
src/Dodge/Placement/Instance/LightSource.hs
+2 -1
View File
@@ -21,7 +21,6 @@ mntLSOn
-> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement
mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _)
= ps0jPushPS (PutShape . setCol $ shapeF wallp lsp)
-- = ps0j (PutShape . setCol $ shapeF wallp lsp)
. pt0 (PutLS $ ls & lsParam . lsPos .~ lsp')
where
lsp' = lsp -.-.- V3 x y 1
@@ -111,6 +110,8 @@ mntLightLnkCond f = RandomPlacement $ do
unusedLnkToPS :: RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)
unusedLnkToPS rp _ = case rp of
UnusedLink p a -> Just (PS p a,UsedSpot p a)
-- UsedInLink _ p a -> Just (PS p a,UsedSpot p a)
-- UsedOutLink _ _ p a -> Just (PS p a,UsedSpot p a)
_ -> Nothing
spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement
src/Dodge/Placement/PlaceSpot.hs
-1
View File
@@ -54,7 +54,6 @@ placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room)
placePlainPSSpot w rm plmnt shift =
let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
newplmnt = plmnt & plMID ?~ i
--in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
where
recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
src/Dodge/Room/Branch.hs
+5 -3
View File
@@ -20,6 +20,8 @@ branchRectWith t = do
x <- state $ randomR (100,200)
y <- state $ randomR (100,200)
b <- t
root <- randomiseOutLinks $ roomRectAutoLinks x y
return $ Node (PassDown root) [Node (UseAll door) [], changeToPassDown <$>
treeFromTrunk [PassDown door] b]
root <- shuffleLinks $ roomRectAutoLinks x y
return $ Node (PassDown root)
[ Node (UseAll door) []
, changeToPassDown <$> treeFromTrunk [PassDown door] b
]
src/Dodge/Room/Link.hs
+5 -14
View File
@@ -14,7 +14,6 @@ module Dodge.Room.Link
, randomiseAllLinks
, shuffleLinks
, filterLinks
, randomiseOutLinks
, chooseOneInLink
, restrictRMInLinksPD
) where
@@ -47,13 +46,6 @@ restrictToFstInLink = rmLinks %~ f
| otherwise = rl : f xs
f [] = []
{- Shuffle the initial links of a room randomly. -}
randomiseOutLinks :: RandomGen g => Room -> State g Room
randomiseOutLinks r = do
let (outs,xs) = partition (S.member OutLink . _rlType) $ _rmLinks r
newLinks <- shuffle outs
return $ r {_rmLinks = newLinks ++ xs }
sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room
sortOutLinksOn f = overLnkType OutLink $ sortOn (f . lnkPosDir)
@@ -95,8 +87,8 @@ shiftRoomBy shift r = r
& rmShift %~ shiftPosDirBy shift
& rmFloor . tiles %~ map
( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift )
. (tileX %~ shiftPointBy shift )
. (tileZero %~ shiftPointBy shift )
. (tileX %~ shiftPointBy shift )
)
& rmViewpoints %~ map (shiftPointBy shift)
@@ -109,8 +101,8 @@ moveRoomBy shift r = r
& rmPmnts %~ map (shiftPlacement shift)
& rmFloor . tiles %~ map
( (tilePoly %~ map (shiftPointBy shift))
. (tileZero %~ shiftPointBy shift )
. (tileX %~ shiftPointBy shift )
. (tileZero %~ shiftPointBy shift )
. (tileX %~ shiftPointBy shift )
)
& rmViewpoints %~ map (shiftPointBy shift)
@@ -124,8 +116,7 @@ shiftRoomShiftToLink l inlink r
(p,a) = inlink
-- NOTE placements, when placed, will be shifted by the value _rmShift
shiftRoomShiftBy :: (Point2,Float) -> Room -> Room
shiftRoomShiftBy shift r = r
& rmShift %~ shiftPosDirBy shift
shiftRoomShiftBy shift = rmShift %~ shiftPosDirBy shift
shiftPosDirBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
shiftPosDirBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
src/Dodge/Room/Start.hs
+3 -3
View File
@@ -25,7 +25,7 @@ import Dodge.Item.Weapon.Utility
import Geometry
--import Padding
import Color
--import Shape
import Shape
import LensHelp
--import Data.Maybe
@@ -96,11 +96,11 @@ startRoom' = do
h <- state $ randomR (200,400)
let plmnts =
[ sPS (V2 0 0) 0 $ PutShape $ girderV 40 20 10 (V2 0 (h/2)) (V2 w (h/2))
--, mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
-- , mntLS jShape (V2 0 (h/3)) (V3 40 (h/3) 70)
, tankSquareEmboss4 (dim orange) 50 (h-60)
, tankSquare (dim orange) 50 50
, tankSquare (dim orange) 50 120
--, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
, sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25)
]
thecol <- rezColor
treeFromPost [PassDown $ rezBox thecol, PassDown door] . UseAll
src/Dodge/Tree/Shift.hs
+12 -7
View File
@@ -24,7 +24,8 @@ type RoomInt = (Room,Int)
positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [RoomInt])
positionRoomsFromTree (Node (r,i) ts) = printHeader
>> posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty
>> (fmap (fmap (map $ first createUnusedLinkPos)))
(posRms (map pointsToPoly $ _rmBound r') (r',i) (zipCount ts) Empty)
where
r' = r & rmMID ?~ 0
@@ -41,7 +42,7 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
tryParentLinks outlinks
where
child = fst childi
outlinks = zipCount
outlinks = zipCount
. Prelude.filter (not . S.null . S.intersection (_rmConnectsTo child) . _rlType)
$ _rmLinks parent
tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing
@@ -62,19 +63,23 @@ posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt
clipping = or (convexPolysOverlap <$> newBounds <*> bounds)
updateparent rm = doLnkEff (lnkPosDir outlnk) $ rm
& rmLinks %~ delete outlnk
& rmPos .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk)
& rmLinks %~ delete outlnk
& rmPos .:~ uncurry (UsedOutLink numChild (snd childi)) (lnkPosDir outlnk)
& rmChildren .:~ snd childi
shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk
updatechild rm = rm
& rmMParent ?~ snd parenti
& rmMID ?~ snd childi
& rmLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
. (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++) )
& rmLinks %~ delete il
& rmPos %~ ( (uncurry (UsedInLink 0) (lnkPosDir il):)
-- . (map (uncurry UnusedLink . lnkPosDir) (delete il (_rmLinks rm)) ++)
)
shiftedt = applyToRoot
(first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) t
createUnusedLinkPos :: Room -> Room
createUnusedLinkPos rm = rm & rmPos .++~ map (uncurry UnusedLink . lnkPosDir) (_rmLinks rm)
zipCount :: [a] -> [(Int,a)]
zipCount = Prelude.zip [0..]