path: root/lib/Tiled2.hs

{-# 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 Tiled2 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.Maybe             (fromMaybe)
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 nixer prefix strip
  , fieldLabelModifier = drop l . map toLower
  }

-- | 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
  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)
      ty -> fail $ "properties can only have type string or bool, but encountered " <> 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
                            ]

data Object = Object { objectId         :: Int
                       -- ^ Incremental id - unique across all objects
                     , objectWidth      :: Double
                       -- ^ Width in pixels. Ignored if using a gid.
                     , objectHeight     :: Double
                       -- ^ Height in pixels. Ignored if using a gid.
                     , objectName       :: String
                       -- ^ String assigned to name field in editor
                     , objectType       :: String
                       -- ^ String assigned to type field in editor
                     , objectProperties :: Map Text Text
                       -- ^ String key-value pairs
                     , objectVisible    :: Bool
                       -- ^ Whether object is shown in editor.
                     , objectX          :: Double
                       -- ^ x coordinate in pixels
                     , objectY          :: Double
                       -- ^ y coordinate in pixels
                     , objectRotation   :: Float
                       -- ^ Angle in degrees clockwise
                     , objectGid        :: Maybe GlobalId
                       -- ^ GID, only if object comes from a Tilemap
                     , objectEllipse    :: Bool
                       -- ^ Used to mark an object as an ellipse
                     , objectPolygon    :: Maybe (Vector (Double, Double))
                       -- ^ A list of x,y coordinates in pixels
                     , objectPolyline   :: Maybe (Vector (Double, Double))
                       -- ^ A list of x,y coordinates in pixels
                     , objectText       :: Map Text Text
                       -- ^ String key-value pairs
                     } 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             :: String
                     -- ^ “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
                   } 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
                 } 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          :: Float
                           -- ^ The JSON format version
                         , tiledmapTiledversion     :: 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)


class HasProperties a where
  getProperties :: a -> [Property]
  adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a

instance HasProperties Layer where
  getProperties = fromMaybe [] . layerProperties
  adjustProperties f layer = layer
    { layerProperties = f (getProperties layer) }

instance HasProperties Tileset where
  getProperties = fromMaybe [] . tilesetProperties
  adjustProperties f tileset = tileset
    { tilesetProperties = f (getProperties tileset) }

instance HasProperties Tiledmap where
  getProperties = fromMaybe [] . tiledmapProperties
  adjustProperties f tiledmap = tiledmap
    { tiledmapProperties = f (getProperties tiledmap) }

class HasName a where
  getName :: a -> Text
instance HasName Layer where
  getName = layerName
instance HasName Tileset where
  getName = tilesetName

class IsProperty a where
  asProperty :: a -> PropertyValue
instance IsProperty PropertyValue where
  asProperty = id
  {-# INLINE asProperty #-}
instance IsProperty Text where
  asProperty = StrProp
  {-# INLINE asProperty #-}

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