htiled (empty) → 0.0.2
raw patch · 6 files changed
+308/−0 lines, 6 filesdep +basedep +base64-bytestringdep +bytestringsetup-changed
Dependencies added: base, base64-bytestring, bytestring, containers, filepath, hxt, zlib
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- htiled.cabal +24/−0
- src/Data/Tiled.hs +6/−0
- src/Data/Tiled/Load.hs +153/−0
- src/Data/Tiled/Types.hs +93/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, cra++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 cra 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ htiled.cabal view
@@ -0,0 +1,24 @@+Name: htiled+Version: 0.0.2+Synopsis: Import from the Tiled map editor.+Description: Import maps from the .tmx map format generated by Tiled,+ <http://www.mapeditor.org>.+License: BSD3+License-file: LICENSE+Author: Christian Rødli Amble+Maintainer: cra+code@cra.no+Category: Game+Build-type: Simple+Cabal-version: >=1.6++Source-Repository head+ Type: git+ Location: git://github.com/chrra/htiled.git++Library+ Hs-Source-Dirs: src+ Exposed-Modules: Data.Tiled, Data.Tiled.Types, Data.Tiled.Load+ Build-depends: base ==0.4.*, zlib ==0.5.*, bytestring ==0.9.*+ , hxt >9.1 && <9.3, base64-bytestring ==0.1.*+ , containers ==0.4.*, filepath+ Ghc-Options: -Wall
+ src/Data/Tiled.hs view
@@ -0,0 +1,6 @@+module Data.Tiled+ ( module X+ ) where++import Data.Tiled.Load as X+import Data.Tiled.Types as X
+ src/Data/Tiled/Load.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE Arrows, UnicodeSyntax, RecordWildCards #-}+module Data.Tiled.Load (loadMapFile) where++import Prelude hiding ((.), id)+import Control.Category ((.), id)+import Data.Bits (testBit, clearBit)+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Char (digitToInt)+import Data.List (sort)+import Data.Map (fromDistinctAscList, Map)+import Data.Maybe (listToMaybe, fromMaybe, isNothing)+import Data.Word (Word32)++import qualified Codec.Compression.GZip as GZip+import qualified Codec.Compression.Zlib as Zlib+import Text.XML.HXT.Core++import Data.Tiled.Types++-- | Load a map file.+loadMapFile ∷ FilePath → IO TiledMap+loadMapFile fp = head `fmap` runX (+ configSysVars [withValidate no, withWarnings yes]+ >>> readDocument [] fp+ >>> getChildren >>> isElem+ >>> doMap fp)++properties ∷ IOSArrow XmlTree Properties+properties = listA $ getChildren >>> isElem >>> hasName "properties"+ >>> getChildren >>> isElem >>> hasName "property"+ >>> getAttrValue "name" &&& getAttrValue "value"++getAttrR ∷ (Read α, Num α) ⇒ String → IOSArrow XmlTree α+getAttrR a = arr read . getAttrValue0 a++doMap ∷ FilePath → IOSArrow XmlTree TiledMap+doMap mapPath = proc m → do+ mapOrientation ← arr (\x → case x of "orthogonal" → Orthogonal+ "isometric" → Isometric+ _ → error "unsupported orientation")+ . getAttrValue "orientation" ⤙ m+ mapWidth ← getAttrR "width" ⤙ m+ mapHeight ← getAttrR "height" ⤙ m+ mapTileWidth ← getAttrR "tilewidth" ⤙ m+ mapTileHeight ← getAttrR "tileheight" ⤙ m+ mapProperties ← properties ⤙ m+ mapTilesets ← tilesets ⤙ m+ mapLayers ← layers ⤙ (m, (mapWidth, mapHeight))+ returnA ⤙ TiledMap {..}++layers ∷ IOSArrow (XmlTree, (Int, Int)) [Layer]+layers = listA (first (getChildren >>> isElem) >>> doObjectGroup <+> doLayer)+ where+ doObjectGroup = arr fst >>> hasName "objectgroup" >>> id &&& (listA object >>> arr Right) >>> common++ object = getChildren >>> isElem >>> hasName "object"+ >>> proc obj → do+ objectName ← arr listToMaybe . listA (getAttrValue "name") ⤙ obj+ objectType ← arr listToMaybe . listA (getAttrValue "type") ⤙ obj+ objectX ← getAttrR "x" ⤙ obj+ objectY ← getAttrR "y" ⤙ obj+ objectWidth ← arr listToMaybe . listA (getAttrR "width") ⤙ obj+ objectHeight ← arr listToMaybe . listA (getAttrR "height") ⤙ obj+ objectGid ← arr listToMaybe . listA (getAttrR "gid") ⤙ obj+ objectPolygon ← arr listToMaybe . polygon ⤙ obj+ objectPolyline ← arr listToMaybe . polyline ⤙ obj+ objectProperties ← properties ⤙ obj+ returnA ⤙ Object {..}++ polygon ∷ IOSArrow XmlTree [Polygon]+ polygon = listA $ getChildren >>> isElem >>> hasName "polygon"+ >>> getAttrValue "points" >>> arr (Polygon . points)+ polyline ∷ IOSArrow XmlTree [Polyline]+ polyline = listA $ getChildren >>> isElem >>> hasName "polyline"+ >>> getAttrValue "points" >>> arr (Polyline . points)++ points :: String → [(Int, Int)]+ points s = (x, y):if null rest then [] else points rest+ where (p, rest) = drop 1 `fmap` break (==' ') s+ (x', y') = drop 1 `fmap` break (==',') p+ x = read x'+ y = read y'++ doLayer = first (hasName "layer") >>> arr fst &&& (doData >>> arr Left) >>> common++ doData = first (getChildren >>> isElem >>> hasName "data")+ >>> proc (dat, (w, h)) → do+ encoding ← getAttrValue "encoding" ⤙ dat+ compression ← getAttrValue "compression" ⤙ dat+ text ← getText . isText . getChildren ⤙ dat+ returnA ⤙ dataToTiles w h encoding compression text++ -- Width → Height → Encoding → Compression → Data → [Tile]+ dataToTiles ∷ Int → Int → String → String → String → Map (Int, Int) Tile+ dataToTiles w h "base64" "gzip" = toMap w h . base64 GZip.decompress+ dataToTiles w h "base64" "zlib" = toMap w h . base64 Zlib.decompress+ dataToTiles _ _ _ _ = error "unsupported tile data format, only base64 and \+ \gzip/zlib is supported at the moment."++ toMap w h = fromDistinctAscList . sort . filter (\(_, x) → tileGid x /= 0)+ . zip [(x, y) | y ← [0..h-1], x ← [0..w-1]]++ base64 f = bytesToTiles . LBS.unpack . f . LBS.fromChunks+ . (:[]) . B64.decodeLenient . BS.pack++ bytesToTiles (a:b:c:d:xs) = Tile { .. } : bytesToTiles xs+ where n = f a + f b * 256 + f c * 65536 + f d * 16777216+ f = fromIntegral . fromEnum ∷ Char → Word32+ tileGid = n `clearBit` 30 `clearBit` 31+ tileIsVFlipped = n `testBit` 30+ tileIsHFlipped = n `testBit` 31+ bytesToTiles [] = []+ bytesToTiles _ = error "number of bytes not a multiple of 4."++ common = proc (l, x) → do+ layerName ← getAttrValue "name" ⤙ l+ layerOpacity ← arr (fromMaybe 1 . listToMaybe)+ . listA (getAttrR "opacity") ⤙ l+ layerIsVisible ← arr (isNothing . listToMaybe)+ . listA (getAttrValue "visible") ⤙ l+ layerProperties ← properties ⤙ l+ returnA ⤙ case x of Left layerData → Layer {..}+ Right layerObjects → ObjectLayer {..}+++tilesets ∷ IOSArrow XmlTree [Tileset]+tilesets = listA $ getChildren >>> isElem >>> hasName "tileset"+ >>> proc ts → do+ tsName ← getAttrValue "name" ⤙ ts+ tsInitialGid ← getAttrR "firstgid" ⤙ ts+ tsTileWidth ← getAttrR "tilewidth" ⤙ ts+ tsTileHeight ← getAttrR "tileheight" ⤙ ts+ tsImages ← images ⤙ ts+ tsTileProperties ← listA tileProperties ⤙ ts+ returnA ⤙ Tileset {..}+ where tileProperties ∷ IOSArrow XmlTree (Word32, Properties)+ tileProperties = getChildren >>> isElem >>> hasName "tile"+ >>> getAttrR "id" &&& properties++ images = listA (getChildren >>> isElem >>> hasName "image" >>>+ proc image → do+ iSource ← getAttrValue "source" ⤙ image+ iTrans ← arr (fmap colorToTriplet . listToMaybe)+ . listA (getAttrValue0 "trans") ⤙ image+ iWidth ← getAttrR "width" ⤙ image+ iHeight ← getAttrR "height" ⤙ image+ returnA ⤙ Image {..})++ colorToTriplet x = (h x, h $ drop 2 x, h $ drop 4 x)+ where h (y:z:_) = fromIntegral $ digitToInt y * 16 + digitToInt z+ h _ = error "invalid color in an <image ...> somewhere."
+ src/Data/Tiled/Types.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE UnicodeSyntax, RecordWildCards #-}+module Data.Tiled.Types where++import Data.Map (Map)+import Data.Word (Word8, Word32)++-- | Orientations.+data MapOrientation = Orthogonal | Isometric deriving (Show, Eq)++-- | Properties.+type Properties = [(String, String)]++-- | A tiled map.+data TiledMap = TiledMap+ { mapPath ∷ FilePath -- ^ The file path of the map file.+ , mapOrientation ∷ MapOrientation+ , mapWidth, mapHeight ∷ Int+ , mapTileWidth ∷ Int+ , mapTileHeight ∷ Int+ , mapProperties ∷ Properties+ , mapTilesets ∷ [Tileset]+ , mapLayers ∷ [Layer]+ } deriving (Show, Eq)++-- | A set of tiles that can be used.+data Tileset = Tileset+ { tsName ∷ String+ , tsInitialGid ∷ Word32+ , tsTileWidth, tsTileHeight ∷ Int+ , tsImages ∷ [Image] -- ^ Multiple images not+ -- yet supported in tiled.+ , tsTileProperties ∷ [(Word32, Properties)]+ } deriving (Show, Eq)++-- | An image containing tiles.+data Image = Image+ { iSource ∷ FilePath+ , iTrans ∷ Maybe (Word8, Word8, Word8)+ , iWidth, iHeight ∷ Int+ } deriving (Show, Eq)++-- | An object, usable for stuff not repetitively aligned on a grid.+data Object = Object+ { objectName ∷ Maybe String+ , objectType ∷ Maybe String+ , objectProperties ∷ Properties+ , objectX, objectY ∷ Int+ , objectWidth, objectHeight ∷ Maybe Int+ , objectGid ∷ Maybe Word32+ , objectPolygon ∷ Maybe Polygon+ , objectPolyline ∷ Maybe Polyline+ } deriving (Show, Eq)++-- | A polygon.+data Polygon = Polygon [(Int, Int)] deriving (Show, Eq)++-- | A polyline.+data Polyline = Polyline [(Int, Int)] deriving (Show, Eq)++-- | Either a tile layer or an object layer.+data Layer = Layer+ { layerName ∷ String+ , layerOpacity ∷ Float+ , layerIsVisible ∷ Bool+ , layerProperties ∷ Properties+ , layerData ∷ Map (Int, Int) Tile+ }+ | ObjectLayer+ { layerName ∷ String+ , layerOpacity ∷ Float+ , layerIsVisible ∷ Bool+ , layerProperties ∷ Properties+ , layerObjects ∷ [Object]+ } deriving Eq++-- | A single tile as is stored in a layer.+data Tile = Tile { tileGid ∷ Word32+ , tileIsVFlipped, tileIsHFlipped ∷ Bool+ } deriving (Show, Eq, Ord)+++instance Show Layer where+ show Layer {..} = "Layer { layerName = " ++ show layerName +++ ", layerOpacity = " ++ show layerOpacity +++ ", layerIsVisible = " ++ show layerIsVisible +++ ", layerProperties = " ++ show layerProperties +++ ", layerData = \"...\" }"+ show ObjectLayer {..} = "ObjectLayer { layerName = " ++ show layerName +++ ", layerOpacity = " ++ show layerOpacity +++ ", layerIsVisible = " ++ show layerIsVisible +++ ", layerProperties = " ++ show layerProperties +++ ", layerObjects = " ++ show layerObjects ++ " }"+