diff --git a/Graphics/GD.hs b/Graphics/GD.hs new file mode 100644 --- /dev/null +++ b/Graphics/GD.hs @@ -0,0 +1,216 @@ +module Graphics.GD ( + -- * Types + Image, Size, Point, Color, + -- * Creating and copying images + newImage, copyImage, + copyRegion, copyRegionScaled, + -- * Memory management + withImage, + -- * Loading images + -- ** JPEG + loadJpegFile, loadJpegData, loadJpegByteString, + -- ** PNG + loadPngFile, loadPngData, loadPngByteString, + -- ** GIF + loadGifFile, loadGifData, loadGifByteString, + -- * Saving images + -- ** JPEG + saveJpegFile, saveJpegByteString, + -- ** PNG + savePngFile, savePngByteString, + -- ** GIF + saveGifFile, saveGifByteString, + -- * Getting image information + imageSize, + -- * Querying + getPixel, + -- * Manipulating images + resizeImage, rotateImage, + -- * Drawing + fillImage, + drawFilledRectangle, + drawFilledEllipse, + drawLine, + drawArc, + antiAliased, + setPixel, + -- * Text + useFontConfig, + drawString, + measureString, + drawStringCircle, + -- * Colors + rgb, rgba + ) where + +import Graphics.GD.Internal + +import qualified Data.ByteString.Internal as B +import Control.Monad (liftM,unless) +import Foreign +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Error +import System.IO.Error + +-- +-- * Loading images +-- + +-- | Load a JPEG image from a file. +loadJpegFile :: FilePath -> IO Image +loadJpegFile = loadImageFile gdImageCreateFromJpeg + +-- | Load a JPEG image from a buffer. +loadJpegData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> 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 + +-- | Load a PNG image from a buffer. +loadPngData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> 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 +loadGifFile = loadImageFile gdImageCreateFromGif + +-- | Load a GIF image from a buffer. +loadGifData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> 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 + mkImage p + +loadImageData :: (CInt -> Ptr a -> IO (Ptr GDImage)) -> Int -> Ptr a -> IO Image +loadImageData f sz buf = + 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 +-- + +-- | Save an image as a JPEG file. +saveJpegFile :: Int -- ^ quality: 0-95, or negative for default quality. + -> 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 0 . fromIntegral) (peek szPtr) + +-- +-- * Text +-- + +-- | 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) diff --git a/Graphics/GD/ByteString.hs b/Graphics/GD/ByteString.hs new file mode 100644 --- /dev/null +++ b/Graphics/GD/ByteString.hs @@ -0,0 +1,217 @@ +module Graphics.GD.ByteString ( + -- * Types + Image, Size, Point, Color, + -- * Creating and copying images + newImage, copyImage, + copyRegion, copyRegionScaled, + -- * Memory management + withImage, + -- * Loading images + -- ** JPEG + loadJpegFile, loadJpegData, loadJpegByteString, + -- ** PNG + loadPngFile, loadPngData, loadPngByteString, + -- ** GIF + loadGifFile, loadGifData, loadGifByteString, + -- * Saving images + -- ** JPEG + saveJpegFile, saveJpegByteString, + -- ** PNG + savePngFile, savePngByteString, + -- ** GIF + saveGifFile, saveGifByteString, + -- * Getting image information + imageSize, + -- * Querying + getPixel, + -- * Manipulating images + resizeImage, rotateImage, + -- * Drawing + fillImage, + drawFilledRectangle, + drawFilledEllipse, + drawLine, + drawArc, + antiAliased, + setPixel, + -- * Text + useFontConfig, + drawString, + measureString, + drawStringCircle, + -- * Colors + rgb, rgba + ) where + +import Graphics.GD.Internal + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI + +import Control.Monad (liftM,unless) +import Foreign +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Error + +-- +-- * Loading images +-- + +-- | Load a JPEG image from a file. +loadJpegFile :: FilePath -> IO Image +loadJpegFile = loadImageFile gdImageCreateFromJpeg + +-- | Load a JPEG image from a buffer. +loadJpegData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> 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 + +-- | Load a PNG image from a buffer. +loadPngData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> 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 +loadGifFile = loadImageFile gdImageCreateFromGif + +-- | Load a GIF image from a buffer. +loadGifData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> 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 + mkImage p + +loadImageData :: (CInt -> Ptr a -> IO (Ptr GDImage)) -> Int -> Ptr a -> IO Image +loadImageData f sz buf = + 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 BI.toForeignPtr bstr of + (fptr, start, sz) -> withForeignPtr fptr (\ptr -> f sz (plusPtr ptr start)) + +-- +-- * Saving images +-- + +-- | Save an image as a JPEG file. +saveJpegFile :: Int -- ^ quality: 0-95, or negative for default quality. + -> 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 (BI.fromForeignPtr datPtr 0 . fromIntegral) (peek szPtr) + +-- +-- * Text +-- + +-- | Draw a string using the FreeType 2.x library +drawString :: B.ByteString -- ^ Font name + -> Double -- ^ Font point size + -> Double -- ^ Angle in counterclockwise radians + -> Point -- ^ Origin + -> B.ByteString -- ^ 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 :: B.ByteString -- ^ Font name + -> Double -- ^ Font point size + -> Double -- ^ Angle in counterclockwise radians + -> Point -- ^ Origin + -> B.ByteString -- ^ 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 -> B.ByteString -> Double -> Double -> Point -> B.ByteString -> Ptr GDImage -> IO (Point, Point, Point, Point) +drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt imgPtr + = allocaArray 8 $ + \bboxPtr -> B.useAsCString fontName $ + \cFontName -> B.useAsCString 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 + -> B.ByteString -- ^ Font name + -> Double -- ^ Font size hint + -> B.ByteString -- ^ Text to write on the top of the circle + -> B.ByteString -- ^ 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 + = B.useAsCString fontName $ + \cFontName -> B.useAsCString topTxt $ + \cTopTxt -> B.useAsCString 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) diff --git a/Graphics/GD/ByteString/Lazy.hs b/Graphics/GD/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/Graphics/GD/ByteString/Lazy.hs @@ -0,0 +1,224 @@ +module Graphics.GD.ByteString.Lazy ( + -- * Types + Image, Size, Point, Color, + -- * Creating and copying images + newImage, copyImage, + copyRegion, copyRegionScaled, + -- * Memory management + withImage, + -- * Loading images + -- ** JPEG + loadJpegFile, loadJpegData, loadJpegByteString, + -- ** PNG + loadPngFile, loadPngData, loadPngByteString, + -- ** GIF + loadGifFile, loadGifData, loadGifByteString, + -- * Saving images + -- ** JPEG + saveJpegFile, saveJpegByteString, + -- ** PNG + savePngFile, savePngByteString, + -- ** GIF + saveGifFile, saveGifByteString, + -- * Getting image information + imageSize, + -- * Querying + getPixel, + -- * Manipulating images + resizeImage, rotateImage, + -- * Drawing + fillImage, + drawFilledRectangle, + drawFilledEllipse, + drawLine, + drawArc, + antiAliased, + setPixel, + -- * Text + useFontConfig, + drawString, + measureString, + drawStringCircle, + -- * Colors + rgb, rgba + ) where + +import Graphics.GD.Internal + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Internal as BI + +import Control.Monad (liftM,unless) +import Foreign +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Error + +-- +-- * Loading images +-- + +-- | Load a JPEG image from a file. +loadJpegFile :: FilePath -> IO Image +loadJpegFile = loadImageFile gdImageCreateFromJpeg + +-- | Load a JPEG image from a buffer. +loadJpegData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> IO Image +loadJpegData = loadImageData gdImageCreateFromJpegPtr + +-- | Load a JPEG image from a ByteString +loadJpegByteString :: L.ByteString -> IO Image +loadJpegByteString = onByteStringData loadJpegData + + +-- | Load a PNG image from a file. +loadPngFile :: FilePath -> IO Image +loadPngFile = loadImageFile gdImageCreateFromPng + +-- | Load a PNG image from a buffer. +loadPngData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> IO Image +loadPngData = loadImageData gdImageCreateFromPngPtr + +-- | Load a PNG image from a ByteString +loadPngByteString :: L.ByteString -> IO Image +loadPngByteString = onByteStringData loadPngData + +-- | Load a GIF image from a file. +loadGifFile :: FilePath -> IO Image +loadGifFile = loadImageFile gdImageCreateFromGif + +-- | Load a GIF image from a buffer. +loadGifData :: Int -- ^ Buffer size. + -> Ptr a -- ^ Buffer with image data. + -> IO Image +loadGifData = loadImageData gdImageCreateFromGifPtr + +-- | Load a GIF image from a ByteString +loadGifByteString :: L.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 + mkImage p + +loadImageData :: (CInt -> Ptr a -> IO (Ptr GDImage)) -> Int -> Ptr a -> IO Image +loadImageData f sz buf = + do p <- throwIfNull ("Loading image") $ f (fromIntegral sz) buf + mkImage p + +onByteStringData :: (Int -> Ptr a -> IO b) -> L.ByteString -> IO b +onByteStringData f bstr + = case BI.toForeignPtr (lazyToStrict bstr) of + (fptr, start, sz) -> withForeignPtr fptr (\ptr -> f sz (plusPtr ptr start)) + +lazyToStrict :: L.ByteString -> B.ByteString +lazyToStrict = foldr1 B.append . L.toChunks + +-- +-- * Saving images +-- + +-- | Save an image as a JPEG file. +saveJpegFile :: Int -- ^ quality: 0-95, or negative for default quality. + -> 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 L.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 L.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 L.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 (L.ByteString) +saveImageByteString f img = withImagePtr img (\p -> dataByteString (f p)) + +dataByteString :: (Ptr CInt -> IO (Ptr a)) -> IO L.ByteString +dataByteString f = alloca $ \szPtr -> do datPtr <- f szPtr >>= newForeignPtr gdFree . castPtr + liftM (L.fromChunks . return . BI.fromForeignPtr datPtr 0 . fromIntegral) (peek szPtr) + +-- +-- * Text +-- + +-- | Draw a ByteString using the FreeType 2.x library +drawString :: L.ByteString -- ^ Font name + -> Double -- ^ Font point size + -> Double -- ^ Angle in counterclockwise radians + -> Point -- ^ Origin + -> L.ByteString -- ^ 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 :: L.ByteString -- ^ Font name + -> Double -- ^ Font point size + -> Double -- ^ Angle in counterclockwise radians + -> Point -- ^ Origin + -> L.ByteString -- ^ 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 -> L.ByteString -> Double -> Double -> Point -> L.ByteString -> Ptr GDImage -> IO (Point, Point, Point, Point) +drawStringImagePtr color fontName ptSize angle (oriX, oriY) txt imgPtr + = allocaArray 8 $ + \bboxPtr -> toCStr fontName $ + \cFontName -> toCStr 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 + -> L.ByteString -- ^ Font name + -> Double -- ^ Font size hint + -> L.ByteString -- ^ Text to write on the top of the circle + -> L.ByteString -- ^ 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 + = toCStr fontName $ + \cFontName -> toCStr topTxt $ + \cTopTxt -> toCStr 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) + +toCStr :: L.ByteString -> (CString -> IO a) -> IO a +toCStr = B.useAsCString . lazyToStrict diff --git a/Graphics/GD/Internal.hsc b/Graphics/GD/Internal.hsc new file mode 100644 --- /dev/null +++ b/Graphics/GD/Internal.hsc @@ -0,0 +1,382 @@ +module Graphics.GD.Internal where + +import Control.Exception (bracket) +import Control.Monad (liftM, unless) +import Foreign +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Error + +data CFILE = 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 = + throwErrnoIfNull file $ withCString file $ + \f -> withCString mode $ \m -> c_fopen f m + +fclose :: Ptr CFILE -> IO () +fclose p = throwErrnoIf_ (== #{const EOF}) "fclose" $ c_fclose p + +withCFILE :: FilePath -> String -> (Ptr CFILE -> IO a) -> IO a +withCFILE file mode = bracket (fopen file mode) fclose + +#include +#include "gd-extras.h" + +data GDImage = GDImage + +-- JPEG format + +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) + +-- PNG format + +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) + +-- GIF format + +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) + +-- Creating and destroying images + +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 ()) + + +-- Copying image parts + +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.h gdImageCopyRotated" gdImageCopyRotated + :: Ptr GDImage -> Ptr GDImage + -> CDouble -> CDouble -> 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 + +-- Drawing functions + +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 () + +-- 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. +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 <- mallocForeignPtr + withForeignPtr fp $ \p -> poke p img + addForeignPtrFinalizer ptr_gdImagePtrDestroyIfNotNull fp + return $ Image fp + +-- | Creates an image, performs an operation on the image, and +-- frees it. +-- This function allows block scoped management of 'Image' objects. +-- If you are handling large images, the delay before the finalizer which frees +-- the image runs may cause significant temporary extra memory use. +-- Use this function to force the image to be freed as soons as you are done with it. +-- Note that it is unsafe to hold on to the 'Image' after the +-- function is done. +withImage :: IO Image -- ^ Image creation action. + -> (Image -> IO b) -- ^ Some operation on the image. The result should + -- not reference the 'Image'. + -> IO b +withImage ini f = bracket ini freeImage f + +-- | Overwrites the pointer with a null pointer, and frees the @gdImage@. +-- Safe to call twice. Doesn't free the 'ForeignPtr', we rely on the +-- GC to do that. +freeImage :: Image -> IO () +freeImage (Image fp) = withForeignPtr fp $ + \pp -> do p <- peek pp + poke pp nullPtr + unless (p == nullPtr) $ gdImageDestroy p + +withImagePtr :: Image -> (Ptr GDImage -> IO a) -> IO a +withImagePtr (Image fp) f = withForeignPtr fp $ + \pp -> peek pp >>= \p -> if p == nullPtr then fail "Image has been freed." else f p + +-- | Create a new empty image. +newImage :: Size -> IO Image +newImage (w,h) = newImage_ (int w) (int h) + +newImage_ :: CInt -> CInt -> IO Image +newImage_ w h = do p <- throwIfNull "gdImageCreateTrueColor" $ + gdImageCreateTrueColor w h + mkImage p + +-- | Create a new empty image and apply a function to it. +onNewImage :: CInt -> CInt -> (Ptr GDImage -> IO a) -> IO Image +onNewImage w h f = newImage_ w h >>= \i -> withImagePtr i f >> return i + +-- | Make a copy of an image. +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) + +-- | 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) + +-- +-- * Querying +-- + +-- | Retrieves the color index or the color values of a particular pixel. +getPixel :: (Int,Int) -> Image -> IO Color +getPixel (x,y) i = withImagePtr i f + where f p' = gdImageGetPixel p' (int x) (int y) + +-- +-- * Getting information about images. +-- + +-- | Get the size of an image. +imageSize :: Image -> IO (Int,Int) -- ^ (width, height) +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 <- #{peek gdImage, sx} p + h <- #{peek gdImage, sy} p + return (w, h) + +-- +-- * Transforming images. +-- + +-- | Resize an image to a give size. +resizeImage :: Int -- ^ width in pixels of output image + -> Int -- ^ height in pixels of output image + -> 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 + +-- | Rotate an image by a multiple of 90 degrees counter-clockwise. +rotateImage :: Int -- ^ 1 for 90 degrees counter-clockwise, + -- 2 for 180 degrees, etc. + -> 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 inW-1 else 0; + srcY = if q == 2 || q == 3 then inH-1 else 0; + onNewImage outW outH (\p' -> + gdImageCopyRotated90 p' p 0 0 srcX srcY inW inH q) + +-- +-- * Drawing +-- + +-- | Fill the entire image with the given color. +fillImage :: Color -> Image -> IO () +fillImage c i = do sz <- imageSize i + drawFilledRectangle (0,0) sz c i + +drawFilledRectangle :: Point -- ^ Upper left corner + -> Point -- ^ Lower right corner + -> 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 -- ^ Center + -> Size -- ^ Width and height + -> 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 -- ^ Start + -> Point -- ^ End + -> 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 -- ^ Center + -> Size -- ^ Width and height + -> Int -- ^ Starting position (degrees) + -> Int -- ^ Ending position (degrees) + -> 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 + +-- | Use anti-aliasing when performing the given drawing function. +-- This can cause a segault with some gd versions. +antiAliased :: (Color -> Image -> IO a) -> Color -> Image -> IO a +antiAliased f c i = + do withImagePtr i (\p -> gdImageSetAntiAliased p c) + f (#{const gdAntiAliased}) i + +setPixel :: Point -> Color -> Image -> IO () +setPixel (x,y) c i = + withImagePtr i $ \p -> + gdImageSetPixel p (int x) (int y) c + +-- +-- * Colors +-- + +rgb :: Int -- ^ Red (0-255) + -> Int -- ^ Green (0-255) + -> Int -- ^ Blue (0-255) + -> Color +rgb r g b = rgba r g b 0 + +rgba :: Int -- ^ Red (0-255) + -> Int -- ^ Green (0-255) + -> Int -- ^ Blue (0-255) + -> Int -- ^ Alpha (0-127), 0 is opaque, 127 is transparent + -> Color +rgba r g b a = + (int a `shiftL` 24) .|. + (int r `shiftL` 16) .|. + (int g `shiftL` 8) .|. + int b + +-- +-- * 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 + +-- +-- * Utilities +-- + +int :: (Integral a, Num b) => a -> b +int = fromIntegral + +double :: (Real a, Fractional b) => a -> b +double = realToFrac diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runghc + +import Distribution.Simple +main = defaultMain diff --git a/cbits/gd-extras.c b/cbits/gd-extras.c new file mode 100644 --- /dev/null +++ b/cbits/gd-extras.c @@ -0,0 +1,83 @@ +#include +#include "gd-extras.h" + +BGD_DECLARE(void) gdImagePtrDestroyIfNotNull (gdImagePtr *imp) +{ + gdImagePtr im = *imp; + if (im) { + gdImageDestroy(im); + } +} + +BGD_DECLARE(void) gdImageCopyRotated90 (gdImagePtr dst, + gdImagePtr src, + int dstX, int dstY, + int srcX, int srcY, + int srcW, int srcH, int quadrants) +{ + int dx, dy; + /* make sure it's 0-3 */ + int q = (4 + quadrants % 4) % 4; + int even = q % 2 == 0; + int cos_q = even ? 1 - q : 0; + int sin_q = even ? 0 : 2 - q; + + /* hack for figuring out destination width */ + int dstW = even ? srcW : srcH; + int dstH = even ? srcH : srcW; + + int cmap[gdMaxColors]; + int i; + for (i = 0; (i < gdMaxColors); i++) + { + cmap[i] = (-1); + } + + for (dy = 0; (dy < dstH); dy++) + { + for (dx = 0; (dx < dstW); dx++) + { + int sx = srcX + cos_q * dx - sin_q * dy; + int sy = srcY + sin_q * dx + cos_q * dy; + if ((sx >= 0) && (sx < srcW) && + (sy >= 0) && (sy < srcH)) + { + int c = gdImageGetPixel (src, sx, sy); + + if (!src->trueColor) + { + /* Use a table to avoid an expensive + lookup on every single pixel */ + if (cmap[c] == -1) + { + cmap[c] = gdImageColorResolveAlpha (dst, + gdImageRed (src, c), + gdImageGreen (src, + c), + gdImageBlue (src, + c), + gdImageAlpha (src, + c)); + } + gdImageSetPixel (dst, dstX + dx, dstY + dy, cmap[c]); + } + else + { + gdImageSetPixel (dst, + dstX + dx, dstY + dy, + gdImageColorResolveAlpha (dst, + gdImageRed (src, + c), + gdImageGreen + (src, c), + gdImageBlue (src, + c), + gdImageAlpha + (src, c))); + } + + } + } + } + +} diff --git a/cbits/gd-extras.h b/cbits/gd-extras.h new file mode 100644 --- /dev/null +++ b/cbits/gd-extras.h @@ -0,0 +1,24 @@ +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef GD_EXTRAS_H +#define G_DEXTRAS_H 1 + +#include + +BGD_DECLARE(void) gdImagePtrDestroyIfNotNull (gdImagePtr *im); + +BGD_DECLARE(void) gdImageCopyRotated90 (gdImagePtr dst, + gdImagePtr src, + int dstX, int dstY, + int srcX, int srcY, + int srcW, int srcH, int quadrants); + + + +#endif + +#ifdef __cplusplus +} +#endif diff --git a/gd.cabal b/gd.cabal new file mode 100644 --- /dev/null +++ b/gd.cabal @@ -0,0 +1,34 @@ +Name: gd +Category: Graphics +License-File: LICENSE +Version: 1000.0 +Cabal-version: >= 1.2 +Build-type: Simple +Copyright: Bjorn Bringert +Maintainer: chrisdone@gmail.com +Author: Bjorn Bringert +License: BSD3 +Synopsis: A Haskell binding to a subset of the GD graphics library +Description: + This is a binding to a (currently very small) subset of + the GD graphics library. +Extra-source-files: cbits/gd-extras.h + +Flag bytestring-in-base + +Library + if flag(bytestring-in-base) + -- bytestring was in base-2.0 and 2.1.1 + Build-depends: base >= 2.0 && < 2.2 + else + -- in base 1.0 and 3.0 bytestring is a separate package + Build-depends: base < 2.0 || >= 3, bytestring >= 0.9 + Extensions: ForeignFunctionInterface + Exposed-Modules: Graphics.GD, Graphics.GD.ByteString, Graphics.GD.ByteString.Lazy + Ghc-options: -Wall + Extra-libraries: gd, png, z, jpeg, m, fontconfig, freetype, expat + Includes: gd.h + Include-dirs: cbits + Install-includes: gd-extras.h + C-sources: cbits/gd-extras.c + Other-modules: Graphics.GD.Internal