On Thu, 18 Nov 2004 19:20:02 +0900 (JST), Nobuo Yamashita  
<nobsun / sampou.org> wrote:
>> IOArray Point Color ->  IO (IOArray Point Color) なら具体的なインスタン 
>> スとして通るようですね。
>
> IOArray Point Color -> IOArray Point Color という意図で考えていた
> プログラムを、型システムを黙らせるためだけに、型宣言だけを、
> IOArray Point Color -> IO (IOArray Point Color) に換えて、
> 大丈夫なんですか?それで、プログラムが意図したとおり動くのですか?

あーっと、以前書いたようにもともと monad の中でこの関数を使おうとし
ていたので、それ用に少し書き換えただけできちんと動きます。

      bitmapLoad :: FilePath -> IO (Bitmap ())
      bitmapLoad fpath
        = do wxcBeginBusyCursor
             im1 <- imageCreateFromFile fpath
             px1 <- imageGetPixelIOArray im1
             im2 <- imageCreateFromPixelIOArray (lowpassFilter px1)
             bm2 <- bitmapCreateFromImage im2 (-1)
             wxcEndBusyCursor
             -- delete for performance reasons.
             imageDelete im2
             imageDelete im1
             return bm2

を

      bitmapLoad :: FilePath -> IO (Bitmap ())
      bitmapLoad fpath
        = do wxcBeginBusyCursor
             im1 <- imageCreateFromFile fpath
             px1 <- imageGetPixelIOArray im1
             low  <- lowpassFilter px1
             im2 <- imageCreateFromPixelIOArray low
             bm2 <- bitmapCreateFromImage im2 (-1)
             wxcEndBusyCursor
             -- delete for performance reasons.
             imageDelete im2
             imageDelete im1
             return bm2

に。


ただ、今までこういう事をやっていたのは Anti-Alias のパフォーマンスをあげる
ためだったのに、それができなかったのが悲しい……。

800 * 600 の画像で original が 3分38秒で描画できるのに、IOUArray 版で 4 分
32秒ぐらいになります。newListArray のコストが高いのかな?

module Graphics.UI.WXCore.Image

import Char( toLower )
import Data.Array

import Data.Array.IO
import Data.Bits( shiftL, shiftR, (.&.), (.|.) )

import Foreign.Marshal.Array
import Foreign.C.String
import Foreign.Storable

import Graphics.UI.WXCore.WxcTypes
import Graphics.UI.WXCore.WxcDefs
import Graphics.UI.WXCore.WxcClasses
import Graphics.UI.WXCore.Types
import Graphics.UI.WXCore.Defines

(snip)

-- | Get the pixels of an image as an array
imageGetPixelIOArray :: Image a -> IO (IOUArray Point Int)
imageGetPixelIOArray image
   = do h  <- imageGetHeight image
        w  <- imageGetWidth image
        ps <- imageGetPixels image
        let bounds = (pointZero, point (w-1) (h-1))
        pixelArray <- newListArray bounds ps
        return pixelArray
     where
         imageGetPixels :: Image a -> IO [Int]
         imageGetPixels image
           = do pb <- imageGetPixelBuffer image
                pixelBufferGetPixels pb

         pixelBufferGetPixels :: PixelBuffer -> IO [Int]
         pixelBufferGetPixels (PixelBuffer owned (Size w h) buffer)
           = do let count = w*h
                rgbs <- peekCStringLen (buffer,3*count)                 --  
peekArray seems buggy in ghc 6.2.1
                return (convert rgbs)
           where
               convert :: [Char] -> [Int]
               convert (r:g:b:xs)  = colorRGB (intFromCChar r)  
(intFromCChar g) (intFromCChar b): convert xs
               convert []          = []
               colorRGB :: Int -> Int -> Int -> Int
               colorRGB r g b = shiftL r 16 .|. shiftL g 8 .|. b

-- | Create an image from a pixel array
imageCreateFromPixelIOArray :: IOUArray Point Int -> IO (Image ())
imageCreateFromPixelIOArray pixels
   = do
       let (Point x y) = snd (Data.Array.IO.bounds pixels)
       elems <- getElems pixels
       let colors = map colorFromInt elems
       imageCreateFromPixels (sz (x+1) (y+1)) colors


module Main where

(snip)

-- bitmapLoad は二番目のものを使用

-- Low pass filter.
type Pixels = IOUArray Point Int

lowpassFilter ::  Pixels ->  IO (Pixels)
lowpassFilter pixels
   = newListArray (bounds pixels) [lowpass p | p <- indices pixels]
   where
      lowpass :: Point -> Int
      lowpass (Point px py)
        = intFromColor $ average $ map colorFromInt ints
        where ints = [pixels!p | dx <- [-1..1]
                               , dy <- [-1..1]
                               , let p = Point (px+dx) (py+dy)
                               , valid p
                               ]

      average :: [Color] -> Color
      average colors
        = let r = avg colorRed
              g = avg colorGreen
              b = avg colorBlue
          in colorRGB r g b
        where
          avg f = sum (map f colors) `div` len
          len   = length colors

      valid :: Point -> Bool
      valid p
        = let (low,hi) = bounds pixels
              bound    = rectBetween low hi
          in rectContains bound p

      -- (!) :: (MArray a e m, Ix i) => a i e -> i -> m e
      arr!k = unsafePerformIO $ readArray arr k

-- 
shelarcy <shelarcy capella.freemail.ne.jp>
http://page.freett.com/shelarcy/