diff options
Diffstat (limited to 'tiled/Data')
| -rw-r--r-- | tiled/Data/Tiled.hs | 396 | ||||
| -rw-r--r-- | tiled/Data/Tiled/Abstract.hs | 66 |
2 files changed, 462 insertions, 0 deletions
diff --git a/tiled/Data/Tiled.hs b/tiled/Data/Tiled.hs new file mode 100644 index 0000000..046a080 --- /dev/null +++ b/tiled/Data/Tiled.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# 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 Data.Tiled where + +import Universum + +-- TODO: what ever are these aeson imports +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) + + +-- | 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 nicer prefix strip + , fieldLabelModifier = drop l . map toLower + , sumEncoding = UntaggedValue + } + +-- | A globally indexed identifier. +newtype GlobalId = GlobalId { unGlobalId :: Int } + deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData) + +mkTiledId :: Int -> GlobalId +mkTiledId i = GlobalId { unGlobalId = i } + +-- | A locally indexed identifier. +newtype LocalId = LocalId { unLocalId :: Int } + deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData) + +type Color = Text + +-- | A custom tiled property, which just has a name and a value. +data Property = Property Text PropertyValue + deriving (Eq, Generic, Show, NFData) + +-- | 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 | FloatProp Float + deriving (Eq, Generic, Show, NFData) + +instance IsString PropertyValue where + fromString s = StrProp (toText 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) + A.String "float" -> do + val <- o .: "value" + pure $ Property name (FloatProp 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 + ] + FloatProp float -> object + [ "type" .= A.String "float" + , "name" .= name + , "value" .= float + ] + +data Point = Point { pointX :: Double + , pointY :: Double + } deriving (Eq, Generic, Show, NFData) + +instance FromJSON Point where + parseJSON = genericParseJSON (aesonOptions 5) +instance ToJSON Point where + toJSON = genericToJSON (aesonOptions 5) + + +-- | all kinds of objects that can occur in object layers, even +-- | those that we don't want to allow. +data Object = ObjectRectangle + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectWidth :: Maybe Double + , objectHeight :: Maybe Double + , objectEllipse :: Maybe Bool + , objectPoint :: Maybe Bool + , objectType :: Text + } + | ObjectPolygon + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectWidth :: Maybe Double + , objectHeight :: Maybe Double + , objectType :: Text + , objectPolygon :: Vector Point + } + | ObjectPolyline + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectWidth :: Maybe Double + , objectHeight :: Maybe Double + , objectType :: Text + , objectPolyline :: Vector Point + } + | ObjectText + { objectId :: Int + , objectName :: Maybe String + , objectProperties :: Maybe (Vector Property) + , objectVisible :: Maybe Bool + , objectX :: Double + , objectY :: Double + , objectRotation :: Double + , objectGid :: Maybe GlobalId + , objectText :: A.Value + , objectWidth :: Maybe Double + , objectHeight :: Maybe Double + , objectEllipse :: Maybe Bool + , objectType :: Text + } deriving (Eq, Generic, Show, NFData) + + + + + +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 :: Text + -- ^ “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 Float + , layerOffsety :: Maybe Float + , layerParallaxx :: Maybe Float + , layerParallaxy :: Maybe Float + , layerTintColor :: Maybe Color + , layerTransparentColor :: Maybe Color + , layerImage :: Maybe Text + , layerLayers :: Maybe [Layer] + , layerStartX :: Maybe Int + , layerStartY :: Maybe Int + , layerColor :: Maybe Color + } deriving (Eq, Generic, Show, NFData) + +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, NFData) + +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, NFData) + +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 Property) + , 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, NFData) + +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 :: Maybe 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 + , tilesetFileName :: Maybe Text + } deriving (Eq, Generic, Show, NFData) + +newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value) + deriving newtype (Show, Eq, 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, NFData) + +instance FromJSON Tiledmap where + parseJSON = genericParseJSON (aesonOptions 8) +instance ToJSON Tiledmap where + toJSON = genericToJSON (aesonOptions 8) + +data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String + deriving Show + +-- | 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 diff --git a/tiled/Data/Tiled/Abstract.hs b/tiled/Data/Tiled/Abstract.hs new file mode 100644 index 0000000..4b2e15d --- /dev/null +++ b/tiled/Data/Tiled/Abstract.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Tiled.Abstract where + +import Universum + +import qualified Data.Vector as V +import Data.Tiled (Layer (..), Object (..), Property (..), + PropertyValue (..), Tile (..), Tiledmap (..), + Tileset (..)) + +class HasProperties a where + getProperties :: a -> [Property] + adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a + +instance HasProperties Layer where + getProperties = maybeToMonoid . layerProperties + adjustProperties f layer = layer + { layerProperties = f (getProperties layer) } + +instance HasProperties Tileset where + getProperties = maybeToMonoid . tilesetProperties + adjustProperties f tileset = tileset + { tilesetProperties = f (getProperties tileset) } + +instance HasProperties Tile where + getProperties = V.toList . maybeToMonoid . tileProperties + adjustProperties f tile = tile + { tileProperties = (fmap V.fromList . f) (getProperties tile) } + +instance HasProperties Object where + getProperties = V.toList . maybeToMonoid . objectProperties + adjustProperties f obj = obj + { objectProperties = (fmap V.fromList . f) (getProperties obj) } + +instance HasProperties Tiledmap where + getProperties = maybeToMonoid . tiledmapProperties + adjustProperties f tiledmap = tiledmap + { tiledmapProperties = f (getProperties tiledmap) } + +class HasTypeName a where + typeName :: Proxy a -> Text +instance HasTypeName Layer where + typeName _ = "layer" +instance HasTypeName Tileset where + typeName _ = "tileset" +instance HasTypeName Property where + typeName _ = "property" + +class HasName a where + getName :: a -> Text +instance HasName Layer where + getName = layerName +instance HasName Tileset where + getName = tilesetName +instance HasName Property where + getName (Property n _) = n + +class IsProperty a where + asProperty :: a -> PropertyValue +instance IsProperty PropertyValue where + asProperty = id + {-# INLINE asProperty #-} +instance IsProperty Text where + asProperty = StrProp + {-# INLINE asProperty #-} |