{-# LINE 1 "Graphics/Transform/Magick/Images.hsc" #-}
module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage, pingImage,
{-# LINE 2 "Graphics/Transform/Magick/Images.hsc" #-}
              readInlineImage,
              getFilename,
             -- transformations
              flipImage,
              flopImage,
              rotateImage,
              affineTransform,
              shearImage,
              chopImage,
              cropImage,
              flattenImage,
              mosaic,
              rollImage,
              shaveImage,
              -- resizing
              scaleImage,
              magnifyImage,
              minifyImage,
              sampleImage,
              thumbnailImage,
              resizeImage,
              -- enhancements
              contrastImage,
              equalizeImage,
              gammaImage,
              levelImage,
              levelImageChannel,
              modulateImage,
              negateImage,
              normalizeImage,
             -- constitution
              constituteImage,
              dispatchImage,
              --exportPixelImageArea,
              importPixelImageArea,
             -- composition
              compositeImage,
             -- image methods
              allocateImage,
              setImageColormap,
              newImageColormap,
              appendImages,
              averageImages,
              cycleColormapImage,
--              describeImage,
             -- Stuff what displays stuff
              animateImages) where


{-# LINE 51 "Graphics/Transform/Magick/Images.hsc" #-}

import Graphics.Transform.Magick.Magick
import Graphics.Transform.Magick.Types
import Graphics.Transform.Magick.FFIHelpers
import Graphics.Transform.Magick.Errors
import Graphics.Transform.Magick.Util

import Data.Char
import Data.List
import System.Directory

-- 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)
                   (((\hsc_ptr -> hsc_ptr `plusPtr` 6544)) (getImage hImage))
{-# LINE 148 "Graphics/Transform/Magick/Images.hsc" #-}
  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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) importInfo
{-# LINE 468 "Graphics/Transform/Magick/Images.hsc" #-}
           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)