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,21 +149,65 @@ 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'
-              defEntity'
+                    { pos = Set (V2 or nc)
-                { pos = Set (V2 or nc)
+                    }
-                }
+                | (nr - fromIntegral (floor nr) >= minr &&
-            | otherwise =
+                  nr - fromIntegral (floor nr) <= maxr) &&
-              defEntity'
+                  (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
     { worldState = nws
@@ -178,43 +222,69 @@ 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
-  save ctx
+    if (isNothing img)
-  let x = realToFrac $ 640 + ((fromIntegral col - pc) +
+    then drawPlayer
-        (fromIntegral row - pr)) * (tileWidth / 2)
+    else do
-      y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
+      if (isNothing mb)
-        (fromIntegral col - pc)) * (tileHeight / 2)
+      then do
-  unless (img == Nothing) $ do
+        drawImage
-    let dist = distance (V2 (fromIntegral row) (fromIntegral col))
+        drawPlayer
-          (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
+      else do
-        fact = if (floor pr <= row && floor pc >= col) && isWall (fromJust img)
+        let (Boundaries (minr, minc) (maxr, maxc)) = fromJust mb
-          then min 1 dist
+        if (pr <= fromIntegral (floor pr) + minr &&
-          else 1
+          pc >= fromIntegral (floor pc) + minc)
-    paint <- imagePattern
+        then do
-      ctx x (y - (74 * fact - realToFrac tileHeight))
+          drawPlayer
-      (realToFrac tileWidth) 74
+          drawImage
-      0
+        else do
-      (ai Map.! fromJust img)
+          drawImage
-      fact
+          drawPlayer
-    beginPath ctx
+    -- when (isNothing img) drawPlayer
-    if fact < 1
+    restore ctx
-    then do
+  where
-      moveTo ctx x (y + (realToFrac tileHeight - 74 * fact))
+    tileWidth = 64 :: Double
-      lineTo ctx (x + realToFrac tileWidth) (y + (realToFrac tileHeight - 74 * fact))
+    tileHeight = 32 :: Double
-      lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2)
+    x = realToFrac $ 640 + ((fromIntegral col - pc) +
-      lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight)
+      (fromIntegral row - pr)) * (tileWidth / 2)
-      lineTo ctx x (y + realToFrac tileHeight / 2)
+    y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
-      closePath ctx
+      (fromIntegral col - pc)) * (tileHeight / 2)
-    else
+    dist = distance (V2 (fromIntegral row) (fromIntegral col))
-      rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74
+      (V2 (realToFrac pr - 1) (realToFrac pc)) / 4
-    fillPaint ctx paint
+    fact =
-    fill ctx
+      if (floor pr <= row && floor pc >= col) &&
-  when (floor pr == row && floor pc == col) $ do
+        isWall (fromJust img)
-    beginPath ctx
+      then min 1 dist
-    circle ctx 640 360 5
+      else 1
-    closePath ctx
+    mb = imgObstacle img
-    fillColor ctx (rgba 0 255 255 255)
+    drawImage = do
-    fill ctx
+      beginPath ctx
-  restore ctx
+      paint <- imagePattern
+        ctx x (y - (74 * fact - realToFrac tileHeight))
+        (realToFrac tileWidth) 74
+        0
+        (ai Map.! fromJust img)
+        fact
+      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 / 2)
+        lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight)
+        lineTo ctx x (y + realToFrac tileHeight / 2)
+        closePath ctx
+      else
+        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

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)