Select Git revision
LayerData.hs
Tiled2.hs 16.75 KiB
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides Haskell types for Tiled's JSON exports, which you can
-- read about at http://doc.mapeditor.org/en/latest/reference/json-map-format/.
-- That said - as of the writing of this module the JSON documentation does not
-- cover some of the types and records that are available in the format. For
-- those you should read the TMX documentation at
-- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/
module Tiled2 where
import Control.Exception (try)
import Control.Exception.Base (SomeException)
import Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import Data.Aeson.Types (typeMismatch)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import Data.Char (toLower)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.String (IsString (fromString))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import GHC.Generics (Generic)
-- | options for Aeson's generic encoding and parsing functions
aesonOptions :: Int -> Options
aesonOptions l = defaultOptions
{ omitNothingFields = True
, rejectUnknownFields = True
-- can't be bothered to do a nixer prefix strip
, fieldLabelModifier = drop l . map toLower
}
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
mkTiledId :: Int -> GlobalId
mkTiledId i = GlobalId { unGlobalId = i }
-- | A locally indexed identifier.
newtype LocalId = LocalId { unLocalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
-- | TODO: type-check colours?
type Color = Text
-- | A custom tiled property, which just has a name and a value.
data Property = Property Text PropertyValue
deriving (Eq, Generic, Show)
-- | The value of a custom tiled property.
-- It is strongly typed via a tag in the json representation,
-- and needs a custom ToJSON and FromJSON instance because of that.
data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int
deriving (Eq, Generic, Show)
instance IsString PropertyValue where
fromString s = StrProp (T.pack s)
instance FromJSON Property where parseJSON (A.Object o) = do
name <- o .: "name"
o .: "type" >>= \case
A.String "string" -> do
val <- o .: "value"
pure $ Property name (StrProp val)
A.String "bool" -> do
val <- o .: "value"
pure $ Property name (BoolProp val)
A.String "int" -> do
val <- o .: "value"
pure $ Property name (IntProp val)
ty -> fail $ "properties can only have types string, int, bool, but encountered type" <> show ty
parseJSON invalid = typeMismatch "Property" invalid
instance ToJSON Property where
toJSON (Property name val) = case val of
StrProp str -> object [ "type" .= A.String "string"
, "name" .= name
, "value" .= str
]
BoolProp bool -> object [ "type" .= A.String "bool"
, "name" .= name
, "value" .= bool
]
IntProp int -> object [ "type" .= A.String "int"
, "name" .= name
, "value" .= int]
data Point = Point { pointX :: Int
, pointY :: Int
} deriving (Eq, Generic, Show)
instance FromJSON Point where
parseJSON = genericParseJSON (aesonOptions 5)
instance ToJSON Point where
toJSON = genericToJSON (aesonOptions 5)
data Object = Object { objectId :: Int
-- ^ Incremental id - unique across all objects
, objectWidth :: Double
-- ^ Width in pixels. Ignored if using a gid.
, objectHeight :: Double
-- ^ Height in pixels. Ignored if using a gid.
, objectName :: Maybe String
-- ^ String assigned to name field in editor
, objectType :: String
-- ^ String assigned to type field in editor
, objectProperties :: Maybe Value
-- ^ String key-value pairs
, objectVisible :: Maybe Bool
-- ^ Whether object is shown in editor.
, objectX :: Double
-- ^ x coordinate in pixels
, objectY :: Double
-- ^ y coordinate in pixels
, objectRotation :: Float
-- ^ Angle in degrees clockwise
, objectGid :: Maybe GlobalId
-- ^ GID, only if object comes from a Tilemap
, objectEllipse :: Maybe Bool
-- ^ Used to mark an object as an ellipse
, objectPolygon :: Maybe (Vector Point)
-- ^ A list of x,y coordinates in pixels
, objectPolyline :: Maybe (Vector Point)
-- ^ A list of x,y coordinates in pixels
, objectText :: Maybe Value
-- ^ String key-value pairs
} deriving (Eq, Generic, Show)
instance FromJSON Object where
parseJSON = genericParseJSON (aesonOptions 6)
instance ToJSON Object where
toJSON = genericToJSON (aesonOptions 6)
data Layer = Layer { layerWidth :: Maybe Double
-- ^ Column count. Same as map width for fixed-size maps.
, layerHeight :: Maybe Double
-- ^ Row count. Same as map height for fixed-size maps.
, layerName :: Text
-- ^ Name assigned to this layer
, layerType :: String
-- ^ “tilelayer”, “objectgroup”, or “imagelayer”
, layerVisible :: Bool
-- ^ Whether layer is shown or hidden in editor
, layerX :: Double
-- ^ Horizontal layer offset in tiles. Always 0.
, layerY :: Double
-- ^ Vertical layer offset in tiles. Always 0.
, layerData :: Maybe (Vector GlobalId)
-- ^ Array of GIDs. tilelayer only.
, layerObjects :: Maybe (Vector Object)
-- ^ Array of Objects. objectgroup only.
, layerProperties :: Maybe [Property]
-- ^ string key-value pairs.
, layerOpacity :: Float
-- ^ Value between 0 and 1
, layerDraworder :: Maybe String
-- ^ “topdown” (default) or “index”. objectgroup only.
, layerId :: Int
, layerOffsetx :: Maybe Int
, layerOffsety :: Maybe Int
, layerParallaxx :: Maybe Float
, layerParallaxy :: Maybe Float
, layerTintColor :: Maybe Color
, layerTransparentColor :: Maybe Color
, layerImage :: Maybe Text
, layerLayers :: Maybe [Layer]
, layerStartX :: Maybe Int
, layerStartY :: Maybe Int
} deriving (Eq, Generic, Show)
instance FromJSON Layer where
parseJSON = genericParseJSON (aesonOptions 5)
instance ToJSON Layer where
toJSON = genericToJSON (aesonOptions 5)
data Terrain = Terrain { terrainName :: String
-- ^ Name of terrain
, terrainTile :: LocalId
-- ^ Local ID of tile representing terrain
} deriving (Eq, Generic, Show)
instance FromJSON Terrain where
parseJSON (A.Object o) = Terrain <$> o .: "name"
<*> o .: "tile"
parseJSON invalid = typeMismatch "Terrain" invalid
instance ToJSON Terrain where
toJSON Terrain{..} = object [ "name" .= terrainName
, "tile" .= terrainTile
]
data Frame = Frame { frameDuration :: Int
, frameTileId :: LocalId
} deriving (Eq, Generic, Show)
instance FromJSON Frame where
parseJSON (A.Object o) = Frame <$> o .: "duration"
<*> o .: "tileid"
parseJSON invalid = typeMismatch "Frame" invalid
instance ToJSON Frame where
toJSON Frame{..} = object [ "duration" .= frameDuration
, "tileid" .= frameTileId
]
data Tile = Tile { tileId :: Int
, tileProperties :: Maybe (Vector Value)
, tileImage :: Maybe Value
, tileObjectGroup :: Maybe Value
, tileAnimation :: Maybe (Vector Frame)
, tileImageheight :: Maybe Int
, tileImagewidth :: Maybe Int
, tileProbability :: Maybe Float
, tileType :: Maybe Text
, tileTerrain :: Maybe [Int]
} deriving (Eq, Generic, Show)
instance FromJSON Tile where
parseJSON = genericParseJSON (aesonOptions 4)
instance ToJSON Tile where
toJSON = genericToJSON (aesonOptions 4)
data Tileset = Tileset { tilesetFirstgid :: GlobalId
-- ^ GID corresponding to the first tile in the set
, tilesetImage :: Text
-- ^ Image used for tiles in this set
, tilesetName :: Text
-- ^ Name given to this tileset
, tilesetTilewidth :: Int
-- ^ Maximum width of tiles in this set
, tilesetTileheight :: Int
-- ^ Maximum height of tiles in this set
, tilesetImagewidth :: Int
-- ^ Width of source image in pixels
, tilesetImageheight :: Int
-- ^ Height of source image in pixels
, tilesetProperties :: Maybe [Property]
-- ^ String key-value pairs
, tilesetPropertytypes :: Maybe (Map Text Text)
-- ^ String key-value pairs
, tilesetMargin :: Int
-- ^ Buffer between image edge and first tile (pixels)
, tilesetSpacing :: Int
-- ^ Spacing between adjacent tiles in image (pixels)
, tilesetTileproperties :: Maybe (Map GlobalId (Map Text Text))
-- ^ Per-tile properties, indexed by gid as string
, tilesetTerrains :: Maybe (Vector Terrain)
-- ^ Array of Terrains (optional)
, tilesetColumns :: Int
-- ^ The number of tile columns in the tileset
, tilesetTilecount :: Int
-- ^ The number of tiles in this tileset
, tilesetTiles :: Maybe (Vector Tile)
-- ^ Tiles (optional)
, tilesetTransparentcolor :: Maybe Text
, tilesetEditorsettings :: Maybe Value
, tilesetBackgroundColor :: Maybe Text
, tilesetGrid :: Maybe Value
, tilesetSource :: Maybe Text
, tilesetTiledversion :: Maybe Text , tilesetTileoffset :: Maybe Value
, tilesetTransformations :: Maybe Value
, tilesetVersion :: Maybe Value
, tilesetWangsets :: Maybe Value
, tilesetType :: Maybe Text
} deriving (Eq, Generic, Show)
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
deriving (Show, Eq, Generic, FromJSON)
instance FromJSON Tileset where
parseJSON = genericParseJSON (aesonOptions 7)
instance ToJSON Tileset where
toJSON = genericToJSON (aesonOptions 7)
-- | The full monty.
data Tiledmap = Tiledmap { tiledmapVersion :: Value
-- ^ The JSON format version
, tiledmapTiledversion :: Maybe String
-- ^ The Tiled version used to save the file
, tiledmapWidth :: Int
-- ^ Number of tile columns
, tiledmapHeight :: Int
-- ^ Number of tile rows
, tiledmapTilewidth :: Double
-- ^ Map grid width.
, tiledmapTileheight :: Double
-- ^ Map grid height.
, tiledmapOrientation :: String
-- ^ Orthogonal, isometric, or staggered
, tiledmapLayers :: Vector Layer
-- ^ Array of Layers
, tiledmapTilesets :: Vector Tileset
-- ^ Array of Tilesets
, tiledmapBackgroundcolor :: Maybe String
-- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional)
, tiledmapRenderorder :: String
-- ^ Rendering direction (orthogonal maps only)
, tiledmapProperties :: Maybe [Property]
-- ^ String key-value pairs
, tiledmapNextobjectid :: Int
-- ^ Auto-increments for each placed object
, tiledmapCompressionLevel :: Maybe Int
, tiledmapInfinite :: Bool
, tiledmapNextlayerid :: Maybe Int
, tiledmapHexsidelength :: Maybe Int
, tiledmapStaggeraxis :: Maybe Text
, tiledmapStaggerindex :: Maybe String
, tiledmapType :: String
, tiledmapEditorsettings :: Maybe Value
} deriving (Eq, Generic, Show)
instance FromJSON Tiledmap where
parseJSON = genericParseJSON (aesonOptions 8)
instance ToJSON Tiledmap where
toJSON = genericToJSON (aesonOptions 8)
class HasProperties a where
getProperties :: a -> [Property]
adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a
instance HasProperties Layer where
getProperties = fromMaybe [] . layerProperties
adjustProperties f layer = layer
{ layerProperties = f (getProperties layer) }
instance HasProperties Tileset where getProperties = fromMaybe [] . tilesetProperties
adjustProperties f tileset = tileset
{ tilesetProperties = f (getProperties tileset) }
instance HasProperties Tiledmap where
getProperties = fromMaybe [] . tiledmapProperties
adjustProperties f tiledmap = tiledmap
{ tiledmapProperties = f (getProperties tiledmap) }
class HasName a where
getName :: a -> Text
instance HasName Layer where
getName = layerName
instance HasName Tileset where
getName = tilesetName
class IsProperty a where
asProperty :: a -> PropertyValue
instance IsProperty PropertyValue where
asProperty = id
{-# INLINE asProperty #-}
instance IsProperty Text where
asProperty = StrProp
{-# INLINE asProperty #-}
data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String
-- | Load a Tiled map from the given 'FilePath'.
loadTiledmap :: FilePath -> IO LoadResult
loadTiledmap path = do
res <- try (BS.readFile path)
pure $ case res of
Right file -> case eitherDecode . LB.fromStrict $ file of
Left err -> DecodeErr err
Right tiledmap -> Loaded tiledmap
Left (err :: SomeException) -> IOErr $ show err