mandulia-0.4: src/Image.hs

{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Image(Image(), iWidth, iHeight, iChannels, iBuffer, image, upload) where

import Foreign.Ptr(Ptr())
import Foreign.Marshal.Alloc(mallocBytes)

import Graphics.UI.GLUT

data Image =
  Image
    { iWidth    :: Int
    , iHeight   :: Int
    , iChannels :: Int
    , iBuffer   :: Ptr ()
    }

image :: Int -> Int -> Int -> IO Image
image w h c
  | w > 0 && h > 0 && c > 0 = do
    b <- mallocBytes $ w * h * c
    return Image{ iWidth = w, iHeight = h, iChannels = c, iBuffer = b }
  | otherwise = error $ "Image.image: " ++ show [w,h,c]

upload :: Image -> IO TextureObject
upload i
  | iChannels i == 4 = do
    [tex] <- genObjectNames 1
    texture Texture2D $= Enabled
    textureBinding Texture2D $= Just tex
    build2DMipmaps Texture2D RGBA' (fromIntegral $ iWidth i) (fromIntegral $ iHeight i) (PixelData RGBA UnsignedByte (iBuffer i))
    textureFilter  Texture2D $= ((Linear', Just Linear'), Linear')
    textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
    textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
    textureBinding Texture2D $= Nothing
    texture Texture2D $= Disabled
    return tex
  | otherwise = error $ "Image.upload: " ++ show (iChannels i)