path: root/lib/Tiled.hs

{-# 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)

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 | FloatProp Float
  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)
      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)

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)





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)

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 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)

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)

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