jort-1.0.0: Bitmaps.hs

module Bitmaps
    (Bitmap,
     module Data.Array,
     loadBitmap
    )
    where
    
import Basics
import Data.Array
import Graphics.UI.Gtk hiding (Color, Bitmap)
import Data.Array(Array, listArray)
import Data.Array.Base ( unsafeRead )
import Data.Array.MArray(newArray_, writeArray, unsafeFreeze)
import Data.Array.IO
import Data.Word


type Bitmap = Array (Int, Int) Color

pixbufGetPixelData :: Pixbuf -> IO (Array (Int, Int) (Word8, Word8, Word8))
pixbufGetPixelData pb =
  do
     rowstride <- pixbufGetRowstride pb
     w <- pixbufGetWidth pb
     h <- pixbufGetHeight pb
     chan <- pixbufGetNChannels pb
--      putStr "rowstride = " 
--      print rowstride
--      putStr "width = "
--      print w
--      putStr "height = "
--      print h  
     pixelData <- pixbufGetPixels pb :: IO (PixbufData Int Word8)
--      putStrLn "got pointer to pixels"
     pixels <- newArray_ ((0,0),(w,h))
     let pixels_type :: IOArray (Int,Int) (Word8, Word8, Word8)
	 pixels_type = pixels
         fetchPixel x y = do r <- unsafeRead pixelData (x*chan+y*rowstride+0)
                             g <- unsafeRead pixelData (x*chan+y*rowstride+1)
                             b <- unsafeRead pixelData (x*chan+y*rowstride+2)
			     writeArray pixels (x,y) $! 
                                            (fromIntegral r, fromIntegral g, fromIntegral b)
     sequence_ [fetchPixel x y | x <- [0..w], y <- [0..h]]
     unsafeFreeze pixels


loadBitmap fname = 
    do 
       putStrLn ("loading bitmap: " ++ fname)
       pb <- pixbufNewFromFile fname
       putStrLn "bitmap loaded; xlation..."
       pixels <- pixbufGetPixelData pb
       let result = fmap pixelToColor pixels
       return result
    where pixelToColor (r,g,b) = Color (f r/255) (f g/255) (f b/255)
	  f = fromIntegral

main =
     do
        initGUI
        bm <- loadBitmap "../rtrt/ciel.tif"
        print bm