From 8fb80f9691508b225005a0f6a66dd29fa7b0a925 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 9 Jun 2022 19:17:27 +0100 Subject: [PATCH] BROKEN partial redo of room tree composition --- src/Dodge/Annotation.hs | 2 +- src/Dodge/Floor.hs | 2 +- src/Dodge/Room/Containing.hs | 8 +-- src/Dodge/Room/GlassLesson.hs | 20 ++++---- src/Dodge/RoomCluster/Data.hs | 4 +- src/Dodge/Tree/Compose.hs | 90 +++++++++++++++++----------------- src/Dodge/Tree/Compose/Data.hs | 7 +-- 7 files changed, 68 insertions(+), 65 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 1d056a3cf..9094d2eb5 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -53,7 +53,7 @@ roomThenCorridor theRoom = fmap (shuffleLinks corridor) {- | Create a random room tree structure from a list of annotations. -} -anoToRoomTree :: [Annotation] -> State StdGen (LabSubCompTree Room) +anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room) anoToRoomTree anos = case anos of [AnoApplyInt i f] -> f i -- [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 3807ee1f0..946480442 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -100,5 +100,5 @@ initialAnoTree = padSucWithDoors $ treeFromPost <&> (,TreeSubLabelling "telRoomLev" Nothing)] {- | A test level tree. -} -initialRoomTree :: State StdGen (Tree (LabSubCompTree Room)) +initialRoomTree :: State StdGen (Tree (Room -> Maybe (String,Room), Tree Room)) initialRoomTree = mapM anoToRoomTree initialAnoTree diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs index eb38cf4dc..6f72e1afa 100644 --- a/src/Dodge/Room/Containing.hs +++ b/src/Dodge/Room/Containing.hs @@ -8,6 +8,7 @@ import Dodge.Room.Procedural import Dodge.Room.Tanks import Dodge.Room.Link import Dodge.Room.Ngon +import Dodge.UseAll import LensHelp import Geometry --import Dodge.Item.Equipment @@ -20,9 +21,10 @@ roomsContaining crs its = do [ randomFourCornerRoomCrsIts crs its , tanksRoom crs its ] - return (treeFromPost [] $ UseAll endroom - ,TreeSubLabelling ("roomsContaining-creatures:" ++ intercalate "," (map _crName crs) - ++ "-items:" ++ intercalate "," (map (show . _iyBase . _itType) its)) Nothing) + return (toOnward ("roomsContaining-creatures:" ++ intercalate "," (map _crName crs) + ++ "-items:" ++ intercalate "," (map (show . _iyBase . _itType) its)) + , pure $ useAll endroom + ) pedestalRoom :: RandomGen g => Item -> State g Room pedestalRoom it = do diff --git a/src/Dodge/Room/GlassLesson.hs b/src/Dodge/Room/GlassLesson.hs index e00798765..b145907a9 100644 --- a/src/Dodge/Room/GlassLesson.hs +++ b/src/Dodge/Room/GlassLesson.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} module Dodge.Room.GlassLesson where +import Dodge.UseAll import Dodge.RoomLink import Dodge.Creature import Dodge.LevelGen.Data @@ -18,19 +19,18 @@ import LensHelp import qualified Data.Set as S --import Control.Monad.Loops -glassLesson :: RandomGen g => State g (SubCompTree Room) +glassLesson :: RandomGen g => State g (Tree Room) glassLesson = do i <- takeOne [1,2,3] - corridors <- replicateM i $ PassDown <$> shuffleLinks corridor - return $ Node (PassDown botRoom) - [ singleUseNone $ door & rmConnectsTo .~ fromWest North 1 + corridors <- replicateM i $ shuffleLinks corridor + return $ Node botRoom + [ pure $ door & rmConnectsTo .~ fromWest North 1 , uppers - , treeFromPost (PassDown (door & rmConnectsTo .~ S.member (OnEdge East)) - : corridors) $ UseAll door] + , treeFromPost ( (door & rmConnectsTo .~ S.member (OnEdge East)) + : corridors) $ useAll door] where fromWest edge i s = S.member (OnEdge edge) s && S.member (FromWest i) s - uppers = Node (PassDown $ door & rmConnectsTo .~ fromWest North 0) - [singleUseNone topRoom] + uppers = Node (door & rmConnectsTo .~ fromWest North 0) [pure topRoom] botRoom = roomRect 200 200 1 1 & rmPmnts .~ botplmnts & rmLinks %~ setInLinksByType (OnEdge West) @@ -54,6 +54,6 @@ glassLesson = do ] ] glassLessonRunPast :: RandomGen g => State g (LabSubCompTree Room) -glassLessonRunPast = (f <$> glassLesson) <&> (,TreeSubLabelling "glassLessonRunPast" Nothing) +glassLessonRunPast = (f <$> glassLesson) <&> (toOnward "glassLessonRunPast",) 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 diff --git a/src/Dodge/RoomCluster/Data.hs b/src/Dodge/RoomCluster/Data.hs index 567cd021b..d40f796df 100644 --- a/src/Dodge/RoomCluster/Data.hs +++ b/src/Dodge/RoomCluster/Data.hs @@ -9,7 +9,7 @@ data ClusterStatus = ClusterStatus , _csLinks :: S.Set ClusterLink } -data ClusterLink = OnwardCluster | SideCluster - deriving (Ord,Eq,Enum,Show) +data ClusterLink = OnwardCluster | SideCluster | LabelCluster Int + deriving (Ord,Eq,Show) makeLenses ''ClusterStatus diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 5a532770f..04579e3f1 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -1,16 +1,16 @@ {-# LANGUAGE TupleSections #-} {-| Combining and composing trees of trees. -} module Dodge.Tree.Compose - ( expandTree - , singleUseAll - , singleUseNone - , passUntilUseAll - , chainUses - , useAllAtEnd - , changeToPassDown - , overwriteLabel - , applyToCompRoot - , composeTree + ( --expandTree + --, singleUseAll + --, singleUseNone + --, passUntilUseAll + --, chainUses + --, useAllAtEnd + --, changeToPassDown + --, overwriteLabel + --, applyToCompRoot + composeTree , composeTree' , composeTreeRand -- , compTree @@ -26,49 +26,49 @@ import Data.Foldable import System.Random 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 (PassDown x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs - Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs - $ map (:[]) extChildren ++ repeat [] +--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 (PassDown 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) -> SubCompTree a -> SubCompTree a -applyToCompRoot f = over root (unCompose %~ f) +--applyToCompRoot :: (a -> a) -> SubCompTree a -> SubCompTree a +--applyToCompRoot f = over root (unCompose %~ f) -overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a -overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i) - $ updateSingleNodes islabel update t - where - islabel (UseLabel j _) | i == j = True - islabel _ = False - update (Node x _) = Node (f $ _unCompose x) ts +--overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a +--overwriteLabel i f t ts = errorHead ("tried to overwriteLabel " ++ show i) +-- $ updateSingleNodes islabel update t +-- where +-- islabel (UseLabel j _) | i == j = True +-- islabel _ = False +-- update (Node x _) = Node (f $ _unCompose x) ts -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 +--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 -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" +--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" -singleUseAll :: a -> Tree (ComposingNode a) -singleUseAll x = Node (UseAll x) [] +--singleUseAll :: a -> Tree (ComposingNode a) +--singleUseAll x = Node (UseAll x) [] -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) [] +--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) [] -singleUseNone :: a -> SubCompTree a -singleUseNone x = Node (UseNone x) [] +--singleUseNone :: a -> SubCompTree a +--singleUseNone x = Node (UseNone x) [] -changeToPassDown :: ComposingNode a -> ComposingNode a -changeToPassDown x = PassDown (_unCompose x) +--changeToPassDown :: ComposingNode a -> ComposingNode a +--changeToPassDown x = PassDown (_unCompose x) composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a) composeTreeRand (Node (_,t) ts) = attachListR t ts diff --git a/src/Dodge/Tree/Compose/Data.hs b/src/Dodge/Tree/Compose/Data.hs index adbeecf9b..2d68506c2 100644 --- a/src/Dodge/Tree/Compose/Data.hs +++ b/src/Dodge/Tree/Compose/Data.hs @@ -10,9 +10,9 @@ data ComposingNode a | UseSome {_composeIndices :: [Int], _unCompose :: a} | UseNone {_unCompose :: a} | UseLabel {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children -type SubCompTree a = Tree (ComposingNode a) -type CompTree a = Tree (SubCompTree a) -type LabSubCompTree a = (Tree (ComposingNode a),TreeSubLabelling) +type SubCompTree a = Tree a +type CompTree a = Tree (Tree a) +type LabSubCompTree a = (a -> Maybe ([String],a),Tree a) type LabCompTree a = Tree (LabSubCompTree a) data TreeSubLabelling = TreeSubLabelling { _topLabel :: String @@ -20,3 +20,4 @@ data TreeSubLabelling = TreeSubLabelling } makeLenses ''ComposingNode makeLenses ''TreeSubLabelling +