diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/CheckDir.hs | 2 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 2 | ||||
| -rw-r--r-- | lib/LayerData.hs | 2 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 2 | ||||
| -rw-r--r-- | lib/Properties.hs | 11 | ||||
| -rw-r--r-- | lib/Tiled.hs | 395 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 85 | ||||
| -rw-r--r-- | lib/Util.hs | 2 |
8 files changed, 10 insertions, 491 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index a19a412..300cf00 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -41,7 +41,7 @@ import System.FilePath (splitPath, (</>)) import qualified System.FilePath as FP import System.FilePath.Posix (takeDirectory) import Text.Dot (showDot) -import Tiled (Tiledmap) +import Data.Tiled (Tiledmap) import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint), ellipsis) diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 23267a8..9dc3a4c 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -32,7 +32,7 @@ import LintWriter (LintResult, invertLintResult, runLintWriter) import Properties (checkLayer, checkMap, checkTileset) import System.FilePath (takeFileName) -import Tiled (Layer (layerLayers, layerName), +import Data.Tiled (Layer (layerLayers, layerName), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), loadTiledmap) diff --git a/lib/LayerData.hs b/lib/LayerData.hs index 6956c92..46d6449 100644 --- a/lib/LayerData.hs +++ b/lib/LayerData.hs @@ -8,7 +8,7 @@ import Control.Monad.Zip (mzipWith) import Data.Set (insert) import Data.Vector (maximum, uncons) import qualified Text.Show as TS -import Tiled (GlobalId (unGlobalId), Layer (..)) +import Data.Tiled (GlobalId (unGlobalId), Layer (..)) import Util (PrettyPrint (..)) -- | A collision between two layers of the given names. diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index d0c6c4e..b55b16e 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -48,7 +48,7 @@ import Universum import Badges (Badge) import Data.Map (fromListWith) import LintConfig (LintConfig') -import TiledAbstract (HasName (getName)) +import Data.Tiled.Abstract (HasName (getName)) import Types (Dep, Hint, Level (..), Lint (..), hint, lintsToHints) diff --git a/lib/Properties.hs b/lib/Properties.hs index eb31403..846430b 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -18,14 +18,13 @@ import Universum hiding (intercalate, isPrefixOf) import Data.Text (intercalate, isInfixOf, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V -import Tiled (Layer (..), Object (..), Property (..), +import Data.Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), Tiledmap (..), Tileset (..)) -import TiledAbstract (HasData (..), HasName (..), - HasProperties (..), HasTypeName (..), - IsProperty (..), layerIsEmpty) -import Util (mkProxy, naiveEscapeHTML, prettyprint, - showText) +import Data.Tiled.Abstract (HasName (..), HasProperties (..), + HasTypeName (..), IsProperty (..), HasData (..)) +import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, + prettyprint) import Badges (Badge (Badge), BadgeArea (BadgePoint, BadgeRect), diff --git a/lib/Tiled.hs b/lib/Tiled.hs deleted file mode 100644 index 3162dfd..0000000 --- a/lib/Tiled.hs +++ /dev/null @@ -1,395 +0,0 @@ -{-# 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 diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs deleted file mode 100644 index f55e75e..0000000 --- a/lib/TiledAbstract.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TiledAbstract where - -import Universum - -import qualified Data.Vector as V -import 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 diff --git a/lib/Util.hs b/lib/Util.hs index 1ffbbe5..d5e9e98 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -17,7 +17,7 @@ import Universum import Data.Aeson as Aeson import qualified Data.Set as S import qualified Data.Text as T -import Tiled (Layer (layerData), PropertyValue (..), +import Data.Tiled (Layer (layerData), PropertyValue (..), Tileset (tilesetName), layerName, mkTiledId) -- | helper function to create proxies |