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 (join, when) 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 fontFace ctx (assetFonts ud 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 :: JoystickMessage -> Affection UserData () cacheJoypad msg = do ud <- getAffection putAffection ud { joyCache = msg : joyCache ud } emitJoyActionMessage :: JoystickMessage -> Affection UserData () emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do ud <- getAffection case translation ud 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 () emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do ud <- getAffection let Subsystems _ _ _ _ t = subsystems ud case (translation ud) of JoyTranslation tmap -> do case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of Just act -> partEmit t (ActionMessage act time) _ -> return () _ -> return () emitJoyActionMessage _ = return () emitKbdActionMessage :: KeyboardMessage -> Affection UserData () emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do ud <- getAffection let Subsystems _ _ _ _ t = subsystems ud val = if press == SDL.Pressed then 1 else 0 case (translation ud) 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 :: Affection UserData () fullClean = do ud <- getAffection let Subsystems w m k j t = subsystems ud toClean = uuid ud mapM_ (\u -> do partUnSubscribe w u partUnSubscribe m u partUnSubscribe k u partUnSubscribe j u partUnSubscribe t u ) toClean putAffection ud { uuid = [] }