summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/CheckDir.hs2
-rw-r--r--lib/CheckMap.hs2
-rw-r--r--lib/LayerData.hs2
-rw-r--r--lib/LintWriter.hs2
-rw-r--r--lib/Properties.hs11
-rw-r--r--lib/Tiled.hs395
-rw-r--r--lib/TiledAbstract.hs85
-rw-r--r--lib/Util.hs2
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