diff options
Diffstat (limited to 'lib/Tiled.hs')
| -rw-r--r-- | lib/Tiled.hs | 395 |
1 files changed, 0 insertions, 395 deletions
diff --git a/lib/Tiled.hs b/lib/Tiled.hs deleted file mode 100644 index 3162dfd..0000000 --- a/lib/Tiled.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# 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 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 - --- | 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 |