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
2021-11-22 13:21:26 +00:00
parent 09e774d009
commit b4759e4a27
8 changed files with 30 additions and 116 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+4 -4
View File
@@ -45,13 +45,13 @@ anoToRoomTree anos = case anos of
[AnoApplyInt i f] -> f i
[SetLabel i randrm] -> do
rm <- randrm
return . connectRoom $ rm & rmLabel ?~ i
return . singleUseAll $ rm & rmLabel ?~ i
[UseLabel i randrm] -> do
rm <- randrm
return $ connectRoom $ rm & rmTakeFrom ?~ i
return $ singleUseAll $ rm & rmTakeFrom ?~ i
[ChainAnos ass] -> do
rms <- mapM anoToRoomTree ass
return $ linkEitherTrees rms
return $ chainUses rms
[OrAno as] -> do
a <- takeOne as
anoToRoomTree a
@@ -60,7 +60,7 @@ anoToRoomTree anos = case anos of
[FirstWeapon] -> do
branchWP <- branchRectWith weaponRoom
blockedC <- longBlockedCorridor
join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
join $ takeOne $ return (passUntilUseAll branchWP [blockedC]) : replicate 5 weaponRoom
[EndRoom] -> fmap (pure . UseAll) (telRoomLev 1)
(SpecificRoom rt:_) -> rt
(BossAno cr : _) -> do
src/Dodge/Annotation/Data.hs
-1
View File
@@ -5,7 +5,6 @@ import Dodge.Data
import Dodge.Room
import Dodge.Tree.Compose.Data
import Data.Tree
import Control.Monad.State
import Control.Lens
data Annotation g
src/Dodge/Floor.hs
+1 -1
View File
@@ -94,7 +94,7 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk
{- | A test level tree. -}
initialRoomTree :: RandomGen g => State g (Tree Room)
initialRoomTree = do
expandTreeBy id <$> mapM anoToRoomTree initialAnoTree
expandTree <$> mapM anoToRoomTree initialAnoTree
layoutLevelFromSeed :: Int -> Int -> IO [Room]
layoutLevelFromSeed i seed = do
src/Dodge/Room/Branch.hs
+2 -4
View File
@@ -21,7 +21,5 @@ branchRectWith t = do
y <- state $ randomR (100,200)
b <- t
root <- randomiseOutLinks $ roomRectAutoLinks x y
return $ Node (PassDown root) [Node (UseAll door) [], rToL <$> treeFromTrunk [PassDown door] b]
where
rToL (UseAll r) = PassDown r
rToL (PassDown r) = PassDown r
return $ Node (PassDown root) [Node (UseAll door) [], changeToPassDown <$>
treeFromTrunk [PassDown door] b]
src/Dodge/Room/RoadBlock.hs
-1
View File
@@ -14,7 +14,6 @@ import Dodge.RandomHelp
import Dodge.Creature
import Dodge.Tree
import Data.Tree
import Control.Monad.State
import Control.Lens
import System.Random
src/Dodge/Room/Room.hs
+13 -21
View File
@@ -77,7 +77,7 @@ glassLesson = do
corridors <- replicateM i $ PassDown <$> randomiseOutLinks corridor
return $ Node (PassDown botRoom) [singleUseNone door,uppers, treeFromPost (PassDown door : corridors) $ UseAll door]
where
uppers = Node (PassDown door) [deadRoom topRoom]
uppers = Node (PassDown door) [singleUseNone topRoom]
botRoom = set rmPmnts botplmnts $ roomRect 200 200 1 1
topRoom = set rmPmnts topplmnts $ roomRect 200 200 1 1
botplmnts =
@@ -171,7 +171,7 @@ miniRoom3 = do
,sPS cp (pi/8+7*pi/4) b
,sPS (V2 (w/2) (h/2)) 0 putLamp
]
fmap connectRoom $ randomiseOutLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
fmap singleUseAll $ randomiseOutLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen)
@@ -179,17 +179,9 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree
roomMiniIntro :: RandomGen g => State g (SubCompTree Room)
roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost
[return $ connectRoom door
,join $ takeOne [miniTree2,glassLesson]
]
$ connectRoom <$> randomiseOutLinks corridor
where
f (Node (UseAll x) xs) = Node (UseAll (UseAll x)) $ map f xs
f (Node (PassDown x) xs) = Node (PassDown (PassDown x)) $ map f xs
g (Node (UseAll x) []) = Node (UseAll x) []
g (Node (UseAll x) xs) = Node (PassDown x) $ map g xs
g (Node y ys) = Node y $ map g ys
roomMiniIntro = do
midroom <- join $ takeOne [miniTree2,glassLesson]
return $ chainUses $ [return $ UseAll door, midroom,return $ UseAll corridor]
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
@@ -272,7 +264,7 @@ weaponEmptyRoom = do
,mntLightLnkCond unusedLnkToPS
]
treeFromTrunk [PassDown corridor]
<$> ((fmap connectRoom . randomiseOutLinks) =<<
<$> ((fmap singleUseAll . randomiseOutLinks) =<<
changeLinkTo ((\p -> dist p (V2 (w/2) 0) < 10) . fst) (set rmPmnts plmnts $ roomRect w h 2 2)
)
@@ -285,14 +277,14 @@ weaponUnderCrits = do
]
let continuationRoom = treeFromTrunk
[PassDown corridorN,PassDown corridorN]
(connectRoom (set rmPmnts plmnts corridorN))
(singleUseAll (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar
deadEndRoom' <- takeOne [roomPillars,rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest]
return $ treeFromTrunk [PassDown corridorN,PassDown corridorN]
$ Node junctionRoom
[continuationRoom
,deadRoom deadEndRoom'
,singleUseNone deadEndRoom'
]
weaponBehindPillar :: RandomGen g => State g (SubCompTree Room)
@@ -310,7 +302,7 @@ weaponBehindPillar = do
[PassDown corridor
,PassDown $ over rmLinks tail $ over rmPmnts (++ plmnts1) rcp
]
(connectRoom $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
(singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room)
weaponBetweenPillars = do
@@ -324,7 +316,7 @@ weaponBetweenPillars = do
,sPS crPos2 (d crPos2) randC1
]
theRoom = roomPillars & rmPmnts %~ (++ plmnts)
(fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom
(fmap singleUseAll . randomiseOutLinks) =<< filterLinks f theRoom
where
f (_,a) = a == 0
@@ -336,8 +328,8 @@ weaponLongCorridor = do
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (connectRoom $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (deadRoom $ putWp corridor)
let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (singleUseAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (singleUseNone $ putWp corridor)
return $ Node (PassDown root) [branch1,branch2]
where
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ])
@@ -512,4 +504,4 @@ spawnerRoom = do
roomWithSpawner <- roomC x y <&>
rmPmnts %~ (spNoID (PSRoomRand 0) (PutCrit spawnerCrit) :)
aRoom <- airlock
return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ connectRoom roomWithSpawner
return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner
src/Dodge/Room/Start.hs
+5 -4
View File
@@ -80,11 +80,12 @@ rezThenLasTurret = do
cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just 0}
let doorroom = switchDoorRoom {_rmTakeFrom = Just 0}
contTree = treeFromPost [PassDown cenroom,PassDown doorroom] (UseAll door)
return $ rbox `appendEitherTree` [contTree]
return $ rbox `passUntilUseAll` [contTree]
startRoom :: RandomGen g => Int -> State g (SubCompTree Room)
startRoom i = join $ takeOne
[ minigunfakeout
[-- roomMiniIntro
minigunfakeout
, rezBoxesWp
, rezBoxesThenWeaponRoom
, rezBoxThenWeaponRoom
@@ -96,7 +97,7 @@ runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)
runPastStart i = do
s <- rezBoxStart
rp <- runPastRoom i
return $ s `appendEitherTree` [rp]
return $ s `passUntilUseAll` [rp]
rezBoxStart :: RandomGen g => State g (SubCompTree Room)
rezBoxStart = do
@@ -135,7 +136,7 @@ rezBoxesThenWeaponRoom :: RandomGen g => State g (SubCompTree Room)
rezBoxesThenWeaponRoom = do
rboxes <- rezBoxes
wroom <- weaponRoom
return $ rboxes `appendEitherTree` [wroom]
return $ rboxes `passUntilUseAll` [wroom]
rezBoxThenWeaponRoom :: RandomGen g => State g (SubCompTree Room)
rezBoxThenWeaponRoom = do
src/Dodge/Tree/Compose.hs
+5 -80
View File
@@ -1,17 +1,12 @@
{-| Combining and composing trees of trees. -}
module Dodge.Tree.Compose
( expandTreeBy
, appendEitherTree
, connectRoom
, connectTrunk
, deadRoom
, linkEitherTrees
, expandTree
( expandTree
, singleUseAll
, singleUseNone
, passUntilUseAll
, chainUses
, useAllAtEnd
, changeToPassDown
) where
import Dodge.Tree.Compose.Data
import Data.Tree
@@ -25,95 +20,25 @@ expandTree (Node root extChildren) = case root of
Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs
$ map (:[]) extChildren ++ repeat []
expandTreeBy
:: (a -> SubCompTree b) -- ^ Node function
-> Tree a -- ^ Base tree
-> Tree b
expandTreeBy f (Node x []) = fmap _unCompose (f x)
expandTreeBy f (Node x xs) = appendAndRemove $ f x
where
appendAndRemove (Node (PassDown y) ys) = Node y (map appendAndRemove ys)
appendAndRemove (Node (UseAll y) _ ) = Node y (map (expandTreeBy f) xs)
---- | 'Left' elements get new children as given by the node function,
---- 'Right' elements inherit the children from the base tree
--expandTreeBy
-- :: (a -> Tree (Either b b)) -- ^ Node function
-- -> Tree a -- ^ Base tree
-- -> Tree b
--expandTreeBy f (Node x []) = fmap removeEither (f x)
--expandTreeBy f (Node x xs) = appendAndRemove $ f x
-- where
-- appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
-- appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
-- | Appends a second either forest at the 'Right' elements of a first either
-- tree.
-- Makes such 'Right' elements into 'Left's.
--appendEitherTree
-- :: Tree (Either a a) -- ^ The first tree
-- -> [Tree (Either a a)] -- ^ The forest to append
-- -> Tree (Either a a)
--appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (`appendEitherTree` ts') ts
--appendEitherTree (Node (Right x) _) ts' = Node (Left x) ts'
appendEitherTree = passUntilUseAll
passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts
--linkEitherTrees :: [Tree (Either a a)] -> Tree (Either a a)
--linkEitherTrees (t:s:ts) = linkEitherTrees (appendEitherTree t [s]:ts)
--linkEitherTrees [t] = t
--linkEitherTrees [] = error "tried to concatenate an empty list of either trees"
linkEitherTrees = chainUses
chainUses :: [SubCompTree a] -> SubCompTree a
chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
chainUses [t] = t
chainUses [] = error "tried to concatenate an empty list of SubCompTrees"
removeEither = _unCompose
-- this is _unCompose
--removeEither :: Either p p -> p
--removeEither (Left y) = y
--removeEither (Right y) = y
{- |
Make a singleton connection of an Either Tree.
-}
--connectRoom :: a -> Tree (Either a a)
--connectRoom r = Node (Right r) []
connectRoom = singleUseAll
singleUseAll :: a -> Tree (ComposingNode a)
singleUseAll x = Node (UseAll x) []
{- |
Make a single Either connection at the end of a tree.
-}
--connectTrunk :: Tree a -> Tree (Either a a)
--connectTrunk (Node x (t:ts)) = Node (Left x) (connectTrunk t : map (fmap Left) ts)
--connectTrunk (Node x []) = Node (Right x) []
--
connectTrunk = useAllAtEnd
useAllAtEnd :: Tree a -> SubCompTree a
useAllAtEnd tree = case tree of
Node x (t:ts) -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
Node x [] -> Node (UseAll x) []
{- |
Make a singleton dead end of an Either Tree.
-}
--deadRoom :: a -> Tree (Either a a)
--deadRoom r = Node (Left r) []
deadRoom = singleUseNone
singleUseNone :: a -> SubCompTree a
singleUseNone x = Node (UseNone x) []
changeToPassDown :: ComposingNode a -> ComposingNode a
changeToPassDown x = PassDown (_unCompose x)