VideoGuts.hs

   1 module VideoGuts where
   2
   3 import Prelude hiding (init, flip)
   4 import Graphics.UI.SDL
   5 import Data.Complex
   6 import Data.IntMap
   7 import Control.Monad
   8 import Debug.Trace
   9
  10 import Coord
  11 import Image
  12
  13 data Video = Video {
  14   clear :: IO (),
  15   loadImage :: String -> IO Image,
  16   setClip :: Maybe (Coord, Coord) -> IO (),
  17   finalize :: IO ()
  18 }
  19
  20 setupSDL :: Int -> Int -> IO Surface
  21 setupSDL w h = do
  22   init [InitEverything]
  23   setVideoMode w h 32 []
  24
  25 setupGL :: Int -> Int -> IO ()
  26 setupGL w h = do
  27   error "OpenGL backend non-existent"
  28   init [InitEverything]
  29   setVideoMode w h 32 [OpenGL]
  30   -- opengl boilerplate here
  31   return ()
  32
  33 quitGuts :: IO ()
  34 quitGuts = quit
  35
  36 sdlLoadImage :: Surface -> String -> IO Image
  37 sdlLoadImage screen path = do
  38   raw <- loadBMP path
  39   surf <- displayFormat raw
  40   setColorKey surf [SrcColorKey] (Pixel 0)
  41   return (sdlImage screen surf)
  42
  43 glLoadImage :: String -> IO Image
  44 glLoadImage path = undefined
  45
  46 sdlSetClip :: Surface -> Maybe (Coord,Coord) -> IO ()
  47 sdlSetClip screen Nothing = setClipRect screen Nothing
  48 sdlSetClip screen (Just (xy,wh)) = setClipRect screen r where
  49   r = Just (Rect (floor x) (floor y) (floor w) (floor h))
  50   (x:+y) = xy
  51   (w:+h) = wh
  52 glSetClip :: Maybe (Coord,Coord) -> IO ()
  53 glSetClip = undefined
  54
  55 sdlClear :: Surface -> IO ()
  56 sdlClear screen = fillRect screen Nothing (Pixel 0) >> return ()
  57 glClear :: IO ()
  58 glClear = error "glClear ?"
  59
  60 sdlFinalize :: Surface -> IO ()
  61 sdlFinalize screen = flip screen
  62 glFinalize :: IO ()
  63 glFinalize = error "glFinalize ?"
  64
  65 loadAllImages :: Video -> IO (IntMap Image)
  66 loadAllImages vid = return empty
  67
  68
  69
  70 glQuad = undefined
  71 glGenImg = undefined
  72
  73 sdlBlit :: Surface -> Surface -> Complex Double -> IO ()
  74 sdlBlit dst src xy = blitSurface src Nothing dst loc >> return () where
  75   (x :+ y) = xy
  76   (w,h) = (surfaceGetWidth src, surfaceGetHeight src)
  77   loc = Just (Rect (floor x) (floor y) w h)
  78
  79 loadSurface :: String -> IO Surface
  80 loadSurface filename = loadBMP filename
  81
  82 {-
  83 loadAllImages :: Video -> IO Video
  84 loadAllImages video = do
  85   (numbers, files) <- return ([],[])
  86   images <- forM files (loadImage video)
  87   let table = fromList (zip numbers images)
  88   return (video { vidImages = table })
  89 -}
  90
  91
  92 surfWH :: Surface -> Complex Double
  93 surfWH surf = fromIntegral (surfaceGetWidth surf) :+ fromIntegral (surfaceGetHeight surf)
  94
  95 sdlImage :: Surface -> Surface -> Image
  96 sdlImage screen surf = Image {
  97   imgWH = surfWH surf,
  98   imgApply = \xy -> sdlBlit screen surf xy
  99 }
 100
 101 glImage :: Int -> Rect -> Surface -> Image
 102 glImage n rect surf = Image {
 103   imgWH = surfWH surf,
 104   imgApply = \xy -> glQuad n rect xy
 105 }
 106