diff --git a/data/music/firstCompo.mid b/data/music/firstCompo.mid index 42411e4c5..bad3e62be 100644 Binary files a/data/music/firstCompo.mid and b/data/music/firstCompo.mid differ diff --git a/src/Dodge/Config/KeyConfig.hs b/src/Dodge/Config/KeyConfig.hs new file mode 100644 index 000000000..989235c3c --- /dev/null +++ b/src/Dodge/Config/KeyConfig.hs @@ -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 diff --git a/src/Dodge/Data/SoundOrigin.hs b/src/Dodge/Data/SoundOrigin.hs new file mode 100644 index 000000000..0fc6f2acb --- /dev/null +++ b/src/Dodge/Data/SoundOrigin.hs @@ -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) + diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 257691da3..51cd52d10 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -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 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 50f3a97aa..86a58b43d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -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 ] diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 59267c363..6b89d6b5a 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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] diff --git a/src/Dodge/Layout/Generate.hs b/src/Dodge/Layout/Generate.hs new file mode 100644 index 000000000..f8937ec57 --- /dev/null +++ b/src/Dodge/Layout/Generate.hs @@ -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 + + diff --git a/src/Dodge/Layout/LockAndKey.hs b/src/Dodge/Layout/LockAndKey.hs deleted file mode 100644 index f20b25052..000000000 --- a/src/Dodge/Layout/LockAndKey.hs +++ /dev/null @@ -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 diff --git a/src/Dodge/Layout/Tree.hs b/src/Dodge/Layout/Tree.hs index a32f6a4c9..7bb32cee5 100644 --- a/src/Dodge/Layout/Tree.hs +++ b/src/Dodge/Layout/Tree.hs @@ -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 diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs new file mode 100644 index 000000000..2c8590de9 --- /dev/null +++ b/src/Dodge/Layout/Tree/Annotate.hs @@ -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 diff --git a/src/Dodge/Layout/Tree/Either.hs b/src/Dodge/Layout/Tree/Either.hs new file mode 100644 index 000000000..203b079eb --- /dev/null +++ b/src/Dodge/Layout/Tree/Either.hs @@ -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 diff --git a/src/Dodge/Layout/Tree/GenerateStructure.hs b/src/Dodge/Layout/Tree/GenerateStructure.hs new file mode 100644 index 000000000..7fc969846 --- /dev/null +++ b/src/Dodge/Layout/Tree/GenerateStructure.hs @@ -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 + + diff --git a/src/Dodge/Layout/Tree/Polymorphic.hs b/src/Dodge/Layout/Tree/Polymorphic.hs new file mode 100644 index 000000000..31265ce4b --- /dev/null +++ b/src/Dodge/Layout/Tree/Polymorphic.hs @@ -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 + diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 3b7916b87..9ad8b24a5 100644 --- a/src/Dodge/RandomHelp.hs +++ b/src/Dodge/RandomHelp.hs @@ -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 diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Room.hs similarity index 92% rename from src/Dodge/Rooms.hs rename to src/Dodge/Room.hs index 81dfa33d2..b12b072c4 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Room.hs @@ -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 diff --git a/src/Dodge/Room/CheckConsistency.hs b/src/Dodge/Room/CheckConsistency.hs new file mode 100644 index 000000000..403544156 --- /dev/null +++ b/src/Dodge/Room/CheckConsistency.hs @@ -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 diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index ffce91b95..980360263 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs new file mode 100644 index 000000000..2fdb4a188 --- /dev/null +++ b/src/Dodge/Room/Procedural.hs @@ -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)