pituicat/src/Map.hs

74 lines
2.2 KiB
Haskell
Raw Normal View History

2020-10-09 23:00:33 +00:00
{-# LANGUAGE OverloadedStrings #-}
2020-10-09 03:51:00 +00:00
module Map where
2020-10-16 23:51:19 +00:00
import qualified Graphics.Rendering.OpenGL as GL
2020-10-09 03:51:00 +00:00
import Linear
2020-10-09 23:00:33 +00:00
import Codec.Picture
import Codec.Picture.Extra
2020-10-09 23:00:33 +00:00
import qualified Data.Vector as V
2020-10-16 23:51:19 +00:00
import Control.Monad (foldM)
2020-10-09 03:51:00 +00:00
-- internal imports
import Types
import Graphics
2020-10-09 03:51:00 +00:00
2020-10-16 23:51:19 +00:00
constructMap :: LevelDescriptor -> GL.GLuint -> IO LevelMap
constructMap desc tilemapSlot = do
tilemap <- uncurry TileMap <$> newTexture (levelTileMap desc) tilemapSlot
2020-10-16 23:51:19 +00:00
(layers, dimensions) <- foldM
(\(layers, dims) descTup -> do
(nlayer, ndims) <-
readLayer descTup (fmap fromIntegral $ tileMapDimensions tilemap)
2020-10-16 23:51:19 +00:00
if not (null layers) && ndims /= dims
then error ("Map Layer dimensions mismatch in: " <> snd descTup)
else return (layers ++ [nlayer], ndims)
)
([], V2 0 0)
(V.fromList $ levelLayerPath desc)
LevelMap
<$> pure (V.fromList layers)
<*> pure (levelWalkLayer desc)
<*> pure (fmap fromIntegral dimensions)
<*> pure tilemap
<*> pure (V2 (fst $ levelStartPos desc) (snd $ levelStartPos desc))
2020-10-09 03:51:00 +00:00
2020-10-09 23:00:33 +00:00
readLayer
:: (Word, FilePath) -- ^ index and path of the layer descriptor image
-> V2 Float -- ^ size of Tilemap in pixels
-> IO ((V.Vector Tile), V2 Int)
2021-01-03 00:43:37 +00:00
readLayer (_, path) (V2 tx ty) = do
img <- flipVertically <$> convertRGBA8 <$> either error id <$> readImage path
2020-10-09 23:00:33 +00:00
let width = imageWidth img
height = imageHeight img
2020-10-17 14:18:42 +00:00
layer = V.foldl
(\acc (py, px) -> case (pixelAt img px py) of
(PixelRGBA8 r g b _) -> if r >= 253
then
acc `V.snoc` Tile
(V2 (fromIntegral px) (fromIntegral py))
( (V2
((255 - fromIntegral g) * (32 / tx))
(1 - (255 - fromIntegral b + 1) * (32 / ty))
)
, (V2
((255 - fromIntegral g + 1) * (32 / tx))
(1 - (255 - fromIntegral b) * (32 / ty))
)
)
2020-10-17 14:18:42 +00:00
(case r of
255 -> Solid
254 -> Platform
_ -> Decoration
)
else
acc
2020-10-09 23:00:33 +00:00
)
2020-10-17 14:18:42 +00:00
V.empty
2020-10-09 23:00:33 +00:00
(V.fromList ((,) <$> [0 .. height - 1] <*> [0 .. width - 1]))
return (layer, V2 width height)