Ticket #19: bmp-loader.dpatch

1 patch for repository /home/cdsmith/gloss-head-tmp:

Sun Aug  7 21:45:09 MDT 2011  Chris Smith <cdsmith@gmail.com>
  * Add BMP file loader

New patches:

[Add BMP file loader
Chris Smith <cdsmith@gmail.com>**20110808034509
 Ignore-this: dbe9f2941ebccf3844cd0b768c35c5df
] hunk ./library/Graphics/Gloss/Data/Picture.hs 15
        , pictures
 
        -- * Miscellaneous
+       , loadBMPFile
        , lineLoop
        , circleSolid
        
hunk ./library/Graphics/Gloss/Data/Picture.hs 26
 import Graphics.Gloss.Data.Color
 import Graphics.Gloss.Data.Point
 import Graphics.Gloss.Data.Vector
+import Control.Monad
 import Data.Monoid
hunk ./library/Graphics/Gloss/Data/Picture.hs 28
-import Data.ByteString
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
 
 
 -- | A path through the x-y plane.
hunk ./library/Graphics/Gloss/Data/Picture.hs 127
 pictures = Pictures
 
 
+-- BMP file loader ------------------------------------------------------------
+-- | An IO action that loads a BMP format file from the given path, and
+-- produces a picture.
+loadBMPFile :: FilePath -> IO Picture
+loadBMPFile fname = do
+    bs <- B.readFile fname
+    when (not (isBmp bs)) $ error (fname ++ ": not a bmp file"                      )
+    when (bpp  bs < 32)   $ error (fname ++ ": must be saved in 32-bit RGBA format" )
+    when (comp bs /= 0)   $ error (fname ++ ": must be saved in uncompressed format")
+    return (Bitmap (width bs) (height bs) (dat bs))
+  where range s n bs    = B.unpack (B.take n (B.drop s bs))
+        littleEndian ds = sum [ fromIntegral b * 256^k | (b,k) <- zip ds [(0 :: Int) ..] ]
+        isBmp bs        = littleEndian (range  0 2 bs) == (19778 :: Int)
+        pxOff bs        = littleEndian (range 10 4 bs) :: Int
+        width bs        = littleEndian (range 18 4 bs) :: Int
+        height bs       = littleEndian (range 22 4 bs) :: Int
+        bpp bs          = littleEndian (range 28 2 bs) :: Int
+        comp bs         = littleEndian (range 30 4 bs) :: Int
+        dat bs          = swapRB (B.take (4 * width bs * height bs)
+                                         (B.drop (pxOff bs) bs))
+        swapRB bs
+          | B.null bs   = B.empty
+          | otherwise   = let [b,g,r,a] = B.unpack (B.take 4 bs)
+                          in  B.pack [r,g,b,a] `B.append` swapRB (B.drop 4 bs)
+
+
 -- Shapes ----------------------------------------------------------------------------------------
 -- | A closed loop along this path.
 lineLoop :: Path -> Picture

Context:

[fix typo in docs
Chris Smith <cdsmith@gmail.com>**20110805043827
 Ignore-this: 5eaa3e5393395f8d976fb104aec34715
] 
[add circleSolid to export list
Chris Smith <cdsmith@gmail.com>**20110808024148
 Ignore-this: 62b8f994bd9f7a85fee0eb0524e84cb8
] 
[Add circleSolid
Chris Smith <cdsmith@gmail.com>**20110805044049
 Ignore-this: 1d64f38f77e704a85eabdf21afcac0cb
] 
[TAG Release 1.3.3.1
Ben Lippmeier <benl@ouroborus.net>**20110803064127
 Ignore-this: 66231bcec657fe6c21bb62dfe0dad8bf
] 
Patch bundle hash:
5871429b1e30cb8988b490c99dc8e6e945d2d8d1