72 lines
2.2 KiB
Haskell
72 lines
2.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Map where
|
|
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
|
|
import Linear
|
|
|
|
import Codec.Picture
|
|
import Codec.Picture.Extra
|
|
|
|
import qualified Data.Vector as V
|
|
|
|
import Control.Monad (foldM)
|
|
|
|
-- internal imports
|
|
|
|
import Types
|
|
|
|
constructMap :: LevelDescriptor -> GL.GLuint -> IO LevelMap
|
|
constructMap desc tilemapSlot = do
|
|
tilemap <- uncurry TileMap <$> newTexture (levelTileMap desc) tilemapSlot
|
|
(layers, dimensions) <- foldM
|
|
(\(layers, dims) descTup -> do
|
|
(nlayer, ndims) <-
|
|
readLayer descTup (fmap fromIntegral $ tileMapDimensions tilemap)
|
|
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))
|
|
|
|
readLayer
|
|
:: (Word, FilePath) -- ^ index and path of the layer descriptor image
|
|
-> V2 Float -- ^ size of Tilemap in pixels
|
|
-> IO ((V.Vector Tile), V2 Int)
|
|
readLayer (_, path) (V2 tx ty) = do
|
|
img <- flipVertically <$> convertRGBA8 <$> either error id <$> readImage path
|
|
let width = imageWidth img
|
|
height = imageHeight img
|
|
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))
|
|
)
|
|
)
|
|
(case r of
|
|
255 -> Solid
|
|
254 -> Platform
|
|
_ -> Decoration
|
|
)
|
|
else
|
|
acc
|
|
)
|
|
V.empty
|
|
(V.fromList ((,) <$> [0 .. height - 1] <*> [0 .. width - 1]))
|
|
return (layer, V2 width height)
|