summaryrefslogtreecommitdiff
path: root/lib/Tiled2.hs
blob: 7e462cc201f49bad0042719f76661e5253546668 (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
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
-- | 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/
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module Tiled2 where

import           Control.Applicative     ((<|>))
import           Control.Exception       (try)
import           Control.Exception.Base  (SomeException)
import           Control.Monad           (forM)
import           Data.Aeson              hiding (Object)
import qualified Data.Aeson              as A
import           Data.Aeson.Types        (Parser, typeMismatch)
import qualified Data.ByteString         as BS
import qualified Data.ByteString.Lazy    as LB
import           Data.Either.Combinators (mapLeft)
import           Data.Functor            ((<&>))
import           Data.Map                (Map)
import qualified Data.Map                as M
import           Data.Maybe              (fromMaybe)
import           Data.Text               (Text)
import           Data.Vector             (Vector)
import           GHC.Exts                (fromList, toList)
import           GHC.Generics            (Generic)


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


data XYPair a = XYPair a a

instance FromJSON a => FromJSON (XYPair a) where
  parseJSON (A.Object o) =
    XYPair <$> o .: "x"
           <*> o .: "y"
  parseJSON invalid = typeMismatch "Object" invalid

instance ToJSON a => ToJSON (XYPair a) where
  toJSON (XYPair x y) =
    object [ "x" .= x
           , "y" .= y
           ]

fromXYPair :: XYPair a -> (a, a)
fromXYPair (XYPair x y) = (x, y)

toXYPair :: (a, a) -> XYPair a
toXYPair (x, y) = XYPair x y

omitNulls :: Value -> Value
omitNulls (A.Object hs) = A.Object
                        . fromList
                        . filter ((/= Null) . snd)
                        $ toList hs
omitNulls x = x

parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a
parseDefault o s d = fromMaybe d <$> o .:? s


{-- | workadventure custom property
data Property = Property { propertyName  :: Text
                         --, propertyType :: Text (unnecessary since always string)
                         , propertyValue :: Text
                         } deriving (Eq, Generic, Show)
-}

data PropertyValue = StrProp Text | BoolProp Bool
  deriving (Eq, Generic, Show)
data Property = Property Text PropertyValue
  deriving (Eq, Generic, Show)


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 (A.Object o) = Object <$> o .: "id"
                                  <*> o .: "width"
                                  <*> o .: "height"
                                  <*> o .: "name"
                                  <*> o .: "type"
                                  <*> parseDefault o "properties" M.empty
                                  <*> o .: "visible"
                                  <*> o .: "x"
                                  <*> o .: "y"
                                  <*> o .: "rotation"
                                  <*> o .:? "gid"
                                  <*> parseDefault o "ellipse" False
                                  <*> (fmap . fmap . fmap) fromXYPair (o .:? "polygon")
                                  <*> (fmap . fmap . fmap) fromXYPair (o .:? "polyline")
                                  <*> parseDefault o "text" M.empty
  parseJSON invalid = typeMismatch "Object" invalid

instance ToJSON Object where
  toJSON Object{..} = omitNulls $
    object [ "id"         .= objectId
           , "width"      .= objectWidth
           , "height"     .= objectHeight
           , "name"       .= objectName
           , "type"       .= objectType
           , "properties" .= objectProperties
           , "visible"    .= objectVisible
           , "x"          .= objectX
           , "y"          .= objectY
           , "rotation"   .= objectRotation
           , "gid"        .= objectGid
           , "ellipse"    .= objectEllipse
           , "polygon"    .= (fmap . fmap) toXYPair objectPolygon
           , "polyline"   .= (fmap . fmap) toXYPair objectPolyline
           , "text"       .= objectText
           ]


data Layer = Layer { layerWidth      :: Double
                     -- ^ Column count. Same as map width for fixed-size maps.
                   , layerHeight     :: 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 :: [Property]
                     -- ^ string key-value pairs.
                   , layerOpacity    :: Float
                     -- ^ Value between 0 and 1
                   , layerDraworder  :: String
                     -- ^ “topdown” (default) or “index”. objectgroup only.
                   } deriving (Eq, Generic, Show)

instance FromJSON Layer where
  parseJSON (A.Object o) = Layer <$> (o .: "width"      <|> pure 0)
                                 <*> (o .: "height"     <|> pure 0)
                                 <*>  o .: "name"
                                 <*>  o .: "type"
                                 <*>  o .: "visible"
                                 <*>  o .: "x"
                                 <*>  o .: "y"
                                 <*> (o .: "data"       <|> pure Nothing)
                                 <*> o .:? "objects"
                                 <*> (o .:? "properties" <&> fromMaybe [])
                                 <*>  o .: "opacity"
                                 <*> (o .: "draworder"  <|> pure "topdown")
  parseJSON invalid = typeMismatch "Layer" invalid

instance ToJSON Layer where
  toJSON Layer{..} = omitNulls $
    object [ "width"      .= layerWidth
           , "height"     .= layerHeight
           , "name"       .= layerName
           , "type"       .= layerType
           , "visible"    .= layerVisible
           , "x"          .= layerX
           , "y"          .= layerY
           , "data"       .= layerData
           , "objects"    .= layerObjects
           , "properties" .= layerProperties
           , "opacity"    .= layerOpacity
           , "draworder"  .= layerDraworder
           ]


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          :: LocalId
                 , tileProperties  :: Map Text Text
                 , tileImage       :: Maybe Value
                 , tileObjectGroup :: Maybe (Vector Object)
                 , tileAnimation   :: Maybe (Vector Frame)
                 } deriving (Eq, Generic, Show)

instance FromJSON Tile where
  parseJSON (A.Object o) = Tile 0 <$> (o .: "properties"  <|> pure mempty)
                                  <*> (o .: "image"       <|> pure Nothing)
                                  <*> (o .: "objectGroup" <|> pure mempty)
                                  <*> (o .: "animation"   <|> pure mempty)
  parseJSON invalid = typeMismatch "Tile" invalid

instance ToJSON Tile where
  toJSON Tile{..} = object [ "properties"   .= tileProperties
                           , "image"        .= tileImage
                           , "objectGroup"  .= tileObjectGroup
                           , "animation"    .= tileAnimation
                           ]


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     :: Map Text Text
                         -- ^ String key-value pairs
                       , tilesetPropertytypes  :: 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 :: Map GlobalId (Map Text Text)
                         -- ^ Per-tile properties, indexed by gid as string
                       , tilesetTerrains       :: 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          :: Map LocalId Tile
                         -- ^ Tiles (optional)
                       } deriving (Eq, Generic, Show)

newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
  deriving (Show, Eq, Generic, FromJSON)

parseTiles :: A.Object -> Parser (Map LocalId Tile)
parseTiles o = do
  TransitiveTilesetMap localId2Value <- o .: "tiles"
  localIdAndTiles <- forM (M.toList localId2Value) $ \(lid, val) -> do
    tile <- parseJSON val
    return (lid, tile{ tileId = lid })
  return $ M.fromList localIdAndTiles

instance FromJSON Tileset where
  parseJSON (A.Object o) = Tileset <$>  o .: "firstgid"
                                   <*>  o .: "image"
                                   <*>  o .: "name"
                                   <*>  o .: "tilewidth"
                                   <*>  o .: "tileheight"
                                   <*>  o .: "imagewidth"
                                   <*>  o .: "imageheight"
                                   <*> (o .: "properties"     <|> pure mempty)
                                   <*> (o .: "propertytypes"  <|> pure mempty)
                                   <*>  o .: "margin"
                                   <*>  o .: "spacing"
                                   <*> (o .: "tileproperties" <|> pure mempty)
                                   <*> (o .: "terrains"       <|> pure mempty)
                                   <*>  o .: "columns"
                                   <*>  o .: "tilecount"
                                   <*> (parseTiles o          <|> pure mempty)
  parseJSON invalid = typeMismatch "Tileset" invalid

instance ToJSON Tileset where
  toJSON Tileset{..} = object [ "firstgid"       .= tilesetFirstgid
                              , "image"          .= tilesetImage
                              , "name"           .= tilesetName
                              , "tilewidth"      .= tilesetTilewidth
                              , "tileheight"     .= tilesetTileheight
                              , "imagewidth"     .= tilesetImagewidth
                              , "imageheight"    .= tilesetImageheight
                              , "properties"     .= tilesetProperties
                              , "propertytypes"  .= tilesetPropertytypes
                              , "margin"         .= tilesetMargin
                              , "spacing"        .= tilesetSpacing
                              , "tileproperties" .= tilesetTileproperties
                              , "terrains"       .= tilesetTerrains
                              , "columns"        .= tilesetColumns
                              , "tilecount"      .= tilesetTilecount
                              , "tiles"          .= tilesetTiles
                              ]


-- | 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      :: [Property]
                           -- ^ String key-value pairs
                         , tiledmapNextobjectid    :: Int
                           -- ^ Auto-increments for each placed object
                         } deriving (Eq, Generic, Show)

instance FromJSON Tiledmap where
  parseJSON (A.Object o) = Tiledmap <$>  o .: "version"
                                    <*>  o .: "tiledversion"
                                    <*>  o .: "width"
                                    <*>  o .: "height"
                                    <*>  o .: "tilewidth"
                                    <*>  o .: "tileheight"
                                    <*>  o .: "orientation"
                                    <*>  o .: "layers"
                                    <*>  o .: "tilesets"
                                    <*> (o .: "backgroundcolor" <|> pure Nothing)
                                    <*>  o .: "renderorder"
                                    <*> (o .:? "properties" <&> fromMaybe [])
                                    <*>  o .: "nextobjectid"
  parseJSON invalid = typeMismatch "Tiledmap" invalid

instance ToJSON Tiledmap where
  toJSON Tiledmap{..} = object [ "version"         .= tiledmapVersion
                               , "tiledversion"    .= tiledmapTiledversion
                               , "width"           .= tiledmapWidth
                               , "height"          .= tiledmapHeight
                               , "tilewidth"       .= tiledmapTilewidth
                               , "tileheight"      .= tiledmapTileheight
                               , "orientation"     .= tiledmapOrientation
                               , "layers"          .= tiledmapLayers
                               , "tilesets"        .= tiledmapTilesets
                               , "backgroundcolor" .= tiledmapBackgroundcolor
                               , "renderorder"     .= tiledmapRenderorder
                               , "properties"      .= tiledmapProperties
                               , "nextobjectid"    .= tiledmapNextobjectid
                               ]

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 map -> Loaded map
    Left (err :: SomeException) -> IOErr $ show err