gridland 0.1.0.1 → 0.1.0.2
raw patch · 3 files changed
+187/−51 lines, 3 files
Files
- gridland.cabal +1/−1
- src/GridLand.hs +176/−49
- src/GridLand/Data.hs +10/−1
gridland.cabal view
@@ -1,5 +1,5 @@ name: gridland-version: 0.1.0.1+version: 0.1.0.2 synopsis: Grid-based multimedia engine description: Learn Haskell by drawing sprites and playing music and sound effects. license: MIT
src/GridLand.hs view
@@ -48,6 +48,7 @@ import Data.Char import Data.Maybe import Control.Arrow+import System.Environment -- SDL import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL.Video as SDL@@ -114,39 +115,16 @@ in SDL.Pixel v loadSpriteStretch :: FilePath -> Stretch -> GridLand a Sprite-loadSpriteStretch path stretch = do+loadSpriteStretch rawPath stretch = do+ path <- correctPath rawPath base <- liftIO $ Image.load path >>= SDL.displayFormat >>= setColorKey (0xff,0x00,0xff) let (w,h) = (SDL.surfaceGetWidth base, SDL.surfaceGetHeight base) let side = max w h ts <- RWS.asks tileSize let zoom = (fromIntegral ts) / (fromIntegral side)- let blit (cf, theta) = do- rotozoom <- Gfx.rotozoom base (fromIntegral theta) zoom (stretch == Smooth)- ping <- SDL.displayFormat rotozoom >>= setColorKey (0xff, 0x00, 0xff)- pong <- setColorKey (0xff, 0x00, 0xff) rotozoom- let (w,h) = (SDL.surfaceGetWidth rotozoom, SDL.surfaceGetHeight rotozoom)- let fmt = SDL.surfaceGetPixelFormat rotozoom- let cfFn v = case cf of- NoFilter -> SDL.Pixel v- Tint color -> let- (tr, tg, tb) = colorValue color- (cr, cg, cb) = fromColor32 v- (r, g, b) = (shiftR tr 1 + shiftR cr 1, shiftR tg 1 + shiftR cg 1, shiftR tb 1 + shiftR cb 1)- tinted = toColor32' r g b- in SDL.Pixel $ if 0x00ff00ff == v .&. 0x00ffffff- then 0x00ff00ff- else tinted- Replace color -> let- (SDL.Pixel p) = colorToPixel color- in SDL.Pixel $ if 0x00ff00ff == v .&. 0x00ffffff- then 0x00ff00ff- else p- forM_ ([(x,y) | x <- [0 .. w - 1], y <- [0 .. h - 1]]) $ \(x,y) -> do- (SDL.Pixel v) <- getPixel32 x y ping- putPixel32 x y (cfFn v) pong- SDL.freeSurface ping- return pong- frames <- liftIO $ mapM blit spriteOpts+ fmt <- io (surfacePixelFormat base)+ let blitter = blit stretch base zoom+ frames <- liftIO $ mapM (\(cf, theta) -> blitter (mapFilterColor fmt cf) theta) spriteOpts liftIO $ SDL.freeSurface base let spriteFrames = V.fromListN totalFrames frames key <- RWS.gets (Map.size . sprites . fst)@@ -154,6 +132,106 @@ RWS.modify . first $ \s -> s { sprites = Map.insert spr spriteFrames (sprites s) } return spr +blit+ :: Stretch+ -> SDL.Surface+ -> Double+ -> (Word32 -> SDL.Pixel)+ -> Int+ -> IO SDL.Surface+blit stretch base zoom toPixel theta = do+ rotozoom <- Gfx.rotozoom base (fromIntegral theta) zoom (stretch == Smooth)+ ping <- SDL.displayFormat rotozoom >>= setColorKey (0xff, 0x00, 0xff)+ pong <- setColorKey (0xff, 0x00, 0xff) rotozoom+ let (w,h) = (SDL.surfaceGetWidth rotozoom, SDL.surfaceGetHeight rotozoom)+ let fmt = SDL.surfaceGetPixelFormat rotozoom+ forM_ ([(x,y) | x <- [0 .. w - 1], y <- [0 .. h - 1]]) $ \(x,y) -> do+ (SDL.Pixel v) <- getPixel32 x y ping+ putPixel32 x y (toPixel v) pong+ SDL.freeSurface ping+ return pong++mapFilterColor :: PixelFormat -> ColorFilter -> Word32 -> SDL.Pixel+mapFilterColor RGBA = filterColorRGBA+mapFilterColor BGRA = filterColorBGRA+mapFilterColor ARGB = filterColorARGB+mapFilterColor ABGR = filterColorABGR++filterColorABGR :: ColorFilter -> Word32 -> SDL.Pixel+filterColorABGR = mkFilterColor toColorABGR32 fromColorABGR32 0xff000000++filterColorARGB :: ColorFilter -> Word32 -> SDL.Pixel+filterColorARGB = mkFilterColor toColorARGB32 fromColorARGB32 0xff000000++filterColorRGBA :: ColorFilter -> Word32 -> SDL.Pixel+filterColorRGBA = mkFilterColor toColorRGBA32 fromColorRGBA32 0x000000ff++filterColorBGRA :: ColorFilter -> Word32 -> SDL.Pixel+filterColorBGRA = mkFilterColor toColorBGRA32 fromColorBGRA32 0x000000ff++mkFilterColor+ :: (Word8 -> Word8 -> Word8 -> Word32)+ -> (Word32 -> (Word8, Word8, Word8))+ -> Word32+ -> ColorFilter+ -> Word32+ -> SDL.Pixel+mkFilterColor toColor fromColor transMask = let+ magenta = toColor 0xff 0x00 0xff+ white = toColor 0xff 0xff 0xff+ trans = xor magenta transMask+ in filterColor toColor fromColor white magenta trans++filterColor+ :: (Word8 -> Word8 -> Word8 -> Word32)+ -> (Word32 -> (Word8, Word8, Word8))+ -> Word32+ -> Word32+ -> Word32+ -> ColorFilter+ -> Word32+ -> SDL.Pixel+filterColor _ _ _ _ _ NoFilter v = SDL.Pixel v+filterColor toColor fromColor white magenta trans (Tint color) v = let+ (cr, cg, cb) = fromColor v+ (tr, tg, tb) = colorValue color+ (r, g, b) = (shiftR tr 1 + shiftR cr 1, shiftR tg 1 + shiftR cg 1, shiftR tb 1 + shiftR cb 1)+ tinted = toColor r g b+ in SDL.Pixel $ if magenta == toColor cr cg cb .&. white+ then trans+ else tinted+filterColor toColor fromColor white magenta trans (Replace color) v = let+ (cr, cg, cb) = fromColor v+ (r, g, b) = colorValue color+ p = toColor r g b+ in SDL.Pixel $ if magenta == (toColor cr cg cb) .&. white+ then trans+ else p++-- This is a necessary hack because the SDL bindings are insufficient+surfacePixelFormat :: SDL.Surface -> IO PixelFormat+surfacePixelFormat sur = do+ let fmt = SDL.surfaceGetPixelFormat sur+ rShift <- pixelFormatGetRShift fmt+ bShift <- pixelFormatGetBShift fmt+ gShift <- pixelFormatGetGShift fmt+ aShift <- pixelFormatGetAShift fmt+ return $ case (rShift, gShift, bShift, aShift) of+ ( 0, 8, 16, 24) -> ABGR+ (16, 8, 0, 24) -> ARGB+ (24, 16, 8, 0) -> RGBA+ ( 8, 16, 24, 0) -> BGRA+ _ -> ABGR -- default++correctPath :: FilePath -> GridLand a FilePath+correctPath "" = RWS.gets (pathPrefix . fst)+correctPath path =+ if head path == '/'+ then return path+ else do+ prefix <- RWS.gets (pathPrefix . fst)+ return $ prefix ++ path+ loadSprite :: FilePath -> GridLand a Sprite loadSprite path = loadSpriteStretch path Pixelated @@ -174,17 +252,35 @@ aMask <- if elem SDL.SrcColorKey flags then return 0 else pixelFormatGetAMask fmt SDL.createRGBSurface [SDL.SWSurface] (SDL.surfaceGetWidth sur) (SDL.surfaceGetHeight sur) bpp rMask gMask bMask aMask -pixelFormatGetRMask :: SDL.PixelFormat -> IO Word32-pixelFormatGetRMask format = withForeignPtr format $ \hsc_ptr -> peekByteOff hsc_ptr 16+pixelFormatGetBytes :: Storable a => Int -> SDL.PixelFormat -> IO a+pixelFormatGetBytes offset fmt = withForeignPtr fmt (\ptr -> peekByteOff ptr offset) -pixelFormatGetGMask :: SDL.PixelFormat -> IO Word32-pixelFormatGetGMask format = withForeignPtr format $ \hsc_ptr -> peekByteOff hsc_ptr 20+pixelFormatGetRShift, pixelFormatGetGShift, pixelFormatGetBShift, pixelFormatGetAShift :: SDL.PixelFormat -> IO Word8+-- 64 bit+pixelFormatGetRShift = pixelFormatGetBytes 14+pixelFormatGetGShift = pixelFormatGetBytes 15+pixelFormatGetBShift = pixelFormatGetBytes 16+pixelFormatGetAShift = pixelFormatGetBytes 17+{- 32 bit+pixelFormatGetRShift = pixelFormatGetBytes 10+pixelFormatGetGShift = pixelFormatGetBytes 11+pixelFormatGetBShift = pixelFormatGetBytes 12+pixelFormatGetAShift = pixelFormatGetBytes 13+-} -pixelFormatGetBMask :: SDL.PixelFormat -> IO Word32-pixelFormatGetBMask format = withForeignPtr format $ \hsc_ptr -> peekByteOff hsc_ptr 24+pixelFormatGetRMask, pixelFormatGetGMask, pixelFormatGetBMask, pixelFormatGetAMask :: SDL.PixelFormat -> IO Word32+-- 64 bit+pixelFormatGetRMask = pixelFormatGetBytes 20+pixelFormatGetGMask = pixelFormatGetBytes 24+pixelFormatGetBMask = pixelFormatGetBytes 28+pixelFormatGetAMask = pixelFormatGetBytes 32+{- 32 bit+pixelFormatGetRMask = pixelFormatGetBytes 16+pixelFormatGetGMask = pixelFormatGetBytes 20+pixelFormatGetBMask = pixelFormatGetBytes 24+pixelFormatGetAMask = pixelFormatGetBytes 28+-} -pixelFormatGetAMask :: SDL.PixelFormat -> IO Word32-pixelFormatGetAMask format = withForeignPtr format $ \hsc_ptr -> peekByteOff hsc_ptr 28 getPixel32 :: Int -> Int -> SDL.Surface -> IO SDL.Pixel getPixel32 x y s = do@@ -197,7 +293,8 @@ pokeElemOff pixels ((y * SDL.surfaceGetWidth s) + x) pixel loadBackdropImageStretch :: FilePath -> Stretch -> GridLand a Backdrop-loadBackdropImageStretch path stretch = do+loadBackdropImageStretch rawPath stretch = do+ path <- correctPath rawPath base <- liftIO $ Image.load path scr <- RWS.asks screen let (scrW,scrH) = (SDL.surfaceGetWidth scr, SDL.surfaceGetHeight scr)@@ -312,33 +409,58 @@ released :: Key -> Input released = flip Key Released -fromColor32 :: Word32 -> (Word8, Word8, Word8)-fromColor32 c =+fromColorARGB32 :: Word32 -> (Word8, Word8, Word8)+fromColorARGB32 c = (fromIntegral ((shiftR c (2 * 8)) .&. 0xff), fromIntegral ((shiftR c 8) .&. 0xff), fromIntegral (c .&. 0xff)) -fromColor32' :: Word32 -> (Word8, Word8, Word8)-fromColor32' c =+fromColorABGR32 :: Word32 -> (Word8, Word8, Word8)+fromColorABGR32 c = (fromIntegral (c .&. 0xff), fromIntegral ((shiftR c 8) .&. 0xff), fromIntegral ((shiftR c (2 * 8)) .&. 0xff)) +fromColorRGBA32 :: Word32 -> (Word8, Word8, Word8)+fromColorRGBA32 c =+ (fromIntegral ((shiftR c (3 * 8)) .&. 0xff),+ fromIntegral ((shiftR c (2 * 8)) .&. 0xff),+ fromIntegral ((shiftR c 8) .&. 0xff)) -toColor32 :: Word8 -> Word8 -> Word8 -> Word32-toColor32 r g b =+fromColorBGRA32 :: Word32 -> (Word8, Word8, Word8)+fromColorBGRA32 c =+ (fromIntegral ((shiftR c 8) .&. 0xff),+ fromIntegral ((shiftR c (2 * 8)) .&. 0xff),+ fromIntegral ((shiftR c (3 * 8)) .&. 0xff))++toColorABGR32 :: Word8 -> Word8 -> Word8 -> Word32+toColorABGR32 r g b = shiftL 0xff (3 * 8) .|. shiftL (fromIntegral b) (2 * 8) .|. shiftL (fromIntegral g) 8 .|. (fromIntegral r) -toColor32' :: Word8 -> Word8 -> Word8 -> Word32-toColor32' r g b =+toColorARGB32 :: Word8 -> Word8 -> Word8 -> Word32+toColorARGB32 r g b = shiftL 0xff (3 * 8) .|. shiftL (fromIntegral r) (2 * 8) .|. shiftL (fromIntegral g) 8 .|. (fromIntegral b) +toColorBGRA32 :: Word8 -> Word8 -> Word8 -> Word32+toColorBGRA32 r g b =+ shiftL (fromIntegral b) (3 * 8) .|.+ shiftL (fromIntegral g) (2 * 8) .|.+ shiftL (fromIntegral r) 8 .|.+ 0xff++toColorRGBA32 :: Word8 -> Word8 -> Word8 -> Word32+toColorRGBA32 r g b =+ shiftL (fromIntegral r) (3 * 8) .|.+ shiftL (fromIntegral g) (2 * 8) .|.+ shiftL (fromIntegral b) 8 .|.+ 0xff+ colorValue :: Integral a => Color -> (a, a, a) colorValue = \case Red -> (0xcc, 0x00, 0x00)@@ -424,7 +546,8 @@ void $ SDL.blitSurface gfxSurface tileRect scr (Just $ gfxRect ts gfxLocation gfxSurface) loadMusic :: FilePath -> GridLand a Music-loadMusic (path) = do+loadMusic rawPath = do+ path <- correctPath rawPath mus <- liftIO $ Mixer.loadMUS path key <- RWS.gets (Map.size . musics . fst) let music = Music key@@ -462,7 +585,8 @@ unless isPlaying $ RWS.modify . first $ (\s -> s { playingMusic = Nothing } ) loadSfx :: FilePath -> GridLand a Sfx-loadSfx path = do+loadSfx rawPath = do+ path <- correctPath rawPath sfxRef <- liftIO $ Mixer.loadWAV path key <- RWS.gets (Map.size . sfxs . fst) let sfx = Sfx key@@ -482,8 +606,11 @@ -- | Config -> Start -> Update -> End -> IO () runGridLand :: Config -> GridLand () a -> GridLand a () -> GridLand a () -> IO () runGridLand cfg onStart onUpdate onEnd = do+ execPath <- getExecutablePath+ progName <- getProgName+ let pathPrefix = take (length execPath - length progName) execPath foundation@Foundation{..} <- start cfg- let common = newCommon+ let common = newCommon { pathPrefix = pathPrefix } (initUserData, (initCommon,_), _) <- RWS.runRWST (unGridLand onStart) foundation (common, ()) let initState = (initCommon, initUserData) let update = establishPlayingMusic >> onUpdate >> drawBackdrop@@ -535,7 +662,7 @@ return $ \c -> table V.! (fromEnum c) newCommon :: Common-newCommon = Common Map.empty Map.empty Map.empty Map.empty (BkdColor White) Nothing [] (Location 0 0) 0+newCommon = Common Map.empty Map.empty Map.empty Map.empty (BkdColor White) Nothing [] (Location 0 0) 0 "" end :: Foundation -> Common -> IO () end Foundation{..} Common{..} = do
src/GridLand/Data.hs view
@@ -117,7 +117,8 @@ playingMusic :: Maybe Music, inputs :: [Input], mousePosition :: Location,- currSfxChan :: Int+ currSfxChan :: Int,+ pathPrefix :: FilePath } data Todo = Todo {@@ -126,6 +127,14 @@ todoBackSprites :: Map Location Gfx, todoBackdrop :: Backdrop }++-- The SDL bindings lacks the appropriate R/W to deal directly with its PixelFormat struct+data PixelFormat+ = RGBA+ | BGRA+ | ARGB+ | ABGR+ deriving (Show, Eq) newtype GridLand a b = GridLand { unGridLand :: RWST Foundation Todo(Common, a) IO b } deriving