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

Add tree structure generation

Browse Source
This commit is contained in:
jgk
2021-04-15 21:35:03 +02:00
parent 6119276d45
commit 38d67520cc
18 changed files with 531 additions and 153 deletions
Download Patch File Download Diff File Expand all files Collapse all files
data/music/firstCompo.mid
BIN
View File
Binary file not shown.
src/Dodge/Config/KeyConfig.hs
+152
View File
@@ -0,0 +1,152 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Dodge.Config.KeyConfig
where
import Data.Aeson
import Foreign.C.Types
import GHC.Generics
import qualified GHC.Int
import qualified SDL
import SDL.Internal.Numbered as SDL.Internal.Numbered
import System.Directory
data KeyConfig = KeyConfig
{ moveUpBinding :: Int,
moveDownBinding :: Int,
moveLeftBinding :: Int,
moveRightBinding :: Int,
pauseBinding :: Int,
escapeBinding :: Int,
dropItemBinding :: Int,
toggleMapBinding :: Int,
reloadBinding :: Int,
testEventBinding :: Int,
spaceActionBinding :: Int,
rotateCameraPlusBinding :: Int,
rotateCameraMinusBinding :: Int,
zoomInBinding :: Int,
zoomOutBinding :: Int,
newBinding :: Int
}
deriving (Generic, Show)
data KeyConfigSDL = KeyConfigSDL
{ moveUpKey :: SDL.Scancode,
moveDownKey :: SDL.Scancode,
moveLeftKey :: SDL.Scancode,
moveRightKey :: SDL.Scancode,
pauseKey :: SDL.Scancode,
escapeKey :: SDL.Scancode,
dropItemKey :: SDL.Scancode,
toggleMapKey :: SDL.Scancode,
reloadKey :: SDL.Scancode,
testEventKey :: SDL.Scancode,
spaceActionKey :: SDL.Scancode,
rotateCameraPlusKey :: SDL.Scancode,
rotateCameraMinusKey :: SDL.Scancode,
zoomInKey :: SDL.Scancode,
zoomOutKey :: SDL.Scancode,
newKey :: SDL.Scancode
}
deriving (Generic, Show)
defaultKeyConfigSDL =
KeyConfigSDL
{ moveUpKey = SDL.ScancodeW,
moveDownKey = SDL.ScancodeS,
moveLeftKey = SDL.ScancodeA,
moveRightKey = SDL.ScancodeD,
pauseKey = SDL.ScancodeP,
escapeKey = SDL.ScancodeEscape,
dropItemKey = SDL.ScancodeF,
toggleMapKey = SDL.ScancodeM,
reloadKey = SDL.ScancodeR,
testEventKey = SDL.ScancodeT,
spaceActionKey = SDL.ScancodeSpace,
rotateCameraPlusKey = SDL.ScancodeQ,
rotateCameraMinusKey = SDL.ScancodeE,
zoomInKey = SDL.ScancodeJ,
zoomOutKey = SDL.ScancodeK,
newKey = SDL.ScancodeN
}
instance ToJSON KeyConfig where
toEncoding = genericToEncoding defaultOptions
instance FromJSON KeyConfig where
parseJSON = withObject "KeyConfig" $ \o -> do
moveUpBinding <- o .:? "moveUp" .!= 119
moveDownBinding <- o .:? "moveDown" .!= 115
moveLeftBinding <- o .:? "moveLeft" .!= 97
moveRightBinding <- o .:? "moveRight" .!= 100
pauseBinding <- o .:? "pause" .!= 112
escapeBinding <- o .:? "escape" .!= 27
dropItemBinding <- o .:? "dropItem" .!= 102
toggleMapBinding <- o .:? "toggleMap" .!= 109
reloadBinding <- o .:? "reload" .!= 114
testEventBinding <- o .:? "testEvent" .!= 116
spaceActionBinding <- o .:? "spaceAction" .!= 32
rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113
rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101
zoomInBinding <- o .:? "zoomIn" .!= 106
zoomOutBinding <- o .:? "zoomOut" .!= 107
newBinding <- o .:? "new" .!= 110
return
KeyConfig
{ moveUpBinding = moveUpBinding,
moveDownBinding = moveDownBinding,
moveLeftBinding = moveLeftBinding,
moveRightBinding = moveRightBinding,
pauseBinding = pauseBinding,
escapeBinding = escapeBinding,
dropItemBinding = dropItemBinding,
toggleMapBinding = toggleMapBinding,
reloadBinding = reloadBinding,
testEventBinding = testEventBinding,
spaceActionBinding = spaceActionBinding,
rotateCameraPlusBinding = rotateCameraPlusBinding,
rotateCameraMinusBinding = rotateCameraMinusBinding,
zoomInBinding = zoomInBinding,
zoomOutBinding = zoomOutBinding,
newBinding = newBinding
}
loadKeyConfig :: IO KeyConfigSDL
loadKeyConfig = do
fExists <- doesFileExist "keys.json"
if fExists
then do
mayConfig <- decodeFileStrict "keys.json"
print mayConfig
case mayConfig of
Just config ->
return
KeyConfigSDL
{ moveUpKey = getSdlScancode $ moveUpBinding config,
moveDownKey = getSdlScancode $ moveDownBinding config,
moveLeftKey = getSdlScancode $ moveLeftBinding config,
moveRightKey = getSdlScancode $ moveRightBinding config,
pauseKey = getSdlScancode $ pauseBinding config,
escapeKey = getSdlScancode $ escapeBinding config,
dropItemKey = getSdlScancode $ dropItemBinding config,
toggleMapKey = getSdlScancode $ toggleMapBinding config,
reloadKey = getSdlScancode $ reloadBinding config,
testEventKey = getSdlScancode $ testEventBinding config,
spaceActionKey = getSdlScancode $ spaceActionBinding config,
rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config,
rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config,
zoomInKey = getSdlScancode $ zoomInBinding config,
zoomOutKey = getSdlScancode $ zoomOutBinding config,
newKey = getSdlScancode $ newBinding config
}
Nothing -> do
putStrLn "invalid keys.json, loading default config"
-- This is duplicated but not sure how to reduce
return defaultKeyConfigSDL
else do
putStrLn "No keys.json found, loading default config"
return defaultKeyConfigSDL
getSdlScancode :: Int -> SDL.Scancode
getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode
src/Dodge/Data/SoundOrigin.hs
+20
View File
@@ -0,0 +1,20 @@
module Dodge.Data.SoundOrigin
where
data SoundOrigin = InventorySound
| BackgroundSound
| OnceSound
| CrSound Int
| CrWeaponSound Int
| WallSound Int
| CrReloadSound Int
| Flamer
| ShellSound Int
| Flame
| LasSound
| FootstepSound Int
| BlockDegradeSound Int
| CrHitSound Int
| BarrelHiss Int
| GlassBreakSound Int
deriving (Eq,Ord,Show)
src/Dodge/Event/Menu.hs
+1 -3
View File
@@ -1,9 +1,7 @@
module Dodge.Event.Menu
( handlePressedKeyInMenu
)
where
) where
import Dodge.Data
import Dodge.Rooms
import Dodge.Floor
import Dodge.Initialisation
import Dodge.SoundLogic
src/Dodge/Floor.hs
+5 -2
View File
@@ -6,10 +6,13 @@ module Dodge.Floor
import Geometry
import Picture
import Dodge.Data
import Dodge.Rooms
import Dodge.Room
import Dodge.Room.Procedural
import Dodge.Room.Data
import Dodge.Base
import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either
import Dodge.Creature
import Dodge.SoundLogic
import Dodge.RandomHelp
@@ -80,7 +83,7 @@ roomToLevel2 = join $ takeOne
]
portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
portalRoom1 = return $ connectRoom $ (roomRectAutoLinks 300 300) { _rmPS = plmnts}
where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
,PS (60,100) pi $ PutCrit autoCrit
]
src/Dodge/Layout.hs
+19 -32
View File
@@ -3,7 +3,6 @@ module Dodge.Layout
, module Dodge.Layout.Tree
)
where
-- imports {{{
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.Data
@@ -13,29 +12,24 @@ import Dodge.Graph
import Dodge.Layout.Tree
import Dodge.Room.Data
import Dodge.Default
import Geometry
import Control.Monad.State
import Control.Lens
import System.Random
import Data.List
import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import qualified Data.Map as M
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
-- }}}
-- connects a collection (tree) of rooms together
-- | connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts
$ w {_walls = wallsFromTree tr, _randGen = g
@@ -43,21 +37,22 @@ generateFromTree t w = zoning $ placeSpots plmnts
,_pathGraph' = pairGraph
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
,_pathInc = pinc}
where tr = evalState t $ _randGen w
plmnts = concatMap _rmPS $ flatten tr
g = _randGen w
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph
zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
w
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
where
tr = evalState t $ _randGen w
plmnts = concatMap _rmPS $ flatten tr
g = _randGen w
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph
zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
w
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten
@@ -119,14 +114,6 @@ changeLinkTo cond r = do
return $ r {_rmLinks = newLinks}
-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
composeTreeWith :: (a -> Tree (Either b b)) -> Tree a -> Tree (Either b b)
composeTreeWith f (Node x []) = f x
composeTreeWith f (Node x xs) = paste xs $ f x
where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)
-- the old version of this used a version of polysIntersect with intersectSegSeg'
boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
src/Dodge/Layout/Generate.hs
+25
View File
@@ -0,0 +1,25 @@
{-|
Random generation of high level layout of rooms.
-}
module Dodge.Layout.Generate
where
import Data.Tree
import Control.Monad.State
import System.Random
generateLayout :: State g (Tree RoomProperties)
generateLayout = undefined
data RoomProperties = RProps
{ _pickUpLevel :: [Int]
, _pickUps :: [Int]
}
randomTreeStructure :: Int -> State g (Tree ())
randomTreeStructure i = undefined
treeMaxDepthFromTrunk :: Int -> Int -> State g (Tree ())
treeMaxDepthFromTrunk nNodes maxDepth = do
undefined
src/Dodge/Layout/LockAndKey.hs
-14
View File
@@ -1,14 +0,0 @@
module Dodge.Layout.LockAndKey
where
data Key = Key Int
-- data Area
-- = Area
-- { _arID :: Int
-- , _arLinks :: [Int]
-- , _arMonsters :: [Creature]
-- , _arItems :: [Item]
-- }
--generateGraph
src/Dodge/Layout/Tree.hs
-40
View File
@@ -6,44 +6,4 @@ module Dodge.Layout.Tree
import Data.Tree
import Control.Monad.State
import System.Random
-- | 'Left' elements get new children, 'Right' elements inherit the children from the
-- mapped over node
expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
expandTreeBy f (Node x []) = fmap removeEither (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeBy f (Node x xs) = appendAndRemove $ f x
where appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
expandTreeRand :: RandomGen g =>
(a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeRand f (Node x xs) = do
root <- f x
branches <- sequence $ map (expandTreeRand f) xs
return (appendAndRemove branches root)
where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
appendAndRemove bran (Node (Right y) _) = Node y bran
collapseTree :: Tree (Tree (Either a a)) -> Tree (Either a a)
collapseTree = g . expandTreeBy f
where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
g (Node (Right x) []) = Node (Right x) []
g (Node (Right x) xs) = Node (Left x) $ map g xs
g (Node y ys) = Node y $ map g ys
treePost :: [a] -> a -> Tree a
treePost [] y = Node y []
treePost (x:xs) y = Node x [treePost xs y]
treeTrunk :: [a] -> Tree a -> Tree a
treeTrunk [] t = t
treeTrunk (x:xs) t = Node x [treeTrunk xs t]
applyToRoot :: (a -> a) -> Tree a -> Tree a
applyToRoot f (Node x xs) = Node (f x) xs
src/Dodge/Layout/Tree/Annotate.hs
+24
View File
@@ -0,0 +1,24 @@
{-
Annotating tree structures with desired properties for rooms.
-}
module Dodge.Layout.Tree.Annotate
where
import Dodge.RandomHelp
import Dodge.Layout.Tree.Polymorphic
import Data.Tree
import Control.Monad.State
import System.Random
data Annotation
= Lock Int
| Key Int
addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation])
addLock i t = do
(beforeLock, afterLock) <- splitTrunk t
newBefore <- applyToRandomNode (Key i :) beforeLock
return $ addToTrunk newBefore [Node [Lock i] afterLock]
--annoToRoom :: RandomGen g => [Annotation] -> State g (Either Room Room)
--annoToRoom as = undefined
src/Dodge/Layout/Tree/Either.hs
+22
View File
@@ -0,0 +1,22 @@
{-|
Combining and composing trees with 'Either' nodes.
-}
module Dodge.Layout.Tree.Either
( expandTreeBy
) where
import Data.Tree
-- | 'Left' elements get new children as given by the node function,
-- 'Right' elements inherit the children from the base tree
expandTreeBy
:: (a -> Tree (Either b b)) -- ^ Node function
-> Tree a -- ^ Base tree
-> Tree b
expandTreeBy f (Node x []) = fmap removeEither (f x)
expandTreeBy f (Node x xs) = appendAndRemove $ f x
where
appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
removeEither (Left y) = y
removeEither (Right y) = y
src/Dodge/Layout/Tree/GenerateStructure.hs
+56
View File
@@ -0,0 +1,56 @@
{-
Procedural generation of tree structures.
A /trunk/ refers to the successive first nodes in lists of children.
-}
module Dodge.Layout.Tree.GenerateStructure
where
import Dodge.RandomHelp
import Data.Tree
import Control.Monad.State
import System.Random
{-
Single branched tree (a trunk).
-}
treePath :: Int -> Tree ()
treePath 0 = Node () []
treePath x = Node () [treePath (x-1)]
{-
Adds a branch at a certain point down a trunk.
-}
addBranchAt
:: Int -- ^ Depth to add branch at
-> Tree () -- ^ Branch to add
-> Tree () -- ^ Starting tree
-> Tree ()
addBranchAt 0 b (Node () xs) = Node () (xs ++ [b])
addBranchAt i b (Node () (x:xs))
= Node () (addBranchAt (i-1) b x : xs)
{-
Randomly generate a tree containing a maximum of three nodes.
-}
smallBranch :: RandomGen g => State g (Tree ())
smallBranch = takeOne
[ treePath 0
, treePath 1
, treePath 2
, addBranchAt 0 (treePath 0) (treePath 1)
]
{-
Randomly generate a small tree.
-}
aTreeStrut :: RandomGen g => State g (Tree ())
aTreeStrut = do
d <- state $ randomR (9,11:: Int)
nbs <- state $ randomR (2,5)
bds <- takeN nbs [1 .. d - 1]
bs <- replicateM nbs smallBranch
let trunk = treePath d
return $ foldr (uncurry addBranchAt) trunk $ zip bds bs
src/Dodge/Layout/Tree/Polymorphic.hs
+111
View File
@@ -0,0 +1,111 @@
module Dodge.Layout.Tree.Polymorphic
where
import Dodge.RandomHelp
import Data.Tree
import Control.Monad.State
import System.Random
{-
Creates a linear tree.
Safe.
-}
treePost :: [a] -> a -> Tree a
treePost [] y = Node y []
treePost (x:xs) y = Node x [treePost xs y]
{-
Creates a tree with one trunk branch,
input as a list, that ends in another tree.
-}
treeTrunk
:: [a] -- ^ The trunk
-> Tree a -- ^ The end of the tree
-> Tree a
treeTrunk [] t = t
treeTrunk (x:xs) t = Node x [treeTrunk xs t]
{-
Applies a function to the root of a tree.
-}
applyToRoot :: (a -> a) -> Tree a -> Tree a
applyToRoot f (Node x xs) = Node (f x) xs
treeSize = length . flatten
{-
Applies a function to a specific node determined by a list of indices.
Unsafe (partial function).
-}
applyToNode :: [Int] -> (a -> a) -> Tree a -> Tree a
applyToNode [] f t = applyToRoot f t
applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
where
(ys, z:zs) = splitAt i xs
zipTree :: Tree a -> Tree b -> Tree (a,b)
zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys
{-
Makes each node into its child number, i.e. the index it has
in the list of children of its parent.
-}
treeChildNums :: Tree a -> Tree Int
treeChildNums t = setRoot 0 t
where
setRoot :: Int -> Tree a -> Tree Int
setRoot i (Node x xs) = Node i (zipWith setRoot [0..] xs)
{-
Makes each node into its path, i.e. the list of indices that,
when followed from the root, lead to the node.
-}
treePaths :: Tree a -> Tree [a]
treePaths (Node x xs) = fmap (x :) $ Node [] (map treePaths xs)
{-
Picks a random path in the tree.
Uniform probability that the path leads to any specific node.
-}
randomPath :: RandomGen g => Tree a -> State g [Int]
randomPath = takeOne . flatten . treePaths . treeChildNums
{-
Apply a function to a node picked uniformly at random.
-}
applyToRandomNode :: RandomGen g => (a -> a) -> Tree a -> State g (Tree a)
applyToRandomNode f t = do
p <- randomPath t
return $ applyToNode p f t
{-
Add a forest to the end of a tree.
-}
addToTrunk :: Tree a -> [Tree a] -> Tree a
addToTrunk (Node x []) f = Node x f
addToTrunk (Node x (t:ts)) f = Node x (addToTrunk t f : ts)
{-
Find the depth of a tree along the trunk.
-}
trunkDepth :: Tree a -> Int
trunkDepth (Node _ []) = 0
trunkDepth (Node _ (x:xs)) = trunkDepth x + 1
{-
Split a tree at a given point along its trunk.
-}
splitTrunkAt :: Int -> Tree a -> (Tree a, [Tree a])
splitTrunkAt 0 (Node x xs) = (Node x [],xs)
splitTrunkAt i (Node y (x:xs)) =
let (t, ts) = (splitTrunkAt (i-1) x)
in (Node y (t : xs) , ts)
{-
Split a tree at a random point along its trunk.
-}
splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a])
splitTrunk t = do
i <- state $ randomR (0, trunkDepth t)
return $ splitTrunkAt i t
src/Dodge/RandomHelp.hs
+1
View File
@@ -33,6 +33,7 @@ takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a])
takeNMore n p = foldr (const ((=<<) takeOneMore)) (return p) [1..n]
takeN :: RandomGen g => Int -> [a] -> State g [a]
takeN 0 xs = return []
takeN i xs = fmap fst $ takeNMore i ([],xs)
-- to randomly shuffle a list
src/Dodge/Rooms.hs → src/Dodge/Room.hs
+17 -61
View File
@@ -1,9 +1,8 @@
module Dodge.Rooms
-- ( module Dodge.Rooms
-- , module Dodge.Rooms.Data
-- )
{-
Specification of individual rooms.
-}
module Dodge.Room
where
-- imports {{{
import Dodge.Data
import Dodge.Item.Weapon
import Dodge.Creature
@@ -15,37 +14,33 @@ import Dodge.RandomHelp
import Dodge.Default
import Dodge.Path
import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either
import Dodge.LightSources
import Dodge.SoundLogic
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Room.Procedural
import Geometry
import Picture
import qualified SDL.Mixer as Mix
import Control.Lens
import Control.Monad.State
import Control.Monad.Loops
import Control.Lens
import System.Random
import Data.List
import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import qualified Data.Map as M
import Data.Graph.Inductive.Graph hiding ((&))
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
-- }}}
-- definition of individual rooms
airlockOneWay :: Int -> Room
airlockOneWay n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
@@ -158,23 +153,6 @@ roomC x y = Room
,( ( 0, 20),pi/2)
]
makeRect :: Float -> Float -> [(Point2,Point2)]
makeRect x y = [((0,0),(x,0))
,((0,0),(0,y))
,((x,y),(x,0))
,((x,y),(0,y))
]
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
, b <- take ny $ scanl (+) 0 $ repeat y
]
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
makeGrid x nx y ny = nub $ concatMap doublePair
$ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
$ gridPoints x nx y ny
roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = Room
{ _rmPolys = [ps]
@@ -184,32 +162,10 @@ roomPadCut ps p = Room
, _rmBound = []
}
roomRect' :: Float -> Float -> Int -> Int -> Room
roomRect' x y a b = Room
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [PS (x/2,y/2) 0 $ putLamp]
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
}
where yn,xn :: Int
yn = b
yd = (y - 40) / fromIntegral yn
xn = a
xd = (x - 40) / fromIntegral xn
elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints 0 1 yd (yn+1)
wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints 0 1 yd (yn+1)
nlnks = flip zip (repeat ( 0)) $ translateS (20,y) $ gridPoints xd (xn+1) 0 1
slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
roomRect :: Float -> Float -> Room
roomRect x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
door :: Room
door = Room
@@ -349,7 +305,7 @@ miniRoom3 = do
,PS cp (pi/8+7*pi/4) b
,PS (w/2,h/2) 0 putLamp
]
randomiseLinks $ set rmPS plmnts $ roomRect w h
randomiseLinks $ set rmPS plmnts $ roomRectAutoLinks w h
rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen)
@@ -549,7 +505,7 @@ branchRectWith t = do
x <- state $ randomR (100,200)
y <- state $ randomR (100,200)
b <- t
root <- randLinks $ roomRect x y
root <- randLinks $ roomRectAutoLinks x y
return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b]
where rToL :: Either a a -> Either a a
rToL (Right r) = Left r
@@ -588,7 +544,7 @@ slowDoorRoom = do
]
fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
$ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRect x y
$ roomRectAutoLinks x y
))
longRoom :: RandomGen g => State g Room
longRoom = do
@@ -656,7 +612,7 @@ shootersRoom1 = do
++ [PS p (-pi/2) $ PutCrit autoCrit
,PS (w/2,200) 0 putLamp
]
return $ set rmPS plmnts $ roomRect w 600
return $ set rmPS plmnts $ roomRectAutoLinks w 600
shootersRoom :: RandomGen g => State g Room
shootersRoom = do
@@ -677,7 +633,7 @@ shootersRoom = do
,PS (x3,y3-10) (-pi/2) $ PutCrit autoCrit
,PS (w/2,200) 0 putLamp
]
return $ set rmPS plmnts $ roomRect w 600
return $ set rmPS plmnts $ roomRectAutoLinks w 600
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = do
src/Dodge/Room/CheckConsistency.hs
+17
View File
@@ -0,0 +1,17 @@
module Dodge.Room.CheckConsistency
where
import Dodge.Room.Data
import Dodge.Graph
linksOnPath :: Room -> Bool
linksOnPath r = all pointOnPath linkPoints
where
linkPoints = map fst $ _rmLinks r
pointOnPath p = elem p $ concatMap flat2 $ _rmPath r
flat2 (x,y) = [x,y]
pathConnected :: Room -> Bool
pathConnected = isSingleton . pairsToSCC . _rmPath
where
isSingleton (_:[]) = True
isSingleton _ = False
src/Dodge/Room/Placement.hs
+1 -1
View File
@@ -1,3 +1,4 @@
-- | Module defining helper placements for rooms.
module Dodge.Room.Placement
where
import Dodge.Data
@@ -7,7 +8,6 @@ import Dodge.Creature.Inanimate
import Geometry
-- module defining helper placements for rooms
putLamp = PutCrit lamp
src/Dodge/Room/Procedural.hs
+60
View File
@@ -0,0 +1,60 @@
module Dodge.Room.Procedural
where
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Geometry
import Data.List (nub,sortBy)
import Data.Function (on)
{-
A simple rectangular room with a light in the center.
Creates links and pathfinding graph.
-}
roomRect'
:: Float -- ^ Width
-> Float -- ^ Height
-> Int -- ^ Number of links on vertical walls
-> Int -- ^ Number of links on horizontal walls
-> Room
roomRect' x y xn yn = Room
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [PS (x/2,y/2) 0 $ putLamp]
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
}
where
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints 0 1 yd (yn+1)
wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints 0 1 yd (yn+1)
nlnks = flip zip (repeat ( 0)) $ translateS (20,y) $ gridPoints xd (xn+1) 0 1
slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
makeGrid x nx y ny = nub $ concatMap doublePair
$ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
$ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
, b <- take ny $ scanl (+) 0 $ repeat y
]
makeRect :: Float -> Float -> [(Point2,Point2)]
makeRect x y = [((0,0),(x,0))
,((0,0),(0,y))
,((x,y),(x,0))
,((x,y),(0,y))
]
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)