[project @ 2004-05-20 16:53:58 by duncan_coutts] haddock fix

--  -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Pixbuf@
--
--  Author : Vincenzo Ciancia, Axel Simon
--  Created: 26 March 2002
--
--  Version $Revision: 1.6 $ from $Date: 2004/05/20 16:53:58 $
--
--  Copyright (c) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Library General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
--  @ref data Pixbuf@s are bitmap images in memory.
--
-- @documentation@ ------------------------------------------------------------
--
-- * A Pixbuf is used to represent images. It contains information
--   about the image's pixel data, its color space, bits per sample, width
--   and height, and the rowstride or number of bytes between rows.
--
-- * This module contains functions to scale and crop
--   @ref data Pixbuf@s and to scale and crop a @ref data Pixbuf@ and
--   compose the result with an existing image.
--
-- @todo@ ---------------------------------------------------------------------
--
-- * if there is a portable way of modifying external arrays in Haskell do:
--	gdk_pixbuf_get_pixels, gdk_pixbuf_new_from_data, everything in
--	Inline data,
--
-- * if anybody writes an image manipulation program, do the checker board
--   functions: gdk_pixbuf_composite_color_simple and
--   gdk_pixbuf_composite_color. Moreover, do: pixbuf_saturate_and_pixelate
--
-- * the animation functions
--
-- * pixbuf loader
--
-- * module interface
--
-- * rendering function for Bitmaps and Pixmaps when the latter are added
--
module Pixbuf(
  Pixbuf,
  PixbufClass,
  PixbufError(..),
  Colorspace(..),
  pixbufGetColorSpace,
  pixbufGetNChannels,
  pixbufGetHasAlpha,
  pixbufGetBitsPerSample,
  pixbufGetWidth,
  pixbufGetHeight,
  pixbufGetRowstride,
  pixbufGetOption,
  pixbufNewFromFile,
  ImageType,
  pixbufGetFormats,
  pixbufSave,
  pixbufNew,
  pixbufNewFromXPMData,
  InlineImage,
  pixbufNewFromInline,
  pixbufNewSubpixbuf,
  pixbufCopy,
  InterpType(..),
  pixbufScaleSimple,
  pixbufScale,
  pixbufComposite,
  pixbufAddAlpha,
  pixbufCopyArea,
  pixbufFill,
  pixbufGetFromDrawable
  ) where

import FFI
{#import Hierarchy#}
import GObject
import Monad

import Structs		(GError(..), GQuark, Rectangle(..))
import LocalData	(unsafePerformIO)
import Exception	(bracket)
import LocalData	((.|.), shiftL)

{#context prefix="gdk" #}

-- @data PixbufError@ Error codes for loading image files.
--
{#enum PixbufError {underscoreToCase} #}

-- @data Colorspace@ Enumerate all supported color spaces.
--
-- * Only RGB is supported right now.
--
{#enum Colorspace {underscoreToCase} #}

-- @method pixbufGetColorSpace@ Queries the color space of a pixbuf.
--
pixbufGetColorSpace :: Pixbuf -> IO Colorspace
pixbufGetColorSpace pb = liftM (toEnum . fromIntegral) $
  {#call unsafe pixbuf_get_colorspace#} pb

-- @method pixbufGetNChannels@ Queries the number of colors for each pixel.
--
pixbufGetNChannels :: Pixbuf -> IO Int
pixbufGetNChannels pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_n_channels#} pb

-- @method pixbufGetHasAlpha@ Query if the image has an alpha channel.
--
-- * The alpha channel determines the opaqueness of the pixel.
--
pixbufGetHasAlpha :: Pixbuf -> IO Bool
pixbufGetHasAlpha pb =
  liftM toBool $ {#call unsafe pixbuf_get_has_alpha#} pb

-- @method pixbufGetBitsPerSample@ Queries the number of bits for each color.
--
-- * Each pixel is has a number of cannels for each pixel, each channel
--   has this many bits.
--
pixbufGetBitsPerSample :: Pixbuf -> IO Int
pixbufGetBitsPerSample pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_bits_per_sample#} pb

-- @method pixbufGetWidth@ Queries the width of this image.
--
pixbufGetWidth :: Pixbuf -> IO Int
pixbufGetWidth pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_width#} pb

-- @method pixbufGetHeight@ Queries the height of this image.
--
pixbufGetHeight :: Pixbuf -> IO Int
pixbufGetHeight pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_height#} pb

-- @method pixbufGetRowstride@ Queries the rowstride of this image.
--
-- * Queries the rowstride of a pixbuf, which is the number of bytes between
--   rows. Use this value to caculate the offset to a certain row.
--
pixbufGetRowstride :: Pixbuf -> IO Int
pixbufGetRowstride pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_rowstride#} pb

-- @method pixbufGetOption@ Returns an attribut of an image.
--
-- * Looks up if some information was stored under the @ref arg key@ when
--   this image was saved.
--
pixbufGetOption :: Pixbuf -> String -> IO (Maybe String)
pixbufGetOption pb key = withUTFString key $ \strPtr -> do
  resPtr <- {#call unsafe pixbuf_get_option#} pb strPtr
  if (resPtr==nullPtr) then return Nothing else
    liftM Just $ peekUTFString resPtr

-- pixbufErrorDomain -- helper function
pixbufErrorDomain :: GQuark
pixbufErrorDomain = unsafePerformIO {#call unsafe pixbuf_error_quark#}

-- @constructor pixbufNewFromFile@ Load an image synchonously.
--
-- * Use this function to load only small images as this call will block.
--
-- * The function will return @literal Left (err,msg)@ where @ref arg err@
--   is the error code and @ref arg msg@ is a human readable description
--   of the error. If an error occurs which is not captured by any of
--   those in @ref data PixbufError@, an exception is thrown.
--
pixbufNewFromFile :: FilePath -> IO (Either (PixbufError,String) Pixbuf)
pixbufNewFromFile fname = withUTFString fname $ \strPtr ->
  alloca $ \errPtrPtr -> do
  pbPtr <- {#call unsafe pixbuf_new_from_file#} strPtr (castPtr errPtrPtr)
  if pbPtr/=nullPtr then liftM Right $ makeNewGObject mkPixbuf (return pbPtr)
    else do
      errPtr <- peek errPtrPtr
      (GError dom code msg) <- peek errPtr
      if dom==pixbufErrorDomain then
        return (Left (toEnum (fromIntegral code), msg))
       else
	error msg

-- @type ImageType@ A string representing an image file format.
--
type ImageType = String

-- @constant pixbufGetFormats@ A list of valid image file formats.
--
pixbufGetFormats :: [ImageType]

pixbufGetFormats = ["png","bmp","wbmp", "gif","ico","ani","jpeg","pnm",
		    "ras","tiff","xpm","xbm","tga"]

-- @method pixbufSave@ Save an image to disk.
--
-- * The function takes a list of key - value pairs to specify
--   either how an image is saved or to actually save this additional
--   data with the image. JPEG images can be saved with a "quality"
--   parameter; its value should be in the range [0,100]. Text chunks
--   can be attached to PNG images by specifying parameters of the form
--   "tEXt::key", where key is an ASCII string of length 1-79.
--   The values are Unicode strings.
--
-- * The function returns @literal Nothing@ if writing was successful.
--   Otherwise the error code and a description is returned or,
--   if the error is not captured by one of the error codes in
--   @ref data PixbufError@, an exception is thrown.
--
pixbufSave :: Pixbuf -> FilePath -> ImageType -> [(String, String)] ->
	      IO (Maybe (PixbufError, String))
pixbufSave pb fname iType options =
  let (keys, values) = unzip options in
  let optLen = length keys in
  withUTFString fname $ \fnPtr ->
  withUTFString iType $ \tyPtr ->
  allocaArray0 optLen $ \keysPtr ->
  allocaArray optLen $ \valuesPtr ->
  alloca $ \errPtrPtr -> do
    keyPtrs <- mapM newUTFString keys
    valuePtrs <- mapM newUTFString values
    pokeArray keysPtr keyPtrs
    pokeArray valuesPtr valuePtrs
    res <- {#call unsafe pixbuf_savev#} pb fnPtr tyPtr keysPtr valuesPtr
					(castPtr errPtrPtr)
    mapM_ free keyPtrs
    mapM_ free valuePtrs
    if not (toBool res) then return Nothing else do
      errPtr <- peek errPtrPtr
      (GError dom code msg) <- peek errPtr
      if dom==pixbufErrorDomain then
        return (Just (toEnum (fromIntegral code), msg))
       else
	error msg

-- @constructor pixbufNew@ Create a new image in memory.
--
-- * Creates a new pixbuf structure and allocates a buffer for
--   it. Note that the buffer is not cleared initially.
--
pixbufNew :: Colorspace -> Bool -> Int -> Int -> Int -> IO Pixbuf
pixbufNew colorspace hasAlpha bitsPerSample width height =
  makeNewGObject mkPixbuf $
    {#call pixbuf_new#} ((fromIntegral . fromEnum) colorspace)
      (fromBool hasAlpha) (fromIntegral bitsPerSample) (fromIntegral width)
      (fromIntegral height)

-- @constructor pixbufNewFromXPMData@ Create a new image from a String.
--
-- * Creates a new pixbuf from a string description.
--
pixbufNewFromXPMData :: [String] -> IO Pixbuf
pixbufNewFromXPMData s =
  bracket (mapM newUTFString s) (mapM free) $ \strPtrs ->
    withArray0 nullPtr strPtrs $ \strsPtr ->
      makeNewGObject mkPixbuf $ {#call pixbuf_new_from_xpm_data#} strsPtr

-- @data InlineImage@ A dymmy type for inline picture data.
--
-- * This dummy type is used to declare pointers to image data
--   that is embedded in the executable. See
--   @ref constructor pixbufNewFromInline@ for an example.
--
data InlineImage = InlineImage

-- @constructor pixbufNewFromInline@ Create a new image from a static pointer.
--
-- * Like @ref constructor pixbufNewFromXPMData@, this function allows to
--   include images in the final binary program. The method used by this
--   function uses a binary representation and therefore needs less space
--   in the final executable. Save the image you want to include as
--   @literal png@ and run @prog
--   echo #include "my_image.h" > my_image.c
--   gdk-pixbuf-csource --raw --extern --name=my_image myimage.png >> my_image.c
--   @ on it. Write a header file @literal my_image.h@ containing @prog
--   #include <gdk/gdk.h>
--   extern guint8 my_image\[\];
--   @ and save it in the current directory.
--   The created file can be compiled with @prog
--   cc -c my_image.c `pkg-config --cflags gdk-2.0`
--   @ into an object file which must be linked into your Haskell program by
--   specifying @literal my_image.o@ and @literal "-#include my_image.h"@ on
--   the command line of GHC.
--   Within you application you delcare a pointer to this image: @prog
--   foreign label "my_image" myImage :: Ptr InlineImage
--   @ Calling @ref constructor pixbufNewFromInline@ with this pointer will
--   return the image in the object file. Creating the C file with
--   the @literal --raw@ flag will result in a non-compressed image in the
--   object file. The advantage is that the picture will not be
--   copied when this function is called.
--
--
pixbufNewFromInline :: Ptr InlineImage -> IO Pixbuf
pixbufNewFromInline iPtr = alloca $ \errPtrPtr -> do
  pbPtr <- {#call unsafe pixbuf_new_from_inline#} (-1) (castPtr iPtr)
    (fromBool False) (castPtr errPtrPtr)
  if pbPtr/=nullPtr then makeNewGObject mkPixbuf (return pbPtr)
    else do
      errPtr <- peek errPtrPtr
      (GError dom code msg) <- peek errPtr
      error msg

-- @method pixbufNewSubpixbuf@ Create a restricted view of an image.
--
-- * This function returns a @ref data Pixbuf@ object which shares
--   the image of the original one but only shows a part of it.
--   Modifying either buffer will affect the other.
--
-- * This function throw an exception if the requested bounds are invalid.
--
pixbufNewSubpixbuf :: Pixbuf -> Int -> Int -> Int -> Int -> IO Pixbuf
pixbufNewSubpixbuf pb srcX srcY height width =
  makeNewGObject mkPixbuf $ do
    pbPtr <- {#call unsafe pixbuf_new_subpixbuf#} pb
      (fromIntegral srcX) (fromIntegral srcY)
      (fromIntegral height) (fromIntegral width)
    if pbPtr==nullPtr then error "pixbufNewSubpixbuf: invalid bounds"
      else return pbPtr

-- @constructor pixbufCopy@ Create a deep copy of an image.
--
pixbufCopy :: Pixbuf -> IO Pixbuf
pixbufCopy pb = makeNewGObject mkPixbuf $ {#call unsafe pixbuf_copy#} pb

-- @data InterpType@ How an image is scaled.
--
--
-- * @variant InterpNearest@ Nearest neighbor sampling; this is the
--   fastest and lowest quality mode. Quality is normally unacceptable when
--   scaling down, but may be OK when scaling up.
--
-- * @variant InterpTiles@ This is an accurate simulation of the
--   PostScript image operator without any interpolation enabled. Each
--   pixel is rendered as a tiny parallelogram of solid color, the edges of
--   which are implemented with antialiasing. It resembles nearest neighbor
--   for enlargement, and bilinear for reduction.
--
-- * @variant InterpBilinear@ Best quality/speed balance; use this
--   mode by default. Bilinear interpolation. For enlargement, it is
--   equivalent to point-sampling the ideal bilinear-interpolated
--   image. For reduction, it is equivalent to laying down small tiles and
--   integrating over the coverage area.
--
-- * @variant InterpHyper@ This is the slowest and highest quality
--   reconstruction function. It is derived from the hyperbolic filters in
--   Wolberg's "Digital Image Warping", and is formally defined as the
--   hyperbolic-filter sampling the ideal hyperbolic-filter interpolated
--   image (the filter is designed to be idempotent for 1:1 pixel mapping).
--
{#enum InterpType {underscoreToCase} #}

-- @method pixbufScaleSimple@ Scale an image.
--
-- * Creates a new @ref data GdkPixbuf@ containing a copy of
--   @ref arg src@ scaled to the given measures. Leaves @ref arg src@
--   unaffected.
--
-- * @ref arg interp@ affects the quality and speed of the scaling function.
--   @variant InterpNearest@ is the fastest option but yields very poor
--   quality when scaling down. @variant InterpBilinear@ is a good
--   trade-off between speed and quality and should thus be used as a
--   default.
--
pixbufScaleSimple :: Pixbuf -> Int -> Int -> InterpType -> IO Pixbuf
pixbufScaleSimple pb width height interp =
    makeNewGObject mkPixbuf $ liftM castPtr $
	{#call pixbuf_scale_simple#} (toPixbuf pb)
	(fromIntegral width) (fromIntegral height)
	(fromIntegral $ fromEnum interp)

-- @method pixbufScale@ Copy a scaled image part to another image.
--
-- * This function is the generic version of @ref method pixbufScaleSimple@.
--   It scales @ref arg src@ by @ref arg scaleX@ and @ref arg scaleY@ and
--   translate the image by @ref arg offsetX@ and @ref arg offsetY@. Whatever
--   is in the intersection with the rectangle @ref arg destX@,
--   @ref arg destY@, @ref arg destWidth@, @ref arg destHeight@ will be
--   rendered into @ref arg dest@.
--
-- * The rectangle in the destination is simply overwritten. Use
--   @ref method pixbufComposite@ if you need to blend the source
--   image onto the destination.
--
pixbufScale :: Pixbuf -> Pixbuf -> Int -> Int -> Int -> Int ->
	       Double -> Double -> Double -> Double -> InterpType -> IO ()
pixbufScale src dest destX destY destWidth destHeight offsetX offsetY
            scaleX scaleY interp = {#call unsafe pixbuf_scale#} src dest
  (fromIntegral destX) (fromIntegral destY) (fromIntegral destHeight)
  (fromIntegral destWidth) (realToFrac offsetX) (realToFrac offsetY)
  (realToFrac scaleX) (realToFrac scaleY)
  ((fromIntegral . fromEnum) interp)

-- @method pixbufComposite@ Blend a scaled image part onto another image.
--
-- * This function is similar to @ref method pixbufScale@ but allows the
--   original image to "shine through". The @ref arg alpha@ value determines
--   how opaque the source image is. Passing @literal 0@ is
--   equivalent to not calling this function at all, passing
--   @literal 255@ has the
--   same effect as calling @ref method pixbufScale@.
--
pixbufComposite :: Pixbuf -> Pixbuf -> Int -> Int -> Int -> Int ->
		   Double -> Double -> Double -> Double -> InterpType ->
	       	   Word8 -> IO ()
pixbufComposite src dest destX destY destWidth destHeight
  offsetX offsetY scaleX scaleY interp alpha =
  {#call unsafe pixbuf_composite#} src dest
  (fromIntegral destX) (fromIntegral destY) (fromIntegral destHeight)
  (fromIntegral destWidth) (realToFrac offsetX) (realToFrac offsetY)
  (realToFrac scaleX) (realToFrac scaleY)
  ((fromIntegral . fromEnum) interp) (fromIntegral alpha)

-- @method pixbufAddAlpha@ Add an opacity layer to the @ref data Pixbuf@.
--
-- * This function returns a copy of the given @ref arg src@
--   @ref data Pixbuf@, leaving @ref arg src@ unmodified.
--   The new @ref data Pixbuf@ has an alpha (opacity)
--   channel which defaults to @literal 255@ (fully opaque pixels)
--   unless @ref arg src@ already had an alpha channel in which case
--   the original values are kept.
--   Passing in a color triple @literal (r,g,b)@ makes all
--   pixels that have this color fully transparent
--   (opacity of @literal 0@). The pixel color itself remains unchanged
--   during this substitution.
--
pixbufAddAlpha :: Pixbuf -> Maybe (Word8, Word8, Word8) -> IO Pixbuf
pixbufAddAlpha pb Nothing = makeNewGObject mkPixbuf $
  {#call unsafe pixbuf_add_alpha#} pb (fromBool False) 0 0 0
pixbufAddAlpha pb (Just (r,g,b)) = makeNewGObject mkPixbuf $
  {#call unsafe pixbuf_add_alpha#} pb (fromBool True)
    (fromIntegral r) (fromIntegral g) (fromIntegral b)

-- @method pixbufCopyArea@ Copy a rectangular portion into another
-- @ref data Pixbuf@.
--
-- * The source @ref data Pixbuf@ remains unchanged. Converion between
--   different formats is done automatically.
--
pixbufCopyArea :: Pixbuf -> Int -> Int -> Int -> Int ->
		  Pixbuf -> Int -> Int -> IO ()
pixbufCopyArea src srcX srcY srcWidth srcHeight dest destX destY =
  {#call unsafe pixbuf_copy_area#} src (fromIntegral srcX)
    (fromIntegral srcY) (fromIntegral srcHeight) (fromIntegral srcWidth)
    dest (fromIntegral destX) (fromIntegral destY)

-- @method pixbufFill@ Fills a @ref data Pixbuf@ with a color.
--
-- * The passed-in color is a quadruple consisting of the red, green, blue
--   and alpha component of the pixel. If the @ref data Pixbuf@ does not
--   have an alpha channel, the alpha value is ignored.
--
pixbufFill :: Pixbuf -> Word8 -> Word8 -> Word8 -> Word8 -> IO ()
pixbufFill pb red green blue alpha = {#call unsafe pixbuf_fill#} pb
  ((fromIntegral red)   `shiftL` 24 .|.
   (fromIntegral green) `shiftL` 16 .|.
   (fromIntegral blue)  `shiftL`  8 .|.
   (fromIntegral alpha))

-- @method pixbufGetFromDrawable@ Take a screenshot of a @ref data Drawable@.
--
-- * This function creates a @ref data Pixbuf@ and fills it with the image
--   currently in the @ref data Drawable@ (which might be invalid if the
--   window is obscured or minimized). Note that this transfers data from
--   the server to the client on X Windows.
--
-- * This function will return a @ref data Pixbuf@ with no alpha channel
--   containing the part of the @ref data Drawable@ specified by the
--   rectangle. The function will return @literal Nothing@ if the window
--   is not currently visible.
--
pixbufGetFromDrawable :: DrawableClass d => d -> Rectangle -> IO (Maybe Pixbuf)
pixbufGetFromDrawable d (Rectangle x y width height) = do
  pbPtr <- {#call unsafe pixbuf_get_from_drawable#}
    (mkPixbuf nullForeignPtr) (toDrawable d) (mkColormap nullForeignPtr)
    (fromIntegral x) (fromIntegral y) 0 0
    (fromIntegral width) (fromIntegral height)
  if pbPtr==nullPtr then return Nothing else liftM Just $
    makeNewGObject mkPixbuf (return pbPtr)

--  -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Pixbuf@
--
--  Author : Vincenzo Ciancia, Axel Simon
--  Created: 26 March 2002
--
--  Version $Revision: 1.5 $ from $Date: 2003/07/09 22:42:44 $
--
--  Copyright (c) 2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Library General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
--  @ref data Pixbuf@s are bitmap images in memory.
--
-- @documentation@ ------------------------------------------------------------
--
-- * A Pixbuf is used to represent images. It contains information
--   about the image's pixel data, its color space, bits per sample, width
--   and height, and the rowstride or number of bytes between rows.
--
-- * This module contains functions to scale and crop
--   @ref data Pixbuf@s and to scale and crop a @ref data Pixbuf@ and
--   compose the result with an existing image.
--
-- @todo@ ---------------------------------------------------------------------
--
-- * if there is a portable way of modifying external arrays in Haskell do:
--	gdk_pixbuf_get_pixels, gdk_pixbuf_new_from_data, everything in
--	Inline data,
--
-- * if anybody writes an image manipulation program, do the checker board
--   functions: gdk_pixbuf_composite_color_simple and
--   gdk_pixbuf_composite_color. Moreover, do: pixbuf_saturate_and_pixelate
--
-- * the animation functions
--
-- * pixbuf loader
--
-- * module interface
--
-- * rendering function for Bitmaps and Pixmaps when the latter are added
--
module Pixbuf(
  Pixbuf,
  PixbufClass,
  PixbufError(..),
  Colorspace(..),
  pixbufGetColorSpace,
  pixbufGetNChannels,
  pixbufGetHasAlpha,
  pixbufGetBitsPerSample,
  pixbufGetWidth,
  pixbufGetHeight,
  pixbufGetRowstride,
  pixbufGetOption,
  pixbufNewFromFile,
  ImageType,
  pixbufGetFormats,
  pixbufSave,
  pixbufNew,
  pixbufNewFromXPMData,
  InlineImage,
  pixbufNewFromInline,
  pixbufNewSubpixbuf,
  pixbufCopy,
  InterpType(..),
  pixbufScaleSimple,
  pixbufScale,
  pixbufComposite,
  pixbufAddAlpha,
  pixbufCopyArea,
  pixbufFill,
  pixbufGetFromDrawable
  ) where

import FFI
{#import Hierarchy#}
import GObject
import Monad

import Structs		(GError(..), GQuark, Rectangle(..))
import LocalData	(unsafePerformIO)
import Exception	(bracket)
import LocalData	((.|.), shiftL)

{#context prefix="gdk" #}

-- @data PixbufError@ Error codes for loading image files.
--
{#enum PixbufError {underscoreToCase} #}

-- @data Colorspace@ Enumerate all supported color spaces.
--
-- * Only RGB is supported right now.
--
{#enum Colorspace {underscoreToCase} #}

-- @method pixbufGetColorSpace@ Queries the color space of a pixbuf.
--
pixbufGetColorSpace :: Pixbuf -> IO Colorspace
pixbufGetColorSpace pb = liftM (toEnum . fromIntegral) $
  {#call unsafe pixbuf_get_colorspace#} pb

-- @method pixbufGetNChannels@ Queries the number of colors for each pixel.
--
pixbufGetNChannels :: Pixbuf -> IO Int
pixbufGetNChannels pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_n_channels#} pb

-- @method pixbufGetHasAlpha@ Query if the image has an alpha channel.
--
-- * The alpha channel determines the opaqueness of the pixel.
--
pixbufGetHasAlpha :: Pixbuf -> IO Bool
pixbufGetHasAlpha pb =
  liftM toBool $ {#call unsafe pixbuf_get_has_alpha#} pb

-- @method pixbufGetBitsPerSample@ Queries the number of bits for each color.
--
-- * Each pixel is has a number of cannels for each pixel, each channel
--   has this many bits.
--
pixbufGetBitsPerSample :: Pixbuf -> IO Int
pixbufGetBitsPerSample pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_bits_per_sample#} pb

-- @method pixbufGetWidth@ Queries the width of this image.
--
pixbufGetWidth :: Pixbuf -> IO Int
pixbufGetWidth pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_width#} pb

-- @method pixbufGetHeight@ Queries the height of this image.
--
pixbufGetHeight :: Pixbuf -> IO Int
pixbufGetHeight pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_height#} pb

-- @method pixbufGetRowstride@ Queries the rowstride of this image.
--
-- * Queries the rowstride of a pixbuf, which is the number of bytes between
--   rows. Use this value to caculate the offset to a certain row.
--
pixbufGetRowstride :: Pixbuf -> IO Int
pixbufGetRowstride pb = liftM fromIntegral $
  {#call unsafe pixbuf_get_rowstride#} pb

-- @method pixbufGetOption@ Returns an attribut of an image.
--
-- * Looks up if some information was stored under the @ref arg key@ when
--   this image was saved.
--
pixbufGetOption :: Pixbuf -> String -> IO (Maybe String)
pixbufGetOption pb key = withUTFString key $ \strPtr -> do
  resPtr <- {#call unsafe pixbuf_get_option#} pb strPtr
  if (resPtr==nullPtr) then return Nothing else
    liftM Just $ peekUTFString resPtr

-- pixbufErrorDomain -- helper function
pixbufErrorDomain :: GQuark
pixbufErrorDomain = unsafePerformIO {#call unsafe pixbuf_error_quark#}

-- @constructor pixbufNewFromFile@ Load an image synchonously.
--
-- * Use this function to load only small images as this call will block.
--
-- * The function will return @literal Left (err,msg)@ where @ref arg err@
--   is the error code and @ref arg msg@ is a human readable description
--   of the error. If an error occurs which is not captured by any of
--   those in @ref data PixbufError@, an exception is thrown.
--
pixbufNewFromFile :: FilePath -> IO (Either (PixbufError,String) Pixbuf)
pixbufNewFromFile fname = withUTFString fname $ \strPtr ->
  alloca $ \errPtrPtr -> do
  pbPtr <- {#call unsafe pixbuf_new_from_file#} strPtr (castPtr errPtrPtr)
  if pbPtr/=nullPtr then liftM Right $ makeNewGObject mkPixbuf (return pbPtr)
    else do
      errPtr <- peek errPtrPtr
      (GError dom code msg) <- peek errPtr
      if dom==pixbufErrorDomain then
        return (Left (toEnum (fromIntegral code), msg))
       else
	error msg

-- @type ImageType@ A string representing an image file format.
--
type ImageType = String

-- @constant pixbufGetFormats@ A list of valid image file formats.
--
pixbufGetFormats :: [ImageType]

pixbufGetFormats = ["png","bmp","wbmp", "gif","ico","ani","jpeg","pnm",
		    "ras","tiff","xpm","xbm","tga"]

-- @method pixbufSave@ Save an image to disk.
--
-- * The function takes a list of key - value pairs to specify
--   either how an image is saved or to actually save this additional
--   data with the image. JPEG images can be saved with a "quality"
--   parameter; its value should be in the range [0,100]. Text chunks
--   can be attached to PNG images by specifying parameters of the form
--   "tEXt::key", where key is an ASCII string of length 1-79.
--   The values are Unicode strings.
--
-- * The function returns @literal Nothing@ if writing was successful.
--   Otherwise the error code and a description is returned or,
--   if the error is not captured by one of the error codes in
--   @ref data PixbufError@, an exception is thrown.
--
pixbufSave :: Pixbuf -> FilePath -> ImageType -> [(String, String)] ->
	      IO (Maybe (PixbufError, String))
pixbufSave pb fname iType options =
  let (keys, values) = unzip options in
  let optLen = length keys in
  withUTFString fname $ \fnPtr ->
  withUTFString iType $ \tyPtr ->
  allocaArray0 optLen $ \keysPtr ->
  allocaArray optLen $ \valuesPtr ->
  alloca $ \errPtrPtr -> do
    keyPtrs <- mapM newUTFString keys
    valuePtrs <- mapM newUTFString values
    pokeArray keysPtr keyPtrs
    pokeArray valuesPtr valuePtrs
    res <- {#call unsafe pixbuf_savev#} pb fnPtr tyPtr keysPtr valuesPtr
					(castPtr errPtrPtr)
    mapM_ free keyPtrs
    mapM_ free valuePtrs
    if not (toBool res) then return Nothing else do
      errPtr <- peek errPtrPtr
      (GError dom code msg) <- peek errPtr
      if dom==pixbufErrorDomain then
        return (Just (toEnum (fromIntegral code), msg))
       else
	error msg

-- @constructor pixbufNew@ Create a new image in memory.
--
-- * Creates a new pixbuf structure and allocates a buffer for
--   it. Note that the buffer is not cleared initially.
--
pixbufNew :: Colorspace -> Bool -> Int -> Int -> Int -> IO Pixbuf
pixbufNew colorspace hasAlpha bitsPerSample width height =
  makeNewGObject mkPixbuf $
    {#call pixbuf_new#} ((fromIntegral . fromEnum) colorspace)
      (fromBool hasAlpha) (fromIntegral bitsPerSample) (fromIntegral width)
      (fromIntegral height)

-- @constructor pixbufNewFromXPMData@ Create a new image from a String.
--
-- * Creates a new pixbuf from a string description.
--
pixbufNewFromXPMData :: [String] -> IO Pixbuf
pixbufNewFromXPMData s =
  bracket (mapM newUTFString s) (mapM free) $ \strPtrs ->
    withArray0 nullPtr strPtrs $ \strsPtr ->
      makeNewGObject mkPixbuf $ {#call pixbuf_new_from_xpm_data#} strsPtr

-- @data InlineImage@ A dymmy type for inline picture data.
--
-- * This dummy type is used to declare pointers to image data
--   that is embedded in the executable. See
--   @ref constructor pixbufNewFromInline@ for an example.
--
data InlineImage = InlineImage

-- @constructor pixbufNewFromInline@ Create a new image from a static pointer.
--
-- * Like @ref constructor pixbufNewFromXPMData@, this function allows to
--   include images in the final binary program. The method used by this
--   function uses a binary representation and therefore needs less space
--   in the final executable. Save the image you want to include as
--   @literal png@ and run @prog
--   echo #include "my_image.h" > my_image.c
--   gdk-pixbuf-csource --raw --extern --name=my_image myimage.png >> my_image.c
--   @ on it. Write a header file @literal my_image.h@ containing @prog
--   #include <gdk/gdk.h>
--   extern guint8 my_image[];
--   @ and save it in the current directory.
--   The created file can be compiled with @prog
--   cc -c my_image.c `pkg-config --cflags gdk-2.0`
--   @ into an object file which must be linked into your Haskell program by
--   specifying @literal my_image.o@ and @literal "-#include my_image.h"@ on
--   the command line of GHC.
--   Within you application you delcare a pointer to this image: @prog
--   foreign label "my_image" myImage :: Ptr InlineImage
--   @ Calling @ref constructor pixbufNewFromInline@ with this pointer will
--   return the image in the object file. Creating the C file with
--   the @literal --raw@ flag will result in a non-compressed image in the
--   object file. The advantage is that the picture will not be
--   copied when this function is called.
--
--
pixbufNewFromInline :: Ptr InlineImage -> IO Pixbuf
pixbufNewFromInline iPtr = alloca $ \errPtrPtr -> do
  pbPtr <- {#call unsafe pixbuf_new_from_inline#} (-1) (castPtr iPtr)
    (fromBool False) (castPtr errPtrPtr)
  if pbPtr/=nullPtr then makeNewGObject mkPixbuf (return pbPtr)
    else do
      errPtr <- peek errPtrPtr
      (GError dom code msg) <- peek errPtr
      error msg

-- @method pixbufNewSubpixbuf@ Create a restricted view of an image.
--
-- * This function returns a @ref data Pixbuf@ object which shares
--   the image of the original one but only shows a part of it.
--   Modifying either buffer will affect the other.
--
-- * This function throw an exception if the requested bounds are invalid.
--
pixbufNewSubpixbuf :: Pixbuf -> Int -> Int -> Int -> Int -> IO Pixbuf
pixbufNewSubpixbuf pb srcX srcY height width =
  makeNewGObject mkPixbuf $ do
    pbPtr <- {#call unsafe pixbuf_new_subpixbuf#} pb
      (fromIntegral srcX) (fromIntegral srcY)
      (fromIntegral height) (fromIntegral width)
    if pbPtr==nullPtr then error "pixbufNewSubpixbuf: invalid bounds"
      else return pbPtr

-- @constructor pixbufCopy@ Create a deep copy of an image.
--
pixbufCopy :: Pixbuf -> IO Pixbuf
pixbufCopy pb = makeNewGObject mkPixbuf $ {#call unsafe pixbuf_copy#} pb

-- @data InterpType@ How an image is scaled.
--
--
-- * @variant InterpNearest@ Nearest neighbor sampling; this is the
--   fastest and lowest quality mode. Quality is normally unacceptable when
--   scaling down, but may be OK when scaling up.
--
-- * @variant InterpTiles@ This is an accurate simulation of the
--   PostScript image operator without any interpolation enabled. Each
--   pixel is rendered as a tiny parallelogram of solid color, the edges of
--   which are implemented with antialiasing. It resembles nearest neighbor
--   for enlargement, and bilinear for reduction.
--
-- * @variant InterpBilinear@ Best quality/speed balance; use this
--   mode by default. Bilinear interpolation. For enlargement, it is
--   equivalent to point-sampling the ideal bilinear-interpolated
--   image. For reduction, it is equivalent to laying down small tiles and
--   integrating over the coverage area.
--
-- * @variant InterpHyper@ This is the slowest and highest quality
--   reconstruction function. It is derived from the hyperbolic filters in
--   Wolberg's "Digital Image Warping", and is formally defined as the
--   hyperbolic-filter sampling the ideal hyperbolic-filter interpolated
--   image (the filter is designed to be idempotent for 1:1 pixel mapping).
--
{#enum InterpType {underscoreToCase} #}

-- @method pixbufScaleSimple@ Scale an image.
--
-- * Creates a new @ref data GdkPixbuf@ containing a copy of
--   @ref arg src@ scaled to the given measures. Leaves @ref arg src@
--   unaffected.
--
-- * @ref arg interp@ affects the quality and speed of the scaling function.
--   @variant InterpNearest@ is the fastest option but yields very poor
--   quality when scaling down. @variant InterpBilinear@ is a good
--   trade-off between speed and quality and should thus be used as a
--   default.
--
pixbufScaleSimple :: Pixbuf -> Int -> Int -> InterpType -> IO Pixbuf
pixbufScaleSimple pb width height interp =
    makeNewGObject mkPixbuf $ liftM castPtr $
	{#call pixbuf_scale_simple#} (toPixbuf pb)
	(fromIntegral width) (fromIntegral height)
	(fromIntegral $ fromEnum interp)

-- @method pixbufScale@ Copy a scaled image part to another image.
--
-- * This function is the generic version of @ref method pixbufScaleSimple@.
--   It scales @ref arg src@ by @ref arg scaleX@ and @ref arg scaleY@ and
--   translate the image by @ref arg offsetX@ and @ref arg offsetY@. Whatever
--   is in the intersection with the rectangle @ref arg destX@,
--   @ref arg destY@, @ref arg destWidth@, @ref arg destHeight@ will be
--   rendered into @ref arg dest@.
--
-- * The rectangle in the destination is simply overwritten. Use
--   @ref method pixbufComposite@ if you need to blend the source
--   image onto the destination.
--
pixbufScale :: Pixbuf -> Pixbuf -> Int -> Int -> Int -> Int ->
	       Double -> Double -> Double -> Double -> InterpType -> IO ()
pixbufScale src dest destX destY destWidth destHeight offsetX offsetY
            scaleX scaleY interp = {#call unsafe pixbuf_scale#} src dest
  (fromIntegral destX) (fromIntegral destY) (fromIntegral destHeight)
  (fromIntegral destWidth) (realToFrac offsetX) (realToFrac offsetY)
  (realToFrac scaleX) (realToFrac scaleY)
  ((fromIntegral . fromEnum) interp)

-- @method pixbufComposite@ Blend a scaled image part onto another image.
--
-- * This function is similar to @ref method pixbufScale@ but allows the
--   original image to "shine through". The @ref arg alpha@ value determines
--   how opaque the source image is. Passing @literal 0@ is
--   equivalent to not calling this function at all, passing
--   @literal 255@ has the
--   same effect as calling @ref method pixbufScale@.
--
pixbufComposite :: Pixbuf -> Pixbuf -> Int -> Int -> Int -> Int ->
		   Double -> Double -> Double -> Double -> InterpType ->
	       	   Word8 -> IO ()
pixbufComposite src dest destX destY destWidth destHeight
  offsetX offsetY scaleX scaleY interp alpha =
  {#call unsafe pixbuf_composite#} src dest
  (fromIntegral destX) (fromIntegral destY) (fromIntegral destHeight)
  (fromIntegral destWidth) (realToFrac offsetX) (realToFrac offsetY)
  (realToFrac scaleX) (realToFrac scaleY)
  ((fromIntegral . fromEnum) interp) (fromIntegral alpha)

-- @method pixbufAddAlpha@ Add an opacity layer to the @ref data Pixbuf@.
--
-- * This function returns a copy of the given @ref arg src@
--   @ref data Pixbuf@, leaving @ref arg src@ unmodified.
--   The new @ref data Pixbuf@ has an alpha (opacity)
--   channel which defaults to @literal 255@ (fully opaque pixels)
--   unless @ref arg src@ already had an alpha channel in which case
--   the original values are kept.
--   Passing in a color triple @literal (r,g,b)@ makes all
--   pixels that have this color fully transparent
--   (opacity of @literal 0@). The pixel color itself remains unchanged
--   during this substitution.
--
pixbufAddAlpha :: Pixbuf -> Maybe (Word8, Word8, Word8) -> IO Pixbuf
pixbufAddAlpha pb Nothing = makeNewGObject mkPixbuf $
  {#call unsafe pixbuf_add_alpha#} pb (fromBool False) 0 0 0
pixbufAddAlpha pb (Just (r,g,b)) = makeNewGObject mkPixbuf $
  {#call unsafe pixbuf_add_alpha#} pb (fromBool True)
    (fromIntegral r) (fromIntegral g) (fromIntegral b)

-- @method pixbufCopyArea@ Copy a rectangular portion into another
-- @ref data Pixbuf@.
--
-- * The source @ref data Pixbuf@ remains unchanged. Converion between
--   different formats is done automatically.
--
pixbufCopyArea :: Pixbuf -> Int -> Int -> Int -> Int ->
		  Pixbuf -> Int -> Int -> IO ()
pixbufCopyArea src srcX srcY srcWidth srcHeight dest destX destY =
  {#call unsafe pixbuf_copy_area#} src (fromIntegral srcX)
    (fromIntegral srcY) (fromIntegral srcHeight) (fromIntegral srcWidth)
    dest (fromIntegral destX) (fromIntegral destY)

-- @method pixbufFill@ Fills a @ref data Pixbuf@ with a color.
--
-- * The passed-in color is a quadruple consisting of the red, green, blue
--   and alpha component of the pixel. If the @ref data Pixbuf@ does not
--   have an alpha channel, the alpha value is ignored.
--
pixbufFill :: Pixbuf -> Word8 -> Word8 -> Word8 -> Word8 -> IO ()
pixbufFill pb red green blue alpha = {#call unsafe pixbuf_fill#} pb
  ((fromIntegral red)   `shiftL` 24 .|.
   (fromIntegral green) `shiftL` 16 .|.
   (fromIntegral blue)  `shiftL`  8 .|.
   (fromIntegral alpha))

-- @method pixbufGetFromDrawable@ Take a screenshot of a @ref data Drawable@.
--
-- * This function creates a @ref data Pixbuf@ and fills it with the image
--   currently in the @ref data Drawable@ (which might be invalid if the
--   window is obscured or minimized). Note that this transfers data from
--   the server to the client on X Windows.
--
-- * This function will return a @ref data Pixbuf@ with no alpha channel
--   containing the part of the @ref data Drawable@ specified by the
--   rectangle. The function will return @literal Nothing@ if the window
--   is not currently visible.
--
pixbufGetFromDrawable :: DrawableClass d => d -> Rectangle -> IO (Maybe Pixbuf)
pixbufGetFromDrawable d (Rectangle x y width height) = do
  pbPtr <- {#call unsafe pixbuf_get_from_drawable#}
    (mkPixbuf nullForeignPtr) (toDrawable d) (mkColormap nullForeignPtr)
    (fromIntegral x) (fromIntegral y) 0 0
    (fromIntegral width) (fromIntegral height)
  if pbPtr==nullPtr then return Nothing else liftM Just $
    makeNewGObject mkPixbuf (return pbPtr)


Remove "Allocating: ..." message in newVar

-- -*- haskell -*-- -----------------------------------------------
-- |
-- Module      :  Data.Boolean.CUDD
-- Copyright   :  (C) 2002-2005, 2009 University of New South Wales, (C) 2009-2011 Peter Gammie
-- License     :  LGPL (see COPYING.LIB for details)
--
-- A binding for CUDD (Fabio Somenzi, University of Colorado).
--
-- Note this library is not thread-safe.
-------------------------------------------------------------------
module Data.Boolean.CUDD
    (
        BDD
    ,	module Data.Boolean

        -- * CUDD-specific functions
--          ,	gc
    ,	stats
    ,	reorder
    ,	dynamicReordering
    ,	varIndices
    ,	bddSize
    ,	printInfo
    ) where

-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------

#include "cudd_im.h"

import Control.DeepSeq  ( NFData )
import Control.Monad	( foldM, liftM, mapAndUnzipM, zipWithM_ )

import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
import Data.List	( genericLength )
import Data.Maybe	( fromJust, isJust )

import Data.Map         ( Map )
import qualified Data.Map as Map

import Foreign		( ForeignPtr, withForeignPtr, newForeignPtr, newForeignPtr_, finalizerFree, touchForeignPtr
                        , Ptr, advancePtr, castPtr, peek, pokeElemOff, ptrToIntPtr
                        , mallocArray )
import Foreign.C

import GHC.ForeignPtr   ( newConcForeignPtr )

import System.IO	( Handle, hIsReadable, hIsWritable )
-- import System.Mem	( performGC )
import System.Posix.IO	( handleToFd )
import System.IO.Unsafe	( unsafePerformIO )

import Data.Boolean

-------------------------------------------------------------------
-- Extra FFI functions.
-------------------------------------------------------------------

-- | A C file handle.
{#pointer *FILE -> CFile#}

-- | Convert a Haskell Handle into a C FILE *.
-- - FIXME: throw exception on error.
-- - suggested by Simon Marlow.
handleToCFile :: Handle -> IO FILE
handleToCFile h =
    do r <- hIsReadable h
       w <- hIsWritable h
       modestr <- newCString $ mode r w
       fd <- handleToFd h
       {#call unsafe fdopen#} (cToNum fd) modestr
    where mode :: Bool -> Bool -> String
          mode False False = error "Handle not readable or writable!"
          mode False True  = "w"
          mode True  False = "r"
          mode True  True  = "r+" -- FIXME

-- | The Haskell Handle is unusable after calling 'handleToCFile',
-- so provide a neutered "fprintf"-style thing here.
printCFile :: FILE -> String -> IO ()
printCFile file str =
    withCString str ({#call unsafe fprintf_neutered#} file)

--  Close a C FILE *.
-- - FIXME: throw exception on error.
-- closeCFile :: FILE -> IO ()
-- closeCFile cfile = do {#call unsafe fclose#} cfile
--                    return ()

cToNum :: (Num i, Integral e) => e -> i
cToNum  = fromIntegral . toInteger
{-# INLINE cToNum #-}

cFromEnum :: (Integral i, Enum e) => e -> i
cFromEnum  = fromIntegral . fromEnum
{-# INLINE cFromEnum #-}

-------------------------------------------------------------------
-- Types.
-------------------------------------------------------------------

-- | The BDD manager, which we hide from clients.
{#pointer *DdManager as DDManager newtype#}

-- | The arguments to 'Cudd_Init'.
{#enum CuddSubtableSize {} #}
{#enum CuddCacheSize {} #}

-- | Variable reordering tree options.
{#enum CuddMTRParams {} #}

-- | The abstract type of BDDs.
{#pointer *DdNode as BDD foreign newtype#}

{-# INLINE withBDD #-}

-- BDDs are just pointers, so there's no work to do when we @deepseq@ them.
instance Control.DeepSeq.NFData BDD

-- Belt-and-suspenders equality checking and ordering.
instance Eq BDD where
    bdd0 == bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p

instance Ord BDD where
    bdd0 <= bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p || bdd0p < bdd1p

instance Show BDD where
-- Print out the BDD as a sum-of-products.
    showsPrec _ = sop

-------------------------------------------------------------------
-- Administrative functions.
-------------------------------------------------------------------

-- | The BDD manager. This needs to be invoked before any of the
-- following functions... which we arrange for automagically.
ddmanager :: DDManager
ddmanager = unsafePerformIO $
  {#call unsafe Cudd_Init as _cudd_Init #}
    0 0 (cFromEnum UNIQUE_SLOTS) (cFromEnum CACHE_SLOTS) 0
{-# NOINLINE ddmanager #-}

-- | A map to and from BDD variable numbers.
-- FIXME: the second one would be more efficiently Data.IntMap, but we don't use it often.
type VarMap = (Map String BDD, Map CUInt String)

-- | Tracks existing variables.
bdd_vars :: IORef VarMap
bdd_vars = unsafePerformIO $ newIORef (Map.empty, Map.empty)
{-# NOINLINE bdd_vars #-}

-- | Attaches a finalizer to a BDD object.
-- The call to "Cudd_Ref" happens in C to ensure atomicity.
-- Returning objects with initial refcount 0 is a bad design decision.
addBDDfinalizer :: Ptr BDD -> IO BDD
addBDDfinalizer bddp = liftM BDD $ newConcForeignPtr bddp bddf
    where bddf = {#call unsafe Cudd_RecursiveDeref as _cudd_RecursiveDeref#} ddmanager bddp
                   >> return ()
{-# INLINE addBDDfinalizer #-}

-- | Attaches a null finalizer to a 'BDD' object.
-- Used for variables and constants.
addBDDnullFinalizer :: Ptr BDD -> IO BDD
addBDDnullFinalizer bddp = fmap BDD $ newForeignPtr_ bddp
{-# INLINE addBDDnullFinalizer #-}

-- Simulate an "apply" function to simplify atomic refcount incrementing.
{#enum CuddBinOp {} #}

-------------------------------------------------------------------
-- Logical operations.
-------------------------------------------------------------------

-- | Allocate a variable.
newVar :: IO (Ptr BDD) -> String -> IO (Maybe CUInt, BDD)
newVar allocVar label =
      do (toBDD, fromBDD) <- readIORef bdd_vars
         case label `Map.lookup` toBDD of
           Just bdd -> return (Nothing, bdd)
           Nothing ->
             do bddp <- allocVar
                vid <- fmap cToNum $
                         {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                --putStrLn $ label ++ " -> " ++ (show (vid, bdd))
                bdd <- addBDDnullFinalizer bddp
                writeIORef bdd_vars ( Map.insert label bdd   toBDD
                                    , Map.insert vid   label fromBDD )
                return (Just vid, bdd)

instance BooleanVariable BDD where
    bvar label = unsafePerformIO $
      fmap snd $ newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)  label

    bvars labels =
      case labels of
        [] -> []
        ls -> unsafePerformIO $
          do (vids, vars) <- mapAndUnzipM (newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)) ls
             if all isJust vids
               then groupVars (fromJust (head vids)) (genericLength vids)
               else putStrLn $ "hBDD-CUDD warning: not grouping variables " ++ show ls
             return vars
      where
        -- FIXME why one or the other?
        groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_DEFAULT) >> return ()
        -- groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_FIXED) >> return ()
        makeTreeNode = {#call unsafe Cudd_MakeTreeNode as _cudd_MakeTreeNode#}

    unbvar bdd = unsafePerformIO $ bdd `seq`
                   withBDD bdd $ \bddp ->
                     do vid <- {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                        (_, fromBDD) <- readIORef bdd_vars
                        return $ case cToNum vid `Map.lookup` fromBDD of
                                   Nothing -> "(VID: " ++ show vid ++ ")"
                                   Just v  -> v

instance Boolean BDD where
    true  = cudd_constant {#call unsafe Cudd_ReadOne as _cudd_ReadOne#}
    false = cudd_constant {#call unsafe Cudd_ReadLogicZero as _cudd_ReadLogicZero#}

    (/\)  = bddBinOp AND
    neg x = unsafePerformIO $ withBDD x $ \xp ->
      {#call unsafe cudd_bddNot#} xp >>= addBDDfinalizer

    nand  = bddBinOp NAND
    (\/)  = bddBinOp OR
    nor   = bddBinOp NOR
    xor   = bddBinOp XOR
    -- (-->) = FIXME ???
    (<->) = bddBinOp XNOR

    -- bITE i t e = unsafePerformIO $
    --   withBDD i $ \ip -> withBDD t $ \tp -> withBDD e $ \ep ->
    --     {#call unsafe cudd_bddIte#} ddmanager ip tp ep
    --       >>= addBDDfinalizer

cudd_constant :: (DDManager -> IO (Ptr BDD)) -> BDD
cudd_constant f = unsafePerformIO $ f ddmanager >>= addBDDnullFinalizer
{-# INLINE cudd_constant #-}

bddBinOp :: CuddBinOp -> BDD -> BDD -> BDD
bddBinOp op x y = unsafePerformIO $
  withBDD x $ \xp -> withBDD y $ \yp ->
    {#call unsafe cudd_BinOp#} ddmanager (cFromEnum op) xp yp >>= addBDDfinalizer
{-# INLINE bddBinOp #-}

instance QBF BDD where
    data Group BDD = MkGroup !BDD

    mkGroup = MkGroup . conjoin -- FIXME maybe use Cudd_bddComputeCube
    exists = cudd_exists
    forall = cudd_forall
    rel_product = cudd_rel_product

instance Substitution BDD where
  -- Cache substitution arrays.
  data Subst BDD = MkSubst {-# UNPACK #-} !Int
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))

  mkSubst = cudd_mkSubst
  rename = cudd_rename
  substitute = error "CUDD substitute" -- cudd_substitute

cudd_mkSubst :: [(BDD, BDD)] -> Subst BDD
cudd_mkSubst subst = unsafePerformIO $
    do arrayx  <- mallocArray len
       arrayx' <- mallocArray len
       zipWithM_ (pokeSubst arrayx arrayx') subst [0..]
       fpx  <- newForeignPtr finalizerFree arrayx
       fpx' <- newForeignPtr finalizerFree arrayx'
       return (MkSubst len fpx fpx')
  where
    pokeSubst :: Ptr (Ptr BDD) -> Ptr (Ptr BDD) -> (BDD, BDD) -> Int -> IO ()
    pokeSubst arrayx arrayx' (v, v') i =
      do withBDD v  $ pokeElemOff arrayx  i
         withBDD v' $ pokeElemOff arrayx' i

    len = length subst
{-# INLINE cudd_mkSubst #-}

instance BDDOps BDD where
    get_bdd_ptr bdd = unsafePerformIO $ withBDD bdd (return . ptrToIntPtr)
    bif bdd = unsafePerformIO $
      do vid <- withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
         {#call unsafe Cudd_bddIthVar as _cudd_bddIthVar#} ddmanager (cToNum vid)
           >>= addBDDnullFinalizer
    bthen bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddT#} bddp >>= addBDDfinalizer
    belse bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddE#} bddp >>= addBDDfinalizer

    reduce = cudd_reduce
    satisfy = cudd_satisfy
    support = cudd_support

-------------------------------------------------------------------
-- Implementations.
-------------------------------------------------------------------

withGroup :: Group BDD -> (Ptr BDD -> IO a) -> IO a
withGroup (MkGroup g) = withBDD g

cudd_exists :: Group BDD -> BDD -> BDD
cudd_exists group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddExistAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_exists #-}

cudd_forall :: Group BDD -> BDD -> BDD
cudd_forall group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddUnivAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_forall #-}

cudd_rel_product :: Group BDD -> BDD -> BDD -> BDD
cudd_rel_product group f g = unsafePerformIO $
  withGroup group $ \groupp -> withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddAndAbstract#} ddmanager fp gp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_rel_product #-}

-- | This function swaps variables, as it uses
-- @cudd_bddSwapVariables@. This is not exactly a "rename" behaviour.
cudd_rename :: Subst BDD -> BDD -> BDD
cudd_rename s@(MkSubst len fpx fpx') f = unsafePerformIO $ s `seq` f `seq`
  withBDD f $ \fp ->
    withForeignPtr fpx $ \arrayx -> withForeignPtr fpx' $ \arrayx' ->
      {#call unsafe cudd_bddSwapVariables#} ddmanager fp arrayx arrayx' (fromIntegral len)
        >>= addBDDfinalizer
{-# INLINE cudd_rename #-}

-- FIXME verify implementation.
cudd_reduce :: BDD -> BDD -> BDD
cudd_reduce f g = unsafePerformIO $
  withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddLICompaction#} ddmanager fp gp
      >>= addBDDfinalizer

-- FIXME verify implementation.
cudd_satisfy :: BDD -> BDD
cudd_satisfy bdd = unsafePerformIO $
  withBDD bdd ({#call unsafe cudd_satone#} ddmanager) >>= addBDDfinalizer

cudd_support :: BDD -> [BDD]
cudd_support bdd = unsafePerformIO $
  do varBitArray <- withBDD bdd ({#call unsafe Cudd_SupportIndex as _cudd_SupportIndex#} ddmanager)
     touchForeignPtr (case bdd of BDD fp -> fp)
     -- The array is as long as the number of variables allocated.
     (_toBDD, fromBDD) <- readIORef bdd_vars
     bdds <- foldM (toBDDs varBitArray) [] (Map.toList fromBDD)
     {#call unsafe cFree#} (castPtr varBitArray)
     return bdds
  where
    toBDDs varBitArray bdds (vid, var) =
      do varInSupport <- peek (advancePtr varBitArray (cToNum vid))
         return $ if varInSupport /= 0
                    then bvar var : bdds
                    else bdds

-------------------------------------------------------------------
-- Operations specific to this BDD binding.
-------------------------------------------------------------------

-- | Dump usage statistics to the given 'Handle'.
stats :: Handle -> IO ()
stats handle =
    do cfile <- handleToCFile handle
       printCFile cfile "CUDD stats\n"
       _ <- {#call unsafe Cudd_PrintInfo as _cudd_PrintInfo#} ddmanager cfile
       printCFile cfile "\nVariable groups\n"
       {#call unsafe cudd_printVarGroups#} ddmanager

----------------------------------------
-- Variable Reordering.
----------------------------------------

{#enum Cudd_ReorderingType as CUDDReorderingMethod {} deriving (Eq, Ord, Show)#}

decodeROM :: ReorderingMethod -> CInt
decodeROM rom = cFromEnum $ case rom of
  ReorderNone -> CUDD_REORDER_NONE
  ReorderSift -> CUDD_REORDER_SIFT
  ReorderSiftSym -> CUDD_REORDER_SYMM_SIFT
  ReorderStableWindow3 -> CUDD_REORDER_WINDOW3

-- | Reorder the variables now.
reorder :: ReorderingMethod -> IO ()
reorder rom = {#call unsafe Cudd_ReduceHeap as _cudd_ReduceHeap#} ddmanager (decodeROM rom) 1 >> return ()

-- | Set the dynamic variable ordering heuristic.
dynamicReordering :: ReorderingMethod -> IO ()
dynamicReordering rom = {#call unsafe Cudd_AutodynEnable as _cudd_AutodynEnable#} ddmanager (decodeROM rom) >> return ()

----------------------------------------
-- | Returns the relationship between BDD indices, BDD ids and
-- variable names. This may be useful for discovering what the
-- dynamic reordering is doing.
--
-- The intention of this function is to return
--   @[(position in variable order, immutable variable id, label)]@
-- so that the variable order can be saved.
----------------------------------------

varIndices :: IO [(CInt, CInt, String)]
varIndices = do (toBDD, _fromBDD) <- readIORef bdd_vars
                mapM procVar $ Map.toList toBDD
    where -- procVar :: (String, BDD) -> IO (CUInt, CUInt, String)
          procVar (var, bdd) =
              do -- FIXME CUDD inconsistently uses signed and unsigned ints.
                 vid <- fmap cToNum $
                          withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
                 level <- {#call unsafe Cudd_ReadPerm as _cudd_ReadPerm#} ddmanager vid
                 return (level, vid, var)
{-# NOINLINE varIndices #-}

----------------------------------------
-- BDD Statistics.
----------------------------------------

-- | Determine the size of a BDD.
bddSize :: BDD -> Int
bddSize bdd = unsafePerformIO $
  do size <- withBDD bdd ({#call unsafe Cudd_DagSize as _cudd_DagSize#})
     return $ cToNum size

printInfo :: IO ()
printInfo = {#call unsafe print_stats#} ddmanager

-- -*- haskell -*-- -----------------------------------------------
-- |
-- Module      :  Data.Boolean.CUDD
-- Copyright   :  (C) 2002-2005, 2009 University of New South Wales, (C) 2009-2011 Peter Gammie
-- License     :  LGPL (see COPYING.LIB for details)
--
-- A binding for CUDD (Fabio Somenzi, University of Colorado).
--
-- Note this library is not thread-safe.
-------------------------------------------------------------------
module Data.Boolean.CUDD
    (
        BDD
    ,	module Data.Boolean

        -- * CUDD-specific functions
--          ,	gc
    ,	stats
    ,	reorder
    ,	dynamicReordering
    ,	varIndices
    ,	bddSize
    ,	printInfo
    ) where

-------------------------------------------------------------------
-- Dependencies.
-------------------------------------------------------------------

#include "cudd_im.h"

import Control.DeepSeq  ( NFData )
import Control.Monad	( foldM, liftM, mapAndUnzipM, zipWithM_ )

import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
import Data.List	( genericLength )
import Data.Maybe	( fromJust, isJust )

import Data.Map         ( Map )
import qualified Data.Map as Map

import Foreign		( ForeignPtr, withForeignPtr, newForeignPtr, newForeignPtr_, finalizerFree, touchForeignPtr
                        , Ptr, advancePtr, castPtr, peek, pokeElemOff, ptrToIntPtr
                        , mallocArray )
import Foreign.C

import GHC.ForeignPtr   ( newConcForeignPtr )

import System.IO	( Handle, hIsReadable, hIsWritable )
-- import System.Mem	( performGC )
import System.Posix.IO	( handleToFd )
import System.IO.Unsafe	( unsafePerformIO )

import Data.Boolean

-------------------------------------------------------------------
-- Extra FFI functions.
-------------------------------------------------------------------

-- | A C file handle.
{#pointer *FILE -> CFile#}

-- | Convert a Haskell Handle into a C FILE *.
-- - FIXME: throw exception on error.
-- - suggested by Simon Marlow.
handleToCFile :: Handle -> IO FILE
handleToCFile h =
    do r <- hIsReadable h
       w <- hIsWritable h
       modestr <- newCString $ mode r w
       fd <- handleToFd h
       {#call unsafe fdopen#} (cToNum fd) modestr
    where mode :: Bool -> Bool -> String
          mode False False = error "Handle not readable or writable!"
          mode False True  = "w"
          mode True  False = "r"
          mode True  True  = "r+" -- FIXME

-- | The Haskell Handle is unusable after calling 'handleToCFile',
-- so provide a neutered "fprintf"-style thing here.
printCFile :: FILE -> String -> IO ()
printCFile file str =
    withCString str ({#call unsafe fprintf_neutered#} file)

--  Close a C FILE *.
-- - FIXME: throw exception on error.
-- closeCFile :: FILE -> IO ()
-- closeCFile cfile = do {#call unsafe fclose#} cfile
--                    return ()

cToNum :: (Num i, Integral e) => e -> i
cToNum  = fromIntegral . toInteger
{-# INLINE cToNum #-}

cFromEnum :: (Integral i, Enum e) => e -> i
cFromEnum  = fromIntegral . fromEnum
{-# INLINE cFromEnum #-}

-------------------------------------------------------------------
-- Types.
-------------------------------------------------------------------

-- | The BDD manager, which we hide from clients.
{#pointer *DdManager as DDManager newtype#}

-- | The arguments to 'Cudd_Init'.
{#enum CuddSubtableSize {} #}
{#enum CuddCacheSize {} #}

-- | Variable reordering tree options.
{#enum CuddMTRParams {} #}

-- | The abstract type of BDDs.
{#pointer *DdNode as BDD foreign newtype#}

{-# INLINE withBDD #-}

-- BDDs are just pointers, so there's no work to do when we @deepseq@ them.
instance Control.DeepSeq.NFData BDD

-- Belt-and-suspenders equality checking and ordering.
instance Eq BDD where
    bdd0 == bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p

instance Ord BDD where
    bdd0 <= bdd1 = unsafePerformIO $
      withBDD bdd0 $ \bdd0p -> withBDD bdd1 $ \bdd1p ->
        return $ bdd0p == bdd1p || bdd0p < bdd1p

instance Show BDD where
-- Print out the BDD as a sum-of-products.
    showsPrec _ = sop

-------------------------------------------------------------------
-- Administrative functions.
-------------------------------------------------------------------

-- | The BDD manager. This needs to be invoked before any of the
-- following functions... which we arrange for automagically.
ddmanager :: DDManager
ddmanager = unsafePerformIO $
  {#call unsafe Cudd_Init as _cudd_Init #}
    0 0 (cFromEnum UNIQUE_SLOTS) (cFromEnum CACHE_SLOTS) 0
{-# NOINLINE ddmanager #-}

-- | A map to and from BDD variable numbers.
-- FIXME: the second one would be more efficiently Data.IntMap, but we don't use it often.
type VarMap = (Map String BDD, Map CUInt String)

-- | Tracks existing variables.
bdd_vars :: IORef VarMap
bdd_vars = unsafePerformIO $ newIORef (Map.empty, Map.empty)
{-# NOINLINE bdd_vars #-}

-- | Attaches a finalizer to a BDD object.
-- The call to "Cudd_Ref" happens in C to ensure atomicity.
-- Returning objects with initial refcount 0 is a bad design decision.
addBDDfinalizer :: Ptr BDD -> IO BDD
addBDDfinalizer bddp = liftM BDD $ newConcForeignPtr bddp bddf
    where bddf = {#call unsafe Cudd_RecursiveDeref as _cudd_RecursiveDeref#} ddmanager bddp
                   >> return ()
{-# INLINE addBDDfinalizer #-}

-- | Attaches a null finalizer to a 'BDD' object.
-- Used for variables and constants.
addBDDnullFinalizer :: Ptr BDD -> IO BDD
addBDDnullFinalizer bddp = fmap BDD $ newForeignPtr_ bddp
{-# INLINE addBDDnullFinalizer #-}

-- Simulate an "apply" function to simplify atomic refcount incrementing.
{#enum CuddBinOp {} #}

-------------------------------------------------------------------
-- Logical operations.
-------------------------------------------------------------------

-- | Allocate a variable.
newVar :: IO (Ptr BDD) -> String -> IO (Maybe CUInt, BDD)
newVar allocVar label =
      do (toBDD, fromBDD) <- readIORef bdd_vars
         case label `Map.lookup` toBDD of
           Just bdd -> return (Nothing, bdd)
           Nothing ->
             do putStrLn $ "Allocating: " ++ label
                bddp <- allocVar
                vid <- fmap cToNum $
                         {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                --putStrLn $ label ++ " -> " ++ (show (vid, bdd))
                bdd <- addBDDnullFinalizer bddp
                writeIORef bdd_vars ( Map.insert label bdd   toBDD
                                    , Map.insert vid   label fromBDD )
                return (Just vid, bdd)

instance BooleanVariable BDD where
    bvar label = unsafePerformIO $
      fmap snd $ newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)  label

    bvars labels =
      case labels of
        [] -> []
        ls -> unsafePerformIO $
          do (vids, vars) <- mapAndUnzipM (newVar ({#call unsafe Cudd_bddNewVar as _cudd_bddNewVar#} ddmanager)) ls
             if all isJust vids
               then groupVars (fromJust (head vids)) (genericLength vids)
               else putStrLn $ "hBDD-CUDD warning: not grouping variables " ++ show ls
             return vars
      where
        -- FIXME why one or the other?
        groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_DEFAULT) >> return ()
        -- groupVars vid len = makeTreeNode ddmanager vid len (cFromEnum CUDD_MTR_FIXED) >> return ()
        makeTreeNode = {#call unsafe Cudd_MakeTreeNode as _cudd_MakeTreeNode#}

    unbvar bdd = unsafePerformIO $ bdd `seq`
                   withBDD bdd $ \bddp ->
                     do vid <- {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#} bddp
                        (_, fromBDD) <- readIORef bdd_vars
                        return $ case cToNum vid `Map.lookup` fromBDD of
                                   Nothing -> "(VID: " ++ show vid ++ ")"
                                   Just v  -> v

instance Boolean BDD where
    true  = cudd_constant {#call unsafe Cudd_ReadOne as _cudd_ReadOne#}
    false = cudd_constant {#call unsafe Cudd_ReadLogicZero as _cudd_ReadLogicZero#}

    (/\)  = bddBinOp AND
    neg x = unsafePerformIO $ withBDD x $ \xp ->
      {#call unsafe cudd_bddNot#} xp >>= addBDDfinalizer

    nand  = bddBinOp NAND
    (\/)  = bddBinOp OR
    nor   = bddBinOp NOR
    xor   = bddBinOp XOR
    -- (-->) = FIXME ???
    (<->) = bddBinOp XNOR

    -- bITE i t e = unsafePerformIO $
    --   withBDD i $ \ip -> withBDD t $ \tp -> withBDD e $ \ep ->
    --     {#call unsafe cudd_bddIte#} ddmanager ip tp ep
    --       >>= addBDDfinalizer

cudd_constant :: (DDManager -> IO (Ptr BDD)) -> BDD
cudd_constant f = unsafePerformIO $ f ddmanager >>= addBDDnullFinalizer
{-# INLINE cudd_constant #-}

bddBinOp :: CuddBinOp -> BDD -> BDD -> BDD
bddBinOp op x y = unsafePerformIO $
  withBDD x $ \xp -> withBDD y $ \yp ->
    {#call unsafe cudd_BinOp#} ddmanager (cFromEnum op) xp yp >>= addBDDfinalizer
{-# INLINE bddBinOp #-}

instance QBF BDD where
    data Group BDD = MkGroup !BDD

    mkGroup = MkGroup . conjoin -- FIXME maybe use Cudd_bddComputeCube
    exists = cudd_exists
    forall = cudd_forall
    rel_product = cudd_rel_product

instance Substitution BDD where
  -- Cache substitution arrays.
  data Subst BDD = MkSubst {-# UNPACK #-} !Int
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))
                           {-# UNPACK #-} !(ForeignPtr (Ptr BDD))

  mkSubst = cudd_mkSubst
  rename = cudd_rename
  substitute = error "CUDD substitute" -- cudd_substitute

cudd_mkSubst :: [(BDD, BDD)] -> Subst BDD
cudd_mkSubst subst = unsafePerformIO $
    do arrayx  <- mallocArray len
       arrayx' <- mallocArray len
       zipWithM_ (pokeSubst arrayx arrayx') subst [0..]
       fpx  <- newForeignPtr finalizerFree arrayx
       fpx' <- newForeignPtr finalizerFree arrayx'
       return (MkSubst len fpx fpx')
  where
    pokeSubst :: Ptr (Ptr BDD) -> Ptr (Ptr BDD) -> (BDD, BDD) -> Int -> IO ()
    pokeSubst arrayx arrayx' (v, v') i =
      do withBDD v  $ pokeElemOff arrayx  i
         withBDD v' $ pokeElemOff arrayx' i

    len = length subst
{-# INLINE cudd_mkSubst #-}

instance BDDOps BDD where
    get_bdd_ptr bdd = unsafePerformIO $ withBDD bdd (return . ptrToIntPtr)
    bif bdd = unsafePerformIO $
      do vid <- withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
         {#call unsafe Cudd_bddIthVar as _cudd_bddIthVar#} ddmanager (cToNum vid)
           >>= addBDDnullFinalizer
    bthen bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddT#} bddp >>= addBDDfinalizer
    belse bdd = unsafePerformIO $
      withBDD bdd $ \bddp ->
        {#call unsafe cudd_bddE#} bddp >>= addBDDfinalizer

    reduce = cudd_reduce
    satisfy = cudd_satisfy
    support = cudd_support

-------------------------------------------------------------------
-- Implementations.
-------------------------------------------------------------------

withGroup :: Group BDD -> (Ptr BDD -> IO a) -> IO a
withGroup (MkGroup g) = withBDD g

cudd_exists :: Group BDD -> BDD -> BDD
cudd_exists group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddExistAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_exists #-}

cudd_forall :: Group BDD -> BDD -> BDD
cudd_forall group bdd = unsafePerformIO $ bdd `seq`
  withGroup group $ \groupp -> withBDD bdd $ \bddp ->
    {#call unsafe cudd_bddUnivAbstract#} ddmanager bddp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_forall #-}

cudd_rel_product :: Group BDD -> BDD -> BDD -> BDD
cudd_rel_product group f g = unsafePerformIO $
  withGroup group $ \groupp -> withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddAndAbstract#} ddmanager fp gp groupp
      >>= addBDDfinalizer
{-# INLINE cudd_rel_product #-}

-- | This function swaps variables, as it uses
-- @cudd_bddSwapVariables@. This is not exactly a "rename" behaviour.
cudd_rename :: Subst BDD -> BDD -> BDD
cudd_rename s@(MkSubst len fpx fpx') f = unsafePerformIO $ s `seq` f `seq`
  withBDD f $ \fp ->
    withForeignPtr fpx $ \arrayx -> withForeignPtr fpx' $ \arrayx' ->
      {#call unsafe cudd_bddSwapVariables#} ddmanager fp arrayx arrayx' (fromIntegral len)
        >>= addBDDfinalizer
{-# INLINE cudd_rename #-}

-- FIXME verify implementation.
cudd_reduce :: BDD -> BDD -> BDD
cudd_reduce f g = unsafePerformIO $
  withBDD f $ \fp -> withBDD g $ \gp ->
    {#call unsafe cudd_bddLICompaction#} ddmanager fp gp
      >>= addBDDfinalizer

-- FIXME verify implementation.
cudd_satisfy :: BDD -> BDD
cudd_satisfy bdd = unsafePerformIO $
  withBDD bdd ({#call unsafe cudd_satone#} ddmanager) >>= addBDDfinalizer

cudd_support :: BDD -> [BDD]
cudd_support bdd = unsafePerformIO $
  do varBitArray <- withBDD bdd ({#call unsafe Cudd_SupportIndex as _cudd_SupportIndex#} ddmanager)
     touchForeignPtr (case bdd of BDD fp -> fp)
     -- The array is as long as the number of variables allocated.
     (_toBDD, fromBDD) <- readIORef bdd_vars
     bdds <- foldM (toBDDs varBitArray) [] (Map.toList fromBDD)
     {#call unsafe cFree#} (castPtr varBitArray)
     return bdds
  where
    toBDDs varBitArray bdds (vid, var) =
      do varInSupport <- peek (advancePtr varBitArray (cToNum vid))
         return $ if varInSupport /= 0
                    then bvar var : bdds
                    else bdds

-------------------------------------------------------------------
-- Operations specific to this BDD binding.
-------------------------------------------------------------------

-- | Dump usage statistics to the given 'Handle'.
stats :: Handle -> IO ()
stats handle =
    do cfile <- handleToCFile handle
       printCFile cfile "CUDD stats\n"
       _ <- {#call unsafe Cudd_PrintInfo as _cudd_PrintInfo#} ddmanager cfile
       printCFile cfile "\nVariable groups\n"
       {#call unsafe cudd_printVarGroups#} ddmanager

----------------------------------------
-- Variable Reordering.
----------------------------------------

{#enum Cudd_ReorderingType as CUDDReorderingMethod {} deriving (Eq, Ord, Show)#}

decodeROM :: ReorderingMethod -> CInt
decodeROM rom = cFromEnum $ case rom of
  ReorderNone -> CUDD_REORDER_NONE
  ReorderSift -> CUDD_REORDER_SIFT
  ReorderSiftSym -> CUDD_REORDER_SYMM_SIFT
  ReorderStableWindow3 -> CUDD_REORDER_WINDOW3

-- | Reorder the variables now.
reorder :: ReorderingMethod -> IO ()
reorder rom = {#call unsafe Cudd_ReduceHeap as _cudd_ReduceHeap#} ddmanager (decodeROM rom) 1 >> return ()

-- | Set the dynamic variable ordering heuristic.
dynamicReordering :: ReorderingMethod -> IO ()
dynamicReordering rom = {#call unsafe Cudd_AutodynEnable as _cudd_AutodynEnable#} ddmanager (decodeROM rom) >> return ()

----------------------------------------
-- | Returns the relationship between BDD indices, BDD ids and
-- variable names. This may be useful for discovering what the
-- dynamic reordering is doing.
--
-- The intention of this function is to return
--   @[(position in variable order, immutable variable id, label)]@
-- so that the variable order can be saved.
----------------------------------------

varIndices :: IO [(CInt, CInt, String)]
varIndices = do (toBDD, _fromBDD) <- readIORef bdd_vars
                mapM procVar $ Map.toList toBDD
    where -- procVar :: (String, BDD) -> IO (CUInt, CUInt, String)
          procVar (var, bdd) =
              do -- FIXME CUDD inconsistently uses signed and unsigned ints.
                 vid <- fmap cToNum $
                          withBDD bdd {#call unsafe Cudd_NodeReadIndex as _cudd_NodeReadIndex#}
                 level <- {#call unsafe Cudd_ReadPerm as _cudd_ReadPerm#} ddmanager vid
                 return (level, vid, var)
{-# NOINLINE varIndices #-}

----------------------------------------
-- BDD Statistics.
----------------------------------------

-- | Determine the size of a BDD.
bddSize :: BDD -> Int
bddSize bdd = unsafePerformIO $
  do size <- withBDD bdd ({#call unsafe Cudd_DagSize as _cudd_DagSize#})
     return $ cToNum size

printInfo :: IO ()
printInfo = {#call unsafe print_stats#} ddmanager


[project @ 2003-11-11 12:07:43 by juhp]

[project @ 2003-11-11 12:07:43 by juhp]

(sourceTagSetStyle): Fix docu typo.

darcs-hash:20031111120743-f332a-4204102591aef0df07b793b11a3a9ae45f0407c7.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry SourceTag@
--
--  Author : Duncan Coutts
--  derived from GtkTextView bindings by Axel Simon
--
--  Created: 22 October 2003
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--
module SourceTag (
  SourceTag,
  syntaxTagNew,
  patternTagNew,
  keywordListTagNew,
  blockCommentTagNew,
  lineCommentTagNew,
  stringTagNew,
  sourceTagGetStyle,
  sourceTagSetStyle
  ) where

import Monad	(liftM)
import FFI
import GObject	(makeNewGObject)
{#import Hierarchy#}
{#import SourceViewType#}
import SourceTagStyle
import GList   (toGSList, fromGSList)

{# context lib="gtk" prefix="gtk" #}

-- methods

-- @constructor syntaxTagNew@ Create a new @ref type SourceTag@
--
syntaxTagNew :: String -> String -> String -> String -> IO SourceTag
syntaxTagNew id name patternStart patternEnd =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id           $ \strPtr1 ->
  withCString name         $ \strPtr2 ->
  withCString patternStart $ \strPtr3 ->
  withCString patternEnd   $ \strPtr4 ->
  {#call syntax_tag_new#} strPtr1 strPtr2 strPtr3 strPtr4

-- @constructor patternTagNew@ Create a new @ref type SourceTag@
--
patternTagNew :: String -> String -> String -> IO SourceTag
patternTagNew id name pattern =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id      $ \strPtr1 ->
  withCString name    $ \strPtr2 ->
  withCString pattern $ \strPtr3 ->
  {#call unsafe pattern_tag_new#} strPtr1 strPtr2 strPtr3

-- @constructor keywordListTagNew@ Create a new @ref type SourceTag@.
--
keywordListTagNew :: String -> String -> [String] -> Bool -> Bool -> Bool ->
		     String -> String -> IO SourceTag
keywordListTagNew id name keywords
                  caseSensitive
                  matchEmptyStringAtBeginning
                  matchEmptyStringAtEnd
                  beginningRegex
                  endRegex = do
  keywordPtrs <- mapM newUTFString keywords
  keywordList <- toGSList keywordPtrs
  obj <- makeNewGObject mkSourceTag $ liftM castPtr $
	 withCString  id      $ \strPtr1 ->
	 withCString  name    $ \strPtr2 ->
	 withCString  beginningRegex $ \strPtr3 ->
	 withCString  endRegex $ \strPtr4 -> {#call unsafe keyword_list_tag_new#}
	   strPtr1 strPtr2 keywordList (fromBool caseSensitive)
	   (fromBool matchEmptyStringAtBeginning) (fromBool matchEmptyStringAtEnd)
	   strPtr3 strPtr4
  -- destory the list
  fromGSList keywordList
  -- destory the elements
  mapM_ free keywordPtrs
  return obj

-- @constructor blockCommentTagNew@ Create a new @ref type SourceTag@
--
blockCommentTagNew :: String -> String -> String -> String -> IO SourceTag
blockCommentTagNew = syntaxTagNew --in the C header this is just a macro

-- @constructor lineCommentTagNew@ Create a new @ref type SourceTag@
--
lineCommentTagNew :: String -> String -> String -> IO SourceTag
lineCommentTagNew id name pattern =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id      $ \strPtr1 ->
  withCString name    $ \strPtr2 ->
  withCString pattern $ \strPtr3 ->
  {#call unsafe line_comment_tag_new#} strPtr1 strPtr2 strPtr3

-- @constructor stringTagNew@ Create a new @ref type SourceTag@
--
stringTagNew :: String -> String -> String -> String -> Bool -> IO SourceTag
stringTagNew id name patternStart patternEnd endAtLineEnd =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id           $ \strPtr1 ->
  withCString name         $ \strPtr2 ->
  withCString patternStart $ \strPtr3 ->
  withCString patternEnd   $ \strPtr4 ->
  {#call unsafe string_tag_new#} strPtr1 strPtr2 strPtr3 strPtr4 (fromBool endAtLineEnd)

-- @method sourceTagGetStyle@
--
sourceTagGetStyle :: SourceTag -> IO SourceTagStyle
sourceTagGetStyle tag = do
  tsPtr <- {#call unsafe source_tag_get_style#} tag
  ts <- peek (castPtr tsPtr)
  {#call unsafe g_free#} tsPtr
  return ts

-- @method sourceTagSetStyle@
--
sourceTagSetStyle :: SourceTag -> SourceTagStyle -> IO ()
sourceTagSetStyle tag ts = alloca $ \tsPtr -> do
  poke tsPtr ts
  {#call unsafe source_tag_set_style#} tag (castPtr tsPtr)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry SourceTag@
--
--  Author : Duncan Coutts
--  derived from GtkTextView bindings by Axel Simon
--
--  Created: 22 October 2003
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------
--
--
module SourceTag (
  SourceTag,
  syntaxTagNew,
  patternTagNew,
  keywordListTagNew,
  blockCommentTagNew,
  lineCommentTagNew,
  stringTagNew,
  sourceTagGetStyle,
  sourceTagSetStyle
  ) where

import Monad	(liftM)
import FFI
import GObject	(makeNewGObject)
{#import Hierarchy#}
{#import SourceViewType#}
import SourceTagStyle
import GList   (toGSList, fromGSList)

{# context lib="gtk" prefix="gtk" #}

-- methods

-- @constructor syntaxTagNew@ Create a new @ref type SourceTag@
--
syntaxTagNew :: String -> String -> String -> String -> IO SourceTag
syntaxTagNew id name patternStart patternEnd =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id           $ \strPtr1 ->
  withCString name         $ \strPtr2 ->
  withCString patternStart $ \strPtr3 ->
  withCString patternEnd   $ \strPtr4 ->
  {#call syntax_tag_new#} strPtr1 strPtr2 strPtr3 strPtr4

-- @constructor patternTagNew@ Create a new @ref type SourceTag@
--
patternTagNew :: String -> String -> String -> IO SourceTag
patternTagNew id name pattern =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id      $ \strPtr1 ->
  withCString name    $ \strPtr2 ->
  withCString pattern $ \strPtr3 ->
  {#call unsafe pattern_tag_new#} strPtr1 strPtr2 strPtr3

-- @constructor keywordListTagNew@ Create a new @ref type SourceTag@.
--
keywordListTagNew :: String -> String -> [String] -> Bool -> Bool -> Bool ->
		     String -> String -> IO SourceTag
keywordListTagNew id name keywords
                  caseSensitive
                  matchEmptyStringAtBeginning
                  matchEmptyStringAtEnd
                  beginningRegex
                  endRegex = do
  keywordPtrs <- mapM newUTFString keywords
  keywordList <- toGSList keywordPtrs
  obj <- makeNewGObject mkSourceTag $ liftM castPtr $
	 withCString  id      $ \strPtr1 ->
	 withCString  name    $ \strPtr2 ->
	 withCString  beginningRegex $ \strPtr3 ->
	 withCString  endRegex $ \strPtr4 -> {#call unsafe keyword_list_tag_new#}
	   strPtr1 strPtr2 keywordList (fromBool caseSensitive)
	   (fromBool matchEmptyStringAtBeginning) (fromBool matchEmptyStringAtEnd)
	   strPtr3 strPtr4
  -- destory the list
  fromGSList keywordList
  -- destory the elements
  mapM_ free keywordPtrs
  return obj

-- @constructor blockCommentTagNew@ Create a new @ref type SourceTag@
--
blockCommentTagNew :: String -> String -> String -> String -> IO SourceTag
blockCommentTagNew = syntaxTagNew --in the C header this is just a macro

-- @constructor lineCommentTagNew@ Create a new @ref type SourceTag@
--
lineCommentTagNew :: String -> String -> String -> IO SourceTag
lineCommentTagNew id name pattern =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id      $ \strPtr1 ->
  withCString name    $ \strPtr2 ->
  withCString pattern $ \strPtr3 ->
  {#call unsafe line_comment_tag_new#} strPtr1 strPtr2 strPtr3

-- @constructor stringTagNew@ Create a new @ref type SourceTag@
--
stringTagNew :: String -> String -> String -> String -> Bool -> IO SourceTag
stringTagNew id name patternStart patternEnd endAtLineEnd =
  makeNewGObject mkSourceTag $ liftM castPtr $
  withCString id           $ \strPtr1 ->
  withCString name         $ \strPtr2 ->
  withCString patternStart $ \strPtr3 ->
  withCString patternEnd   $ \strPtr4 ->
  {#call unsafe string_tag_new#} strPtr1 strPtr2 strPtr3 strPtr4 (fromBool endAtLineEnd)

-- @method sourceTagGetStyle@
--
sourceTagGetStyle :: SourceTag -> IO SourceTagStyle
sourceTagGetStyle tag = do
  tsPtr <- {#call unsafe source_tag_get_style#} tag
  ts <- peek (castPtr tsPtr)
  {#call unsafe g_free#} tsPtr
  return ts

-- @method sourceTagGetStyle@
--
sourceTagSetStyle :: SourceTag -> SourceTagStyle -> IO ()
sourceTagSetStyle tag ts = alloca $ \tsPtr -> do
  poke tsPtr ts
  {#call unsafe source_tag_set_style#} tag (castPtr tsPtr)