hsmagick-0.3: Graphics/Transform/Magick/Images.hsc
module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage, pingImage,
readInlineImage,
getFilename,
-- transformations
flipImage,
flopImage,
rotateImage,
affineTransform,
shearImage,
chopImage,
cropImage,
flattenImage,
mosaic,
rollImage,
shaveImage,
-- resizing
scaleImage,
magnifyImage,
minifyImage,
sampleImage,
thumbnailImage,
resizeImage,
-- enhancements
contrastImage,
equalizeImage,
gammaImage,
levelImage,
levelImageChannel,
modulateImage,
negateImage,
normalizeImage,
-- constitution
constituteImage,
dispatchImage,
--exportPixelImageArea,
importPixelImageArea,
-- composition
compositeImage,
-- image methods
allocateImage,
setImageColormap,
newImageColormap,
appendImages,
averageImages,
cycleColormapImage,
-- describeImage,
-- Stuff what displays stuff
animateImages) where
#include <magick/api.h>
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
-- The externally-visible Haskell API for GraphicsMagick.
-- API:
--------- Reading/writing
readImage :: FilePath -> IO HImage
writeImage :: FilePath -> HImage -> IO ()
pingImage :: FilePath -> IO HImage
initializeMagick :: IO ()
--------- Transformations
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
--------- Resizing
scaleImage, sampleImage, thumbnailImage :: Word -> Word -> HImage -> HImage
magnifyImage, minifyImage :: HImage -> HImage
resizeImage :: Int -> Int -> FilterTypes -> Double -> HImage -> HImage
--------- Enhancements
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
--------- Constitution
-- This type says: if I can store blobs of type a as pixels of type b,
-- and b is a Storable thing, then I can constitute an image from a list
-- of blobs of type a. Gotta love Haskell!
constituteImage :: (StorablePixel a b) => PixMap -> [[a]] -> HImage
-- Not quite as nice, because we have to tell the GraphicsMagick library
-- the StorageType so that it knows what type of pixels to put into the
-- the array it's returning.
dispatchImage :: (StorablePixel a b) => PixMap -> StorageType -> Rectangle ->
HImage -> [[a]]
{-
TODO
exportPixelImageArea :: (StorablePixel a b) => QuantumType2 -> Word ->
Maybe ExportPixelAreaOptions -> HImage -> [[a]]
-}
-- TODO: this requires that the pixels are unsigned chars. Is there a better way?
importPixelImageArea :: QuantumType2 -> Word -> [[Word8]] ->
Maybe ImportPixelAreaOptions -> HImage -> HImage
readInlineImage :: String -> HImage
------------- Composition
compositeImage :: CompositeOp -> Int -> Int -> HImage -> HImage -> HImage
------------- Image methods
-- returns a new image, initialized with default values
allocateImage :: ImageNotLoaded -> HImage
setImageColormap :: Word32 -> HImage -> HImage
newImageColormap :: Word32 -> HImage
appendImages :: ImageOrder -> [HImage] -> HImage
averageImages :: [HImage] -> HImage
cycleColormapImage :: Int -> HImage -> HImage
-- TODO.
-- describeImage :: Verbosity -> HImage -> String
------------- Stuff what displays stuff
animateImages :: [HImage] -> IO ()
--------------------------------------------------------------
------------------- Reading/writing images -------------------
--------------------------------------------------------------
----------------- readImage -------------------
-- readImage: reads in an image from a file.
readImage = genericReadImage read_image
--------------- writeImage --------------------
-- writeImage: writes the given image to the given file path
-- TODO: has the side effect that it writes the filepath into the image filename
-- fields. is this the right thing?
writeImage fp hImage = do
-- hmm, side-effect the image info or make a copy of it?
setFilename hImage fp
debug 2 $ "About to write image..."
-- write_image signals an exception by returning 0
withExceptions_ (write_image (getImageInfo hImage) (getImage hImage))
"writeImage: error writing image"
(== 0)
((#ptr Image, exception) (getImage hImage))
debug 2 $ "Wrote the image!"
ex <- doesFileExist fp
debug 3 $ fp ++ (if ex then " exists " else " doesn't exist")
------------- pingImage -----------------------
pingImage = genericReadImage ping_image
------------- composition ---------------------
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
------------- image methods -------------------
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
-- should require list to be nonempty
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"
-- TODO:
-- should require a nonempty list
-- TODO:
-- hmm, appendImages and averageImages look a lot alike...
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"
-- TODO: should really abstract the patterns of "returns boolean" and
-- "may return null pointer"
cycleColormapImage amount img = sideEffectingOp
(\ im -> cycle_colormap_image (getImage im) (fromIntegral amount))
img
{-
TODO.
describeImage verbosity img = unsafePerformIO $ do
-- the API requires a file in which to dump the description -- grr
tmpDir <- getTemporaryDirectory
(fp, hdl) <- openTempFile tmpDir "hsMagick.tmp"
hClose hdl
withCString (\ fileStr -> withCString (\ modeStr -> do
filePtr <- fopen fileStr modeStr
withExceptions_ (describe_image (getImage img) filePtr (toCEnum verbosity))
"describeImage: error describing" (== 0) (getExceptionInfo img)
fclose filePtr
readFile fp))
-}
------------- Stuff what displays stuff
animateImages images@(img:_) = do
linkImagesTogether images
withExceptions_ (animate_images (getImageInfo img) (getImage img))
"animateImages: error animating" (== 0) (getExceptionInfo img)
animateImages [] = return ()
------------- genericReadImage - not exported
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 --------------
-- Initializes state in the Magick library, but I'm not sure where/when it needs to be called.
-- initialize_magick takes an argv pointer, but just passing null seems to work
initializeMagick = initialize_magick nullPtr
--------------------------------------------------------------
------------------- Transformations -------------------
--------------------------------------------------------------
----------------- Simple transformations
-- vertical flip.
flipImage = doTransform flip_image
-- horizontal flip (flop).
flopImage = doTransform flop_image
-- double size
magnifyImage = doTransform magnify_image
-- halve size
minifyImage = doTransform minify_image
--------------------------------------------
-- rotates an image by an arbitrary number of degrees
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)
-- cuts the specified rectangle out of the image,
-- and squishes the remaining part to fill it
chopImage = rectOp chop_image
-- returns an image consisting of the specified
-- rectangle from the original image
cropImage = rectOp crop_image
-- returns an image consisting of the original image with the specified
-- rectangle shaved from it
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
-- takes a list of images and returns a single image consisting of all of them
-- overlaid over each other
-- TODO: require a nonempty list
flattenImage [] = unsafePerformIO $
signalException "flattenImage: list cannot be empty"
-- TODO: it's somewhat sketchy to do the side-effecting we do here
-- (mutating the next fields of the images). rethink that
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
-- the stupid argument names are due to these names being already taken
-- as record fields.
resizeImage cols rws fltr blr hImage =
doTransformIO (resize_image (getImage hImage) (fromIntegral cols)
(fromIntegral rws) (toCEnum fltr)
(realToFrac blr) (getExceptionInfo hImage))
hImage
------------ enhancements
-- TODO: the contrastImage call only increases or decreases by a
-- given increment. perhaps want to change our API to specify
-- an amount of contrast
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
------------- Constitution
-- TODO: we should require pixels to be a non-empty list
-- This constructs an image from a list of scanlines.
-- A scanline is a list of pixels.
-- A pixel is anything that can be stored as one of the C types
-- that can be a pixel.
-- All of the scanlines should have the same length, but I don't
-- know how to enforce that.
-- TODO: a pixel is really a triple (R,G,B) or a quadruple (C,M,Y,K) or...
-- depending on the color space. as is, each scanline is just a flat list
-- now. but we could do it in a more strongly typed way.
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
-- this is kind of weak... the pixmap
-- says how many numbers represent each pixel. seems bad.
-- we should have a better type system for this.
hght
mapStr
(toCEnum (storageType (head aScanline)))
pixelArray eInfo))) "constituteImage: error" (== nullPtr) eInfo
iInfo <- mkNewImageInfo
return $ mkImage iPtr (mkUnloadedImage iInfo eInfo)
-- TODO: freeing pixelArray and other memory?
where aScanline = head pixels
wdth = (fromIntegral $ (length aScanline) `div` (pixelSize pixMap))
hght = fromIntegral $ length pixels
-- TODO: could we add a field in HImage for the pixMap and avoid the need to pass that?
-- TODO: a fun QuickCheck property to add would be:
-- forall pm blobs i . blobs == dispatchImage (pm all (constituteImage pm blobs i))
-- where all is a rectangle representing the entire image
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)
{-
TODO: Seems to have disappeared from library
-- note: the exportInfo structure that export_image_pixel_area initializes
-- only contains the number of bytes exported, which we use to determine
-- the length of the list exportPixelImageArea returns -- so we don't need
-- to return it as well.
-- TODO: quantumSize shouldn't be necessary
-- TODO: have a test that uses a non-null options structure,
-- and use exportPixelAreaOptionsInit
exportPixelImageArea quantumType quantumSize options hImage =
unsafePerformIO $
(allocaArray (fromIntegral (quantumSize * imagePixels))
(\ pixelArray -> (alloca (\ exportInfo -> (alloca (\ optionsPtr -> do
optsPtr <- maybeToPtr options optionsPtr
withExceptions_ (export_image_pixel_area (getImage hImage) (toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr exportInfo) "exportPixelImageArea: error exporting" (== 0) (getExceptionInfo hImage)
bytes_exported <- (#peek ExportPixelAreaInfo, bytes_exported) exportInfo
pixelList <- peekArray bytes_exported pixelArray
let blobs = map unmarshalPixel pixelList
return $ groups cols blobs))))))
where rws = hImageRows hImage
cols = hImageColumns hImage
imagePixels = rws*cols
-}
-- this may very well be wrong
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
-- this side-effects the image, so we need to make a copy
res <- (import_image_pixel_area (getImage theImage)
(toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr
importInfo)
bytes_imported <- (#peek ImportPixelAreaInfo, bytes_imported) 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))
-- this ensures we can read data from uuencode -m without
-- munging it somewhere else. I'm not sure whether the final
-- version of the library should do this.
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
--------- helpers (private) ------------
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
-- Does this actually free the memory?
(rectPtr::ForeignPtr Rectangle) <- mallocForeignPtr
-- This was causing a segfault so it\'s temporarily commented out.
-- TODO: Worry about memory freeing.
--addForeignPtrFinalizer p_free rectPtr
withForeignPtr rectPtr $
(\ rectP -> do
poke rectP rect
return $ doTransformIO
(transform (getImage hImage) rectP
(getExceptionInfo hImage))
hImage)