{-# 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