tracer/src/Util.hs

374 lines
12 KiB
Haskell

module Util where
import Affection as A
import Data.Matrix as M
import qualified Data.HashSet as HS
import qualified Data.Set as S
import qualified Data.Map as Map
import Data.ByteString.Lazy (toStrict)
import Data.Graph.AStar
import Data.Maybe
import qualified Data.Text as T
import Data.String
import Control.Monad
import Control.Concurrent.MVar
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import System.Exit (exitFailure)
import Linear hiding (E(..), translation)
import NanoVG hiding (V2(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Codec.Picture as CP
import Codec.Picture.Extra
-- internal imports
import Types
convertTileToImg :: Matrix TileState -> Matrix (Maybe ImgId)
convertTileToImg mat = fromLists conversion
where
conversion =
zipWith
(\i ls -> zipWith (convertTile i) [1..] ls)
[1..]
(toLists mat)
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"
)
Offi
| any
(\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
[(1, 0), (-1, 0), (0, 1), (0, -1)] ->
Just ImgEmpty
| otherwise ->
Nothing
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
_ ->
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)
]
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)
inBounds :: V2 Int -> Boundaries Int -> Bool
inBounds (V2 r c) (Boundaries (minr, minc) (maxr, maxc)) =
(r >= minr && r <= maxr) && (c >= minc && c <= maxc)
astarAppl
:: Matrix (Maybe ImgId)
-> [(V2 Double, Boundaries Double)]
-> V2 Int
-> V2 Int
-> Maybe [V2 Int]
astarAppl imgmat animBounds target = aStar
(naviGraph imgmat animBounds)
(\a b -> distance
(fmap (fromIntegral :: Int -> Double) a)
(fmap (fromIntegral :: Int -> Double) b)
)
(distance (fmap fromIntegral target) . fmap fromIntegral)
(== target)
naviGraph
:: Matrix (Maybe ImgId)
-> [(V2 Double, Boundaries Double)]
-> V2 Int
-> HS.HashSet (V2 Int)
naviGraph imgmat animBounds (V2 r c) =
let list1 =
foldl
(\acc (rr, cc) ->
if null
(maybe [] collisionObstacle
(join $ M.safeGet (r + rr) (c + cc) imgmat)
++
map snd (filter
(\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds))
then V2 (r + rr) (c + cc) : acc
else acc
)
[]
[(0, 1), (0, -1), (1, 0), (-1, 0)]
list2 =
foldl
(\acc (rr, cc) ->
if null
(maybe [] collisionObstacle
(M.unsafeGet (r + rr) (c + cc) imgmat)
++
map snd (filter (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds))
&& all null
(map
(\(oor, ooc) -> (maybe [] collisionObstacle
(M.unsafeGet (r + oor) (c + ooc) imgmat)) ++
map snd (filter
(\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
animBounds))
[(0, cc), (rr, 0)])
then V2 (r + rr) (c + cc) : acc
else acc
)
[]
[(-1, -1), (-1, 1), (1, -1), (1, 1)]
in HS.fromList (list1 ++ list2)
drawLoadScreen :: UserData -> (Float, T.Text) -> IO ()
drawLoadScreen ud (progress, msg) = do
let ctx = nano ud
save ctx
fillColor ctx (rgb 255 128 0)
fontSize ctx 100
fonts <- readMVar (assetFonts ud)
fontFace ctx (fonts Map.! FontBedstead)
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
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
logIO Error (fromString err)
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
mapM
(\(i, AnimationConfig (xoffs, yoffs) (w, h) (sx, sy) count dur pb) -> do
let crs = map
(\iid -> crop (xoffs + (iid * sx)) (yoffs + (iid * sy)) w h img)
[0 .. (count - 1)]
mresimgs <- mapM
(\cr ->
createImageMem nvg
(S.singleton ImagePremultiplied) (toStrict $ encodePng cr))
crs
imgs <- if any isNothing mresimgs
then do
logIO
Error
("failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure
else
return $ catMaybes mresimgs
return
( i
, Animation dur imgs pb
)
) idconfs
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
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 *)
cacheJoypad :: UserData -> JoystickMessage -> Affection ()
cacheJoypad ud msg = do
joy <- liftIO $ readMVar (joyCache ud)
void $ liftIO $ swapMVar (joyCache ud) (msg : joy)
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
let Subsystems _ _ _ _ t = subsystems ud
case trans of
JoyTranslation tmap -> do
case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
Just act -> partEmit t (ActionMessage act time)
_ -> return ()
_ -> return ()
_ -> return ()
emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection ()
emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
let Subsystems _ _ _ _ t = subsystems ud
val = if press == SDL.Pressed then 1 else 0
trans <- liftIO $ readMVar (translation ud)
case trans of
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 ()
_ -> return ()
emitKbdActionMessage _ _ = return ()
fullClean :: UserData -> Affection ()
fullClean ud = do
let Subsystems w m k j t = subsystems ud
toClean <- liftIO $ readMVar $ uuid ud
mapM_ (\u -> do
partUnSubscribe w u
partUnSubscribe m u
partUnSubscribe k u
partUnSubscribe j u
partUnSubscribe t u
) toClean
void $ liftIO $ swapMVar (uuid ud) []