adding simple mouse coordination

This commit is contained in:
nek0 2018-02-18 03:11:41 +01:00
parent 53321a2576
commit 3c3a152265
4 changed files with 104 additions and 77 deletions

View file

@ -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
, Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds))
, Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col)
, Boundaries coord (matmax bounds)
in ( [ Boundaries (matmin bs) coord
, Boundaries (fst (matmin bs), col) (row, snd (matmax bs))
, Boundaries (row, snd (matmin bs)) (fst (matmax bs), col)
, 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
bounds =
let nbs = map (\(mi, ma) -> Boundaries mi ma) bs
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
| M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c
| otherwise = r
maxCol r c
let 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)
(snd (matmin bounds), snd (matmax bounds))
(fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs))
South ->
inRow
amat
(fst (matmax bounds) + 1)
(snd (matmin bounds), snd (matmax bounds))
(fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs))
East ->
inCol
amat
(fst (matmin bounds), fst (matmax bounds))
(snd (matmin bounds) - 1)
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
West ->
inCol
amat
(fst (matmin bounds), fst (matmax bounds))
(snd (matmax bounds) + 1)
(fst (matmin bs), fst (matmax bs))
(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)
(snd (matmin bounds), snd (matmax bounds))
(fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs))
South ->
inRow
amat
(fst (matmax bounds) + 1)
(snd (matmin bounds), snd (matmax bounds))
(fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs))
East ->
inCol
amat
(fst (matmin bounds), fst (matmax bounds))
(snd (matmin bounds) - 1)
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
West ->
inCol
amat
(fst (matmin bounds), fst (matmax bounds))
(snd (matmax bounds) + 1)
(fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1)
inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
inRow mat row cols = do
col <- randomRIO cols

View file

@ -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 ()

View file

@ -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))
(zip [1..] (toLists matrix))
mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls))
(zip [0..] (toLists matrix))
drawTile :: Int -> Int -> TileState -> Affection UserData ()
drawTile row col tile = do
ctx <- nano <$> getAffection
(xinit, yinit) <- initCoords <$> stateData <$> getAffection
let tileWidth = 20 :: CFloat
tileHeight = 10 :: CFloat
ud <- getAffection
let ctx = nano ud
(xinit, yinit) = initCoords $ stateData ud
(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) +
(fromIntegral row * tileWidth / 2)
y = fromIntegral yinit + (fromIntegral row * tileHeight / 2) -
(fromIntegral col * tileHeight / 2)
let x = realToFrac $ 650 + ((fromIntegral col - pc) +
(fromIntegral row - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((fromIntegral row - pr) -
(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 + tileWidth) y
lineTo ctx (x + tileWidth / 2) (y - tileHeight / 2)
lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight / 2)
lineTo ctx (x + realToFrac tileWidth) y
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

View file

@ -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
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
generalUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where
filterMsg (u, _) p = u /= p