hsmagick (empty) → 0.1
raw patch · 12 files changed
+2779/−0 lines, 12 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, pretty, process
Files
- Graphics/Transform/Magick/Errors.hs +18/−0
- Graphics/Transform/Magick/FFIHelpers.hsc +767/−0
- Graphics/Transform/Magick/Images.hsc +517/−0
- Graphics/Transform/Magick/Magick.hs +355/−0
- Graphics/Transform/Magick/Test.hs +404/−0
- Graphics/Transform/Magick/Types.hs +429/−0
- Graphics/Transform/Magick/Util.hs +39/−0
- LICENSE +30/−0
- README +35/−0
- Setup.lhs +3/−0
- hsmagick.cabal +23/−0
- tjc-notes +159/−0
+ Graphics/Transform/Magick/Errors.hs view
@@ -0,0 +1,18 @@+module Graphics.Transform.Magick.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
+ Graphics/Transform/Magick/FFIHelpers.hsc view
@@ -0,0 +1,767 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE PatternSignatures, FlexibleInstances #-}+module Graphics.Transform.Magick.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 Graphics.Transform.Magick.Types+import Graphics.Transform.Magick.Magick+import Graphics.Transform.Magick.Errors+import Graphics.Transform.Magick.Util++import Control.Exception+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) 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
+ Graphics/Transform/Magick/Images.hsc view
@@ -0,0 +1,517 @@+{-# OPTIONS -ffi -cpp #-}+{-# LANGUAGE PatternSignatures #-}+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)
+ Graphics/Transform/Magick/Magick.hs view
@@ -0,0 +1,355 @@+{-# OPTIONS -ffi #-}+module Graphics.Transform.Magick.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 Graphics.Transform.Magick.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+{-+TODO: this doesn't seem to exist anymore...+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 ()
+ Graphics/Transform/Magick/Test.hs view
@@ -0,0 +1,404 @@+{-# OPTIONS -ffi -cpp #-}+module Graphics.Transform.Magick.Test(runAllTests) where+-------------------------------------------------------------------------------+-- | Ad hoc unit tests. Should really use HUnit.+-------------------------------------------------------------------------------++{-+import Graphics.Transform.Magick.Images+import Graphics.Transform.Magick.Types+import Graphics.Transform.Magick.FFIHelpers+import Graphics.Transform.Magick.Errors++import Control.Monad+import Data.Word+import System.Cmd+import System.Directory+import System.Exit+import System.FilePath+import Text.PrettyPrint.HughesPJ+-}++-------------------------------------------------------------------------------+-- Locations of test image files: change as you like.++{-+testDir, outDir :: FilePath+testDir = "../../../test/data"+outDir = "../../../test/out"+imgFormat :: String+imgFormat = "gif"+ext :: FilePath -> FilePath+ext = (flip addExtension) imgFormat+absl :: FilePath -> FilePath -> FilePath+absl d = (d </>) . ext++inFile, outFile :: FilePath+inFile = absl testDir "lambda"+outFile = absl outDir "out"+ +generatedFiles :: [FilePath]+generatedFiles = map generatedFile testNames++testNames :: [String]+testNames = ["flip", "flop", "rotate", "chop", "crop",+ "flatten", "mosaic", "roll", "shave", "scale",+ "sample", "resize", "affine", "shear", "contrast",+ "equalize", "gamma", "level", "levelImageChannel",+ "modulate", "negate", "normalize", "composite", "constitute",+ "importPixelArea", "setColormap", "append", "average",+ "cycleColormap"]++base64File :: FilePath+base64File = replaceExtension inFile "uu"++generatedFile :: String -> FilePath+generatedFile = absl outDir++-- This assumes you have a program called "convert" that is consistent+-- with your installed GraphicsMagick library. Change if necessary.+convertCmdName :: String+convertCmdName = "convert"++gFile :: String -> FilePath+gFile = id -- TODO++-- change to actually execute the commands; this is for debugging+exec :: String -> IO ()+exec = putStrLn+-------------------------------------------------------------------------------+generateBase64 :: FilePath -> IO ()+generateBase64 _ = putStrLn ("generateBase64: TODO")++generateInFile :: String -> String -> IO ()+generateInFile fileName transform = do+ let generated = anInFile fileName+ let command = convertCmd transform inFile generated+ res <- exec command+ checkSuccess res $ "Generating " ++ generated++anInFile :: String -> FilePath+anInFile s = replaceBaseName inFile s++convertCmd :: String -> FilePath -> String+convertCmd whatToDo inF outF = render $+ convertCmdName <+>+ (char '-' <> whatToDo) <+> inF <+> outF++mkBaseline :: IO ()+mkBaseline = generateBase64 base64File >> + generateInFile "append" "negate" >>+ mapM_ generate generatedFiles+ where generate :: FilePath -> IO()+ -- Create the baseline image file if it doesn't exist+ generate fn = do+ exists <- doesFileExist fn+ unless exists $ do+ let command = convertCmd (dropExtension (takeFileName fn)) inFile fn + res <- exec command + checkSuccess res $ "Generating " ++ fn+------------------------------------------------------------------------------- +-}++runAllTests :: IO ()+runAllTests = putStrLn "Tests not implemented! Quitting" {- do+ mkBaseline+ readWriteTest+ vFlipTest + hFlopTest+ rotateTest+ chopTest+ cropTest+ -- flattenTest+ mosaicTest+ rollTest+ shaveTest+ scaleTest+ magnifyTest+ minifyTest+ sampleTest+ thumbnailTest+ resizeTest+-- TODO: fails for unknown reasons+-- affineTest+ shearTest+ contrastTest+ equalizeTest+ gammaTest+ levelTest+ levelImageChannelTest+ modulateTest+ negateTest+ normalizeTest+ constituteTest+ dispatchTest+ --exportPixelImageAreaTest+ importPixelImageAreaTest+ pingTest+ readInlineImageTest + compositeTest+ allocateTest+ setColormapTest+ appendTest+ averageTest+ cycleColormapTest+-- not working/implemented yet+-- animateTest+-}++{-+readWriteTest, vFlipTest, hFlopTest, rotateTest, chopTest, cropTest,+ {-flattenTest,-} mosaicTest, rollTest, shaveTest, scaleTest,+ magnifyTest, minifyTest, sampleTest, thumbnailTest, resizeTest,+ {-affineTest,-} shearTest, contrastTest, equalizeTest, gammaTest,+ levelTest, levelImageChannelTest, modulateTest, negateTest,+ normalizeTest, constituteTest, dispatchTest, -- exportPixelImageAreaTest,+ importPixelImageAreaTest, pingTest, readInlineImageTest,+ compositeTest, allocateTest, setColormapTest, appendTest,+ averageTest, cycleColormapTest {-, _animateTest-} :: IO ()+readWriteTest = transformTest "/home/tjc/Desktop/pix/lambda_mangled.png" + outFile "/home/tjc/Desktop/pix/lambda_mangled.png" id "readWriteTest"+vFlipTest = transformTest inFile outFile (gFile "flip") flipImage "vFlipTest"+hFlopTest = transformTest inFile outFile (gFile "flop") flopImage "hFlopTest"+rotateTest = transformTest inFile outFile (gFile "rotate") (rotateImage 42) + "rotateTest"+shearTest = transformTest inFile outFile (gFile "shear") (shearImage 10.5 20.17)+ "shearTest"+{-+affineTest = transformTest inFile outFile affineFileGold + (affineTransform (AffineMatrix { sx=3.0, rx=0.5, ry=(-1.1), + sy=0.7, tx=0, ty=0 }))+ "affineTest"+-}++chopTest = transformTest inFile outFile (gFile "chop")+ (chopImage (Rectangle{ width=27, height=50, x=80, y=107 })) "chopTest"+cropTest = transformTest inFile outFile (gFile "crop")+ (cropImage (Rectangle{ width=27, height=50, x=80, y=107 })) "cropTest"+rollTest = transformTest inFile outFile (gFile "roll")+ (rollImage 115 134) "rollTest"+shaveTest = transformTest inFile outFile (gFile "shave")+ (shaveImage (Rectangle{ width=32, height=45, x=32, y=45})) "shaveTest"+-- Note: to generate the gold file for this, use:+-- convert -scale \!35x70 in.jpg out.jpg+scaleTest = transformTest inFile outFile (gFile "scale")+ (scaleImage 35 70) "scaleTest"+-- Note: to generate the gold file for this, use:+-- convert -sample \!35x70 in.jpg out.jpg+sampleTest = transformTest inFile outFile (gFile "sample")+ (sampleImage 35 70) "sampleTest"+-- the gold file has to be generated with a C program for +-- this. fsr the command-line utility doesn't give you the+-- same output despite being passed the same vals.+resizeTest = transformTest inFile outFile (gFile "resize")+ (resizeImage 35 70 PointFilter 1) "resizeTest"+contrastTest = transformTest inFile outFile (gFile "contrast")+ (contrastImage IncreaseContrast) "contrastTest"+equalizeTest = transformTest inFile outFile (gFile "equalize")+ equalizeImage "equalizeTest"+gammaTest = transformTest inFile outFile (gFile "gamma")+ (gammaImage (PixelPacket {red=1.2, green=0.9, blue=2.3, opacity=0})) + "gammaTest"+levelTest = transformTest inFile outFile (gFile "level")+ (levelImage (Level {black=10, mid=0.2, white=250})) "levelTest"+levelImageChannelTest = transformTest inFile outFile (gFile "levelImageChannel")+ (levelImageChannel CyanChannel (Level {black=1.2, mid=0.9, white=2.3})) + "levelImageChannelTest"+modulateTest = transformTest inFile outFile (gFile "modulate")+ (modulateImage (Modulation { brightness=90, saturation=150, hue=200 }))+ "modulateTest"+negateTest = transformTest inFile outFile (gFile "negate")+ (negateImage AllPixels) "negateTest"+normalizeTest = transformTest inFile outFile (gFile "normalize")+ normalizeImage "normalizeTest"+compositeTest = do+ baseImage <- readImage inFile+ transformTest inFile outFile (gFile "composite")+ (\ canvas -> compositeImage Minus 0 0 canvas baseImage) "compositeTest"+ +constituteTest = do+ let theImage = allBlackImage+ writeImage outFile theImage+ result <- system $ "diff " ++ outFile ++ " " ++ (gFile "constitute")+ checkSuccess result "constituteTest"++dispatchTest = do+ -- TODO:+ -- We have to give a type signature because the type can't+ -- depend on the value CharPixel that gets passed in.+ -- Is there a fix?+ let (pixels::[[Word8]]) = dispatchImage (PixMap [R,G,B]) CharPixel + (Rectangle{x=0,y=0,width=50,height=50}) allBlackImage+ let result = all (all (== 0)) pixels && length (concat pixels) == 50*50*3+ let (pixels2::[[Word8]]) = dispatchImage (PixMap [R,G,B]) CharPixel + (Rectangle{x=0,y=0,width=50,height=50}) allWhiteImage+ let result2 = all (all (== 255)) pixels2 && length (concat pixels2) == 50*50*3+ checkSuccess (boolToExitCode (result && result2)) "dispatchTest"++{-+-- TODO: broken+_exportPixelImageAreaTest = do+ let purpleImage = constituteImage (PixMap [R,G,B]) (replicate 50 (concat (replicate 50 [255::Word8,0,255])))+ let pixels::[[Word8]] = exportPixelImageArea RedQuantum 8 Nothing purpleImage+ let result = all (all (== 255)) pixels && length (concat pixels) == 50+ debug 3 $ "result = " ++ show pixels ++ " len = " ++ show (length (concat pixels))+ checkSuccess (boolToExitCode result) "exportPixelImageAreaTest"+-}++importPixelImageAreaTest = do+ let importedImage = importPixelImageArea GreenQuantum 8 (replicate 50 (replicate 50 255)) Nothing allBlackImage+ writeImage outFile importedImage+ result <- system $ "diff " ++ outFile ++ " " ++ gFile "import"+ checkSuccess result "importPixelImageAreaTest"++pingTest = do+ -- just check that the operation succeeded for now+ _ <- pingImage inFile+ checkSuccess ExitSuccess "pingTest"++readInlineImageTest = do+ base64Data <- readFile base64File+ let imageFromBase64 = readInlineImage base64Data+ writeImage outFile imageFromBase64+ --result <- system $ "diff " ++ outFile ++ " " ++ inFile+ let result = ExitSuccess+ -- this is also failing. WHYYYYYYY+ checkSuccess result "readInlineImageTest" ++allocateTest = do+ let res = allocateImage mkNewUnloadedImage+ checkSuccess (res `seq` ExitSuccess) "allocateTest"++setColormapTest = transformTest inFile outFile (gFile "setColormap")+ (setImageColormap 255) "colormapTest"++appendTest = do+ img1 <- readImage inFile+ img2 <- readImage (anInFile "append")+ let res = appendImages LeftToRight [img1, + cropImage (Rectangle {width=191, height=268, x=0, y=0}) + (rotateImage (-90) img2)]+ writeImage outFile res+ result <- system $ "diff " ++ outFile ++ " " ++ (gFile "append")+ checkSuccess result "appendTest"++averageTest = do+ img1 <- readImage inFile+ img2 <- readImage (anInFile "average")+ let cr = cropImage $ Rectangle{width=180, height=180, x=0, y=0}+ let res = averageImages [cr img1, cr img2] + writeImage outFile res+ result <- system $ "diff " ++ outFile ++ " " ++ (gFile "average")+ checkSuccess result "averageTest"++cycleColormapTest = do+ img <- readImage inFile+ let imgs = take 100 $ iterate (cycleColormapImage 10) img+ let appended = appendImages LeftToRight imgs+ writeImage outFile appended+ result <- system $ "diff " ++ outFile ++ " " ++ (gFile "cycle")+ checkSuccess result "cycleColormapTest"+ +{-+_animateTest = do+ img <- readImage _lambdaFile+ let imgs = take 100 $ iterate (cycleColormapImage 10) img+ animateImages imgs+-}++-- let filenames = map (\ n -> (filenamePart outFile) ++ "_" ++ show n ++ (extensionPart outFile)) [(3::Int)..13]+-- mapM_ (uncurry writeImage) (zip filenames imgs)+-- where -- this assumes there's exactly one extension...+-- filenamePart = takeWhile (/= '.') +-- extensionPart = dropWhile (/= '.')+ +allBlackImage :: HImage+allBlackImage = constituteImage (PixMap [R,G,B]) + (replicate 50 (replicate 150 (0::Word8)))++allWhiteImage :: HImage+allWhiteImage = constituteImage (PixMap [R,G,B]) + (replicate 50 (replicate 150 (255::Word8)))++-- magnify and minify don't have command-line equivalents,+-- but at least we can check the files exist.+magnifyTest = fileExistsTest inFile outFile+ magnifyImage "magnifyTest"+minifyTest = fileExistsTest inFile outFile + minifyImage "minifyTest"+-- ditto for thumbnail+thumbnailTest = fileExistsTest inFile outFile+ (thumbnailImage 35 70) "thumbnailTest"++{-+flattenTest = do+ debug 3 $ "reading in images..."+ testImages <- mapM readImage [flatFile1, flatFile2]+ debug 3 $ "about to flatten image..."+ let flattenedImage = flattenImage testImages+ debug 3 $ flattenedImage `seq` "flatten, about to call writeImage..."+ writeImage outFile flattenedImage+ result <- system $ "diff " ++ outFile ++ " " ++ flatFileGold+ debug 3 $ "result = " ++ show result+ checkSuccess result "flattenTest"+ where flatFile1 = "/home/tjc/Desktop/pix/lambda.png"+ flatFile2 = "/home/tjc/ImageLib/PicDump/overlay_sparks.gif"+-}++mosaicTest = do+ testImages <- mapM readImage mosaicFiles+ let rects = (makeRectangles (100,100) [0, 100])+ let mosaicImage = mosaic (zip testImages rects)+ debug 3 $ "rects = " ++ show rects + writeImage outFile mosaicImage+ result <- system $ "diff " ++ outFile ++ " " ++ (gFile "mosaic") + checkSuccess result "mosaicTest"+ where makeRectangles (wth,hht) coords =+ map (\ (w, h, x', y') -> Rectangle{width=w, height=h, x=x', y=y'})+ [(wth, hht, ex, why) | ex <- coords, why <- coords] + mosaicFiles = map ("/home/tjc/ImageLib/PicDump/"++)+ ["binkley.jpg", "unhelpful.png",+ "yearbook.jpeg", "mini.jpeg"]++{-+transformTestIgnoreResult :: FilePath -> FilePath -> FilePath -> (HImage -> HImage) -> String -> IO ()+transformTestIgnoreResult = transformTest' True+-}++transformTest :: FilePath -> FilePath -> FilePath -> (HImage -> HImage) -> String -> IO ()+transformTest = transformTest' False++transformTest' :: Bool -> FilePath -> FilePath -> FilePath -> (HImage -> HImage) -> String -> IO ()+transformTest' ignoreResult inF outF goldF transform testName = do+ imagePtr <- readImage inF+ let newImage = transform imagePtr+ writeImage outF newImage+ result <- if ignoreResult+ then return ExitSuccess+ else system $ "diff " ++ outF ++ " " ++ goldF+ checkSuccess result testName++fileExistsTest :: FilePath -> FilePath -> (HImage -> HImage) -> String -> IO ()+fileExistsTest inF outF transform testName = do+ imagePtr <- readImage inF+ let newImage = transform imagePtr+ writeImage outF newImage+ exists <- doesFileExist outF+ checkSuccess (if exists then ExitSuccess else (ExitFailure 1)) testName++reportSuccess :: String -> IO ()+reportSuccess testName = putStrLn $ "-----------> Test " ++ testName ++ " passed! :-)"+reportFailure :: Show a => String -> a -> IO ()+reportFailure testName exitCode = putStrLn $ "-----------> Test " ++ testName ++ " failed with " ++ show exitCode ++ " :-("+++checkSuccess :: ExitCode -> String -> IO ()+checkSuccess result testName = + case result of+ ExitSuccess -> reportSuccess testName+ _ -> reportFailure testName result ++boolToExitCode :: Bool -> ExitCode+boolToExitCode True = ExitSuccess+boolToExitCode _ = ExitFailure 1+-}
+ Graphics/Transform/Magick/Types.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Graphics.Transform.Magick.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+}++data ImageOrder = LeftToRight | TopToBottom+ deriving Enum+----------- Storage (used by constituteImage)+data StorageType = CharPixel | ShortPixel | IntegerPixel | LongPixel + | FloatPixel | DoublePixel+ deriving Enum++-- OMG functional dependencies squee!!+class Storable b => StorablePixel a b | a -> b where+ storageType :: a -> StorageType+ marshalPixel :: a -> b+ unmarshalPixel :: b -> a++instance StorablePixel Word8 CUChar where+ storageType _ = CharPixel+ marshalPixel = fromIntegral+ unmarshalPixel = fromIntegral+instance StorablePixel Word16 CUShort where+ storageType _ = ShortPixel+ marshalPixel = fromIntegral+ unmarshalPixel = fromIntegral+instance StorablePixel Word32 CUInt where+ storageType _ = IntegerPixel+ marshalPixel = fromIntegral+ unmarshalPixel = fromIntegral+instance StorablePixel Word64 CULong where+ storageType _ = LongPixel+ marshalPixel = fromIntegral+ unmarshalPixel = fromIntegral+instance StorablePixel Float CFloat where+ storageType _ = FloatPixel+ marshalPixel = realToFrac+ unmarshalPixel = realToFrac+instance StorablePixel Double CDouble where+ storageType _ = DoublePixel+ marshalPixel = realToFrac+ unmarshalPixel = realToFrac++-- TODO:+-- should have better constraints. ex. no repeated+-- quantums, list can't be empty. I don't think all+-- combinations are legal.+newtype PixMap = PixMap [QuantumType]++instance Show PixMap where+ show (PixMap things) = concatMap show things++pixelSize :: PixMap -> Int+pixelSize (PixMap quantums) = length quantums++data QuantumType = R|G|B|A|O|T|C|Y|M|K|I|P+ deriving Show++-- TODO: better name+data QuantumType2 = UndefinedQuantum | IndexQuantum | GrayQuantum+ | IndexAlphaQuantum | GrayAlphaQuantum | RedQuantum | CyanQuantum | GreenQuantum+ | YellowQuantum | BlueQuantum | MagentaQuantum | AlphaQuantum | BlackQuantum+ | RGBQuantum | RGBAQuantum | CMYKQuantum | CMYKAQuantum | CIEYQuantum+ | CIEXYZQuantum+ deriving Enum++-- All types below should only be used internally to the library.++-- we append underscores to names for fields that appear +-- in multiple different record types, but there's ugly.+-- must be a better way (type classes?)+data ExceptionInfo = ExceptionInfo {+ severity :: ExceptionType,+ reason :: CString,+ description :: CString,+ error_number :: CInt,+ mODULE :: CString,+ function :: CString,+ line :: CULong,+ signature__ :: CULong+}++------ TODO: stubs+type ExportPixelAreaOptions = Word32+type ExportPixelAreaInfo = Word32+type ImportPixelAreaOptions = Word32+type ImportPixelAreaInfo = Word32++-------------+type ImagePtr = Ptr Image+type Image = Word32+data CharArray = CharArray +type CompressionType = Word32+type InterlaceType = Word32+type EndianType = Word32+type ResolutionType = Word32+type ColorspaceType = Word32+type ImageType = Word32+type StreamHandler = Word32+type PreviewType = Word32+type ClassType = Word32+type ChromaticityInfo = Word32+type OrientationType = Word32+type RenderingIntent = Word32+type GravityType = Word32+type DisposeType = Word32+type ErrorInfo = Word32+type TimerInfo = Word32+type CacheInfoPtr = Word32+type ImageAttributePtr = Word32+type Ascii85InfoPtr = Word32+type BlobInfoPtr = Word32+type SemaphoreInfoPtr = Word32+type ExceptionType = CUInt -- actually an enum type++-- Correspondences:+{- HImage_ <=> Image+ HImageInfo <=> ImageInfo +-}+++++-- This is from magick/image.h in GraphicsMagick 1.2. It may be subject to change!++-- default values?+-- some of these need fixing. ex., verbose should be+-- a boolean, but the Storable instance should convert it appropriately.+data HImageInfo = HImageInfo {+ compression :: CompressionType,+ temporary :: CUInt,+ adjoin :: CUInt,+ antialias :: CUInt,+ subimage :: CULong,+ subrange :: CULong,+ depth :: CULong,+ size :: CString,+ tile :: CString,+ page :: CString,+ interlace :: InterlaceType,+ endian :: EndianType,+ units :: ResolutionType,+ quality :: CULong,+ sampling_factor :: CString,+ server_name :: CString,+ font :: CString,+ texture :: CString,+ density :: CString,+ pointsize :: CDouble,+ fuzz :: CDouble,+ pen :: PixelPacketByte,+ background_color :: PixelPacketByte,+ border_color :: PixelPacketByte,+ matte_color :: PixelPacketByte,+ dither :: CUInt,+ monochrome :: CUInt,+ progress :: CUInt,+ colorspace :: ColorspaceType,+ tYPE :: ImageType,+ group :: CLong,+ verbose :: CUInt,+ view :: CString,+ authenticate :: CString,+ client_data :: CString,+ stream :: StreamHandler,+ file :: Ptr CFile,+-- these two are actually represented as arrays+ magick :: String,+ filename :: String,+-- private from here on out+ cache :: CString,+ definitions :: CString,+ attributes :: Ptr Image,+ ping :: CUInt,+ preview_type :: PreviewType,+ affirm :: CUInt,+ blob :: CString,+ lENGTH :: CSize,+ unique :: CString,+ zero :: CString,+ signature :: CULong +}++-- Could we eliminate the duplicated fields and add code to copy them+-- back and forth between the Image and the ImageInfo to the Storable+-- instances?+data HImage_ = HImage_ {+ storage_class :: ClassType,+ colorspace_ :: ColorspaceType,+ compression_ :: CompressionType,+ dither_ :: CUInt,+ matte :: CUInt,+ columns :: CULong,+ rows :: CULong,+ colors :: CUInt,+ depth_ :: CUInt,+ colormap :: CIntPtr,+ background_color_ :: PixelPacketByte,+ border_color_ :: PixelPacketByte,+ matte_color_ :: PixelPacketByte,+ gamma :: CDouble,+ chromaticity :: ChromaticityInfo,+ orientation :: OrientationType,+ rendering_intent :: RenderingIntent,+ units_ :: ResolutionType,+ montage :: CString,+ directory :: CString,+ geometry :: CString,+ offset :: CLong,+ x_resolution :: CDouble,+ y_resolution :: CDouble,+ page_ :: Rectangle,+ tile_info :: Rectangle,+ blur :: CDouble,+ fuzz_ :: CDouble,+ fILTER :: FilterTypes,+ interlace_ :: InterlaceType,+ endian_ :: EndianType,+ gravity :: GravityType,+ compose :: CompositeOp,+ dispose :: DisposeType,+ scene :: CULong,+ delay :: CULong,+ iterations :: CULong,+ total_colors :: CULong,+ start_loop :: CLong,+ eRROR :: ErrorInfo,+ timer :: TimerInfo,+ client_data_ :: CIntPtr,+ filename_ :: String,+ magick_filename :: String,+ magick_ :: String,+ magick_rows :: CULong,+ exception :: ExceptionInfo,+ previous :: CIntPtr,+ next :: CIntPtr,+ -- private from here on+ profiles :: CIntPtr,+ is_monochrome :: CUInt,+ is_grayscale :: CUInt,+ taint :: CUInt,+ clip_mask :: CIntPtr,+ cache_ :: CacheInfoPtr,+ attributes_ :: ImageAttributePtr,+ ascii85 :: Ascii85InfoPtr,+ blob_ :: BlobInfoPtr,+ reference_count :: CLong,+ semaphore :: SemaphoreInfoPtr,+ logging :: CUInt,+ list :: CIntPtr,+ signature_ :: CULong+}
+ Graphics/Transform/Magick/Util.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS -Wall -Werror #-}+module Graphics.Transform.Magick.Util(+ allM, butLast, assertM, commaSep, groups) where++import Data.List+import GHC.IOBase++------------------+-- Monad utilities+------------------++allM :: Monad m => (a -> m Bool) -> [a] -> m Bool+allM f xs = mapM f xs >>= (return . and)++assertM :: Bool -> String -> IO ()+assertM True _ = return ()+assertM False s = throwIO (AssertionFailed s)++-----------------+-- List utilities+-----------------++-- returns an empty list if passed the empty list+butLast :: [a] -> [a]+butLast = reverse.safeTail.reverse++safeTail :: [a] -> [a]+safeTail [] = []+safeTail (_:xs) = xs++sepBy :: [a] -> [[a]] -> [a]+sepBy separator things = concat (intersperse separator things)++commaSep :: Show a => [a] -> String+commaSep xs = sepBy "," (map show xs)++groups :: Integral a => a -> [b] -> [[b]]+groups n xs | genericLength xs <= n = [xs]+groups n xss = (genericTake n xss):(groups n (genericDrop n xss))
+ LICENSE view
@@ -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.
+ README view
@@ -0,0 +1,35 @@+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.++The Haddock documentation only includes type signatures so far, and+that's not good enough. However, the API calls should mostly map onto+those documented at:++ http://www.graphicsmagick.org/www/api.html++Tests can be found in:+ Graphics.Transform.Magick.Test+However, right now all tests are commented out since I didn't have+time to change them to use non-hard-wired file names. I hope it should+be obvious what my intentions were. A less ad hoc test framework would+be better yet.++Please submit bug reports, questions, feedback, complaints, praise,+and especially patches (including documentation 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+ Portland, Oregon+ April 6, 2008
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ hsmagick.cabal view
@@ -0,0 +1,23 @@+name: hsmagick+version: 0.1+synopsis: FFI bindings for the GraphicsMagick library+description: FFI bindings for the GraphicsMagick library+category: Graphics+license: BSD3+license-file: LICENSE+author: Tim Chevalier+maintainer: chevalier@alum.wellesley.edu+copyright: (c) Tim Chevalier, 2008+stability: alpha+homepage: http://community.haskell.org/~tim+build-depends: base, directory, filepath, pretty, process+exposed-modules: Graphics.Transform.Magick.Images, Graphics.Transform.Magick.Types, Graphics.Transform.Magick.Test+other-modules: Graphics.Transform.Magick.FFIHelpers, Graphics.Transform.Magick.Util, Graphics.Transform.Magick.Errors, Graphics.Transform.Magick.Magick+ghc-options: -Wall+extra-libraries: tiff jasper jpeg png wmflite bz2 z m pthread+pkgconfig-depends: GraphicsMagick >= 1.1.10, lcms, freetype2, sm, ice, x11, libxml-2.0+tested-with: GHC ==6.8.2+extensions: CPP, ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies, PatternSignatures+data-files: README+build-type: Simple+
+ tjc-notes view
@@ -0,0 +1,159 @@++Sept. 6++I can't figure out how to define a structure with an array field. c2hs will do it, maybe?+Look for an example of a struct type like this in gtk2hs or something.++Sept. 7++perhaps #ptr in hsc2hs could be used to get the address of imageInfo->filename, then we can call strcpy (or pokeByteOff).++WriteImage returns 1. I don't know if it's an error or not. in any case, when I pass in the exception, catchException doesn't do anything. however ReadImage seems to be working all right. What's up? I do not know.++Oct. 5++So GraphicsMagick 1.1.7 (the version in the debian repo) deadlocks if you call InitializeMagick before the lock file exists. Trying to download 1.2.++building GraphicsMagick:+./configure --without-magick-plus-plus --without-perl++but it works now. to enable logging, set MAGICK_DEBUG environment variable to "All". This dumps log to stdout. (or stderr. whatever.)++(now we have two versions of GM installed so we have to make sure to set the include dirs so that it looks in /usr/local/include/GraphicsMagick first.)++Retardation: WriteImage uses the filename member of the image structure to determine the file to write to, but it takes both an Image and an ImageInfo, which BOTH have filename fields. They can get out of sync.++next up: Storable instance for HImage++maybe it would make a lot more sense to do this by patching hsc2hs to handle array fields in structs...++Oct. 6++Issues:+- repeated code for exception handling [DONE]+- charArray handling [DONE, or at least, now we use peek/poke or rather, getField and (-->)]+ * still an issue since getting one field of a pointer requires peeking the entire thing,+ and writing one field requires peeking/poking the entire thing+- boilerplate for type declarations and Storable instances +- what about memory management?++next up: write a Storable instance for ExceptionInfo (which is a struct contained inside a struct,+so things weren't getting copied properly.)++Things under transform.html that aren't implemented yet because they involve animation:+* CoalesceImages++Oct. 7++We don't need an exception field in our HImage -- we should use the exception field in+an Image.++next up: resize++Working on enhancement ops.++Oct. 8++gm convert -gamma foo/bar/quux doesn't seem to work. report it!++doc bug to report: LevelImageChannel doesn't actually take a level string.+++----+constituteImage is worth writing home about. Look at the type in Haskell!+Look at the type in C!++working on dispatchImage. blergh type errrors...++Oct. 10++dispatchImage gives this error:+Images_in.hs:300:50:+ Ambiguous type variables `b', `a' in the constraint:+ `StorablePixel a b'+ arising from use of `storageType' at Images_in.hs:300:50-75+ Probable fix: add a type signature that fixes these type variable(s)++Not sure if it's recoverable. Think!++It is, but only by doing some stupid things.++Next: test for exportPixelImageArea.++Oct. 11++I seem to be doing one function per day. Done with exportPixelImageArea, on to+ExportPixelAreaOptionsInit.++Oct. 12++ah, this doesn't need to be in the API (should only be used w/in exportPixel+ImageArea, or perhaps not at all)++importPixelImageArea is done, now need a test.++Oct. 13++ImportPixelAreaOptionsInit also doesn't need to be in the API, but should use it w/in import... Maybe.++working on C code to try to figure out what ReadInlineImage does. there seem to be problems if there are nulls in the binary image data.++Oct. 14++the base-64-reading code is *very* fragile:+- there must be a comma between the metadata and the string itself +- we have to delete the three-equals-signs-on-a-single-line at the end+- string can't have newlines.++status:+resizing: all functions implemented+transforms: CoalesceImages, DeconstructImages not done yet, but will be.+ TransformImage will not be implemented.+shear/rotate: all functions implemented+enhancement: all functions implemented+constitution: everything except WriteImages and some functions that probably aren't necessary are implemented.+composition: all functions implemented+image methods: not doing AllocateNextImage or AnimateImages yet+ or CatchImageException: what's the difference between this and CatchException?+ or DisplayImages, GetImageException+ is ModifyImage necessary?+ also not sure if we need ReferenceImage+ No wrappers yet for AccessDefinition, AddDefinitions, RemoveDefinition (do we ever need to+ manipulate this stuff from Haskell?)+ ClipPathImage: not implemented b/c I can't find a way to test it+image channel methods:+color counting:+reducing colors:+segmenting:+image effects:+special effects:+image decoration:+text attributes:+annotation:+painting:+drawing:+thumbnails:+interactive display/edit:+interactive animation:+getting/setting pixels:+image lists:+reading/writing objects:+reading/listing formats:+message digests:+registry:+error:+pixel operators:+progress monitor:+++when we create images, should we use a finalizer that calls DestroyImage?++next: wrappers for everything under "Image methods" in Magick. fwee!++setImageColormap doesn't work. why????????/++Oct. 16++argh, I don't understand how ClipPathImage works. is the image with the clipping path in it required to be a TIFF? I have an SVG image with a path in it and it doesn't seem to work.++I want to post to the mailing list but my subscription request seems to be pending.