module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage, pingImage,
readInlineImage,
getFilename,
blobToImage,
imageToBlob,
flipImage,
flopImage,
rotateImage,
affineTransform,
shearImage,
chopImage,
cropImage,
flattenImage,
mosaic,
rollImage,
shaveImage,
scaleImage,
magnifyImage,
minifyImage,
sampleImage,
thumbnailImage,
resizeImage,
contrastImage,
equalizeImage,
gammaImage,
levelImage,
levelImageChannel,
modulateImage,
negateImage,
normalizeImage,
constituteImage,
dispatchImage,
--exportPixelImageArea,
importPixelImageArea,
compositeImage,
allocateImage,
setImageColormap,
newImageColormap,
appendImages,
averageImages,
cycleColormapImage,
destroyImage,
animateImages) where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Graphics.Transform.Magick.Magick
import Graphics.Transform.Magick.Types
import Graphics.Transform.Magick.FFIHelpers
import Graphics.Transform.Magick.Errors
import Graphics.Transform.Magick.Util
import Data.Char
import Data.List
import System.Directory
readImage :: FilePath -> IO HImage
writeImage :: FilePath -> HImage -> IO ()
pingImage :: FilePath -> IO HImage
initializeMagick :: IO ()
flipImage, flopImage :: HImage -> HImage
rotateImage :: Double -> HImage -> HImage
affineTransform :: AffineMatrix -> HImage -> HImage
shearImage :: Double -> Double -> HImage -> HImage
chopImage, cropImage :: Rectangle -> HImage -> HImage
flattenImage :: [HImage] -> HImage
mosaic :: [(HImage, Rectangle)] -> HImage
rollImage :: Int -> Int -> HImage -> HImage
shaveImage :: Rectangle -> HImage -> HImage
scaleImage, sampleImage, thumbnailImage :: Word -> Word -> HImage -> HImage
magnifyImage, minifyImage :: HImage -> HImage
resizeImage :: Int -> Int -> FilterTypes -> Double -> HImage -> HImage
contrastImage :: Contrast -> HImage -> HImage
equalizeImage, normalizeImage :: HImage -> HImage
gammaImage :: PixelPacket Double -> HImage -> HImage
levelImage :: Level -> HImage -> HImage
levelImageChannel :: ChannelType -> Level -> HImage -> HImage
modulateImage :: Modulation -> HImage -> HImage
negateImage :: Negation -> HImage -> HImage
constituteImage :: (StorablePixel a b) => PixMap -> [[a]] -> HImage
dispatchImage :: (StorablePixel a b) => PixMap -> StorageType -> Rectangle ->
HImage -> [[a]]
importPixelImageArea :: QuantumType2 -> Word -> [[Word8]] ->
Maybe ImportPixelAreaOptions -> HImage -> HImage
readInlineImage :: String -> HImage
compositeImage :: CompositeOp -> Int -> Int -> HImage -> HImage -> HImage
allocateImage :: ImageNotLoaded -> HImage
setImageColormap :: Word32 -> HImage -> HImage
newImageColormap :: Word32 -> HImage
appendImages :: ImageOrder -> [HImage] -> HImage
averageImages :: [HImage] -> HImage
cycleColormapImage :: Int -> HImage -> HImage
destroyImage :: HImage -> IO ()
animateImages :: [HImage] -> IO ()
readImage = genericReadImage read_image
writeImage fp hImage = withForeignPtr (getImage hImage) $ \img_ptr -> do
setFilename hImage fp
debug 2 $ "About to write image..."
excInfo <- nonFinalizedExceptionInfo (((\hsc_ptr -> hsc_ptr `plusPtr` 6544)) img_ptr)
withExceptions_ (withForeignPtr (getImageInfo hImage) (\ii ->
(write_image ii img_ptr)))
"writeImage: error writing image"
(== 0) excInfo
debug 2 $ "Wrote the image!"
ex <- doesFileExist fp
debug 3 $ fp ++ (if ex then " exists " else " doesn't exist")
pingImage = genericReadImage ping_image
compositeImage op x_offset y_offset canvas_image comp_image = sideEffectingOp
(\ canvasIm -> withExceptions (
withForeignPtr (getImage canvasIm) $ \canvasImPtr ->
withForeignPtr (getImage comp_image) $ \comp_image_ptr ->
composite_image canvasImPtr (toCEnum op) comp_image_ptr
(fromIntegral x_offset) (fromIntegral y_offset))
"compositeImage: error compositing image" (== 0)
(getExceptionInfo canvasIm)) canvas_image
allocateImage imgNotLoaded = unsafePerformIO $ do
imagePtr <- withForeignPtr (imageInfo imgNotLoaded) allocate_image
if(imagePtr == nullPtr)
then (signalException "allocateImage returned null")
else return $ mkImage imagePtr imgNotLoaded
destroyImage (HImage img (ImageNotLoaded info exc)) = do
finalizeForeignPtr img
finalizeForeignPtr info
finalizeForeignPtr exc
setImageColormap clrs hImage = sideEffectingOp
(\ im -> applyImageFn1 im allocate_image_colormap (fromIntegral clrs))
hImage
newImageColormap clrs = unsafePerformIO $ do
let hImage = allocateImage mkNewUnloadedImage
withExceptions_ (applyImageFn1 hImage allocate_image_colormap (fromIntegral clrs))
"setImageColormap: error setting colormap" (== 0)
(getExceptionInfo hImage)
return hImage
appendImages order images@(img:_) = unsafePerformIO $ do
linkImagesTogether images
iPtr <- withExceptions (applyImageFn1' img append_images (toCEnum order))
"appendImage: error appending"
(== nullPtr) (getExceptionInfo img)
return $ setImage img iPtr
appendImages _ [] = unsafePerformIO $ signalException "appendImages: empty list"
averageImages images@(img:_) = unsafePerformIO $ do
linkImagesTogether images
iPtr <- withExceptions (applyImageFn' img average_images id)
"averageImages: error averaging" (== nullPtr) (getExceptionInfo img)
return $ setImage img iPtr
averageImages [] = unsafePerformIO $ signalException "averageImages: empty list"
cycleColormapImage amount img = sideEffectingOp
(\ im -> applyImageFn1 im cycle_colormap_image (fromIntegral amount))
img
animateImages images@(img:_) = do
linkImagesTogether images
withExceptions_ (withForeignPtr (getImageInfo img) (\ii ->
(applyImageFn img (animate_images ii) id)))
"animateImages: error animating" (== 0) (getExceptionInfo img)
animateImages [] = return ()
genericReadImage :: (Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_))
-> FilePath -> IO HImage
genericReadImage reader fp =
genericReadOp ((flip setFilename) fp) reader
"readImage: error reading image"
genericReadOp :: (ImageNotLoaded -> IO ()) ->
(Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
String -> IO HImage
genericReadOp prepareImageInfo theAction errStr = do
infoPtr <- mkNewExceptionInfo
image_info <- mkNewImageInfo
let theImage = mkUnloadedImage image_info infoPtr
prepareImageInfo theImage
iPtr <- withForeignPtr image_info $ \ii_ptr ->
withForeignPtr infoPtr $ \exc_ptr ->
withExceptions (theAction ii_ptr exc_ptr)
errStr (== nullPtr) infoPtr
return $ mkImage iPtr theImage
initializeMagick = initialize_magick nullPtr
flipImage = doTransform flip_image
flopImage = doTransform flop_image
magnifyImage = doTransform magnify_image
minifyImage = doTransform minify_image
rotateImage degrees hImage = doTransformIO
(applyImageFn1' hImage rotate_image (realToFrac degrees))
hImage
affineTransform affineMatrix hImage = unsafePerformIO $ do
(matrixPtr::ForeignPtr AffineMatrix) <- mallocForeignPtr
withForeignPtr matrixPtr $
(\ matrixP -> do
poke matrixP affineMatrix
return $ doTransformIO
(applyImageFn1' hImage affine_transform matrixP)
hImage)
chopImage = rectOp chop_image
cropImage = rectOp crop_image
shaveImage = rectOp shave_image
rectOp :: ((Ptr HImage_) -> Ptr Rectangle -> Ptr ExceptionInfo ->
IO (Ptr HImage_))
-> Rectangle -> HImage -> HImage
rectOp fun rect im = unsafePerformIO $ withRectangle rect fun im
flattenImage [] = unsafePerformIO $
signalException "flattenImage: list cannot be empty"
flattenImage images@(img:_) = unsafePerformIO $ do
debug 3 $ "Linking images..."
linkImagesTogether images
let res = doTransform flatten_images img
debug 3 $ res `seq` "FlattenImage: done!"
return res
mosaic [] = unsafePerformIO $ signalException $ "mosaic: list cannot be empty"
mosaic imagesAndRects@((img,_):_) = unsafePerformIO $ do
let images = fst $ unzip imagesAndRects
linkImagesTogether images
mapM_ (uncurry setPage) imagesAndRects
return $ doTransform mosaic_images img
rollImage xOffset yOffset hImage = doTransformIO_XY roll_image
hImage xOffset yOffset
scaleImage xFactor yFactor hImage = doTransformIO_XY scale_image
hImage xFactor yFactor
sampleImage xFactor yFactor hImage = doTransformIO_XY sample_image
hImage xFactor yFactor
thumbnailImage xFactor yFactor hImage = doTransformIO_XY thumbnail_image
hImage xFactor yFactor
shearImage xFactor yFactor hImage = doTransformIO_XY_real shear_image
hImage xFactor yFactor
resizeImage cols rws fltr blr hImage =
doTransformIO (applyImageFn' hImage resize_image $ \f -> f
(fromIntegral cols)
(fromIntegral rws) (toCEnum fltr)
(realToFrac blr))
hImage
contrastImage increaseOrDecrease hImage = sideEffectingOp
(\ im -> applyImageFn1 im contrast_image sharpen) hImage
where sharpen = case increaseOrDecrease of
IncreaseContrast -> 1
DecreaseContrast -> 0
equalizeImage = simpleOp equalize_image
normalizeImage = simpleOp normalize_image
gammaImage (PixelPacket { red=gRed, green=gGreen, blue=gBlue }) hImage =
sideEffectingOp (\ im -> applyImageFn im gamma_image $ withCString levelStr)
hImage
where levelStr = commaSep [gRed, gGreen, gBlue]
levelImage (Level { black=lBlack, mid=lMid, white=lWhite }) hImage =
sideEffectingOp (\ im ->
applyImageFn im level_image $ withCString levelStr)
hImage
where levelStr = commaSep [lBlack, lMid, lWhite]
levelImageChannel chanTy (Level { black=lBlack, mid=lMid, white=lWhite })
hImage = sideEffectingOp (\ im ->
applyImageFn im level_image_channel $ \ f ->
f (toCEnum chanTy) (realToFrac lBlack)
(realToFrac lMid) (realToFrac lWhite)) hImage
modulateImage (Modulation{ brightness=b, saturation=s, hue=h }) hImage =
sideEffectingOp (\ im ->
applyImageFn im modulate_image $ withCString modStr) hImage
where modStr = commaSep [b, s, h]
negateImage whatToNegate hImage =
(sideEffectingOp (\ im -> applyImageFn1 im negate_image whatToDo) hImage)
where whatToDo = case whatToNegate of
AllPixels -> 0
GrayscalePixels -> 1
constituteImage pixMap pixels = unsafePerformIO $ do
eInfo <- mkNewExceptionInfo
debug 3 $ "width = " ++ show wdth ++ " height = " ++ show hght ++ " sz = " ++ (show (pixelSize pixMap) ++ " len = " ++ show (length aScanline))
iPtr <- withExceptions (withArray (map marshalPixel (concat pixels)) (\ pixelArray ->
withCString (show pixMap) $
(\ mapStr -> withForeignPtr eInfo $
constitute_image
wdth
hght
mapStr
(toCEnum (storageType (head aScanline)))
pixelArray))) "constituteImage: error" (== nullPtr) eInfo
iInfo <- mkNewImageInfo
return $ mkImage iPtr (mkUnloadedImage iInfo eInfo)
where aScanline = head pixels
wdth = (fromIntegral $ (length aScanline) `div` (pixelSize pixMap))
hght = fromIntegral $ length pixels
dispatchImage pixMap storType (Rectangle{ width=cols, height=rws,
x=x_offset, y=y_offset}) hImage =
unsafePerformIO $
(allocaArray len (\ pixelArray ->
withCString (show pixMap) $
(\ mapStr -> do
withExceptions_ (applyImageFn' hImage dispatch_image $ \f ->
f (fromIntegral x_offset) (fromIntegral y_offset)
(fromIntegral cols) (fromIntegral rws) mapStr
(toCEnum storType) pixelArray)
"dispatchImage: error" (== 0)
(getExceptionInfo hImage)
pixelList <- peekArray (fromIntegral len) pixelArray
let blobs = map unmarshalPixel pixelList
return $ groups cols blobs)))
where len = (fromIntegral cols*fromIntegral rws*pixelSize pixMap)
importPixelImageArea quantumType quantumSize pixels options hImage =
sideEffectingOp (\ theImage ->
(withArray (map (fromIntegral.ord) (unlines (map (map (chr.fromIntegral)) pixels)))
(\ pixelArray -> (alloca (\ importInfo -> (alloca (\ optionsPtr -> do
optsPtr <- maybeToPtr options optionsPtr
res <- (applyImageFn theImage import_image_pixel_area $ \f ->
f (toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr
importInfo)
bytes_imported <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) importInfo
assertM (bytes_imported == length pixels)
("importPixelImageArea: internal error, not all pixels were imported: only " ++ show bytes_imported ++ " bytes were imported")
return res))))))) hImage
readInlineImage base64content = unsafePerformIO $ do
debug 47 $ "cleanedUpString = " ++ cleanedUpString
genericReadOp (const (return ()))
(\ image_info exception_info ->
(withCString cleanedUpString (\ content_str ->
read_inline_image image_info content_str exception_info)))
"readInlineImage: error reading inline content"
where cleanedUpString = insertComma (deleteNewlines
(deleteEqualsSignLine base64content))
deleteEqualsSignLine s | last (lines s) == "====" =
unlines (butLast (lines s))
deleteEqualsSignLine s = s
deleteNewlines = filter (/= '\n')
insertComma s | ',' `elem` s = s
insertComma s | null (", " `intersect` (nub s)) = (',':s)
insertComma s =
case (lines s) of
(firstLine:secondLine:restLines) ->
unlines (firstLine:((',':secondLine):restLines))
_ -> s
blobToImage :: BS.ByteString -> HImage
blobToImage bs = unsafePerformIO $ do
genericReadOp (const (return ()))
(\image_info exception_info ->
BS.unsafeUseAsCStringLen bs (\(ptr, len) ->
blob_to_image image_info (castPtr ptr) (fromIntegral len)
exception_info))
"blobToImage: error loading image from blob"
imageToBlob :: HImage -> BS.ByteString
imageToBlob img = unsafePerformIO $
withTmpImageInfo $ \imgInfo ->
alloca $ \sizePtr -> do
excInfo <- mkNewExceptionInfo
dat <- withExceptions (applyImageFn1' img (image_to_blob imgInfo) sizePtr)
"imageToBlob: unable to encode image"
(==nullPtr)
excInfo
len <- fromIntegral `fmap` peek sizePtr
BS.unsafePackCStringFinalizer (castPtr dat) len (free dat)
simpleOp :: (Ptr HImage_ -> IO CUInt) -> HImage -> HImage
simpleOp op im = sideEffectingOp
(\hImage ->
withForeignPtr (getImage hImage) $ \ii_ptr ->
op ii_ptr) im
withRectangle :: Rectangle ->
(Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
HImage -> IO HImage
withRectangle rect transform hImage = do
(rectPtr::ForeignPtr Rectangle) <- mallocForeignPtr
withForeignPtr rectPtr $
(\ rectP -> do
poke rectP rect
return $ doTransformIO
(applyImageFn1' hImage transform rectP)
hImage)