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

Polymorphise meta tree labels

Browse Source
This commit is contained in:
justin
2022-06-13 15:22:15 +01:00
parent 31e7f4290e
commit 7a07fc97c2
19 changed files with 67 additions and 97 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Annotation.hs
+2 -2
View File
@@ -14,7 +14,7 @@ import LensHelp
--import Control.Lens --import Control.Lens
import Data.Maybe import Data.Maybe
annoToRoomTree :: Annotation -> State (StdGen,Int) (MetaTree Room) annoToRoomTree :: Annotation -> State (StdGen,Int) MTRS
annoToRoomTree an = case an of annoToRoomTree an = case an of
SpecificRoom r -> zoom _1 r SpecificRoom r -> zoom _1 r
OnwardList ans -> do OnwardList ans -> do
@@ -31,6 +31,6 @@ annoToRoomTree an = case an of
ii <- randomitemidentity ii <- randomitemidentity
keyroom <- fromJust $ lookup ii ks keyroom <- fromJust $ lookup ii ks
return $ MTree ("PassthroughLockKeyLists-"++show ii) return $ MTree ("PassthroughLockKeyLists-"++show ii)
(NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch "" (toLabel i) keyroom]) (NodeMTree $ MTree "RassThroughLockKeyLists" (NodeMTree lr) [MBranch (toLabel i) keyroom])
[] []
src/Dodge/Annotation/Data.hs
+7 -4
View File
@@ -9,14 +9,17 @@ import Dodge.Tree.Compose.Data
import Control.Monad.State import Control.Monad.State
import Control.Lens import Control.Lens
import System.Random import System.Random
type MTRS = MetaTree Room String
data Annotation data Annotation
= ModifyTree (MetaTree Room -> MetaTree Room) Annotation = ModifyTree (MetaTree Room String -> MetaTree Room String) Annotation
| OnwardList [Annotation] | OnwardList [Annotation]
| IntAnno (Int -> Annotation) | IntAnno (Int -> Annotation)
| SpecificRoom (State StdGen (MetaTree Room)) | SpecificRoom (State StdGen (MetaTree Room String))
| PassthroughLockKeyLists | PassthroughLockKeyLists
[(Int -> State StdGen (MetaTree Room), State StdGen ItemBaseType)] [(Int -> State StdGen (MetaTree Room String), State StdGen ItemBaseType)]
[(ItemBaseType, State StdGen (MetaTree Room))] [(ItemBaseType, State StdGen (MetaTree Room String))]
Int Int
makeLenses ''Annotation makeLenses ''Annotation
src/Dodge/Floor.hs
+3 -3
View File
@@ -38,7 +38,7 @@ import Data.List (intersperse)
initialAnoTree :: Annotation initialAnoTree :: Annotation
initialAnoTree = OnwardList initialAnoTree = OnwardList
$ intersperse (SpecificRoom $ tToBTree . pure <$> shuffleLinks (cleatOnward corridor)) $ intersperse (SpecificRoom $ tToBTree "cori" . pure <$> shuffleLinks (cleatOnward corridor))
[ IntAnno $ SpecificRoom . startRoom [ IntAnno $ SpecificRoom . startRoom
-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) -- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
, IntAnno $ PassthroughLockKeyLists , IntAnno $ PassthroughLockKeyLists
@@ -50,7 +50,7 @@ initialAnoTree = OnwardList
[ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
, spNoID anyUnusedSpot (PutCrit armourChaseCrit) , spNoID anyUnusedSpot (PutCrit armourChaseCrit)
] ]
, IntAnno $ SpecificRoom . fmap tToBTree . healthTest , IntAnno $ SpecificRoom . fmap (tToBTree "healthTest") . healthTest
, SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
, IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms
, SpecificRoom randomChallenges , SpecificRoom randomChallenges
@@ -100,5 +100,5 @@ initialAnoTree = OnwardList
] ]
{- | A test level tree. -} {- | A test level tree. -}
initialRoomTree :: State (StdGen,Int) (MetaTree Room) initialRoomTree :: State (StdGen,Int) (MetaTree Room String)
initialRoomTree = annoToRoomTree initialAnoTree initialRoomTree = annoToRoomTree initialAnoTree
src/Dodge/LevelGen.hs
-10
View File
@@ -42,9 +42,6 @@ layoutLevelFromSeed i seed = do
----appendFile "log/TreeCluster" ("Seed: "++ show seed) ----appendFile "log/TreeCluster" ("Seed: "++ show seed)
----mapM_ (appendFile "log/treeCluster" . ('\n':)) strs ----mapM_ (appendFile "log/treeCluster" . ('\n':)) strs
----mapM_ putStrLn strs ----mapM_ putStrLn strs
--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 "Room layout (compact): "
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
@@ -66,13 +63,6 @@ layoutLevelFromSeed i seed = do
let (seed',_) = random g let (seed',_) = random g
layoutLevelFromSeed i' seed' layoutLevelFromSeed i' seed'
drawTreeSubLabelling :: Tree TreeSubLabelling -> String
drawTreeSubLabelling t = drawTree (fmap _topLabel t)
++ concatMap f (flatten t)
where
f (TreeSubLabelling _ Nothing) = ""
f (TreeSubLabelling l (Just t')) = l ++ ":\n" ++ drawTreeSubLabelling t'
reversePair :: (a,b) -> (b,a) reversePair :: (a,b) -> (b,a)
reversePair (a,b) = (b,a) reversePair (a,b) = (b,a)
src/Dodge/LockAndKey.hs
+5 -5
View File
@@ -17,7 +17,7 @@ import Dodge.Item
bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ] bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ]
bossKeyItems = [(return . cleatOnward <$> bossRoom autoCrit, takeOne [PISTOL]) ] bossKeyItems = [(return . cleatOnward <$> bossRoom autoCrit, takeOne [PISTOL]) ]
lockRoomMultiItems :: RandomGen g => [ ( State g (MetaTree Room) , State g [ItemBaseType] ) ] lockRoomMultiItems :: RandomGen g => [ ( State g (MetaTree Room String) , State g [ItemBaseType] ) ]
lockRoomMultiItems = lockRoomMultiItems =
[ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR] [ (blinkAcrossChallenge, takeOne [[BLINKERUNSAFE,AUTODETECTOR WALLDETECTOR]
,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR] ,[BLINKERUNSAFE,CLICKDETECTOR WALLDETECTOR]
@@ -25,7 +25,7 @@ lockRoomMultiItems =
) )
] ]
lockRoomKeyItems :: RandomGen g => [ (Int -> State g (MetaTree Room) , State g ItemBaseType ) ] lockRoomKeyItems :: RandomGen g => [ (Int -> State g (MetaTree Room String) , 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] )
@@ -37,10 +37,10 @@ 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 (MetaTree Room) , State g ItemBaseType ) ] keyCardRunPastRand :: RandomGen g => [ (Int -> State g (MetaTree Room String) , State g ItemBaseType ) ]
keyCardRunPastRand = [(keyCardRoomRunPast 0, return (KEYCARD 0)) ] keyCardRunPastRand = [(keyCardRoomRunPast 0, return (KEYCARD 0)) ]
itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room))] itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room String))]
itemRooms = itemRooms =
[ (LAUNCHER , join $ takeOne [ (LAUNCHER , join $ takeOne
[corridorBoss launcherCrit [corridorBoss launcherCrit
@@ -108,7 +108,7 @@ someCrits = do
-- return $ roomsContaining crits its -- return $ roomsContaining crits its
corridorBoss :: RandomGen g => Creature -> State g (MetaTree Room) corridorBoss :: RandomGen g => Creature -> State g (MetaTree Room String)
corridorBoss cr = do corridorBoss cr = do
endroom <- bossRoom cr endroom <- bossRoom cr
rToOnward ("corridorBoss-"++_crName cr) rToOnward ("corridorBoss-"++_crName cr)
src/Dodge/Room/BlinkAcross.hs
+1 -1
View File
@@ -34,7 +34,7 @@ import LensHelp
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room) blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room String)
blinkAcrossChallenge = do blinkAcrossChallenge = do
teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200 teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200
teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200 teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200
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 (MetaTree Room) roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String)
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
+2 -1
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.GlassLesson where module Dodge.Room.GlassLesson where
import Dodge.UseAll import Dodge.UseAll
import Dodge.Annotation.Data
import Dodge.RoomLink import Dodge.RoomLink
import Dodge.Creature import Dodge.Creature
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
@@ -53,7 +54,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 (MetaTree Room) glassLessonRunPast :: RandomGen g => State g MTRS
glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f
where where
f (Node r rs) = Node r $ return (cleatLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs f (Node r rs) = Node r $ return (cleatLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs
src/Dodge/Room/LasTurret.hs
+4 -4
View File
@@ -71,7 +71,7 @@ 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 (MetaTree Room) keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room String)
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
@@ -114,13 +114,13 @@ healthTest n = do
, cleatOnward door , cleatOnward door
] ]
lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room) lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room String)
lasSensorTurretTest n = do lasSensorTurretTest n = do
cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur
rToOnward "lasSensorTurretTest" $ treePost rToOnward "lasSensorTurretTest" $ treePost
[ door, cenroom, triggerDoorRoom n, cleatOnward door] [ door, cenroom, triggerDoorRoom n, cleatOnward door]
lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room) lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room String)
lasCenSensEdge n = do lasCenSensEdge n = do
cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur
let doorroom = triggerDoorRoom n let doorroom = triggerDoorRoom n
@@ -165,7 +165,7 @@ 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 (MetaTree Room) lasTunnelRunPast :: RandomGen g => Float -> State g (MetaTree Room String)
lasTunnelRunPast y = do lasTunnelRunPast y = do
r <- lasTunnel y r <- lasTunnel y
r1 <- takeOne [door,corridor] r1 <- takeOne [door,corridor]
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -140,7 +140,7 @@ 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 (MetaTree Room) slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room String)
slowDoorRoomRunPast = do slowDoorRoomRunPast = do
r <- slowDoorRoom r <- slowDoorRoom
rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r
src/Dodge/Room/LongRoom.hs
+1 -1
View File
@@ -47,7 +47,7 @@ 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 (MetaTree Room) longRoomRunPast :: RandomGen g => State g (MetaTree Room String)
longRoomRunPast = do longRoomRunPast = do
r <- longRoom r <- longRoom
rToOnward "longRoomRunPast" rToOnward "longRoomRunPast"
src/Dodge/Room/Room.hs
+4 -4
View File
@@ -123,7 +123,7 @@ 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
-- no idea what was going on here... -- no idea what was going on here...
roomMiniIntro :: RandomGen g => State g (MetaTree Room) roomMiniIntro :: RandomGen g => State g (MetaTree Room String)
roomMiniIntro = do roomMiniIntro = do
midroom <- join $ takeOne [miniTree2] --,glassLesson] midroom <- join $ takeOne [miniTree2] --,glassLesson]
rToOnward "roomMiniIntro" midroom rToOnward "roomMiniIntro" midroom
@@ -191,7 +191,7 @@ weaponEmptyRoom = do
$ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm ) return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm )
weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room) weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
weaponUnderCrits i = do weaponUnderCrits i = do
let plmnts = let plmnts =
[--sPS (V2 20 0) 0 $ RandPS randFirstWeapon [--sPS (V2 20 0) 0 $ RandPS randFirstWeapon
@@ -278,7 +278,7 @@ 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 (MetaTree Room) weaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
weaponRoom i = join $ takeOne weaponRoom i = join $ takeOne
[ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom" [ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom"
, weaponUnderCrits i , weaponUnderCrits i
@@ -381,7 +381,7 @@ pistolerRoom = pillarGrid
] ]
++) ++)
shootingRange :: RandomGen g => State g (MetaTree Room) shootingRange :: RandomGen g => State g (MetaTree Room String)
shootingRange = do shootingRange = do
rm1 <- shootersRoom1 >>= shuffleLinks . restrictInLinks (\(V2 _ y,_) -> y < 40) rm1 <- shootersRoom1 >>= shuffleLinks . restrictInLinks (\(V2 _ y,_) -> y < 40)
. restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0) . restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0)
src/Dodge/Room/SensorDoor.hs
+2 -1
View File
@@ -1,5 +1,6 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.SensorDoor where module Dodge.Room.SensorDoor where
import Dodge.Annotation.Data
import Dodge.UseAll import Dodge.UseAll
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.PlacementSpot import Dodge.PlacementSpot
@@ -56,7 +57,7 @@ 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 (MetaTree Room) sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g MTRS
sensorRoomRunPast dt n = do sensorRoomRunPast dt n = do
t <- sensorRoom dt n t <- sensorRoom dt n
rToOnward "sensorRoomRunPast" $ t & applyToSubforest [0] rToOnward "sensorRoomRunPast" $ t & applyToSubforest [0]
src/Dodge/Room/Start.hs
+6 -6
View File
@@ -48,7 +48,7 @@ powerFakeout = do
, keyholeCorridor, corridor]) , keyholeCorridor, corridor])
`treeFromPost` cleatOnward door `treeFromPost` cleatOnward door
startRoom :: RandomGen g => Int -> State g (MetaTree Room) startRoom :: RandomGen g => Int -> State g (MetaTree Room String)
startRoom i = join (takeOne startRoom i = join (takeOne
[-- (,) (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))
@@ -60,7 +60,7 @@ startRoom i = join (takeOne
-- , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms -- , startCrafts >>= roomsContaining' [] >>= rezBoxThenRooms
-- >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms" -- >>= rToOnward "startCrafts >>= roomsContaining [] >>= rezBoxThenRooms"
]) ])
randomChallenges :: RandomGen g => State g (MetaTree Room) randomChallenges :: RandomGen g => State g (MetaTree Room String)
randomChallenges = shootingRange randomChallenges = shootingRange
-- join (takeOne -- join (takeOne
-- [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing) -- [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing)
@@ -80,17 +80,17 @@ rezBoxStart = do
ls <- rezColor ls <- rezColor
return $ treePost [ rezBox ls, cleatOnward door ] return $ treePost [ rezBox ls, cleatOnward door ]
rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
rezBoxesThenWeaponRoom i = do rezBoxesThenWeaponRoom i = do
rboxes <- rezBoxes rboxes <- rezBoxes
wroom <- weaponRoom i wroom <- weaponRoom i
return $ tToBTree rboxes `attachOnward` wroom return $ tToBTree "rboxes" rboxes `attachOnward` wroom
rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room) rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room String)
rezBoxThenWeaponRoom i = do rezBoxThenWeaponRoom i = do
rcol <- rezColor rcol <- rezColor
wroom <- weaponRoom i wroom <- weaponRoom i
return $ tToBTree (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom return $ tToBTree "rezbox" (treePost [rezBox rcol, cleatOnward door]) `attachOnward` wroom
rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room) rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
rezBoxThenRoom r = do rezBoxThenRoom r = do
src/Dodge/Room/Warning.hs
+1 -1
View File
@@ -37,7 +37,7 @@ 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 (MetaTree Room) warningRooms :: RandomGen g => Int -> State g (MetaTree Room String)
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
src/Dodge/Tree/Compose.hs
+13 -25
View File
@@ -22,25 +22,12 @@ import TreeHelp
--import Dodge.Base --import Dodge.Base
import LensHelp import LensHelp
import Data.Bifunctor --import Data.Bifunctor
import Control.Monad.State --import Control.Monad.State
import Data.Foldable --import Data.Foldable
import System.Random --import System.Random
import Data.Maybe import Data.Maybe
--expandTree :: CompTree a -> Tree a
--expandTree (Node rt extChildren) = case rt of
-- Node (useAll x) _ -> Node x (map expandTree extChildren)
-- Node (UseSome is x) _ -> Node x (map (expandTree . \i -> extChildren !! i) is)
-- Node (UseNone _) _ -> fmap _unCompose rt
-- Node (useLabel _ _) _ -> fmap _unCompose rt
-- Node ( x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs
-- Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs
-- $ map (:[]) extChildren ++ repeat []
--applyToCompRoot :: (a -> a) -> Tree a -> Tree a
--applyToCompRoot f = over root (unCompose %~ f)
overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
overwriteLabel i t ts = safeUpdateSingleNode overwriteLabel i t ts = safeUpdateSingleNode
(\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks)) (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
@@ -186,17 +173,17 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
-- brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt -- brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
-- return $ Node (_btValue mt) brs -- return $ Node (_btValue mt) brs
composeTree :: MetaTree a -> Tree a composeTree :: MetaTree a b -> Tree a
composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt) composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
composeNode :: MetaNode a -> Tree a composeNode :: MetaNode a b -> Tree a
composeNode (NodeTree t) = t composeNode (NodeTree t) = t
composeNode (NodeMTree mt) = composeTree mt composeNode (NodeMTree mt) = composeTree mt
attachList' :: Tree a -> [MetaBranch a] -> Tree a attachList' :: Tree a -> [MetaBranch a b] -> Tree a
attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
attachBranch :: MetaBranch a -> Tree ([Tree a],a) -> Tree ([Tree a],a) attachBranch :: MetaBranch a b -> Tree ([Tree a],a) -> Tree ([Tree a],a)
attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) ) ( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) )
where where
@@ -204,14 +191,15 @@ attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
g x = fromMaybe x (upf x) g x = fromMaybe x (upf x)
tToBTree :: Tree Room -> MetaTree Room tToBTree :: String -> Tree Room -> MetaTree Room String
tToBTree t = MTree "" (NodeTree t) [] tToBTree str t = MTree str (NodeTree t) []
attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room attachOnward :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
attachOnward t1 t2 = t1 & mtBranches .:~ MBranch "Onward" toOnward t2 attachOnward t1 t2 = t1 & mtBranches .:~ MBranch toOnward t2
toOnward :: Room -> Maybe Room toOnward :: Room -> Maybe Room
toOnward rm toOnward rm
| OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks
= Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
| otherwise = Nothing | otherwise = Nothing
src/Dodge/Tree/Compose/Data.hs
+4 -15
View File
@@ -4,23 +4,12 @@ module Dodge.Tree.Compose.Data where
import Data.Tree import Data.Tree
import Control.Lens import Control.Lens
data MetaBranch a
= MBranch {_mbLabel :: String, _mbAttach :: a -> Maybe a, _mbTree :: MetaTree a}
data MetaTree a --data MetaTree a = MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] }
= MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] } data MetaTree a b = MTree {_mtLabel :: b , _mtTree :: MetaNode a b, _mtBranches :: [MetaBranch a b] }
-- | BTree {_btLabel :: String , _btValue :: a , _btBranches :: [MetaTree a] } data MetaNode a b = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a b}
data MetaNode a = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a} data MetaBranch a b = MBranch {_mbAttach :: a -> Maybe a, _mbTree :: MetaTree a b}
--type CompTree a = Tree (Tree a)
type LabTree a = (a -> Maybe ([String],a),Tree a)
type LabCompTree a = Tree (LabTree a)
data TreeSubLabelling = TreeSubLabelling
{ _topLabel :: String
, _subLabels :: Maybe (Tree TreeSubLabelling)
}
makeLenses ''TreeSubLabelling
makeLenses ''MetaTree makeLenses ''MetaTree
makeLenses ''MetaBranch makeLenses ''MetaBranch
makeLenses ''MetaNode makeLenses ''MetaNode
src/Dodge/UseAll.hs
+2 -2
View File
@@ -18,8 +18,8 @@ toLabel i rm
| LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just rm | LabelCluster i `elem` rm ^?! rmClusterStatus . csLinks = Just rm
| otherwise = Nothing | otherwise = Nothing
rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room) rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room String)
rToOnward s t = return $ tToBTree t & mtLabel .~ s rToOnward s t = return $ tToBTree s t
cleatOnward :: Room -> Room cleatOnward :: Room -> Room
cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster cleatOnward = rmClusterStatus . csLinks .~ S.singleton OnwardCluster
src/TreeHelp.hs
+8 -10
View File
@@ -24,9 +24,11 @@ module TreeHelp
, updateRandNode , updateRandNode
, safeUpdateSingleNode , safeUpdateSingleNode
, msafeUpdateSingleNode , msafeUpdateSingleNode
, numTraversable
) where ) where
import RandomHelp import RandomHelp
import Data.Traversable
import Data.Maybe import Data.Maybe
import Data.Tree.Lens import Data.Tree.Lens
import Data.Tree import Data.Tree
@@ -183,15 +185,11 @@ splitTrunk t = do
i <- state $ randomR (0, trunkDepth t) i <- state $ randomR (0, trunkDepth t)
return $ splitTrunkAt i t return $ splitTrunkAt i t
numTraversable :: Traversable t => t a -> t (a,Int)
numTraversable = snd . mapAccumL f 0
where
f i x = (i+1,(x,i))
-- untested -- untested
inorderNumberTree :: Tree a -> Tree (a,Int) inorderNumberTree :: Tree a -> Tree (a,Int)
inorderNumberTree = fst . f 0 inorderNumberTree = numTraversable
where
f i (Node x ts) =
let (ts',i') = g (i+1) ts
in (Node (x,i) ts', i')
g i (t:ts) =
let (t',i') = f i t
(ts',i'') = g i' ts
in (t': ts', i'')
g i [] = ([], i)