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

Cleanup

Browse Source
This commit is contained in:
justin
2022-06-10 20:53:01 +01:00
parent 1b7463f287
commit 6966e76206
14 changed files with 54 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+2 -9
View File
@@ -48,11 +48,6 @@ randomPadCorridors (Node x xs) = do
n <- state $ randomR (1, 3)
xs' <- mapM randomPadCorridors xs
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 (Tree Room)
roomThenCorridor theRoom = fmap
(\r -> Node ( theRoom) [(pure . useAll) r])
(shuffleLinks corridor)
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room)
@@ -67,10 +62,8 @@ anoToRoomTree anos = case anos of
let lr = snd lr'
keyroom' <- fromJust $ lookup ii ks
let keyroom = snd keyroom'
return (toOnward ("PassthroughLockKeyLists-"++show ii)
, overwriteLabel 0 lr [keyroom]
)
_ -> (toOnward "no label" ,) <$> anoToRoomTree' anos
rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom]
_ -> rToOnward "no label" =<< anoToRoomTree' anos
{- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room)
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -43,7 +43,7 @@ layoutLevelFromSeed i seed = do
--putStrLn "Room cluster layout:"
--putStrLn $ drawTreeSubLabelling $ fmap snd treecluster
--let rmtree = inorderNumberTree $ expandTree $ fmap fst treecluster
let rmtree = inorderNumberTree $ tc
let rmtree = inorderNumberTree tc
putStrLn "Room layout (compact): "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
let nameshow (r,rid) = _rmName r ++ "-" ++ show rid
src/Dodge/LockAndKey.hs
+2 -4
View File
@@ -115,7 +115,5 @@ someCrits = do
corridorBoss :: RandomGen g => Creature -> State g (LabTree Room)
corridorBoss cr = do
endroom <- bossRoom cr
return ( toOnward ("corridorBoss-"++_crName cr)
, treeFromPost (replicate 5 $ corridor) ( endroom)
)
rToOnward ("corridorBoss-"++_crName cr)
$ treeFromPost (replicate 5 corridor) endroom
src/Dodge/Room/Branch.hs
+2 -2
View File
@@ -22,7 +22,7 @@ branchRectWith t = do
y <- state $ randomR (100,200)
b <- t
rt <- shuffleLinks $ roomRectAutoLinks x y
return $ Node ( rt)
return $ Node rt
[ Node (useAll door) []
, useSide <$> treeFromTrunk [ door] b
, treeFromTrunk [door] b
]
src/Dodge/Room/LasTurret.hs
+5 -8
View File
@@ -76,9 +76,9 @@ keyCardRoomRunPast keyid rmid = do
cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
let doorroom = triggerDoorRoom rmid
return (toOnward "keyCardRoomRunPast",
treeFromTrunk [door] $ Node (cenroom)
treeFromTrunk [door] $ Node cenroom
[ treeFromPost [doorroom] (useAll door)
, treeFromPost [door] (useLabel 0 corridor)
, treeFromPost [door] (useLabel rmid corridor)
])
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
@@ -124,12 +124,11 @@ lasCenSensEdge :: RandomGen g => Int -> State g (LabTree Room)
lasCenSensEdge n = do
cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
let doorroom = triggerDoorRoom n
return (toOnward "lasCenSensEdge"
, treeFromTrunk [ door] $ Node ( cenroom)
rToOnward "lasCenSensEdge"
$ treeFromTrunk [ door] $ Node cenroom
[ treeFromPost [ doorroom] (useAll door)
, treeFromPost [ door] (useLabel 0 corridor)
]
)
lasTunnel :: RandomGen g => Float -> State g Room
lasTunnel y = do
@@ -171,9 +170,7 @@ lasTunnelRunPast y = do
r <- lasTunnel y
r1 <- takeOne [door,corridor]
r2 <- takeOne [door,corridor]
return (toOnward "lasTunnelRunPast"
, Node ( r)
rToOnward "lasTunnelRunPast" $ Node r
[ pure $ useAll r1
, return (useLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
]
)
src/Dodge/Room/LongDoor.hs
+1 -3
View File
@@ -143,9 +143,7 @@ slowDoorRoom = do
slowDoorRoomRunPast :: RandomGen g => State g (LabTree Room)
slowDoorRoomRunPast = do
r <- slowDoorRoom
return ( toOnward "slowDoorRoomRunPast"
, treeFromTrunk [ door] $ Node ( r)
rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r
[ pure $ useAll door
, return (useLabel 0 $ door & rmConnectsTo .~ S.member InLink)
]
)
src/Dodge/Room/LongRoom.hs
+3 -6
View File
@@ -50,12 +50,9 @@ longRoom = do
longRoomRunPast :: RandomGen g => State g (LabTree Room)
longRoomRunPast = do
r <- longRoom
return (toOnward "longRoomRunPast"
, treeFromTrunk [ door]
(Node ( r)
[ pure door
rToOnward "longRoomRunPast"
$ treeFromTrunk [ door] $ Node r
[ pure $ useAll door
, treeFromPost [ corridor & rmConnectsTo .~ S.member InLink]
(useLabel 0 door)
]
)
)
src/Dodge/Room/RezBox.hs
+8 -14
View File
@@ -54,12 +54,10 @@ rezBoxesWp = do
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom
return $ treeFromTrunk [ rezBox thecol
, door
]
(Node ( centralRoom) (rezrooms ++ [onwardpassage]))
return $ treeFromTrunk [ rezBox thecol , door ]
$ Node centralRoom (rezrooms ++ [onwardpassage])
where
adddoor rm = treeFromPost [ connectsToNorth door ] ( rm)
adddoor rm = treeFromPost [ connectsToNorth door ] rm
connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
maybeBlockedPassage :: RandomGen g => State g (Tree Room)
maybeBlockedPassage = fmap (pure . useAll)
@@ -82,12 +80,10 @@ rezBoxesWpCrit = do
$ insertAt i (wpAdd theweapon aroom)
$ insertAt j (crAdd aroom)
$ replicate (n-3) aroom
return $ treeFromTrunk [ rezBox thecol
, door
]
(Node ( centralRoom) (rezrooms ++ [onwardpassage]))
return $ treeFromTrunk [rezBox thecol , door]
$ Node centralRoom (rezrooms ++ [onwardpassage])
where
adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] ( rm)
adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] rm
crAdd :: Room -> Room
crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
@@ -103,10 +99,8 @@ rezBoxes = do
centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ setInLinks bottomEdgeTest
let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
return $ treeFromTrunk [ rezBox thecol
, door
]
(Node ( centralRoom) (replicate (n-1) dbox ++ [Node (useAll door) []]))
return $ treeFromTrunk [rezBox thecol, door]
$ Node centralRoom (replicate (n-1) dbox ++ [Node (useAll door) []])
rezColor :: RandomGen g => State g LightSource
rezColor = do
src/Dodge/Room/Room.hs
+8 -8
View File
@@ -60,7 +60,7 @@ branchWith r ts = Node r $ return (useAll door) : ts
manyDoors :: Int -> Tree Room
manyDoors i = treeFromPost (replicate i ( door)) $ useAll door
manyDoors i = treeFromPost (replicate i door) $ useAll door
glassSwitchBack :: RandomGen g => State g Room
glassSwitchBack = do
@@ -282,9 +282,9 @@ weaponLongCorridor = do
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 $ corridorN) (pure . useAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ corridorN) (pure . useSide $ putWp corridor)
return $ Node ( rt) [branch1,branch2]
let branch1 = treeFromTrunk (replicate i1 corridorN) (pure . useAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . useSide $ putWp corridor)
return $ Node rt [branch1,branch2]
where
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
@@ -307,11 +307,11 @@ deadEndRoom = defaultRoom
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => Int -> State g (LabTree Room)
weaponRoom i = join $ takeOne
[ weaponEmptyRoom <&> (f "weaponEmptyRoom")
[ weaponEmptyRoom <&> f "weaponEmptyRoom"
, weaponUnderCrits i
, weaponBehindPillar<&> (f "weaponBehindPillar")
, weaponBetweenPillars<&> (f "weaponBetweenPillars")
, weaponLongCorridor<&> (f "weaponLongCorridor")
, weaponBehindPillar <&> f "weaponBehindPillar"
, weaponBetweenPillars <&> f "weaponBetweenPillars"
, weaponLongCorridor <&> f "weaponLongCorridor"
]
where
f str = ( toOnward str ,)
src/Dodge/Room/RunPast.hs
+5 -5
View File
@@ -60,10 +60,10 @@ runPastRoom i = do
}
switchdoor = triggerDoorRoom i
n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks cenroom
controom = treeFromPost [ switchdoor, linkcor] (useAll door)
controom = treeFromPost [ switchdoor, linkcor,corridor,corridor] (useAll door)
critrooms :: [Tree Room]
critrooms = treeFromPost [ switchdoor] ( critroom) :
replicate (n-2) (treeFromPost [ switchdoor] ( linkcor))
return $ Node ( cenroom) $
critrooms = treeFromPost [ switchdoor] critroom
: replicate (n-2) (treeFromPost [ switchdoor] linkcor)
return $ Node cenroom $
map (over root $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms)
++ [return $ aswitchroom]
++ [return aswitchroom]
src/Dodge/Room/Start.hs
+9 -12
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Start where
import Dodge.UseAll
import Dodge.Data
@@ -6,7 +6,7 @@ import Dodge.LevelGen.Data
--import Dodge.PlacementSpot
import Dodge.Room.RunPast
import Dodge.Room.Containing
import Dodge.Room.LongDoor
--import Dodge.Room.LongDoor
--import Dodge.RoomLink
--import Dodge.Data
--import Dodge.Default
@@ -49,20 +49,17 @@ powerFakeout = do
`treeFromPost` useAll door
startRoom :: RandomGen g => Int -> State g (LabTree Room)
startRoom i = join (takeOne $
startRoom i = join (takeOne
[-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i])
-- <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
-- wat
(rezBoxesWp <&> (toOnward "rezBoxesWp",))
, (rezBoxThenWeaponRoom i)
, (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit",))
, (runPastStart i <&> (toOnward ("runPastStart " ++ show i),))
-- , ((startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms) <&>
-- (toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms",))
rezBoxesWp >>= rToOnward "rezBoxesWp"
, rezBoxThenWeaponRoom i
, rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit"
, runPastStart i >>= rToOnward ("runPastStart " ++ show i)
, startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms
>>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"
])
where
roomsContaining' a b = fst <$> roomsContaining a b
one = 1::Float
randomChallenges :: RandomGen g => State g (LabTree Room)
randomChallenges = shootingRange
-- join (takeOne
src/Dodge/Tree/Compose.hs
+2 -2
View File
@@ -43,8 +43,8 @@ import Data.Maybe
overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
overwriteLabel i t ts = safeUpdateSingleNode
(\rm -> LabelCluster 0 `elem` (rm ^?! rmClusterStatus . csLinks))
((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster 0) .~ Nothing))
(\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing))
t
--overwriteLabel :: Int -> (a -> ComposingNode a) -> Tree a -> [Tree a] -> Tree a
src/Dodge/UseAll.hs
+5
View File
@@ -1,6 +1,8 @@
{-# LANGUAGE TupleSections #-}
module Dodge.UseAll where
import Dodge.Data
import Data.Tree
import Control.Lens
import qualified Data.Set as S
@@ -9,6 +11,9 @@ toOnward s rm
| OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm)
| otherwise = Nothing
rToOnward :: Monad m => String -> Tree Room -> m (Room -> Maybe ([String],Room), Tree Room)
rToOnward s = return . (toOnward s ,)
toClusterLabel :: Int -> String -> Room -> Maybe ([String],Room)
toClusterLabel i s rm
| LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just ([s],rm)
src/TreeHelp.hs
+1 -1
View File
@@ -115,7 +115,7 @@ msafeUpdateSingleNode :: Monoid b => (a -> Bool) -> (Tree a -> (b, Tree a)) -> T
msafeUpdateSingleNode f g t = fromMaybe (mempty,t) $ listToMaybe $ mupdateSingleNodes f g t
msubMap :: Functor m => (a -> [m a]) -> [a] -> [m [a]]
msubMap f (x:xs) = (f x <&> fmap (: xs)) ++ ( (fmap (x :)) <$> msubMap f xs )
msubMap f (x:xs) = (f x <&> fmap (: xs)) ++ ( fmap (x :) <$> msubMap f xs )
msubMap _ [] = []
subMap :: (a -> [a]) -> [a] -> [[a]]