Cleanup: broken pathfinding

appDodge/Main.hs

@@ -3,7 +3,7 @@ module Main
     ) where
 import Loop
 import Dodge.Data
-import Dodge.Initialisation
+import Dodge.LevelGen
 import Dodge.Update
 import Dodge.Event
 import Dodge.Render
@@ -56,7 +56,7 @@ firstWorldLoad theConfig = do
     SDL.cursorVisible $= False
     theKeyConfig <- loadKeyConfig
     pdata <- doPreload >>= applyWorldConfig theConfig
-    w <- worldFromSeed 0
+    w <- generateWorldFromSeed 0
     return $ w & preloadData .~ pdata
         & keyConfig .~ theKeyConfig
         & config .~ theConfig

src/Dodge/Annotation.hs

@@ -0,0 +1,69 @@
+{- | Annotating tree structures with desired properties for rooms.  -}
+module Dodge.Annotation 
+    ( module Dodge.Annotation.Data
+    , module Dodge.Annotation
+    ) where
+import Dodge.RandomHelp
+import Dodge.Layout.Tree.Polymorphic
+import Dodge.Layout.Tree.Either
+import Dodge.Room
+import Dodge.Annotation.Data
+
+import Data.Tree
+import Control.Monad.State
+import System.Random
+import Control.Lens
+
+addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g])
+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 g] -> Tree [Annotation g]
+padWithCorridors (Node x xs) = Node [Corridor] [Node x (map padWithCorridors xs)]
+padSucWithCorridors :: Tree [Annotation g] -> Tree [Annotation g]
+padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs)
+
+{- Add one to three corridors between each parent-child link of a tree of annotations.  -}
+randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
+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 (Tree (Either Room Room))
+roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) 
+                                (randomiseOutLinks corridor)
+{- | Create a random room tree structure from a list of annotations.  -}
+anoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
+anoToRoomTree anos = case anos of
+    [SetLabel i randrm] -> do
+        rm <- randrm
+        return . connectRoom $ rm & rmLabel ?~ i
+    [UseLabel i randrm] -> do
+        rm <- randrm
+        return $ connectRoom $ rm & rmTakeFrom ?~ i
+    [ChainAnos ass] -> do
+        rms <- mapM anoToRoomTree ass
+        return $ linkEitherTrees rms
+    [OrAno as] -> do
+        a <- takeOne as
+        anoToRoomTree a
+    [Corridor] -> pure . Right <$> randomiseOutLinks corridor
+    [AirlockAno] -> airlock >>=  roomThenCorridor
+    [FirstWeapon] -> do
+        branchWP <- branchRectWith weaponRoom
+        blockedC <- longBlockedCorridor
+        join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
+    [EndRoom] -> fmap (pure . Right) (telRoomLev 1)
+    [StartRoom] -> startRoom
+    (SpecificRoom rt:_) -> rt
+    (BossAno cr : _) -> do
+        br <- bossRoom cr
+        branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
+    (TreasureAno crs loot : _) -> branchRectWith . fmap (pure . Left) $ lootRoom crs loot
+    _ -> do
+        w <- state $ randomR (100,400)
+        h <- state $ randomR (200,400)
+        fmap (pure . Right) . randomiseOutLinks $ roomRectAutoLinks w h

src/Dodge/Annotation/Data.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StrictData #-}
+module Dodge.Annotation.Data where
+import Dodge.Data
+import Dodge.Room
+
+import Data.Tree
+import Control.Monad.State
+import Control.Lens
+data Annotation g
+    = Lock Int
+    | Key  Int
+    | Corridor
+    | AirlockAno
+    | FirstWeapon
+    | StartRoom
+    | EndRoom
+    | OrAno [[Annotation g]]
+    | SpecificRoom (State g (Tree (Either Room Room)))
+    | BossAno Creature
+    | TreasureAno [Creature] [Item]
+    | SetLabel Int (State g Room)
+    | UseLabel Int (State g Room)
+    | ChainAnos [[Annotation g]]
+
+makeLenses ''Annotation

src/Dodge/Creature.hs

@@ -163,7 +163,9 @@ startCr = defaultCreature
     }
 {- | Items you start with.  -}
 startInventory :: IM.IntMap Item
-startInventory = IM.fromList (zip [0..20] 
+startInventory = IM.fromList $ zip [0..20] $ repeat NoItem
+stackedInventory :: IM.IntMap Item
+stackedInventory = IM.fromList (zip [0..20] 
     (
     [spreadGun
     ,tractorGun

src/Dodge/Debug/Terminal.hs

@@ -2,9 +2,12 @@ module Dodge.Debug.Terminal
     where
 import Dodge.Data
 import Dodge.Config.Data
+import Dodge.Creature
 
 import Control.Lens
 
 applyTerminalString :: String -> World -> World
 applyTerminalString "NOCLIP" w = w & config . debug_noclip %~ not
+applyTerminalString "LOADME" w = w & creatures . ix 0 . crInv .~ stackedInventory
 applyTerminalString _ w = w
+

src/Dodge/Floor.hs

@@ -7,7 +7,7 @@ import Geometry.Data
 import Dodge.Data
 import Dodge.Creature.State.Data
 import Dodge.Room
-import Dodge.Placements.Button
+import Dodge.Placement.Instance.Button
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
 import Dodge.Annotation

src/Dodge/Initialisation.hs

@@ -4,8 +4,6 @@ import Dodge.Save
 import Dodge.Data
 import Dodge.Data.SoundOrigin
 import Dodge.Creature
-import Dodge.Floor
-import Dodge.Layout
 import Dodge.Story
 import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
@@ -17,12 +15,6 @@ import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 
-worldFromSeed :: Int -> IO World
-worldFromSeed i = do
-    roomList <- layoutLevelFromSeed 0 i
-    return $ generateLevelFromRoomList roomList 
-         initialWorld -- note this uses a random generator defined elsewhere
-
 initialWorld :: World
 initialWorld = defaultWorld
     { _keys = S.empty

src/Dodge/Item/Random.hs

@@ -0,0 +1,10 @@
+module Dodge.Item.Random where
+import Dodge.Data
+import Dodge.RandomHelp
+import Dodge.Item.Weapon.BulletGuns
+
+import Control.Monad.State
+import System.Random
+
+randBlockBreakWeapon :: RandomGen g => State g Item
+randBlockBreakWeapon = takeOne [pistol,ltAutoGun,spreadGun,autoGun]

src/Dodge/Item/Weapon.hs

@@ -1,7 +1,6 @@
 {- | Definitions of weapons.
 In progress: move out effects into other modules.  -}
-module Dodge.Item.Weapon 
-    where
+module Dodge.Item.Weapon where
 import Dodge.Data
 import Dodge.Data.SoundOrigin
 import Dodge.Base

src/Dodge/Layout.hs

@@ -3,10 +3,11 @@ module Dodge.Layout
     ( generateLevelFromRoomList
     ) where
 import Dodge.Data
-import Dodge.LevelGen
+import Dodge.Path
+import Dodge.ShiftPoint
+import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.StaticWalls
-import Dodge.LevelGen.Pathing
 import Dodge.Room.Foreground
 import Dodge.Wall.Zone
 import Dodge.GameRoom

src/Dodge/LevelGen.hs

@@ -2,205 +2,17 @@
 {-# LANGUAGE RankNTypes #-}
 -- | deals with placement of objects within the world
 -- after they have had their coordinates set by the layout
-module Dodge.LevelGen 
-    ( shiftPlacement
-    , shiftPointBy
-    , invShiftPointBy
-    , placeSpot
-    ) where
+module Dodge.LevelGen where
 import Dodge.Data
-import Dodge.LevelGen.Block
-import Dodge.LevelGen.Pathing
-import Dodge.LevelGen.TriggerDoor
-import Dodge.LevelGen.Data
-import Dodge.Default.Wall
---import Dodge.RandomHelp
---import Dodge.Placements.Spot
-import Geometry
-import Geometry.Vector3D
-import Shape
-import qualified IntMapHelp as IM
-import Color
+import Dodge.Floor
+import Dodge.Layout
+import Dodge.Initialisation
+--import qualified IntMapHelp as IM
 
-import System.Random
-import Control.Monad.State
-import Control.Lens
-import qualified Data.IntSet as IS
-import Data.Bifunctor
+--import Control.Lens
 
--- when placing a placement, we update the world and the room and assign an id
--- to the placement
-placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
-placeSpot (w,rm) plmnt = case plmnt of
-    Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
-    Placement{_plSpot = PSLnk extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
-    Placement{} ->
-        let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
-            newplmnt = plmnt & plMID ?~ i
-        in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
-      where
-        recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
-                        in (wr,newplmnt:newplmnts)
-            -- (placeSpot (w',rm)) (_plIDCont plmnt i)
-    PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
-    RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
-      where
-        (plmnt', g) = runState rplmnt (_randGen w)
-  where
-    shift = _rmShift rm
-
--- this should be tidied up
-placeSpotUsingLink :: World -> Room -> Placement 
-    -> (RoomPos -> Maybe PlacementSpot)
-    -> (RoomPos -> Room -> Room)
-    -> Maybe Placement
-    -> ((World, Room), [Placement])
-placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
-    Just (ps,pos,newrmpos) -> placeSpot (w, eff pos $ rm & rmPos .~ newrmpos) (plmnt & plSpot .~ ps)
-    Nothing -> case fallback of
-        Nothing -> ((w,rm),[plmnt])
-        Just plmnt' -> placeSpot (w,rm) plmnt'
-  where
-    searchedPoss [] = error "no correct pos type for lnk placement"
-    searchedPoss (pos:poss) = case extract pos of
-        Nothing -> second (pos:) <$> searchedPoss poss
-        Just ps -> Just ( ps,pos, poss)
-
-placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
-placeSpotRoomRand rm i plmnt w =
-    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
-    in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
-
-shiftPlacement :: (Point2,Float) -> Placement -> Placement
-shiftPlacement shift plmnt = case plmnt of
-    Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
-        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
-    PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
-        (fmap (shiftPlacement shift) f)
-    RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
-
-shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
-shiftPSBy (pos,rot) ps = ps
-    & psPos %~ shiftPointBy (pos,rot)
-    & psRot %~ (+ rot)
-
--- the Int here allows for passing parameters down to other placements:
--- button ids, etc
-placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
-placeSpotID ps pt w = case pt of
-    PutTrigger cond -> placeNewInto triggers cond w
-    PutProp prop    -> plNewUpID props pjID (mvProp p rot prop) w
-    PutButton bt    -> plNewUpID buttons btID (mvButton p rot bt) w
-    PutFlIt itm     -> plNewUpID floorItems flItID (createFlIt p rot itm) w
-    PutCrit cr      -> plNewUpID creatures crID (mvCr p rot cr) w
-    PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
-    PutLS ls        -> plNewUpID lightSources lsID (mvLS p' rot ls) w
-    PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
-    RandPS rgen -> evaluateRandPS rgen ps w
-    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
-    PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
-    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
-    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
-    PutBlock{} -> error "messed up block placement somehow"
-    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
-    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
-    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
-    PutNothing -> (0,w)
-    PutID i -> (i, w)
-    PutWorldUpdate f -> (0,f ps w)
-  where 
-    p@(V2 px py) = _psPos ps
-    p' = V3 px py 0
-    rot = _psRot ps
-    doShift = shiftPointBy (p,rot)
-
-evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
-evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
-  where 
-    (evaluatedType, g) = runState rgen (_randGen w)
-
-placeWallPoly :: [Point2] -> Wall -> World -> World
-placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
-  where
-    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
-
-shiftPointBy :: (Point2,Float) -> Point2 -> Point2
-shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
-
-invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
-invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
-
-shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
-shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
-
-addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
-addWalls qs wl wls = foldr (addPane wl) wls pairs
-  where 
-    (p:ps) = orderPolygon qs
-    pairs = zip (ps ++ [p]) (p:ps)
-
-addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
-addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
-  where
-    wlid = IM.newKey wls
-
--- | generalised way of putting a new item into a lensed intmap, returning the
--- new index as well
-placeNewInto :: ALens' World (IM.IntMap a)
-    -> a
-    -> World
-    -> (Int,World)
-placeNewInto l x w = (i,w & l #%~ IM.insert i x)
-  where
-    i = IM.newKey $ w ^# l
-
--- | place an new object into an intmap and update its id
-plNewUpID :: ALens' World (IM.IntMap a)
-    -> ALens' a Int
-    -> a
-    -> World
-    -> (Int,World)
-plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
-  where
-    i = IM.newKey $ w ^# l
-
-mvProp :: Point2 -> Float -> Prop -> Prop
-mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
-
-mvButton :: Point2 -> Float -> Button -> Button
-mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
-
-{- Creates a floor item at a given point.-}
-createFlIt :: Point2 -> Float -> Item -> FloorItem
-createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }
-
-mvPP :: Point2 -> Float -> PressPlate -> PressPlate
-mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
-
-mvCr :: Point2 -> Float -> Creature -> Creature
-mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
-
-placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
-placeMachine color wallpoly mc p rot w = (mcid
-    , w & machines  %~ addMc
-        & walls     %~ placeMachineWalls color wallpoly mcid wlid
-    )
-  where 
-    mcid = IM.newKey $ _machines w
-    wlid = IM.newKey $ _walls w
-    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
-    addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
-
--- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
-placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
-placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
-  where
-    f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
-    baseWall = defaultMachineWall 
-        & wlColor .~ col
-        & wlStructure . wlStMachine .~ mcid
-
-mvLS :: Point3 -> Float -> LightSource -> LightSource
-mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
-  where
-    startPos = onXY (rotateV rot) $ _lsPos ls
+generateWorldFromSeed :: Int -> IO World
+generateWorldFromSeed i = do
+    roomList <- layoutLevelFromSeed 0 i
+    return $ generateLevelFromRoomList roomList 
+         initialWorld -- note this uses a random generator defined elsewhere

src/Dodge/LevelGen/Pathing.hs

@@ -1,32 +0,0 @@
-module Dodge.LevelGen.Pathing
-    ( removePathsCrossing
-    , pairsToGraph
-    )
-    where
-import Dodge.Data
-import Dodge.Base
-import Dodge.Zone
-import Geometry
-
-import Control.Lens
-import Data.Maybe
-import Data.List
-import qualified Data.IntMap.Strict as IM
-import Data.Graph.Inductive hiding ((&))
---import Data.Graph.Inductive.NodeMap
-
-pairsToGraph :: (Ord a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
-pairsToGraph f pairs = 
-    let nodes' = nub (map fst pairs ++ map snd pairs)
-        pairs' = map (\(x,y)->(x,y,f x y)) pairs
-    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs'
-
-removePathsCrossing :: Point2 -> Point2 -> World -> World
-removePathsCrossing a b w = w
-    & pathGraph  .~ newGraph 
-    & pathGraphP .~ pg'
-    & pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
-  where 
-    pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
-    insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-    newGraph = pairsToGraph dist pg'

src/Dodge/Menu.hs

@@ -12,10 +12,10 @@ import Dodge.Config.Data
 import Dodge.Config.Update
 import SDL
 import SDL.Internal.Numbered
-import Dodge.Initialisation
 import Preload.Update
 import Dodge.Base.Window
 import Dodge.SoundLogic
+import Dodge.LevelGen
 
 import Control.Lens
 import System.Random
@@ -160,7 +160,7 @@ pauseMenuOptions =
 startNewGame :: World -> Maybe World
 startNewGame w = Just $ w
     & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
-    & sideEffects .~ const (worldFromSeed i <&> keyConfig .~ _keyConfig w <&> config .~ _config w
+    & sideEffects .~ const (generateWorldFromSeed i <&> keyConfig .~ _keyConfig w <&> config .~ _config w
         <&> preloadData .~ _preloadData w) -- this kills save games etc...
   where
     i = fst $ random (_randGen w)

src/Dodge/Path.hs

@@ -3,18 +3,24 @@ module Dodge.Path
     --, pointTowardsImpulse'
     , makePathBetween
     , makePathBetweenPs
+    , removePathsCrossing
+    , pairsToGraph
     )
     where
 import Dodge.Data
 import Dodge.Base.Collide
 import Dodge.Zone
 import Geometry.Data
+import Dodge.Base
+import Geometry
 
-import Data.List
+import Control.Lens
 import Data.Maybe
+import Data.List
+import qualified Data.IntMap.Strict as IM
+import Data.Graph.Inductive hiding ((&))
 --import Data.Graph.Inductive.PatriciaTree
-import Data.Graph.Inductive.Query.SP
-import Data.Graph.Inductive.Graph hiding ((&))
+--import Data.Graph.Inductive.Graph hiding ((&))
 
 makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
 makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
@@ -73,3 +79,19 @@ pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a
 --    case ns of 
 --        [] -> return Nothing
 --        _  -> return $ Just $ ns !! i
+--
+pairsToGraph :: (Ord a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
+pairsToGraph f pairs = 
+    let nodes' = nub (map fst pairs ++ map snd pairs)
+        pairs' = map (\(x,y)->(x,y,f x y)) pairs
+    in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs'
+
+removePathsCrossing :: Point2 -> Point2 -> World -> World
+removePathsCrossing a b w = w
+    & pathGraph  .~ newGraph 
+    & pathGraphP .~ pg'
+    & pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
+  where 
+    pg' = filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
+    insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
+    newGraph = pairsToGraph dist pg'

src/Dodge/Placement.hs

@@ -0,0 +1 @@
+module Dodge.Placement where

src/Dodge/Placement/Instance.hs

@@ -0,0 +1,17 @@
+module Dodge.Placement.Instance
+    ( module Dodge.Placement.Instance.Door
+    , module Dodge.Placement.Instance.LightSource
+    , module Dodge.Placement.Instance.Wall
+    , module Dodge.Placement.Instance.Button
+    , module Dodge.Placement.Instance.Turret
+    , module Dodge.Placement.Instance.Sensor
+    , module Dodge.Placement.Instance.Creature
+    )
+    where
+import Dodge.Placement.Instance.Door
+import Dodge.Placement.Instance.LightSource
+import Dodge.Placement.Instance.Wall
+import Dodge.Placement.Instance.Button
+import Dodge.Placement.Instance.Turret
+import Dodge.Placement.Instance.Sensor
+import Dodge.Placement.Instance.Creature

src/Dodge/Placement/Instance/Button.hs

@@ -1,4 +1,4 @@
-module Dodge.Placements.Button where
+module Dodge.Placement.Instance.Button where
 import Dodge.Data
 import Color
 import Geometry
@@ -6,7 +6,7 @@ import Geometry.Vector3D
 import Dodge.LevelGen.Data
 import Dodge.Default
 import Dodge.LevelGen.Switch
-import Dodge.Placements.LightSource
+import Dodge.Placement.Instance.LightSource
 import Dodge.PlacementSpot
 import ShapePicture
 

src/Dodge/Placement/Instance/Creature.hs

@@ -0,0 +1,8 @@
+module Dodge.Placement.Instance.Creature where
+import Dodge.LevelGen.Data
+import Dodge.RandomHelp
+import Dodge.Creature.ArmourChase
+import Dodge.Creature.ChaseCrit
+
+randC1 :: PSType
+randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit

src/Dodge/Placement/Instance/Door.hs

@@ -1,5 +1,4 @@
-module Dodge.Placements.Door
-    where
+module Dodge.Placement.Instance.Door where
 import Dodge.Data
 import Dodge.Base
 import Color

src/Dodge/Placement/Instance/LightSource.hs

@@ -1,4 +1,4 @@
-module Dodge.Placements.LightSource where
+module Dodge.Placement.Instance.LightSource where
 import Dodge.Data
 import Dodge.LightSources.Lamp
 import Dodge.LevelGen.Data

src/Dodge/Placement/Instance/Sensor.hs

@@ -1,4 +1,4 @@
-module Dodge.Placements.Sensor
+module Dodge.Placement.Instance.Sensor
     ( lightSensor
     ) where
 import Color

src/Dodge/Placement/Instance/Turret.hs

@@ -1,4 +1,4 @@
-module Dodge.Placements.Turret where
+module Dodge.Placement.Instance.Turret where
 import Color
 import Dodge.Data
 import Dodge.LevelGen.Data

src/Dodge/Placement/Instance/Wall.hs

@@ -1,4 +1,4 @@
-module Dodge.Placements.Wall
+module Dodge.Placement.Instance.Wall
     where
 import Dodge.Data
 import Color

src/Dodge/Placement/PlaceSpot.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+-- | deals with placement of objects within the world
+-- after they have had their coordinates set by the layout
+module Dodge.Placement.PlaceSpot
+    ( shiftPlacement
+    , shiftPointBy
+    , invShiftPointBy
+    , placeSpot
+    ) where
+import Dodge.Data
+import Dodge.Path
+import Dodge.Placement.PlaceSpot.Block
+import Dodge.Placement.PlaceSpot.TriggerDoor
+import Dodge.LevelGen.Data
+import Dodge.Default.Wall
+import Dodge.ShiftPoint
+--import Dodge.RandomHelp
+--import Dodge.Placements.Spot
+import Geometry
+import Geometry.Vector3D
+import Shape
+import qualified IntMapHelp as IM
+import Color
+
+import System.Random
+import Control.Monad.State
+import Control.Lens
+import qualified Data.IntSet as IS
+import Data.Bifunctor
+
+-- when placing a placement, we update the world and the room and assign an id
+-- to the placement
+placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] )
+placeSpot (w,rm) plmnt = case plmnt of
+    Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
+    Placement{_plSpot = PSLnk extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
+    Placement{} ->
+        let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w
+            newplmnt = plmnt & plMID ?~ i
+        in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt newplmnt)
+      where
+        recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl
+                        in (wr,newplmnt:newplmnts)
+            -- (placeSpot (w',rm)) (_plIDCont plmnt i)
+    PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
+    RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt'
+      where
+        (plmnt', g) = runState rplmnt (_randGen w)
+  where
+    shift = _rmShift rm
+
+-- this should be tidied up
+placeSpotUsingLink :: World -> Room -> Placement 
+    -> (RoomPos -> Maybe PlacementSpot)
+    -> (RoomPos -> Room -> Room)
+    -> Maybe Placement
+    -> ((World, Room), [Placement])
+placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
+    Just (ps,pos,newrmpos) -> placeSpot (w, eff pos $ rm & rmPos .~ newrmpos) (plmnt & plSpot .~ ps)
+    Nothing -> case fallback of
+        Nothing -> ((w,rm),[plmnt])
+        Just plmnt' -> placeSpot (w,rm) plmnt'
+  where
+    searchedPoss [] = error "no correct pos type for lnk placement"
+    searchedPoss (pos:poss) = case extract pos of
+        Nothing -> second (pos:) <$> searchedPoss poss
+        Just ps -> Just ( ps,pos, poss)
+
+placeSpotRoomRand :: Room -> Int -> Placement -> World -> ((World,Room),[Placement])
+placeSpotRoomRand rm i plmnt w =
+    let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
+    in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
+
+shiftPlacement :: (Point2,Float) -> Placement -> Placement
+shiftPlacement shift plmnt = case plmnt of
+    Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
+        & plIDCont %~ fmap (fmap $ shiftPlacement shift)
+    PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p)
+        (fmap (shiftPlacement shift) f)
+    RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl
+
+shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
+shiftPSBy (pos,rot) ps = ps
+    & psPos %~ shiftPointBy (pos,rot)
+    & psRot %~ (+ rot)
+
+-- the Int here allows for passing parameters down to other placements:
+-- button ids, etc
+placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
+placeSpotID ps pt w = case pt of
+    PutTrigger cond -> placeNewInto triggers cond w
+    PutProp prop    -> plNewUpID props pjID (mvProp p rot prop) w
+    PutButton bt    -> plNewUpID buttons btID (mvButton p rot bt) w
+    PutFlIt itm     -> plNewUpID floorItems flItID (createFlIt p rot itm) w
+    PutCrit cr      -> plNewUpID creatures crID (mvCr p rot cr) w
+    PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
+    PutLS ls        -> plNewUpID lightSources lsID (mvLS p' rot ls) w
+    PutPressPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
+    RandPS rgen -> evaluateRandPS rgen ps w
+    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
+    PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w
+    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
+    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
+    PutBlock{} -> error "messed up block placement somehow"
+    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
+    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
+    PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
+    PutNothing -> (0,w)
+    PutID i -> (i, w)
+    PutWorldUpdate f -> (0,f ps w)
+  where 
+    p@(V2 px py) = _psPos ps
+    p' = V3 px py 0
+    rot = _psRot ps
+    doShift = shiftPointBy (p,rot)
+
+evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
+evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
+  where 
+    (evaluatedType, g) = runState rgen (_randGen w)
+
+placeWallPoly :: [Point2] -> Wall -> World -> World
+placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl)
+  where
+    rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
+
+
+addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
+addWalls qs wl wls = foldr (addPane wl) wls pairs
+  where 
+    (p:ps) = orderPolygon qs
+    pairs = zip (ps ++ [p]) (p:ps)
+
+addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
+addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
+  where
+    wlid = IM.newKey wls
+
+-- | generalised way of putting a new item into a lensed intmap, returning the
+-- new index as well
+placeNewInto :: ALens' World (IM.IntMap a)
+    -> a
+    -> World
+    -> (Int,World)
+placeNewInto l x w = (i,w & l #%~ IM.insert i x)
+  where
+    i = IM.newKey $ w ^# l
+
+-- | place an new object into an intmap and update its id
+plNewUpID :: ALens' World (IM.IntMap a)
+    -> ALens' a Int
+    -> a
+    -> World
+    -> (Int,World)
+plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i))
+  where
+    i = IM.newKey $ w ^# l
+
+mvProp :: Point2 -> Float -> Prop -> Prop
+mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
+
+mvButton :: Point2 -> Float -> Button -> Button
+mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a ))
+
+{- Creates a floor item at a given point.-}
+createFlIt :: Point2 -> Float -> Item -> FloorItem
+createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm }
+
+mvPP :: Point2 -> Float -> PressPlate -> PressPlate
+mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
+
+mvCr :: Point2 -> Float -> Creature -> Creature
+mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
+
+placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
+placeMachine color wallpoly mc p rot w = (mcid
+    , w & machines  %~ addMc
+        & walls     %~ placeMachineWalls color wallpoly mcid wlid
+    )
+  where 
+    mcid = IM.newKey $ _machines w
+    wlid = IM.newKey $ _walls w
+    wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
+    addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
+
+-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
+placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
+placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
+  where
+    f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
+    baseWall = defaultMachineWall 
+        & wlColor .~ col
+        & wlStructure . wlStMachine .~ mcid
+
+mvLS :: Point3 -> Float -> LightSource -> LightSource
+mvLS (V3 x y z) rot ls = ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot}
+  where
+    startPos = onXY (rotateV rot) $ _lsPos ls

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -1,13 +1,13 @@
 {- | Creation, update and destruction of destructible walls.  -}
-module Dodge.LevelGen.Block 
+module Dodge.Placement.PlaceSpot.Block 
     ( placeBlock
     , placeLineBlock
     )
     where
 import Dodge.Data
+import Dodge.Path
 import Dodge.Base
 import Dodge.Zone
-import Dodge.LevelGen.Pathing
 import Dodge.Default.Wall
 import Geometry
 import qualified IntMapHelp as IM

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -1,5 +1,5 @@
 --{-# LANGUAGE BangPatterns #-}
-module Dodge.LevelGen.TriggerDoor
+module Dodge.Placement.PlaceSpot.TriggerDoor
     ( placeDoor
     , placeSlideDoor
     ) where

src/Dodge/Placements.hs

@@ -1,15 +0,0 @@
-module Dodge.Placements
-    ( module Dodge.Placements.Door
-    , module Dodge.Placements.LightSource
-    , module Dodge.Placements.Wall
-    , module Dodge.Placements.Button
-    , module Dodge.Placements.Turret
-    , module Dodge.Placements.Sensor
-    )
-    where
-import Dodge.Placements.Door
-import Dodge.Placements.LightSource
-import Dodge.Placements.Wall
-import Dodge.Placements.Button
-import Dodge.Placements.Turret
-import Dodge.Placements.Sensor

src/Dodge/Room/Airlock.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TupleSections #-}
 {- Rooms that contain two doors and a switch alternating both.  -}
 module Dodge.Room.Airlock where
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Dodge.Room.Foreground
 import Dodge.Default.Room
 import Dodge.Default.Wall

src/Dodge/Room/Boss.hs

@@ -3,7 +3,7 @@ module Dodge.Room.Boss
   where
 import Dodge.Data
 import Dodge.Default.Room
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Dodge.LevelGen.Data
 import Dodge.Room.Procedural
 import Dodge.Room.Link

src/Dodge/Room/Corridor.hs

@@ -5,7 +5,7 @@ import Dodge.LevelGen.Data
 import Dodge.Default.Room
 --import Dodge.LevelGen.Data
 --import Dodge.LightSources.Lamp
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Geometry
 import Tile
 

src/Dodge/Room/Door.hs

@@ -4,7 +4,7 @@ module Dodge.Room.Door
 import Geometry
 import Dodge.Data
 import Dodge.Default.Room
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Color
 
 import Data.Maybe

src/Dodge/Room/Furniture.hs

@@ -1,7 +1,7 @@
 module Dodge.Room.Furniture
     where
 import Dodge.Data
-import Dodge.LevelGen
+import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
 import Dodge.Default.Wall

src/Dodge/Room/Link.hs

@@ -9,6 +9,8 @@ module Dodge.Room.Link
     , shiftRoomBy
     , shiftLinkBy
     , doRoomShift
+    , sortOutLinksOn
+    , filterSortOutLinksOn
     , randomiseAllLinks
     , filterLinks
     , changeLinkTo
@@ -18,7 +20,7 @@ module Dodge.Room.Link
     , invShiftLinkBy
     , finalLinksUpdate
     ) where
-import Dodge.LevelGen
+import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
 import Dodge.RandomHelp
 import Geometry
@@ -34,6 +36,19 @@ randomiseOutLinks r = do
     newLinks <- shuffle $ init $ _rmLinks r
     return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
 
+sortOutLinksOn :: Ord b => ((Point2,Float) -> b) -> Room -> Room
+sortOutLinksOn f = rmLinks %~ dosort
+  where
+    dosort [] = []
+    dosort xs = sortOn f (init xs) ++ [last xs]
+
+filterSortOutLinksOn :: Ord b => ((Point2,Float) -> Bool) -> ((Point2,Float) -> b) -> Room -> Room
+filterSortOutLinksOn test f = rmLinks %~ dosort
+  where
+    dosort [] = []
+    dosort xs = let (ys,zs) = partition test (init xs)
+        in sortOn f ys ++ zs ++ [last xs]
+
 {- Shuffle all links of a room randomly. -}
 randomiseAllLinks :: RandomGen g => Room -> State g Room
 randomiseAllLinks r = do

src/Dodge/Room/LongDoor.hs

@@ -6,7 +6,7 @@ module Dodge.Room.LongDoor
 import Dodge.Data
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Dodge.Room.Link
 import Dodge.Room.Procedural
 --import Dodge.Layout.Tree.Either
@@ -140,5 +140,3 @@ slowDoorRoom = do
     proom <- southPillarsRoom x y h
     addButtonSlowDoor x h (proom & rmPmnts %~ (++ (crits ++ barrels ++ lsources)))
 
-randC1 :: PSType
-randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit

src/Dodge/Room/Procedural.hs

@@ -11,7 +11,7 @@ module Dodge.Room.Procedural
     ) where
 import Dodge.Data
 import Dodge.Default.Wall
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Dodge.Room.Link
 import Dodge.Room.Path
 import Dodge.Default.Room
@@ -21,7 +21,7 @@ import Dodge.Room.Foreground
 import Dodge.Item.Weapon
 import Dodge.Item.Weapon.Launcher
 import Dodge.RandomHelp
-import Dodge.LevelGen
+import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
 import Dodge.Creature

src/Dodge/Room/RoadBlock.hs

@@ -5,12 +5,12 @@ import Geometry
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
 import Dodge.Room.Link
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Dodge.Room.Corridor
 import Dodge.Room.Furniture
 --import Dodge.LevelGen.Data
 --import Dodge.Default.Wall
---import Dodge.RandomHelp
+import Dodge.RandomHelp
 import Dodge.Creature
 import Dodge.Layout.Tree.Polymorphic
 
@@ -75,6 +75,19 @@ blockedCorridor = do
             ]
     sequence $ treeFromPost [] $ return $ Right $ set rmPmnts plmnts corridor
 
+-- | A single corridor with a destructible block blocking it.
+blockedCorridor' :: RandomGen g => State g Room
+blockedCorridor' = do
+    r <- state $ randomR (0,pi)
+    theblocks <- takeOne [ [sPS (V2 20 40) r $ PutBlock [1] thecol $ reverse $ square 10]
+        ,   [ sPS (V2 5 40) r $ PutBlock [1] thecol $ reverse $ square 10
+            , sPS (V2 35 40) (r+0.5) $ PutBlock [1] thecol $ reverse $ square 10
+            ]
+        ]
+    return $ corridor & rmPmnts .~ theblocks
+  where
+    thecol = V4 (150/256) ( 75/256)  0 ( 250/256)
+
 lasTunnel :: Room
 lasTunnel = defaultRoom
     { _rmPolys  = polys

src/Dodge/Room/Room.hs

@@ -9,14 +9,13 @@ import Dodge.RandomHelp
 import Dodge.Default.Wall
 import Dodge.Layout.Tree.Polymorphic
 import Dodge.Layout.Tree.Either
-import Dodge.Placements
+import Dodge.Placement.Instance
 --import Dodge.LevelGen.Data
 import Dodge.Room.Procedural
 import Dodge.Room.Corridor
 import Dodge.Room.Link
 import Dodge.Room.Door
 import Dodge.Room.Airlock
-import Dodge.Room.LongDoor
 import Geometry
 import Picture
 import Tile

src/Dodge/Room/Start.hs

@@ -1,14 +1,18 @@
 module Dodge.Room.Start where
 import Dodge.LevelGen.Data
+import Dodge.Data
 import Dodge.Room.Door
 import Dodge.Room.Link
 import Dodge.Room.Procedural
 import Dodge.Room.Foreground
 import Dodge.Room.Furniture
-import Dodge.Placements
+import Dodge.Room.RoadBlock
+import Dodge.Placement.Instance
 import Dodge.Layout.Tree.Polymorphic
+import Dodge.Item.Random
 --import Dodge.LevelGen.Data
 import Geometry.Data
+import Padding
 import Color
 import Shape
 
@@ -20,17 +24,49 @@ import System.Random
 
 rezBox :: Room
 --rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 
-rezBox = roomRect 40 40 1 1 
-    & rmPmnts .~ [ spanColLightI (V3 0 0.5 0) 95 (V2 0 1) (V2 40 1) ]
+rezBox = roomRect 40 60 1 1 
+    & rmPmnts .~ [ spanColLightI (V3 0 0 0.5) 95 (V2 0 1) (V2 40 1) ]
 
 rezInvBox :: Room
-rezInvBox = roomRect 40 40 1 1 
-    & rmPmnts .~ [ spanColLightI (V3 0 0.5 0) 95 (V2 0 39) (V2 40 39) ]
+rezInvBox = roomRect 40 60 1 1 
+    & rmPmnts .~ [ spanColLightI (V3 0 0 0.5) 95 (V2 0 59) (V2 40 59) ]
+
+crRezBox :: Room
+crRezBox = rezInvBox -- & rmPmnts %~ (sPS (V2 20 0) pi randC1 :)
+
+wpRezBox :: Item -> Room
+wpRezBox wp = rezInvBox & rmPmnts %~ (sPS (V2 15 30) 1 (PutFlIt wp) :)
 
 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = do
     w <- state $ randomR (100,400)
-    h <- state $ randomR (100,200)
+    h <- state $ randomR (40,40)
+    theweapon <- randBlockBreakWeapon
+    let bottomEdgeTest (V2 _ y,_) = y < 1
+        bottomLeftTest (V2 x y,_) = y < 1 && x < 21
+    centralRoom <- filterSortOutLinksOn bottomEdgeTest ((\(V2 a b) -> (b,a)) . fst) <$>
+            (randomiseOutLinks =<< changeLinkTo bottomLeftTest 
+                    ((roomRectAutoLinks w h) {_rmPmnts = []}))
+    let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom
+    i <- state $ randomR (0,n-3)
+    j <- state $ randomR (i,n-2)
+    blcor <- blockedCorridor'
+    let rezrooms = map adddoor 
+            $ insertAt i (wpRezBox theweapon) 
+            $ insertAt j crRezBox 
+            $ replicate (n-3) rezInvBox
+    return $ treeFromTrunk [Left rezBox
+        , Left door
+        ] 
+        (Node (Left centralRoom) (rezrooms ++ [onwardtree blcor]))
+  where
+    adddoor rm = treeFromPost [Left door] (Left rm)
+    onwardtree blcor = treeFromPost [Left door] (Right blcor)
+
+randomRezBoxes :: RandomGen g => State g (Tree (Either Room Room))
+randomRezBoxes = do
+    w <- state $ randomR (100,400)
+    h <- state $ randomR (40,40)
     let bottomEdgeTest (V2 _ y,_) = y < 1
     centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest 
         ((roomRectAutoLinks w h) {_rmPmnts = []})

src/Dodge/Room/Teleport.hs

@@ -5,7 +5,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.LevelGen.Data
 import Dodge.Room.Procedural
-import Dodge.Placements
+import Dodge.Placement.Instance
 --import Dodge.LevelGen.Data
 import Geometry
 import Picture

src/Dodge/Room/Treasure.hs

@@ -5,7 +5,7 @@ Typically dead ends.
 module Dodge.Room.Treasure
     where
 import Dodge.Data
-import Dodge.Placements
+import Dodge.Placement.Instance
 import Dodge.Default.Room
 import Dodge.LevelGen.Data
 import Geometry

src/Dodge/ShiftPoint.hs

@@ -0,0 +1,12 @@
+module Dodge.ShiftPoint where
+import Geometry
+import Geometry.Vector3D
+
+shiftPointBy :: (Point2,Float) -> Point2 -> Point2
+shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
+
+invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
+invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
+
+shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
+shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)

src/Padding.hs

@@ -7,6 +7,7 @@ module Padding
     , rotU
     , rotD
     , rotListAt
+    , insertAt
     )
     where
 leftPad :: Int -> a -> [a] -> [a]
@@ -46,3 +47,6 @@ rotListAt x' xs = f x' xs []
         | y == x    = y:ys ++ zs
         | otherwise = f x ys (y:zs)
     f _ [] zs = zs
+
+insertAt :: Int -> a -> [a] -> [a]
+insertAt i x xs = let (ys,zs) = splitAt i xs in ys ++ [x] ++ zs