{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module SDLClient.SpriteSheet
  ( SpriteSheet(..)
  , SpriteDescription(..)
  , SpriteSheetType(..)
  , loadSpriteSheet
  , drawMap
  ) where

import           Codec.Archive.Zip
import           Codec.Image.STB (decodeImage)
import           Control.Monad (mzero)
import           Data.Array
import           Data.Bitmap (withBitmap)
import qualified Data.ByteString      as BS
import           Data.ByteString.Lazy.Char8 (unpack)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map as M
import           Data.Word (Word32)
import qualified Graphics.UI.SDL as SDL

data SpriteSheet = SpriteSheet
  { drawSprite :: Neighborhood Adj -> SDL.Surface -> (Int, Int) -> IO ()
  }

data SpriteSheetType
  = BasicSprite  -- Where adjacent tiles don't matter
  | FenceSprite  -- Where the Von Neumann neighborhood determines the sprite
  | BlobSprite   -- Where the Moore neighborhood determines the sprite
    deriving (Eq,Show,Read)

type Pt = (Int, Int)

-- A Moore neighborhood, i.e. a tile and everything surrounding it
newtype Neighborhood a = N (a,a,a
                           ,a,a,a
                           ,a,a,a) deriving (Eq,Show)

instance Functor Neighborhood where
  fmap f (N (a,b,c,d,e,g,h,i,j)) =
    N (f a, f b, f c, f d, f e, f g, f h, f i, f j)

-- An adjacent tile is either the Same or Different
-- In the neighborhoods we create, the center will always
-- be S, because it's the same as itself
data Adj = S | D deriving (Eq,Show)

-- XXX: animated sprites as well
data SpriteDescription = SpriteDescription
  { sdName :: BS.ByteString
  , sdSize :: (Int, Int)
  , sdType :: SpriteSheetType
  } deriving (Eq,Show,Read)

mkSpriteSheet :: (Int, Int) -> (Int, Int) -> (Neighborhood Adj -> Int) -> SDL.Surface -> IO SpriteSheet
mkSpriteSheet (sW, sH) (iW, iH) getIdx sprites = do
  let drawSprite hood screen (xP, yP) = do
        let n      = getIdx hood
        let (u, v) = (rem n iW * sW, div n iW * sH)
        let (x, y) = (xP * sW, yP * sH)
        SDL.blitSurface sprites (Just (SDL.Rect u v sW sH))
                        screen  (Just (SDL.Rect x y sW sH))
        return ()
  return SpriteSheet { .. }

parseImg :: String -> BSL.ByteString -> IO SDL.Surface
parseImg errmsg bs = do
  result <- decodeImage (BSL.toStrict bs)
  case result of
    Right img -> withBitmap img (\(width, height) chn pad ptr -> do
      let pitch = (width * chn) + pad
      let (r,g,b,a) = components chn
      SDL.createRGBSurfaceFrom ptr width height (8 * chn) pitch r g b a)
    Left err -> error (errmsg ++ ": " ++ err)

components :: Int -> (Word32, Word32, Word32, Word32)
components 1 = (0xFF000000,0xFF000000,0xFF000000,0x00000000)
components 2 = (0x00FF0000,0x00FF0000,0x00FF0000,0xFF000000)
components 3 = (0x000000FF,0x0000FF00,0x00FF0000,0x00000000)
components 4 = (0x000000FF,0x0000FF00,0x00FF0000,0xFF000000)


loadSpriteSheet :: FilePath -> IO SpriteSheet
loadSpriteSheet path = do
  rawArchive <- toArchive `fmap` BSL.readFile path
  let Just meta = findEntryByPath "texture.hs" rawArchive
  let Just png  = findEntryByPath "sprites.png" rawArchive
  let SpriteDescription { .. } = read (unpack (fromEntry meta))
  let errmsg = "Error loading " ++ path ++ ": "
  surface    <- parseImg errmsg (fromEntry png)
  let sz = case sdType of
             BasicSprite -> (1,1)
             FenceSprite -> (4,4)
             BlobSprite  -> (10,5)
  let getIds = case sdType of
                 BasicSprite -> const 0
                 FenceSprite -> fenceLookup
                 BlobSprite  -> blobLookup
  mkSpriteSheet sdSize sz getIds surface

center :: Neighborhood a -> a
center (N (_,_,_,_,x,_,_,_,_)) = x

lkp :: Array Pt a -> Pt -> (Maybe a)
lkp arr pt
  | inRange (bounds arr) pt = Just (arr ! pt)
  | otherwise               = Nothing

getNeighborhood :: Array Pt a -> Pt -> Neighborhood (Maybe a)
getNeighborhood arr (x, y) = N
  ( go (x-1, y-1), go (x  , y-1), go (x+1, y-1)
  , go (x-1, y  ), go (x  , y  ), go (x+1, y  )
  , go (x-1, y+1), go (x  , y+1), go (x+1, y+1)
  ) where go = lkp arr

getMapNeighborhood :: M.Map Pt a -> Pt -> Neighborhood (Maybe a)
getMapNeighborhood mp (x, y) = N
  ( go (x-1, y-1), go (x  , y-1), go (x+1, y-1)
  , go (x-1, y  ), go (x  , y  ), go (x+1, y  )
  , go (x-1, y+1), go (x  , y+1), go (x+1, y+1)
  ) where go pt = M.lookup pt mp

toAdj :: (Eq a) => Neighborhood (Maybe a) -> Neighborhood Adj
toAdj (N (a,b,c,d,Just e,f,g,h,i)) =
  N (go a, go b, go c, go d, S, go f, go g, go h, go i)
    where go (Just x) | x == e    = S
                      | otherwise = D
          go Nothing              = S

drawMap :: (Eq a) => (a -> SpriteSheet) -> M.Map Pt a
                  -> SDL.Surface -> IO ()
drawMap spriteFor map surf = mapM_ go (M.assocs map)
  where go ((x, y), b) = drawSprite sheet adj surf (x, y)
          where hood  = getMapNeighborhood map (x, y)
                adj   = toAdj hood
                sheet = spriteFor b

fenceLookup :: Neighborhood Adj -> Int
fenceLookup (N (_,D,_
               ,D,_,D
               ,_,S,_)) = 0
fenceLookup (N (_,D,_
               ,D,_,S
               ,_,S,_)) = 1
fenceLookup (N (_,D,_
               ,S,_,S
               ,_,S,_)) = 2
fenceLookup (N (_,D,_
               ,S,_,D
               ,_,S,_)) = 3
fenceLookup (N (_,S,_
               ,D,_,D
               ,_,S,_)) = 4
fenceLookup (N (_,S,_
               ,D,_,S
               ,_,S,_)) = 5
fenceLookup (N (_,S,_
               ,S,_,S
               ,_,S,_)) = 6
fenceLookup (N (_,S,_
               ,S,_,D
               ,_,S,_)) = 7
fenceLookup (N (_,S,_
               ,D,_,D
               ,_,D,_)) = 8
fenceLookup (N (_,S,_
               ,D,_,S
               ,_,D,_)) = 9
fenceLookup (N (_,S,_
               ,S,_,S
               ,_,D,_)) = 10
fenceLookup (N (_,S,_
               ,S,_,D
               ,_,D,_)) = 11
fenceLookup (N (_,D,_
               ,D,_,D
               ,_,D,_)) = 12
fenceLookup (N (_,D,_
               ,D,_,S
               ,_,D,_)) = 13
fenceLookup (N (_,D,_
               ,S,_,S
               ,_,D,_)) = 14
fenceLookup (N (_,D,_
               ,S,_,D
               ,_,D,_)) = 15

blobLookup :: Neighborhood Adj -> Int
blobLookup (N (_,D,_
              ,D,_,D
              ,_,S,_)) = 0
blobLookup (N (_,D,_
              ,D,_,S
              ,_,S,S)) = 1
blobLookup (N (_,D,_
              ,S,_,S
              ,S,S,S)) = 2
blobLookup (N (_,D,_
              ,S,_,D
              ,S,S,_)) = 3
blobLookup (N (_,D,_
              ,D,_,S
              ,_,S,D)) = 4
blobLookup (N (_,D,_
              ,S,_,S
              ,D,S,D)) = 5
blobLookup (N (_,D,_
              ,S,_,D
              ,D,S,_)) = 6
blobLookup (N (S,S,S
              ,S,_,S
              ,S,S,D)) = 7
blobLookup (N (S,S,S
              ,S,_,S
              ,D,S,D)) = 8
blobLookup (N (S,S,S
              ,S,_,S
              ,D,S,S)) = 9
blobLookup (N (_,S,_
              ,D,_,D
              ,_,S,_)) = 10
blobLookup (N (_,S,S
              ,D,_,S
              ,_,S,S)) = 11
blobLookup (N (S,S,S
              ,S,_,S
              ,S,S,S)) = 12
blobLookup (N (S,S,_
              ,S,_,D
              ,S,S,_)) = 13
blobLookup (N (_,S,D
              ,D,_,S
              ,_,S,D)) = 14
blobLookup (N (_,D,_
              ,D,_,D
              ,_,D,_)) = 15
blobLookup (N (D,S,_
              ,S,_,D
              ,D,S,_)) = 16
blobLookup (N (S,S,D
              ,S,_,S
              ,S,S,D)) = 17
blobLookup (N (D,S,D
              ,S,_,S
              ,D,S,D)) = 18
blobLookup (N (D,S,S
              ,S,_,S
              ,D,S,S)) = 19
blobLookup (N (_,S,_
              ,D,_,D
              ,_,D,_)) = 20
blobLookup (N (_,S,S
              ,D,_,S
              ,_,D,_)) = 21
blobLookup (N (S,S,S
              ,S,_,S
              ,_,D,_)) = 22
blobLookup (N (S,S,_
              ,S,_,D
              ,_,D,_)) = 23
blobLookup (N (_,S,D
              ,D,_,S
              ,_,D,_)) = 24
blobLookup (N (D,S,D
              ,S,_,S
              ,_,D,_)) = 25
blobLookup (N (D,S,_
              ,S,_,D
              ,_,D,_)) = 26
blobLookup (N (S,S,D
              ,S,_,S
              ,S,S,S)) = 27
blobLookup (N (D,S,D
              ,S,_,S
              ,S,S,S)) = 28
blobLookup (N (D,S,S
              ,S,_,S
              ,S,S,S)) = 29
blobLookup (N (_,D,_
              ,D,_,S
              ,_,D,_)) = 31
blobLookup (N (_,D,_
              ,S,_,S
              ,_,D,_)) = 32
blobLookup (N (_,D,_
              ,S,_,D
              ,_,D,_)) = 33
blobLookup (N (_,D,_
              ,S,_,S
              ,S,S,D)) = 34
blobLookup (N (S,S,_
              ,S,_,D
              ,D,S,_)) = 35
blobLookup (N (_,S,_
              ,D,_,S
              ,_,S,D)) = 36
blobLookup (N (_,D,_
              ,S,_,S
              ,D,S,S)) = 37
blobLookup (N (S,S,D
              ,S,_,S
              ,D,S,D)) = 38
blobLookup (N (D,S,S
              ,S,_,S
              ,D,S,D)) = 39
blobLookup (N (S,S,D
              ,S,_,S
              ,D,S,S)) = 42
blobLookup (N (D,S,S
              ,S,_,S
              ,S,S,D)) = 43
blobLookup (N (_,S,D
              ,D,_,S
              ,_,S,S)) = 44
blobLookup (N (D,S,S
              ,S,_,S
              ,_,D,_)) = 45
blobLookup (N (S,S,D
              ,S,_,S
              ,_,D,_)) = 46
blobLookup (N (D,S,_
              ,S,_,D
              ,S,S,_)) = 47
blobLookup (N (D,S,D
              ,S,_,S
              ,S,S,D)) = 48
blobLookup (N (D,S,D
              ,S,_,S
              ,D,S,S)) = 49
