diff --git a/Graphics/GD.hsc b/Graphics/GD.hsc --- a/Graphics/GD.hsc +++ b/Graphics/GD.hsc @@ -2,23 +2,24 @@ -- * Types Image, Size, Point, Color, -- * Creating and copying images - newImage, copyImage, + newImage, copyImage, + copyRegion, copyRegionScaled, -- * Memory management withImage, -- * Loading images -- ** JPEG - loadJpegFile, loadJpegData, + loadJpegFile, loadJpegData, loadJpegByteString, -- ** PNG - loadPngFile, loadPngData, + loadPngFile, loadPngData, loadPngByteString, -- ** GIF - loadGifFile, loadGifData, + loadGifFile, loadGifData, loadGifByteString, -- * Saving images -- ** JPEG - saveJpegFile, + saveJpegFile, saveJpegByteString, -- ** PNG - savePngFile, + savePngFile, savePngByteString, -- ** GIF - saveGifFile, + saveGifFile, saveGifByteString, -- * Getting image information imageSize, -- * Manipulating images @@ -31,16 +32,22 @@ drawArc, antiAliased, setPixel, + -- * Text + useFontConfig, + drawString, measureString, + drawStringCircle, -- * Colors rgb, rgba ) where import Control.Exception (bracket) import Control.Monad (liftM, unless) +import qualified Data.ByteString.Base as B import Foreign import Foreign.C import Foreign.ForeignPtr import Foreign.Marshal.Error +import System.IO.Error data CFILE = CFILE @@ -76,6 +83,8 @@ 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) -- PNG format @@ -88,6 +97,8 @@ 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) -- GIF format @@ -100,6 +111,8 @@ 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) -- Creating and destroying images @@ -159,7 +172,22 @@ foreign import ccall "gd.h gdImageSetPixel" gdImageSetPixel :: Ptr GDImage -> CInt -> CInt -> CInt -> IO () +-- Text functions +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 + +-- Miscellaneous functions + +foreign import ccall "gd.h &gdFree" gdFree + :: FunPtr (Ptr a -> IO ()) + -- We use a second level of indirection to allow storing a null pointer -- when the image has already been freed. This allows 'withImage' to -- free the @gdImage@ early. @@ -223,7 +251,30 @@ where f p = do (w,h) <- imageSize_ p onNewImage w h (\p' -> gdImageCopy p' p 0 0 0 0 w h) +-- | Copy a region of one image into another +copyRegion :: Point -- ^ Source upper left-hand corner + -> Size -- ^ Size of copied region + -> Image -- ^ Source image + -> Point -- ^ Destination upper left-hand corner + -> Image -- ^ Destination 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) +-- | Copy a region of one image into another, rescaling the region +copyRegionScaled :: Point -- ^ Source upper left-hand corner + -> Size -- ^ Size of source region + -> Image -- ^ Source image + -> Point -- ^ Destination upper left-hand corner + -> Size -- ^ Size of destination region + -> Image -- ^ Destination 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) -- -- * Loading images @@ -239,7 +290,11 @@ -> IO Image loadJpegData = loadImageData gdImageCreateFromJpegPtr +-- | Load a JPEG image from a ByteString +loadJpegByteString :: B.ByteString -> IO Image +loadJpegByteString = onByteStringData loadJpegData + -- | Load a PNG image from a file. loadPngFile :: FilePath -> IO Image loadPngFile = loadImageFile gdImageCreateFromPng @@ -250,6 +305,9 @@ -> IO Image loadPngData = loadImageData gdImageCreateFromPngPtr +-- | Load a PNG image from a ByteString +loadPngByteString :: B.ByteString -> IO Image +loadPngByteString = onByteStringData loadPngData -- | Load a GIF image from a file. loadGifFile :: FilePath -> IO Image @@ -261,7 +319,11 @@ -> IO Image loadGifData = loadImageData gdImageCreateFromGifPtr +-- | Load a GIF image from a ByteString +loadGifByteString :: B.ByteString -> IO Image +loadGifByteString = onByteStringData loadGifData + loadImageFile :: (Ptr CFILE -> IO (Ptr GDImage)) -> FilePath -> IO Image loadImageFile f file = do p <- throwIfNull ("Loading image from " ++ file) $ withCFILE file "rb" f @@ -272,6 +334,11 @@ do p <- 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) -> withForeignPtr fptr (\ptr -> f sz (plusPtr ptr start)) + -- -- * Saving images -- @@ -281,17 +348,38 @@ -> FilePath -> Image -> IO () saveJpegFile q = saveImageFile (\p h -> gdImageJpeg p h (fromIntegral q)) +-- | Write a JPEG format ByteString of an image. +saveJpegByteString :: Int -> Image -> IO B.ByteString +saveJpegByteString q = saveImageByteString (\p h -> gdImageJpegPtr p h (fromIntegral q)) + + -- | Save an image as a PNG file. savePngFile :: FilePath -> Image -> IO () savePngFile = saveImageFile gdImagePng +-- | Write a PNG format ByteString of an image. +savePngByteString :: Image -> IO B.ByteString +savePngByteString = saveImageByteString gdImagePngPtr + + -- | Save an image as a GIF file. saveGifFile :: FilePath -> Image -> IO () saveGifFile = saveImageFile gdImageGif +-- | Write a GIF format ByteString of an image. +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 = alloca $ \szPtr -> do datPtr <- f szPtr >>= newForeignPtr gdFree . castPtr + liftM (B.fromForeignPtr datPtr . fromIntegral) (peek szPtr) + -- -- * Getting information about images. -- @@ -389,6 +477,69 @@ gdImageSetPixel p (int x) (int y) c -- +-- * Text +-- + +-- | Globally switch from using font file names to fontconfig paths +-- | for fonts in drawString (and measureString). +useFontConfig :: Bool -> IO Bool +useFontConfig use = liftM (/= 0) $ gdFTUseFontConfig $ if use then 1 else 0 + +-- | Draw a string using the FreeType 2.x library +drawString :: String -- ^ Font name + -> Double -- ^ Font point size + -> Double -- ^ Angle in counterclockwise radians + -> Point -- ^ Origin + -> String -- ^ Text, including HTML entities + -> Color -> Image -> IO (Point, Point, Point, Point) -- ^ Bounding box of the drawn text +drawString fontName ptSize angle (oriX, oriY) txt color img + = withImagePtr img $ drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt + +-- | Measure a string using the FreeType 2.x library. This computes +-- the bounding box but does not actually draw the string to any +-- image. +measureString :: String -- ^ Font name + -> Double -- ^ Font point size + -> Double -- ^ Angle in counterclockwise radians + -> Point -- ^ Origin + -> String -- ^ Text, including HTML entities + -> Color -> IO (Point, Point, Point, Point) -- ^ Bounding box of the drawn text +measureString fontName ptSize angle (oriX, oriY) txt color + = drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt nullPtr + +drawStringImagePtr :: Color -> String -> Double -> Double -> Point -> String -> Ptr GDImage -> IO (Point, Point, Point, Point) +drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt imgPtr + = allocaArray 8 $ + \bboxPtr -> withCAString fontName $ + \cFontName -> withCAString txt $ + \cTxt -> do res <- gdImageStringFT imgPtr bboxPtr color cFontName (double ptSize) (double angle) (int oriX) (int oriY) cTxt + if res == nullPtr + then peekArray 8 bboxPtr >>= parseBBox + else 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 + +-- | Draw strings around the top and bottom of a torus +drawStringCircle :: Point -- ^ Center of text path circle + -> Double -- ^ Outer radius of text + -> Double -- ^ Fraction of radius occupied by text + -> Double -- ^ Portion of circle arc filled by text + -> String -- ^ Font name + -> Double -- ^ Font size hint + -> String -- ^ Text to write on the top of the circle + -> String -- ^ Text to write on the bottom of the circle + -> Color -- ^ Text color + -> Image -> IO () +drawStringCircle (ctrX, ctrY) rad textRad textFill fontName fontSize topTxt bottomTxt color img + = withCAString fontName $ + \cFontName -> withCAString topTxt $ + \cTopTxt -> 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 == nullPtr) (peekCAString res >>= ioError . userError) + +-- -- * Colors -- @@ -416,3 +567,6 @@ int :: (Integral a, Num b) => a -> b int = fromIntegral + +double :: (Real a, Fractional b) => a -> b +double = realToFrac diff --git a/gd.cabal b/gd.cabal --- a/gd.cabal +++ b/gd.cabal @@ -1,5 +1,5 @@ Name: gd -Version: 3000.2.0 +Version: 3000.3.0 Copyright: Bjorn Bringert Maintainer: bjorn@bringert.net Author: Bjorn Bringert @@ -12,7 +12,7 @@ the GD graphics library. Exposed-Modules: Graphics.GD ghc-options: -O2 -Wall -fffi -extra-libraries: gd, jpeg, m, png +extra-libraries: gd, png, z, jpeg, m, fontconfig, freetype, pthread, expat includes: gd.h include-dirs: cbits install-includes: gd-extras.h