tracer/src/Util.hs

374 lines
12 KiB
Haskell
Raw Permalink Normal View History

2018-03-02 01:10:35 +00:00
module Util where
import Affection as A
import Data.Matrix as M
2018-04-14 16:43:05 +00:00
import qualified Data.HashSet as HS
import qualified Data.Set as S
import qualified Data.Map as Map
import Data.ByteString.Lazy (toStrict)
2018-04-14 16:43:05 +00:00
import Data.Graph.AStar
import Data.Maybe
2018-07-19 02:51:07 +00:00
import qualified Data.Text as T
2019-10-28 17:20:34 +00:00
import Data.String
2018-03-02 01:10:35 +00:00
2020-05-05 04:29:35 +00:00
import Control.Monad
import Control.Concurrent.MVar
2018-09-18 01:13:53 +00:00
2018-03-03 10:06:38 +00:00
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import System.Exit (exitFailure)
2018-10-12 12:26:06 +00:00
import Linear hiding (E(..), translation)
2018-03-03 10:06:38 +00:00
import NanoVG hiding (V2(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Codec.Picture as CP
import Codec.Picture.Extra
2018-03-02 01:10:35 +00:00
-- internal imports
import Types
convertTileToImg :: Matrix TileState -> Matrix (Maybe ImgId)
convertTileToImg mat = fromLists conversion
where
conversion =
2018-09-02 08:44:33 +00:00
zipWith
(\i ls -> zipWith (convertTile i) [1..] ls)
[1..]
(toLists mat)
2018-03-02 01:10:35 +00:00
convertTile irow icol tile =
case tile of
Wall -> Just (case neighWalls irow icol mat of
4 ->
ImgWallCross
3
| M.safeGet (irow + 1) icol mat /= Just Wall &&
M.safeGet (irow + 1) icol mat /= Just Door ->
ImgWallTNW
| M.safeGet irow (icol + 1) mat /= Just Wall &&
M.safeGet irow (icol + 1) mat /= Just Door ->
ImgWallTSW
| M.safeGet (irow - 1) icol mat /= Just Wall &&
M.safeGet (irow - 1) icol mat /= Just Door ->
ImgWallTSE
| otherwise ->
ImgWallTNE
2
| (M.safeGet (irow + 1) icol mat == Just Wall ||
M.safeGet (irow + 1) icol mat == Just Door) &&
(M.safeGet (irow - 1) icol mat == Just Wall ||
M.safeGet (irow - 1) icol mat == Just Door) ->
ImgWallDesc
| (M.safeGet irow (icol + 1) mat == Just Wall ||
M.safeGet irow (icol + 1) mat == Just Door) &&
(M.safeGet irow (icol - 1) mat == Just Wall ||
M.safeGet irow (icol - 1) mat == Just Door) ->
ImgWallAsc
| (M.safeGet (irow - 1) icol mat == Just Wall ||
M.safeGet (irow - 1) icol mat == Just Door) &&
(M.safeGet irow (icol - 1) mat == Just Wall ||
M.safeGet irow (icol - 1) mat == Just Door) ->
ImgWallCornerW
| (M.safeGet irow (icol - 1) mat == Just Wall ||
M.safeGet irow (icol - 1) mat == Just Door) &&
(M.safeGet (irow + 1) icol mat == Just Wall ||
M.safeGet (irow + 1) icol mat == Just Door) ->
ImgWallCornerS
| (M.safeGet (irow + 1) icol mat == Just Wall ||
M.safeGet (irow + 1) icol mat == Just Door) &&
(M.safeGet irow (icol + 1) mat == Just Wall ||
M.safeGet irow (icol + 1) mat == Just Door) ->
ImgWallCornerE
| otherwise ->
ImgWallCornerN
1
| M.safeGet (irow - 1) icol mat == Just Wall ||
M.safeGet (irow - 1) icol mat == Just Door ->
ImgWallDesc
| M.safeGet (irow + 1) icol mat == Just Wall ||
M.safeGet (irow + 1) icol mat == Just Door ->
ImgWallDesc
| M.safeGet irow (icol + 1) mat == Just Wall ||
M.safeGet irow (icol + 1) mat == Just Door ->
ImgWallAsc
| otherwise ->
ImgWallAsc
0 ->
ImgWallCross
_ ->
error "unexpected number if neighbouring walls"
)
2018-04-01 17:40:54 +00:00
Offi
| any
(\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
[(1, 0), (-1, 0), (0, 1), (0, -1)] ->
2018-07-21 18:37:01 +00:00
Just ImgEmpty
2018-04-01 17:40:54 +00:00
| otherwise ->
Nothing
2018-11-12 23:56:18 +00:00
Kitc
| any
(\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
[(1, 0), (-1, 0), (0, 1), (0, -1)] ->
Just ImgEmpty
| otherwise ->
Nothing
Toil
| any
(\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
[(1, 0), (-1, 0), (0, 1), (0, -1)] ->
Just ImgEmpty
| otherwise ->
Nothing
2018-03-02 01:10:35 +00:00
_ ->
Nothing
neighWalls :: Int -> Int -> Matrix TileState -> Int
neighWalls row col mat =
Prelude.foldl (\acc (ir, ic) ->
if M.safeGet (row + ir) (col + ic) mat == Just Wall ||
M.safeGet (row + ir) (col + ic) mat == Just Door
then acc + 1
else acc
)
0
[ (0, -1)
, (-1, 0)
, (0, 1)
, (1, 0)
]
2018-03-03 10:06:38 +00:00
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)
2018-04-14 11:34:28 +00:00
inBounds :: V2 Int -> Boundaries Int -> Bool
inBounds (V2 r c) (Boundaries (minr, minc) (maxr, maxc)) =
(r >= minr && r <= maxr) && (c >= minc && c <= maxc)
2018-04-14 16:43:05 +00:00
2018-07-21 19:10:32 +00:00
astarAppl
:: Matrix (Maybe ImgId)
-> [(V2 Double, Boundaries Double)]
-> V2 Int
-> V2 Int
-> Maybe [V2 Int]
astarAppl imgmat animBounds target = aStar
(naviGraph imgmat animBounds)
2018-07-03 14:19:27 +00:00
(\a b -> distance
(fmap (fromIntegral :: Int -> Double) a)
(fmap (fromIntegral :: Int -> Double) b)
)
2018-09-02 08:44:33 +00:00
(distance (fmap fromIntegral target) . fmap fromIntegral)
2018-04-14 16:43:05 +00:00
(== target)
2018-07-21 19:10:32 +00:00
naviGraph
:: Matrix (Maybe ImgId)
-> [(V2 Double, Boundaries Double)]
-> V2 Int
-> HS.HashSet (V2 Int)
naviGraph imgmat animBounds (V2 r c) =
let list1 =
2018-04-25 12:44:28 +00:00
foldl
2018-07-03 14:19:27 +00:00
(\acc (rr, cc) ->
if null
2018-09-02 08:44:33 +00:00
(maybe [] collisionObstacle
2018-09-18 01:13:53 +00:00
(join $ M.safeGet (r + rr) (c + cc) imgmat)
++
2018-09-02 08:44:33 +00:00
map snd (filter
2018-07-21 19:10:32 +00:00
(\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds))
2018-10-14 21:18:41 +00:00
then V2 (r + rr) (c + cc) : acc
2018-04-25 12:44:28 +00:00
else acc
)
[]
[(0, 1), (0, -1), (1, 0), (-1, 0)]
list2 =
2018-04-25 12:44:28 +00:00
foldl
2018-07-03 14:19:27 +00:00
(\acc (rr, cc) ->
if null
2018-09-18 01:13:53 +00:00
(maybe [] collisionObstacle
2019-10-20 08:53:53 +00:00
(M.unsafeGet (r + rr) (c + cc) imgmat)
2018-09-18 01:13:53 +00:00
++
map snd (filter (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds))
2018-05-14 17:34:07 +00:00
&& all null
2018-04-25 12:44:28 +00:00
(map
(\(oor, ooc) -> (maybe [] collisionObstacle
2019-10-20 08:53:53 +00:00
(M.unsafeGet (r + oor) (c + ooc) imgmat)) ++
2018-09-02 08:44:33 +00:00
map snd (filter
(\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
animBounds))
2018-07-03 14:19:27 +00:00
[(0, cc), (rr, 0)])
2018-10-14 22:26:12 +00:00
then V2 (r + rr) (c + cc) : acc
2018-04-25 12:44:28 +00:00
else acc
)
[]
[(-1, -1), (-1, 1), (1, -1), (1, 1)]
in HS.fromList (list1 ++ list2)
2018-07-19 02:51:07 +00:00
drawLoadScreen :: UserData -> (Float, T.Text) -> IO ()
drawLoadScreen ud (progress, msg) = do
let ctx = nano ud
save ctx
fillColor ctx (rgb 255 128 0)
2018-06-10 02:21:00 +00:00
fontSize ctx 100
2020-05-05 04:29:35 +00:00
fonts <- readMVar (assetFonts ud)
fontFace ctx (fonts Map.! FontBedstead)
2018-06-10 02:21:00 +00:00
textAlign ctx (S.fromList [AlignCenter, AlignTop])
textBox ctx 0 300 1280 "Loading"
beginPath ctx
rect ctx
(640 - 640 * realToFrac progress) 450 (1280 * realToFrac progress) 20
closePath ctx
fill ctx
2018-07-19 02:51:07 +00:00
fontSize ctx 25
textBox ctx 0 500 1280 msg
restore ctx
loadAnimationSprites
:: FilePath -- Path to Sprite map
-> Context -- NanoVG context
-> [(AnimId, AnimationConfig)]
-> IO [(AnimId, Animation)]
loadAnimationSprites fp nvg idconfs = do
eimg <- readImage fp
case eimg of
Left err -> do
2019-10-28 17:20:34 +00:00
logIO Error (fromString err)
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
mapM
2018-09-02 08:44:33 +00:00
(\(i, AnimationConfig (xoffs, yoffs) (w, h) (sx, sy) count dur pb) -> do
let crs = map
2018-07-21 04:43:26 +00:00
(\iid -> crop (xoffs + (iid * sx)) (yoffs + (iid * sy)) w h img)
[0 .. (count - 1)]
mresimgs <- mapM
(\cr ->
createImageMem nvg
2022-02-18 20:34:02 +00:00
(S.singleton ImagePremultiplied) (toStrict $ encodePng cr))
crs
imgs <- if any isNothing mresimgs
then do
2019-10-28 17:20:34 +00:00
logIO
Error
("failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure
else
return $ catMaybes mresimgs
2018-09-02 08:44:33 +00:00
return
2018-07-03 14:19:27 +00:00
( i
, Animation dur imgs pb
)
) idconfs
2018-07-06 15:17:57 +00:00
direction :: V2 Double -> Maybe Direction
direction vel'@(V2 vr _) = if sqrt (vel' `dot` vel') > 0
then
let xuu =
acos ((vel' `dot` V2 0 1) /
sqrt (vel' `dot` vel')) / pi * 180
xu = if vr < 0 then 360 - xuu else xuu
d
| xu < 22.5 = NE
| xu > 22.5 && xu < 67.5 = E
| xu > 67.5 && xu < 112.5 = SE
| xu > 112.5 && xu < 157.5 = S
| xu > 157.5 && xu < 202.5 = SW
| xu > 202.5 && xu < 247.5 = W
| xu > 247.5 && xu < 292.5 = NW
| xu > 292.5 && xu < 337.5 = N
| xu > 337.5 = NE
| otherwise = NE
in Just d
else Nothing
2018-10-12 12:26:06 +00:00
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
where
nx = x * cos (dtor deg) + y * sin (dtor deg)
ny = x * sin (dtor deg) - y * cos (dtor deg)
dtor :: (Num a, Floating a) => a -> a
dtor = (pi / 180 *)
2020-05-05 04:29:35 +00:00
cacheJoypad :: UserData -> JoystickMessage -> Affection ()
cacheJoypad ud msg = do
joy <- liftIO $ readMVar (joyCache ud)
void $ liftIO $ swapMVar (joyCache ud) (msg : joy)
2018-10-12 12:26:06 +00:00
2020-05-05 04:29:35 +00:00
emitJoyActionMessage :: UserData -> JoystickMessage -> Affection ()
emitJoyActionMessage ud message = do
trans <- liftIO $ readMVar (translation ud)
case message of
MsgJoystickAxis time _ axis val -> do
case trans of
JoyTranslation tmap -> do
let Subsystems _ _ _ _ t = subsystems ud
vnormal = fromIntegral val / 32768
sigvnormal = abs vnormal
align
| signum vnormal >= 0 = AxisPositive
| signum vnormal < 0 = AxisNegative
case tmap Map.!? (AxisAction axis align) of
Just (ActUp _) -> partEmit t (ActionMessage (ActUp sigvnormal) time)
Just (ActDown _) -> partEmit t (ActionMessage (ActDown sigvnormal) time)
Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
_ -> return ()
_ -> return ()
MsgJoystickButton time _ but SDL.JoyButtonPressed -> do
2019-02-11 23:11:53 +00:00
let Subsystems _ _ _ _ t = subsystems ud
2020-05-05 04:29:35 +00:00
case trans of
JoyTranslation tmap -> do
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
Just act -> partEmit t (ActionMessage act time)
_ -> return ()
_ -> return ()
2019-02-13 11:09:41 +00:00
_ -> return ()
2019-02-11 23:11:53 +00:00
2020-05-05 04:29:35 +00:00
emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection ()
emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
2018-10-12 12:26:06 +00:00
let Subsystems _ _ _ _ t = subsystems ud
2019-02-11 23:11:53 +00:00
val = if press == SDL.Pressed then 1 else 0
2020-05-05 04:29:35 +00:00
trans <- liftIO $ readMVar (translation ud)
case trans of
2019-02-11 23:11:53 +00:00
KbdTranslation tmap -> do
case tmap Map.!? SDL.keysymKeycode sym of
Just (ActUp _) -> partEmit t (ActionMessage (ActUp val) time)
Just (ActDown _) -> partEmit t (ActionMessage (ActDown val) time)
Just (ActLeft _) -> partEmit t (ActionMessage (ActLeft val) time)
Just (ActRight _) -> partEmit t (ActionMessage (ActRight val) time)
Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
_ -> return ()
2019-02-13 11:09:41 +00:00
_ -> return ()
2020-05-05 04:29:35 +00:00
emitKbdActionMessage _ _ = return ()
2018-10-12 19:40:16 +00:00
2020-05-05 04:29:35 +00:00
fullClean :: UserData -> Affection ()
fullClean ud = do
2018-10-12 19:40:16 +00:00
let Subsystems w m k j t = subsystems ud
2020-05-05 04:29:35 +00:00
toClean <- liftIO $ readMVar $ uuid ud
2018-10-12 19:40:16 +00:00
mapM_ (\u -> do
partUnSubscribe w u
partUnSubscribe m u
partUnSubscribe k u
partUnSubscribe j u
partUnSubscribe t u
) toClean
2020-05-05 04:29:35 +00:00
void $ liftIO $ swapMVar (uuid ud) []