Slightly broken placements

src/Dodge/LevelGen.hs

@@ -14,8 +14,8 @@ import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.TriggerDoor
 import Dodge.LevelGen.Data
 import Dodge.Default.Wall
-import Dodge.RandomHelp
-import Dodge.Placements.Spot
+--import Dodge.RandomHelp
+--import Dodge.Placements.Spot
 import Geometry
 import Geometry.Vector3D
 import Shape
@@ -26,13 +26,14 @@ 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{}}      -> placeSpotUsingLink w rm plmnt
+    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
@@ -48,37 +49,33 @@ placeSpot (w,rm) plmnt = case plmnt of
   where
     shift = _rmShift rm
 
+invShiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
+invShiftPSBy (pos,rot) (PS p r) = PS (invShiftPointBy (pos,rot) p) (r - rot)
+invShiftPSBy _ ps = ps
+
+
 -- this should be tidied up
-placeSpotUsingLink :: World -> Room -> Placement -> ((World, Room), [Placement])
-placeSpotUsingLink w rm plmnt = case lnks of
-    ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki lnk) (updatePS (f lnk) plmnt)
-    [] -> case fallback of
+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
-    uselnk lnki lnk = _psLnkRoomEff rps (f' lnk rps) rm & rmLinks %~ deletei lnki
-    rps = _plSpot plmnt
-    fallback = _psLnkFallback rps
-    test = _psLnkTest rps
-    (lnks,g) = runState (shuffle $ filter (test . snd) $ zip [0..] 
-        $ map (invShiftLinkBy $ _rmShift rm) $ _rmLinks rm) $ _randGen w
-    f' x (PSLnk t s _ _)
-        | t x = s x
-    f' _ _ = error "wrong type of link: something is wrong"
-    f x (PSLnk t s _ _)
-        | t x = uncurry PS $ s x
-    f _ ps = ps
-    invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
-    invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
+    searchedPoss [] = error "no correct pos type for lnk placement"
+    searchedPoss (pos:poss) = case extract (invShiftPosBy (_rmShift rm) 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)
 
-deletei :: Int -> [a] -> [a]
-deletei i xs = take i xs ++ drop (i+1) xs
-
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift plmnt = case plmnt of
     Placement {} -> plmnt & plSpot %~ shiftPSBy shift 
@@ -138,6 +135,17 @@ shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 invShiftPointBy :: (Point2,Float) -> Point2 -> Point2
 invShiftPointBy (p1,r) p2 = rotateV (-r) $ p2 -.- p1
 
+invShiftPosBy :: (Point2,Float) -> RoomPos -> RoomPos
+invShiftPosBy s rp = case rp of
+    OutLink i p a   -> uncurry (OutLink i)  $ invShiftLinkBy s (p,a)
+    InLink  p a     -> uncurry (InLink)     $ invShiftLinkBy s (p,a)
+    UnusedLink p a  -> uncurry (UnusedLink) $ invShiftLinkBy s (p,a)
+    PosPl   p a     -> uncurry (PosPl)      $ invShiftLinkBy s (p,a)
+    LabPos  i rp'   -> LabPos i $ invShiftPosBy s rp'
+
+invShiftLinkBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float)
+invShiftLinkBy (pos,rot) (p,r) = (invShiftPointBy (pos,rot) p, r - rot)
+
 shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
 shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)