Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Import hsmagick source

darcs-hash:20080406190325-d61e2-320b7453c91bd91f258afdc3cf211da9fdcc8ded.gz
  • Loading branch information...
commit 17cceaa8b32b764281576fdb458ba2a5c3d36fc7 0 parents
@catamorphism catamorphism authored
18 Errors.hs
@@ -0,0 +1,18 @@
+module Errors where
+
+import Control.Exception
+
+-- Error handling functions
+
+-- Todo: something better
+signalException :: String -> IO a
+signalException = throwIO . ErrorCall
+
+tellUser :: String -> IO ()
+tellUser = putStrLn
+
+debug :: Int -> String -> IO ()
+debug n | n <= debugLevel = putStrLn
+debug _ = const $ return ()
+debugLevel :: Int
+debugLevel = 2
767 FFIHelpers_in.hs
@@ -0,0 +1,767 @@
+module FFIHelpers(withExceptions,
+ withExceptions_,
+ setField,
+ (-->),
+ setFilename,
+ getFilename,
+ setPage,
+ doTransform,
+ doTransformIO,
+ doTransformIO_XY,
+ doTransformIO_XY_real,
+ sideEffectingOp,
+ linkImagesTogether,
+ mkNewExceptionInfo,
+ mkNewImageInfo,
+ toCEnum,
+ hImageRows,
+ hImageColumns,
+ maybeToPtr,
+ mkNewUnloadedImage) where
+
+#include <magick/api.h>
+
+import Types
+import Magick
+import Errors
+import Util
+
+import Prelude hiding (maximum, minimum)
+
+-- functions to help with doing FFI
+
+-------------- Strings/char arrays
+-- This is really terrible. How to avoid these casts?
+pokeStringIntoCharArray :: Ptr CharArray -> String -> IO ()
+pokeStringIntoCharArray ptr s = go (castPtr ptr) s
+ where go :: Ptr CChar -> String -> IO ()
+ go p [] = poke p nullChar
+ go p (c:cs) = do
+ debug 3 $ "p = " ++ show p ++ " c = " ++ show c
+ poke p (castCharToCChar c)
+ go (p `plusPtr` charSize) cs
+
+peekStringFromCharArray :: Ptr CharArray -> IO String
+peekStringFromCharArray ptr =
+ (debug 3 $ "peekStringFromCharArray: ptr = " ++ show ptr)
+ >> go (castPtr ptr) ""
+ where go :: Ptr CChar -> String -> IO String
+ go p s = do
+ debug 3 $ "p = " ++ show p
+ c <- (liftM castCCharToChar) $ peek p
+ debug 3 $ " c = " ++ show c
+ if c == '\0'
+ then return s
+ else go (p `plusPtr` charSize) (s ++ [c])
+
+charSize :: Int
+charSize = sizeOf (undefined::CChar)
+nullChar :: CChar
+nullChar = castCharToCChar '\0'
+
+-------- sets a field in something Storable --------
+setField :: Storable a => (a -> a) -> Ptr a -> IO ()
+setField modify p = peek p >>= ((poke p).modify)
+(-->) :: Storable a => Ptr a -> (a -> b) -> b
+(-->) p sel = unsafePerformIO $ peek p >>= (return.sel)
+---------------------------------
+
+-- Function for handling exceptions from GraphicsMagick calls.
+-- Takes an IO action (that's presumably a call to a GraphicsMagick function),
+-- an error message to print if something goes wrong, and a function to
+-- determine whether the result of the call was erroneous, as well as a pointer
+-- to the exception info that the action will set.
+-- The checker function is assumed to return True if there was an error.
+withExceptions :: IO a -> String -> (a -> Bool) -> (Ptr ExceptionInfo) -> IO a
+withExceptions action errMsg checker excPtr = do
+ result <- action
+ if (checker result)
+ then do
+ -- this prints out GraphicsMagick's message
+ tellUser "hsMagick: caught a GraphicsMagick exception as follows: "
+ catch_exception excPtr
+ signalException errMsg
+ else return result
+-- Same as withExceptions, but throws away the result
+withExceptions_ :: IO a -> String -> (a -> Bool) -> Ptr ExceptionInfo -> IO ()
+withExceptions_ action errMsg checker excPtr =
+ withExceptions action errMsg checker excPtr >> return ()
+
+-- Note: for a plain Image -> Exception -> Image function, we should
+-- call doTransform. For transformations that take extra arguments,
+-- we use doTransformIO.
+
+-- doTransform takes an image transformation that takes an
+-- image pointer and an exception pointer as arguments, and applies it
+-- to the given HImage.
+-- It's assumed that the transformer returns null if an error occurs,
+-- so this checks for null and looks at the exception field.
+doTransform :: (Ptr HImage_ -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)) -> HImage -> HImage
+doTransform transform hImage =
+ doTransformIO (transform (getImage hImage) excInfo) hImage
+ where excInfo = getExceptionInfo hImage
+
+-- doTransformIO takes an arbitrary IO action that returns an HImage_
+-- pointer, and returns a new HImage with the image field of the given
+-- HImage set to it, checking for exceptions.
+-- It's assumed that the IO action returns a null pointer to signal
+-- an exception.
+doTransformIO :: IO (Ptr HImage_) -> HImage -> HImage
+doTransformIO act hImage =
+ setImage hImage (unsafePerformIO
+ (withExceptions act
+ -- TODO: better messages
+ "error doing image transformation"
+ (== nullPtr)
+ excInfo))
+ where excInfo = getExceptionInfo hImage
+
+doTransformIO_XY :: (Integral a, Integral b) =>
+ (Ptr HImage_ -> a -> a -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
+ HImage -> b -> b -> HImage
+doTransformIO_XY transform hImage x_ y_ =
+ doTransformIO (transform (getImage hImage) (fromIntegral x_) (fromIntegral y_)
+ (getExceptionInfo hImage))
+ hImage
+
+-- Ugh.
+doTransformIO_XY_real :: (Real b, Fractional a) =>
+ (Ptr HImage_ -> a -> a -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
+ HImage -> b -> b -> HImage
+doTransformIO_XY_real transform hImage x_ y_ =
+ doTransformIO (transform (getImage hImage) (realToFrac x_) (realToFrac y_)
+ (getExceptionInfo hImage))
+ hImage
+
+------------------ creating image sequences -----------
+linkImagesTogether :: [HImage] -> IO ()
+linkImagesTogether [] = signalException $ "internal error: linkImagesTogether:"
+ ++ " empty list"
+linkImagesTogether (img:images) = do
+ foldM (\ bigImage smallImage -> do
+ (#poke Image, next) (getImage bigImage)
+ (getImage smallImage)
+ return smallImage)
+ img
+ images
+ debug 3 $ "Checking assertion..."
+ -- check that: all images but the last one have a non-null "next"
+ -- ptr, and also, the last one has a null "next" ptr
+ allGood <- allM nextImageNotNull (butLast images)
+ lastNull <- (liftM not) (nextImageNotNull (last images))
+ assertM (allGood && lastNull)
+ "flattenImage: internal error: couldn't create sequence"
+ where nextImageNotNull hImage = do
+ debug 3 $ "peeking: " ++ show (getImage hImage)
+ nextIm <- (#peek Image, next) (getImage hImage)
+ debug 3 $ "peeked! " ++ show nextIm
+ return $ nextIm /= nullPtr
+
+
+------------------ instances --------------------------
+--- (should this be in this module? Who knows?)
+
+instance Storable FilterTypes where
+ sizeOf _ = sizeOf (undefined::CUInt)
+ alignment _ = alignment (undefined::CUInt)
+ peek ptr = do
+ -- is this use of cast right?
+ theInt::CUInt <- peek (castPtr ptr)
+ return $ toEnum (fromIntegral theInt)
+ poke ptr val = poke (castPtr ptr) (fromEnum val)
+
+-- TODO:
+-- could this be auto-generated? boilerplate sux...
+-- (fundeps? instance Enum a => Storable a...)
+instance Storable CompositeOp where
+ sizeOf _ = sizeOf (undefined::CUInt)
+ alignment _ = alignment (undefined::CUInt)
+ peek ptr = do
+ -- is this use of cast right?
+ theInt::CUInt <- peek (castPtr ptr)
+ return $ toEnum (fromIntegral theInt)
+ poke ptr val = poke (castPtr ptr) (fromEnum val)
+
+instance Storable ImageCharacteristics where
+ sizeOf _ = (sizeOf (undefined::CUInt)) * 5
+ alignment _ = alignment (undefined::CUInt)
+ peek ptr = do
+ cmyk' <- (#peek ImageCharacteristics, cmyk) ptr
+ grayscale' <- (#peek ImageCharacteristics, grayscale) ptr
+ mONOCHROME' <- (#peek ImageCharacteristics, monochrome) ptr
+ opaque' <- (#peek ImageCharacteristics, opaque) ptr
+ palette' <- (#peek ImageCharacteristics, palette) ptr
+ return $ ImageC { cmyk=toEnum cmyk', grayscale=toEnum grayscale',
+ mONOCHROME=toEnum mONOCHROME', opaque=toEnum opaque',
+ palette=toEnum palette'}
+ poke ptr i = do
+ (#poke ImageCharacteristics, cmyk) ptr (fromEnum$ cmyk i)
+ (#poke ImageCharacteristics, grayscale) ptr (fromEnum$ grayscale i)
+ (#poke ImageCharacteristics, monochrome) ptr (fromEnum$ mONOCHROME i)
+ (#poke ImageCharacteristics, opaque) ptr (fromEnum$ opaque i)
+ (#poke ImageCharacteristics, palette) ptr (fromEnum$ palette i)
+
+instance Storable ImageStatistics where
+ sizeOf _ = 4 * sizeOf (undefined::ImageChannelStatistics)
+ alignment _ = alignment (undefined::ImageChannelStatistics)
+ peek ptr = do
+ red' <- (#peek ImageStatistics, red) ptr
+ green' <- (#peek ImageStatistics, green) ptr
+ blue' <- (#peek ImageStatistics, blue) ptr
+ opacity' <- (#peek ImageStatistics, opacity) ptr
+ return $ ImageS { red_=red', green_=green', blue_=blue', opacity_=opacity' }
+ poke ptr i = do
+ (#poke ImageStatistics, red) ptr (red_ i)
+ (#poke ImageStatistics, green) ptr (green_ i)
+ (#poke ImageStatistics, blue) ptr (blue_ i)
+ (#poke ImageStatistics, opacity) ptr (opacity_ i)
+
+instance Storable ImageChannelStatistics where
+ sizeOf _ = 5 * sizeOf (undefined::CDouble)
+ alignment _ = alignment (undefined::CDouble)
+ peek ptr = do
+ maximum'::CDouble <- (#peek ImageChannelStatistics, maximum) ptr
+ minimum'::CDouble <- (#peek ImageChannelStatistics, minimum) ptr
+ mean'::CDouble <- (#peek ImageChannelStatistics, mean) ptr
+ standard_deviation'::CDouble <- (#peek ImageChannelStatistics, standard_deviation) ptr
+ variance'::CDouble <- (#peek ImageChannelStatistics, variance) ptr
+ return $ ImageCS { maximum=realToFrac maximum', minimum=realToFrac minimum',
+ mean=realToFrac mean', standard_deviation=realToFrac standard_deviation',
+ variance=realToFrac variance' }
+ poke ptr i = do
+ (#poke ImageChannelStatistics, maximum) ptr (maximum i)
+ (#poke ImageChannelStatistics, minimum) ptr (minimum i)
+ (#poke ImageChannelStatistics, mean) ptr (mean i)
+ (#poke ImageChannelStatistics, standard_deviation) ptr (standard_deviation i)
+ (#poke ImageChannelStatistics, variance) ptr (variance i)
+
+
+instance Storable ExceptionInfo where
+ sizeOf _ = 32 -- TODO
+ alignment _ = alignment (undefined::CULong)
+ peek ptr = do
+ severity' <- (#peek ExceptionInfo, severity ) ptr
+ reason' <- (#peek ExceptionInfo, reason ) ptr
+ description' <- (#peek ExceptionInfo, description ) ptr
+ error_number' <- (#peek ExceptionInfo, error_number ) ptr
+ mODULE' <- (#peek ExceptionInfo, module ) ptr
+ function' <- (#peek ExceptionInfo, function ) ptr
+ line' <- (#peek ExceptionInfo, line ) ptr
+ signature__' <- (#peek ExceptionInfo, signature ) ptr
+ return $ ExceptionInfo { severity=severity',
+ reason=reason',
+ description=description',
+ error_number=error_number',
+ mODULE=mODULE',
+ function=function',
+ line=line',
+ signature__=signature__'}
+ poke ptr e = do
+ (#poke ExceptionInfo, severity ) ptr (severity e )
+ (#poke ExceptionInfo, reason ) ptr (reason e )
+ (#poke ExceptionInfo, description ) ptr (description e )
+ (#poke ExceptionInfo, error_number ) ptr (error_number e)
+ (#poke ExceptionInfo, module ) ptr (mODULE e )
+ (#poke ExceptionInfo, function ) ptr (function e )
+ (#poke ExceptionInfo, line ) ptr (signature__ e )
+
+-- it's unfortunate that we have to write this twice
+-- (maybe there's some wackier type system feature that
+-- would let us not do so)
+instance Storable (PixelPacket Word8) where
+ sizeOf _ = 4*(sizeOf(undefined::Word8))
+ alignment _ = alignment (undefined::Word8)
+ peek ptr = do
+ red' <- (#peek PixelPacket, red) ptr
+ green' <- (#peek PixelPacket, green) ptr
+ blue' <- (#peek PixelPacket, blue) ptr
+ opacity' <- (#peek PixelPacket, opacity) ptr
+ return $ PixelPacket{ red=red', green=green',
+ blue=blue', opacity=opacity' }
+ poke ptr p = do
+ (#poke PixelPacket, red) ptr (red p)
+ (#poke PixelPacket, blue) ptr (blue p)
+ (#poke PixelPacket, green) ptr (green p)
+ (#poke PixelPacket, opacity) ptr (opacity p)
+
+instance Storable CharArray where
+ sizeOf _ = maxTextExtent
+ alignment _ = 1
+ peek _ = error "CharArray: peek is not implemented"
+ poke _ _ = error "CharArray: poke is not implemented"
+
+instance Storable HImageInfo where
+ sizeOf _ = (#size ImageInfo)
+ alignment _ = alignment (undefined::CULong)
+ peek ptr = do
+ -- again, ugh
+ compression' <- (#peek ImageInfo, compression) ptr
+ temporary' <- (#peek ImageInfo, temporary) ptr
+ adjoin' <- (#peek ImageInfo, adjoin) ptr
+ antialias' <- (#peek ImageInfo, antialias) ptr
+ subimage' <- (#peek ImageInfo, subimage) ptr
+ subrange' <- (#peek ImageInfo, subrange) ptr
+ depth' <- (#peek ImageInfo, depth) ptr
+ size' <- (#peek ImageInfo, size) ptr
+ tile' <- (#peek ImageInfo, tile) ptr
+ page' <- (#peek ImageInfo, page) ptr
+ interlace' <- (#peek ImageInfo, interlace) ptr
+ endian' <- (#peek ImageInfo, endian) ptr
+ units' <- (#peek ImageInfo, units) ptr
+ quality' <- (#peek ImageInfo, quality) ptr
+ sampling_factor' <- (#peek ImageInfo, sampling_factor) ptr
+ server_name' <- (#peek ImageInfo, server_name) ptr
+ font' <- (#peek ImageInfo, font) ptr
+ texture' <- (#peek ImageInfo, texture) ptr
+ density' <- (#peek ImageInfo, density) ptr
+ pointsize' <- (#peek ImageInfo, pointsize) ptr
+ fuzz' <- (#peek ImageInfo, fuzz) ptr
+ pen' <- (#peek ImageInfo, pen) ptr
+ background_color' <- (#peek ImageInfo, background_color) ptr
+ border_color' <- (#peek ImageInfo, border_color) ptr
+ matte_color' <- (#peek ImageInfo, matte_color) ptr
+ dither' <- (#peek ImageInfo, dither) ptr
+ monochrome' <- (#peek ImageInfo, monochrome) ptr
+ colorspace' <- (#peek ImageInfo, colorspace) ptr
+ tYPE' <- (#peek ImageInfo, type) ptr
+ group' <- (#peek ImageInfo, group) ptr
+ verbose' <- (#peek ImageInfo, verbose) ptr
+ view' <- (#peek ImageInfo, view) ptr
+ progress' <- (#peek ImageInfo, progress) ptr
+ authenticate' <- (#peek ImageInfo, authenticate) ptr
+ client_data' <- (#peek ImageInfo, client_data) ptr
+ stream' <- (#peek ImageInfo, stream) ptr
+ file' <- (#peek ImageInfo, file) ptr
+ magick' <- peekStringFromCharArray $ (#ptr ImageInfo, magick) ptr
+ filename' <- peekStringFromCharArray $ (#ptr ImageInfo, filename) ptr
+ cache' <- (#peek ImageInfo, cache) ptr
+ definitions' <- (#peek ImageInfo, definitions) ptr
+ attributes' <- (#peek ImageInfo, attributes) ptr
+ ping' <- (#peek ImageInfo, ping) ptr
+ preview_type' <- (#peek ImageInfo, preview_type) ptr
+ affirm' <- (#peek ImageInfo, affirm) ptr
+ blob' <- (#peek ImageInfo, blob) ptr
+ lENGTH' <- (#peek ImageInfo, length) ptr
+ unique' <- (#peek ImageInfo, unique) ptr
+ zero' <- (#peek ImageInfo, zero) ptr
+ signature' <- (#peek ImageInfo, signature) ptr
+ return $ HImageInfo{compression=compression',
+ temporary=temporary',
+ adjoin=adjoin',
+ antialias=antialias',
+ subimage=subimage',
+ subrange=subrange',
+ depth=depth',
+ size=size',
+ tile=tile',
+ page=page',
+ interlace=interlace',
+ endian=endian',
+ units=units',
+ quality=quality',
+ sampling_factor=sampling_factor',
+ server_name=server_name',
+ font=font',
+ texture=texture',
+ density=density',
+ pointsize=pointsize',
+ fuzz=fuzz',
+ pen=pen',
+ background_color=background_color',
+ border_color=border_color',
+ matte_color=matte_color',
+ dither=dither',
+ monochrome=monochrome',
+ colorspace=colorspace',
+ tYPE=tYPE',
+ group=group',
+ verbose=verbose',
+ view=view',
+ progress=progress',
+ authenticate=authenticate',
+ client_data=client_data',
+ stream=stream',
+ file=file',
+ magick=magick',
+ filename=filename',
+ cache=cache',
+ definitions=definitions',
+ attributes=attributes',
+ ping=ping',
+ preview_type=preview_type',
+ affirm=affirm',
+ blob=blob',
+ lENGTH=lENGTH',
+ unique=unique',
+ zero=zero',
+ signature=signature'}
+ poke ptr hImageInfo = do
+ -- ugh, boilerplate. is there a way to auto-generate this?
+ (#poke ImageInfo, compression) ptr (compression hImageInfo)
+ (#poke ImageInfo, temporary) ptr (temporary hImageInfo)
+ (#poke ImageInfo, adjoin) ptr (adjoin hImageInfo)
+ (#poke ImageInfo, antialias) ptr (antialias hImageInfo)
+ (#poke ImageInfo, subimage) ptr (subimage hImageInfo)
+ (#poke ImageInfo, subrange) ptr (subrange hImageInfo)
+ (#poke ImageInfo, depth) ptr (depth hImageInfo)
+ (#poke ImageInfo, size) ptr (size hImageInfo)
+ (#poke ImageInfo, tile) ptr (tile hImageInfo)
+ (#poke ImageInfo, page) ptr (page hImageInfo)
+ (#poke ImageInfo, interlace) ptr (interlace hImageInfo)
+ (#poke ImageInfo, endian ) ptr (endian hImageInfo)
+ (#poke ImageInfo, units ) ptr (units hImageInfo)
+ (#poke ImageInfo, quality ) ptr (quality hImageInfo )
+ (#poke ImageInfo, sampling_factor) ptr (sampling_factor hImageInfo)
+ (#poke ImageInfo, server_name) ptr (server_name hImageInfo)
+ (#poke ImageInfo, font ) ptr (font hImageInfo)
+ (#poke ImageInfo, texture ) ptr (texture hImageInfo )
+ (#poke ImageInfo, density ) ptr (density hImageInfo )
+ (#poke ImageInfo, pointsize ) ptr (pointsize hImageInfo )
+ (#poke ImageInfo, fuzz ) ptr (fuzz hImageInfo )
+ (#poke ImageInfo, pen ) ptr (pen hImageInfo )
+ (#poke ImageInfo, background_color) ptr (background_color hImageInfo)
+ (#poke ImageInfo, border_color) ptr (border_color hImageInfo)
+ (#poke ImageInfo, matte_color) ptr (matte_color hImageInfo)
+ (#poke ImageInfo, dither ) ptr (dither hImageInfo )
+ (#poke ImageInfo, monochrome ) ptr (monochrome hImageInfo )
+ (#poke ImageInfo, colorspace ) ptr (colorspace hImageInfo)
+ (#poke ImageInfo, type ) ptr (tYPE hImageInfo )
+ (#poke ImageInfo, group ) ptr (group hImageInfo )
+ (#poke ImageInfo, verbose ) ptr (verbose hImageInfo )
+ (#poke ImageInfo, view ) ptr (view hImageInfo )
+ (#poke ImageInfo, authenticate) ptr (authenticate hImageInfo)
+ (#poke ImageInfo, client_data) ptr (client_data hImageInfo)
+ (#poke ImageInfo, stream ) ptr (stream hImageInfo )
+ (#poke ImageInfo, file ) ptr (file hImageInfo )
+ -- the two char-array things: magick and filename
+ pokeStringIntoCharArray ((#ptr ImageInfo, magick) ptr) (magick hImageInfo)
+ pokeStringIntoCharArray ((#ptr ImageInfo, filename) ptr) (filename hImageInfo)
+ --
+ (#poke ImageInfo, cache ) ptr (cache hImageInfo )
+ (#poke ImageInfo, definitions) ptr (definitions hImageInfo)
+ (#poke ImageInfo, attributes ) ptr (attributes hImageInfo)
+ (#poke ImageInfo, ping ) ptr (ping hImageInfo)
+ (#poke ImageInfo, preview_type) ptr (preview_type hImageInfo)
+ (#poke ImageInfo, affirm ) ptr (affirm hImageInfo)
+ (#poke ImageInfo, blob ) ptr (blob hImageInfo)
+ (#poke ImageInfo, length ) ptr (lENGTH hImageInfo)
+ (#poke ImageInfo, unique ) ptr (unique hImageInfo)
+ (#poke ImageInfo, zero ) ptr (zero hImageInfo)
+ (#poke ImageInfo, signature ) ptr (signature hImageInfo)
+
+instance Storable HImage_ where
+ sizeOf _ = (#size Image)
+ alignment _ = alignment (undefined::CULong)
+ peek ptr = do
+ storage_class' <- (#peek Image, storage_class) ptr
+ colorspace_' <- (#peek Image, colorspace) ptr
+ compression_' <- (#peek Image, compression) ptr
+ dither_' <- (#peek Image, dither) ptr
+ matte' <- (#peek Image, matte) ptr
+ columns' <- (#peek Image, columns) ptr
+ rows' <- (#peek Image, rows) ptr
+ colors' <- (#peek Image, colors) ptr
+ depth_' <- (#peek Image, depth) ptr
+ colormap' <- (#peek Image, colormap) ptr
+ background_color_' <- (#peek Image, background_color) ptr
+ border_color_' <- (#peek Image, border_color) ptr
+ matte_color_' <- (#peek Image, matte_color) ptr
+ gamma' <- (#peek Image, gamma) ptr
+ chromaticity' <- (#peek Image, chromaticity) ptr
+ orientation' <- (#peek Image, orientation) ptr
+ rendering_intent' <- (#peek Image, rendering_intent) ptr
+ units_' <- (#peek Image, units) ptr
+ montage' <- (#peek Image, montage) ptr
+ directory' <- (#peek Image, directory) ptr
+ geometry' <- (#peek Image, geometry) ptr
+ offset' <- (#peek Image, offset) ptr
+ x_resolution' <- (#peek Image, x_resolution) ptr
+ y_resolution' <- (#peek Image, y_resolution) ptr
+ page_' <- (#peek Image, page) ptr
+ tile_info' <- (#peek Image, tile_info) ptr
+ blur' <- (#peek Image, blur) ptr
+ fuzz_' <- (#peek Image, fuzz) ptr
+ fILTER' <- (#peek Image, filter) ptr
+ interlace_' <- (#peek Image, interlace) ptr
+ endian_' <- (#peek Image, endian) ptr
+ gravity' <- (#peek Image, gravity) ptr
+ compose' <- (#peek Image, compose) ptr
+ dispose' <- (#peek Image, dispose) ptr
+ scene' <- (#peek Image, scene) ptr
+ delay' <- (#peek Image, delay) ptr
+ iterations' <- (#peek Image, iterations) ptr
+ total_colors' <- (#peek Image, total_colors) ptr
+ start_loop' <- (#peek Image, start_loop) ptr
+ eRROR' <- (#peek Image, error) ptr
+ timer' <- (#peek Image, timer) ptr
+ client_data_' <- (#peek Image, client_data) ptr
+ filename_' <- peekStringFromCharArray ((#ptr Image, filename) ptr)
+ magick_filename' <- peekStringFromCharArray ((#ptr Image, magick_filename) ptr)
+ magick_' <- peekStringFromCharArray ((#ptr Image, magick) ptr)
+ magick_rows' <- (#peek Image, magick_rows) ptr
+ exception' <- (#peek Image, exception) ptr
+ previous' <- (#peek Image, previous) ptr
+ next' <- (#peek Image, next) ptr
+ profiles' <- (#peek Image, profiles) ptr
+ is_monochrome' <- (#peek Image, is_monochrome) ptr
+ is_grayscale' <- (#peek Image, is_grayscale) ptr
+ taint' <- (#peek Image, taint) ptr
+ clip_mask' <- (#peek Image, clip_mask) ptr
+ cache_' <- (#peek Image, cache) ptr
+ attributes_' <- (#peek Image, attributes) ptr
+ ascii85' <- (#peek Image, ascii85) ptr
+ blob_' <- (#peek Image, blob) ptr
+ reference_count' <- (#peek Image, reference_count) ptr
+ semaphore' <- (#peek Image, semaphore) ptr
+ logging' <- (#peek Image, logging) ptr
+ list' <- (#peek Image, list) ptr
+ signature_' <- (#peek Image, signature) ptr
+ return $ HImage_ {
+ storage_class=storage_class',
+ colorspace_=colorspace_',
+ compression_=compression_',
+ dither_=dither_',
+ matte=matte',
+ columns=columns',
+ rows=rows',
+ colors=colors',
+ depth_=depth_',
+ colormap=colormap',
+ background_color_=background_color_',
+ border_color_=border_color_',
+ matte_color_=matte_color_',
+ gamma=gamma',
+ chromaticity=chromaticity',
+ orientation=orientation',
+ rendering_intent=rendering_intent',
+ units_=units_',
+ montage=montage',
+ directory=directory',
+ geometry=geometry',
+ offset=offset',
+ x_resolution=x_resolution',
+ y_resolution=y_resolution',
+ page_=page_',
+ tile_info=tile_info',
+ blur=blur',
+ fuzz_=fuzz_',
+ fILTER=fILTER',
+ interlace_=interlace_',
+ endian_=endian_',
+ gravity=gravity',
+ compose=compose',
+ dispose=dispose',
+ scene=scene',
+ delay=delay',
+ iterations=iterations',
+ total_colors=total_colors',
+ start_loop=start_loop',
+ eRROR=eRROR',
+ timer=timer',
+ client_data_=client_data_',
+ filename_=filename_',
+ magick_filename=magick_filename',
+ magick_=magick_',
+ magick_rows=magick_rows',
+ exception=exception',
+ previous=previous',
+ next=next',
+ profiles=profiles',
+ is_monochrome=is_monochrome',
+ is_grayscale=is_grayscale',
+ taint=taint',
+ clip_mask=clip_mask',
+ cache_=cache_',
+ attributes_=attributes_',
+ ascii85=ascii85',
+ blob_=blob_',
+ reference_count=reference_count',
+ semaphore=semaphore',
+ logging=logging',
+ list=list',
+ signature_=signature_'
+ }
+ poke ptr hImage = do
+ (#poke Image, storage_class) ptr (storage_class hImage)
+ (#poke Image, colorspace) ptr (colorspace_ hImage)
+ (#poke Image, compression) ptr (compression_ hImage)
+ (#poke Image, dither) ptr (dither_ hImage)
+ (#poke Image, matte) ptr (matte hImage)
+ (#poke Image, columns) ptr (columns hImage)
+ (#poke Image, rows) ptr (rows hImage)
+ (#poke Image, colors) ptr (colors hImage)
+ (#poke Image, depth) ptr (depth_ hImage)
+ (#poke Image, colormap) ptr (colormap hImage)
+ (#poke Image, background_color) ptr (background_color_ hImage)
+ (#poke Image, border_color) ptr (border_color_ hImage)
+ (#poke Image, matte_color) ptr (matte_color_ hImage)
+ (#poke Image, gamma) ptr (gamma hImage)
+ (#poke Image, chromaticity) ptr (chromaticity hImage)
+ (#poke Image, orientation) ptr (orientation hImage)
+ (#poke Image, rendering_intent) ptr (rendering_intent hImage)
+ (#poke Image, units) ptr (units_ hImage)
+ (#poke Image, montage) ptr (montage hImage)
+ (#poke Image, directory) ptr (directory hImage)
+ (#poke Image, geometry) ptr (geometry hImage)
+ (#poke Image, offset) ptr (offset hImage)
+ (#poke Image, x_resolution) ptr (x_resolution hImage)
+ (#poke Image, y_resolution) ptr (y_resolution hImage)
+ (#poke Image, page) ptr (page_ hImage)
+ (#poke Image, tile_info) ptr (tile_info hImage)
+ (#poke Image, blur) ptr (blur hImage)
+ (#poke Image, fuzz) ptr (fuzz_ hImage)
+ (#poke Image, filter) ptr (fILTER hImage)
+ (#poke Image, interlace) ptr (interlace_ hImage)
+ (#poke Image, endian) ptr (endian_ hImage)
+ (#poke Image, gravity) ptr (gravity hImage)
+ (#poke Image, compose) ptr (compose hImage)
+ (#poke Image, dispose) ptr (dispose hImage)
+ (#poke Image, scene) ptr (scene hImage)
+ (#poke Image, delay) ptr (delay hImage)
+ (#poke Image, iterations) ptr (iterations hImage)
+ (#poke Image, total_colors) ptr (total_colors hImage)
+ (#poke Image, start_loop) ptr (start_loop hImage)
+ (#poke Image, error) ptr (eRROR hImage)
+ (#poke Image, timer) ptr (timer hImage)
+ (#poke Image, client_data) ptr (client_data_ hImage)
+ pokeStringIntoCharArray ((#ptr Image, filename) ptr) (filename_ hImage)
+ pokeStringIntoCharArray ((#ptr Image, magick_filename) ptr) (magick_filename hImage)
+ pokeStringIntoCharArray ((#ptr Image, magick) ptr) (magick_ hImage)
+ (#poke Image, magick_rows) ptr (magick_rows hImage)
+ (#poke Image, exception) ptr (exception hImage)
+ (#poke Image, previous) ptr (previous hImage)
+ (#poke Image, next) ptr (next hImage)
+ (#poke Image, profiles) ptr (profiles hImage)
+ (#poke Image, is_monochrome) ptr (is_monochrome hImage)
+ (#poke Image, is_grayscale) ptr (is_grayscale hImage)
+ (#poke Image, taint) ptr (taint hImage)
+ (#poke Image, clip_mask) ptr (clip_mask hImage)
+ (#poke Image, cache) ptr (cache_ hImage)
+ (#poke Image, attributes) ptr (attributes_ hImage)
+ (#poke Image, ascii85) ptr (ascii85 hImage)
+ (#poke Image, blob) ptr (blob_ hImage)
+ (#poke Image, reference_count) ptr (reference_count hImage)
+ (#poke Image, semaphore) ptr (semaphore hImage)
+ (#poke Image, logging) ptr (logging hImage)
+ (#poke Image, list) ptr (list hImage)
+ (#poke Image, signature) ptr (signature_ hImage)
+
+instance Storable Rectangle where
+ sizeOf _ = (2*(sizeOf(undefined::CUInt))) +
+ (2*(sizeOf(undefined::CInt)))
+ alignment _ = alignment (undefined::CInt)
+ peek ptr = do
+ width' <- (#peek RectangleInfo, width) ptr
+ height' <- (#peek RectangleInfo, height) ptr
+ x' <- (#peek RectangleInfo, x) ptr
+ y' <- (#peek RectangleInfo, y) ptr
+ return $ Rectangle{ width=width', height=height',
+ x=x', y=y'}
+ poke ptr rect = do
+ (#poke RectangleInfo, width) ptr (width rect)
+ (#poke RectangleInfo, height) ptr (height rect)
+ (#poke RectangleInfo, x) ptr (x rect)
+ (#poke RectangleInfo, y) ptr (y rect)
+
+instance Storable AffineMatrix where
+ sizeOf _ = (#size AffineMatrix)
+ alignment _ = alignment (undefined::CDouble)
+ peek ptr = do
+ sx' <- (#peek AffineMatrix, sx) ptr
+ rx' <- (#peek AffineMatrix, rx) ptr
+ ry' <- (#peek AffineMatrix, ry) ptr
+ sy' <- (#peek AffineMatrix, sy) ptr
+ tx' <- (#peek AffineMatrix, tx) ptr
+ ty' <- (#peek AffineMatrix, ty) ptr
+ return $ AffineMatrix { sx=sx', rx=rx', ry=ry', sy=sy', tx=tx', ty=ty' }
+ poke ptr mat = do
+ (#poke AffineMatrix, sx) ptr (sx mat)
+ (#poke AffineMatrix, rx) ptr (rx mat)
+ (#poke AffineMatrix, ry) ptr (ry mat)
+ (#poke AffineMatrix, sy) ptr (sy mat)
+ (#poke AffineMatrix, tx) ptr (tx mat)
+ (#poke AffineMatrix, ty) ptr (ty mat)
+
+-- shouldn't really have this magick number here
+maxTextExtent :: Int
+maxTextExtent = 2053
+
+hImageRows, hImageColumns :: HImage -> Word
+hImageRows = fromIntegral.columns.unsafePerformIO.peek.getImage
+hImageColumns = fromIntegral.rows.unsafePerformIO.peek.getImage
+
+--------------- Filename handling
+
+class HasFilename a where
+ setFilename :: a -> FilePath -> IO ()
+ getFilename :: a -> FilePath
+
+instance HasFilename ImageNotLoaded where
+ getFilename (ImageNotLoaded{ imageInfo = iInfo}) = iInfo-->filename
+ setFilename (ImageNotLoaded{ imageInfo = iInfo}) s =
+ setField (\ info -> info{filename=s}) iInfo
+
+instance HasFilename HImage where
+ getFilename(HImage{ image=p, otherInfo=other }) =
+ let filename1 = p-->filename_
+ filename2 = getFilename other in
+ assert ((filename1 == filename2)::Bool)
+ ("getFilename: filenames differ in HImage:"
+ ++ filename1 ++ " and " ++ filename2)
+ filename1
+ setFilename(HImage{ image=p, otherInfo=other }) s =
+ setFilename other s >>
+ setField (\ im -> im{filename_=s}) p
+
+------------- Page setting
+setPage :: HImage -> Rectangle -> IO ()
+setPage hImage rect = (#poke Image, page) (getImage hImage) rect
+
+------------- Dealing with side-effecting GraphicsMagick functions
+sideEffectingOp :: (HImage -> IO CUInt) -> HImage -> HImage
+sideEffectingOp impureFun = (\ hImage -> unsafePerformIO $ do
+ newImage <- cloneImage hImage
+ withExceptions_ (impureFun newImage) "hsMagick: Error doing transformation"
+ (== 0) (getExceptionInfo newImage)
+ return newImage)
+
+--------- Utils
+-- The type emphasizes that we're doing something wantonly
+-- non-referentially-transparent
+cloneImage :: HImage -> IO HImage
+cloneImage hImage = do
+ clonedImagePtr <- cloneImagePtr (getImage hImage)
+ clonedImageInfo <- clone_image_info (getImageInfo hImage)
+ clonedExceptionInfo <- mkNewExceptionInfo
+ return $ mkImage clonedImagePtr (mkUnloadedImage clonedImageInfo clonedExceptionInfo)
+ -- 0 and 0 say that the cloned image should have the same
+ -- size as the original. 1 says this should be an orphan
+ -- image (not part of a list.)
+ where cloneImagePtr p = withExceptions (clone_image p 0 0 1 (getExceptionInfo hImage))
+ "cloneImagePtr: error cloning image"
+ (== nullPtr)
+ (getExceptionInfo hImage)
+----------- Exceptions
+mkNewExceptionInfo :: IO (Ptr ExceptionInfo)
+mkNewExceptionInfo = do
+ infoPtr <- malloc
+ get_exception_info infoPtr
+ return infoPtr
+----------- Image info
+mkNewImageInfo :: IO (Ptr HImageInfo)
+mkNewImageInfo = clone_image_info nullPtr
+----------- Both
+mkNewUnloadedImage :: ImageNotLoaded
+mkNewUnloadedImage = unsafePerformIO $ do
+ e <- mkNewExceptionInfo
+ i <- mkNewImageInfo
+ return $ mkUnloadedImage i e
+----------- Type conversion
+-- meant to convert an integ>ral type to a C enum type
+toCEnum :: (Enum a, Num b) => a -> b
+toCEnum = fromIntegral.fromEnum
+----------- dealing with pointers whose values may not be present
+maybeToPtr :: Storable a => Maybe a -> Ptr a -> IO (Ptr a)
+maybeToPtr Nothing _ = return nullPtr
+maybeToPtr (Just stuff) p = poke p stuff >> return p
514 Images.hs
@@ -0,0 +1,514 @@
+{-# INCLUDE <magick/api.h> #-}
+{-# LINE 1 "Images_in.hs" #-}
+{-# OPTIONS -ffi -cpp -fglasgow-exts #-}
+{-# LINE 2 "Images_in.hs" #-}
+
+module 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
+
+
+{-# LINE 53 "Images_in.hs" #-}
+
+import Magick
+import Types
+import FFIHelpers
+import Errors
+import Util
+
+import 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]]
+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
+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)
+ (((\hsc_ptr -> hsc_ptr `plusPtr` 6544)) (getImage hImage))
+{-# LINE 147 "Images_in.hs" #-}
+ 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
+
+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)
+
+-- 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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) exportInfo
+{-# LINE 443 "Images_in.hs" #-}
+ 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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) importInfo
+{-# LINE 461 "Images_in.hs" #-}
+ 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)
507 Images_in.hs
@@ -0,0 +1,507 @@
+{-# OPTIONS -ffi -cpp -fglasgow-exts #-}
+
+module 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 Magick
+import Types
+import FFIHelpers
+import Errors
+import Util
+
+import 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]]
+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
+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
+
+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)
+
+-- 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)
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) Tim Chevalier <chevalier@alum.wellesley.edu> 2008
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
352 Magick.hs
@@ -0,0 +1,352 @@
+{-# OPTIONS -ffi #-}
+module Magick(module Foreign.C.Types,
+ module Foreign,
+ module Foreign.C.String,
+ module Control.Monad,
+ initialize_magick,
+ get_exception_info,
+ clone_image_info,
+ read_image,
+ write_image,
+ catch_exception,
+ ------- transformations
+ flip_image,
+ flop_image,
+ rotate_image,
+ affine_transform,
+ shear_image,
+ chop_image,
+ crop_image,
+ flatten_images,
+ mosaic_images,
+ roll_image,
+ shave_image,
+ ------- resizing
+ scale_image,
+ magnify_image,
+ minify_image,
+ sample_image,
+ thumbnail_image,
+ resize_image,
+ -- enhancements
+ contrast_image,
+ equalize_image,
+ gamma_image,
+ level_image,
+ level_image_channel,
+ modulate_image,
+ negate_image,
+ normalize_image,
+ -- constitution
+ constitute_image,
+ dispatch_image,
+ export_image_pixel_area,
+ export_pixel_area_options_init,
+ import_image_pixel_area,
+ import_pixel_area_options_init,
+ ping_image,
+ read_inline_image,
+ -- composition
+ composite_image,
+ -- image methods
+ access_definition,
+ add_definitions,
+ allocate_image,
+ allocate_image_colormap,
+ append_images,
+ average_images,
+ clip_path_image,
+ cycle_colormap_image,
+ describe_image,
+ destroy_image,
+ destroy_image_info,
+ get_image_clip_mask,
+ get_image_depth,
+ get_image_characteristics,
+ get_image_geometry,
+ get_image_info,
+ get_image_statistics,
+ get_image_type,
+ image_equals,
+ is_taint_image,
+ plasma_image,
+ reference_image,
+ remove_definitions,
+ replace_image_colormap,
+ set_image,
+ set_image_clip_mask,
+ set_image_depth,
+ set_image_opacity,
+ set_image_type,
+ texture_image,
+ -- stuff what displays stuff
+ animate_images,
+ --- util (internal use only!)
+ p_free,
+ clone_image,
+ fopen,
+ fclose) where
+
+import Types
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Control.Monad
+
+-- The internal interface to the GraphicsMagick library. This
+-- module should mostly (if not entirely) contain import declarations
+-- for foreign calls.
+
+-- also the place to dump in modules we'd like to re-export :-)
+
+--------------- Basics
+foreign import ccall "static magick/api.h InitializeMagick"
+ initialize_magick :: Ptr a -> IO ()
+
+foreign import ccall "static magick/api.h GetExceptionInfo"
+ get_exception_info :: Ptr ExceptionInfo -> IO ()
+
+foreign import ccall "static magick/api.h CloneImageInfo"
+ clone_image_info :: Ptr HImageInfo -> IO (Ptr HImageInfo)
+
+foreign import ccall "static magick/api.h ReadImage"
+ read_image :: Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h WriteImage"
+ write_image :: Ptr HImageInfo -> Ptr HImage_ -> IO CUInt
+
+foreign import ccall "static magick/api.h CatchException"
+ catch_exception :: Ptr ExceptionInfo -> IO ()
+----------------- Constituting an image
+foreign import ccall "static magick/api.h ConstituteImage"
+ constitute_image :: CULong -> CULong -> CString -> CUInt
+ -> Ptr a -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+-- TODO: DestroyConstitute; do we need it?
+foreign import ccall "static magick/api.h DispatchImage"
+ dispatch_image :: Ptr HImage_ -> CULong -> CULong ->
+ CULong -> CULong -> CString -> CUInt
+ -> Ptr a -> Ptr ExceptionInfo -> IO CUInt
+foreign import ccall "static magick/api.h ExportImagePixelArea"
+ export_image_pixel_area :: Ptr HImage_ -> CUInt -> CUInt ->
+ Ptr a -> Ptr ExportPixelAreaOptions ->
+ Ptr ExportPixelAreaInfo -> IO CUInt
+foreign import ccall "static magick/api.h ExportPixelAreaOptionsInit"
+ export_pixel_area_options_init ::
+ Ptr ExportPixelAreaOptions -> IO ()
+foreign import ccall "static magick/api.h ImportImagePixelArea"
+ import_image_pixel_area :: Ptr HImage_ -> CUInt -> CUInt ->
+ CString -> Ptr ImportPixelAreaOptions ->
+ Ptr ImportPixelAreaInfo -> IO CUInt
+foreign import ccall "static magick/api.h ImportPixelAreaOptionsInit"
+ import_pixel_area_options_init ::
+ Ptr ImportPixelAreaOptions -> IO ()
+foreign import ccall "static magick/api.h PingImage"
+ ping_image :: Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+foreign import ccall "static magick/api.h ReadInlineImage"
+ read_inline_image :: Ptr HImageInfo -> CString -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+----------------- Transformations
+
+foreign import ccall "static magick/api.h FlipImage"
+ flip_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h FlopImage"
+ flop_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h RotateImage"
+ rotate_image :: Ptr HImage_ -> CDouble -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h AffineTransformImage"
+ affine_transform :: Ptr HImage_ -> Ptr AffineMatrix -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ShearImage"
+ shear_image :: Ptr HImage_ -> CDouble -> CDouble -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ChopImage"
+ chop_image :: Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h CropImage"
+ crop_image :: Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h FlattenImages"
+ flatten_images :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h MosaicImages"
+ mosaic_images :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h RollImage"
+ roll_image :: Ptr HImage_ -> CLong -> CLong -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ShaveImage"
+ shave_image :: Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+----------------- Resizing
+foreign import ccall "static magick/api.h ScaleImage"
+ scale_image :: Ptr HImage_ -> CULong -> CULong -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h MagnifyImage"
+ magnify_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h MinifyImage"
+ minify_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h SampleImage"
+ sample_image :: Ptr HImage_ -> CULong -> CULong -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ThumbnailImage"
+ thumbnail_image :: Ptr HImage_ -> CULong -> CULong -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ResizeImage"
+ resize_image :: Ptr HImage_ -> CULong -> CULong -> CUInt -> CDouble ->
+ Ptr ExceptionInfo -> IO (Ptr HImage_)
+---------- Enhancements
+
+-- Note that these side-effect the image! Higher-level API
+-- has to hide this from the user via copying.
+foreign import ccall "static magick/api.h ContrastImage"
+ contrast_image :: Ptr HImage_ -> CUInt -> IO CUInt
+
+foreign import ccall "static magick/api.h EqualizeImage"
+ equalize_image :: Ptr HImage_ -> IO CUInt
+
+foreign import ccall "static magick/api.h GammaImage"
+ gamma_image :: Ptr HImage_ -> CString -> IO CUInt
+
+foreign import ccall "static magick/api.h LevelImage"
+ level_image :: Ptr HImage_ -> CString -> IO CUInt
+
+foreign import ccall "static magick/api.h LevelImageChannel"
+ level_image_channel :: Ptr HImage_ -> CUInt ->
+ CDouble -> CDouble -> CDouble -> IO CUInt
+
+foreign import ccall "static magick/api.h ModulateImage"
+ modulate_image :: Ptr HImage_ -> CString -> IO CUInt
+
+foreign import ccall "static magick/api.h NegateImage"
+ negate_image :: Ptr HImage_ -> CUInt -> IO CUInt
+
+foreign import ccall "static magick/api.h NormalizeImage"
+ normalize_image :: Ptr HImage_ -> IO CUInt
+
+---------- Composition
+
+foreign import ccall "static magick/api.h CompositeImage"
+ composite_image :: Ptr HImage_ -> CUInt -> Ptr HImage_ -> CLong -> CLong
+ -> IO CUInt
+
+---------- Image methods
+foreign import ccall "static magick/api.h AccessDefinition"
+ access_definition :: Ptr HImageInfo -> CString -> CString -> IO CString
+
+foreign import ccall "static magick/api.h AddDefinitions"
+ add_definitions :: Ptr HImageInfo -> CString -> IO ()
+
+foreign import ccall "static magick/api.h AllocateImage"
+ allocate_image :: Ptr HImageInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h AllocateImageColormap"
+ allocate_image_colormap :: Ptr HImage_ -> CULong -> IO CUInt
+
+foreign import ccall "static magick/api.h AnimateImages"
+ animate_images :: Ptr HImageInfo -> Ptr HImage_ -> IO CUInt
+
+foreign import ccall "static magick/api.h AppendImages"
+ append_images :: Ptr HImage_ -> CUInt -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h AverageImages"
+ average_images :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ClipPathImage"
+ clip_path_image :: Ptr HImage_ -> CString -> CUInt -> IO CUInt
+
+foreign import ccall "static magick/api.h CycleColormapImage"
+ cycle_colormap_image :: Ptr HImage_ -> CInt -> IO CUInt
+
+foreign import ccall "static magick/api.h DescribeImage"
+ describe_image :: Ptr HImage_ -> Ptr CFile -> CUInt -> IO CUInt
+
+foreign import ccall "static magick/api.h DestroyImage"
+ destroy_image :: Ptr HImage_ -> IO ()
+
+foreign import ccall "static magick/api.h DestroyImageInfo"
+ destroy_image_info :: Ptr HImageInfo -> IO ()
+
+foreign import ccall "static magick/api.h GetImageClipMask"
+ get_image_clip_mask :: Ptr HImage_ -> Ptr ExceptionInfo -> Ptr HImage_
+
+foreign import ccall "static magick/api.h GetImageDepth"
+ get_image_depth :: Ptr HImage_ -> Ptr ExceptionInfo -> IO CULong
+
+foreign import ccall "static magick/api.h GetImageCharacteristics"
+ get_image_characteristics :: Ptr HImage_ -> Ptr ImageCharacteristics -> CUInt -> Ptr ExceptionInfo -> IO CUInt
+
+foreign import ccall "static magick/api.h GetImageGeometry"
+ get_image_geometry :: Ptr HImage_ -> CString -> CUInt -> Ptr Rectangle -> IO CInt
+
+foreign import ccall "static magick/api.h GetImageInfo"
+ get_image_info :: Ptr HImageInfo -> IO ()
+
+foreign import ccall "static magick/api.h GetImageStatistics"
+ get_image_statistics :: Ptr HImage_ -> Ptr ImageStatistics -> Ptr ExceptionInfo -> IO CUInt
+
+foreign import ccall "static magick/api.h GetImageType"
+ get_image_type :: Ptr HImage_ -> Ptr ExceptionInfo -> IO ImageType
+
+foreign import ccall "static magick/api.h IsImagesEqual"
+ image_equals :: Ptr HImage_ -> Ptr HImage_ -> IO CUInt
+
+foreign import ccall "static magick/api.h IsTaintImage"
+ is_taint_image :: Ptr HImage_ -> IO CUInt
+
+foreign import ccall "static magick/api.h PlasmaImage"
+ plasma_image :: Ptr HImage_ -> Ptr SegmentInfo -> CULong -> CULong -> IO CUInt
+
+foreign import ccall "static magick/api.h ReferenceImage"
+ reference_image :: Ptr HImage_ -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h RemoveDefinitions"
+ remove_definitions :: Ptr HImageInfo -> CString -> Ptr ExceptionInfo -> IO ()
+
+foreign import ccall "static magick/api.h ReplaceImageColormap"
+ replace_image_colormap :: Ptr HImage_ -> Ptr (PixelPacket Word16) -> CUInt -> IO CUInt
+
+foreign import ccall "static magick/api.h SetImage"
+ set_image :: Ptr HImage_ -> CUInt -> IO ()
+
+foreign import ccall "static magick/api.h SetImageClipMask"
+ set_image_clip_mask :: Ptr HImage_ -> Ptr HImage_ -> IO CUInt
+
+foreign import ccall "static magick/api.h SetImageDepth"
+ set_image_depth :: Ptr HImage_ -> CULong -> IO CUInt
+
+foreign import ccall "static magick/api.h SetImageOpacity"
+ set_image_opacity :: Ptr HImage_ -> CUInt -> IO ()
+
+foreign import ccall "static magick/api.h SetImageType"
+ set_image_type :: Ptr HImage_ -> ImageType -> IO ()
+
+foreign import ccall "static magick/api.h TextureImage"
+ texture_image :: Ptr HImage_ -> Ptr HImage_ -> IO CUInt
+
+---------- util (internal library use only)
+foreign import ccall "stdlib.h &free"
+ p_free :: FunPtr (Ptr a -> IO ())
+
+foreign import ccall "static magick/api.h CloneImage"
+ clone_image :: Ptr HImage_ -> CULong -> CULong -> CUInt -> Ptr ExceptionInfo
+ -> IO (Ptr HImage_)
+
+foreign import ccall unsafe "stdlib.h fopen"
+ fopen :: CString -> CString -> IO (Ptr CFile)
+
+foreign import ccall unsafe "stdlib.h fclose"
+ fclose :: Ptr CFile -> IO ()
21 README
@@ -0,0 +1,21 @@
+This is an incomplete set of FFI bindings for the GraphicsMagick
+library. You will need to install GraphicsMagick first -- see:
+
+ http://www.graphicsmagick.org/
+
+I have tested these bindings with GraphicsMagick 1.1.10.
+
+Please submit bug reports, feedback, complaints, praise, and
+especially patches to me at:
+
+ chevalier@alum.wellesley.edu
+
+I did a lot of this work during the second Haskell Hackathon (Hac II
+'07) in Freiburg in September 2007. I'd like to thank all the
+attendees at Hac II for their moral support, particularly Duncan
+Coutts for help with the FFI, as well as: Mark Jones, the members of
+the Portland Functional Programming Study Group, and David MacIver,
+for their encouragement.
+
+ -- Tim Chevalier
+ April 6, 2008
3  Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
428 Types.hs
@@ -0,0 +1,428 @@
+module Types where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+
+-- types used for representing data from GraphicsMagick
+
+-- Types for external use. These are part of the Haskell
+-- GraphicsMagick interface.
+
+-- The idea here is that when we first create an image we
+-- have an exception info and an image info.
+-- Later after it's loaded, we have an image as well.
+-- getFilename and setFilename are class methods that work on
+-- either one, because if we have an image that's not loaded
+-- yet, we want to be able to set the filename (for loading it later),
+-- and if we have an image that *is* loaded, we want to be able to set
+-- the filename in both the image *and* the info.
+
+-- TODO: don't export the selectors for this.
+data HImage = HImage {image::Ptr HImage_,
+ otherInfo::ImageNotLoaded}
+data ImageNotLoaded = ImageNotLoaded { imageInfo::Ptr HImageInfo,
+ exceptionInfo::Ptr ExceptionInfo }
+
+-- A rectangle is represented as a width, height, horizontal offset, and
+-- vertical offset
+data Rectangle = Rectangle { width :: Word,
+ height :: Word,
+ x :: Int,
+ y :: Int }
+ deriving Show
+
+data AffineMatrix = AffineMatrix { sx::Double,
+ rx::Double,
+ ry::Double,
+ sy::Double,
+ tx::Double,
+ ty::Double }
+
+data PixelPacket a = PixelPacket { red::a,
+ green::a,
+ blue::a,
+ opacity::a}
+data Level = Level { black::Double,
+ mid::Double,
+ white::Double }
+
+data Modulation = Modulation { brightness::Double,
+ saturation::Double,
+ hue::Double }
+
+data Negation = AllPixels | GrayscalePixels
+
+-- TODO: quantum depth (number of bits in a pixel)
+-- is determined at GraphicsMagick compile time. need
+-- to reflect that (I guess in a config file for this
+-- library...)
+type PixelPacketByte = PixelPacket Word8
+
+data ChannelType =
+ UndefinedChannel|
+ RedChannel|
+ CyanChannel|
+ GreenChannel|
+ MagentaChannel|
+ BlueChannel|
+ YellowChannel|
+ OpacityChannel|
+ BlackChannel|
+ MatteChannel
+ deriving Enum
+
+getImage :: HImage -> Ptr HImage_
+getImageInfo :: HImage -> Ptr HImageInfo
+getExceptionInfo :: HImage -> Ptr ExceptionInfo
+setImage :: HImage -> Ptr HImage_ -> HImage
+
+getImage = image
+getImageInfo = imageInfo.otherInfo
+getExceptionInfo = exceptionInfo.otherInfo
+
+setImage hIm imPtr = hIm{ image = imPtr }
+
+mkUnloadedImage :: Ptr HImageInfo -> Ptr ExceptionInfo -> ImageNotLoaded
+mkUnloadedImage iInfo exInfo =
+ ImageNotLoaded{ imageInfo = iInfo, exceptionInfo = exInfo }
+
+mkImage :: Ptr HImage_ -> ImageNotLoaded -> HImage
+mkImage p info = HImage { image=p, otherInfo=info }
+
+data FilterTypes =
+ UndefinedFilter
+ | PointFilter
+ | BoxFilter
+ | TriangleFilter
+ | HermiteFilter
+ | HanningFilter
+ | HammingFilter
+ | BlackmanFilter
+ | GaussianFilter
+ | QuadraticFilter
+ | CubicFilter
+ | CatromFilter
+ | MitchellFilter
+ | LacrosFilter
+ | BesselFilter
+ | SincFilter
+ deriving Enum
+
+data CompositeOp = Undefined
+ | Over
+ | In
+ | Out
+ | Atop
+ | Xor
+ | Plus
+ | Minus
+ | Add
+ | Subtract
+ | Difference
+ | Multiply
+ | Bumpmap
+ | Copy
+ | CopyRed
+ | CopyGreen
+ | CopyBlue
+ | CopyOpacity
+ | Clear
+ | Dissolve
+ | Displace
+ | Modulate
+ | Threshold
+ | No
+ | Darken
+ | Lighten
+ | Hue
+ | Saturate
+ | Colorize
+ | Luminize
+ | Screen
+ | Overlay
+ | CopyCyan
+ | CopyMagenta
+ | CopyYellow
+ | CopyBlack
+ deriving Enum
+
+data Contrast = IncreaseContrast | DecreaseContrast
+
+data ImageCharacteristics = ImageC {
+ cmyk::Bool,
+ grayscale::Bool,
+ mONOCHROME::Bool,
+ opaque::Bool,
+ palette::Bool
+}
+
+-- TODO:
+-- the Right Thing to do would be
+-- to use type classes rather than all these underscores
+data ImageStatistics = ImageS {
+ red_::ImageChannelStatistics,
+ green_::ImageChannelStatistics,
+ blue_::ImageChannelStatistics,
+ opacity_::ImageChannelStatistics
+}
+
+data ImageChannelStatistics = ImageCS {
+ maximum::Double,
+ minimum::Double,
+ mean::Double,
+ standard_deviation::Double,
+ variance::Double
+}
+
+data SegmentInfo = SegmentInfo {
+ x1::Double, y1::Double, x2::Double, y2::Double
+}