94 lines
3.7 KiB
Haskell
94 lines
3.7 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
{- | Annotating tree structures with desired properties for rooms. -}
|
|
module Dodge.Annotation
|
|
( module Dodge.Annotation.Data
|
|
, module Dodge.Annotation
|
|
) where
|
|
import Dodge.RandomHelp
|
|
import Dodge.Tree
|
|
import Dodge.Room
|
|
import Dodge.Annotation.Data
|
|
--import LensHelp
|
|
|
|
import Data.Tree
|
|
import Control.Monad.State
|
|
import System.Random
|
|
--import Control.Lens
|
|
import Data.Maybe
|
|
|
|
addLock :: Int -> Tree [Annotation] -> State StdGen (Tree [Annotation])
|
|
addLock i t = do
|
|
(beforeLock, afterLock) <- splitTrunk t
|
|
newBefore <- applyToRandomNode (Key i :) beforeLock
|
|
return $ addToTrunk newBefore [Node [Lock i] afterLock]
|
|
{- | Add one corridor between each parent-child link of a tree of annotations. -}
|
|
padWithCorridors :: Tree [Annotation] -> Tree [Annotation]
|
|
padWithCorridors = padWithAno [Corridor]
|
|
|
|
padWithAno :: [Annotation] -> Tree [Annotation] -> Tree [Annotation]
|
|
padWithAno ano (Node x xs) = Node ano [Node x (map (padWithAno ano) xs)]
|
|
|
|
padSucWithCorridors :: Tree [Annotation] -> Tree [Annotation]
|
|
padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs)
|
|
|
|
padSucWithDoors :: Tree [Annotation] -> Tree [Annotation]
|
|
padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs)
|
|
where
|
|
thetree = do
|
|
thecor <- shuffleLinks corridor
|
|
takeOne
|
|
[ (return (UseAll door),TreeSubLabelling "door" Nothing)
|
|
, (treeFromPost [PassDown door, PassDown thecor] (UseAll door)
|
|
,TreeSubLabelling "twoDoors" Nothing)
|
|
]
|
|
|
|
{- Add one to three corridors between each parent-child link of a tree of annotations. -}
|
|
randomPadCorridors :: Tree [Annotation] -> State StdGen (Tree [Annotation])
|
|
randomPadCorridors (Node x xs) = do
|
|
n <- state $ randomR (1, 3)
|
|
xs' <- mapM randomPadCorridors xs
|
|
return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
|
|
{- | Add a corridor to a random out-link of a room. -}
|
|
roomThenCorridor :: RandomGen g => Room -> State g (SubCompTree Room)
|
|
roomThenCorridor theRoom = fmap
|
|
(\r -> Node (PassDown theRoom) [(pure . UseAll) r])
|
|
(shuffleLinks corridor)
|
|
|
|
{- | Create a random room tree structure from a list of annotations. -}
|
|
anoToRoomTree :: [Annotation] -> State StdGen (LabSubCompTree Room)
|
|
anoToRoomTree anos = case anos of
|
|
[AnoApplyInt i f] -> f i
|
|
-- [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing)
|
|
(SpecificRoom rt:_) -> rt
|
|
[PassthroughLockKeyLists i ls ks] -> do
|
|
(functionlockroom,randomitemidentity) <- takeOne ls
|
|
lr' <- functionlockroom i
|
|
ii <- randomitemidentity
|
|
let lr = fst lr'
|
|
keyroom' <- fromJust $ lookup ii ks
|
|
let keyroom = fst keyroom'
|
|
return (overwriteLabel 0 UseNone lr [keyroom]
|
|
,TreeSubLabelling ("PassthroughLockKeyLists-"++show ii)
|
|
(Just $ treeFromPost [snd lr'] (snd keyroom'))
|
|
)
|
|
_ -> (,TreeSubLabelling "no label" Nothing) <$> anoToRoomTree' anos
|
|
|
|
{- | Create a random room tree structure from a list of annotations. -}
|
|
anoToRoomTree' :: [Annotation] -> State StdGen (SubCompTree Room)
|
|
anoToRoomTree' anos = case anos of
|
|
[ChainAnos ass] -> do
|
|
rms <- mapM anoToRoomTree' ass
|
|
return $ chainUses rms
|
|
[OrAno as] -> do
|
|
a <- takeOne as
|
|
anoToRoomTree' a
|
|
[Corridor] -> pure . UseAll <$> shuffleLinks corridor
|
|
(BossAno cr : _) -> do
|
|
br <- bossRoom cr
|
|
branchRectWith . pure . fmap PassDown $ treeFromPost [corridor,corridor] br
|
|
(TreasureAno crs loot : _) -> branchRectWith . fmap (pure . PassDown) $ lootRoom crs loot
|
|
_ -> do
|
|
w <- state $ randomR (100,400)
|
|
h <- state $ randomR (200,400)
|
|
fmap (pure . UseAll) . shuffleLinks $ roomRectAutoLinks w h
|