subtile collision for walls

src/Interior.hs

@@ -40,7 +40,7 @@ placeInteriorIO imat imgmat graph =
       let applicable =
             reverse (L.sortBy (\a b -> size a `compare` size b) (
               L.filter
-                (\a -> clusterRoom a == roomType && size a < size bnds)
+                (\a -> clusterRoom a == roomType && size a <= size bnds)
                 [minBound .. maxBound] :: [Cluster])
               )
           roomType = fst (head $ reverse $ L.sortBy
@@ -71,7 +71,7 @@ placeInteriorIO imat imgmat graph =
               )
           cmat = clusterMat appl
       in
-        if try > 100 || fromIntegral freeRoom < size appl
+        if try > 10 || fromIntegral freeRoom < size appl
         then (g2, mat)
         else
           if pr + nrows cmat - 1 > fst (matmax bnds) ||

src/Test.hs

@@ -149,65 +149,11 @@ updateMap dt = do
       pos'@(V2 or oc) <- E.get pos
       vel' <- E.get vel
       let npos@(V2 nr nc) = pos' + fmap (* (4 * dt)) vel'
-      let ent =
-            case imgObstacle (imgMat (stateData ud) M.! (floor nr, floor nc)) of
-              Just (Boundaries (minr, minc) (maxr, maxc))
-                | (nr - fromIntegral (floor nr) >= minr &&
-                  nr - fromIntegral (floor nr) <= maxr) &&
-                  (nc - fromIntegral (floor nc) >= minc &&
-                  nc - fromIntegral (floor nc) <= maxc) &&
-                  (or - fromIntegral (floor or) < minr ||
-                  or - fromIntegral (floor or) > maxr) ->
-                  defEntity'
-                    { pos = Set (V2 or nc)
-                    }
-                | (nr - fromIntegral (floor nr) >= minr &&
-                  nr - fromIntegral (floor nr) <= maxr) &&
-                  (nc - fromIntegral (floor nc) >= minc &&
-                  nc - fromIntegral (floor nc) <= maxc) &&
-                  (oc - fromIntegral (floor oc) < minc ||
-                  oc - fromIntegral (floor oc) > maxc) ->
-                  defEntity'
-                    { pos = Set (V2 nr oc)
-                    }
-                | (nr - fromIntegral (floor nr) < minr ||
-                  nr - fromIntegral (floor nr) > maxr) &&
-                  (nc - fromIntegral (floor nc) < minc ||
-                  nc - fromIntegral (floor nc) > maxc) ->
-                  defEntity'
-                    { pos = Set npos
-                    }
-                | (nr - fromIntegral (floor nr) < minr ||
-                  nr - fromIntegral (floor nr) > maxr) &&
-                  (nc - fromIntegral (floor nc) >= minc &&
-                  nc - fromIntegral (floor nc) <= maxc) ->
-                  defEntity'
-                    { pos = Set npos
-                    }
-                | (nr - fromIntegral (floor nr) >= minr &&
-                  nr - fromIntegral (floor nr) <= maxr) &&
-                  (nc - fromIntegral (floor nc) < minc ||
-                  nc - fromIntegral (floor nc) > maxc) ->
-                  defEntity'
-                    { pos = Set npos
-                    }
-                | otherwise ->
-                  defEntity'
-              Nothing
-                | Wall /= matrix M.! (floor nr, floor nc) ->
-                  defEntity'
-                    { pos = Set npos
-                    }
-                | Wall /= matrix M.! (floor nr, floor oc) ->
-                  defEntity'
-                    { pos = Set (V2 nr oc)
-                    }
-                | Wall /= matrix M.! (floor or, floor nc) ->
-                  defEntity'
-                    { pos = Set (V2 or nc)
-                    }
-                | otherwise ->
-                  defEntity'
+      let ent = defEntity'
+            { pos = Set $ Prelude.foldl (checkBoundsCollision pos')
+              npos
+              (imgObstacle (imgMat (stateData ud) M.! (floor nr, floor nc)))
+            }
       return ent
   putAffection ud
     { worldState = nws
@@ -228,25 +174,27 @@ drawTile ai ctx pr pc row col img =
     if (isNothing img)
     then drawPlayer
     else do
-      if (isNothing mb)
+      if (Prelude.null mb)
       then do
         drawImage
         drawPlayer
       else do
-        let (Boundaries (minr, minc) (maxr, maxc)) = fromJust mb
-        if (pr <= fromIntegral (floor pr) + minr &&
-          pc >= fromIntegral (floor pc) + minc)
+        if any (\minr -> pr <= fromIntegral (floor pr) + minr) minrs &&
+          any (\minc -> pc >= fromIntegral (floor pc) + minc) mincs
         then do
           drawPlayer
           drawImage
         else do
           drawImage
           drawPlayer
-    -- when (isNothing img) drawPlayer
     restore ctx
   where
     tileWidth = 64 :: Double
     tileHeight = 32 :: Double
+    minrs = Prelude.map (fst . matmin) mb
+    maxrs = Prelude.map (fst . matmax) mb
+    mincs = Prelude.map (snd . matmin) mb
+    maxcs = Prelude.map (snd . matmax) mb
     x = realToFrac $ 640 + ((fromIntegral col - pc) +
       (fromIntegral row - pr)) * (tileWidth / 2)
     y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
@@ -254,8 +202,9 @@ drawTile ai ctx pr pc row col img =
     dist = distance (V2 (fromIntegral row) (fromIntegral col))
       (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
     fact =
-      if (floor pr <= row && floor pc >= col) &&
-        isWall (fromJust img)
+      if (pr <= fromIntegral row + maximum minrs &&
+         pc >= fromIntegral col + minimum mincs) &&
+         isWall (fromJust img)
       then min 1 dist
       else 1
     mb = imgObstacle img
@@ -288,3 +237,42 @@ drawTile ai ctx pr pc row col img =
         closePath ctx
         fillColor ctx (rgba 0 255 255 255)
         fill ctx
+
+checkBoundsCollision
+  :: V2 Double
+  -> V2 Double
+  -> Boundaries Double
+  -> V2 Double
+checkBoundsCollision
+  pos'@(V2 or oc) acc@(V2 fr fc) (Boundaries (minr, minc) (maxr, maxc))
+    | (fr - fromIntegral (floor fr) >= minr &&
+      fr - fromIntegral (floor fr) <= maxr) &&
+      (fc - fromIntegral (floor fc) >= minc &&
+      fc - fromIntegral (floor fc) <= maxc) &&
+      (or - fromIntegral (floor or) < minr ||
+      or - fromIntegral (floor or) > maxr) =
+      (V2 or fc)
+    | (fr - fromIntegral (floor fr) >= minr &&
+      fr - fromIntegral (floor fr) <= maxr) &&
+      (fc - fromIntegral (floor fc) >= minc &&
+      fc - fromIntegral (floor fc) <= maxc) &&
+      (oc - fromIntegral (floor oc) < minc ||
+      oc - fromIntegral (floor oc) > maxc) =
+      (V2 fr oc)
+    | (fr - fromIntegral (floor fr) < minr ||
+      fr - fromIntegral (floor fr) > maxr) &&
+      (fc - fromIntegral (floor fc) < minc ||
+      fc - fromIntegral (floor fc) > maxc) =
+      acc
+    | (fr - fromIntegral (floor fr) < minr ||
+      fr - fromIntegral (floor fr) > maxr) &&
+      (fc - fromIntegral (floor fc) >= minc &&
+      fc - fromIntegral (floor fc) <= maxc) =
+      acc
+    | (fr - fromIntegral (floor fr) >= minr &&
+      fr - fromIntegral (floor fr) <= maxr) &&
+      (fc - fromIntegral (floor fc) < minc ||
+      fc - fromIntegral (floor fc) > maxc) =
+      acc
+    | otherwise =
+      pos'

src/Types/Interior.hs

@@ -14,9 +14,9 @@ data Cluster
 clusterMat :: Cluster -> Matrix (Maybe ImgId)
 clusterMat ClusterBox1 =
   M.fromLists
-    [ [Nothing,          Nothing, Nothing]
-    , [Nothing, Just ImgMiscBox1, Nothing]
-    , [Nothing,          Nothing, Nothing]
+    -- [ [         Nothing]
+    [ [Just ImgMiscBox1]
+    -- , [Nothing,          Nothing, Nothing]
     ]
 
 clusterRoom :: Cluster -> TileState

src/Types/UserData.hs

@@ -58,9 +58,47 @@ isWall :: ImgId -> Bool
 isWall ImgMiscBox1 = False
 isWall _ = True
 
-imgObstacle :: Maybe ImgId -> Maybe (Boundaries Double)
-imgObstacle (Just ImgMiscBox1) = Just (Boundaries (0.2, 0.34) (0.8, 1))
-imgObstacle _ = Nothing
+imgObstacle :: Maybe ImgId -> [(Boundaries Double)]
+imgObstacle (Just ImgMiscBox1) = [Boundaries (0.2, 0.34) (0.8, 1)]
+imgObstacle (Just ImgWallAsc) = [Boundaries (0.37, 0) (0.63, 1)]
+imgObstacle (Just ImgWallDesc) = [Boundaries (0, 0.37) (1, 0.63)]
+imgObstacle (Just ImgWallCornerN) =
+  [ Boundaries (0, 0.37) (0.63, 0.63)
+  , Boundaries (0.37, 0.37) (0.63, 1)
+  ]
+imgObstacle (Just ImgWallCornerE) =
+  [ Boundaries (0.37, 0.37) (1, 0.63)
+  , Boundaries (0.37, 0.37) (0.63, 1)
+  ]
+imgObstacle (Just ImgWallCornerS) =
+  [ Boundaries (0.37, 0.37) (1, 0.63)
+  , Boundaries (0.37, 0) (0.63, 0.63)
+  ]
+imgObstacle (Just ImgWallCornerW) =
+  [ Boundaries (0, 0.37) (0.63, 0.63)
+  , Boundaries (0.37, 0) (0.63, 0.63)
+  ]
+imgObstacle (Just ImgWallTNE) =
+  [ Boundaries (0, 0.37) (1, 0.63)
+  , Boundaries (0.37, 0.37) (0.63, 1)
+  ]
+imgObstacle (Just ImgWallTSW) =
+  [ Boundaries (0, 0.37) (1, 0.63)
+  , Boundaries (0.37, 0) (0.63, 0.63)
+  ]
+imgObstacle (Just ImgWallTSE) =
+  [ Boundaries (0.37, 0) (0.63, 1)
+  , Boundaries (0.37, 0.37) (1, 0.63)
+  ]
+imgObstacle (Just ImgWallTNW) =
+  [ Boundaries (0.37, 0) (0.63, 1)
+  , Boundaries (0, 0.37) (0.63, 0.63)
+  ]
+imgObstacle (Just ImgWallCross) =
+  [ Boundaries (0.37, 0) (0.63, 1)
+  , Boundaries (0, 0.37) (1, 0.63)
+  ]
+imgObstacle _ = []
 
 data FontId
   = FontBedstead