tracer/src/Util.hs

226 lines
7.1 KiB
Haskell
Raw 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-03-02 01:10:35 +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-03-03 10:06:38 +00:00
import Linear
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 =
map (\(i, ls) -> map (uncurry $ convertTile i) (zip [1..] ls))
(zip [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"
)
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-04-01 17:40:54 +00:00
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
astarAppl :: Matrix (Maybe ImgId) -> V2 Int -> V2 Int -> Maybe [V2 Int]
astarAppl imgmat target start = aStar
(naviGraph imgmat)
(\a b -> distance (fmap fromIntegral a) (fmap fromIntegral b))
(\a -> distance (fmap fromIntegral target) (fmap fromIntegral a))
(== target)
start
naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int)
naviGraph imgmat (V2 r c) =
let list1 =
2018-04-25 12:44:28 +00:00
foldl
(\acc (or, oc) ->
if null
(fromMaybe [] $
imgObstacle <$> M.safeGet (r + or) (c + oc) imgmat)
2018-04-25 12:44:28 +00:00
then V2 (r + or) (c + oc): acc
else acc
)
[]
[(0, 1), (0, -1), (1, 0), (-1, 0)]
list2 =
2018-04-25 12:44:28 +00:00
foldl
(\acc (or, oc) ->
if null (fromMaybe [] $
imgObstacle <$> M.safeGet (r + or) (c + oc) imgmat)
2018-05-14 17:34:07 +00:00
&& all null
2018-04-25 12:44:28 +00:00
(map
(\(oor, ooc) -> fromMaybe [] $
imgObstacle <$> M.safeGet (r + oor) (c + ooc) imgmat)
[(0, oc), (or, 0)])
2018-04-25 12:44:28 +00:00
then V2 (r + or) (c + oc): acc
else acc
)
[]
[(-1, -1), (-1, 1), (1, -1), (1, 1)]
in HS.fromList (list1 ++ list2)
drawLoadScreen :: UserData -> Float -> IO ()
drawLoadScreen ud progress = do
let ctx = nano ud
save ctx
fillColor ctx (rgb 255 128 0)
2018-06-10 02:21:00 +00:00
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
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 err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
mapM
(\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
let crs = map
(\i -> crop (xoffs + (i * w)) yoffs 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: " ++ fp ++ " " ++ show id)
exitFailure
else
return $ catMaybes mresimgs
return $
( id
, Animation dur imgs pb
)
) idconfs