diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Joe Vargas + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,96 @@ +module Main where + +import Control.Monad (unless, when) +import GridLand + +main :: IO () +main = runGridLand cfg start update (return ()) + +cfg :: Config +cfg = Config { cfgRows = 8 * 2, cfgCols = 16 * 2, cfgTileSize = 40 } + +data App = App { + fluffy :: Sprite, + cocoa :: Sprite, + angle :: Angle, -- Degrees + cocoaLocations :: [Location], + fluffyLocations :: [Location], + oops :: Sfx, + laser :: Sfx +} + +start :: GridLand () App +start = do + titleBar "The Adventures of Cocoa & Fluffy" + bkgImg <- loadBackdropImage "data/space.jpg" + backdrop bkgImg + cocoaSprite <- loadSprite "data/cocoa.png" + fluffySprite <- loadSprite "data/lion.png" + music <- loadMusic "data/amen_break.wav" + playMusic music Nothing + oopsSfx <- loadSfx "data/oops.wav" + laserSfx <- loadSfx "data/laser.wav" + return App { + fluffy = fluffySprite, + cocoa = cocoaSprite, + angle = Degrees 0, + cocoaLocations = replicate 20 (Location 0 0), + fluffyLocations = replicate 50 (Location 0 0), + oops = oopsSfx, + laser = laserSfx + } + +update :: GridLand App () +update = do + updateAngle + updateCocoas + updateFluffies + updateSfx + +updateAngle :: GridLand App () +updateAngle = do + app <- getData + let (Degrees d) = angle app + putData app { angle = Degrees (d + 1) } + +updateFluffies :: GridLand App () +updateFluffies = do + app <- getData + inputs <- getInputs + let loc = move (head $ fluffyLocations app) inputs + let locs = if loc == (head $ fluffyLocations app) + then fluffyLocations app + else loc : (init $ fluffyLocations app) + let draw (loc,color) = drawSpriteMiddle (fluffy app) (Tint color) loc (angle app) + mapM_ draw (zip locs $ cycle [minBound .. maxBound]) + putData app { fluffyLocations = locs } + +updateCocoas :: GridLand App () +updateCocoas = do + app <- getData + mpos <- getMousePosition + let locs = if mpos == (head $ cocoaLocations app) -- Update if there's change in mouse position + then cocoaLocations app + else mpos : (init $ cocoaLocations app) + let draw (loc,color) = drawSpriteFront (cocoa app) (Tint color) loc (angle app) + mapM_ draw (zip locs $ cycle [minBound .. maxBound]) + putData app { cocoaLocations = locs } + +move :: Location -> [Input] -> Location +move loc inputs = + if elem (Key UpArrow Pressed) inputs + then Location (locX loc) (locY loc - 1) + else if elem (Key DownArrow Pressed) inputs + then Location (locX loc) (locY loc + 1) + else if elem (Key LeftArrow Pressed) inputs + then Location (locX loc - 1) (locY loc) + else if elem (Key RightArrow Pressed) inputs + then Location (locX loc + 1) (locY loc) + else loc + +updateSfx :: GridLand App () +updateSfx = do + app <- getData + inputs <- getInputs + when (elem (Key (Char 'a') Pressed) inputs) (playSfx (oops app)) + when (elem (Key (Char 'f') Pressed) inputs) (playSfx (laser app)) diff --git a/gridland.cabal b/gridland.cabal new file mode 100644 --- /dev/null +++ b/gridland.cabal @@ -0,0 +1,67 @@ +name: gridland +version: 0.1.0.1 +synopsis: Grid-based multimedia engine +description: Learn Haskell by drawing sprites and playing music and sound effects. +license: MIT +license-file: LICENSE +author: Joe Vargas +maintainer: https://github.com/jxv +-- copyright: +category: Game +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/jxv/gridland + +flag demo + description: build demo + default: False + +library + exposed-modules: + GridLand + other-modules: + GridLand.Import + GridLand.Data + -- other-extensions: + default-extensions: + RecordWildCards + LambdaCase + GeneralizedNewtypeDeriving + FlexibleContexts + MultiWayIf + build-depends: + base ==4.*, + SDL, + SDL-image, + SDL-mixer, + -- SDL-ttf, + SDL-gfx, + astar, + containers, + tuple, + random, + grid, + htiled, + vector, + mtl, + array, + safe + hs-source-dirs: src + default-language: Haskell2010 + +executable demo + main-is: Main.hs + default-extensions: + RecordWildCards + if flag(demo) + build-depends: + base, gridland + buildable: True + else + buildable: False + hs-source-dirs: demo + default-language: Haskell2010 diff --git a/src/GridLand.hs b/src/GridLand.hs new file mode 100644 --- /dev/null +++ b/src/GridLand.hs @@ -0,0 +1,574 @@ +module GridLand + ( Config(..) + , Color(..) + , Stretch(..) + , ColorFilter(..) + , Angle(..) + , Backdrop(..) + , Input(..) + , Key(..) + , KeyState(..) + , Location(..) + , ToSprite(..) + , BackdropImage + , Sprite + , Sfx + , Music + , GridLand + , titleBar + , loadSprite + , loadSpriteStretch + , loadBackdropImage + , loadBackdropImageStretch + , drawSpriteFront + , drawSpriteMiddle + , drawSpriteBack + , loadMusic + , playMusic + , stopMusic + , stopAllMusic + , loadSfx + , playSfx + , print' + , putStrLn' + , runGridLand + , backdrop + , getData + , putData + , modifyData + , getPlayingMusic + , io + , getInputs + , getMousePosition + ) where + +-- base +import Debug.Trace +import Data.IORef +import Data.Char +import Data.Maybe +import Control.Arrow +-- SDL +import qualified Graphics.UI.SDL as SDL +import qualified Graphics.UI.SDL.Video as SDL +-- SDL-image +import qualified Graphics.UI.SDL.Image as Image +-- SDL-ttf (unused) +-- import qualified Graphics.UI.SDL.TTF as TTF +-- SDL-mixer +import qualified Graphics.UI.SDL.Mixer as Mixer +-- SDL-gfx +import qualified Graphics.UI.SDL.Framerate as Gfx +import qualified Graphics.UI.SDL.Primitives as Gfx +import qualified Graphics.UI.SDL.Rotozoomer as Gfx +-- containers +import qualified Data.Map as Map +import qualified Data.Set as Set +-- grid +import qualified Math.Geometry.Grid as Grid +-- vector +import qualified Data.Vector as V +-- mtl +import qualified Control.Monad.State as State +import qualified Control.Monad.RWS as RWS +-- array +import qualified Data.Array as Array +-- safe +import qualified Safe as Safe + +import GridLand.Import +import GridLand.Data + +newTodo :: Todo +newTodo = Todo Map.empty Map.empty Map.empty (BkdColor White) + +getData :: GridLand a a +getData = RWS.gets snd + +putData :: a -> GridLand a () +putData a = RWS.modify . second $ const a + +modifyData :: (a -> a) -> GridLand a () +modifyData f = RWS.modify . second $ f + +spriteDegrees :: [Int] +spriteDegrees = [ rot * 360 `div` rotations | rot <- [0 .. (rotations - 1)]] + +spriteOpts :: [(ColorFilter, Int)] +spriteOpts = noFilters ++ filters + where + noFilters = [(NoFilter, theta) | theta <- spriteDegrees] + filters = [(cf c, theta) | cf <- [Tint, Replace], c <- [minBound..maxBound], theta <- spriteDegrees] + +setColorKey :: (Word8, Word8, Word8) -> SDL.Surface -> IO SDL.Surface +setColorKey (r, g, b) sur = mapRGB sur r g b >>= SDL.setColorKey sur [SDL.SrcColorKey] >> return sur + +mapRGB :: SDL.Surface -> Word8 -> Word8 -> Word8 -> IO SDL.Pixel +mapRGB = SDL.mapRGB . SDL.surfaceGetPixelFormat + +colorToPixel :: Color -> SDL.Pixel +colorToPixel color = let + (r',g,b') = colorValue color + (r,b) = (b',r') + v = shiftL 0xff (8 * 3) .|. shiftL (fromIntegral b) (8 * 2) .|. shiftL (fromIntegral g) (8 * 1) .|. (fromIntegral r) + in SDL.Pixel v + +loadSpriteStretch :: FilePath -> Stretch -> GridLand a Sprite +loadSpriteStretch path stretch = do + 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 + liftIO $ SDL.freeSurface base + let spriteFrames = V.fromListN totalFrames frames + key <- RWS.gets (Map.size . sprites . fst) + let spr = Sprite key + RWS.modify . first $ \s -> s { sprites = Map.insert spr spriteFrames (sprites s) } + return spr + +loadSprite :: FilePath -> GridLand a Sprite +loadSprite path = loadSpriteStretch path Pixelated + +copySurface :: SDL.Surface -> IO SDL.Surface +copySurface sur = do + copy <- copyFromSurface sur + SDL.blitSurface sur Nothing copy Nothing + return copy + +copyFromSurface :: SDL.Surface -> IO SDL.Surface +copyFromSurface sur = do + let fmt = SDL.surfaceGetPixelFormat sur + bpp <- fromIntegral `liftM` SDL.pixelFormatGetBitsPerPixel fmt + rMask <- pixelFormatGetRMask fmt + gMask <- pixelFormatGetGMask fmt + bMask <- pixelFormatGetBMask fmt + flags <- SDL.surfaceGetFlags sur + 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 + +pixelFormatGetGMask :: SDL.PixelFormat -> IO Word32 +pixelFormatGetGMask format = withForeignPtr format $ \hsc_ptr -> peekByteOff hsc_ptr 20 + +pixelFormatGetBMask :: SDL.PixelFormat -> IO Word32 +pixelFormatGetBMask format = withForeignPtr format $ \hsc_ptr -> peekByteOff hsc_ptr 24 + +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 + pixels <- castPtr `liftM` SDL.surfaceGetPixels s + SDL.Pixel `liftM` peekElemOff pixels ((y * SDL.surfaceGetWidth s) + x) + +putPixel32 :: Int -> Int -> SDL.Pixel -> SDL.Surface -> IO () +putPixel32 x y (SDL.Pixel pixel) s = do + pixels <- castPtr `liftM` SDL.surfaceGetPixels s + pokeElemOff pixels ((y * SDL.surfaceGetWidth s) + x) pixel + +loadBackdropImageStretch :: FilePath -> Stretch -> GridLand a Backdrop +loadBackdropImageStretch path stretch = do + base <- liftIO $ Image.load path + scr <- RWS.asks screen + let (scrW,scrH) = (SDL.surfaceGetWidth scr, SDL.surfaceGetHeight scr) + let (w,h) = (SDL.surfaceGetWidth base, SDL.surfaceGetHeight base) + let (zoomW, zoomH) = (fromIntegral scrW / fromIntegral w, fromIntegral scrH / fromIntegral h) + zoomed <- liftIO $ Gfx.zoom base zoomW zoomH (stretch == Smooth) + key <- RWS.gets (Map.size . bkdImages . fst) + let bi = BackdropImage key + RWS.modify . first $ \s -> s { bkdImages = Map.insert bi zoomed (bkdImages s) } + liftIO $ SDL.freeSurface base + return (BkdImage bi) + +loadBackdropImage :: FilePath -> GridLand a Backdrop +loadBackdropImage path = loadBackdropImageStretch path Smooth + +pollEvents :: IO [SDL.Event] +pollEvents = do + event <- SDL.pollEvent + if event == SDL.NoEvent + then return [] + else (:) <$> return event <*> pollEvents + +toMousePosition :: Foundation -> (Word16, Word16) -> Location +toMousePosition Foundation{..} (x,y) = Location { + locX = fromIntegral x `div` tileSize, + locY = fromIntegral y `div` tileSize + } + +pollInputs :: Foundation -> IO ([Input], Maybe Location) +pollInputs foundation = do + events <- pollEvents + return (foldr cvt [] events, mousePos events) + where + mousePos = Safe.headMay . catMaybes . map mpos + mpos (SDL.MouseMotion x y _ _) = let + pos = toMousePosition foundation (x,y) + in if inRange foundation pos + then Just pos + else Nothing + mpos _ = Nothing + -- Quit + cvt SDL.Quit inputs = Quit : inputs + cvt (SDL.KeyDown (SDL.Keysym keysym _ ch)) inputs = case keysym of + SDL.SDLK_ESCAPE -> Quit : inputs + -- Key (pressed) + SDL.SDLK_UP -> pressed UpArrow : inputs + SDL.SDLK_DOWN -> pressed DownArrow : inputs + SDL.SDLK_LEFT -> pressed LeftArrow : inputs + SDL.SDLK_RIGHT -> pressed RightArrow : inputs + SDL.SDLK_RETURN -> pressed Enter : inputs + SDL.SDLK_LSHIFT -> pressed Shift : inputs + SDL.SDLK_RSHIFT -> pressed Shift : inputs + SDL.SDLK_LCTRL -> pressed Ctrl : inputs + SDL.SDLK_RCTRL -> pressed Ctrl : inputs + SDL.SDLK_LALT -> pressed AltKey : inputs + SDL.SDLK_RALT -> pressed AltKey : inputs + SDL.SDLK_TAB-> pressed Tab : inputs + SDL.SDLK_BACKSPACE -> pressed Backspace : inputs + SDL.SDLK_LSUPER -> pressed Meta : inputs + SDL.SDLK_RSUPER -> pressed Meta : inputs + key -> + if (key >= SDL.SDLK_SPACE && key <= SDL.SDLK_z) + then pressed (Char $ toLower ch) : inputs + else inputs -- ignore + -- Key (released) + cvt (SDL.KeyUp (SDL.Keysym keysym _ ch)) inputs = case keysym of + SDL.SDLK_UP -> released UpArrow : inputs + SDL.SDLK_DOWN -> released DownArrow : inputs + SDL.SDLK_LEFT -> released LeftArrow : inputs + SDL.SDLK_RIGHT -> released RightArrow : inputs + SDL.SDLK_RETURN -> released Enter : inputs + SDL.SDLK_LSHIFT -> released Shift : inputs + SDL.SDLK_RSHIFT -> released Shift : inputs + SDL.SDLK_LCTRL -> released Ctrl : inputs + SDL.SDLK_RCTRL -> released Ctrl : inputs + SDL.SDLK_LALT -> released AltKey : inputs + SDL.SDLK_RALT -> released AltKey : inputs + SDL.SDLK_TAB-> released Tab : inputs + SDL.SDLK_BACKSPACE -> released Backspace : inputs + SDL.SDLK_LSUPER -> released Meta : inputs + SDL.SDLK_RSUPER -> released Meta : inputs + key -> + if (key >= SDL.SDLK_SPACE && key <= SDL.SDLK_z) + then released (Char $ toLower ch) : inputs + else inputs -- ignore + -- Click + cvt (SDL.MouseButtonDown x y SDL.ButtonLeft) inputs = Click Location{ locX = fromIntegral x, locY = fromIntegral y } : inputs + -- Ignore the rest + cvt _ inputs = inputs + +mergeInputs :: [Input] -> [Input] -> [Input] +mergeInputs old new = new + +stepInputs :: [Input] -> [Input] +stepInputs = foldr step [] + where + held key = Key key Held + step inp inps = case inp of + Key key Pressed -> held key : inps + Key key Released -> inps + _ -> inp : inps + +getInputs :: GridLand a [Input] +getInputs = State.gets (inputs . fst) + +getMousePosition :: GridLand a Location +getMousePosition = State.gets (mousePosition . fst) + +pressed :: Key -> Input +pressed = flip Key Pressed + +released :: Key -> Input +released = flip Key Released + +fromColor32 :: Word32 -> (Word8, Word8, Word8) +fromColor32 c = + (fromIntegral ((shiftR c (2 * 8)) .&. 0xff), + fromIntegral ((shiftR c 8) .&. 0xff), + fromIntegral (c .&. 0xff)) + +fromColor32' :: Word32 -> (Word8, Word8, Word8) +fromColor32' c = + (fromIntegral (c .&. 0xff), + fromIntegral ((shiftR c 8) .&. 0xff), + fromIntegral ((shiftR c (2 * 8)) .&. 0xff)) + + +toColor32 :: Word8 -> Word8 -> Word8 -> Word32 +toColor32 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 = + shiftL 0xff (3 * 8) .|. + shiftL (fromIntegral r) (2 * 8) .|. + shiftL (fromIntegral g) 8 .|. + (fromIntegral b) + +colorValue :: Integral a => Color -> (a, a, a) +colorValue = \case + Red -> (0xcc, 0x00, 0x00) + Orange -> (0xff, 0xa5, 0x00) + Yellow -> (0xff, 0xff, 0x00) + YellowGreen -> (0x7f, 0xff, 0x00) + Green -> (0x00, 0x66, 0x00) + LightBlue -> (0x66, 0xff, 0xff) + Blue -> (0x00, 0x00, 0x99) + Pink -> (0xff, 0x66, 0x99) + Black -> (0x00, 0x00, 0x00) + White -> (0xff, 0xff, 0xff) + +colorValue' :: Integral a => Color -> (a -> a -> a -> b) -> b +colorValue' c f = uncurryN f (colorValue c) + +rotations, colors, withoutColors, withColors, totalFrames, colorAngleInterval:: Int +rotations = 36 +colors = 1 + fromEnum (maxBound :: Color) +withColors = 2 +withoutColors = 1 +totalFrames = (withoutColors + withColors * colors) * rotations +colorAngleInterval = colors * rotations + +colorAngleOffset :: Color -> Angle -> Int +colorAngleOffset c t = colorOffset c + angleOffset t + +angleOffset :: Angle -> Int +angleOffset (Radians r) = angleOffset $ Degrees (round $ 180 * r / pi) +angleOffset (Degrees d) = ((d `mod` 360) * rotations `div` 360) + +colorOffset :: Color -> Int +colorOffset c = fromEnum c * rotations + +frameOffset :: ColorFilter -> Angle -> Int +frameOffset NoFilter theta = angleOffset theta +frameOffset (Tint c) theta = rotations + colorAngleOffset c theta +frameOffset (Replace c) theta = rotations + colorAngleInterval + colorAngleOffset c theta + +spriteGfx :: Sprite -> ColorFilter -> Location -> Angle -> GridLand a Gfx +spriteGfx spr cf loc theta = do + let offset = frameOffset cf theta + sprMap <- RWS.gets (sprites . fst) + let sur = (sprMap Map.! spr) V.! offset + return $ Gfx sur loc + +gfxRect :: Int -> Location -> SDL.Surface -> SDL.Rect +gfxRect ts Location{..} sur = let + (w, h) = (SDL.surfaceGetWidth sur, SDL.surfaceGetHeight sur) + in SDL.Rect (ts * locX) (ts * locY) ts ts + +drawSpriteMapFront :: ToSprite s => Map Location s -> GridLand a () +drawSpriteMapFront sprMap = do + return () + +drawSpriteFront :: ToSprite s => s -> ColorFilter -> Location -> Angle -> GridLand a () +drawSpriteFront a cf loc theta = do + gfx <- spriteGfx (toSprite a) cf loc theta + RWS.tell $ mempty { todoFrontSprites = Map.singleton loc gfx } + +drawSpriteMiddle :: ToSprite s => s -> ColorFilter -> Location -> Angle -> GridLand a () +drawSpriteMiddle a cf loc theta = do + gfx <- spriteGfx (toSprite a) cf loc theta + RWS.tell $ mempty { todoMiddleSprites = Map.singleton loc gfx } + +drawSpriteBack :: ToSprite s => s -> ColorFilter -> Location -> Angle -> GridLand a () +drawSpriteBack a cf loc theta = do + gfx <- spriteGfx (toSprite a) cf loc theta + RWS.tell $ mempty { todoBackSprites = Map.singleton loc gfx } + +drawSprite :: ToSprite s => s -> ColorFilter -> Location -> Angle -> GridLand a () +drawSprite a cf loc theta = do + (s, ts) <- RWS.asks (screen &&& tileSize) + Gfx{..} <- spriteGfx (toSprite a) cf loc theta + let (w, h) = (SDL.surfaceGetWidth gfxSurface, SDL.surfaceGetHeight gfxSurface) + let tileRect = Just $ SDL.Rect ((w - ts) `div` 2) ((h - ts) `div` 2) ts ts + void . liftIO $ SDL.blitSurface gfxSurface tileRect s (Just $ gfxRect ts gfxLocation gfxSurface) + +drawGfx :: SDL.Surface -> Int -> Gfx -> IO () +drawGfx scr ts Gfx{..} = do + let (w, h) = (SDL.surfaceGetWidth gfxSurface, SDL.surfaceGetHeight gfxSurface) + let tileRect = Just $ SDL.Rect ((w - ts) `div` 2) ((h - ts) `div` 2) ts ts + void $ SDL.blitSurface gfxSurface tileRect scr (Just $ gfxRect ts gfxLocation gfxSurface) + +loadMusic :: FilePath -> GridLand a Music +loadMusic (path) = do + mus <- liftIO $ Mixer.loadMUS path + key <- RWS.gets (Map.size . musics . fst) + let music = Music key + RWS.modify . first $ \s -> s { musics = Map.insert music mus (musics s) } + return music + +playMusic :: Music -> Maybe Int -> GridLand a () +playMusic music mloops = do + mus <- RWS.gets ((Map.! music) . musics . fst) + let loops = maybe (-1) (\n -> if n < -1 then 0 else n) mloops + liftIO $ Mixer.playMusic mus loops + RWS.modify . first $ (\s -> s { playingMusic = Just music } ) + +stopMusic :: Music -> GridLand a () +stopMusic music = do + mplaying <- RWS.gets (playingMusic . fst) + case mplaying of + Nothing -> return () + Just currMusic -> do + when (music == currMusic) $ do + liftIO Mixer.haltMusic + RWS.modify . first $ (\s -> s { playingMusic = Nothing } ) + +stopAllMusic :: GridLand a () +stopAllMusic = do + liftIO Mixer.haltMusic + RWS.modify . first $ (\s -> s { playingMusic = Nothing } ) + +getPlayingMusic :: GridLand a (Maybe Music) +getPlayingMusic = RWS.gets (playingMusic . fst) + +establishPlayingMusic :: GridLand a () +establishPlayingMusic = do + isPlaying <- liftIO Mixer.playingMusic + unless isPlaying $ RWS.modify . first $ (\s -> s { playingMusic = Nothing } ) + +loadSfx :: FilePath -> GridLand a Sfx +loadSfx path = do + sfxRef <- liftIO $ Mixer.loadWAV path + key <- RWS.gets (Map.size . sfxs . fst) + let sfx = Sfx key + RWS.modify . first $ \s -> s { sfxs = Map.insert sfx sfxRef (sfxs s) } + return sfx + +playSfx :: Sfx -> GridLand a () +playSfx sfx = do + chunk <- RWS.gets ((Map.! sfx) . sfxs . fst) + chan <- RWS.gets (currSfxChan . fst) + void . liftIO $ Mixer.playChannel chan chunk 0 + RWS.modify . first $ \s -> s { currSfxChan = mod (chan + 1) sfxChannels } + +sfxChannels :: Int +sfxChannels = 16 + +-- | Config -> Start -> Update -> End -> IO () +runGridLand :: Config -> GridLand () a -> GridLand a () -> GridLand a () -> IO () +runGridLand cfg onStart onUpdate onEnd = do + foundation@Foundation{..} <- start cfg + let common = newCommon + (initUserData, (initCommon,_), _) <- RWS.runRWST (unGridLand onStart) foundation (common, ()) + let initState = (initCommon, initUserData) + let update = establishPlayingMusic >> onUpdate >> drawBackdrop + let dgfx = drawGfx screen tileSize + endState <- ($ initState) $ fix $ \loop state -> do + startTick <- SDL.getTicks + let inps = (inputs . fst) state + let pos = (mousePosition . fst) state + (inps', mpos) <- first (mergeInputs (stepInputs inps)) <$> pollInputs foundation + let state' = first (\s -> s { + inputs = inps', + mousePosition = fromMaybe (mousePosition s) mpos + }) state + (continue, state'', todo) <- RWS.runRWST (unGridLand update) foundation state' + let ranger loc _ = inRange foundation loc + mapM_ dgfx (Map.elems . Map.filterWithKey ranger $ todoBackSprites todo) + mapM_ dgfx (Map.elems . Map.filterWithKey ranger $ todoMiddleSprites todo) + mapM_ dgfx (Map.elems . Map.filterWithKey ranger $ todoFrontSprites todo) + liftIO $ SDL.flip screen + endTick <- SDL.getTicks + let diff = endTick - startTick + when (diff < 16) (SDL.delay $ 16 - diff) + if elem Quit inps' + then return state'' + else loop state'' + void $ RWS.execRWST (unGridLand onEnd) foundation endState + end foundation common + +inRange :: Foundation -> Location -> Bool +inRange Foundation{..} Location{..} = locX >= 0 && locY >= 0 && locX < cols && locY < rows + +start :: Config -> IO Foundation +start Config{..} = do + SDL.init [SDL.InitEverything] + screen <- SDL.setVideoMode (cfgCols * cfgTileSize) (cfgRows * cfgTileSize) 32 [SDL.SWSurface] + SDL.setCaption "Grid Land" "" + SDL.enableUnicode True + colorMap <- getColorMap screen + -- ttfOk <- TTF.init + Mixer.openAudio 22050 Mixer.AudioS16Sys 2 4096 + Mixer.allocateChannels sfxChannels + return $ Foundation screen colorMap cfgRows cfgCols cfgTileSize + +getColorMap :: SDL.Surface -> IO (Color -> SDL.Pixel) +getColorMap s = do + let fmt = SDL.surfaceGetPixelFormat s + pixels <- forM [minBound..maxBound] $ \c -> liftIO $ colorValue' c (SDL.mapRGB fmt) + let table = V.fromList pixels + 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 + +end :: Foundation -> Common -> IO () +end Foundation{..} Common{..} = do + mapM_ SDL.freeSurface (Map.elems bkdImages) + mapM_ (mapM_ SDL.freeSurface . V.toList) (Map.elems sprites) + mapM_ Mixer.freeMusic (Map.elems musics) + mapM_ (const $ return ()) (Map.elems sfxs) -- Mixer.freeChunks is missing its binding + SDL.freeSurface screen + Mixer.closeAudio + -- TTF.quit + SDL.quit + +putStrLn' :: String -> GridLand a () +putStrLn' = liftIO . putStrLn + +print' :: Show b => b -> GridLand a () +print' = liftIO . print + +titleBar :: String -> GridLand a () +titleBar title = liftIO $ SDL.setCaption title "" + +backdrop :: Backdrop -> GridLand a () +backdrop b = RWS.modify . first $ \s -> s { currBkd = b } + +drawBackdrop :: GridLand a () +drawBackdrop = do + (s, cmap) <- RWS.asks (screen &&& colorMap) + b <- RWS.gets (currBkd . fst) + case b of + BkdColor c -> void . liftIO $ SDL.fillRect s Nothing (cmap c) + BkdImage bi -> do + img <- RWS.gets ((Map.! bi) . bkdImages . fst) + void . liftIO $ SDL.blitSurface img Nothing s Nothing + +io :: IO b -> GridLand a b +io = liftIO diff --git a/src/GridLand/Data.hs b/src/GridLand/Data.hs new file mode 100644 --- /dev/null +++ b/src/GridLand/Data.hs @@ -0,0 +1,155 @@ +module GridLand.Data where + +import GridLand.Import +-- SDL +import qualified Graphics.UI.SDL as SDL +import qualified Graphics.UI.SDL.Video as SDL +-- SDL-image +import qualified Graphics.UI.SDL.Image as Image +-- SDL-ttf (unused) +--import qualified Graphics.UI.SDL.TTF as TTF +-- SDL-mixer +import qualified Graphics.UI.SDL.Mixer as Mixer + +data Config = Config { + cfgRows :: Int, + cfgCols :: Int, + cfgTileSize :: Int +} + +data Foundation = Foundation { + screen :: SDL.Surface, + colorMap :: Color -> SDL.Pixel, + rows :: Int, + cols :: Int, + tileSize :: Int +} + +data Backdrop + = BkdColor Color + | BkdImage BackdropImage + +newtype BackdropImage = BackdropImage { bkdImageKey :: Int } + deriving (Eq, Num, Ord, Show) + +data Color + = Red + | Orange + | Yellow + | YellowGreen + | Green + | LightBlue + | Blue + | Pink + | Black + | White + deriving (Enum, Eq, Bounded, Show) + +data Input + = Quit + | Key Key KeyState + | Click Location + deriving (Eq, Show) + +data Key + = Char Char + | UpArrow + | DownArrow + | LeftArrow + | RightArrow + | Enter + | Shift + | Ctrl + | AltKey + | Tab + | Backspace + | Meta + deriving (Eq, Show) + +data KeyState + = Pressed + | Held + | Released + deriving (Enum, Eq, Bounded, Show) + +-- (1 + Tinted-N-Replace * Colors) * Rotations +newtype Sprite = Sprite { spriteKey :: Int } + deriving (Eq, Num, Ord, Show) + +data ColorFilter + = NoFilter + | Tint Color + | Replace Color + deriving (Eq, Show) + +data Stretch + = Smooth + | Pixelated + deriving (Eq, Enum, Bounded, Show) + +data Angle + = Radians Float + | Degrees Int + deriving (Eq, Show) + +data Location = Location { + locX :: Int, + locY :: Int +} deriving (Show, Eq) + +data Gfx = Gfx { + gfxSurface :: SDL.Surface, + gfxLocation :: Location +} + +newtype Sfx = Sfx { sfxKey :: Int } + deriving (Eq, Num, Ord, Show) + +newtype Music = Music { musicKey :: Int } + deriving (Eq, Num, Ord, Show) + +data Common = Common { + bkdImages :: Map BackdropImage SDL.Surface, + sprites :: Map Sprite (Vector SDL.Surface), + sfxs :: Map Sfx Mixer.Chunk, + musics :: Map Music Mixer.Music, + currBkd :: Backdrop, + playingMusic :: Maybe Music, + inputs :: [Input], + mousePosition :: Location, + currSfxChan :: Int +} + +data Todo = Todo { + todoFrontSprites :: Map Location Gfx, + todoMiddleSprites :: Map Location Gfx, + todoBackSprites :: Map Location Gfx, + todoBackdrop :: Backdrop +} + +newtype GridLand a b = GridLand { unGridLand :: RWST Foundation Todo(Common, a) IO b } + deriving + (Functor, Applicative, Monad, MonadIO, MonadRWS Foundation Todo (Common, a) + ,MonadReader Foundation, MonadWriter Todo, MonadState (Common, a)) + +class ToSprite a where + toSprite :: a -> Sprite + +instance Ord Location where + compare loc0 loc1 = compare (locX loc0, locY loc0) (locX loc1, locY loc1) + +instance ToSprite Sprite where + toSprite = id + +instance Monoid Backdrop where + mempty = BkdColor White + mappend _ a = a + +instance Monoid Todo where + mempty = Todo mempty mempty mempty mempty + mappend a b = Todo { + todoFrontSprites = mappend (todoFrontSprites a) (todoFrontSprites b), + todoMiddleSprites = mappend (todoMiddleSprites a) (todoMiddleSprites b), + todoBackSprites = mappend (todoBackSprites a) (todoBackSprites b), + todoBackdrop = mappend (todoBackdrop a) (todoBackdrop b) + } diff --git a/src/GridLand/Import.hs b/src/GridLand/Import.hs new file mode 100644 --- /dev/null +++ b/src/GridLand/Import.hs @@ -0,0 +1,32 @@ +module GridLand.Import (module X) where + +-- base +import System.Exit as X +import Data.Functor as X +import Control.Monad as X +import Control.Monad.Trans as X +import Control.Monad.Fix as X +import Data.Monoid as X +import Control.Applicative as X +import Control.Arrow as X +import Foreign as X hiding (void) +import Data.Char as X +import Data.Word as X +import Data.Maybe as X +-- containers +import Data.Map as X (Map) +import Data.Set as X (Set) +-- random +import System.Random as X +-- tuple +import Data.Tuple.Curry as X +-- htiled +import Data.Tiled as X +-- astar +import Data.Graph.AStar as X +-- mtl +import Control.Monad.RWS as X (RWS, RWST, MonadState, MonadReader, MonadWriter, MonadRWS) +-- vector +import Data.Vector as X (Vector) +-- import Data.List +import Data.Array as X (Array)