module Graphics.GD (
Image, Size, Point, Color, PCREOption(..),
newImage, copyImage,
copyRegion, copyRegionScaled,
withImage,
loadJpegFile, loadJpegData, loadJpegByteString,
loadPngFile, loadPngData, loadPngByteString,
loadGifFile, loadGifData, loadGifByteString,
saveJpegFile, saveJpegByteString,
savePngFile, savePngByteString,
saveGifFile, saveGifByteString,
imageSize,
getPixel,
resizeImage, rotateImage,
brushed,
setBrush,
fillImage,
drawFilledRectangle,
drawFilledEllipse,
drawLine,
drawArc,
antiAliased,
setPixel,
colorAllocate,
useFontConfig,
drawString, measureString,
drawStringCircle,
rgb, rgba, toRGBA,
saveAlpha,
alphaBlending,
) where
import Control.Exception (bracket)
import Control.Monad (liftM, unless)
import Data.Bits
import qualified Data.ByteString.Internal as B
import Foreign (Ptr,FunPtr,ForeignPtr)
import Foreign (peekByteOff)
import qualified Foreign as F
import Foreign.C (CString)
import qualified Foreign.C as C
import Foreign.C.Types
data CFILE
foreign import ccall "stdio.h fopen" c_fopen
:: CString -> CString -> IO (Ptr CFILE)
foreign import ccall "stdio.h fclose" c_fclose
:: Ptr CFILE -> IO CInt
fopen :: FilePath -> String -> IO (Ptr CFILE)
fopen file mode =
C.throwErrnoIfNull file $ C.withCString file $
\f -> C.withCString mode $ \m -> c_fopen f m
fclose :: Ptr CFILE -> IO ()
fclose p = C.throwErrnoIf_ (== 1) "fclose" $ c_fclose p
withCFILE :: FilePath -> String -> (Ptr CFILE -> IO a) -> IO a
withCFILE file mode = bracket (fopen file mode) fclose
data GDImage
foreign import ccall "gd.h gdImageCreateFromJpeg" gdImageCreateFromJpeg
:: Ptr CFILE -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImageCreateFromJpegPtr" gdImageCreateFromJpegPtr
:: CInt -> Ptr a -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImageJpeg" gdImageJpeg
:: Ptr GDImage -> Ptr CFILE -> CInt -> IO ()
foreign import ccall "gd.h gdImageJpegPtr" gdImageJpegPtr
:: Ptr GDImage -> Ptr CInt -> CInt -> IO (Ptr a)
foreign import ccall "gd.h gdImageCreateFromPng" gdImageCreateFromPng
:: Ptr CFILE -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImageCreateFromPngPtr" gdImageCreateFromPngPtr
:: CInt -> Ptr a -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImagePng" gdImagePng
:: Ptr GDImage -> Ptr CFILE -> IO ()
foreign import ccall "gd.h gdImagePngPtr" gdImagePngPtr
:: Ptr GDImage -> Ptr CInt -> IO (Ptr a)
foreign import ccall "gd.h gdImageCreateFromGif" gdImageCreateFromGif
:: Ptr CFILE -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImageCreateFromGifPtr" gdImageCreateFromGifPtr
:: CInt -> Ptr a -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImageGif" gdImageGif
:: Ptr GDImage -> Ptr CFILE -> IO ()
foreign import ccall "gd.h gdImageGifPtr" gdImageGifPtr
:: Ptr GDImage -> Ptr CInt -> IO (Ptr a)
foreign import ccall "gd.h gdImageCreateTrueColor" gdImageCreateTrueColor
:: CInt -> CInt -> IO (Ptr GDImage)
foreign import ccall "gd.h gdImageDestroy" gdImageDestroy
:: Ptr GDImage -> IO ()
foreign import ccall "gd-extras.h &gdImagePtrDestroyIfNotNull"
ptr_gdImagePtrDestroyIfNotNull
:: FunPtr (Ptr (Ptr GDImage) -> IO ())
foreign import ccall "gd.h gdImageCopy" gdImageCopy
:: Ptr GDImage -> Ptr GDImage
-> CInt -> CInt -> CInt -> CInt
-> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageCopyResampled" gdImageCopyResampled
:: Ptr GDImage -> Ptr GDImage
-> CInt -> CInt -> CInt -> CInt
-> CInt -> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd-extras.h gdImageCopyRotated90" gdImageCopyRotated90
:: Ptr GDImage -> Ptr GDImage
-> CInt -> CInt -> CInt -> CInt
-> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageGetPixel" gdImageGetPixel
:: Ptr GDImage -> CInt -> CInt -> IO CInt
foreign import ccall "gd.h gdImageSetBrush" gdImageSetBrush
:: Ptr GDImage -> Ptr GDImage -> IO ()
foreign import ccall "gd.h gdImageFilledRectangle" gdImageFilledRectangle
:: Ptr GDImage -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageFilledEllipse" gdImageFilledEllipse
:: Ptr GDImage -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageLine" gdImageLine
:: Ptr GDImage -> CInt -> CInt -> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageArc" gdImageArc
:: Ptr GDImage -> CInt -> CInt -> CInt -> CInt
-> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageSetAntiAliased" gdImageSetAntiAliased
:: Ptr GDImage -> CInt -> IO ()
foreign import ccall "gd.h gdImageSetPixel" gdImageSetPixel
:: Ptr GDImage -> CInt -> CInt -> CInt -> IO ()
foreign import ccall "gd.h gdImageColorAllocate" gdImageColorAllocate
:: Ptr GDImage -> CInt -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "gd.h gdFTUseFontConfig" gdFTUseFontConfig
:: CInt -> IO CInt
foreign import ccall "gd.h gdImageStringFT" gdImageStringFT
:: Ptr GDImage -> Ptr CInt -> CInt -> CString -> CDouble -> CDouble ->
CInt -> CInt -> CString -> IO CString
foreign import ccall "gd.h gdImageStringFTCircle" gdImageStringFTCircle
:: Ptr GDImage -> CInt -> CInt -> CDouble -> CDouble -> CDouble -> CString
-> CDouble -> CString -> CString -> CInt -> IO CString
foreign import ccall "gd.h &gdFree" gdFree
:: FunPtr (Ptr a -> IO ())
toRGBA :: Color -> (Int, Int, Int, Int)
toRGBA c = (fromIntegral r, fromIntegral g, fromIntegral b, fromIntegral a)
where
b = c `mod` byte
g = shiftR c 8 `mod` byte
r = shiftR c 16 `mod` byte
a = shiftR c 24 `mod` byte
byte = 2 ^ (8::Int)
foreign import ccall "gd.h gdImageSaveAlpha" gdImageSaveAlpha
:: Ptr GDImage -> CInt -> IO ()
foreign import ccall "gd.h gdImageAlphaBlending" gdImageAlphaBlending
:: Ptr GDImage -> CInt -> IO ()
newtype PCREOption = PCREOption { unPCREOption :: CInt }
deriving (Eq,Show)
newtype Image = Image (ForeignPtr (Ptr GDImage))
type Size = (Int,Int)
type Point = (Int,Int)
type Color = CInt
mkImage :: Ptr GDImage -> IO Image
mkImage img = do fp <- F.mallocForeignPtr
F.withForeignPtr fp $ \p -> F.poke p img
F.addForeignPtrFinalizer ptr_gdImagePtrDestroyIfNotNull fp
return $ Image fp
withImage :: IO Image
-> (Image -> IO b)
-> IO b
withImage ini f = bracket ini freeImage f
freeImage :: Image -> IO ()
freeImage (Image fp) = F.withForeignPtr fp $
\pp -> do p <- F.peek pp
F.poke pp F.nullPtr
unless (p == F.nullPtr) $ gdImageDestroy p
withImagePtr :: Image -> (Ptr GDImage -> IO a) -> IO a
withImagePtr (Image fp) f = F.withForeignPtr fp $
\pp -> F.peek pp >>= \p ->
if p == F.nullPtr then fail "Image has been freed." else f p
newImage :: Size -> IO Image
newImage (w,h) = newImage_ (int w) (int h)
newImage_ :: CInt -> CInt -> IO Image
newImage_ w h = do p <- F.throwIfNull "gdImageCreateTrueColor" $
gdImageCreateTrueColor w h
mkImage p
onNewImage :: CInt -> CInt -> (Ptr GDImage -> IO a) -> IO Image
onNewImage w h f = newImage_ w h >>= \i -> withImagePtr i f >> return i
copyImage :: Image -> IO Image
copyImage i = withImagePtr i f
where f p = do (w,h) <- imageSize_ p
onNewImage w h (\p' -> gdImageCopy p' p 0 0 0 0 w h)
copyRegion :: Point
-> Size
-> Image
-> Point
-> Image
-> IO ()
copyRegion (srcX, srcY) (w, h) srcIPtr (dstX, dstY) dstIPtr
= withImagePtr dstIPtr $
\dstImg -> withImagePtr srcIPtr $
\srcImg -> gdImageCopy dstImg srcImg
(int dstX) (int dstY) (int srcX) (int srcY) (int w) (int h)
copyRegionScaled :: Point
-> Size
-> Image
-> Point
-> Size
-> Image
-> IO ()
copyRegionScaled (srcX,srcY) (srcW,srcH) srcIPtr (dstX,dstY) (dstW,dstH) dstIPtr
= withImagePtr dstIPtr $
\dstImg -> withImagePtr srcIPtr $
\srcImg -> gdImageCopyResampled dstImg srcImg
(int dstX) (int dstY) (int srcX) (int srcY)
(int dstW) (int dstH) (int srcW) (int srcH)
loadJpegFile :: FilePath -> IO Image
loadJpegFile = loadImageFile gdImageCreateFromJpeg
loadJpegData :: Int
-> Ptr a
-> IO Image
loadJpegData = loadImageData gdImageCreateFromJpegPtr
loadJpegByteString :: B.ByteString -> IO Image
loadJpegByteString = onByteStringData loadJpegData
loadPngFile :: FilePath -> IO Image
loadPngFile = loadImageFile gdImageCreateFromPng
loadPngData :: Int
-> Ptr a
-> IO Image
loadPngData = loadImageData gdImageCreateFromPngPtr
loadPngByteString :: B.ByteString -> IO Image
loadPngByteString = onByteStringData loadPngData
loadGifFile :: FilePath -> IO Image
loadGifFile = loadImageFile gdImageCreateFromGif
loadGifData :: Int
-> Ptr a
-> IO Image
loadGifData = loadImageData gdImageCreateFromGifPtr
loadGifByteString :: B.ByteString -> IO Image
loadGifByteString = onByteStringData loadGifData
loadImageFile :: (Ptr CFILE -> IO (Ptr GDImage)) -> FilePath -> IO Image
loadImageFile f file = do
p <- F.throwIfNull ("Loading image from " ++ file) $ withCFILE file "rb" f
mkImage p
loadImageData :: (CInt -> Ptr a -> IO (Ptr GDImage)) -> Int -> Ptr a -> IO Image
loadImageData f sz buf = do
p <- F.throwIfNull ("Loading image") $ f (fromIntegral sz) buf
mkImage p
onByteStringData :: (Int -> Ptr a -> IO b) -> B.ByteString -> IO b
onByteStringData f bstr =
case B.toForeignPtr bstr of
(fptr, start, sz) -> F.withForeignPtr fptr $
\ptr -> f sz (F.plusPtr ptr start)
saveJpegFile :: Int
-> FilePath -> Image -> IO ()
saveJpegFile q = saveImageFile (\p h -> gdImageJpeg p h (fromIntegral q))
saveJpegByteString :: Int -> Image -> IO B.ByteString
saveJpegByteString q =
saveImageByteString (\p h -> gdImageJpegPtr p h (fromIntegral q))
savePngFile :: FilePath -> Image -> IO ()
savePngFile = saveImageFile gdImagePng
savePngByteString :: Image -> IO B.ByteString
savePngByteString = saveImageByteString gdImagePngPtr
saveGifFile :: FilePath -> Image -> IO ()
saveGifFile = saveImageFile gdImageGif
saveGifByteString :: Image -> IO B.ByteString
saveGifByteString = saveImageByteString gdImageGifPtr
saveImageFile :: (Ptr GDImage -> Ptr CFILE -> IO ())
-> FilePath -> Image -> IO ()
saveImageFile f file i = withImagePtr i (\p -> withCFILE file "wb" (f p))
saveImageByteString :: (Ptr GDImage -> Ptr CInt -> IO (Ptr a)) -> Image
-> IO (B.ByteString)
saveImageByteString f img = withImagePtr img (\p -> dataByteString (f p))
dataByteString :: (Ptr CInt -> IO (Ptr a)) -> IO B.ByteString
dataByteString f = F.alloca $ \szPtr -> do
datPtr <- f szPtr >>= F.newForeignPtr gdFree . F.castPtr
liftM (B.fromForeignPtr datPtr 0 . fromIntegral) (F.peek szPtr)
getPixel :: (Int,Int) -> Image -> IO Color
getPixel (x,y) i = withImagePtr i f
where f p' = gdImageGetPixel p' (int x) (int y)
imageSize :: Image -> IO (Int,Int)
imageSize i = liftM f $ withImagePtr i imageSize_
where f = (\ (w,h) -> (fromIntegral w, fromIntegral h))
imageSize_ :: Ptr GDImage -> IO (CInt,CInt)
imageSize_ p = do w <- (\hsc_ptr -> peekByteOff hsc_ptr 4) p
h <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
return (w, h)
resizeImage :: Int
-> Int
-> Image
-> IO Image
resizeImage w h i = withImagePtr i f
where
f p = do let (outW,outH) = (fromIntegral w, fromIntegral h)
(inW, inH) <- imageSize_ p
onNewImage outW outH $ \p' ->
gdImageCopyResampled p' p 0 0 0 0 outW outH inW inH
rotateImage :: Int
-> Image
-> IO Image
rotateImage r i = withImagePtr i f
where f p = do (inW,inH) <- imageSize_ p
let q = fromIntegral (r `mod` 4)
(outW,outH) | r `mod` 2 == 0 = (inW,inH)
| otherwise = (inH,inW)
srcX = if q == 1 || q == 2 then inW1 else 0;
srcY = if q == 2 || q == 3 then inH1 else 0;
onNewImage outW outH (\p' ->
gdImageCopyRotated90 p' p 0 0 srcX srcY inW inH q)
brushed :: PCREOption
brushed = PCREOption (3)
setBrush :: Image
-> Image
-> IO ()
setBrush i b =
withImagePtr b $
\brushImg -> withImagePtr i $
\srcImg -> gdImageSetBrush srcImg brushImg
fillImage :: Color -> Image -> IO ()
fillImage c i = do sz <- imageSize i
drawFilledRectangle (0,0) sz c i
drawFilledRectangle :: Point
-> Point
-> Color -> Image -> IO ()
drawFilledRectangle (x1,y1) (x2,y2) c i =
withImagePtr i $ \p ->
gdImageFilledRectangle p (int x1) (int y1) (int x2) (int y2) c
drawFilledEllipse :: Point
-> Size
-> Color -> Image -> IO ()
drawFilledEllipse (cx,cy) (w,h) c i =
withImagePtr i $ \p ->
gdImageFilledEllipse p (int cx) (int cy) (int w) (int h) c
drawLine :: Point
-> Point
-> Color -> Image -> IO ()
drawLine (x1,y1) (x2,y2) c i =
withImagePtr i $ \p ->
gdImageLine p (int x1) (int y1) (int x2) (int y2) c
drawArc :: Point
-> Size
-> Int
-> Int
-> Color -> Image -> IO ()
drawArc (cx,cy) (w,h) sp ep c i =
withImagePtr i $ \p ->
gdImageArc p (int cx) (int cy) (int w) (int h) (int sp) (int ep) c
antiAliased :: (Color -> Image -> IO a) -> Color -> Image -> IO a
antiAliased f c i =
do withImagePtr i (\p -> gdImageSetAntiAliased p c)
f (7) i
setPixel :: Point -> Color -> Image -> IO ()
setPixel (x,y) c i =
withImagePtr i $ \p ->
gdImageSetPixel p (int x) (int y) c
colorAllocate :: CInt -> CInt -> CInt -> CInt -> Image -> IO Color
colorAllocate r g b a i =
withImagePtr i $ \p ->
gdImageColorAllocate p r g b a
useFontConfig :: Bool -> IO Bool
useFontConfig use = liftM (/= 0) $ gdFTUseFontConfig $ if use then 1 else 0
drawString :: String
-> Double
-> Double
-> Point
-> String
-> Color -> Image
-> IO (Point, Point, Point, Point)
drawString fontName ptSize angle (oriX, oriY) txt color img
= withImagePtr img $
drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt
measureString :: String
-> Double
-> Double
-> Point
-> String
-> Color
-> IO (Point, Point, Point, Point)
measureString fontName ptSize angle (oriX, oriY) txt color
= drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt F.nullPtr
drawStringImagePtr :: Color -> String -> Double -> Double -> Point -> String ->
Ptr GDImage -> IO (Point, Point, Point, Point)
drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt imgPtr
= F.allocaArray 8 $
\bboxPtr -> C.withCAString fontName $
\cFontName -> C.withCAString txt $
\cTxt -> do res <- gdImageStringFT imgPtr bboxPtr color cFontName
(double ptSize) (double angle)
(int oriX) (int oriY) cTxt
if res == F.nullPtr
then F.peekArray 8 bboxPtr >>= parseBBox
else C.peekCAString res >>= ioError . userError
where parseBBox l =
case map int l of
[llx, lly, lrx, lry, urx, ury, ulx, uly] ->
return ((llx, lly), (lrx, lry), (urx, ury), (ulx, uly))
_ -> ioError $ userError $
"parseBBox with /= 8 elements: " ++ show l
drawStringCircle :: Point
-> Double
-> Double
-> Double
-> String
-> Double
-> String
-> String
-> Color
-> Image -> IO ()
drawStringCircle (ctrX, ctrY) rad textRad textFill fontName
fontSize topTxt bottomTxt color img
= C.withCAString fontName $
\cFontName -> C.withCAString topTxt $
\cTopTxt -> C.withCAString bottomTxt $
\cBottomTxt -> withImagePtr img $
\imgPtr -> do
res <- gdImageStringFTCircle imgPtr
(int ctrX) (int ctrY) (double rad) (double textRad)
(double textFill) cFontName (double fontSize)
cTopTxt cBottomTxt color
unless (res == F.nullPtr) (C.peekCAString res >>= ioError . userError)
saveAlpha :: Bool -> Image -> IO ()
saveAlpha b i = withImagePtr i $ \p -> gdImageSaveAlpha p $ if b then 1 else 0
alphaBlending :: Bool -> Image -> IO ()
alphaBlending b i = withImagePtr i $ \p -> gdImageAlphaBlending p $ if b then 1 else 0
rgb :: Int
-> Int
-> Int
-> Color
rgb r g b = rgba r g b 0
rgba :: Int
-> Int
-> Int
-> Int
-> Color
rgba r g b a =
(int a `F.shiftL` 24) .|.
(int r `F.shiftL` 16) .|.
(int g `F.shiftL` 8) .|.
int b
int :: (Integral a, Num b) => a -> b
int = fromIntegral
double :: (Real a, Fractional b) => a -> b
double = realToFrac