diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Schell Scivally (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Schell Scivally nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +# aeson-tiled +[![Build Status](https://travis-ci.org/schell/aeson-tiled.svg?branch=master)](https://travis-ci.org/schell/aeson-tiled) +[![Hackage](https://img.shields.io/hackage/v/aeson-tiled.svg)](https://hackage.haskell.org/package/aeson-tiled) +`aeson-tiled` is the spiritual successor to `htiled`. `htiled` uses `hxt` which relies +too heavily on Arrows and is rather hard to work with. Tiled's json export +supports 100% of Tiled's features, so there doesn't seem to be much of a +point to maintaining a large Arrows-based project when writing Aeson instances +for Tiled types is much easier. Hence this project! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aeson-tiled.cabal b/aeson-tiled.cabal new file mode 100644 --- /dev/null +++ b/aeson-tiled.cabal @@ -0,0 +1,50 @@ +name: aeson-tiled +version: 0.0.0.1 +synopsis: Aeson instances for the Tiled map editor. +description: The mighty Tiled 2d map editor is an open source + app for creating tile based level maps. This package provides + types and aeson instances to read Tiled json files. +homepage: https://github.com/schell/aeson-tiled#readme +license: BSD3 +license-file: LICENSE +author: Schell Scivally +maintainer: schell@takt.com +copyright: Copyright: (c) 2017 Schell Scivally +category: Game +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.Aeson.Tiled + build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10 + , aeson >= 1.1 + , containers >= 0.5 + , text >= 1.2 + , vector >= 0.12 + default-language: Haskell2010 + +executable aeson-tiled-exe + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , aeson-tiled + default-language: Haskell2010 + +test-suite aeson-tiled-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , aeson >= 1.1 + , aeson-tiled + , hspec + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/schell/aeson-tiled diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Data.Aeson.Tiled + +main :: IO () +main = print =<< loadTiledmap "example.json" diff --git a/src/Data/Aeson/Tiled.hs b/src/Data/Aeson/Tiled.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Tiled.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# 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/ +module Data.Aeson.Tiled + ( -- * Tiled map editor types, their aeson instances and map loading + module Data.Aeson.Tiled + -- * Re-exports for working with Tiled types + , module Data.Map + , module Data.Vector + ) where + +import Control.Applicative ((<|>)) +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.Lazy.Char8 as C8 +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import Data.Vector (Vector) +import GHC.Generics (Generic) + + +-- | A globally indexed identifier. +newtype GlobalId = GlobalId { unGlobalId :: Int } + deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + + +-- | A locally indexed identifier. +newtype LocalId = LocalId { unLocalId :: Int } + deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) + + +data Object = Object { objectId :: Int + -- ^ Incremental id - unique across all objects + , objectWidth :: Int + -- ^ Width in pixels. Ignored if using a gid. + , objectHeight :: Int + -- ^ 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 :: Int + -- ^ x coordinate in pixels + , objectY :: Int + -- ^ y coordinate in pixels + , objectRotation :: Float + -- ^ Angle in degrees clockwise + , objectGid :: GlobalId + -- ^ GID, only if object comes from a Tilemap + , objectEllipse :: Bool + -- ^ Used to mark an object as an ellipse + , objectPolygon :: Vector (Int, Int) + -- ^ A list of x,y coordinates in pixels + , objectPolyline :: Vector (Int, Int) + -- ^ 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" + <*> o .: "properties" + <*> o .: "visible" + <*> o .: "x" + <*> o .: "y" + <*> o .: "rotation" + <*> o .: "gid" + <*> o .: "ellipse" + <*> o .: "polygon" + <*> o .: "polyline" + <*> o .: "text" + parseJSON invalid = typeMismatch "Object" invalid + +instance ToJSON Object where + toJSON Object{..} = 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" .= objectPolygon + , "polyline" .= objectPolyline + , "text" .= objectText + ] + + +data Layer = Layer { layerWidth :: Int + -- ^ Column count. Same as map width for fixed-size maps. + , layerHeight :: Int + -- ^ Row count. Same as map height for fixed-size maps. + , layerName :: String + -- ^ Name assigned to this layer + , layerType :: String + -- ^ “tilelayer”, “objectgroup”, or “imagelayer” + , layerVisible :: Bool + -- ^ Whether layer is shown or hidden in editor + , layerX :: Int + -- ^ Horizontal layer offset in tiles. Always 0. + , layerY :: Int + -- ^ 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 :: Map Text Text + -- ^ 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" <|> pure Nothing) + <*> (o .: "properties" <|> pure mempty) + <*> o .: "opacity" + <*> (o .: "draworder" <|> pure "topdown") + parseJSON invalid = typeMismatch "Layer" invalid + +instance ToJSON Layer where + toJSON Layer{..} = 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 :: String + -- ^ Image used for tiles in this set + , tilesetName :: String + -- ^ 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 :: Int + -- ^ Map grid width. + , tiledmapTileheight :: Int + -- ^ 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 :: Map Text Text + -- ^ 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" <|> pure mempty) + <*> 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 + ] + + +-- | Load a Tiled map from the given 'FilePath'. +loadTiledmap :: FilePath -> IO (Either String Tiledmap) +loadTiledmap = fmap eitherDecode . C8.readFile diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE LambdaCase #-} +import Data.Aeson (encode, eitherDecode) +import Test.Hspec +import Control.Monad (forM_) + +import Data.Aeson.Tiled + +files :: [FilePath] +files = [ "maps/example.json" + , "maps/test1.json" + , "maps/test2.json" + , "maps/test3.json" + , "maps/test4.json" + ] + +main :: IO () +main = hspec $ forM_ files $ \file -> + describe ("With " ++ show file) $ + it "loading and encoding and decoding should end up with the same Tiledmap" $ + loadTiledmap file >>= \case + Right tm -> do + let bs = encode tm + eitherDecode bs `shouldBe` Right tm + _ -> fail $ "Could not decode Tiledmap from " ++ show file