Cleanup and various bugfixes

src/Dodge/Floor.hs

@@ -17,6 +17,7 @@ import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
 import Dodge.Item.Weapon.Launcher
 import Dodge.PlacementSpot
+import Dodge.RoomPos
 import MonadHelp
 import Data.Tree
 import Color

src/Dodge/GameRoom.hs

@@ -10,5 +10,6 @@ data GameRoom = GameRoom
     , _grViewpointsEx :: [Point2]
     , _grBound :: [Point2]
     , _grDir :: Float   -- ^ gives direction of room
+    , _grLinkDirs :: [Float]
     , _grName :: String
     }

src/Dodge/Layout.hs

@@ -149,23 +149,31 @@ wallsFromRooms =
   where
     f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i})
 
+-- TODO sort out shifting before or after etc
 gameRoomsFromRooms :: [Room] -> [GameRoom]
-gameRoomsFromRooms = map f
+gameRoomsFromRooms = map gameRoomFromRoom
+
+gameRoomFromRoom :: Room -> GameRoom
+gameRoomFromRoom rm = GameRoom
+    { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
+--       ++ map fst (_rmLinks rm)
+    , _grViewpointsEx = mapMaybe unpos (_rmPos rm)
+    , _grBound = expandPolyCorners 50 . convexHullSafe . nubBy closePoints 
+        . concat $ _rmBound rm ++ _rmPolys rm
+    , _grDir   = getDir $ _rmPos rm
+    , _grLinkDirs = mapMaybe undir $ _rmPos rm
+    , _grName  = _rmName rm
+    }
   where
-    f rm = GameRoom
-        { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
-            ++ map fst (_rmLinks rm)
-        , _grViewpointsEx = mapMaybe unpos (_rmPos rm)
-        , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints 
-            . concat $ _rmBound rm ++ _rmPolys rm
-        , _grDir   = getDir $ _rmPos rm
-        , _grName  = _rmName rm
-        }
-    closePoints x y = roundPoint2 x == roundPoint2 y
-    unpos (OutLink _ p _) = Just p
-    unpos (InLink  p _) = Just p
+    doshift = shiftPointBy (_rmShift rm)
+    unpos (OutLink _ p _) = Just $ doshift p
+    unpos (InLink    p _) = Just $ doshift p
     unpos _ = Nothing
-    getDir (InLink _ a:_) = a
+    undir (OutLink _ _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
+    undir (InLink    _ a) = Just $ 0.5*pi + a + snd (_rmShift rm)
+    undir _ = Nothing
+    closePoints x y = roundPoint2 x == roundPoint2 y
+    getDir (InLink _ a:_) = a -- + snd (_rmShift rm)
     getDir (_:xs) = getDir xs
     getDir _ = 0 -- fallback
 

src/Dodge/LevelGen/Data.hs

@@ -92,14 +92,6 @@ data RoomPos
     | LabPos  Int    RoomPos
   deriving (Eq,Ord,Show)
 
-extractRoomPos :: RoomPos -> (Point2,Float)
-extractRoomPos rp = case rp of
-    OutLink _ p a   -> (p,a)
-    InLink  p a     -> (p,a)
-    UnusedLink p a  -> (p,a)
-    PosPl   p a     -> (p,a)
-    LabPos  _ rp'   -> extractRoomPos rp'
-
 makeLenses ''Room
 makeLenses ''PSType
 makeLenses ''PlacementSpot

src/Dodge/LevelGen/StaticWalls.hs

@@ -7,6 +7,7 @@ module Dodge.LevelGen.StaticWalls
     , removeInverseWalls
     , expandPolyByFixed
     , cutPoly
+    , expandPolyCorners
     )
     where
 import Geometry
@@ -96,6 +97,13 @@ expandPolyByFixed :: Float -> [Point2] -> [Point2]
 expandPolyByFixed x ps = map f ps
   where
     f p = p +.+ x *.* safeNormalizeV (p -.- centroid ps)
+-- | Given a value and a poly, pushes points out by a fixed amount along an
+-- angle determined by the corner, i.e. by the two other neighbour points
+expandPolyCorners :: Float -> [Point2] -> [Point2]
+expandPolyCorners d (x:y:z:xs) = zipWith3 f (x:y:z:xs) (y:z:xs++[x]) (z:xs ++ [x,y])
+  where
+    f l c r = c +.+ d *.* normalizeV (normalizeV (c -.- r) +.+ normalizeV (c -.- l))
+expandPolyCorners _ _ = error "trying to expand poly corners of 2 or fewer points"
 -- | Given a polygon expressed as a list of points and a collection of walls,
 -- returns: 
 -- fst: points of the polygon's intersection with walls

src/Dodge/Path.hs

@@ -1,6 +1,5 @@
 module Dodge.Path 
     ( pointTowardsImpulse
-    --, pointTowardsImpulse'
     , makePathBetween
     , makePathBetweenPs
     , removePathsCrossing

src/Dodge/Room/Procedural.hs

@@ -66,14 +66,15 @@ roomRect x y xn yn = defaultRoom
     lnks = nlnks ++ elnks ++ wlnks ++ slnks
     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.  -}
+-- it is not clear to me that this works for very small rooms (but it does seem
+-- to do so)
 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 xn yn)
     {_rmPmnts = plmnts}
   where
-    plmnts = 
-        [mntLightLnkCond unusedLnkToPS
---        ,sps0 $ PutForeground $ thinHighBarChain 50 $ rectNSWE y 0 0 x
-        ]
+    xn = max 1 $ (ceiling x - 40) `div` 60
+    yn = max 1 $ (ceiling y - 40) `div` 60
+    plmnts = [mntLightLnkCond unusedLnkToPS ]
 {- Combines two rooms into one room.
 Mostly involves concatenation.  -}
 combineRooms :: Room -> Room -> Room

src/Dodge/Room/Start.hs

@@ -1,7 +1,10 @@
 module Dodge.Room.Start where
 import Dodge.LevelGen.Data
 import Dodge.Data
+import Dodge.Layout.Tree.Either
+import Dodge.RandomHelp
 import Dodge.Room.Door
+import Dodge.Room.Room
 import Dodge.Room.Link
 import Dodge.Room.Procedural
 import Dodge.Room.Foreground
@@ -23,23 +26,38 @@ import System.Random
 --import qualified Data.IntMap.Strict as IM
 
 rezBox :: Room
---rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 
 rezBox = roomRect 40 60 1 1 
-    & rmPmnts .~ [ spanColLightI (V3 0 0 0.5) 95 (V2 0 1) (V2 40 1) ]
+    & rmPmnts .~ [ spanColLightI rezcol 95 (V2 0 1) (V2 40 1) ]
+
+rezcol :: Point3
+rezcol = V3 0.0 0.1 0.5
 
 rezInvBox :: Room
 rezInvBox = roomRect 40 60 1 1 
-    & rmPmnts .~ [ spanColLightI (V3 0 0 0.5) 95 (V2 0 59) (V2 40 59) ]
+    & rmPmnts .~ [ spanColLightI rezcol 95 (V2 0 59) (V2 40 59) ]
 
 crRezBox :: Room
-crRezBox = rezInvBox -- & rmPmnts %~ (sPS (V2 20 0) pi randC1 :)
+crRezBox = rezInvBox & rmPmnts %~ (sPS (V2 20 50) (1.5*pi) randC1 :)
 
 wpRezBox :: Item -> Room
 wpRezBox wp = rezInvBox & rmPmnts %~ (sPS (V2 15 30) 1 (PutFlIt wp) :)
 
+rezBoxesThenWeaponRoom :: RandomGen g => State g (Tree (Either Room Room))
+rezBoxesThenWeaponRoom = do
+    rboxes <- rezBoxes
+    wroom  <- weaponRoom
+    return $ rboxes `appendEitherTree` [wroom]
+
 startRoom :: RandomGen g => State g (Tree (Either Room Room))
-startRoom = do
-    w <- state $ randomR (100,400)
+startRoom = join $ takeOne 
+    [-- rezBoxesWp
+    rezBoxesThenWeaponRoom
+    --, rezBoxesWpCrit
+    ]
+
+rezBoxesWpCrit :: RandomGen g => State g (Tree (Either Room Room))
+rezBoxesWpCrit = do
+    w <- state $ randomR (200,400)
     h <- state $ randomR (40,40)
     theweapon <- randBlockBreakWeapon
     let bottomEdgeTest (V2 _ y,_) = y < 1
@@ -63,8 +81,30 @@ startRoom = do
     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
+rezBoxesWp :: RandomGen g => State g (Tree (Either Room Room))
+rezBoxesWp = do
+    w <- state $ randomR (100,400)
+    h <- state $ randomR (40,40)
+    theweapon <- randBlockBreakWeapon
+    let bottomEdgeTest (V2 _ y,_) = y < 1
+    centralRoom <- randomiseOutLinks =<< changeLinkTo bottomEdgeTest 
+        ((roomRectAutoLinks w h) {_rmPmnts = []})
+    blcor <- blockedCorridor'
+    let n = length $ filter bottomEdgeTest $ _rmLinks centralRoom
+    let rezrooms = map adddoor 
+            $ wpRezBox theweapon : replicate (n-2) rezInvBox
+    centralRoom' <- changeLinkFrom bottomEdgeTest centralRoom
+    return $ treeFromTrunk [Left rezBox
+        , Left door
+        ] 
+        (Node (Left centralRoom') (rezrooms ++ [onwardtree blcor]))
+  where
+    --dbox = treeFromPost [Left door] (Left rezInvBox)
+    adddoor rm = treeFromPost [Left door] (Left rm)
+    onwardtree blcor = treeFromPost [Left door] (Right blcor)
+
+rezBoxes :: RandomGen g => State g (Tree (Either Room Room))
+rezBoxes = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (40,40)
     let bottomEdgeTest (V2 _ y,_) = y < 1

src/Dodge/RoomPos.hs

@@ -0,0 +1,11 @@
+module Dodge.RoomPos where
+import Dodge.LevelGen.Data
+import Geometry
+
+extractRoomPos :: RoomPos -> (Point2,Float)
+extractRoomPos rp = case rp of
+    OutLink _  p a -> (p,a)
+    InLink     p a -> (p,a)
+    UnusedLink p a -> (p,a)
+    PosPl      p a -> (p,a)
+    LabPos _ rp'   -> extractRoomPos rp'

src/Dodge/Update/Camera.hs

@@ -176,9 +176,12 @@ farWallPoints :: Point2 -> World -> [Point2]
 farWallPoints p w = concatMap _grViewpoints grs ++ linkvps
   where
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
-    linkvps = map extend (concatMap _grViewpointsEx grs)
+    linkvps = map extend (concatMap _grViewpointsEx grs
+        ++ map addDir (concatMap _grLinkDirs grs)
+        )
     extend :: Point2 -> Point2
     extend outp = p +.+ maxViewDistance *.* safeNormalizeV (outp -.- p)
+    addDir a = p +.+ unitVectorAtAngle a
 
 maxViewDistance :: Float
 maxViewDistance = 800

src/Geometry.hs

@@ -163,7 +163,7 @@ grahamScan = foldr push []
 -- https://codereview.stackexchange.com/questions/206019/graham-scan-algorithm-in-haskell
 grahamEliminate :: [Point2] -> [Point2]
 grahamEliminate (x:y:z:xs)
-    | isRHS x y z = grahamEliminate (x:z:xs)
+    | not $ isLHS x y z = grahamEliminate (x:z:xs)
 grahamEliminate xs = xs
 
 -- | Return midpoint between two points.

src/Geometry/LHS.hs

@@ -22,7 +22,7 @@ isLHS
     a2 = y' - y
     b1 = x'' - x
     b2 = y'' - y
--- | Test whether a point is on the LHS of a line.
+-- | Test whether a point is on the RHS of a line.
 -- Returns False if the line is of zero length.
 isRHS 
     :: Point2 -- ^ First line point.