summaryrefslogtreecommitdiff
path: root/lib/Tiled.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Tiled.hs')
-rw-r--r--lib/Tiled.hs388
1 files changed, 388 insertions, 0 deletions
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
new file mode 100644
index 0000000..9df52d3
--- /dev/null
+++ b/lib/Tiled.hs
@@ -0,0 +1,388 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# 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 Tiled 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.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 nicer prefix strip
+ , fieldLabelModifier = drop l . map toLower
+ , sumEncoding = UntaggedValue
+ }
+
+-- | 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 :: Double
+ , pointY :: Double
+ } deriving (Eq, Generic, Show)
+
+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 = ObjectPoint
+ { objectId :: Int
+ , objectName :: Maybe String
+ , objectProperties :: Maybe (Vector Property)
+ , objectVisible :: Maybe Bool
+ , objectX :: Double
+ , objectY :: Double
+ , objectHeight :: Double
+ , objectWidth :: Double
+ , objectRotation :: Double
+ , objectGid :: Maybe GlobalId
+ , objectText :: Maybe Text
+ , objectType :: Text
+ , objectPoint :: Bool
+ }
+ | ObjectRectangle
+ { objectId :: Int
+ , objectName :: Maybe String
+ , objectProperties :: Maybe (Vector Property)
+ , objectVisible :: Maybe Bool
+ , objectX :: Double
+ , objectY :: Double
+ , objectRotation :: Double
+ , objectGid :: Maybe GlobalId
+ , objectText :: Maybe Text
+ , objectWidth :: Double
+ , objectHeight :: Double
+ , objectEllipse :: 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
+ , objectText :: Maybe Text
+ , objectWidth :: Double
+ , objectHeight :: 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
+ , objectText :: Maybe Text
+ , objectWidth :: Double
+ , objectType :: Text
+ , objectHeight :: Double
+ , objectPolyline :: Vector Point
+ } 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 :: 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 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)
+
+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
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-04 20:03:10 +0000