subtile collision for boxes

src/Test.hs

@@ -14,7 +14,7 @@ import qualified Data.Set as S
 import qualified Data.Text as T
 import Data.Matrix as M
 import Data.Ecstasy as E
-import Data.Maybe (fromJust)
+import Data.Maybe
 
 import NanoVG hiding (V2(..))
 
@@ -149,20 +149,64 @@ 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
+      let ent =
-            | Wall /= matrix M.! (floor nr, floor nc) =
+            case imgObstacle (imgMat (stateData ud) M.! (floor nr, floor nc)) of
-              defEntity'
+              Just (Boundaries (minr, minc) (maxr, maxc))
-                { pos = Set npos
+                | (nr - fromIntegral (floor nr) >= minr &&
-                }
+                  nr - fromIntegral (floor nr) <= maxr) &&
-            | Wall /= matrix M.! (floor nr, floor oc) =
+                  (nc - fromIntegral (floor nc) >= minc &&
-              defEntity'
+                  nc - fromIntegral (floor nc) <= maxc) &&
-                { pos = Set (V2 nr oc)
+                  (or - fromIntegral (floor or) < minr ||
-                }
+                  or - fromIntegral (floor or) > maxr) ->
-            | Wall /= matrix M.! (floor or, floor nc) =
                   defEntity'
                     { pos = Set (V2 or nc)
                     }
-            | otherwise =
+                | (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'
       return ent
   putAffection ud
@@ -178,31 +222,57 @@ drawTile
   -> Int
   -> Maybe ImgId
   -> IO ()
-drawTile ai ctx pr pc row col img = do
+drawTile ai ctx pr pc row col img =
-  let tileWidth = 64 :: Double
+  do
-      tileHeight = 32 :: Double
     save ctx
-  let x = realToFrac $ 640 + ((fromIntegral col - pc) +
+    if (isNothing img)
+    then drawPlayer
+    else do
+      if (isNothing 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)
+        then do
+          drawPlayer
+          drawImage
+        else do
+          drawImage
+          drawPlayer
+    -- when (isNothing img) drawPlayer
+    restore ctx
+  where
+    tileWidth = 64 :: Double
+    tileHeight = 32 :: Double
+    x = realToFrac $ 640 + ((fromIntegral col - pc) +
       (fromIntegral row - pr)) * (tileWidth / 2)
     y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
       (fromIntegral col - pc)) * (tileHeight / 2)
-  unless (img == Nothing) $ do
+    dist = distance (V2 (fromIntegral row) (fromIntegral col))
-    let 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)
+    fact =
+      if (floor pr <= row && floor pc >= col) &&
+        isWall (fromJust img)
       then min 1 dist
       else 1
+    mb = imgObstacle img
+    drawImage = do
+      beginPath ctx
       paint <- imagePattern
         ctx x (y - (74 * fact - realToFrac tileHeight))
         (realToFrac tileWidth) 74
         0
         (ai Map.! fromJust img)
         fact
-    beginPath ctx
       if fact < 1
       then do
         moveTo ctx x (y + (realToFrac tileHeight - 74 * fact))
-      lineTo ctx (x + realToFrac tileWidth) (y + (realToFrac tileHeight - 74 * fact))
+        lineTo ctx
+          (x + realToFrac tileWidth)
+          (y + (realToFrac tileHeight - 74 * fact))
         lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2)
         lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight)
         lineTo ctx x (y + realToFrac tileHeight / 2)
@@ -211,10 +281,10 @@ drawTile ai ctx pr pc row col img = do
         rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74
       fillPaint ctx paint
       fill ctx
+    drawPlayer = do
       when (floor pr == row && floor pc == col) $ do
         beginPath ctx
         circle ctx 640 360 5
         closePath ctx
         fillColor ctx (rgba 0 255 255 255)
         fill ctx
-  restore ctx

src/Types/UserData.hs

@@ -58,6 +58,10 @@ 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
+
 data FontId
   = FontBedstead
   deriving (Show, Eq, Ord, Enum)