tracer/src/Test.hs
2018-05-21 00:40:40 +02:00

430 lines
14 KiB
Haskell

module Test where
import Affection as A hiding (get)
import SDL (get, ($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import NanoVG hiding (V2(..))
import Control.Monad (when, unless, void)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
import Control.Concurrent (forkOS)
import Data.Map.Strict as Map
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
import System.Random (randomRIO)
import Linear
import Foreign.C.Types (CFloat(..))
import Debug.Trace
-- internal imports
import Interior
import Util
import Types
import Floorplan
import NPC
loadMap :: Affection UserData ()
loadMap = do
ud <- getAffection
let fc = FloorConfig
(20, 20)
[(5,5), (35, 35)]
(50, 50)
(Subsystems _ m) = subsystems ud
(mat, gr) <- liftIO $ buildHallFloorIO fc
let imgmat = convertTileToImg mat
exits = Prelude.foldl
(\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
then ReachPoint RoomExit (V2 r c) : acc
else acc
)
[]
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
-- liftIO $ A.logIO A.Debug (show exits)
(inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr
liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps))
let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length nnex)
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
void $ createEntity $ newEntity
{ pos = Just (V2 20.5 20.5)
, vel = Just (V2 0 0)
, player = Just ()
, rot = Just SE
}
void $ mapM_ (\npcpos@(V2 nr nc) -> do
-- ttl <- liftIO $ randomRIO (5, 30)
fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO $ newEmptyMVar
_ <- liftIO $ forkOS $ getPath (fmap floor npcpos) future nnex inter
createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0)
, velFact = Just fact
, rot = Just SE
, npcState = Just (NPCStanding 0 future)
}
) npcposs
uu <- partSubscribe m movePlayer
putAffection ud
{ worldState = nws
, stateData = MenuData
{ mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $
Prelude.map
(\a -> if a == Just ImgEmpty then Nothing else a)
(M.toList inter)
, initCoords = (0, 500)
, reachPoints = rps
}
, uuid = [uu]
}
mouseToPlayer :: V2 Int32 -> Affection UserData ()
mouseToPlayer mv2 = do
ud <- getAffection
(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
let dr = (ry / sin (atan (1/2)) / 2) + rx
dc = rx - (ry / sin (atan (1/2)) / 2)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do
with player
pure $ unchanged
{ vel = Set $ 4 * V2 dr dc
}
putAffection ud
{ worldState = nws
}
movePlayer :: MouseMessage -> Affection UserData ()
movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do
with player
pure $ unchanged
{ vel = Set $ V2 0 0
}
putAffection ud
{ worldState = nws
}
movePlayer _ = return ()
drawMap :: Affection UserData ()
drawMap = do
ud <- getAffection
dt <- getDelta
(_, (playerPos, playerRot, npcposrots)) <- liftIO $ yieldSystemT (worldState ud) $ do
(pc, dir) <- fmap head $ efor allEnts $ do
with player
with pos
with rot
pos' <- query pos
rot' <- query rot
pure (pos', rot')
-- (_, npcposs) <- yieldSystemT (worldState ud) $ do
npcsrots <- efor allEnts $ do
with npcState
with pos
pos' <- query pos
rot' <- query rot
pure (pos', rot')
return (pc, dir, npcsrots)
let V2 pr pc = playerPos
mat = imgMat (stateData ud)
ctx = nano ud
cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat)
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 -- draw floor
beginPath ctx
moveTo ctx (x + realToFrac tileWidth / 2) y
lineTo ctx
(x + cols * (realToFrac tileWidth / 2))
(y - (realToFrac tileHeight / 2) * (cols - 1))
lineTo ctx
(x + (realToFrac tileWidth / 2) * (cols + rows - 1))
(y + (rows - cols) * (realToFrac tileHeight / 2))
lineTo ctx
(x + (realToFrac tileWidth / 2) * rows)
(y + (realToFrac tileHeight / 2) * (rows - 1))
closePath ctx
fillColor ctx (rgb 255 255 255)
fill ctx
mapM_ (\(i, ls) -> mapM_
(\(j, t) -> do
drawTile (assetImages ud) ctx pr pc i j t (dirToImgId playerRot)
drawNPCs (assetImages ud) ctx ud npcposrots pr pc i j t
)
(reverse $ zip [1..] ls))
(zip [1..] (toLists mat))
-- liftIO $ do -- draw FPS
fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ("FPS: " `T.append` (T.pack $ Prelude.take 5 $ show (1/dt)))
updateMap :: Double -> Affection UserData ()
updateMap dt = do
let direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
then toEnum (
let xuu = floor
((((acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel'))) /
pi) + 0.25) * 4 )
xu = if vr < 0 then 7 - xuu else xuu
in A.log A.Debug ("xu: " ++ show xu) xu)
else rot'
ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do
without player
with vel
with velFact
with pos
with rot
pos'@(V2 pr pc) <- query pos
vel' <- query vel
rot' <- query rot
fact' <- query velFact
let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel'
dpos = npos - pos'
ent = unchanged
{ pos = Set $ npos
, rot = Set $ direction vel' rot'
}
return ent
emap allEnts $ do
with player
with vel
with pos
with rot
pos'@(V2 pr pc) <- query pos
vel'@(V2 vr vc) <- query vel
rot' <- query rot
let npos@(V2 nr nc) = pos' + fmap (* dt) vel'
dpos@(V2 dpr dpc) = npos - pos'
len = sqrt (dpos `dot` dpos)
lll = (,)
<$> (
if dpr < 0
then [(floor dpr :: Int) .. 0]
else [0 .. (ceiling dpr :: Int)])
<*> (
if dpc < 0
then [(floor dpc :: Int) .. 0]
else [0 .. (ceiling dpc :: Int)])
-- lll = Prelude.map (\i ->
-- let lrow =
-- [ (nr - (fromIntegral $ floor nr))
-- , (nr - (fromIntegral $ floor nr)) + (dpr / len)
-- ..
-- ]
-- lcol =
-- [ (nc - (fromIntegral $ floor nc))
-- , (nc - (fromIntegral $ floor nc)) + (dpc / len)
-- ..
-- ]
-- in (fromIntegral (floor (lrow !! i)), fromIntegral (floor (lcol !! i)))
-- )
-- [ 0 .. floor len]
ent = unchanged
{ pos = Set $ pos' + dpos * Prelude.foldl
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
in A.log A.Verbose (show ret) ret)
(V2 1 1)
(
concatMap
(\(dr, dc) ->
let bs = fromMaybe [] (imgObstacle <$> (M.safeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(imgMat (stateData ud))))
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
Boundaries
(minr + fromIntegral dr, minc + fromIntegral dc)
(maxr + fromIntegral dr, maxc + fromIntegral dc)
) bs
)
(A.log A.Verbose (show lll ++ " " ++ show len) lll)
)
, rot = Set (A.log A.Debug ("dir: " ++ show (direction vel' rot'))
(direction vel' rot'))
}
return ent
updateNPCs
(imgMat $ stateData ud)
(Prelude.filter
(\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud)
)
dt
putAffection ud
{ worldState = nws
}
drawTile
:: Map ImgId Image
-> Context
-> Double
-> Double
-> Int
-> Int
-> Maybe ImgId
-> ImgId
-> IO ()
drawTile ai ctx pr pc row col img playerImg =
when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
(realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $
do
save ctx
if (isNothing img)
then drawPlayer
else do
if (Prelude.null mb)
then do
drawImage
drawPlayer
else do
if (all (\m -> pr > (fromIntegral (floor pr :: Int)) + m) minrs &&
all (\m -> pc < (fromIntegral (floor pc :: Int)) + m) mincs) ||
(all (\m -> pr > (fromIntegral (floor pr :: Int)) + m) minrs &&
all (\m -> pc < (fromIntegral (floor pc :: Int)) + m) maxcs)
then do
drawImage
drawPlayer
else do
drawPlayer
drawImage
restore ctx
where
tileWidth = 64 :: Double
tileHeight = 32 :: Double
minrs = Prelude.map (fst . matmin) mb
maxrs = Prelude.map (fst . matmax) mb
mincs = Prelude.map (snd . matmin) mb
maxcs = Prelude.map (snd . matmax) mb
x = realToFrac $ 640 + ((fromIntegral col - pc) +
(fromIntegral row - pr)) * (tileWidth / 2) :: CFloat
y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) -
(fromIntegral col - pc)) * (tileHeight / 2) :: CFloat
dist = distance (V2 (fromIntegral row) (fromIntegral col))
(V2 (realToFrac pr - 1) (realToFrac pc)) / 4
fact =
if (pr <= fromIntegral row + minimum maxrs &&
pc >= fromIntegral col + maximum mincs) &&
isWall (fromJust img)
then min 1 dist
else 1
mb = imgObstacle img
drawImage = do
beginPath ctx
paint <- imagePattern
ctx x (y - (74 - realToFrac tileHeight))
(realToFrac tileWidth) 74
0
(ai Map.! fromJust img)
fact
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
paint <- imagePattern
ctx 608 302 64 74 0 (ai Map.! playerImg) 1
rect ctx 608 302 64 74
fillPaint ctx paint
-- circle ctx 640 360 5
-- closePath ctx
-- fillColor ctx (rgba 0 255 255 255)
fill ctx
checkBoundsCollision
:: V2 Double
-> V2 Double
-> V2 Double
-> Boundaries Double
-> V2 Double
checkBoundsCollision
(V2 pr pc) (V2 fr fc) (V2 mr mc) (Boundaries (minr, minc) (maxr, maxc))
| ntestc && ntestr && not testr && not testc = V2 (1 * mr) (1 * mc)
| ntestc && ntestr && not testc = V2 (1 * mr) (0 * mc)
| ntestr && ntestc && not testr = V2 (0 * mr) (1 * mc)
| not ntestr && not ntestc = V2 (1 * mr) (1 * mc)
| not ntestr && ntestc = V2 (1 * mr) (1 * mc)
| not ntestc && ntestr = V2 (1 * mr) (1 * mc)
| otherwise = V2 (0 * mr) (0 * mc)
where
ntestr
= ndistr <= hheight + 0.15
-- | ncdistsq <= 0.005 = True
ntestc
= ndistc <= hwidth + 0.15
-- | ncdistsq <= 0.005 = True
testr
= distr <= hheight + 0.15
-- | cdistsq <= 0.005 = True
testc
= distc <= hwidth + 0.15
-- | cdistsq <= 0.005 = True
ndistr = abs (fr - (fromIntegral (floor fr :: Int) + (minr + hheight)))
ndistc = abs (fc - (fromIntegral (floor fc :: Int) + (minc + hwidth)))
distr = abs (pr - (fromIntegral (floor fr :: Int) + (minr + hheight)))
distc = abs (pc - (fromIntegral (floor fc :: Int) + (minc + hwidth)))
hheight = (maxr - minr) / 2
hwidth = (maxc - minc) / 2
ncdistsq = (ndistr - hheight) ^ (2 :: Int) + (ndistc - hwidth) ^ (2 :: Int)
cdistsq = (distr - hheight) ^ (2 :: Int) + (distc - hwidth) ^ (2 :: Int)
checkBoundsCollision2
:: V2 Double
-> V2 Double
-> Double
-> V2 Double
-> Boundaries Double
-> V2 Double
checkBoundsCollision2
pre@(V2 pr pc) next@(V2 nr nc) dt acc (Boundaries (minr, minc) (maxr, maxc))
| colltr < dt && colltc < dt = V2 0 0
| colltr < dt && incol = V2 0 1 * acc
| colltc < dt && inrow = V2 1 0 * acc
| otherwise = acc
where
vel@(V2 vr vc) = fmap (/ dt) (next - pre)
colltr
| vr > 0 && prr <= maxr =
(((fromIntegral (floor pr :: Int)) + minr - 0.15) - pr) / vr
| vr < 0 && prr >= minr =
(((fromIntegral (floor pr :: Int)) + maxr + 0.15) - pr) / vr
| otherwise = dt
colltc
| vc > 0 && prc <= maxc =
(((fromIntegral (floor pc :: Int)) + minc - 0.15) - pc) / vc
| vc < 0 && prc >= minc =
(((fromIntegral (floor pc :: Int)) + maxc + 0.15) - pc) / vc
| otherwise = dt
inrow = pr > minr && pr < maxr
incol = pc > minc && pc < maxc
prr = pr - (fromIntegral $ floor pr)
prc = pc - (fromIntegral $ floor pc)