summaryrefslogtreecommitdiff
path: root/lib/Tiled.hs
blob: 3162dfd32ea6a944b71464570e55a21dc5ecb08b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
{-# 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