Continue placement refactor

src/Dodge/Default/Room.hs

@@ -1,5 +1,6 @@
 module Dodge.Default.Room
     where
+import Geometry.Data
 import Dodge.Room.Data
 
 defaultRoom :: Room
@@ -11,4 +12,5 @@ defaultRoom = Room
     , _rmBound  = []
     , _rmFloor  = []
     , _rmName   = "defaultRoom"
+    , _rmShift  = (V2 0 0 , 0)
     }

src/Dodge/Layout.hs

@@ -31,7 +31,7 @@ import System.Random
 --import Data.List
 --import Data.Maybe
 import Data.Tree
-import Data.Graph.Inductive.Graph (labNodes)
+--import Data.Graph.Inductive.Graph (labNodes)
 --import qualified Data.Map as M
 import Data.Foldable
 import qualified Control.Foldl as L
@@ -43,7 +43,7 @@ generateLevelFromRoomList gr w
     . setupWorldBounds
 --    . initializeStaticWalls
 --    . setupForegroundEdgeVerxs
-    . placeSpots plmnts
+    . flip (foldr placeSpot') plmnts
 --    . addRoomPolyDecorations rs
 --    . addRoomLinkDecorations rs
     $ w { _walls = wallsFromRooms rs
@@ -55,7 +55,7 @@ generateLevelFromRoomList gr w
   where
     path = pairsToGraph dist pairPath
     pairPath = concatMap _rmPath rs
-    plmnts = concatMap _rmPS rs
+    plmnts = concat $ map (\r -> map ((,) (_rmShift r)) (_rmPS r)) rs
     rs = zipWith addTile zs rs'
     zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w
     rs' = evalState gr $ _randGen w
@@ -79,23 +79,6 @@ setupWorldBounds w = w
 polyhedrasToEdges :: [Polyhedra] -> [Point3]
 polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
 
--- | connects a collection (tree) of rooms together
-generateFromTree :: State StdGen (Tree Room) -> World -> World
-generateFromTree t w = updateWallZoning $ placeSpots plmnts 
-   $ w  {_walls         = wallsFromTree tr
-        ,_pathGraph     = path
-        ,_pathGraphP    = pairGraph
-        ,_pathPoints    = foldl' (flip insertPoint) IM.empty (labNodes path) 
-        }
-  where 
-    tr = evalState t $ _randGen w
-    plmnts = concatMap _rmPS $ flatten tr
-    path = pairsToGraph dist pairGraph
-    pairGraph = makePath tr
-    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
-    --pinc = M.fromList $ pairsToIncidence pairGraph
-
-
 updateWallZoning :: World -> World
 updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
   where

src/Dodge/LevelGen.hs

@@ -9,7 +9,6 @@ module Dodge.LevelGen
     , makeSwitch
     ) where
 import Dodge.Data
---import Dodge.Room.Data
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.LineBlock
 import Dodge.LevelGen.Pathing
@@ -21,26 +20,22 @@ import Dodge.LevelGen.Data
 import Geometry
 import Geometry.Vector3D
 import Shape
---import Geometry.Data
 import Picture
 import qualified IntMapHelp as IM
 
---import System.Random
 import Control.Monad.State
---import Control.Applicative
 import Control.Lens
-import Data.List.Extra
---import Data.Function
---import Data.Maybe
---import qualified Data.Set as S
---import qualified Data.Map as M
 
-placeSpots :: [Placement] -> World -> World
-placeSpots pss w = foldr (placeSpot . _placementSpot) w simplePlacements
-  where
-    (simplePlacements, idPlacements ) = partition isSimple pss
-    isSimple SimplePlacement{} = True
-    isSimple _ = False
+placeSpot' :: ((Point2,Float) , Placement) -> World -> World
+placeSpot' (shift, plmnt) = placeSpot $ shiftPSBy' shift (_placementSpot plmnt)
+
+shiftPSBy'
+    :: (Point2,Float)
+    -> PlacementSpot
+    -> PlacementSpot
+shiftPSBy' (pos,rot) ps = ps
+    & psPos %~ shiftPointBy (pos,rot)
+    & psRot %~ (+ rot)
 
 placeSpot :: PlacementSpot -> World -> World
 placeSpot ps w = case _psType ps of

src/Dodge/LevelGen/Data.hs

@@ -49,16 +49,12 @@ data PlacementSpot = PS
     , _psRot :: Float
     , _psType :: PSType
     }
-data Placement
-    = SimplePlacement {_placementSpot :: PlacementSpot }
-    | IDPlacement {_placementSpot :: PlacementSpot, _idPlacement :: Int -> Placement }
---    | GroupedPlacement
---        {_groupPlacementID :: Int
---        ,_groupUpdate :: World -> [Placement] -> World
---        ,_placementSpot :: PlacementSpot
---        }
+data Placement = Placement 
+    { _placementSpot :: PlacementSpot
+    , _idPlacement :: Int -> Maybe Placement 
+    }
 sPS :: Point2 -> Float -> PSType -> Placement
-sPS p a = SimplePlacement . PS p a
+sPS p a pt = Placement (PS p a pt) (const Nothing)
 makeLenses ''PSType
 makeLenses ''PlacementSpot
 makeLenses ''Placement

src/Dodge/LevelGen/SwarmPlacement.hs

@@ -2,17 +2,17 @@ module Dodge.LevelGen.SwarmPlacement
     ( --swarmPS
     )
     where
-import Dodge.Data
-import Dodge.LevelGen.Data
-import Dodge.Creature.State.Data
---import Geometry
-import Geometry.ConvexPoly
-import Geometry.Data
-import qualified IntMapHelp as IM
-
-import Data.List
-import qualified Data.IntSet as IS
-import Control.Lens
+--import Dodge.Data
+--import Dodge.LevelGen.Data
+--import Dodge.Creature.State.Data
+----import Geometry
+--import Geometry.ConvexPoly
+--import Geometry.Data
+--import qualified IntMapHelp as IM
+--
+--import Data.List
+--import qualified Data.IntSet as IS
+--import Control.Lens
 
 --swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
 --swarmPS i p a cr = GroupedPlacement

src/Dodge/Room/Data.hs

@@ -1,17 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.Room.Data
-    ( Room (..)
-    , rmPolys
-    , rmLinks
-    , rmPath
-    , rmPS
-    , rmBound
-    , rmFloor
-    , rmName
-    ) where
+    where
 import Dodge.LevelGen.Data
---import Geometry
 import Geometry.Data
 import Data.Tile
 
@@ -33,5 +24,6 @@ data Room = Room
     , _rmBound  :: [ [Point2] ]
     , _rmFloor  :: [Tile]
     , _rmName   :: String
+    , _rmShift  :: (Point2, Float)
     }
 makeLenses ''Room

src/Dodge/Room/Link.hs

@@ -63,14 +63,14 @@ shiftRoomToLink l r
     r
   where 
     (p,a) = last $ _rmLinks r
-
+-- NOTE placements are shifted by the room shift
 shiftRoomBy :: (Point2,Float) -> Room -> Room
 shiftRoomBy shift r = r
     & rmPolys %~ fmap (map (shiftPointBy shift))
     & rmLinks %~ fmap (shiftLinkBy shift)
     & rmPath  %~ map (shiftPathPointBy shift)
-    & rmPS    %~ fmap (shiftPSBy shift)
     & rmBound %~ fmap (map (shiftPointBy shift))
+    & rmShift %~ shiftLinkBy shift
     & rmFloor %~ map 
         ( (tilePoly %~ map (shiftPointBy shift))
         . (tileZero %~ shiftPointBy shift    )

src/Dodge/Room/LongDoor.hs

@@ -24,7 +24,7 @@ import Control.Lens
 import Control.Monad.State
 import Data.Tree
 import qualified Data.Map as M
-import qualified Data.IntMap as IM
+--import qualified Data.IntMap as IM
 
 twinSlowDoorRoom 
     :: Int      -- ^ Door id
@@ -56,7 +56,7 @@ twinSlowDoorRoom drid w h x = defaultRoom
     , _rmName   = "twinSlowDoorRoom"
     }
   where
-    drmoving w' = True -- DoorHalfway == _drStatus (_doors w' IM.! drid)
+    drmoving _ = True -- DoorHalfway == _drStatus (_doors w' IM.! drid)
     lampHeight = 41
     ps = 
         [rectNSWE h    0 (-w) w

src/Dodge/Room/Placement.hs

@@ -30,33 +30,33 @@ Places a line of blocks between two points.
 Width 9, also extends out from each point by 9.
  -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = SimplePlacement $ PS
+blockLine a b = Placement PS
     { _psPos    = V2 0 0
     , _psRot    = 0
     , _psType   = PutLineBlock baseBlockPane 9 9 a b
-    }
+    } (const Nothing)
 
 {-
 Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = SimplePlacement $ PS 
+windowLine a b = Placement PS 
     { _psPos    = V2 0 0
     , _psRot    = 0
     , _psType   = PutLineBlock baseWindowPane 8 8 a b
-    }
+    } (const Nothing)
 
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = SimplePlacement $ PS 
+crystalLine a b = Placement PS 
     { _psPos    = V2 0 0
     , _psRot    = 0
     , _psType   = PutWall ps defaultCrystalWall
-    }
+    } (const Nothing)
   where
     ps = 
         [ a +.+ left +.+ up
@@ -70,11 +70,11 @@ crystalLine a b = SimplePlacement $ PS
 Depth 15, does not extend wider than points.
  -}
 wallLine :: Point2 -> Point2 -> Placement
-wallLine a b = SimplePlacement $ PS 
+wallLine a b = Placement PS 
     { _psPos    = V2 0 0
     , _psRot    = 0
     , _psType   = PutWall ps defaultWall
-    }
+    } (const Nothing)
   where
     ps = 
         [ a  +.+ up

src/Dodge/Room/Procedural.hs

@@ -180,7 +180,7 @@ fillNothingPlacement :: PSType -> Room -> Room
 fillNothingPlacement pst r =
     r & rmPS %~ replaceNothingWith pst
   where
-    replaceNothingWith x (SimplePlacement (PS p rot PutNothing): pss) = sPS p rot x : pss
+    replaceNothingWith x (Placement (PS p rot PutNothing) _: pss) = sPS p rot x : pss
     replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
     replaceNothingWith _ [] = []
 {- | Successively fill 'PutNothing' placements with a list of given 'PSType's.