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

Commit mid big tree composing change

Browse Source
This commit is contained in:
justin
2022-06-09 21:25:22 +01:00
parent 8fb80f9691
commit 3edc7a0a58
20 changed files with 263 additions and 248 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+9 -9
View File
@@ -35,8 +35,8 @@ padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs
thetree = do thetree = do
thecor <- shuffleLinks corridor thecor <- shuffleLinks corridor
takeOne takeOne
[ (return (UseAll door),TreeSubLabelling "door" Nothing) [ (return (useAll door),TreeSubLabelling "door" Nothing)
, (treeFromPost [PassDown door, PassDown thecor] (UseAll door) , (treeFromPost [ door, thecor] (useAll door)
,TreeSubLabelling "twoDoors" Nothing) ,TreeSubLabelling "twoDoors" Nothing)
] ]
@@ -47,9 +47,9 @@ randomPadCorridors (Node x xs) = do
xs' <- mapM randomPadCorridors xs xs' <- mapM randomPadCorridors xs
return $ treeFromTrunk (replicate n [Corridor]) (Node x xs') return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
{- | Add a corridor to a random out-link of a room. -} {- | Add a corridor to a random out-link of a room. -}
roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room) roomThenCorridor :: RandomGen g => Room -> State g (Tree Room)
roomThenCorridor theRoom = fmap roomThenCorridor theRoom = fmap
(\r -> Node (PassDown theRoom) [(pure . UseAll) r]) (\r -> Node ( theRoom) [(pure . useAll) r])
(shuffleLinks corridor) (shuffleLinks corridor)
{- | Create a random room tree structure from a list of annotations. -} {- | Create a random room tree structure from a list of annotations. -}
@@ -72,7 +72,7 @@ anoToRoomTree anos = case anos of
_ -> (,TreeSubLabelling "no label" Nothing) <$> anoToRoomTree' anos _ -> (,TreeSubLabelling "no label" Nothing) <$> anoToRoomTree' anos
{- | Create a random room tree structure from a list of annotations. -} {- | Create a random room tree structure from a list of annotations. -}
anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room) anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room)
anoToRoomTree' anos = case anos of anoToRoomTree' anos = case anos of
[ChainAnos ass] -> do [ChainAnos ass] -> do
rms <- mapM anoToRoomTree' ass rms <- mapM anoToRoomTree' ass
@@ -80,12 +80,12 @@ anoToRoomTree' anos = case anos of
[OrAno as] -> do [OrAno as] -> do
a <- takeOne as a <- takeOne as
anoToRoomTree' a anoToRoomTree' a
[Corridor] -> pure . UseAll <$> shuffleLinks corridor [Corridor] -> pure . useAll <$> shuffleLinks corridor
(BossAno cr : _) -> do (BossAno cr : _) -> do
br <- bossRoom cr br <- bossRoom cr
branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br branchRectWith . pure . fmap $ treeFromPost [corridor,corridor] br
(TreasureAno crs loot : _) -> branchRectWith . fmap (pure . PassDown) $ lootRoom crs loot (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . ) $ lootRoom crs loot
_ -> do _ -> do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (200,400) h <- state $ randomR (200,400)
fmap (pure . UseAll) . shuffleLinks $ roomRectAutoLinks w h fmap (pure . useAll) . shuffleLinks $ roomRectAutoLinks w h
src/Dodge/Annotation/Data.hs
+7 -6
View File
@@ -3,6 +3,7 @@
module Dodge.Annotation.Data where module Dodge.Annotation.Data where
import Dodge.Data import Dodge.Data
--import Dodge.Room --import Dodge.Room
import TreeHelp
import Dodge.Tree.Compose.Data import Dodge.Tree.Compose.Data
import Control.Monad.State import Control.Monad.State
@@ -14,16 +15,16 @@ data Annotation
| Corridor | Corridor
| AirlockAno | AirlockAno
| OrAno [[Annotation]] | OrAno [[Annotation]]
| SpecificRoom (State StdGen (LabSubCompTree Room)) | SpecificRoom (State StdGen (LabTree Room))
| BossAno Creature | BossAno Creature
| TreasureAno [Creature] [Item] | TreasureAno [Creature] [Item]
| AnoApplyInt Int (Int -> State StdGen (LabSubCompTree Room)) | AnoApplyInt Int (Int -> State StdGen (LabTree Room))
| AnoNewInt (Int -> State StdGen (SubCompTree Room)) | AnoNewInt (Int -> State StdGen (Tree Room))
| PassthroughLockKeyLists Int | PassthroughLockKeyLists Int
[(Int -> State StdGen (LabSubCompTree Room), State StdGen ItemBaseType)] [(Int -> State StdGen (LabTree Room), State StdGen ItemBaseType)]
[(ItemBaseType, State StdGen (LabSubCompTree Room))] [(ItemBaseType, State StdGen (LabTree Room))]
-- | SetLabel Int (State g Room) -- | SetLabel Int (State g Room)
-- | UseLabel Int (State g Room) -- | useLabel Int (State g Room)
| ChainAnos [[Annotation]] | ChainAnos [[Annotation]]
makeLenses ''Annotation makeLenses ''Annotation
src/Dodge/Floor.hs
+14 -14
View File
@@ -39,7 +39,7 @@ initialAnoTree = padSucWithDoors $ treeFromPost
[[AnoApplyInt 0 startRoom] [[AnoApplyInt 0 startRoom]
, [PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms] , [PassthroughLockKeyLists 2 keyCardRunPastRand itemRooms]
, [SpecificRoom $ warningRooms 7] , [SpecificRoom $ warningRooms 7]
, [SpecificRoom $ return (return . UseAll $ roomRectAutoLinks 400 400 , [SpecificRoom $ return (return . useAll $ roomRectAutoLinks 400 400
& rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) & rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
, spNoID anyUnusedSpot (PutCrit armourChaseCrit) , spNoID anyUnusedSpot (PutCrit armourChaseCrit)
] ]
@@ -48,33 +48,33 @@ initialAnoTree = padSucWithDoors $ treeFromPost
-- , [AnoApplyInt 100 healthTest] -- , [AnoApplyInt 100 healthTest]
, [PassthroughLockKeyLists 23 , [PassthroughLockKeyLists 23
[(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms] [(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )] itemRooms]
, [SpecificRoom ((return . UseAll <$> tanksRoom [] []) , [SpecificRoom ((return . useAll <$> tanksRoom [] [])
<&> (, TreeSubLabelling "empty tanksRoom" Nothing))] <&> (, TreeSubLabelling "empty tanksRoom" Nothing))]
, [PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms] , [PassthroughLockKeyLists 222 lockRoomKeyItems itemRooms]
, [SpecificRoom randomChallenges] , [SpecificRoom randomChallenges]
, [AnoApplyInt 1 lasSensorTurretTest] , [AnoApplyInt 1 lasSensorTurretTest]
-- ,[SpecificRoom $ fmap singleUseAll roomCCrits] -- ,[SpecificRoom $ fmap pure roomCCrits]
-- ,[AirlockAno] -- ,[AirlockAno]
-- ,[Corridor] -- ,[Corridor]
------ ,[SpecificRoom roomCCrits] ------ ,[SpecificRoom roomCCrits]
------ ,[Corridor] ------ ,[Corridor]
------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 ------ ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400
------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit ------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit ------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit ------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
------ ]++) ------ ]++)
------ ] ------ ]
------ --,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 ------ --,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400
------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) ------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
------ -- ] ------ -- ]
------ ,[SpecificRoom . pure . pure . UseAll $ roomGlassOctogon 400 ------ ,[SpecificRoom . pure . pure . useAll $ roomGlassOctogon 400
------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) ------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
------ ] ------ ]
------ ,[Corridor] ------ ,[Corridor]
---- --,[SpecificRoom $ pure . UseAll <$> twinSlowDoorChasers] ---- --,[SpecificRoom $ pure . useAll <$> twinSlowDoorChasers]
----- ,[SpecificRoom $ pure $ (pure . UseAll) (twinSlowDoorRoom 80 200 40)] ----- ,[SpecificRoom $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)]
----- ,[DoorAno] ----- ,[DoorAno]
----- ,[SpecificRoom $ pure . UseAll <$> centerVaultExplosiveExit] ----- ,[SpecificRoom $ pure . useAll <$> centerVaultExplosiveExit]
----- ,[SpecificRoom blockedCorridor] ----- ,[SpecificRoom blockedCorridor]
----- ,[OrAno [[DoorAno] ----- ,[OrAno [[DoorAno]
----- ,[Corridor] ----- ,[Corridor]
@@ -82,21 +82,21 @@ initialAnoTree = padSucWithDoors $ treeFromPost
----- ] ----- ]
----- ,[FirstWeapon] ----- ,[FirstWeapon]
----- ,[CorridorDebug] ----- ,[CorridorDebug]
----- ,[SpecificRoom $ fmap (pure . UseAll) randomFourCornerRoom] ----- ,[SpecificRoom $ fmap (pure . useAll) randomFourCornerRoom]
-- ,[OrAno -- ,[OrAno
-- [[SpecificRoom $ branchRectWith $ fmap (fmap PassDown) armouredChasers] -- [[SpecificRoom $ branchRectWith $ fmap (fmap ) armouredChasers]
-- ,[BossAno $ addArmour launcherCrit & crHP +~ 800 -- ,[BossAno $ addArmour launcherCrit & crHP +~ 800
-- & crState . crDropsOnDeath .~ DropSpecific [0] ] -- & crState . crDropsOnDeath .~ DropSpecific [0] ]
-- ] -- ]
-- ] -- ]
---- ,[SpecificRoom $ fmap (pure . UseAll) armouredCorridor] ---- ,[SpecificRoom $ fmap (pure . useAll) armouredCorridor]
-- ,[Corridor] -- ,[Corridor]
-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] -- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
-- ,[Corridor] -- ,[Corridor]
,[SpecificRoom $ (pure . UseAll <$> randomFourCornerRoom []) ,[SpecificRoom $ (pure . useAll <$> randomFourCornerRoom [])
<&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )] <&>(,TreeSubLabelling "randomFourCornerRoom" Nothing )]
] ]
[SpecificRoom $ fmap (pure . UseAll) (telRoomLev 1) [SpecificRoom $ fmap (pure . useAll) (telRoomLev 1)
<&> (,TreeSubLabelling "telRoomLev" Nothing)] <&> (,TreeSubLabelling "telRoomLev" Nothing)]
{- | A test level tree. -} {- | A test level tree. -}
src/Dodge/LockAndKey.hs
+10 -10
View File
@@ -13,12 +13,12 @@ import Dodge.Item
--import Dodge.Item.Equipment --import Dodge.Item.Equipment
bossKeyItems :: RandomGen g => [ (State g (SubCompTree Room), State g ItemBaseType) ] bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ]
bossKeyItems = bossKeyItems =
[(return . UseAll <$> bossRoom autoCrit, takeOne [PISTOL]) [(return . useAll <$> bossRoom autoCrit, takeOne [PISTOL])
] ]
lockRoomMultiItems :: RandomGen g => [ ( State g (LabSubCompTree Room) , State g [ItemBaseType] ) ] lockRoomMultiItems :: RandomGen g => [ ( State g (LabTree Room) , State g [ItemBaseType] ) ]
lockRoomMultiItems = lockRoomMultiItems =
[ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR] [ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR]
,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR] ,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR]
@@ -26,7 +26,7 @@ lockRoomMultiItems =
) )
] ]
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g ItemBaseType ) ] lockRoomKeyItems :: RandomGen g => [ (Int -> State g (LabTree Room) , State g ItemBaseType ) ]
lockRoomKeyItems = lockRoomKeyItems =
[(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD,FORCEFIELDGUN] ) [(lasCenSensEdge, takeOne [LAUNCHER,LASGUN,SPARKGUN,FLATSHIELD,FORCEFIELDGUN] )
,(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] ) ,(sensorRoomRunPast ELECTRICAL, takeOne [STATICMODULE,SPARKGUN] )
@@ -38,12 +38,12 @@ lockRoomKeyItems =
,(const $ lasTunnelRunPast 400, takeOne [FLATSHIELD,FORCEFIELDGUN]) ,(const $ lasTunnelRunPast 400, takeOne [FLATSHIELD,FORCEFIELDGUN])
,(keyCardRoomRunPast 0, return (KEYCARD 0)) ,(keyCardRoomRunPast 0, return (KEYCARD 0))
] ]
keyCardRunPastRand :: RandomGen g => [ (Int -> State g (LabSubCompTree Room) , State g ItemBaseType ) ] keyCardRunPastRand :: RandomGen g => [ (Int -> State g (LabTree Room) , State g ItemBaseType ) ]
keyCardRunPastRand = keyCardRunPastRand =
[(keyCardRoomRunPast 0, return (KEYCARD 0)) [(keyCardRoomRunPast 0, return (KEYCARD 0))
] ]
itemRooms :: RandomGen g => [(ItemBaseType, State g (LabSubCompTree Room))] itemRooms :: RandomGen g => [(ItemBaseType, State g (LabTree Room))]
itemRooms = itemRooms =
[ (LAUNCHER , join $ takeOne [ (LAUNCHER , join $ takeOne
[corridorBoss launcherCrit [corridorBoss launcherCrit
@@ -104,17 +104,17 @@ someCrits = do
++ replicate 20 chaseCrit ++ replicate 20 chaseCrit
--addcrits :: RandomGen g => [Item] -> State g (SubCompTree Room) --addcrits :: RandomGen g => [Item] -> State g (Tree Room)
--addcrits its = do --addcrits its = do
-- nCrits <- state $ randomR (1,3) -- nCrits <- state $ randomR (1,3)
-- crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] -- crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
-- return $ roomsContaining crits its -- return $ roomsContaining crits its
corridorBoss :: RandomGen g => Creature -> State g (LabSubCompTree Room) corridorBoss :: RandomGen g => Creature -> State g (LabTree Room)
corridorBoss cr = do corridorBoss cr = do
endroom <- bossRoom cr endroom <- bossRoom cr
return (treeFromPost (replicate 5 $ PassDown corridor) return (treeFromPost (replicate 5 $ corridor)
(PassDown endroom) ( endroom)
,TreeSubLabelling ("corridorBoss-"++_crName cr) Nothing) ,TreeSubLabelling ("corridorBoss-"++_crName cr) Nothing)
src/Dodge/Room/BlinkAcross.hs
+2 -2
View File
@@ -33,12 +33,12 @@ import LensHelp
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
blinkAcrossChallenge :: RandomGen g => State g (LabSubCompTree Room) blinkAcrossChallenge :: RandomGen g => State g (LabTree Room)
blinkAcrossChallenge = do blinkAcrossChallenge = do
teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200 teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200
teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200 teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200
emptylink <- shuffleLinks emptyCorridor emptylink <- shuffleLinks emptyCorridor
return (treeFromPost [PassDown teleFromRoom,PassDown emptylink] (UseAll teleToRoom) return (treeFromPost [ teleFromRoom, emptylink] (useAll teleToRoom)
, TreeSubLabelling "blinkAcrossChallenge" Nothing) , TreeSubLabelling "blinkAcrossChallenge" Nothing)
emptyCorridor :: Room emptyCorridor :: Room
src/Dodge/Room/Branch.hs
+4 -4
View File
@@ -15,13 +15,13 @@ import Dodge.Tree
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
branchRectWith :: RandomGen g => State g (SubCompTree Room) -> State g (SubCompTree Room) branchRectWith :: RandomGen g => State g (Tree Room) -> State g (Tree Room)
branchRectWith t = do branchRectWith t = do
x <- state $ randomR (100,200) x <- state $ randomR (100,200)
y <- state $ randomR (100,200) y <- state $ randomR (100,200)
b <- t b <- t
rt <- shuffleLinks $ roomRectAutoLinks x y rt <- shuffleLinks $ roomRectAutoLinks x y
return $ Node (PassDown rt) return $ Node ( rt)
[ Node (UseAll door) [] [ Node (useAll door) []
, changeToPassDown <$> treeFromTrunk [PassDown door] b , changeTo <$> treeFromTrunk [ door] b
] ]
src/Dodge/Room/Containing.hs
+1 -1
View File
@@ -15,7 +15,7 @@ import Geometry
import Data.List import Data.List
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabSubCompTree Room) roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (LabTree Room)
roomsContaining crs its = do roomsContaining crs its = do
endroom <- join $ takeOne endroom <- join $ takeOne
[ randomFourCornerRoomCrsIts crs its [ randomFourCornerRoomCrsIts crs its
src/Dodge/Room/GlassLesson.hs
+1 -1
View File
@@ -53,7 +53,7 @@ glassLesson = do
, mntLS vShape (V2 180 200) (V3 160 180 50) , mntLS vShape (V2 180 200) (V3 160 180 50)
] ]
] ]
glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room) glassLessonRunPast :: RandomGen g => State g (LabTree Room)
glassLessonRunPast = (f <$> glassLesson) <&> (toOnward "glassLessonRunPast",) glassLessonRunPast = (f <$> glassLesson) <&> (toOnward "glassLessonRunPast",)
where where
f (Node r rs) = Node r $ return (useLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs f (Node r rs) = Node r $ return (useLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs
src/Dodge/Room/LasTurret.hs
+27 -23
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.LasTurret where module Dodge.Room.LasTurret where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.UseAll
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.Data import Dodge.Data
import Dodge.Tree import Dodge.Tree
@@ -70,15 +71,15 @@ lightSensByDoor outplid rm = rm
covershape = rectNSEW 10 (-10) 20 (-20) covershape = rectNSEW 10 (-10) 20 (-20)
sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a) sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a)
keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (LabSubCompTree Room) keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (LabTree Room)
keyCardRoomRunPast keyid rmid = do keyCardRoomRunPast keyid rmid = do
cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200 cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200
let doorroom = triggerDoorRoom rmid let doorroom = triggerDoorRoom rmid
return (treeFromTrunk [PassDown door] $ Node (PassDown cenroom) return (toOnward "keyCardRoomRunPast",
[ treeFromPost [PassDown doorroom] (UseAll door) treeFromTrunk [door] $ Node (cenroom)
, treeFromPost [PassDown door] (UseLabel 0 corridor) [ treeFromPost [doorroom] (useAll door)
] , treeFromPost [door] (useLabel 0 corridor)
,TreeSubLabelling "keyCardRoomRunPast" Nothing) ])
keyCardAnalyserByDoor :: Int -> Int -> Room -> Room keyCardAnalyserByDoor :: Int -> Int -> Room -> Room
keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (KEYCARD keyid)) keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (KEYCARD keyid))
@@ -102,31 +103,33 @@ analyserByDoor proxreq outplid rm = rm
where where
sensorshift (p,a) = (p +.+ rotateV a (V2 30 (-10)), a) sensorshift (p,a) = (p +.+ rotateV a (V2 30 (-10)), a)
healthTest :: RandomGen g => Int -> State g (SubCompTree Room) healthTest :: RandomGen g => Int -> State g (Tree Room)
healthTest n = do healthTest n = do
cenroom <- shuffleLinks $ healthAnalyserByDoor n $ roomNgon 8 200 cenroom <- shuffleLinks $ healthAnalyserByDoor n $ roomNgon 8 200
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
return $ treeFromPost [PassDown door return $ treeFromPost [door
,PassDown $ corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100)) , corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100))
,PassDown cenroom,PassDown doorroom] (UseAll door) , cenroom, doorroom]
(useAll door)
lasSensorTurretTest :: RandomGen g => Int -> State g (LabSubCompTree Room) lasSensorTurretTest :: RandomGen g => Int -> State g (LabTree Room)
lasSensorTurretTest n = do lasSensorTurretTest n = do
cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) return ( toOnward "lasSensorTurretTest"
, TreeSubLabelling "lasSensorTurretTest" Nothing , treeFromPost [ door, cenroom, doorroom] (useAll door)
) )
lasCenSensEdge :: RandomGen g => Int -> State g (LabSubCompTree Room) lasCenSensEdge :: RandomGen g => Int -> State g (LabTree Room)
lasCenSensEdge n = do lasCenSensEdge n = do
cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
return (treeFromTrunk [PassDown door] $ Node (PassDown cenroom) return (toOnward "lasCenSensEdge"
[ treeFromPost [PassDown doorroom] (UseAll door) , treeFromTrunk [ door] $ Node ( cenroom)
, treeFromPost [PassDown door] (UseLabel 0 corridor) [ treeFromPost [ doorroom] (useAll door)
, treeFromPost [ door] (useLabel 0 corridor)
] ]
,TreeSubLabelling "lasCenSensEdge" Nothing) )
lasTunnel :: RandomGen g => Float -> State g Room lasTunnel :: RandomGen g => Float -> State g Room
lasTunnel y = do lasTunnel y = do
@@ -163,13 +166,14 @@ lasTunnel y = do
] ]
-- a y value of 400 is probably "unrunnable" -- a y value of 400 is probably "unrunnable"
lasTunnelRunPast :: RandomGen g => Float -> State g (LabSubCompTree Room) lasTunnelRunPast :: RandomGen g => Float -> State g (LabTree Room)
lasTunnelRunPast y = do lasTunnelRunPast y = do
r <- lasTunnel y r <- lasTunnel y
r1 <- takeOne [door,corridor] r1 <- takeOne [door,corridor]
r2 <- takeOne [door,corridor] r2 <- takeOne [door,corridor]
return (Node (PassDown r) return (toOnward "lasTunnelRunPast"
[ singleUseAll r1 , Node ( r)
, return (UseLabel 0 $ r2 & rmConnectsTo .~ S.member InLink) [ pure $ useAll r1
, return (useLabel 0 $ r2 & rmConnectsTo .~ S.member InLink)
] ]
,TreeSubLabelling "lasTunnelRunPast" Nothing) )
src/Dodge/Room/LongDoor.hs
+7 -5
View File
@@ -3,6 +3,7 @@
-} -}
module Dodge.Room.LongDoor where module Dodge.Room.LongDoor where
import Dodge.Data import Dodge.Data
import Dodge.UseAll
import Dodge.RoomLink import Dodge.RoomLink
import Dodge.Base import Dodge.Base
import Dodge.Tree import Dodge.Tree
@@ -139,11 +140,12 @@ slowDoorRoom = do
proom <- southPillarsRoom x y h proom <- southPillarsRoom x y h
addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels))) addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels)))
slowDoorRoomRunPast :: RandomGen g => State g (LabSubCompTree Room) slowDoorRoomRunPast :: RandomGen g => State g (LabTree Room)
slowDoorRoomRunPast = do slowDoorRoomRunPast = do
r <- slowDoorRoom r <- slowDoorRoom
return (treeFromTrunk [PassDown door] $ Node (PassDown r) return ( toOnward "slowDoorRoomRunPast"
[ singleUseAll door , treeFromTrunk [ door] $ Node ( r)
, return (UseLabel 0 $ door & rmConnectsTo .~ S.member InLink) [ pure $ useAll door
, return (useLabel 0 $ door & rmConnectsTo .~ S.member InLink)
] ]
,TreeSubLabelling "slowDoorRoomRunPast" Nothing) )
src/Dodge/Room/LongRoom.hs
+9 -9
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.LongRoom where module Dodge.Room.LongRoom where
import Dodge.UseAll
import Dodge.RoomLink import Dodge.RoomLink
import Dodge.Tree import Dodge.Tree
--import Dodge.Default.Room --import Dodge.Default.Room
@@ -46,16 +47,15 @@ longRoom = do
| crx <- [12.5,37.5,62.5] ] ++ | crx <- [12.5,37.5,62.5] ] ++
[sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ] [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ]
longRoomRunPast :: RandomGen g => State g (LabSubCompTree Room) longRoomRunPast :: RandomGen g => State g (LabTree Room)
longRoomRunPast = do longRoomRunPast = do
r <- longRoom r <- longRoom
return (treeFromTrunk [PassDown door] return (toOnward "longRoomRunPast"
(Node (PassDown r) , treeFromTrunk [ door]
[ singleUseAll door (Node ( r)
--, return (UseLabel 0 $ door & rmConnectsTo .~ S.singleton InLink) [ pure door
--, treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink, PassDown corridor] , treeFromPost [ corridor & rmConnectsTo .~ S.member InLink]
, treeFromPost [PassDown $ corridor & rmConnectsTo .~ S.member InLink] (useLabel 0 door)
(UseLabel 0 door)
] ]
) )
,TreeSubLabelling "longRoomRunPast" Nothing) )
src/Dodge/Room/RezBox.hs
+21 -19
View File
@@ -1,5 +1,6 @@
module Dodge.Room.RezBox where module Dodge.Room.RezBox where
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.UseAll
--import Dodge.PlacementSpot --import Dodge.PlacementSpot
--import Dodge.Room.RunPast --import Dodge.Room.RunPast
import Dodge.RoomLink import Dodge.RoomLink
@@ -39,7 +40,7 @@ rezBox ls = roomRect 40 60 1 1
& restrictOutLinks (\(V2 _ h,_)-> h > 59) & restrictOutLinks (\(V2 _ h,_)-> h > 59)
& rmName .~ "rezBox" & rmName .~ "rezBox"
rezBoxesWp :: RandomGen g => State g (SubCompTree Room) rezBoxesWp :: RandomGen g => State g (Tree Room)
rezBoxesWp = do rezBoxesWp = do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (40,40) h <- state $ randomR (40,40)
@@ -53,16 +54,17 @@ rezBoxesWp = do
let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom
let rezrooms = map adddoor let rezrooms = map adddoor
$ wpAdd theweapon aroom : replicate (n-2) aroom $ wpAdd theweapon aroom : replicate (n-2) aroom
return $ treeFromTrunk [PassDown $ rezBox thecol return $ treeFromTrunk [ rezBox thecol
, PassDown door , door
] ]
(Node (PassDown centralRoom) (rezrooms ++ [onwardpassage])) (Node ( centralRoom) (rezrooms ++ [onwardpassage]))
where where
adddoor rm = treeFromPost [PassDown $ connectsToNorth door ] (PassDown rm) adddoor rm = treeFromPost [ connectsToNorth door ] ( rm)
connectsToNorth = rmConnectsTo .~ S.member (OnEdge North) connectsToNorth = rmConnectsTo .~ S.member (OnEdge North)
maybeBlockedPassage :: RandomGen g => State g (SubCompTree Room) maybeBlockedPassage :: RandomGen g => State g (Tree Room)
maybeBlockedPassage = fmap singleUseAll $ join $ takeOne [return corridor, blockedCorridorCloseBlocks] maybeBlockedPassage = fmap (pure . useAll)
rezBoxesWpCrit :: RandomGen g => State g (SubCompTree Room) $ join $ takeOne [return corridor, blockedCorridorCloseBlocks]
rezBoxesWpCrit :: RandomGen g => State g (Tree Room)
rezBoxesWpCrit = do rezBoxesWpCrit = do
w <- state $ randomR (200,400) w <- state $ randomR (200,400)
h <- state $ randomR (40,40) h <- state $ randomR (40,40)
@@ -72,7 +74,7 @@ rezBoxesWpCrit = do
aroom = rezInvBox thecol aroom = rezInvBox thecol
let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []} let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []}
onwardpassage <- onwardpassage <-
applyToCompRoot (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage over root (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage
let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom
i <- state $ randomR (0,n-3) i <- state $ randomR (0,n-3)
j <- state $ randomR (i,n-2) j <- state $ randomR (i,n-2)
@@ -80,31 +82,31 @@ rezBoxesWpCrit = do
$ insertAt i (wpAdd theweapon aroom) $ insertAt i (wpAdd theweapon aroom)
$ insertAt j (crAdd aroom) $ insertAt j (crAdd aroom)
$ replicate (n-3) aroom $ replicate (n-3) aroom
return $ treeFromTrunk [PassDown $ rezBox thecol return $ treeFromTrunk [ rezBox thecol
, PassDown door , door
] ]
(Node (PassDown centralRoom) (rezrooms ++ [onwardpassage])) (Node ( centralRoom) (rezrooms ++ [onwardpassage]))
where where
adddoor rm = treeFromPost [PassDown $ door & rmConnectsTo .~ S.member (OnEdge North)] (PassDown rm) adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] ( rm)
crAdd :: Room -> Room crAdd :: Room -> Room
crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1 crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1
rezBoxes :: RandomGen g => State g (SubCompTree Room) rezBoxes :: RandomGen g => State g (Tree Room)
rezBoxes = do rezBoxes = do
w <- state $ randomR (100,400) w <- state $ randomR (100,400)
h <- state $ randomR (40,40) h <- state $ randomR (40,40)
thecol <- rezColor thecol <- rezColor
let bottomEdgeTest = S.member (OnEdge South) . _rlType let bottomEdgeTest = S.member (OnEdge South) . _rlType
dbox = treeFromPost [PassDown $ door & rmConnectsTo .~ S.member (OnEdge South)] dbox = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge South)]
(PassDown $ rezInvBox thecol) (rezInvBox thecol)
centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []} centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []}
& rmLinks %~ setInLinks bottomEdgeTest & rmLinks %~ setInLinks bottomEdgeTest
let n = length $ filter bottomEdgeTest $_rmLinks centralRoom let n = length $ filter bottomEdgeTest $_rmLinks centralRoom
return $ treeFromTrunk [PassDown $ rezBox thecol return $ treeFromTrunk [ rezBox thecol
, PassDown door , door
] ]
(Node (PassDown centralRoom) (replicate (n-1) dbox ++ [Node (UseAll door) []])) (Node ( centralRoom) (replicate (n-1) dbox ++ [Node (useAll door) []]))
rezColor :: RandomGen g => State g LightSource rezColor :: RandomGen g => State g LightSource
rezColor = do rezColor = do
src/Dodge/Room/RoadBlock.hs
+5 -4
View File
@@ -1,5 +1,6 @@
{- Connecting rooms designed with a pass-through technique in mind. -} {- Connecting rooms designed with a pass-through technique in mind. -}
module Dodge.Room.RoadBlock where module Dodge.Room.RoadBlock where
import Dodge.UseAll
import Dodge.Data import Dodge.Data
import Dodge.RoomLink import Dodge.RoomLink
import Geometry import Geometry
@@ -50,18 +51,18 @@ litCorridor90 = do
} }
-- | A random length corridor with a destructible block blocking it. -- | A random length corridor with a destructible block blocking it.
longBlockedCorridor :: RandomGen g => Int -> State g (SubCompTree Room) longBlockedCorridor :: RandomGen g => Int -> State g (Tree Room)
longBlockedCorridor maxn = do longBlockedCorridor maxn = do
r <- state $ randomR (0,pi) r <- state $ randomR (0,pi)
n <- state $ randomR (0,maxn) n <- state $ randomR (0,maxn)
let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10 let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10
,sPS (V2 20 15) 0 putLamp ,sPS (V2 20 15) 0 putLamp
] ]
sequence $ treeFromPost (replicate n $ PassDown <$> shuffleLinks corridor) sequence $ treeFromPost (replicate n $ shuffleLinks corridor)
$ return $ UseAll $ set rmPmnts plmnts corridor $ return $ useAll $ set rmPmnts plmnts corridor
-- | A single corridor with a destructible block blocking it. -- | A single corridor with a destructible block blocking it.
blockedCorridor :: RandomGen g => State g (SubCompTree Room) blockedCorridor :: RandomGen g => State g (Tree Room)
blockedCorridor = longBlockedCorridor 0 blockedCorridor = longBlockedCorridor 0
dirtPoly :: [Point2] -> PSType dirtPoly :: [Point2] -> PSType
src/Dodge/Room/Room.hs
+62 -60
View File
@@ -1,6 +1,7 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Dodge.Room.Room where module Dodge.Room.Room where
import Data.Tile import Data.Tile
import Dodge.UseAll
import Dodge.Data import Dodge.Data
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.RoomLink import Dodge.RoomLink
@@ -54,12 +55,12 @@ roomPadCut ps p = defaultRoom
, _rmPath = [(V2 0 0,p)] , _rmPath = [(V2 0 0,p)]
} }
branchWith :: Room -> [Tree Room] -> SubCompTree Room branchWith :: Room -> [Tree Room] -> Tree Room
branchWith r ts = Node (PassDown r) $ return (UseAll door) : fmap (fmap PassDown) ts branchWith r ts = Node r $ return (useAll door) : ts
manyDoors :: Int -> SubCompTree Room manyDoors :: Int -> Tree Room
manyDoors i = treeFromPost (replicate i (PassDown door)) $ UseAll door manyDoors i = treeFromPost (replicate i ( door)) $ useAll door
glassSwitchBack :: RandomGen g => State g Room glassSwitchBack :: RandomGen g => State g Room
glassSwitchBack = do glassSwitchBack = do
@@ -96,12 +97,12 @@ glassSwitchBackCrits = glassSwitchBack
, spNoID (PSRoomRand 1 (uncurry PS)) randC1 , spNoID (PSRoomRand 1 (uncurry PS)) randC1
] ++) ] ++)
miniTree2 :: RandomGen g => State g (SubCompTree Room) miniTree2 :: RandomGen g => State g (Tree Room)
miniTree2 = (glassSwitchBackCrits miniTree2 = (glassSwitchBackCrits
>>= randomiseAllLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70)) >>= randomiseAllLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70))
<&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd) <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)
miniRoom3 :: RandomGen g => State g (SubCompTree Room) miniRoom3 :: RandomGen g => State g (Tree Room)
miniRoom3 = do miniRoom3 = do
w <- state $ randomR (300,400) w <- state $ randomR (300,400)
h <- state $ randomR (300,400) h <- state $ randomR (300,400)
@@ -120,19 +121,19 @@ miniRoom3 = do
] ++ ] ++
[ sPS cp 0 $ PutCrit miniGunCrit [ sPS cp 0 $ PutCrit miniGunCrit
, sPS (V2 (w/2) (h/2)) 0 putLamp ] , sPS (V2 (w/2) (h/2)) 0 putLamp ]
fmap singleUseAll $ shuffleLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h fmap (pure . useAll) $ shuffleLinks $ set rmPmnts plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2 rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen) rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- So, the idea is to attach outer children to the bottommost right nodes -- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree -- inside an inner tree
roomMiniIntro :: RandomGen g => State g (LabSubCompTree Room) -- no idea what was going on here...
roomMiniIntro :: RandomGen g => State g (LabTree Room)
roomMiniIntro = do roomMiniIntro = do
midroom <- join $ takeOne [miniTree2] --,glassLesson] midroom <- join $ takeOne [miniTree2] --,glassLesson]
return (chainUses return ( toOnward "roomMiniIntro"
[return $ UseAll corridor,return $ UseAll corridor,return $ UseAll corridor,return $ UseAll door, midroom,return $ UseAll corridor] , midroom )
,TreeSubLabelling "roomMiniIntro" Nothing)
roomCenterPillar :: RandomGen g => State g Room roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) roomCenterPillar = shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst)
@@ -181,7 +182,7 @@ randFirstWeapon = do
++ replicate 5 (bangStick 4) ++ replicate 5 (bangStick 4)
++ replicate 5 (bangCaneX 3) ++ replicate 5 (bangCaneX 3)
weaponEmptyRoom :: RandomGen g => State g (SubCompTree Room) weaponEmptyRoom :: RandomGen g => State g (Tree Room)
weaponEmptyRoom = do weaponEmptyRoom = do
w <- state $ randomR (220,300) w <- state $ randomR (220,300)
h <- state $ randomR (220,300) h <- state $ randomR (220,300)
@@ -195,9 +196,9 @@ weaponEmptyRoom = do
f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30) f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30)
rm <- addHighGirder >=> shuffleLinks rm <- addHighGirder >=> shuffleLinks
$ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treeFromTrunk [PassDown corridor] (singleUseAll rm ) return $ treeFromTrunk [ corridor] (pure $ useAll rm )
weaponUnderCrits :: RandomGen g => Int -> State g (LabSubCompTree Room) weaponUnderCrits :: RandomGen g => Int -> State g (LabTree Room)
weaponUnderCrits i = do weaponUnderCrits i = do
let plmnts = let plmnts =
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon [--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
@@ -206,37 +207,37 @@ weaponUnderCrits i = do
] ]
addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon) addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon)
let continuationRoom = treeFromTrunk let continuationRoom = treeFromTrunk
[PassDown $ addwpat (V2 20 0) corridorN,PassDown $ addwpat (V2 20 0) corridorN] [ addwpat (V2 20 0) corridorN, addwpat (V2 20 0) corridorN]
(singleUseAll (set rmPmnts plmnts corridorN)) (pure $ useAll (set rmPmnts plmnts corridorN))
rcp <- roomCenterPillar rcp <- roomCenterPillar
rmpils <- roomPillars 30 240 240 2 2 rmpils <- roomPillars 30 240 240 2 2
deadEndRoom' <- takeOne deadEndRoom' <- takeOne
[ addwpat (V2 120 20) rmpils [ addwpat (V2 120 20) rmpils
, addwpat (V2 120 20) rcp] , addwpat (V2 120 20) rcp]
junctionRoom <- takeOne [PassDown tEast,PassDown tWest] junctionRoom <- takeOne [ tEast, tWest]
let thetree = treeFromTrunk let thetree = treeFromTrunk
--[PassDown $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp) --[ $ corridorN & rmPmnts .:~ mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
[PassDown corridorN [ corridorN
,PassDown corridorN] , corridorN]
$ Node junctionRoom $ Node junctionRoom
[continuationRoom [continuationRoom
,singleUseNone deadEndRoom' ,pure deadEndRoom'
] ]
return thetree return (toOnward "weaponUnderCrits" , thetree )
<&> (, TreeSubLabelling ("weaponUnderCrits "++show i) (Just $ fmap composingNodeName thetree)) -- TODO addSubmessages
composingNodeName :: ComposingNode Room -> TreeSubLabelling --composingNodeName :: ComposingNode Room -> TreeSubLabelling
composingNodeName cn = case cn of --composingNodeName cn = case cn of
PassDown rm -> f $ _rmName rm ++ "-PassDown" -- rm -> f $ _rmName rm ++ "-"
SplitDown rm -> f $ _rmName rm ++ "-SplitDown" -- SplitDown rm -> f $ _rmName rm ++ "-SplitDown"
UseAll rm -> f $ _rmName rm ++ "-UseAll" -- useAll rm -> f $ _rmName rm ++ "-useAll"
UseSome is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome" -- UseSome is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome"
UseNone rm -> f $ _rmName rm ++ "-UseNone" -- UseNone rm -> f $ _rmName rm ++ "-UseNone"
UseLabel i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-UseLabel" -- useLabel i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-useLabel"
where -- where
f str = TreeSubLabelling str Nothing -- f str = TreeSubLabelling str Nothing
weaponBehindPillar :: RandomGen g => State g (SubCompTree Room) weaponBehindPillar :: RandomGen g => State g (Tree Room)
weaponBehindPillar = do weaponBehindPillar = do
wpa <- state $ randomR (0,pi) wpa <- state $ randomR (0,pi)
wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35] wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35]
@@ -248,13 +249,13 @@ weaponBehindPillar = do
] ]
rcp <- roomCenterPillar rcp <- roomCenterPillar
return $ treeFromTrunk return $ treeFromTrunk
[PassDown corridor [ corridor
--,PassDown $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp --, $ over rmOutLinks tail $ over rmPmnts (++ plmnts1) rcp
,PassDown $ over rmPmnts (++ plmnts1) rcp , over rmPmnts (++ plmnts1) rcp
] ]
(singleUseAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN) (pure . useAll $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (SubCompTree Room) weaponBetweenPillars :: RandomGen g => State g (Tree Room)
weaponBetweenPillars = do weaponBetweenPillars = do
(w,wn) <- takeOne [(240,2),(340,3)] (w,wn) <- takeOne [(240,2),(340,3)]
(h,hn) <- takeOne [(240,2),(340,3)] (h,hn) <- takeOne [(240,2),(340,3)]
@@ -271,9 +272,9 @@ weaponBetweenPillars = do
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r) && all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
theRoom <- roomPillars 30 w h wn hn <&> rmPmnts .++~ theRoom <- roomPillars 30 w h wn hn <&> rmPmnts .++~
sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots
return $ singleUseAll theRoom return $ pure $ useAll theRoom
weaponLongCorridor :: RandomGen g => State g (SubCompTree Room) weaponLongCorridor :: RandomGen g => State g (Tree Room)
weaponLongCorridor = do weaponLongCorridor = do
rt <- takeOne [tEast, tWest] rt <- takeOne [tEast, tWest]
connectingRoom <- takeOne connectingRoom <- takeOne
@@ -281,9 +282,9 @@ weaponLongCorridor = do
] ]
i1 <- state $ randomR (2,5) i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5) i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 $ PassDown corridorN) (singleUseAll $ putCrs connectingRoom) let branch1 = treeFromTrunk (replicate i1 $ corridorN) (pure . useAll $ putCrs connectingRoom)
let branch2 = treeFromTrunk (replicate i2 $ PassDown corridorN) (singleUseNone $ putWp corridor) let branch2 = treeFromTrunk (replicate i2 $ corridorN) (pure . useSide $ putWp corridor)
return $ Node (PassDown rt) [branch1,branch2] return $ Node ( rt) [branch1,branch2]
where where
putCrs = over rmPmnts (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]) 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)] putWp = set rmPmnts [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
@@ -304,16 +305,16 @@ deadEndRoom = defaultRoom
where where
lnks = [(V2 0 30 ,0) ] lnks = [(V2 0 30 ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -} {- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room) weaponRoom :: RandomGen g => Int -> State g (LabTree Room)
weaponRoom i = join $ takeOne weaponRoom i = join $ takeOne
[ weaponEmptyRoom <&> (,f "weaponEmptyRoom") [ weaponEmptyRoom <&> (f "weaponEmptyRoom")
, weaponUnderCrits i , weaponUnderCrits i
, weaponBehindPillar<&> (,f "weaponBehindPillar") , weaponBehindPillar<&> (f "weaponBehindPillar")
, weaponBetweenPillars<&> (,f "weaponBetweenPillars") , weaponBetweenPillars<&> (f "weaponBetweenPillars")
, weaponLongCorridor<&> (,f "weaponLongCorridor") , weaponLongCorridor<&> (f "weaponLongCorridor")
] ]
where where
f str = TreeSubLabelling str Nothing f str = ( toOnward str ,)
roomCCrits :: RandomGen g => State g Room roomCCrits :: RandomGen g => State g Room
roomCCrits = roomC 200 200 roomCCrits = roomC 200 200
@@ -409,7 +410,7 @@ pistolerRoom = pillarGrid
] ]
++) ++)
shootingRange :: RandomGen g => State g (LabSubCompTree Room) shootingRange :: RandomGen g => State g (LabTree Room)
shootingRange = do shootingRange = do
rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40) rm1 <- shootersRoom1 >>= randomiseAllLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0) . restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
@@ -419,22 +420,23 @@ shootingRange = do
rm3 <- shootersRoom >>= randomiseAllLinks rm3 <- shootersRoom >>= randomiseAllLinks
. restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) . restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180)
. restrictOutLinks (\(_,r) -> r == 0) . restrictOutLinks (\(_,r) -> r == 0)
return (treeFromPost return ( toOnward "shootingRange"
[PassDown rm1 ,treeFromPost
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) [ rm1
, roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
,PassDown rm2 , rm2
,PassDown $ roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) , roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20)
& rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :) & rmPmnts %~ (spanLightI (V2 (-80) 10) (V2 80 10) :)
] ]
(UseAll rm3) (useAll rm3)
,TreeSubLabelling "shootingRange" Nothing) )
spawnerRoom :: RandomGen g => State g (SubCompTree Room) spawnerRoom :: RandomGen g => State g (Tree Room)
spawnerRoom = do spawnerRoom = do
x <- state $ randomR (250,300) x <- state $ randomR (250,300)
y <- state $ randomR (300,400) y <- state $ randomR (300,400)
roomWithSpawner <- roomC x y <&> roomWithSpawner <- roomC x y <&>
rmPmnts %~ (spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit spawnerCrit) :) rmPmnts %~ (spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit spawnerCrit) :)
aRoom <- airlock aRoom <- airlock
return $ treeFromTrunk [PassDown aRoom,PassDown corridor] $ singleUseAll roomWithSpawner return $ treeFromTrunk [ aRoom, corridor] $ pure $ useAll roomWithSpawner
src/Dodge/Room/RunPast.hs
+9 -8
View File
@@ -1,4 +1,5 @@
module Dodge.Room.RunPast where module Dodge.Room.RunPast where
import Dodge.UseAll
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LightSource import Dodge.LightSource
import Dodge.RoomLink import Dodge.RoomLink
@@ -41,7 +42,7 @@ roomCritLS = do
critRoom :: Room critRoom :: Room
critRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)] critRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)]
runPastRoom :: RandomGen g => Int -> State g (SubCompTree Room) runPastRoom :: RandomGen g => Int -> State g (Tree Room)
runPastRoom i = do runPastRoom i = do
h <- state $ randomR (200,400::Float) h <- state $ randomR (200,400::Float)
theedgetest <- takeOne [horEdgeTest (<1), horEdgeTest (>39)] theedgetest <- takeOne [horEdgeTest (<1), horEdgeTest (>39)]
@@ -59,10 +60,10 @@ runPastRoom i = do
} }
switchdoor = triggerDoorRoom i switchdoor = triggerDoorRoom i
n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks cenroom n = length $ filter theedgetest $ map lnkPosDir $ _rmLinks cenroom
controom = treeFromPost [PassDown switchdoor,PassDown linkcor] (UseAll door) controom = treeFromPost [ switchdoor, linkcor] (useAll door)
critrooms :: [SubCompTree Room] critrooms :: [Tree Room]
critrooms = treeFromPost [PassDown switchdoor] (PassDown critroom) : critrooms = treeFromPost [ switchdoor] ( critroom) :
replicate (n-2) (treeFromPost [PassDown switchdoor] (PassDown linkcor)) replicate (n-2) (treeFromPost [ switchdoor] ( linkcor))
return $ Node (PassDown cenroom) $ return $ Node ( cenroom) $
map (applyToCompRoot $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms) map (over root $ rmConnectsTo .~ S.member (OnEdge theedge)) (controom : critrooms)
++ [return $ PassDown aswitchroom] ++ [return $ aswitchroom]
src/Dodge/Room/SensorDoor.hs
+9 -8
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor where module Dodge.Room.SensorDoor where
import Dodge.UseAll
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.Placement.Instance.Terminal import Dodge.Placement.Instance.Terminal
@@ -35,12 +36,12 @@ import Data.Maybe
-- TODO fix case where the sensor created by sensInsideDoor blocks another door -- TODO fix case where the sensor created by sensInsideDoor blocks another door
-- for roomRectAutoLinks-- make the locked door a center door? -- for roomRectAutoLinks-- make the locked door a center door?
sensorRoom :: RandomGen g => DamageType -> Int -> State g (SubCompTree Room) sensorRoom :: RandomGen g => DamageType -> Int -> State g (Tree Room)
sensorRoom senseType n = do sensorRoom senseType n = do
rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200] rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
cenroom <- shuffleLinks $ sensInsideDoor senseType n rm cenroom <- shuffleLinks $ sensInsideDoor senseType n rm
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
return $ treeFromPost [PassDown door,PassDown $ cenroom & rmLinkEff .~ f,PassDown doorroom] (UseAll door) return $ treeFromPost [ door, cenroom & rmLinkEff .~ f, doorroom] (useAll door)
where where
f _ _ 0 rl rm = rm & rmLinks %~ map (g (_rlPos rl) (_rlDir rl)) f _ _ 0 rl rm = rm & rmLinks %~ map (g (_rlPos rl) (_rlDir rl))
f _ _ _ _ rm = rm f _ _ _ _ rm = rm
@@ -51,18 +52,18 @@ sensorRoom senseType n = do
p' = p +.+ rotateV d (V2 0 (negate 100)) p' = p +.+ rotateV d (V2 0 (negate 100))
isclose = dist (_rlPos rl) p' < 30 isclose = dist (_rlPos rl) p' < 30
sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabSubCompTree Room) sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g (LabTree Room)
sensorRoomRunPast dt n = do sensorRoomRunPast dt n = do
t <- sensorRoom dt n t <- sensorRoom dt n
return (applyToSubforest [0] (++ return ( toOnward "sensorRoomRunPast"
, applyToSubforest [0] (++
[treeFromPost [treeFromPost
[PassDown $ door & rmConnectsTo [ door & rmConnectsTo
.~ (\s -> S.member InLink s && not (S.member BlockedLink s)) .~ (\s -> S.member InLink s && not (S.member BlockedLink s))
] (UseLabel 0 corridor) ] (useLabel 0 corridor)
] ]
) t ) t
,TreeSubLabelling "sensorRoomRunPast" Nothing) )--[return $ useLabel 0 $ door & rmConnectsTo .~ S.member InLink]
--[return $ UseLabel 0 $ door & rmConnectsTo .~ S.member InLink]
sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement
sensAboveDoor sensetype wth ps = extTrigLitPos sensAboveDoor sensetype wth ps = extTrigLitPos
src/Dodge/Room/Start.hs
+32 -30
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Dodge.Room.Start where module Dodge.Room.Start where
import Dodge.UseAll
import Dodge.Data import Dodge.Data
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
--import Dodge.PlacementSpot --import Dodge.PlacementSpot
@@ -29,7 +30,7 @@ import LensHelp
--import Data.Tree --import Data.Tree
--import qualified Data.IntMap.Strict as IM --import qualified Data.IntMap.Strict as IM
powerFakeout :: RandomGen g => State g (SubCompTree Room) powerFakeout :: RandomGen g => State g (Tree Room)
powerFakeout = do powerFakeout = do
ncor <- state $ randomR (0,2) ncor <- state $ randomR (0,2)
it <- takeOne it <- takeOne
@@ -37,71 +38,72 @@ powerFakeout = do
,launcherX 7 ,launcherX 7
] ]
roomwithmini <- pedestalRoom it roomwithmini <- pedestalRoom it
randcors <- replicateM ncor $ (fmap PassDown . shuffleLinks) corridor randcors <- replicateM ncor $ shuffleLinks corridor
return $ ([PassDown door return $ ([ door
,PassDown roomwithmini , roomwithmini
,PassDown door , door
] ]
++ randcors ++ randcors
++ [PassDown $ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun) ++ [ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun)
,PassDown keyholeCorridor,PassDown corridor]) , keyholeCorridor, corridor])
`treeFromPost` UseAll door `treeFromPost` useAll door
startRoom :: RandomGen g => Int -> State g (LabSubCompTree Room) startRoom :: RandomGen g => Int -> State g (LabTree Room)
startRoom i = join (uncurry takeOneWeighted $ unzip startRoom i = join (uncurry takeOneWeighted $ unzip
[ (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i]) [-- (,) (0.5::Float) ((chainUses <$> sequence [powerFakeout,fmap fst $weaponRoom i])
<&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing)) -- <&> (,TreeSubLabelling "chainUses <$> sequence [powerFakeout,weaponRoom i]" Nothing))
, (,) one (rezBoxesWp <&> (,TreeSubLabelling "rezBoxesWp" Nothing)) -- wat
(,) one (rezBoxesWp <&> (toOnward "rezBoxesWp",))
, (,) one (rezBoxThenWeaponRoom i) , (,) one (rezBoxThenWeaponRoom i)
, (,) one (rezBoxesWpCrit <&> (,TreeSubLabelling "rezBoxesWpCrit" Nothing)) , (,) one (rezBoxesWpCrit <&> (toOnward "rezBoxesWpCrit"))
, (,) one (runPastStart i <&> (,TreeSubLabelling ("runPastStart " ++ show i) Nothing)) , (,) one (runPastStart i <&> (toOnward ("runPastStart " ++ show i)))
, (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&> , (,) one (startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms <&>
(,TreeSubLabelling "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" Nothing)) (toOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"))
]) ])
<&> over (_2 . topLabel) ("startRoom:"++) <&> over (_2 . topLabel) ("startRoom:"++)
where where
roomsContaining' a b = fst <$> roomsContaining a b roomsContaining' a b = fst <$> roomsContaining a b
one = 1::Float one = 1::Float
randomChallenges :: RandomGen g => State g (LabSubCompTree Room) randomChallenges :: RandomGen g => State g (LabTree Room)
randomChallenges = join (takeOne randomChallenges = join (takeOne
[fmap (return . UseAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing) [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
,shootingRange ,shootingRange
,fmap (return . UseAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing) ,fmap (return . useAll) twinSlowDoorChasers <&> (,TreeSubLabelling "twinSlowDoorChasers" Nothing)
]) <&> over (_2 . topLabel) ("randomChallenges:"++) ]) <&> over (_2 . topLabel) ("randomChallenges:"++)
runPastStart :: RandomGen g => Int -> State g (SubCompTree Room) runPastStart :: RandomGen g => Int -> State g (Tree Room)
runPastStart i = do runPastStart i = do
s <- rezBoxStart s <- rezBoxStart
rp <- runPastRoom i rp <- runPastRoom i
return $ s `passUntilUseAll` [rp] return $ s `passUntiluseAll` [rp]
rezBoxStart :: RandomGen g => State g (SubCompTree Room) rezBoxStart :: RandomGen g => State g (Tree Room)
rezBoxStart = do rezBoxStart = do
ls <- rezColor ls <- rezColor
return $ treeFromPost [PassDown $ rezBox ls] (UseAll door) return $ treeFromPost [ rezBox ls] (useAll door)
rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (SubCompTree Room,String) rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (Tree Room,String)
rezBoxesThenWeaponRoom i = do rezBoxesThenWeaponRoom i = do
rboxes <- rezBoxes rboxes <- rezBoxes
wroom <- fst <$> weaponRoom i wroom <- fst <$> weaponRoom i
return (rboxes `passUntilUseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i) return (rboxes `passUntiluseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabSubCompTree Room) rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (LabTree Room)
rezBoxThenWeaponRoom i = do rezBoxThenWeaponRoom i = do
rcol <- rezColor rcol <- rezColor
(wroom,wroomname) <- weaponRoom i (wroom,wroomname) <- weaponRoom i
return (treeFromTrunk [PassDown $ rezBox rcol,PassDown door] wroom return (treeFromTrunk [ rezBox rcol, door] wroom
, TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname)) , TreeSubLabelling ("rezBoxThenWeaponRoom "++ show i) (Just $ return wroomname))
rezBoxThenRoom :: RandomGen g => Room -> State g (SubCompTree Room) rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
rezBoxThenRoom r = do rezBoxThenRoom r = do
rcol <- rezColor rcol <- rezColor
return $ treeFromTrunk [PassDown $ rezBox rcol,PassDown door] $ singleUseAll r return $ treeFromTrunk [ rezBox rcol, door] $ pure r
rezBoxThenRooms :: RandomGen g => SubCompTree Room -> State g (SubCompTree Room) rezBoxThenRooms :: RandomGen g => Tree Room -> State g (Tree Room)
rezBoxThenRooms r = do rezBoxThenRooms r = do
rcol <- rezColor rcol <- rezColor
return . treeFromTrunk [PassDown $ rezBox rcol,PassDown door] $ r return . treeFromTrunk [ rezBox rcol, door] $ r
startCrafts :: RandomGen g => State g [Item] startCrafts :: RandomGen g => State g [Item]
startCrafts = takeOne $ map (map makeTypeCraft) startCrafts = takeOne $ map (map makeTypeCraft)
src/Dodge/Room/Warning.hs
+4 -3
View File
@@ -36,13 +36,14 @@ import qualified Data.Map.Strict as M
--import qualified Data.Text as T --import qualified Data.Text as T
warningRooms :: RandomGen g => Int -> State g (LabSubCompTree Room) warningRooms :: RandomGen g => Int -> State g (LabTree Room)
warningRooms n = do warningRooms n = do
rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200] rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
cenroom <- shuffleLinks $ addWarningTerminal n rm cenroom <- shuffleLinks $ addWarningTerminal n rm
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) return ( toOnward "warningRooms"
, TreeSubLabelling "warningRooms" Nothing) , treeFromPost [ door, cenroom, doorroom] (useAll door)
)
addWarningTerminal :: Int -> Room -> Room addWarningTerminal :: Int -> Room -> Room
addWarningTerminal outplid = (rmName .++~ "warningTerm-") addWarningTerminal outplid = (rmName .++~ "warningTerm-")
src/Dodge/Tree/Compose.hs
+25 -25
View File
@@ -2,12 +2,12 @@
{-| Combining and composing trees of trees. -} {-| Combining and composing trees of trees. -}
module Dodge.Tree.Compose module Dodge.Tree.Compose
( --expandTree ( --expandTree
--, singleUseAll --, pure
--, singleUseNone --, pure
--, passUntilUseAll --, passUntiluseAll
--, chainUses --, chainUses
--, useAllAtEnd --, useAllAtEnd
--, changeToPassDown --, changeTo
--, overwriteLabel --, overwriteLabel
--, applyToCompRoot --, applyToCompRoot
composeTree composeTree
@@ -28,47 +28,47 @@ import Data.Maybe
--expandTree :: CompTree a -> Tree a --expandTree :: CompTree a -> Tree a
--expandTree (Node rt extChildren) = case rt of --expandTree (Node rt extChildren) = case rt of
-- Node (UseAll x) _ -> Node x (map expandTree extChildren) -- Node (useAll x) _ -> Node x (map expandTree extChildren)
-- Node (UseSome is x) _ -> Node x (map (expandTree . \i -> extChildren !! i) is) -- Node (UseSome is x) _ -> Node x (map (expandTree . \i -> extChildren !! i) is)
-- Node (UseNone _) _ -> fmap _unCompose rt -- Node (UseNone _) _ -> fmap _unCompose rt
-- Node (UseLabel _ _) _ -> fmap _unCompose rt -- Node (useLabel _ _) _ -> fmap _unCompose rt
-- Node (PassDown x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs -- Node ( x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs
-- Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs -- Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs
-- $ map (:[]) extChildren ++ repeat [] -- $ map (:[]) extChildren ++ repeat []
--applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a --applyToCompRoot :: (a -> a) -> Tree a -> Tree a
--applyToCompRoot f = over root (unCompose %~ f) --applyToCompRoot f = over root (unCompose %~ f)
--overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a --overwriteLabel :: Int -> (a -> ComposingNode a) -> Tree a -> [Tree a] -> Tree a
--overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i) --overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i)
-- $ updateSingleNodes islabel update t -- $ updateSingleNodes islabel update t
-- where -- where
-- islabel (UseLabel j _) | i == j = True -- islabel (useLabel j _) | i == j = True
-- islabel _ = False -- islabel _ = False
-- update (Node x _) = Node (f $ _unCompose x) ts -- update (Node x _) = Node (f $ _unCompose x) ts
--passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a --passUntiluseAll :: Tree a -> [Tree a] -> Tree a
--passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts' --passUntiluseAll (Node (useAll x) _) ts' = Node ( x) ts'
--passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts --passUntiluseAll (Node cn ts) ts' = Node ( (_unCompose cn)) $ map (`passUntiluseAll` ts') ts
--chainUses :: [SubCompTree a] -> SubCompTree a --chainUses :: [Tree a] -> Tree a
--chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts) --chainUses (t:s:ts) = chainUses (passUntiluseAll t [s]:ts)
--chainUses [t] = t --chainUses [t] = t
--chainUses [] = error "tried to concatenate an empty list of SubCompTrees" --chainUses [] = error "tried to concatenate an empty list of Trees"
--singleUseAll :: a -> Tree (ComposingNode a) --pure :: a -> Tree (ComposingNode a)
--singleUseAll x = Node (UseAll x) [] --pure x = Node (useAll x) []
--useAllAtEnd :: Tree a -> SubCompTree a --useAllAtEnd :: Tree a -> Tree a
--useAllAtEnd tree = case tree of --useAllAtEnd tree = case tree of
-- Node x (t:ts) -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts) -- Node x (t:ts) -> Node ( x) (useAllAtEnd t : map (fmap UseNone) ts)
-- Node x [] -> Node (UseAll x) [] -- Node x [] -> Node (useAll x) []
--singleUseNone :: a -> SubCompTree a --pure :: a -> Tree a
--singleUseNone x = Node (UseNone x) [] --pure x = Node (UseNone x) []
--changeToPassDown :: ComposingNode a -> ComposingNode a --changeTo :: ComposingNode a -> ComposingNode a
--changeToPassDown x = PassDown (_unCompose x) --changeTo x = (_unCompose x)
composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a) composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
composeTreeRand (Node (_,t) ts) = attachListR t ts composeTreeRand (Node (_,t) ts) = attachListR t ts
src/Dodge/Tree/Compose/Data.hs
+5 -7
View File
@@ -4,16 +4,14 @@ module Dodge.Tree.Compose.Data where
import Data.Tree import Data.Tree
import Control.Lens import Control.Lens
data ComposingNode a data ComposingNode a
= PassDown {_unCompose :: a} = SplitDown {_unCompose :: a}
| SplitDown {_unCompose :: a} -- | useAll {_unCompose :: a}
| UseAll {_unCompose :: a}
| UseSome {_composeIndices :: [Int], _unCompose :: a} | UseSome {_composeIndices :: [Int], _unCompose :: a}
| UseNone {_unCompose :: a} | UseNone {_unCompose :: a}
| UseLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children -- | useLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
type SubCompTree a = Tree a
type CompTree a = Tree (Tree a) type CompTree a = Tree (Tree a)
type LabSubCompTree a = (a -> Maybe ([String],a),Tree a) type LabTree a = (a -> Maybe ([String],a),Tree a)
type LabCompTree a = Tree (LabSubCompTree a) type LabCompTree a = Tree (LabTree a)
data TreeSubLabelling = TreeSubLabelling data TreeSubLabelling = TreeSubLabelling
{ _topLabel :: String { _topLabel :: String
, _subLabels :: Maybe (Tree TreeSubLabelling) , _subLabels :: Maybe (Tree TreeSubLabelling)