packages feed

gridland (empty) → 0.1.0.1

raw patch · 7 files changed

+946/−0 lines, 7 filesdep +SDLdep +SDL-gfxdep +SDL-imagesetup-changed

Dependencies added: SDL, SDL-gfx, SDL-image, SDL-mixer, array, astar, base, containers, grid, gridland, htiled, mtl, random, safe, tuple, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -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))
+ gridland.cabal view
@@ -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
+ src/GridLand.hs view
@@ -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
+ src/GridLand/Data.hs view
@@ -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)+        }
+ src/GridLand/Import.hs view
@@ -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)