separate tiled modules out into own package

2 files changed, 481 insertions, 0 deletions

diff --git a/tiled/Data/Tiled.hs b/tiled/Data/Tiled.hs
new file mode 100644
index 0000000..046a080
--- /dev/null
+++ b/tiled/Data/Tiled.hs
@@ -0,0 +1,396 @@
+{-# 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 Data.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
+  deriving Show
+
+-- | 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
diff --git a/tiled/Data/Tiled/Abstract.hs b/tiled/Data/Tiled/Abstract.hs
new file mode 100644
index 0000000..5a5b7c0
--- /dev/null
+++ b/tiled/Data/Tiled/Abstract.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Tiled.Abstract where
+
+import           Universum
+
+import qualified Data.Vector as V
+import           Data.Tiled  (GlobalId, Layer (..), Object (..), Property (..),
+                              PropertyValue (..), Tile (..), Tiledmap (..),
+                              Tileset (..), mkTiledId)
+import           Util        (showText)
+
+class HasProperties a where
+  getProperties :: a -> [Property]
+  adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a
+
+instance HasProperties Layer where
+  getProperties = maybeToMonoid . layerProperties
+  adjustProperties f layer = layer
+    { layerProperties = f (getProperties layer) }
+
+instance HasProperties Tileset where
+  getProperties = maybeToMonoid . tilesetProperties
+  adjustProperties f tileset = tileset
+    { tilesetProperties = f (getProperties tileset) }
+
+instance HasProperties Tile where
+  getProperties = V.toList . maybeToMonoid . tileProperties
+  adjustProperties f tile = tile
+    { tileProperties = (fmap V.fromList . f) (getProperties tile) }
+
+instance HasProperties Object where
+  getProperties = V.toList . maybeToMonoid . objectProperties
+  adjustProperties f obj = obj
+    { objectProperties = (fmap V.fromList . f) (getProperties obj) }
+
+instance HasProperties Tiledmap where
+  getProperties = maybeToMonoid . tiledmapProperties
+  adjustProperties f tiledmap = tiledmap
+    { tiledmapProperties = f (getProperties tiledmap) }
+
+class HasData a where
+  getData :: a -> Maybe (Vector GlobalId)
+instance HasData Layer where
+  getData = layerData
+instance HasData Tile where
+  getData _ = Nothing
+
+
+class HasTypeName a where
+  typeName :: Proxy a -> Text
+instance HasTypeName Layer where
+  typeName _ = "layer"
+instance HasTypeName Tileset where
+  typeName _ = "tileset"
+instance HasTypeName Property where
+  typeName _ = "property"
+
+
+class HasName a where
+  getName :: a -> Text
+instance HasName Layer where
+  getName = layerName
+instance HasName Tileset where
+  getName = tilesetName
+instance HasName Property where
+  getName (Property n _) = n
+instance HasName Tile where
+  getName tile = "[tile with global id " <> showText (tileId tile) <> "]"
+
+
+class IsProperty a where
+  asProperty :: a -> PropertyValue
+instance IsProperty PropertyValue where
+  asProperty = id
+  {-# INLINE asProperty #-}
+instance IsProperty Text where
+  asProperty = StrProp
+  {-# INLINE asProperty #-}
+
+
+layerIsEmpty :: HasData a => a -> Bool
+layerIsEmpty layer = case getData layer of
+  Nothing -> True
+  Just d  -> all ((==) $ mkTiledId 0) d