373 lines
12 KiB
Haskell
373 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
|
|
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) []
|