tinkering graphics

This commit is contained in:
nek0 2024-06-09 07:32:03 +02:00
parent 7a58d222ad
commit 6f93ead9d9
7 changed files with 93 additions and 55 deletions

View file

@ -81,13 +81,13 @@ handleMessage (Ping id') = do
) )
sock sock
-- handleMessage (TickUpdate !slice !wizard) = do handleMessage (TickUpdate !slice !wizard) = do
-- st <- get st <- get
-- let !newState = st let !newState = st
-- { scWizard = wizard { scWizard = wizard
-- , scMapSlice = slice , scMapSlice = slice
-- } }
-- put newState put newState
handleMessage x = handleMessage x =
liftIO $ putStrLn $ "received unexpected message from server: " <> show x liftIO $ putStrLn $ "received unexpected message from server: " <> show x

View file

@ -23,16 +23,14 @@ runGame = do
queue <- asks rcQueue queue <- asks rcQueue
clientId <- asks rcClientUUID clientId <- asks rcClientUUID
st <- get st <- get
-- recvThread <- liftIO $ forkIO $ forever $ receiveMessage sock queue st
liftIO $ sendMessage (ClientMessage clientId ClientReady) sock liftIO $ sendMessage (ClientMessage clientId ClientReady) sock
whileM_ whileM_
(liftIO (not <$> readIORef (scStopper st))) (liftIO (not <$> readIORef (scStopper st)))
(do (do
liftIO $ receiveMessage sock queue st liftIO $ receiveMessage sock queue st
handleMessages handleMessages
-- draw draw
) )
-- liftIO $ killThread recvThread
handleEvent handleEvent
:: Maybe Event :: Maybe Event

View file

@ -12,7 +12,9 @@ import qualified Data.Vector as V
import Graphics.Vty import Graphics.Vty
import Linear import Linear hiding (trace)
import Debug.Trace
-- internal imports -- internal imports
@ -23,7 +25,7 @@ vFOV :: Float
vFOV = pi / 2 vFOV = pi / 2
hFOV :: Float hFOV :: Float
hFOV = pi / 1.5 hFOV = pi / 2
draw :: Game () draw :: Game ()
draw = do draw = do
@ -34,90 +36,87 @@ draw = do
(w, h) <- liftIO $ displayBounds (outputIface vty) (w, h) <- liftIO $ displayBounds (outputIface vty)
let dims@(dw, dh) = (w, h - 4) let dims@(dw, dh) = (w, h - 4)
result = V.generate (fromIntegral dh) result = V.generate (fromIntegral dh)
(\mh -> string defAttr $ map (\mh -> map
(\mw -> drawPixel mapSlice wizard dims (fromIntegral mw, fromIntegral mh)) (\mw -> drawPixel mapSlice wizard dims (fromIntegral mw, fromIntegral mh))
[1 .. dw] [dw, dw - 1 .. 1]
) )
image = V.foldl (<->) image = V.foldl (<->)
emptyImage emptyImage
(result V.++ (V.map (string currentAttr) result V.++
V.foldl (V.++) V.empty (V.generate 4 (const $ V.singleton emptyImage))) V.foldl (V.++) V.empty (V.generate 4 (const $ V.singleton emptyImage)))
picture = picForImage image picture = picForImage image
liftIO $ update vty picture liftIO $ update vty picture
drawPixel drawPixel
:: MapSlice :: MapSlice -- ^ visible slice of the map
-> Wizard -> Wizard -- ^ Player
-> (Int, Int) -> (Int, Int) -- ^ Screen dimensions
-> (Float, Float) -> (Float, Float) -- ^ current "Pixel"
-> Char -> Char -- ^ resulting "Color"
drawPixel slice wizard (w, h) currentPixel = drawPixel slice wizard (w, h) currentPixel =
let rayLength = castRay let rayLength = castRay
(wizardRot wizard) (wizardRot wizard - pi / 2)
(wizardPos wizard)
slice slice
(fromIntegral w, fromIntegral h) (fromIntegral w, fromIntegral h)
currentPixel currentPixel
in getPixel (fromMaybe 5 rayLength) in getPixel (fromMaybe 5 rayLength)
castRay castRay
:: Float :: Float -- ^ Player rotation
-> V2 Float -> MapSlice -- ^ visible slice of the map
-> MapSlice -> (Float, Float) -- ^ Screen dimensions
-> (Float, Float) -> (Float, Float) -- ^ current "Pixel"
-> (Float, Float) -> Maybe Float -- ^ resulting ray length
-> Maybe Float castRay wizardRot slice (w, h) (dw, dh) =
castRay wizardRot wizardPos@(V2 wr wc) slice (w, h) (dw, dh) = let view@(V2 vr vc) = V2 0 1 `rotVec` (wizardRot + (- hFOV / 2 + dw * hFOV / w))
let slicePos@(V2 sr sc) =
V2 (wr + 5 - (fromIntegral $ floor wr)) (wc + 5 - (fromIntegral $ floor wc))
view@(V2 vr vc) = V2 0 1 `rotVec` (wizardRot + (- hFOV / 2 + dw * hFOV / w))
stepR = signum vr stepR = signum vr
stepC = signum vc stepC = signum vc
tMaxR = (fromIntegral $ floor $ wr + stepR - wr) / vr tMaxR = (fromIntegral $ floor $ 5 + stepR - 5) / vr
tMaxC = (fromIntegral $ floor $ wc + stepC - wc) / vc tMaxC = (fromIntegral $ floor $ 5 + stepC - 5) / vc
tDeltaR = stepR / vc tDeltaR = stepR / vc
tDeltaC = stepC / vc tDeltaC = stepC / vc
sliceRay = (sr, sc) : sliceRay = (5, 5) :
buildRay (tMaxR, tMaxC) (tDeltaR, tDeltaC) (stepR, stepC) (sr, sc) slicePos buildRay (tMaxR, tMaxC) (tDeltaR, tDeltaC) (stepR, stepC) (5, 5)
in fmap (/ cos (-vFOV / 2 + dh * vFOV / h)) (getRayCollision slicePos view slice sliceRay) -- result = fmap (/ cos (-vFOV / 2 + dh * vFOV / h)) (getRayCollision view slice sliceRay)
result = (getRayCollision view slice sliceRay)
in result
buildRay buildRay
:: (Float, Float) :: (Float, Float)
-> (Float, Float) -> (Float, Float)
-> (Float, Float) -> (Float, Float)
-> (Float, Float) -> (Float, Float)
-> V2 Float
-> [(Float, Float)] -> [(Float, Float)]
buildRay (tMaxR, tMaxC) delta@(tDeltaR, tDeltaC) rstep@(stepR, stepC) (r, c) slicePos = buildRay (tMaxR, tMaxC) delta@(tDeltaR, tDeltaC) rstep@(stepR, stepC) (r, c) =
if distance slicePos (V2 r c) < 4 if distance (V2 5 5) (V2 r c) < 4
then if tMaxR < tMaxC then if tMaxR < tMaxC
then then
let ntMaxR = tMaxR - tDeltaR let ntMaxR = tMaxR - tDeltaR
nr = r - stepR nr = r - stepR
in (nr, c) : buildRay (ntMaxR, tMaxC) delta rstep (nr, c) slicePos in (nr, c) : buildRay (ntMaxR, tMaxC) delta rstep (nr, c)
else else
let ntMaxC = tMaxC - tDeltaC let ntMaxC = tMaxC - tDeltaC
nc = c - stepC nc = c - stepC
in (r, nc) : buildRay (tMaxR, ntMaxC) delta rstep (r, nc) slicePos in (r, nc) : buildRay (tMaxR, ntMaxC) delta rstep (r, nc)
else [] else []
getRayCollision getRayCollision
:: V2 Float :: V2 Float
-> V2 Float
-> MapSlice -> MapSlice
-> [(Float, Float)] -> [(Float, Float)]
-> Maybe Float -> Maybe Float
getRayCollision _ _ _ [] = Nothing getRayCollision _ _ [] = Nothing
getRayCollision _ _ _ [_] = Nothing getRayCollision view@(V2 vr vc) mapSlice ((wizR, _):tile@(tr, tc):ts) =
getRayCollision pos@(V2 pr pc) view@(V2 vr vc) mapSlice ((wizR, _):tile@(tr, tc):ts) =
case msViewMap mapSlice M.! (floor tr, floor tc) of case msViewMap mapSlice M.! (floor tr, floor tc) of
Just Wall -> Just Wall ->
let t = if floor wizR == floor tr let t = if floor wizR == floor tr
then (fromIntegral (floor tc) + pc) / vc then (fromIntegral (floor tc) + 5) / vc
else (fromIntegral (floor tr) + pr) / vr else (fromIntegral (floor tr) + 5) / vr
vec = (* t) <$> view vec = (* t) <$> view
in Just (sqrt $ vec `dot` vec) --in trace ("boing" ++ show tile) $ Just (sqrt $ vec `dot` vec)
_ -> getRayCollision pos view mapSlice (tile:ts) in Just (distance vec (V2 5 5))
_ -> getRayCollision view mapSlice (tile:ts)
getRayCollision _ _ [_] = Nothing
getPixel :: Float -> Char getPixel :: Float -> Char
getPixel l getPixel l

View file

@ -66,7 +66,7 @@ main = do
-- shutdown vty -- shutdown vty
stopper <- newIORef False stopper <- newIORef False
clientState <- STM.newTMVarIO (ClientState undefined False) clientState <- STM.newTMVarIO (ClientState vty False)
let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) [] let initSlice = MapSlice (M.matrix 9 9 (const Nothing)) []
let initRead = ReaderContainer sock clientId queue let initRead = ReaderContainer sock clientId queue
initState = StateContainer (initWizard playerWizard) clientState initSlice stopper initState = StateContainer (initWizard playerWizard) clientState initSlice stopper

View file

@ -105,6 +105,7 @@ handleMessage stateContainer readerContainer msg = do
{ playerLastPong = (now, uuid) { playerLastPong = (now, uuid)
} }
void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers) void $ STM.swapTMVar (scPlayers stateContainer) (modPlayer : otherPlayers)
sendUpdate stateContainer (rcMap readerContainer) player
) )
mPlayer mPlayer
) )

View file

@ -1,3 +1,4 @@
{-# LANGUAGE RecordWildCards #-}
module Server.Communication.Send where module Server.Communication.Send where
import Control.Concurrent import Control.Concurrent
@ -14,6 +15,8 @@ import Control.Monad.State
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Matrix as M
import Data.Maybe import Data.Maybe
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -28,6 +31,8 @@ import Data.List
import Data.UUID import Data.UUID
import Data.UUID.V4 import Data.UUID.V4
import Linear
import Network.Socket import Network.Socket
-- internal imports -- internal imports
@ -122,6 +127,42 @@ dropClient clientList sock = do
mClient mClient
close sock close sock
sendUpdates sendUpdate
:: Game () :: StateContainer
sendUpdates = pure () -> ServerMap
-> Player
-> IO ()
sendUpdate stateContainer tileMap player = do
slice <- buildSlice player
sendSlice slice player
where
buildSlice :: Player -> IO MapSlice
buildSlice (Player _ (Wizard {..}) _ _) = do
let V2 wr wc = wizardPos
subCoords = (,) <$> [floor wr - 4 .. floor wr + 4] <*> [floor wc - 4 .. floor wc + 4]
leftBound = wizardRot + (pi / 4)
rightBound = wizardRot - (pi / 4)
leftLine row = cos leftBound * row
rightLine row = sin rightBound * row
correctionLeft = if wizardRot < pi / 2 || wizardRot > 2 * pi
then ceiling
else floor
correctionRight = if wizardRot < pi / 2 || wizardRot > 2 * pi
then ceiling
else floor
initViewMatrix = M.fromList 9 9 $ map
(\(qr, qc) ->
if qc - floor wc <= correctionLeft (leftLine (wr - fromIntegral qr))
&& qc - floor wc >= correctionRight (rightLine (wr - fromIntegral qr))
then
M.safeGet qr qc tileMap
else
Nothing
)
subCoords
pure (MapSlice initViewMatrix [])
sendSlice :: MapSlice -> Player -> IO ()
sendSlice slice (Player playerId wizard _ _) = do
let msg = TickUpdate slice wizard
print slice
liftIO $ sendMessage msg playerId (scClientSockets stateContainer)

View file

@ -38,7 +38,6 @@ runGame = do
handleMessages handleMessages
updateSpawners delta updateSpawners delta
updateWizards delta updateWizards delta
sendUpdates
modify' modify'
(\s -> s (\s -> s
{ scServerLastTick = now { scServerLastTick = now