module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage, pingImage,
readInlineImage,
getFilename,
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,
animateImages) where
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 Data.Maybe
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
animateImages :: [HImage] -> IO ()
readImage = genericReadImage read_image
writeImage fp hImage = do
setFilename hImage fp
debug 2 $ "About to write image..."
withExceptions_ (write_image (getImageInfo hImage) (getImage hImage))
"writeImage: error writing image"
(== 0)
(((\hsc_ptr -> hsc_ptr `plusPtr` 6544)) (getImage hImage))
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 (composite_image (getImage canvasIm) (toCEnum op)
(getImage comp_image)
(fromIntegral x_offset) (fromIntegral y_offset))
"compositeImage: error compositing image" (== 0)
(getExceptionInfo canvasIm)) canvas_image
allocateImage imgNotLoaded = unsafePerformIO $ do
imagePtr <- allocate_image $ imageInfo imgNotLoaded
if(imagePtr == nullPtr)
then (signalException "allocateImage returned null")
else return $ mkImage imagePtr imgNotLoaded
setImageColormap clrs hImage = sideEffectingOp
(\ im -> allocate_image_colormap (getImage im) (fromIntegral clrs))
hImage
newImageColormap clrs = unsafePerformIO $ do
let hImage = allocateImage mkNewUnloadedImage
withExceptions_ (allocate_image_colormap (getImage hImage)
(fromIntegral clrs)) "setImageColormap: error setting colormap" (== 0)
(getExceptionInfo hImage)
return hImage
appendImages order images@(img:_) = unsafePerformIO $ do
linkImagesTogether images
iPtr <- withExceptions (append_images (getImage img) (toCEnum order) (getExceptionInfo img)) "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 (average_images (getImage img) (getExceptionInfo img))
"averageImages: error averaging" (== nullPtr) (getExceptionInfo img)
return $ setImage img iPtr
averageImages [] = unsafePerformIO $ signalException "averageImages: empty list"
cycleColormapImage amount img = sideEffectingOp
(\ im -> cycle_colormap_image (getImage im) (fromIntegral amount))
img
animateImages images@(img:_) = do
linkImagesTogether images
withExceptions_ (animate_images (getImageInfo img) (getImage img))
"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 <- clone_image_info nullPtr
let theImage = mkUnloadedImage image_info infoPtr
prepareImageInfo theImage
iPtr <- withExceptions (theAction image_info infoPtr)
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
(rotate_image (getImage hImage) (realToFrac degrees)
(getExceptionInfo hImage))
hImage
affineTransform affineMatrix hImage = unsafePerformIO $ do
(matrixPtr::ForeignPtr AffineMatrix) <- mallocForeignPtr
withForeignPtr matrixPtr $
(\ matrixP -> do
poke matrixP affineMatrix
return $ doTransformIO
(affine_transform (getImage hImage) matrixP
(getExceptionInfo hImage))
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 (resize_image (getImage hImage) (fromIntegral cols)
(fromIntegral rws) (toCEnum fltr)
(realToFrac blr) (getExceptionInfo hImage))
hImage
contrastImage increaseOrDecrease hImage = sideEffectingOp
(\ im -> contrast_image (getImage im) 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 -> withCString levelStr (gamma_image (getImage im)))
hImage
where levelStr = commaSep [gRed, gGreen, gBlue]
levelImage (Level { black=lBlack, mid=lMid, white=lWhite }) hImage =
sideEffectingOp (\ im -> withCString levelStr (level_image (getImage im)))
hImage
where levelStr = commaSep [lBlack, lMid, lWhite]
levelImageChannel chanTy (Level { black=lBlack, mid=lMid, white=lWhite })
hImage = sideEffectingOp (\ im ->
level_image_channel (getImage im) (toCEnum chanTy)
(realToFrac lBlack) (realToFrac lMid) (realToFrac lWhite)) hImage
modulateImage (Modulation{ brightness=b, saturation=s, hue=h }) hImage =
sideEffectingOp (\ im ->
withCString modStr (modulate_image (getImage im))) hImage
where modStr = commaSep [b, s, h]
negateImage whatToNegate hImage =
(sideEffectingOp (\ im -> negate_image (getImage im) 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 -> constitute_image
wdth
hght
mapStr
(toCEnum (storageType (head aScanline)))
pixelArray eInfo))) "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_ (dispatch_image (getImage hImage) (fromIntegral x_offset)
(fromIntegral y_offset) (fromIntegral cols)
(fromIntegral rws) mapStr (toCEnum storType) pixelArray
(getExceptionInfo hImage)) "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 <- (import_image_pixel_area (getImage theImage)
(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
simpleOp :: (Ptr HImage_ -> IO CUInt) -> HImage -> HImage
simpleOp op im = sideEffectingOp (op.getImage) 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
(transform (getImage hImage) rectP
(getExceptionInfo hImage))
hImage)