packages feed

TeaHS (empty) → 0.3

raw patch · 22 files changed

+1428/−0 lines, 22 filesdep +SDLdep +SDL-imagedep +SDL-mixersetup-changed

Dependencies added: SDL, SDL-image, SDL-mixer, SFont, Sprig, array, base, containers, mtl

Files

+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2010, Liam O'Connor-Davis+All rights reserved.++Redistribution and use in source and binary forms,+with or without modification, are permitted provided+that the following conditions are met:++    * Redistributions of source code must retain+      the above copyright notice, this list of+      conditions and the following disclaimer.+    * Redistributions in binary form must reproduce+      the above copyright notice, this list of+      conditions and the following disclaimer in the+      documentation and/or other materials provided+      with the distribution.+    * Neither the name of Liam O'Connor-Davis nor the+      names of other contributors may be used to+      endorse or promote products derived from this+      software without specific prior written permission.+++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY+OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell+> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain
+ Tea.hs view
@@ -0,0 +1,41 @@+-- | Tea is a library that makes it easier to make games in Haskell.+-- See http://liamoc.github.com/tea-hs for more information.+module Tea+   ( module Tea.Tea+   , module Tea.Display+   , module Tea.Color+   , module Tea.BlendMode+   , module Tea.Input+   , module Tea.Font+   , module Tea.Sound+   , module Tea.Event+   , module Tea.Bitmap+   , module Tea.Screen+   , module Tea.Size+   , module Tea.Primitive+   , module Tea.Blitting+   , module Tea.Clipping+   , module Tea.Grabbing+   , module Tea.ImageSaving+   ) where++-- common types+import Tea.Tea (Tea)+import Tea.Display+import Tea.Color+import Tea.BlendMode hiding (blendModeToSPG)+import Tea.Input     hiding (sdlKey, sdlButton, sdlMod)+import Tea.Font      hiding (getSFont, Font(Font))+import Tea.Sound+import Tea.Event+-- graphics object mixins+import Tea.Size+import Tea.Primitive+import Tea.Blitting+import Tea.Clipping+import Tea.Grabbing+import Tea.ImageSaving+import Tea.TextDrawing+-- mixin inheritors+import Tea.Bitmap hiding (buffer)+import Tea.Screen hiding (screenBuffer)
+ Tea/Bitmap.hs view
@@ -0,0 +1,42 @@+-- | Includes the Bitmap abstract type and its constructors.+module Tea.Bitmap ( Bitmap (..)+               -- * Bitmap Constructors+                  , loadBitmap+                  , blankBitmap+                  ) where+import qualified Graphics.UI.SDL as SDL+import Graphics.UI.SDL.Image (load)+import Control.Monad.Trans+import Tea.Tea+import Tea.Color++_blank :: Int -> Int -> Color -> IO SDL.Surface+_blank w h (Color r g b a)  = do buf <- SDL.createRGBSurface [SDL.SWSurface] w h 32 rmask gmask bmask amask+                                 SDL.fillRect buf (Just (SDL.Rect 0 0 w h)) =<< SDL.mapRGBA (SDL.surfaceGetPixelFormat buf) (fromIntegral r) (fromIntegral g) (fromIntegral b) (fromIntegral a)+                                 return buf+  where rmask = 0xff000000+        gmask = 0x00ff0000+        bmask = 0x0000ff00+        amask = 0x000000ff++-- |A Bitmap is a non-screen surface that can do everything the Screen can, except+--  cannot be drawn directly to hardware.+data Bitmap = Bitmap { buffer :: SDL.Surface }++-- |Load a bitmap from an image file. Can be TGA, BMP, PNM, XPM, XCF, PCX, GIF,+--  JPG, TIF, LBM or PNG.+loadBitmap :: String -> Tea s Bitmap+loadBitmap s = liftIO $ do+              buf  <- load s+              buf' <- SDL.displayFormatAlpha buf+              return Bitmap { buffer = buf' }++-- |Create a new bitmap consisting entirely of a single color+blankBitmap :: Int -- ^ Width+            -> Int -- ^ Height+            -> Color -- ^ Color to fill+            -> Tea s Bitmap+blankBitmap w h c = liftIO $ do+              buf <- _blank w h c+              buf' <- SDL.displayFormatAlpha buf+              return (Bitmap buf')
+ Tea/BlendMode.hs view
@@ -0,0 +1,30 @@+-- |Includes the BlendMode type and internal functions for dealing with Sprig.+module Tea.BlendMode ( BlendMode (..)+                     , blendModeToSPG+                     ) where++import qualified Graphics.UI.SDL.Sprig as SPG+-- |A type to determine how to draw primitives and blit bitmaps, with regards to+--  color and alpha blending.+data BlendMode = DestAlpha+               | SrcAlpha+               | CombineAlpha+               | CopyNoAlpha+               | CopySrcAlpha+               | CopyDestAlpha+               | CopyCombineAlpha+               | CopyAlphaOnly+               | CombineAlphaOnly+               deriving (Show,Eq)++-- |Internal function to convert a Tea BlendMode to a Sprig equivalent. Can only+--  be accessed by directly importing this module.+blendModeToSPG  DestAlpha         = SPG.DestAlpha+blendModeToSPG  SrcAlpha          = SPG.SrcAlpha+blendModeToSPG  CombineAlpha      = SPG.CombineAlpha+blendModeToSPG  CopyNoAlpha       = SPG.CopyNoAlpha+blendModeToSPG  CopySrcAlpha      = SPG.CopySrcAlpha+blendModeToSPG  CopyDestAlpha     = SPG.CopyDestAlpha+blendModeToSPG  CopyCombineAlpha  = SPG.CopyCombineAlpha+blendModeToSPG  CopyAlphaOnly     = SPG.CopyAlphaOnly+blendModeToSPG  CombineAlphaOnly  = SPG.CombineAlphaOnly
+ Tea/Blitting.hs view
@@ -0,0 +1,70 @@+-- | Includes the Blitting class for blittable objects, its instances, and+--   monadic convenience functions.+module Tea.Blitting ( Blitting (blit, blitBlend)+                    , blitBlendM+                    , blitBlendM2+                    , blitM+                    , blitM2+                    ) where++import qualified Graphics.UI.SDL.Sprig as SPG+import qualified Graphics.UI.SDL as SDL+import Control.Monad.Trans+import Tea.Screen+import Tea.Bitmap+import Tea.Tea+import Tea.BlendMode++-- |A class that is instantiated on all types that support blitting operations.+class Blitting v where+   -- |Same as blit, except includes a BlendMode to govern blending method.+   blitBlend :: Blitting s => v -> s -> BlendMode -> (Int, Int) -> Tea z Bool+   blitBlend d s b (x, y) = do+                      liftIO $ SPG.pushBlend $ blendModeToSPG b+                      ret <- blit d s (x,y)+                      liftIO SPG.popBlend+                      return ret+   -- |Blit one Blitting type onto another.+   blit :: Blitting s => v -- ^ Destination buffer+                      -> s -- ^ Source buffer+                      -> (Int, Int) -- ^ Coordinates to blit to+                      -> Tea z Bool+   blit d s (x, y) = liftIO $ SPG.blit src src_rect dst dst_rect+                where src_rect = Just $ SDL.Rect 0 0 src_w src_h+                      dst_rect = Just $ SDL.Rect x y src_w src_h+                      src_w    = SDL.surfaceGetWidth  src+                      src_h    = SDL.surfaceGetHeight src+                      src      = blitting_buffer s+                      dst      = blitting_buffer d+   blitting_buffer :: v -> SDL.Surface++-- |A convenience function for blitBlend that takes a Tea action rather than a+--  Blitting type for the destination.+blitBlendM+  :: (Blitting a, Blitting s) =>+     Tea z a -> s -> BlendMode -> (Int, Int) -> Tea z Bool+blitBlendM  d s a b = d >>= \d' -> blitBlend d' s a b+-- |A convenience function for blitBlend that takes a Tea action rather than a+--  Blitting type for the source and destination+blitBlendM2+  :: (Blitting a, Blitting s) =>+     Tea z a -> Tea z s -> BlendMode -> (Int, Int) -> Tea z Bool+blitBlendM2 d s a b = d >>= \d' -> s >>= \s' -> blitBlend d' s' a b+-- |A convenience function for blit that takes a Tea action rather than a+--  Blitting type for the destination+blitM+  :: (Blitting a, Blitting s) =>+     Tea z a -> s -> (Int, Int) -> Tea z Bool+blitM d s x = d >>= \d' -> blit d' s x+-- |A convenience function for blit that takes a Tea action rather than a+--  Blitting type for the source and destination+blitM2+  :: (Blitting a, Blitting s) =>+     Tea z a -> Tea z s -> (Int, Int) -> Tea z Bool+blitM2 d s x = d >>= \d' -> s >>= flip (blit d') x++instance Blitting Bitmap where+   blitting_buffer = buffer++instance Blitting Screen where+   blitting_buffer = screenBuffer
+ Tea/Clipping.hs view
@@ -0,0 +1,47 @@+-- | Includes the Clipping class for objects that support clipping rectanges,+--   its instances, and monadic convenience functions.+module Tea.Clipping ( Clipping (clip)+                    , clipM+                    ) where++import Control.Monad.State+import Control.Monad.Trans+import Graphics.UI.SDL (withClipRect, Surface, Rect (..))+import Tea.Tea+import Tea.Screen+import Tea.Bitmap+import Tea.TeaState++withTea :: Tea s a -> s -> TeaState -> IO ((a, s), TeaState)+withTea = (runStateT .) . runStateT . extractTea++-- | A class instantiated over all types that support Clipping rectangles.+class Clipping v where+   -- | Run a specified Tea action where the provided Clipping type has been+   --   clipped to the size provided. The clipping only lasts for the duration+   --   of the action.+   clip :: v          -- ^ Buffer to clip+        -> (Int, Int) -- ^ Left-hand corner of clipping rectangle coordinates+        -> Int        -- ^ Width of clipping rectangle+        -> Int        -- ^ Height of clipping rectangle+        -> Tea s z    -- ^ Tea action to run+        -> Tea s z+   clip surf (x, y) w h m = do+                            scr <- getT+                            s <- get+                            ((v, s'),st') <- liftIO $ withClipRect (clipping_buffer surf) (Just $ Rect x y w h) (withTea m s scr)+                            putT st'+                            put s'+                            return v+   clipping_buffer :: v -> Surface++-- |A convenience version of Clip that takes a Tea action instead of a raw buffer.+clipM :: (Clipping v) => Tea s v -> (Int, Int) -> Int -> Int -> Tea s z+        -> Tea s z+clipM v a b c d  = v >>= \v' -> clip v' a b c d++instance Clipping Screen where+   clipping_buffer = screenBuffer++instance Clipping Bitmap where+   clipping_buffer = buffer
+ Tea/Color.hs view
@@ -0,0 +1,6 @@+-- |Includes the Color type.+module Tea.Color ( Color (..)+                 ) where+-- |A type to represent RGBA colors in Tea.+data Color = Color { red :: Int, green :: Int, blue :: Int, alpha :: Int}+           deriving (Show, Eq)
+ Tea/Display.hs view
@@ -0,0 +1,59 @@+-- |Includes core Tea monad functions that regulate display and framerate+--  as well as the runTea function that initializes hardware.+module Tea.Display+       ( screen+       , update+       , runTea+       , setFrameRate+       ) where++import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Mixer as Mixer+import Control.Monad.State+import Control.Monad.Trans+import Control.Applicative((<$>))+import Data.Map (empty)+import Data.Array (listArray)+import Tea.Input (KeyCode)+import Tea.TeaState+import Tea.Screen+import Tea.Tea++-- |Retrieve a buffer handle on the Screen+screen :: Tea s Screen+screen = _screen <$> getT++-- |Sets the frame rate cap. Note that this is merely a cap, and the frame rate may+--  be slower than this if additional processing is required.+setFrameRate :: Int ->  Tea s ()+setFrameRate n = modifyT $ \ts -> ts { _fpsCap = 1000 `div` n }++-- |Flip buffers, causing the hardware display to be updated with changes to+--  the Screen. Note this also waits sufficient time for a frame to have elapsed.+update :: Tea s ()+update = do ts@(TS { _screen = (Screen x), _fpsCap = fps, _lastUpdate = last}) <- getT+            t <- liftIO SDL.getTicks+            liftIO $ do+                     when (fromIntegral t < last + fps) $ SDL.delay $ fromIntegral $ last + fps - fromIntegral t+                     SDL.tryFlip x+            putT $ ts { _lastUpdate = fromIntegral t}++initialEventState = ES { keyCodes    = listArray (minBound :: KeyCode, maxBound :: KeyCode) $ repeat False+                       , keysDown    = 0+                       }++-- |Initialize hardware and run a Tea action with the specified state type.+runTea :: Int      -- ^ Screen Width+       -> Int      -- ^ Screen Height+       -> s        -- ^ State data+       -> Tea s m  -- ^ Tea action+       -> IO ()+runTea w h s m = do+                 SDL.init [SDL.InitEverything]+                 Mixer.openAudio 44100 Mixer.AudioS16Sys 2 1024+                 surf <- SDL.setVideoMode w h 0 [SDL.SWSurface, SDL.DoubleBuf]+                 let initialState = (TS (Screen surf) initialEventState (1000 `div` 60) 0 empty)+                 ((v,s'), st') <- runStateT (runStateT (extractTea m) s) initialState+                 Mixer.closeAudio+                 SDL.quit+                 return ()
+ Tea/Event.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+-- |Includes event handling concerns and mouse, application and keyboard state+--  query mechanisms.+module Tea.Event ( Event (..)+                 , EventQuery (..)+                 , (+>)+                 , eventHandler+                 , handleEvents+                 , updateEvents+                 , (?)+                 , is+                 , mouseCoords+                 , mouseButtons+                 , currentModKeys+                 ) where+import qualified Graphics.UI.SDL as SDL+import Data.Array ((//),(!))+import Control.Applicative ((<$>))+import Control.Monad.State+import Control.Monad.Trans+import Control.Monad(when)+import Data.Monoid+import Tea.Input+import Tea.Tea+import Tea.TeaState++-- | A data type used for phrasing queries passed to the `?' and `is' functions+data EventQuery = KeyDown KeyCode -- ^ Is the specified key currently held down?+                | KeyUp   KeyCode -- ^ Opposite of KeyDown+                | ModOn   Mod     -- ^ Is the specified modifier key currently enabled?+                | ModOff  Mod     -- ^ Opposite of ModOn+                | MouseIn (Int, Int) (Int, Int)      -- ^ Is the mouse between these two coordinates?+                | MouseOutside (Int, Int) (Int, Int) -- ^ Opposite of MouseIn+                | AnyKeyDown        -- ^ Is any key currently held down?+                | NoKeyDown         -- ^ Opposite of AnyKeyDown+                | MouseDown Button  -- ^ Is the specified mouse button being clicked?+                | MouseUp Button    -- ^ Opposite of MouseDown+                | AnyMouseDown      -- ^ Are any mouse buttons currently being clicked?+                | NoMouseDown       -- ^ Opposite of AnyMouseDown+                | AppVisible        -- ^ Is the app window currently non-minimized?+                | AppInvisible      -- ^ Opposite of AppVisible+                deriving (Show, Eq)++-- | A monoidal data type that specifies what to do when an event occurs. Use the+--   default no-op `eventHandler' (or `mempty') constant and override fields rather+--   than specify this directly.+--   You can combine the functionality of many Events using `+>' or `mappend', which+--   will run both handlers in the order they were appended.+data Event s = Event { keyDown        :: KeyCode -> [Mod] -> Tea s () -- ^ When a key is pressed+                     , keyUp          :: KeyCode -> [Mod] -> Tea s () -- ^ When a key stops being pressed+                     , mouseDown      :: Button -> (Int, Int) -> Tea s () -- ^ When a mouse button is pressed+                     , mouseUp        :: Button -> (Int, Int) -> Tea s () -- ^ When a mouse button stops being pressed+                     , mouseMove      :: (Int, Int) -> [Button] -> Tea s ()  -- ^ When the mouse moves+                     , mouseGained    :: Tea s () -- ^ When the application gains mouse focus+                     , mouseLost      :: Tea s () -- ^ When the application loses mouse focus+                     , keyboardGained :: Tea s () -- ^ When the application gains keyboard focus+                     , keyboardLost   :: Tea s () -- ^ When the application loses keyboard focus+                     , exit           :: Tea s () -- ^ When the application recieves the exit signal+                     , minimized      :: Tea s () -- ^ When the application is minimized+                     , restored       :: Tea s () -- ^ When the application ceases being minimized+                     }++instance Monoid (Event s) where+  mappend (Event a1 a2 a3 a4 a5 a7 a8 a9 a10 a11 a12 a13) (Event b1 b2 b3 b4 b5 b7 b8 b9 b10 b11 b12 b13) = Event {+    keyDown        = \key mods -> a1 key mods >> b1 key mods,+    keyUp          = \key mods -> a2 key mods >> b2 key mods,+    mouseDown      = \c b    -> a3 c b >> b3 c b,+    mouseUp        = \c b    -> a4 c b >> b4 c b,+    mouseMove      = \c b    -> a5 c b >> b5 c b,+    mouseGained    = a7 >> b7,+    mouseLost      = a8 >> b8,+    keyboardGained = a9 >> b9,+    keyboardLost   = a10 >> b10,+    exit           = a11 >> b11,+    minimized      = a12 >> b12,+    restored       = a13 >> b13+  }+  mempty = Event {+    keyDown           = \key mods -> return (),+    keyUp             = \key mods -> return (),+    mouseDown         = \x b -> return (),+    mouseUp           = \x b -> return (),+    mouseMove         = \x b -> return (),+    mouseGained       = return (),+    mouseLost         = return (),+    keyboardGained    = return (),+    keyboardLost      = return (),+    exit              = return (),+    minimized         = return (),+    restored          = return ()+  }++z :: Tea s ()+z = return ()++-- |Combine two event handlers. Analogous to mappend+(+>) :: Event s -> Event s -> Event s+(+>) = mappend++-- |A default, no-op event handler for overriding. Analogous to mzero.+eventHandler :: Event s+eventHandler = mempty++-- |Flush the event queue and update mouse and keyboard state queries, but+--  do not run any event handlers. Add this to your game loop if you use+--  `?' and `is' but not `handleEvents'.+updateEvents :: Tea s ()+updateEvents = handleEvents eventHandler++-- |Flush the event queue, updating mouse and keyboard state queries, and+--  executing actions defined in the specified event handler.+handleEvents :: Event s -> Tea s ()+handleEvents e = let e' = eventHandler {+                             keyDown = \code _-> (setEventQuery (KeyDown code) >> setEventQuery AnyKeyDown),+                             keyUp   = \code _-> (setEventQuery (KeyUp   code) >> setEventQuery NoKeyDown)+                          } +> e+                     this = do+                            event <- liftIO SDL.pollEvent+                            buttons <- mouseButtons+                            case event of+                               SDL.GotFocus l            -> foldl (>>) (return ()) $ map gotFocus' l+                               SDL.LostFocus l           -> foldl (>>) (return ()) $ map lostFocus' l+                               SDL.KeyDown ks            -> keyDown e'   (sdlKey (SDL.symKey ks)) (map sdlMod (SDL.symModifiers ks))+                               SDL.KeyUp   ks            -> keyUp   e'   (sdlKey (SDL.symKey ks)) (map sdlMod (SDL.symModifiers ks))+                               SDL.MouseButtonUp x y b   -> mouseUp e'   (sdlButton b) (fromIntegral x, fromIntegral y)+                               SDL.MouseButtonDown x y b -> mouseDown e' (sdlButton b) (fromIntegral x, fromIntegral y)+                               SDL.MouseMotion x y _ _   -> mouseMove e' (fromIntegral x, fromIntegral y) buttons+                               SDL.Quit                  -> exit e'+                               _                         -> return ()+                            when (event /= SDL.NoEvent) this+                     gotFocus' SDL.MouseFocus = mouseGained e'+                     gotFocus' SDL.InputFocus = keyboardGained e'+                     gotFocus' SDL.ApplicationFocus = restored e'+                     lostFocus' SDL.MouseFocus = mouseLost e'+                     lostFocus' SDL.InputFocus = keyboardLost e'+                     lostFocus' SDL.ApplicationFocus = minimized e'+                 in this++setEventQuery (KeyDown code) = keyCodesModify (// [(code, True) ])+setEventQuery (KeyUp code)   = keyCodesModify (// [(code, False)])+setEventQuery AnyKeyDown     = anyKeyModify (+ 1)+setEventQuery NoKeyDown      = anyKeyModify (subtract 1)+setEventQuery _              = undefined++getEventQuery :: EventQuery -> Tea s Bool+getEventQuery (KeyDown code)       = queryKeyCode code+getEventQuery (KeyUp code)         = not <$> queryKeyCode code+getEventQuery (AnyKeyDown)         = queryKeyDown+getEventQuery (NoKeyDown)          = not <$> queryKeyDown+getEventQuery (ModOn code)         = queryModState code+getEventQuery (ModOff code)        = not <$> queryModState code+getEventQuery (MouseIn c1 c2)      = queryMouseIn c1 c2+getEventQuery (MouseOutside c1 c2) = not <$> queryMouseIn c1 c2+getEventQuery (AppVisible)         = queryAppVisible+getEventQuery (AppInvisible)       = not <$> queryAppVisible+getEventQuery (AnyMouseDown)       = queryMouseDown+getEventQuery (NoMouseDown)        = not <$> queryMouseDown+getEventQuery (MouseDown button)   = queryMouseButton button+getEventQuery (MouseUp button)     = not <$> queryMouseButton button++eventStateModify f = modifyT $ \ts@(TS {_eventState = es}) -> ts {_eventState = f es}+keyCodesModify f  = eventStateModify $ \es@(ES { keyCodes = s }) -> es { keyCodes = f s }+anyKeyModify   f  = eventStateModify $ \es@(ES { keysDown = s }) -> es { keysDown = f s }++queryKeyCode code  = (! code)     <$> keyCodes <$> _eventState <$> getT+queryKeyDown       = (> 0)        <$> keysDown <$> _eventState <$> getT+queryMouseDown     = (/= [])      <$> mouseButtons+queryModState code = elem code    <$> currentModKeys+queryMouseButton b = elem b       <$> mouseButtons+queryMouseIn c1 c2 = within c1 c2 <$> mouseCoords+queryAppVisible    = liftIO $ elem SDL.ApplicationFocus <$> SDL.getAppState++-- |Get the current modifier keys that are enabled+currentModKeys :: Tea s [Mod]+currentModKeys = liftIO $ map sdlMod <$> SDL.getModState++-- |Get the current mouse coordinates+mouseCoords :: Tea s (Int, Int)+mouseCoords  = liftIO $ SDL.getMouseState >>= \(x, y, _) -> return (x,y)++-- |Get the currently pressed mouse buttons+mouseButtons :: Tea s [Button]+mouseButtons = liftIO $ SDL.getMouseState >>= \(_, _, l) -> return $ map sdlButton l++within (x1,y1) (x2,y2) (x, y) = x > x1 && y > y1 && x < x2 && y < y2++-- | Execute the specified Tea action if the EventQuery specified is true.+(?) :: EventQuery -> Tea s v -> Tea s ()+q ? m = getEventQuery q >>= flip when (m >> return ())+++-- | Produces a boolean value based on the specified EventQuery.+is :: EventQuery -> Tea s Bool+is = getEventQuery
+ Tea/Font.hs view
@@ -0,0 +1,48 @@+-- | Includes the Font abstract type, its constructor, and helper functions.+module Tea.Font ( Font (..)+                , loadFont+                , wrap+                ) where++import Graphics.UI.SDL.SFont (initFont, textWidth, SFont)+import Graphics.UI.SDL.Image (load)+import Control.Monad.Trans+import Data.List+import Tea.Tea++-- |A data type to represent Bitmap fonts in Tea.+data Font = Font { getSFont :: SFont }++-- |Load a font from an image file in the SFont format. The same image formats+--  as `loadBitmap' are supported.+loadFont :: String -> Tea s Font+loadFont str = do a <- liftIO $ load str+                  b <- liftIO $ initFont a+                  return (Font b)++partitionAtWord :: String -> Int -> (String, String)+partitionAtWord str i = partitionAtWord' ' ' i str []+  where+   partitionAtWord' _ _ [] taken = (reverse taken, [])+   partitionAtWord' ' ' 0 rest  (x:xs) = (reverse xs ,x:rest)+   partitionAtWord' ' ' 0 rest  [] = ([],rest)+   partitionAtWord' ' ' x (' ':xs) taken = partitionAtWord' ' ' x xs (' ':taken)+   partitionAtWord' ' ' x (v:xs) taken = partitionAtWord' v (x-1) xs (v:taken)+   partitionAtWord' _   x (v:xs) taken = partitionAtWord' v x xs (v:taken)++wordsRespectingSpaces :: String -> [String]+wordsRespectingSpaces [] = []+wordsRespectingSpaces str = let (f,s) = partitionAtWord str 1 in f:wordsRespectingSpaces s++-- | Wrap a string to fit in the specified width, if it were rendered in the given font.+wrap :: Font -> String -> Int -> String+wrap (Font font) str w = init $ unlines $ map (\v -> unlines $ reverse $ wrap' v []) $ lines str+  where+    wrap' [] accum = accum+    wrap' str accum = let possibilities = inits $ wordsRespectingSpaces str+                          sizemap =  zip (map (textWidth font . concat) possibilities) (map length possibilities)+                          amountToTake = case snd $ last $ takeWhile ((< w) . fst) sizemap of+                                           0 -> 1+                                           a -> a+                          (taken, dropped) = partitionAtWord str amountToTake+                      in wrap' dropped $ taken:accum
+ Tea/Grabbing.hs view
@@ -0,0 +1,47 @@+-- |Includes the Grabbing class for extracting sub-images, its instances, and+--  monadic helper functions.+module Tea.Grabbing ( Grabbing (grab)+                    , grabM+                    , grabM2+                    ) where++import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Sprig as SPG+import Control.Monad.Trans+import Tea.Tea+import Tea.Screen+import Tea.Bitmap++-- |A class instantiated over all types that can be grabbed from+class Grabbing v where+   -- | Blit a section of one Grabbing buffer to another.+   grab :: Grabbing s => v  -- ^ Source buffer+                      -> s  -- ^ Destination buffer+                      -> (Int, Int)  -- ^ Coordinates of region to grab+                      -> Int  -- ^ Width of region to grab+                      -> Int  -- ^ Height of region to grab+                      -> Tea z ()+   grab s ret (x, y) w h = do+                           liftIO $ SPG.pushBlend SPG.CopySrcAlpha+                           liftIO $ SPG.blit src (Just $ SDL.Rect x y w h) (grabbing_buffer ret) (Just $ SDL.Rect 0 0 w h)+                           liftIO SPG.popBlend+                           return ()+                           where src = grabbing_buffer s+   grabbing_buffer :: v -> SDL.Surface++-- | A monadic convenience function for grab that takes a Tea action instead of a source argument+grabM+  :: (Grabbing a, Grabbing s) =>+  Tea z a -> s -> (Int, Int) -> Int -> Int -> Tea z ()+grabM m a b c d = m >>= \m' -> grab m' a b c d+-- | A monadic convenience function for grab that takes a Tea action instead of both the source and destination.+grabM2+  :: (Grabbing a, Grabbing s) =>+  Tea z a -> Tea z s -> (Int, Int) -> Int -> Int -> Tea z ()+grabM2 m a b c d = m >>= \m' -> a >>= \a' -> grab m' a' b c d++instance Grabbing Bitmap where+   grabbing_buffer = buffer++instance Grabbing Screen where+   grabbing_buffer = screenBuffer
+ Tea/ImageSaving.hs view
@@ -0,0 +1,30 @@+-- |Includes the ImageSaving class, for types with savable image content, its+--  instances, and monadic helper functions.+module Tea.ImageSaving ( ImageSaving (save)+                       , saveM+                       ) where++import Control.Monad.Trans+import Graphics.UI.SDL (saveBMP, Surface)+import Tea.Tea+import Tea.Screen+import Tea.Bitmap++-- |A class instantiated over all types that can save their image content to a+--  BMP file+class ImageSaving v where+   -- |Save a BMP image of the providing ImageSaving type to the filename+   --  specified+   save :: v -> String -> Tea s Bool+   save v = liftIO . saveBMP (image_saving_buffer v)+   image_saving_buffer :: v -> Surface++-- |A monadic convenience function that takes a Tea action instead of a buffer to save.+saveM :: (ImageSaving v) => Tea s v -> String -> Tea s Bool+saveM m s = m >>= flip save s++instance ImageSaving Screen where+   image_saving_buffer = screenBuffer++instance ImageSaving Bitmap where+   image_saving_buffer = buffer
+ Tea/Input.hs view
@@ -0,0 +1,248 @@+-- | Includes basic types for mouse buttons and keyboard keys.+module Tea.Input ( Button (..)+                 , KeyCode (..)+                 , Mod (..)+                 , sdlMod+                 , sdlButton+                 , sdlKey+                 ) where++import Data.Array (Ix (..))+import qualified Graphics.UI.SDL as SDL++-- |Type representing all mouse buttons.+data Button = ButtonLeft | ButtonRight | ButtonMiddle | ButtonScrollUp | ButtonScrollDown deriving (Show, Eq, Ord, Enum, Bounded)+-- |Type representing all keys+data KeyCode = KeyUnknown     | KeyFirst     | KeyBackspace    | KeyTab       | KeyClear      | KeyReturn      | KeyPause    | KeyEscape+             | KeySpace       | KeyExclaim   | KeyDoubleQuote  | KeyHash      | KeyDollar     | KeyAmpersand   | KeyQuote    | KeyLeftParen+             | KeyRightParen  | KeyAsterisk  | KeyPlus         | KeyComma     | KeyMinus      | KeyPeriod      | KeySlash    | KeyNum0+             | KeyNum1        | KeyNum2      | KeyNum3         | KeyNum4      | KeyNum5       | KeyNum6        | KeyNum7     | KeyNum8+             | KeyNum9        | KeyColon     | KeySemicolon    | KeyLess      | KeyEquals     | KeyGreater     | KeyQuestion | KeyAt+             | KeyLeftBracket | KeyBackslash | KeyRightBracket | KeyCaret     | KeyUnderscore | KeyBackquote   | KeyA        | KeyB+             | KeyC           | KeyD         | KeyE            | KeyF         | KeyG          | KeyH           | KeyI        | KeyJ+             | KeyK           | KeyL         | KeyM            | KeyN         | KeyO          | KeyP           | KeyQ        | KeyR+             | KeyS           | KeyT         | KeyU            | KeyV         | KeyW          | KeyX           | KeyY        | KeyZ+             | KeyDelete      | KeyPad0      | KeyPad1         | KeyPad2      | KeyPad3       | KeyPad4        | KeyPad5     | KeyPad6+             | KeyPad7        | KeyPad8      | KeyPad9         | KeyPadPeriod | KeyPadDivide  | KeyPadMultiply | KeyPadMinus | KeyPadPlus+             | KeyPadEnter    | KeyPadEquals | KeyUpArrow      | KeyDownArrow | KeyRightArrow | KeyLeftArrow   | KeyInsert   | KeyHome+             | KeyEnd         | KeyPageUp    | KeyPageDown     | KeyF1        | KeyF2         | KeyF3          | KeyF4       | KeyF5+             | KeyF6          | KeyF7        | KeyF8           | KeyF9        | KeyF10        | KeyF11         | KeyF12      | KeyF13+             | KeyF14         | KeyF15       | KeyNumLock      | KeyCapsLock  | KeyScrolLock  | KeyRShift      | KeyLShift   | KeyRCtrl+             | KeyLCtrl       | KeyRAlt      | KeyLAlt         | KeyRMeta     | KeyLMeta      | KeyLSuper      | KeyRSuper   | KeyAltGr+             | KeyCompose     | KeyHelp      | KeyPrint        | KeySysReq    | KeyBreak      | KeyMenu        | KeyPower    | KeyEuro+             | KeyUndo        | KeyLast+             deriving (Show, Eq, Ord, Enum, Bounded)++-- |Type representing all keyboard modifiers+data Mod = ModLeftShift+         | ModRightShift+         | ModLeftCtrl+         | ModRightCtrl+         | ModLeftAlt+         | ModRightAlt+         | ModLeftMeta+         | ModRightMeta+         | ModNumLock+         | ModCapsLock+         | ModAltGr+         | ModCtrl+         | ModShift+         | ModAlt+         | ModMeta deriving (Show, Eq, Ord, Enum, Bounded)++range' (a,b)     = map toEnum $ range (fromEnum a,fromEnum b)+inRange' (a,b)   = inRange (fromEnum a, fromEnum b) . fromEnum+index' (a,b) c   = fromEnum c - fromEnum a++instance Ix KeyCode where+   range   = range'+   inRange = inRange'+   index   = index'++instance Ix Mod where+   range   = range'+   inRange = inRange'+   index   = index'++instance Ix Button where+   range   = range'+   inRange = inRange'+   index   = index'++sdlButton SDL.ButtonLeft      = ButtonLeft+sdlButton SDL.ButtonRight     = ButtonRight+sdlButton SDL.ButtonMiddle    = ButtonMiddle+sdlButton SDL.ButtonWheelUp   = ButtonScrollUp+sdlButton SDL.ButtonWheelDown = ButtonScrollDown++sdlMod SDL.KeyModLeftShift  = ModLeftShift+sdlMod SDL.KeyModRightShift = ModRightShift+sdlMod SDL.KeyModLeftCtrl   = ModLeftCtrl+sdlMod SDL.KeyModRightCtrl  = ModRightCtrl+sdlMod SDL.KeyModLeftAlt    = ModLeftAlt+sdlMod SDL.KeyModRightAlt   = ModRightAlt+sdlMod SDL.KeyModLeftMeta   = ModLeftMeta+sdlMod SDL.KeyModRightMeta  = ModRightMeta+sdlMod SDL.KeyModNum        = ModNumLock+sdlMod SDL.KeyModCaps       = ModCapsLock+sdlMod SDL.KeyModMode       = ModAltGr+sdlMod SDL.KeyModCtrl       = ModCtrl+sdlMod SDL.KeyModShift      = ModShift+sdlMod SDL.KeyModAlt        = ModAlt+sdlMod SDL.KeyModMeta       = ModMeta++modSDL ModLeftShift  = SDL.KeyModLeftShift+modSDL ModRightShift = SDL.KeyModRightShift+modSDL ModLeftCtrl   = SDL.KeyModLeftCtrl+modSDL ModRightCtrl  = SDL.KeyModRightCtrl+modSDL ModLeftAlt    = SDL.KeyModLeftAlt+modSDL ModRightAlt   = SDL.KeyModRightAlt+modSDL ModLeftMeta   = SDL.KeyModLeftMeta+modSDL ModRightMeta  = SDL.KeyModRightMeta+modSDL ModNumLock    = SDL.KeyModNum+modSDL ModCapsLock   = SDL.KeyModCaps+modSDL ModAltGr      = SDL.KeyModMode+modSDL ModCtrl       = SDL.KeyModCtrl+modSDL ModShift      = SDL.KeyModShift+modSDL ModAlt        = SDL.KeyModAlt+modSDL ModMeta       = SDL.KeyModMeta++sdlKey SDL.SDLK_UNKNOWN      = KeyUnknown+sdlKey SDL.SDLK_FIRST        = KeyFirst+sdlKey SDL.SDLK_BACKSPACE    = KeyBackspace+sdlKey SDL.SDLK_TAB          = KeyTab+sdlKey SDL.SDLK_CLEAR        = KeyClear+sdlKey SDL.SDLK_RETURN       = KeyReturn+sdlKey SDL.SDLK_PAUSE        = KeyPause+sdlKey SDL.SDLK_ESCAPE       = KeyEscape+sdlKey SDL.SDLK_SPACE        = KeySpace+sdlKey SDL.SDLK_EXCLAIM      = KeyExclaim+sdlKey SDL.SDLK_QUOTEDBL     = KeyDoubleQuote+sdlKey SDL.SDLK_HASH         = KeyHash+sdlKey SDL.SDLK_DOLLAR       = KeyDollar+sdlKey SDL.SDLK_AMPERSAND    = KeyAmpersand+sdlKey SDL.SDLK_QUOTE        = KeyQuote+sdlKey SDL.SDLK_LEFTPAREN    = KeyLeftParen+sdlKey SDL.SDLK_RIGHTPAREN   = KeyRightParen+sdlKey SDL.SDLK_ASTERISK     = KeyAsterisk+sdlKey SDL.SDLK_PLUS         = KeyPlus+sdlKey SDL.SDLK_COMMA        = KeyComma+sdlKey SDL.SDLK_MINUS        = KeyMinus+sdlKey SDL.SDLK_PERIOD       = KeyPeriod+sdlKey SDL.SDLK_SLASH        = KeySlash+sdlKey SDL.SDLK_0            = KeyNum0+sdlKey SDL.SDLK_1            = KeyNum1+sdlKey SDL.SDLK_2            = KeyNum2+sdlKey SDL.SDLK_3            = KeyNum3+sdlKey SDL.SDLK_4            = KeyNum4+sdlKey SDL.SDLK_5            = KeyNum5+sdlKey SDL.SDLK_6            = KeyNum6+sdlKey SDL.SDLK_7            = KeyNum7+sdlKey SDL.SDLK_8            = KeyNum8+sdlKey SDL.SDLK_9            = KeyNum9+sdlKey SDL.SDLK_COLON        = KeyColon+sdlKey SDL.SDLK_SEMICOLON    = KeySemicolon+sdlKey SDL.SDLK_LESS         = KeyLess+sdlKey SDL.SDLK_EQUALS       = KeyEquals+sdlKey SDL.SDLK_GREATER      = KeyGreater+sdlKey SDL.SDLK_QUESTION     = KeyQuestion+sdlKey SDL.SDLK_AT           = KeyAt+sdlKey SDL.SDLK_LEFTBRACKET  = KeyLeftBracket+sdlKey SDL.SDLK_BACKSLASH    = KeyBackslash+sdlKey SDL.SDLK_RIGHTBRACKET = KeyRightBracket+sdlKey SDL.SDLK_CARET        = KeyCaret+sdlKey SDL.SDLK_UNDERSCORE   = KeyUnderscore+sdlKey SDL.SDLK_BACKQUOTE    = KeyBackquote+sdlKey SDL.SDLK_a            = KeyA+sdlKey SDL.SDLK_b            = KeyB+sdlKey SDL.SDLK_c            = KeyC+sdlKey SDL.SDLK_d            = KeyD+sdlKey SDL.SDLK_e            = KeyE+sdlKey SDL.SDLK_f            = KeyF+sdlKey SDL.SDLK_g            = KeyG+sdlKey SDL.SDLK_h            = KeyH+sdlKey SDL.SDLK_i            = KeyI+sdlKey SDL.SDLK_j            = KeyJ+sdlKey SDL.SDLK_k            = KeyK+sdlKey SDL.SDLK_l            = KeyL+sdlKey SDL.SDLK_m            = KeyM+sdlKey SDL.SDLK_n            = KeyN+sdlKey SDL.SDLK_o            = KeyO+sdlKey SDL.SDLK_p            = KeyP+sdlKey SDL.SDLK_q            = KeyQ+sdlKey SDL.SDLK_r            = KeyR+sdlKey SDL.SDLK_s            = KeyS+sdlKey SDL.SDLK_t            = KeyT+sdlKey SDL.SDLK_u            = KeyU+sdlKey SDL.SDLK_v            = KeyV+sdlKey SDL.SDLK_w            = KeyW+sdlKey SDL.SDLK_x            = KeyX+sdlKey SDL.SDLK_y            = KeyY+sdlKey SDL.SDLK_z            = KeyZ+sdlKey SDL.SDLK_DELETE       = KeyDelete+sdlKey SDL.SDLK_KP0          = KeyPad0+sdlKey SDL.SDLK_KP1          = KeyPad1+sdlKey SDL.SDLK_KP2          = KeyPad2+sdlKey SDL.SDLK_KP3          = KeyPad3+sdlKey SDL.SDLK_KP4          = KeyPad4+sdlKey SDL.SDLK_KP5          = KeyPad5+sdlKey SDL.SDLK_KP6          = KeyPad6+sdlKey SDL.SDLK_KP7          = KeyPad7+sdlKey SDL.SDLK_KP8          = KeyPad8+sdlKey SDL.SDLK_KP9          = KeyPad9+sdlKey SDL.SDLK_KP_PERIOD    = KeyPadPeriod+sdlKey SDL.SDLK_KP_DIVIDE    = KeyPadDivide+sdlKey SDL.SDLK_KP_MULTIPLY  = KeyPadMultiply+sdlKey SDL.SDLK_KP_MINUS     = KeyPadMinus+sdlKey SDL.SDLK_KP_PLUS      = KeyPadPlus+sdlKey SDL.SDLK_KP_ENTER     = KeyPadEnter+sdlKey SDL.SDLK_KP_EQUALS    = KeyPadEquals+sdlKey SDL.SDLK_UP           = KeyUpArrow+sdlKey SDL.SDLK_DOWN         = KeyDownArrow+sdlKey SDL.SDLK_RIGHT        = KeyRightArrow+sdlKey SDL.SDLK_LEFT         = KeyLeftArrow+sdlKey SDL.SDLK_INSERT       = KeyInsert+sdlKey SDL.SDLK_HOME         = KeyHome+sdlKey SDL.SDLK_END          = KeyEnd+sdlKey SDL.SDLK_PAGEUP       = KeyPageUp+sdlKey SDL.SDLK_PAGEDOWN     = KeyPageDown+sdlKey SDL.SDLK_F1           = KeyF1+sdlKey SDL.SDLK_F2           = KeyF2+sdlKey SDL.SDLK_F3           = KeyF3+sdlKey SDL.SDLK_F4           = KeyF4+sdlKey SDL.SDLK_F5           = KeyF5+sdlKey SDL.SDLK_F6           = KeyF6+sdlKey SDL.SDLK_F7           = KeyF7+sdlKey SDL.SDLK_F8           = KeyF8+sdlKey SDL.SDLK_F9           = KeyF9+sdlKey SDL.SDLK_F10          = KeyF10+sdlKey SDL.SDLK_F11          = KeyF11+sdlKey SDL.SDLK_F12          = KeyF12+sdlKey SDL.SDLK_F13          = KeyF13+sdlKey SDL.SDLK_F14          = KeyF14+sdlKey SDL.SDLK_F15          = KeyF15+sdlKey SDL.SDLK_NUMLOCK      = KeyNumLock+sdlKey SDL.SDLK_CAPSLOCK     = KeyCapsLock+sdlKey SDL.SDLK_SCROLLOCK    = KeyScrolLock+sdlKey SDL.SDLK_RSHIFT       = KeyRShift+sdlKey SDL.SDLK_LSHIFT       = KeyLShift+sdlKey SDL.SDLK_RCTRL        = KeyRCtrl+sdlKey SDL.SDLK_LCTRL        = KeyLCtrl+sdlKey SDL.SDLK_RALT         = KeyRAlt+sdlKey SDL.SDLK_LALT         = KeyLAlt+sdlKey SDL.SDLK_RMETA        = KeyRMeta+sdlKey SDL.SDLK_LMETA        = KeyLMeta+sdlKey SDL.SDLK_LSUPER       = KeyLSuper+sdlKey SDL.SDLK_RSUPER       = KeyRSuper+sdlKey SDL.SDLK_MODE         = KeyAltGr+sdlKey SDL.SDLK_COMPOSE      = KeyCompose+sdlKey SDL.SDLK_HELP         = KeyHelp+sdlKey SDL.SDLK_PRINT        = KeyPrint+sdlKey SDL.SDLK_SYSREQ       = KeySysReq+sdlKey SDL.SDLK_BREAK        = KeyBreak+sdlKey SDL.SDLK_MENU         = KeyMenu+sdlKey SDL.SDLK_POWER        = KeyPower+sdlKey SDL.SDLK_EURO         = KeyEuro+sdlKey SDL.SDLK_UNDO         = KeyUndo+sdlKey SDL.SDLK_LAST         = KeyLast+sdlKey _                 = KeyUnknown
+ Tea/Primitive.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+-- | Includes the Primitive class for drawing primitive concerns, its instances+--   and monadic convenience functions.+module Tea.Primitive ( -- * Primitive Drawing Functions+                       Primitive ( rect+                                 , setPixel+                                 , getPixel+                                 , clear+                                 , roundedRect+                                 , line+                                 , fadeLine+                                 , bezier+                                 , circle+                                 , arc+                                 , ellipse+                                 )+                  -- * Drawing options+                     , PrimitiveOptions (..)+                     , defaults+                  -- * Monadic convenience functions+                     , rectM+                     , setPixelM+                     , getPixelM+                     , clearM+                     , roundedRectM+                     , lineM+                     , fadeLineM+                     , bezierM+                     , circleM+                     , arcM+                     , ellipseM+                     ) where++import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Sprig as SPG+import Control.Monad.Trans+import Tea.Tea+import Tea.BlendMode+import Tea.Bitmap+import Tea.Screen+import Tea.Color++-- |A type representing less common options used when drawing Primitives.+--  Typically you would override defaults rather than use this type directly.+data PrimitiveOptions = PrimitiveOptions { mix :: BlendMode   -- ^ Which blendmode to use when drawing (default is DestAlpha)+                                         , antialias :: Bool  -- ^ Whether or not to antialias lines (default is True)+                                         , filled    :: Bool  -- ^ Whether or not to fill the shape (if possible) (default is False)+                                         , thickness :: Int   -- ^ The line thickness in pixels, if the shape is not filled (default is 1)+                                         } deriving (Show, Eq)+-- | A default set of PrimitiveOptions.+defaults :: PrimitiveOptions+defaults = PrimitiveOptions { mix = DestAlpha, antialias = True, filled = False, thickness = 1 }++colorToPixel surf (Color r g b a) = SDL.mapRGBA (SDL.surfaceGetPixelFormat surf) (fromIntegral r) (fromIntegral g) (fromIntegral b) (fromIntegral a)++withColor s c f = colorToPixel s c >>= flip f (fromIntegral $ alpha c)++alpha' = fromIntegral . alpha+line' s x1 y1 x2 y2 c _                 = withColor s c $ SPG.lineBlend s x1 y1 x2 y2+bezier' s x1 y1 x2 y2 x3 y3 x4 y4 q c _ = withColor s c $ SPG.bezierBlend s x1 y1 x2 y2 x3 y3 x4 y4 (fromIntegral q)+rect' s x1 y1 x2 y2 c True              = withColor s c $ SPG.rectFilledBlend s x1 y1 x2 y2+rect' s x1 y1 x2 y2 c False             = withColor s c $ SPG.rectBlend s x1 y1 x2 y2+roundedRect' s x1 y1 x2 y2 r c True     = withColor s c $ SPG.rectRoundFilledBlend s x1 y1 x2 y2 r+roundedRect' s x1 y1 x2 y2 r c False    = withColor s c $ SPG.rectRoundBlend s x1 y1 x2 y2 r+circle' s x y r c True                  = withColor s c $ SPG.circleFilledBlend s x y r+circle' s x y r c False                 = withColor s c $ SPG.circleBlend s x y r+arc' s x y r a1 a2 c True               = withColor s c $ SPG.arcFilledBlend s x y r a1 a2+arc' s x y r a1 a2 c False              = withColor s c $ SPG.arcBlend s x y r a1 a2+ellipse' s x y rx ry c True             = withColor s c $ SPG.ellipseFilledBlend s x y rx ry+ellipse' s x y rx ry c False            = withColor s c $ SPG.ellipseBlend s x y rx ry+fadeLine' s x1 y1 x2 y2 c c2 _          = do c2' <- colorToPixel s c2; c1' <- colorToPixel s c; SPG.lineFadeBlend s x1 y1 x2 y2 c1' (alpha' c) c2' $ alpha' c2++withOptions :: PrimitiveOptions -> (Bool -> IO v) -> IO v+withOptions (PrimitiveOptions m a o t) g = do SPG.pushBlend (blendModeToSPG m)+                                              SPG.pushAA a+                                              SPG.pushThickness t+                                              ret <- g o+                                              --SPG.popThickness caused arbitrary segfaults.. can't be too bad, can it?+                                              SPG.popAA+                                              SPG.popBlend+                                              return ret++pixelToColor s p = SDL.getRGBA p (SDL.surfaceGetPixelFormat s) >>= \(r,g,b,a) -> return $ Color (fromIntegral r) (fromIntegral g) (fromIntegral b) (fromIntegral a)+++class Primitive v where++   primitive_buffer :: v -> SDL.Surface+   -- |Clear the whole buffer with RGBA 0,0,0,0+   clear :: v -> Tea s Bool+   clear x = liftIO $+             SDL.mapRGBA (SDL.surfaceGetPixelFormat surf) 0 0 0 0 >>=+             SDL.fillRect surf (Just (SDL.Rect 0 0+                                          (SDL.surfaceGetWidth  surf)+                                          (SDL.surfaceGetHeight surf)))+             where surf = primitive_buffer x+   -- |Get the pixel color value at the specified coordinates+   getPixel :: v -> (Int, Int) -> Tea s Color+   getPixel s (x, y) = liftIO $ SPG.getPixel (primitive_buffer s) x y >>= pixelToColor (primitive_buffer s)++   -- |Set the pixel color value at the specified coordinates+   setPixel :: v -> (Int, Int) -> Color -> Tea s ()+   setPixel s (x, y) color = liftIO $ SPG.pixel surf x y =<< colorToPixel surf color+                        where surf = primitive_buffer s++   -- |Draw a rectangle+   rect :: v                 -- ^ Buffer to draw to+        -> (Int, Int)        -- ^ Coordinates of the top-left corner of the+                             --   rectangle+        -> Int               -- ^ Width of the rectangle+        -> Int               -- ^ Height of the rectangle+        -> Color             -- ^ Color of the rectangle+        -> PrimitiveOptions  -- ^ Other drawing options+        -> Tea s ()+   rect s (x,y) w h c opts = liftIO $ withOptions opts $ rect' (primitive_buffer s) x y (x+w) (y+h) c++   -- |Same as rectangle, except also takes a Float value for the radius by+   --  which to round the corners+   roundedRect :: v -> (Int, Int) -> Int -> Int -> Float -> Color -> PrimitiveOptions -> Tea s ()+   roundedRect s (x, y) w h r c opts = liftIO $ withOptions opts $ roundedRect' (primitive_buffer s) x y (x+w) (y+h) r c++   -- |Draw a line of the specified color between two coordinates.+   line :: v -> (Int, Int) -> (Int, Int) -> Color -> PrimitiveOptions -> Tea s ()+   line s (x1, y1) (x2, y2) c opts = liftIO $ withOptions opts $ line' (primitive_buffer s) x1 y1 x2 y2 c++   -- |Same as line, except takes an extra color for a gradient effect.+   fadeLine :: v -> (Int, Int) -> (Int, Int) -> Color -> Color -> PrimitiveOptions -> Tea s ()+   fadeLine s (x1, y1) (x2, y2) c1 c2 opts = liftIO $ withOptions opts $ fadeLine' (primitive_buffer s) x1 y1 x2 y2 c1 c2++   -- |Draw a bezier curve+   bezier :: v                 -- ^ Buffer to draw to+          -> (Int, Int)        -- ^ Start coordinate+          -> (Int, Int)        -- ^ First control point+          -> (Int, Int)        -- ^ Second control point+          -> (Int, Int)        -- ^ End coordinate+          -> Int               -- ^ Quality (number of intermediate points).+                               --   4-7 is normal.+          -> Color             -- ^ Color of the line+          -> PrimitiveOptions  -- ^ Other drawing options+          -> Tea s ()+   bezier s (x1, y1) (x2, y2) (x3, y3) (x4, y4) q c opts = liftIO $ withOptions opts $ bezier' (primitive_buffer s) x1 y1 x2 y2 x3 y3 x4 y4 q c++   -- |Draw a circle, at the specified point, with the specified radius, in+   --  the specified colour.+   circle :: v -> (Int, Int) -> Float -> Color -> PrimitiveOptions -> Tea s ()+   circle s (x, y) r c opts = liftIO $ withOptions opts $ circle' (primitive_buffer s) x y r c+   -- |Draw an arc+   arc :: v                 -- ^ Buffer to draw to+       -> (Int, Int)        -- ^ Point of the center of the arc's circle+       -> Float             -- ^ Radius of the arc's circle+       -> Float             -- ^ Start angle (in degrees)+       -> Float             -- ^ Stop angle (in degrees)+       -> Color             -- ^ Color of the arc+       -> PrimitiveOptions  -- ^ Other drawing options+       -> Tea s ()+   arc s (x, y) r a1 a2 c opts = liftIO $ withOptions opts $ arc' (primitive_buffer s) x y r a1 a2 c++   -- |Draw an ellipse+   ellipse :: v                 -- ^ Buffer to draw to+           -> (Int, Int)        -- ^ Coordinates of the center+           -> Float             -- ^ X axis radius+           -> Float             -- ^ Y axis radius+           -> Color             -- ^ Color of the ellipse+           -> PrimitiveOptions  -- ^ Other drawing options+           -> Tea s ()+   ellipse s (x, y) rx ry c opts = liftIO $ withOptions opts $ ellipse' (primitive_buffer s) x y rx ry c++clearM :: (Primitive a) => Tea s a -> Tea s Bool+clearM = (>>= clear)+-- s/\(.*\)M m\(.*\)/\0 = m >>= \\m' -> \1 m' \2/g+rectM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> Int+     -> Int+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+rectM m c w h l o = m >>= \m' -> rect m'  c w h l o+setPixelM+  :: (Primitive a) => Tea s a -> (Int, Int) -> Color -> Tea s ()+setPixelM m c l = m >>= \m' -> setPixel m'  c l+getPixelM :: (Primitive a) => Tea s a -> (Int, Int) -> Tea s Color+getPixelM m c = m >>= flip getPixel c+roundedRectM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> Int+     -> Int+     -> Float+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+roundedRectM m c w h r l o = m >>= \m' -> roundedRect m'  c w h r l o+lineM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> (Int, Int)+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+lineM m c1 c2 l o = m >>= \m' -> line m'  c1 c2 l o+fadeLineM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> (Int, Int)+     -> Color+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+fadeLineM m c1 c2 l1 l2 o = m >>= \m' -> fadeLine m'  c1 c2 l1 l2 o+bezierM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> (Int, Int)+     -> (Int, Int)+     -> (Int, Int)+     -> Int+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+bezierM m c1 c2 c3 c4 q l o = m >>= \m' -> bezier m'  c1 c2 c3 c4 q l o+circleM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> Float+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+circleM m c r l o = m >>= \m' -> circle m'  c r l o+arcM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> Float+     -> Float+     -> Float+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+arcM m c r s e l o = m >>= \m' -> arc m'  c r s e l o+ellipseM+  :: (Primitive a) =>+     Tea s a+     -> (Int, Int)+     -> Float+     -> Float+     -> Color+     -> PrimitiveOptions+     -> Tea s ()+ellipseM m c rx ry l o = m >>= \m' -> ellipse m'  c rx ry l o++instance Primitive Bitmap where+   primitive_buffer = buffer++instance Primitive Screen where+   primitive_buffer = screenBuffer
+ Tea/Screen.hs view
@@ -0,0 +1,6 @@+-- | Includes the screen type.+module Tea.Screen (Screen (..)) where+import Graphics.UI.SDL (Surface)++-- | Type that represents the hardware linked drawing buffer.+data Screen = Screen { screenBuffer :: Surface }
+ Tea/Size.hs view
@@ -0,0 +1,32 @@+-- | Includes the Size class for types with dimensions, its instances, and+--   monadic convenience functions.+module Tea.Size ( Size (width,height)+                , heightM+                , widthM+                ) where++import Graphics.UI.SDL(Surface, surfaceGetHeight, surfaceGetWidth)+import Tea.Screen+import Tea.Bitmap+import Tea.Tea++-- |A class instantiated over all types that have a width and height.+--  Intended really only for internal use. Define your own Size class+--  if you want similar behavior.+class Size v where+   width  :: v -> Int+   width  = surfaceGetWidth  . size_buffer+   height :: v -> Int+   height = surfaceGetHeight . size_buffer+   size_buffer :: v -> Surface++widthM :: (Size a) => Tea s a -> Tea s Int+widthM  = fmap width+heightM :: (Size a) => Tea s a -> Tea s Int+heightM = fmap height++instance Size Screen where+   size_buffer = screenBuffer++instance Size Bitmap where+   size_buffer = buffer
+ Tea/Sound.hs view
@@ -0,0 +1,111 @@+-- | Includes the Sound type and associated operations, for audio playback+--   in Tea.+module Tea.Sound ( loadSound+                 , maxVolume+                 , play+                 , playLoop+                 , pause+                 , resume+                 , stop+                 , setVolume+                 , getVolume+                 , isPlaying+                 , isPaused+                 , pauseAll+                 , resumeAll+                 , stopAll+                 , setMasterVolume+                 , getMasterVolume+                 , Sound+                 ) where++import Prelude hiding (lookup)+import qualified Graphics.UI.SDL.Mixer as Mixer+import Control.Monad.State+import Control.Applicative((<$>))+import Data.Map(insert, lookup)+import Tea.TeaState+import Tea.Tea++-- |A data type representing a sound that can be played in Tea.+data Sound = Sound Mixer.Chunk++-- |The maximum volume level+maxVolume :: Int+maxVolume = 128++noChannel :: Mixer.Channel+noChannel = -1++-- | Load a sound from the given filename. Supports CMD, Wav, Trackers+--   such as MOD files, MIDI, Ogg,  MP3, however MIDI and MP3 support+--   is platform dependant and shaky.+loadSound :: FilePath -> Tea s Sound+loadSound f = Sound <$> liftIO (Mixer.loadWAV f)++-- | Play a sound+play :: Sound -> Tea s ()+play snd = playLoop snd 0++-- | Play a sound, looping the provided number of times.+playLoop :: Sound -> Int -> Tea s ()+playLoop s@(Sound chun) loops = do stop s+                                   chan <- liftIO $ Mixer.playChannel (-1) chun loops+                                   modifyT $ \s@TS{_channels = c} -> s { _channels = insert (read $ show chun :: Int) chan c }++withChannel = withChannelRet ()++withChannelRet ret chun f = let key = read $ show chun :: Int+                            in do c <- fmap _channels getT+                                  case lookup key c of+                                     Just channel -> f channel+                                     Nothing      -> return ret++-- |Pause a sound+pause :: Sound -> Tea s ()+pause (Sound chun) = withChannel chun $ liftIO . Mixer.pause++-- |Resume a sound+resume :: Sound -> Tea s ()+resume (Sound chun) = withChannel chun $ liftIO . Mixer.resume++-- |Stop a sound playing+stop :: Sound -> Tea s ()+stop (Sound chun) = withChannel chun $ liftIO . Mixer.haltChannel++-- |Set a sound's playback volume.+setVolume :: Sound -> Int -> Tea s ()+setVolume (Sound chun) vol = withChannel chun $ \chan -> liftIO $ do Mixer.volume chan vol+                                                                     return ()+-- |Get a sound's playback volume+getVolume :: Sound -> Tea s Int+getVolume (Sound chun) = withChannelRet (-1) chun $ \chan -> liftIO $ Mixer.volume chan (-1)++-- |Return if a sound is currently playing+isPlaying :: Sound -> Tea s Bool+isPlaying (Sound chun) = withChannelRet False chun $ liftIO . Mixer.isChannelPlaying++-- |Return if a sound is currently paused.+isPaused :: Sound -> Tea s Bool+isPaused (Sound chun) = withChannelRet False chun $ liftIO . Mixer.isChannelPaused++-- |Pause all currently playing sounds.+pauseAll :: Tea s ()+pauseAll = liftIO $ Mixer.pause noChannel++-- |Resume all sounds that have been paused.+resumeAll :: Tea s ()+resumeAll = liftIO $ Mixer.resume noChannel++-- |Stop playback of all sounds.+stopAll :: Tea s ()+stopAll = liftIO $ Mixer.haltChannel noChannel++-- |Set the master volume of sound playback+setMasterVolume :: Int -> Tea s ()+setMasterVolume v = liftIO $ Mixer.volume noChannel v >> return ()++-- |Get the master volume of sound playback+getMasterVolume :: Tea s Int+getMasterVolume = liftIO $ Mixer.volume noChannel (-1)+
+ Tea/Tea.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-- | Includes the Tea type and internal state accessors.+module Tea.Tea ( Tea (..)+               , getT+               , putT+               , modifyT+               ) where+import Control.Monad.State+import Control.Monad.Trans+import Tea.TeaState (TeaState)+-- |Copointed monad that provides a State instance and+--  ensures the initialization of hardware devices+--  used by Tea.+newtype Tea s v = Tea { extractTea :: StateT s (StateT TeaState IO) v }++instance Monad (Tea s) where+   return        = Tea . return+   (Tea a) >>= b = Tea $ a >>= extractTea . b++instance MonadState s (Tea s) where+   get = Tea get+   put = Tea . put++instance Functor (Tea s) where+   fmap f (Tea v) = Tea $ fmap f v++instance MonadIO (Tea s) where+   liftIO = Tea . liftIO++getT = Tea $ lift get+putT = Tea . lift . put+modifyT = Tea . lift . modify
+ Tea/TeaState.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Internal only. Do Not Eat.+module Tea.TeaState ( TeaState (..)+                    , EventState (..)+                    ) where+import Data.Map(Map)+import Data.Array(Array)+import Tea.Screen(Screen)+import Tea.Input(KeyCode)++data TeaState = TS { _screen :: Screen, _eventState :: EventState, _fpsCap :: Int, _lastUpdate :: Int, _channels :: Map Int Int}++data EventState = ES { keyCodes    :: Array KeyCode Bool+                     , keysDown    :: Int+                     }
+ Tea/TextDrawing.hs view
@@ -0,0 +1,33 @@+-- | Includes the TextDrawing class, its instances, and monadic convenience+--   functions.+module Tea.TextDrawing ( TextDrawing (drawText)+                       , drawTextM+                       ) where++import Graphics.UI.SDL (Surface)+import Graphics.UI.SDL.SFont (textHeight, write)+import Control.Monad.Trans+import Tea.Tea+import Tea.Screen+import Tea.Bitmap+import Tea.Font++-- |A class instantiated for all types to which bitmap text+--  can be drawn.+class TextDrawing v where+   -- |Draw text in the given font at the given coordintaes+   drawText :: v -> (Int, Int) -> Font -> String -> Tea s ()+   drawText s (x,y) (Font font) str = do mapM (uncurry drawLine) $ zip (lines str) $ map ((+ y) . (*textHeight font)) [1..]; return ()+        where+           drawLine str y = liftIO $ write (text_drawing_buffer s) font (x,y) str+   text_drawing_buffer :: v -> Surface++-- |A monadic convenience function that takes a Tea action instead of a buffer.+drawTextM :: (TextDrawing v) => Tea s v -> (Int, Int) -> Font -> String -> Tea s ()+drawTextM m c f s = m >>= \m' -> drawText m' c f s++instance TextDrawing Bitmap where+   text_drawing_buffer = buffer++instance TextDrawing Screen where+   text_drawing_buffer = screenBuffer
+ TeaHS.cabal view
@@ -0,0 +1,34 @@+name:                TeaHS+version:             0.3+synopsis:            TeaHS Game Creation Library+description:         A simple library for use creating 2D games, inspired by the Ruby library Tea.+category:            Games+license:             BSD3+license-file:        LICENSE+homepage:            http://liamoc.net/static/TeaHS+author:              Liam O'Connor-Davis+maintainer:          liamoc@cse.unsw.edu.au+build-type:          Simple+cabal-version:       >=1.2+Library+  exposed-modules:     Tea+                       Tea.Bitmap+                       Tea.BlendMode+                       Tea.Blitting+                       Tea.Clipping+                       Tea.Color+                       Tea.Display+                       Tea.Event+                       Tea.Font+                       Tea.Grabbing+                       Tea.ImageSaving+                       Tea.Input+                       Tea.Primitive+                       Tea.Screen+                       Tea.Size+                       Tea.Sound+                       Tea.Tea+                       Tea.TeaState+                       Tea.TextDrawing++  build-depends:       base<5, SDL>=0.5.9, Sprig>=0.1, SDL-image, SDL-mixer,SFont>=0.1, array>=0.2, mtl>=1.1, containers>=0.2