{-# LANGUAGE Arrows          #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnicodeSyntax   #-}
module Data.Tiled.Load (loadMapFile, loadMap) where

import           Control.Category           (id, (.))
import           Data.Bits                  (clearBit, testBit)
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.List.Split            (splitOn)
import           Data.Map                   (Map, fromDistinctAscList)
import           Data.Maybe                 (fromMaybe, isNothing, listToMaybe)
import           Data.Word                  (Word32)
import           Prelude                    hiding (id, (.))

import qualified Codec.Compression.GZip     as GZip
import qualified Codec.Compression.Zlib     as Zlib
import           System.FilePath            (dropFileName, (</>))
import           Text.XML.HXT.Core

import           Data.Tiled.Types

-- | Load a map from a string
loadMap ∷ String → IO TiledMap
loadMap str = load (readString [] str) "binary"

-- | Load a map file.
loadMapFile ∷ FilePath → IO TiledMap
loadMapFile fp = load (readDocument [] fp) fp

load ∷ IOStateArrow () XmlTree XmlTree -> FilePath -> IO TiledMap
load a fp = head `fmap` runX (
        configSysVars [withValidate no, withWarnings yes]
    >>> a
    >>> 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

getAttrMaybeR ∷ (Read α, Num α) ⇒ String → IOSArrow XmlTree (Maybe α)
getAttrMaybeR a = arr (fmap read) . getAttrMaybe a

getAttrMaybe ∷ String → IOSArrow XmlTree (Maybe String)
getAttrMaybe a = arr tm . getAttrValue a
    where
        tm "" = Nothing
        tm s = Just s

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 mapPath      ⤙ m
    mapLayers      ← layers                ⤙ (m, (mapWidth, mapHeight))
    returnA        ⤙ TiledMap {..}

layers ∷ IOSArrow (XmlTree, (Int, Int)) [Layer]
layers = listA (first (getChildren >>> isElem) >>> doObjectGroup <+> doLayer <+> doImageLayer)
  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'

    doImageLayer = arr fst >>> hasName "imagelayer" >>> id &&& image >>> proc (l, layerImage) → 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 ⤙ ImageLayer{..}

    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 w h "csv"    _      = toMap w h . csv
    dataToTiles _ _ _ _ = error "unsupported tile data format, only base64 with \
                                \gzip/zlib and csv are 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 = wordsToTiles . bytesToWords . LBS.unpack . f . LBS.fromChunks
                            . (:[]) . B64.decodeLenient . BS.pack

    csv = wordsToTiles . map (read ∷ String → Word32)
                       . splitOn ","
                       . filter (`elem` (',':['0' .. '9']))

    bytesToWords []           = []
    bytesToWords (a:b:c:d:xs) = n : bytesToWords xs
      where n = f a + f b * 256 + f c * 65536 + f d * 16777216
            f = fromIntegral . fromEnum ∷ Char → Word32
    bytesToWords _            = error "number of bytes not a multiple of 4."

    wordsToTiles []           = []
    wordsToTiles (w:ws)       = Tile { .. } : wordsToTiles ws
      where tileGid           = w `clearBit` 30 `clearBit` 31 `clearBit` 29
            tileIsVFlipped    = w `testBit` 30
            tileIsHFlipped    = w `testBit` 31
            tileIsDiagFlipped = w `testBit` 29

    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 ∷ FilePath → IOSArrow XmlTree [Tileset]
tilesets fp =
  listA $ getChildren >>> isElem >>> hasName "tileset"
  >>> getAttrR "firstgid" &&& ifA (hasAttr "source") (externalTileset fp) id
  >>> tileset

externalTileset ∷ FilePath → IOSArrow XmlTree XmlTree
externalTileset mapPath =
  arr (const (dropFileName mapPath)) &&& getAttrValue "source"
  >>> arr (uncurry (</>))
  >>> readFromDocument [ withValidate no, withWarnings yes ]
  >>> getChildren >>> isElem >>> hasName "tileset"

tileset ∷ IOSArrow (Word32, XmlTree) Tileset
tileset = proc (tsInitialGid, ts) → do
  tsName           ← getAttrValue "name"                        ⤙ ts
  tsTileWidth      ← getAttrR "tilewidth"                       ⤙ ts
  tsTileHeight     ← getAttrR "tileheight"                      ⤙ ts
  tsMargin         ← arr (fromMaybe 0) . getAttrMaybeR "margin"  ⤙ ts
  tsSpacing        ← arr (fromMaybe 0) . getAttrMaybeR "spacing" ⤙ 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 >>> (image <+> tileImage))

data ImageType = TileImage | NormalImage deriving (Read)

image ∷ IOSArrow XmlTree Image
image = isElem >>> hasName "image" >>> proc img → do
    iWidth  ← getAttrR "width"        ⤙ img
    iHeight ← getAttrR "height"       ⤙ img
    iSource ← getAttrValue0 "source"  ⤙ img
    iTrans  ← arr (fmap colorToTriplet) . getAttrMaybe "trans" ⤙ img
    returnA ⤙ Image {..}
    where
        colorToTriplet :: Integral i => String -> (i,i,i)
        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."

tileImage :: IOSArrow XmlTree Image
tileImage = isElem >>> hasName "tile" >>> getChildren >>> image