initial commit

.gitignore

@@ -0,0 +1,3 @@
+test/*
+Pong.hs
+.*.sw?

Tea.hs

@@ -0,0 +1,46 @@
+module Tea
+   ( module Tea.Monad
+   , module Tea.Types
+   , module Tea.Size
+   , module Tea.Sound
+   , module Tea.Event
+   , module Tea.Primitive
+   , module Tea.Blitting
+   , module Tea.Clipping
+   , module Tea.Grabbing
+   , module Tea.Bitmap
+   , module Tea.ImageSaving
+   ) where
+
+import Tea.Monad
+import Tea.Types
+import Tea.Size
+import Tea.Sound
+import Tea.Event
+import Tea.Bitmap
+import Tea.Screen
+import Tea.Primitive
+import Tea.Blitting
+import Tea.Clipping
+import Tea.Grabbing
+import Tea.ImageSaving
+{-
+test_anim x y bmap = if x < 255 && y < 480 then do
+                   scr <- screen
+                   blit scr bmap 0 0
+                   update
+                   liftIO $ SDL.delay 10
+                   test_anim (x+1) (y+1) bmap
+                   return ()
+                else
+                   return ()
+
+test = runTea 640 480 $ do
+                        scr <- screen
+                        circle scr 50 50 20 (Color 255 0 255 255) defaults { antialias = False, filled = True, mix = SrcAlpha }
+                        bmap <- blank 640 480 (Color 0 0 255 64)
+                        circle bmap 50 50 50 (Color 0 255 0 0) defaults { antialias = False, filled = True, mix = SrcAlpha }
+                        bmap2 <- grab bmap 0 0 640 480
+                        test_anim 0 0 bmap2
+
+-}

Tea/Bitmap.hs

@@ -0,0 +1,45 @@
+module Tea.Bitmap where
+import Tea.BitmapConstructorsInternal
+import Tea.Blitting
+import Tea.Clipping
+import Tea.ImageSaving
+import Tea.Size 
+import Tea.Primitive
+import Tea.Types
+import Tea.Grabbing
+import Tea.Monad
+import qualified Graphics.UI.SDL as SDL
+import qualified Graphics.UI.SDL.Image as SDLI
+import Control.Monad.Trans
+
+fromImage :: String -> Tea Bitmap
+fromImage s = liftIO $ do
+              buf <- SDLI.load s
+              buf' <- SDL.displayFormatAlpha buf
+              return $ Bitmap { buffer = buf' }              
+
+
+blank :: Int -> Int -> Color -> Tea Bitmap
+blank w h c = do
+              buf <- liftIO $ _blank w h c
+              return (Bitmap buf)
+
+instance Blitting Bitmap where
+   blitting_buffer = buffer
+
+instance Clipping Bitmap where
+   clipping_buffer = buffer
+
+instance Grabbing Bitmap where
+   grabbing_buffer = buffer
+
+instance ImageSaving Bitmap where
+   image_saving_buffer = buffer
+
+instance Primitive Bitmap where
+   primitive_buffer = buffer
+
+instance Size Bitmap where
+   size_buffer = buffer
+
+

Tea/BitmapConstructorsInternal.hs

@@ -0,0 +1,14 @@
+module Tea.BitmapConstructorsInternal where
+import Tea.Types
+import qualified Graphics.UI.SDL as SDL
+import Control.Monad.Trans
+
+_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
+

Tea/Blitting.hs

@@ -0,0 +1,37 @@
+module Tea.Blitting ( Blitting (..)
+                    , blitBlendM
+                    , blitBlendM2
+                    , blitM
+                    , blitM2
+                    ) where
+
+import Graphics.UI.SDL as SDL
+import qualified Graphics.UI.SDL.Sprig as SPG
+import Tea.Monad
+import Tea.Primitive
+import Tea.Types
+import Control.Monad.Trans
+
+class Blitting v where
+   blitBlend :: Blitting s => v -> s -> BlendMode -> (Int, Int) -> Tea 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 :: Blitting s => v -> s -> (Int, Int) -> Tea 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    = surfaceGetWidth  src
+                      src_h    = surfaceGetHeight src
+                      src      = blitting_buffer s
+                      dst      = blitting_buffer d
+   blitting_buffer :: v -> SDL.Surface   
+
+
+blitBlendM  d s a b = d >>= \d' -> blitBlend d' s a b 
+blitBlendM2 d s a b = d >>= \d' -> s >>= \s' -> blitBlend d' s' a b 
+blitM d s x = d >>= \d' -> blit d' s x 
+blitM2 d s x = d >>= \d' -> s >>= \s' -> blit d' s' x 

Tea/Clipping.hs

@@ -0,0 +1,23 @@
+module Tea.Clipping ( Clipping (..)
+                    , clipM
+                    ) where
+
+import Graphics.UI.SDL
+import Tea.Monad
+import Tea.Types
+import Control.Monad.State
+import Control.Monad.Trans
+
+withTea m st = return =<< runStateT (extract m) st
+
+class Clipping v where
+   clip :: v -> (Int, Int) -> Int -> Int -> Tea z -> Tea z
+   clip s (x, y) w h m = do
+                      scr <- get
+                      (v, st') <- liftIO $ withClipRect (clipping_buffer s) (Just $ Rect x y w h) (withTea m scr)
+                      put st'
+                      return v
+   clipping_buffer :: v -> Surface   
+
+clipM v a b c d  = v >>= \v' -> clip v' a b c d
+

Tea/Event.hs

@@ -0,0 +1,47 @@
+module Tea.Event ((+>), eventHandler) where
+import Data.Monoid
+import qualified Graphics.UI.SDL as SDL
+import Tea.Types
+import Data.Ix
+
+instance Monoid Event 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 -> z,
+    keyUp             = \key mods -> z,
+    mouseDown         = \x b -> z,
+    mouseUp           = \x b -> z,
+    mouseMove         = \x b -> z,
+    mouseGained       = z,
+    mouseLost         = z,
+    keyboardGained    = z,
+    keyboardLost      = z,
+    exit              = z,
+    minimized         = z,
+    restored          = z
+  }
+
+z = return ()
+
+(+>) :: Event -> Event -> Event
+(+>) = mappend
+
+eventHandler :: Event
+eventHandler = mempty
+
+
+
+

Tea/Grabbing.hs

@@ -0,0 +1,23 @@
+module Tea.Grabbing ( Grabbing (..)
+                    , grabM
+                    , grabM2
+                    ) where
+
+import qualified Graphics.UI.SDL as SDL
+import qualified Graphics.UI.SDL.Sprig as SPG
+import Tea.Types
+import Tea.Blitting
+import Tea.Monad
+import Control.Monad.Trans
+class Grabbing v where
+   grab :: Blitting s => v -> (Int, Int) -> Int -> Int -> s -> IO ()
+   grab s (x, y) w h ret = do
+                           liftIO $ SPG.pushBlend (SPG.CopySrcAlpha)
+                           liftIO $ SPG.blit src (Just $ SDL.Rect x y w h) (blitting_buffer ret) (Just $ SDL.Rect 0 0 w h)
+                           liftIO $ SPG.popBlend
+                           return ()
+                           where src = grabbing_buffer s
+   grabbing_buffer :: v -> SDL.Surface  
+
+grabM m a b c d = m >>= \m' -> grab m' a b c d
+grabM2 m a b c d = m >>= \m' -> d >>= \d' -> grab m' a b c d'

Tea/ImageSaving.hs

@@ -0,0 +1,15 @@
+module Tea.ImageSaving ( ImageSaving (..)
+                       , saveM
+                       ) where
+
+import Graphics.UI.SDL as SDL
+import Tea.Types
+import Tea.Monad
+import Control.Monad.Trans
+
+class ImageSaving v where
+   save :: v -> String -> Tea Bool
+   save z path = liftIO $ saveBMP (image_saving_buffer z) path
+   image_saving_buffer :: v -> SDL.Surface   
+
+saveM m s = m >>= \m' -> save m' s