Add tree structure generation

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

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)
+

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

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
                    ]

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
+  where 
-          plmnts = concatMap _rmPS $ flatten tr
+    tr = evalState t $ _randGen w
-          g = _randGen w
+    plmnts = concatMap _rmPS $ flatten tr
-          path = pairsToGraph dist pairGraph
+    g = _randGen w
-          pairGraph = makePath tr
+    path = pairsToGraph dist pairGraph
-          insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+    pairGraph = makePath tr
-          pinc = M.fromList $ pairsToIncidence pairGraph
+    insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-          zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
+    pinc = M.fromList $ pairsToIncidence pairGraph
-                        w
+    zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
-          wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+                  w
-                            = insertIMInZone x y wlid wl
+    wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
-                        | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+                      = insertIMInZone x y wlid wl
-            where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
+                  | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
-                  wlid  = _wlID wl
+      where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
-                  ips = map zoneOfPoint $ divideLine (2*zoneSize) (_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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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/Room.hs

@@ -1,9 +1,8 @@
-module Dodge.Rooms 
+{- 
---    ( module Dodge.Rooms
+Specification of individual rooms.
---    , module Dodge.Rooms.Data
+-}
---    )
+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

@@ -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,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

@@ -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)