no more floortiles

src/Test.hs

@@ -12,7 +12,7 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Map.Strict as Map
 import qualified Data.Set as S
 import qualified Data.Text as T
-import Data.Matrix as M (toLists, (!), Matrix, safeGet)
+import Data.Matrix as M
 import Data.Ecstasy as E
 import Data.Maybe (fromJust)
 
@@ -35,7 +35,7 @@ import Util
 loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
-  let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (40,40)
+  let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (50,75)
       (Subsystems _ m) = subsystems ud
   matrix <- liftIO $ buildHallFloorIO fc
   (nws, _) <- yieldSystemT (worldState ud) $ do
@@ -55,17 +55,6 @@ loadMap = do
     , uuid = [uu]
     }
 
-relativizeMouseCoords :: V2 Int32 -> IO (V2 Double)
-relativizeMouseCoords (V2 ix iy) = do
-  (GL.Position vx vy, GL.Size vw vh) <- SDL.get GL.viewport
-  let rx = ix - vx
-      ry = iy - vy
-      hx = fromIntegral vw / 2
-      hy = fromIntegral vh / 2
-      dx = fromIntegral rx - hx
-      dy = fromIntegral ry - hy
-  return $ V2 (dx / hx) (dy / hy)
-
 mouseToPlayer :: V2 Int32 -> Affection UserData ()
 mouseToPlayer mv2 = do
   ud <- getAffection
@@ -104,11 +93,40 @@ drawMap :: Affection UserData ()
 drawMap = do
   ud <- getAffection
   dt <- getDelta
-  let matrix = imgMat (stateData ud)
+  (_, playerPos) <- yieldSystemT (worldState ud) $ do
-  mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [1..] ls))
+        efor $ \_ -> do
-    (zip [1..] (toLists matrix))
+          with player
+          pos' <- E.get pos
+          pure pos'
+  let V2 pr pc = head playerPos
+      matrix = imgMat (stateData ud)
+      ctx = nano ud
+      cols = fromIntegral (ncols matrix)
+      rows = fromIntegral (nrows matrix)
+      tileWidth = 64 :: Double
+      tileHeight = 32 :: Double
+      x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
+      y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
   liftIO $ do
-    let ctx = nano ud
+    beginPath ctx
+    moveTo ctx x y
+    lineTo ctx
+      (x + cols * (realToFrac tileWidth / 2))
+      (y - realToFrac tileHeight / 2 * cols)
+    lineTo ctx
+      (x + realToFrac tileWidth  / 2 * (cols + rows))
+      (y + (rows - cols) * (realToFrac tileHeight / 2))
+    lineTo ctx
+      (x + realToFrac tileWidth / 2 * rows)
+      (y + realToFrac tileHeight / 2 * rows)
+    closePath ctx
+    fillColor ctx (rgb 255 255 255)
+    fill ctx
+    mapM_ (\(i, ls) -> mapM_
+      (\(j, t) -> drawTile
+        ((mapMat $ stateData ud) M.! (i, j)) (assetImages ud) ctx pr pc i j t)
+        (reverse $ zip [1..] ls))
+      (zip [1..] (toLists matrix))
     fontSize ctx 20
     fontFace ctx (assetFonts ud Map.! FontBedstead)
     textAlign ctx (S.fromList [AlignCenter,AlignTop])
@@ -146,61 +164,42 @@ updateMap dt = do
     { worldState = nws
     }
 
-drawTile :: Int -> Int -> Maybe ImgId -> Affection UserData ()
+drawTile :: TileState -> Map ImgId Image -> Context -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO ()
-drawTile row col img = do
+drawTile tile ai ctx pr pc row col img = do
-  ud <- getAffection
+  let tileWidth = 64 :: Double
-  (_, playerPos) <- yieldSystemT (worldState ud) $ do
-        efor $ \_ -> do
-          with player
-          pos' <- E.get pos
-          pure pos'
-  let V2 pr pc = head playerPos
-      ctx = nano ud
-      tile = (mapMat $ stateData ud) M.! (row, col)
-      (xinit, yinit) = initCoords $ stateData ud
-      tileWidth = 64 :: Double
       tileHeight = 32 :: Double
-  liftIO $ do
+  save ctx
-    save ctx
+  let 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
+    let dist = distance (V2 (fromIntegral row) (fromIntegral col))
+          (V2 (realToFrac pr - 0.5) (realToFrac pc + 0.5)) / 4
+        fact = if floor pr <= row && floor pc >= col
+          then min 1 dist
+          else 1
+    paint <- imagePattern
+      ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 0
+      (ai Map.! fromJust img)
+      fact
     beginPath ctx
-    let x = realToFrac $ 640 + ((fromIntegral col - pc) +
+    if fact < 1
-          (fromIntegral row - pr)) * (tileWidth / 2)
+    then do
-        y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
+      moveTo ctx x (y + (realToFrac tileHeight - 74 * fact))
-          (fromIntegral col - pc)) * (tileHeight / 2)
+      lineTo ctx (x + realToFrac tileWidth) (y + (realToFrac tileHeight - 74 * fact))
-    fillColor ctx (case tile of
+      lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2)
-      Wall -> rgba 128 128 128 255
+      lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight)
-      Door -> rgba 255 128 128 255
+      lineTo ctx x (y + realToFrac tileHeight / 2)
-      Hall -> rgba 255 255 255 255
-      Offi -> rgba 0   255 0   255
-      Toil -> rgba 0   0   255 255
-      Kitc -> rgba 255 0   0   255
-      Elev -> rgba 0   0   0   255
-      _    -> rgba 255 255 0   255
-      )
-    moveTo ctx x (y + realToFrac tileHeight / 2)
-    lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight)
-    lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2)
-    lineTo ctx (x + realToFrac tileWidth / 2) y
-    closePath ctx
-    fill ctx
-    unless (img == Nothing) $ do
-      let dist = distance (V2 (fromIntegral row) (fromIntegral col))
-            (V2 (realToFrac pr - 0.5) (realToFrac pc + 0.5)) / 4
-          fact = if floor pr <= row && floor pc >= col
-            then min 1 dist
-            else 1
-      paint <- imagePattern
-        ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 0
-        (assetImages ud Map.! fromJust img)
-        fact
-      beginPath ctx
-      rect ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74
-      fillPaint ctx paint
-      fill ctx
-    when (floor pr == row && floor pc == col) $ do
-      beginPath ctx
-      circle ctx 640 360 5
       closePath ctx
-      fillColor ctx (rgba 0 255 255 255)
+    else
-      fill ctx
+      rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74
-    restore ctx
+    fillPaint ctx paint
+    fill ctx
+  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/Util.hs

@@ -4,6 +4,11 @@ import Affection as A
 
 import Data.Matrix as M
 
+import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL hiding (get)
+
+import Linear
+
 -- internal imports
 
 import Types
@@ -93,3 +98,14 @@ neighWalls row col mat =
     , (0, 1)
     , (1, 0)
     ]
+
+relativizeMouseCoords :: V2 Int32 -> IO (V2 Double)
+relativizeMouseCoords (V2 ix iy) = do
+  (GL.Position vx vy, GL.Size vw vh) <- SDL.get GL.viewport
+  let rx = ix - vx
+      ry = iy - vy
+      hx = fromIntegral vw / 2
+      hy = fromIntegral vh / 2
+      dx = fromIntegral rx - hx
+      dy = fromIntegral ry - hy
+  return $ V2 (dx / hx) (dy / hy)