adding simple mouse coordination

src/Floorplan.hs

@@ -2,7 +2,6 @@ module Floorplan where
 
 import Data.Matrix (Matrix(..))
 import qualified Data.Matrix as M
-import qualified Data.Vector as V
 import Data.Maybe
 
 import Control.Monad (foldM)
@@ -25,7 +24,7 @@ buildHallFloorIO fc = do
   traceIO "built graph"
   doors <- buildDoors closed doorgraph
   traceIO "built doors"
-  let (g4, facils)  = buildFacilities g2 fc doors
+  let (_, facils)  = buildFacilities g2 fc doors
   return facils
 
 emptyFloor :: FloorConfig -> Matrix TileState
@@ -57,7 +56,7 @@ placeHalls rng fc input =
    [(Boundaries (1,1) (nrows input, ncols input))]
    (elevator fc) 5 input
   where
-    doHalls rand bounds cross wmax mat =
+    doHalls rand bs cross wmax mat =
       foldl (\(agen, amat) b ->
         let (row, g1)   = randomR (fst (matmin b), fst (matmax b)) agen
             (col, g2)   = randomR (snd (matmin b), snd (matmax b)) g1
@@ -67,7 +66,7 @@ placeHalls rng fc input =
           if hallRatio nmat < 0.2 && wmax - 1 > 2
           then doHalls g3 nbs (row, col) (wmax -1) nmat
           else (g3, nmat)
-        ) (rand, mat) bounds
+        ) (rand, mat) bs
 
 boundSize :: Boundaries -> Int
 boundSize (Boundaries mi ma) =
@@ -79,25 +78,25 @@ buildHall
   -> Boundaries
   -> Matrix TileState
   -> ([Boundaries], Matrix TileState)
-buildHall coord@(row, col) width bounds mat =
+buildHall coord@(row, col) width bs mat =
   let vertHalls = foldl (\acc c -> M.mapCol
-        (\r cur -> if r >= fst (matmin bounds) && r <= fst (matmax bounds)
+        (\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
           then replaceTile cur Hall
           else cur
           ) c acc)
         mat
         [col - (width `div` 2) .. col + (width `div` 2)]
       horzHalls = foldl (\acc r -> M.mapRow
-        (\c cur -> if c >= snd (matmin bounds) && c <= snd (matmax bounds)
+        (\c cur -> if c >= snd (matmin bs) && c <= snd (matmax bs)
           then replaceTile cur Hall
           else cur
           ) r acc)
         vertHalls
         [row - (width `div` 2) .. row + (width `div` 2)]
-  in  ( [ Boundaries (matmin bounds) coord
+  in  ( [ Boundaries (matmin bs) coord
-        , Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds))
+        , Boundaries (fst (matmin bs), col) (row, snd (matmax bs))
-        , Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col)
+        , Boundaries (row, snd (matmin bs)) (fst (matmax bs), col)
-        , Boundaries coord (matmax bounds)
+        , Boundaries coord (matmax bs)
         ]
       , horzHalls
       )
@@ -166,8 +165,8 @@ buildInnerWalls rng input =
                 -> Matrix TileState
                 -> (StdGen, Matrix TileState)
               doCross gen cd@(xr, xc) b imat =
-                let nbs = map (\(mi, ma) -> Boundaries mi ma) bounds
+                let nbs = map (\(mi, ma) -> Boundaries mi ma) bs
-                    bounds =
+                    bs =
                       [ (matmin b, cd)
                       , ((fst (matmin b), col), (row, snd (matmax b)))
                       , ((row, snd (matmin b)), (fst (matmax b), col))
@@ -178,7 +177,7 @@ buildInnerWalls rng input =
                         let (fc, gg1) = randomR (fst minb, fst maxb) agen
                             (fr, gg2) = randomR (snd minb, snd maxb) gg1
                         in  (gg2, acc ++ [(fc, fr)])
-                        ) (gen, []) bounds
+                        ) (gen, []) bs
                     horz = M.mapRow (\icol cur ->
                       if icol >= snd (matmin b) && icol <= snd (matmax b)
                       then replaceTile cur Wall
@@ -283,24 +282,9 @@ findNearestOffice mat (rrr, ccc) =
 
 buildDoorsGraph :: Matrix TileState -> [Graph]
 buildDoorsGraph mat =
-  let maxRow r c
+  let maxCol r c
-        | M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c
-        | otherwise = r
-      maxCol r c
         | M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
         | otherwise = c
-      minRow r c
-        | M.safeGet (r + 1) c mat == Just Offi = minRow (r + 1) c
-        | otherwise = r
-      minCol r c
-        | M.safeGet r (c + 1) mat == Just Offi = minCol r (c + 1)
-        | otherwise = c
-      matcoord = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
-      inbounds (qr, qc) fg
-        | fg == Hall =
-          Nothing
-        | otherwise  =
-          Just fg
       buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph]
       buildGraph amat root coord@(br, bc)
         | bc > ncols amat - 1 =
@@ -308,7 +292,7 @@ buildDoorsGraph mat =
         | br > nrows amat - 1 =
           root
         | M.safeGet br bc amat == Just Offi =
-          let flood acc fcoord@(fr, fc) =
+          let flood acc (fr, fc) =
                 let ncoords = [] ++
                       (if (fr + 1, fc) `notElem` acc &&
                         M.safeGet (fr + 1) fc amat == Just Offi
@@ -331,7 +315,7 @@ buildDoorsGraph mat =
               b = Boundaries
                 (minimum (map fst roomcoords), minimum (map snd roomcoords))
                 (maximum (map fst roomcoords), maximum (map snd roomcoords))
-              neighs = map (\(a, b) -> (a, fromJust b)) (filter ((/=Nothing) . snd)
+              neighs = map (\(a, bx) -> (a, fromJust bx)) (filter ((/=Nothing) . snd)
                 [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
                 , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
                 , (East,  M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
@@ -366,7 +350,7 @@ buildDoors input graph = do
     placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
     placeDoors amat (GHall conns) =
       foldM placeDoors amat conns
-    placeDoors amat (GRoom neighs bounds) =
+    placeDoors amat (GRoom neighs bs) =
       if Hall `elem` map snd neighs
       then do
         traceIO "door in Hall"
@@ -377,23 +361,23 @@ buildDoors input graph = do
           North ->
             inRow
               amat
-              (fst (matmin bounds) - 1)
+              (fst (matmin bs) - 1)
-              (snd (matmin bounds), snd (matmax bounds))
+              (snd (matmin bs), snd (matmax bs))
           South ->
             inRow
               amat
-              (fst (matmax bounds) + 1)
+              (fst (matmax bs) + 1)
-              (snd (matmin bounds), snd (matmax bounds))
+              (snd (matmin bs), snd (matmax bs))
           East ->
             inCol
               amat
-              (fst (matmin bounds), fst (matmax bounds))
+              (fst (matmin bs), fst (matmax bs))
-              (snd (matmin bounds) - 1)
+              (snd (matmin bs) - 1)
           West ->
             inCol
               amat
-              (fst (matmin bounds), fst (matmax bounds))
+              (fst (matmin bs), fst (matmax bs))
-              (snd (matmax bounds) + 1)
+              (snd (matmax bs) + 1)
       else do
         traceIO "door in Office"
         idx <- randomRIO (0, length neighs - 1)
@@ -402,23 +386,23 @@ buildDoors input graph = do
           North ->
             inRow
               amat
-              (fst (matmin bounds) - 1)
+              (fst (matmin bs) - 1)
-              (snd (matmin bounds), snd (matmax bounds))
+              (snd (matmin bs), snd (matmax bs))
           South ->
             inRow
               amat
-              (fst (matmax bounds) + 1)
+              (fst (matmax bs) + 1)
-              (snd (matmin bounds), snd (matmax bounds))
+              (snd (matmin bs), snd (matmax bs))
           East ->
             inCol
               amat
-              (fst (matmin bounds), fst (matmax bounds))
+              (fst (matmin bs), fst (matmax bs))
-              (snd (matmin bounds) - 1)
+              (snd (matmin bs) - 1)
           West ->
             inCol
               amat
-              (fst (matmin bounds), fst (matmax bounds))
+              (fst (matmin bs), fst (matmax bs))
-              (snd (matmax bounds) + 1)
+              (snd (matmax bs) + 1)
     inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
     inRow mat row cols = do
       col <- randomRIO cols

src/Main.hs

@@ -41,7 +41,7 @@ pre :: Affection UserData ()
 pre = do
   Subsystems w m <- subsystems <$> getAffection
   _ <- partSubscribe w (fitViewport (1280/720))
-  _ <- partSubscribe w (exitOnWindowClose)
+  _ <- partSubscribe w exitOnWindowClose
   return ()
 
 update :: Double -> Affection UserData ()

src/Test.hs

@@ -1,52 +1,93 @@
 module Test where
 
-import Affection as A
+import Affection as A hiding (get)
 
+import SDL (get, ($=))
+import qualified SDL
+import qualified Graphics.Rendering.OpenGL as GL hiding (get)
+
+import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
 
 import Data.Matrix (toLists)
 
-import NanoVG
+import NanoVG hiding (V2(..))
 
 import Types
 
 import Floorplan
 
+import Linear
+
 import Foreign.C.Types (CFloat(..))
 
+import Debug.Trace
 
 loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
-  let fc = FloorConfig (10, 10) [] (50,50)
+  let fc = FloorConfig (20, 20) [(5,5), (45, 95)] (50,100)
+      (Subsystems _ m) = subsystems ud
   matrix <- liftIO $ buildHallFloorIO fc
+  uu <- partSubscribe m movePlayer
   putAffection ud
     { stateData = MenuData
       { mapMat = matrix
-      , initCoords = (50, 250)
+      , initCoords = (0, 500)
+      , playerCoords = (20, 20)
+      }
+    , uuid = [uu]
+    }
+
+relativizeMouseCoords :: V2 Int32 -> IO (V2 Double)
+relativizeMouseCoords (V2 ix iy) = do
+  (GL.Position vx vy, GL.Size vw vh) <- 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)
+
+movePlayer :: MouseMessage -> Affection UserData ()
+movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] mv2@(V2 mx my) _) = do
+  ud <- getAffection
+  rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
+  let dr = (- ry) + (- rx)
+      dc = (- rx) - (- ry) / 2
+      (pr, pc) = playerCoords $ stateData ud
+  liftIO $ traceIO $ "delta: " ++ show (V2 rx ry)
+  liftIO $ traceIO $ "movement: " ++ show (V2 dr dc)
+  putAffection ud
+    { stateData = (stateData ud)
+      { playerCoords = (pr - dr, pc - dc)
       }
     }
+movePlayer _ = return ()
 
 drawMap :: Affection UserData ()
 drawMap = do
   ud <- getAffection
   let matrix = mapMat (stateData ud)
-  mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [1..] ls))
+  mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls))
-    (zip [1..] (toLists matrix))
+    (zip [0..] (toLists matrix))
 
 drawTile :: Int -> Int -> TileState -> Affection UserData ()
 drawTile row col tile = do
-  ctx <- nano <$> getAffection
+  ud <- getAffection
-  (xinit, yinit) <- initCoords <$> stateData <$> getAffection
+  let ctx = nano ud
-  let tileWidth = 20 :: CFloat
+      (xinit, yinit) = initCoords $ stateData ud
-      tileHeight = 10 :: CFloat
+      (pr, pc) = playerCoords $ stateData ud
+      tileWidth = 20 :: Double
+      tileHeight = 10 :: Double
   liftIO $ do
     save ctx
     beginPath ctx
-    let x = fromIntegral xinit + (fromIntegral col * tileWidth / 2) +
+    let x = realToFrac $ 650 + ((fromIntegral col - pc) +
-          (fromIntegral row * tileWidth / 2)
+          (fromIntegral row - pr)) * (tileWidth / 2)
-        y = fromIntegral yinit + (fromIntegral row * tileHeight / 2) -
+        y = realToFrac $ 360 + ((fromIntegral row - pr) -
-          (fromIntegral col * tileHeight / 2)
+          (fromIntegral col - pc)) * (tileHeight / 2)
     fillColor ctx (case tile of
       Wall -> rgba 128 128 128 255
       Door -> rgba 255 128 128 255
@@ -58,9 +99,15 @@ drawTile row col tile = do
       _    -> rgba 255 255 0   255
       )
     moveTo ctx x y
-    lineTo ctx (x + tileWidth / 2) (y + tileHeight / 2)
+    lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight / 2)
-    lineTo ctx (x + tileWidth) y
+    lineTo ctx (x + realToFrac tileWidth) y
-    lineTo ctx (x + tileWidth / 2) (y - tileHeight / 2)
+    lineTo ctx (x + realToFrac tileWidth / 2) (y - realToFrac tileHeight / 2)
     closePath ctx
     fill ctx
+    when (floor pr + 1 == row && floor pc + 1 == 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

@@ -5,19 +5,14 @@ module Types.UserData where
 
 import Affection
 
-import qualified SDL
-
 import Control.Concurrent.STM
 
 import NanoVG hiding (V2(..), V3(..))
 
 import qualified Data.Map.Strict as M
-import Data.Text (Text(..))
 import Data.Matrix
 import Data.Ecstasy
 
-import Linear
-
 import Types.Map
 
 data UserData = UserData
@@ -39,6 +34,7 @@ data StateData
   | MenuData
     { mapMat :: Matrix TileState
     , initCoords :: (Int, Int)
+    , playerCoords :: (Double, Double)
     }
 
 data ImgId
@@ -106,15 +102,15 @@ generalSubscribe
   -> (msg -> Affection UserData ())
   -> Affection UserData UUID
 generalSubscribe t funct = do
-  uuid <- genUUID
+  uu <- genUUID
-  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+  liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
-  return uuid
+  return uu
 
 generalUnSubscribe
   :: TVar [(UUID, msg -> Affection UserData ())]
   -> UUID
   -> Affection UserData ()
-generalUnSubscribe t uuid =
+generalUnSubscribe t uu =
-  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
+  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
   where
     filterMsg (u, _) p = u /= p