Implement randomness at the placement datatype level

src/Dodge/Layout.hs

@@ -59,15 +59,22 @@ generateLevelFromRoomList gr w
 
 -- the idea is to allow use of link coordinates for placements
 -- though the implementation is clunky
+-- this should PutNothing if there are no links available
+-- first it takes the random placements and derandomises them
+-- then it deals with link placement spots
 assignPlacementSpots :: StdGen -> Room -> (StdGen, [((Point2,Float),Placement)])
 assignPlacementSpots g rm = (g', map (_rmShift rm,) $ plmnts ++ plmnts')
   where
-    (lnkplmnts, plmnts) = partition islnk (_rmPS rm)
+    (randPlmnts, detPlmnts) = partition isRand (_rmPS rm)
+    isRand RandomPlacement{} = True
+    isRand _ = False
+    (unrandPlmnts, g'') = runState (mapM _unRandomPlacement randPlmnts) g
+    (lnkplmnts, plmnts) = partition islnk (unrandPlmnts ++ detPlmnts)
     islnk Placement{_placementSpot=PSLnk{}} = True
     islnk _ = False
-    (shuffledLnks,g') = runState (shuffle $ _rmLinks rm) g
+    (shuffledLnks,g') = runState (shuffle $ _rmLinks rm) g''
     (_,plmnts') = mapAccumR f (map (invShiftLinkBy $ _rmShift rm) shuffledLnks) lnkplmnts
-    f lnks plmnt = 
+    f lnks plmnt =
         let (x:xs,ys) = partition (_psLinkTest $ _placementSpot plmnt) lnks
             thepair = _psLinkShift (_placementSpot plmnt) x
         in (xs++ys, updatePS (updatePSLnkUsing thepair) plmnt)

src/Dodge/LevelGen.hs

@@ -28,12 +28,17 @@ placeSpot w (shift, plmnt@Placement{}) =
     let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType plmnt) w
     in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
 placeSpot w (shift, PlacementUsingPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
+-- random placements SHOULD be dealt with already (see assignPlacementSpots)
+placeSpot w (shift, RandomPlacement rplmnt) = placeSpot (w & randGen .~ g) (shift, plmnt)
+  where
+    (plmnt, g) = runState rplmnt (_randGen w)
 
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
      (fmap (fmap $ shiftPlacement shift) f)
 shiftPlacement shift (PlacementUsingPos p f) = PlacementUsingPos (shiftPoint3By shift p)
      (fmap (shiftPlacement shift) f)
+shiftPlacement shift (RandomPlacement rpl) = RandomPlacement $ fmap (shiftPlacement shift) rpl
 
 shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
 shiftPSBy (pos,rot) ps = ps

src/Dodge/LevelGen/Data.hs

@@ -39,6 +39,7 @@ data Placement = Placement
     , _idPlacement :: Int -> Maybe Placement 
     }
   | PlacementUsingPos Point3 (Point3 -> Placement)  -- allows a placement to use a shifted position
+  | RandomPlacement {_unRandomPlacement :: State StdGen Placement}
 
 sPS :: Point2 -> Float -> PSType -> Placement
 sPS p a pt = Placement (PS p a) pt (const Nothing)

src/Dodge/LevelGen/Switch.hs

@@ -11,7 +11,6 @@ import Picture
 import ShapePicture
 import Shape
 import Geometry
---import Geometry.Data
 
 import qualified Data.IntMap.Strict as IM
 import Control.Lens

src/Dodge/Placements/LightSource.hs

@@ -4,10 +4,12 @@ import Dodge.Data
 import Dodge.LightSources.Lamp
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
+import Dodge.Placements.Spot
 import Geometry
 import Dodge.Creature.Inanimate
 import Shape.Data
 import Dodge.Default
+import Dodge.RandomHelp 
 
 mountLightOnShape
     :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape
@@ -82,6 +84,19 @@ mountLightAID = mountLightOnShape f
 mountLightA :: Point2 -> Point3 -> Placement
 mountLightA = redMID mountLightAID
 
+mountLightACond :: ((Point2,Float) -> Bool) -> Placement
+mountLightACond f = updatePSToLevel 2 (const thePS) $ mountLightA 0 (V3 0 (-40) 40)
+  where
+    thePS = PSLnk f (\(p,a)->(p,a))
+
+mountLightVCond :: ((Point2,Float) -> Bool) -> Placement
+mountLightVCond f = updatePSToLevel 2 (const thePS) $ mountLightV 0 (V3 0 (-20) 40)
+  where
+    thePS = PSLnk f id
+
+mntLightCond :: ((Point2,Float) -> Bool) -> Placement
+mntLightCond f = RandomPlacement $ takeOne [mountLightVCond f,mountLightACond f]
+
 mountLightVID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
 mountLightVID = mountLightOnShape f
   where

src/Dodge/Placements/Spot.hs

@@ -13,11 +13,14 @@ updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Place
 updatePSToLevel 0 _ plmnt = plmnt
 updatePSToLevel i f (PlacementUsingPos p pl) = PlacementUsingPos p (fmap (updatePSToLevel i f) pl)
 updatePSToLevel i f (Placement ps pt pl) = Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl)
+updatePSToLevel i f (RandomPlacement rplmnt) = RandomPlacement $ fmap (updatePSToLevel i f) rplmnt
 
 setLocalPS :: PlacementSpot -> Placement -> Placement
 setLocalPS ps (Placement _ pt f) = Placement ps pt f
+setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) rplmnt)
 setLocalPS _ plmnt = plmnt
 
 updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement
 updatePS f (Placement ps pt iplmnt) = Placement (f ps) pt ((fmap . fmap $ updatePS f) iplmnt)
 updatePS f (PlacementUsingPos p plmnt) = PlacementUsingPos p (fmap (updatePS f) plmnt)
+updatePS f (RandomPlacement rplmnt) = RandomPlacement (fmap (updatePS f) rplmnt)

src/Dodge/Room/Procedural.hs

@@ -48,7 +48,7 @@ roomRect x y xn yn = defaultRoom
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
-    , _rmPS    = [mountLightA (V2 (x/2) 0) (V3 (x/2) 40 50)]
+    , _rmPS    = []
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = [Tile 
             { _tilePoly = rectNSWE y 0 0 x
@@ -68,7 +68,10 @@ roomRect x y xn yn = defaultRoom
     pth  = linksAndPath lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
 {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.  -}
 roomRectAutoLinks :: Float -> Float -> Room
-roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
+roomRectAutoLinks x y = (roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60))
+    {_rmPS = plmnts}
+  where
+    plmnts = [mntLightCond (const True)]
 {- Combines two rooms into one room.
 Combines into one big bound, concatenates the rest.  -}
 combineRooms :: Room -> Room -> Room