module Data.Aeson.Tiled
(
module Data.Aeson.Tiled
, module Data.Map
, module Data.Vector
) where
import Control.Applicative ((<|>))
import Control.Monad (forM)
import Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import Data.Aeson.Types (Parser, typeMismatch)
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import Data.Vector (Vector)
import GHC.Generics (Generic)
newtype GlobalId = GlobalId { unGlobalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
newtype LocalId = LocalId { unLocalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
data Object = Object { objectId :: Int
, objectWidth :: Int
, objectHeight :: Int
, objectName :: String
, objectType :: String
, objectProperties :: Map Text Text
, objectVisible :: Bool
, objectX :: Int
, objectY :: Int
, objectRotation :: Float
, objectGid :: GlobalId
, objectEllipse :: Bool
, objectPolygon :: Vector (Int, Int)
, objectPolyline :: Vector (Int, Int)
, objectText :: Map Text Text
} deriving (Eq, Generic, Show)
instance FromJSON Object where
parseJSON (A.Object o) = Object <$> o .: "id"
<*> o .: "width"
<*> o .: "height"
<*> o .: "name"
<*> o .: "type"
<*> o .: "properties"
<*> o .: "visible"
<*> o .: "x"
<*> o .: "y"
<*> o .: "rotation"
<*> o .: "gid"
<*> o .: "ellipse"
<*> o .: "polygon"
<*> o .: "polyline"
<*> o .: "text"
parseJSON invalid = typeMismatch "Object" invalid
instance ToJSON Object where
toJSON Object{..} = object [ "id" .= objectId
, "width" .= objectWidth
, "height" .= objectHeight
, "name" .= objectName
, "type" .= objectType
, "properties" .= objectProperties
, "visible" .= objectVisible
, "x" .= objectX
, "y" .= objectY
, "rotation" .= objectRotation
, "gid" .= objectGid
, "ellipse" .= objectEllipse
, "polygon" .= objectPolygon
, "polyline" .= objectPolyline
, "text" .= objectText
]
data Layer = Layer { layerWidth :: Int
, layerHeight :: Int
, layerName :: String
, layerType :: String
, layerVisible :: Bool
, layerX :: Int
, layerY :: Int
, layerData :: Maybe (Vector GlobalId)
, layerObjects :: Maybe (Vector Object)
, layerProperties :: Map Text Text
, layerOpacity :: Float
, layerDraworder :: String
} deriving (Eq, Generic, Show)
instance FromJSON Layer where
parseJSON (A.Object o) = Layer <$> (o .: "width" <|> pure 0)
<*> (o .: "height" <|> pure 0)
<*> o .: "name"
<*> o .: "type"
<*> o .: "visible"
<*> o .: "x"
<*> o .: "y"
<*> (o .: "data" <|> pure Nothing)
<*> (o .: "objects" <|> pure Nothing)
<*> (o .: "properties" <|> pure mempty)
<*> o .: "opacity"
<*> (o .: "draworder" <|> pure "topdown")
parseJSON invalid = typeMismatch "Layer" invalid
instance ToJSON Layer where
toJSON Layer{..} = object [ "width" .= layerWidth
, "height" .= layerHeight
, "name" .= layerName
, "type" .= layerType
, "visible" .= layerVisible
, "x" .= layerX
, "y" .= layerY
, "data" .= layerData
, "objects" .= layerObjects
, "properties" .= layerProperties
, "opacity" .= layerOpacity
, "draworder" .= layerDraworder
]
data Terrain = Terrain { terrainName :: String
, terrainTile :: LocalId
} 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 :: LocalId
, tileProperties :: Map Text Text
, tileImage :: Maybe Value
, tileObjectGroup :: Maybe (Vector Object)
, tileAnimation :: Maybe (Vector Frame)
} deriving (Eq, Generic, Show)
instance FromJSON Tile where
parseJSON (A.Object o) = Tile 0 <$> (o .: "properties" <|> pure mempty)
<*> (o .: "image" <|> pure Nothing)
<*> (o .: "objectGroup" <|> pure mempty)
<*> (o .: "animation" <|> pure mempty)
parseJSON invalid = typeMismatch "Tile" invalid
instance ToJSON Tile where
toJSON Tile{..} = object [ "properties" .= tileProperties
, "image" .= tileImage
, "objectGroup" .= tileObjectGroup
, "animation" .= tileAnimation
]
data Tileset = Tileset { tilesetFirstgid :: GlobalId
, tilesetImage :: String
, tilesetName :: String
, tilesetTilewidth :: Int
, tilesetTileheight :: Int
, tilesetImagewidth :: Int
, tilesetImageheight :: Int
, tilesetProperties :: Map Text Text
, tilesetPropertytypes :: Map Text Text
, tilesetMargin :: Int
, tilesetSpacing :: Int
, tilesetTileproperties :: Map GlobalId (Map Text Text)
, tilesetTerrains :: Vector Terrain
, tilesetColumns :: Int
, tilesetTilecount :: Int
, tilesetTiles :: Map LocalId Tile
} deriving (Eq, Generic, Show)
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
deriving (Show, Eq, Generic, FromJSON)
parseTiles :: A.Object -> Parser (Map LocalId Tile)
parseTiles o = do
TransitiveTilesetMap localId2Value <- o .: "tiles"
localIdAndTiles <- forM (M.toList localId2Value) $ \(lid, val) -> do
tile <- parseJSON val
return (lid, tile{ tileId = lid })
return $ M.fromList localIdAndTiles
instance FromJSON Tileset where
parseJSON (A.Object o) = Tileset <$> o .: "firstgid"
<*> o .: "image"
<*> o .: "name"
<*> o .: "tilewidth"
<*> o .: "tileheight"
<*> o .: "imagewidth"
<*> o .: "imageheight"
<*> (o .: "properties" <|> pure mempty)
<*> (o .: "propertytypes" <|> pure mempty)
<*> o .: "margin"
<*> o .: "spacing"
<*> (o .: "tileproperties" <|> pure mempty)
<*> (o .: "terrains" <|> pure mempty)
<*> o .: "columns"
<*> o .: "tilecount"
<*> (parseTiles o <|> pure mempty)
parseJSON invalid = typeMismatch "Tileset" invalid
instance ToJSON Tileset where
toJSON Tileset{..} = object [ "firstgid" .= tilesetFirstgid
, "image" .= tilesetImage
, "name" .= tilesetName
, "tilewidth" .= tilesetTilewidth
, "tileheight" .= tilesetTileheight
, "imagewidth" .= tilesetImagewidth
, "imageheight" .= tilesetImageheight
, "properties" .= tilesetProperties
, "propertytypes" .= tilesetPropertytypes
, "margin" .= tilesetMargin
, "spacing" .= tilesetSpacing
, "tileproperties" .= tilesetTileproperties
, "terrains" .= tilesetTerrains
, "columns" .= tilesetColumns
, "tilecount" .= tilesetTilecount
, "tiles" .= tilesetTiles
]
data Tiledmap = Tiledmap { tiledmapVersion :: Float
, tiledmapTiledversion :: String
, tiledmapWidth :: Int
, tiledmapHeight :: Int
, tiledmapTilewidth :: Int
, tiledmapTileheight :: Int
, tiledmapOrientation :: String
, tiledmapLayers :: Vector Layer
, tiledmapTilesets :: Vector Tileset
, tiledmapBackgroundcolor :: Maybe String
, tiledmapRenderorder :: String
, tiledmapProperties :: Map Text Text
, tiledmapNextobjectid :: Int
} deriving (Eq, Generic, Show)
instance FromJSON Tiledmap where
parseJSON (A.Object o) = Tiledmap <$> o .: "version"
<*> o .: "tiledversion"
<*> o .: "width"
<*> o .: "height"
<*> o .: "tilewidth"
<*> o .: "tileheight"
<*> o .: "orientation"
<*> o .: "layers"
<*> o .: "tilesets"
<*> (o .: "backgroundcolor" <|> pure Nothing)
<*> o .: "renderorder"
<*> (o .: "properties" <|> pure mempty)
<*> o .: "nextobjectid"
parseJSON invalid = typeMismatch "Tiledmap" invalid
instance ToJSON Tiledmap where
toJSON Tiledmap{..} = object [ "version" .= tiledmapVersion
, "tiledversion" .= tiledmapTiledversion
, "width" .= tiledmapWidth
, "height" .= tiledmapHeight
, "tilewidth" .= tiledmapTilewidth
, "tileheight" .= tiledmapTileheight
, "orientation" .= tiledmapOrientation
, "layers" .= tiledmapLayers
, "tilesets" .= tiledmapTilesets
, "backgroundcolor" .= tiledmapBackgroundcolor
, "renderorder" .= tiledmapRenderorder
, "properties" .= tiledmapProperties
, "nextobjectid" .= tiledmapNextobjectid
]
loadTiledmap :: FilePath -> IO (Either String Tiledmap)
loadTiledmap = fmap eitherDecode . C8.readFile