summaryrefslogtreecommitdiff
path: root/tiled/Data
diff options
context:
space:
mode:
Diffstat (limited to 'tiled/Data')
-rw-r--r--tiled/Data/Tiled.hs396
-rw-r--r--tiled/Data/Tiled/Abstract.hs66
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 #-}