`friday`包非常慢

Question

我正在编写一个Haskell程序,它从Knytt Stories世界文件中绘制大地图.我使用包来制作图像文件,我需要编写我从spritesheets放在一起的许多图形层.现在,我使用自己的丑陋功能:friday

import qualified Vision.Primitive as Im
import qualified Vision.Image.Type as Im
import qualified Vision.Image.Class as Im
import Vision.Image.RGBA.Type (RGBA, RGBAPixel(..))

-- Map a Word8 in [0, 255] to a Double in [0, 1].
w2f :: Word8 -> Double
w2f = (/255) . fromIntegral . fromEnum

-- Map a Double in [0, 1] to a Word8 in [0, 255].
f2w :: Double -> Word8
f2w = toEnum . round . (*255)

-- Compose two images into one. `bottom` is wrapped to `top`'s size.
compose :: RGBA -> RGBA -> RGBA
compose bottom top =
    let newSize = Im.manifestSize top
        bottom' = wrap newSize bottom
    in Im.fromFunction newSize $ \p ->
        let RGBAPixel rB gB bB aB = bottom' Im.! p
            RGBAPixel rT gT bT aT = top Im.! p
            aB' = w2f aB; aT' = w2f aT
            ovl :: Double -> Double -> Double
            ovl cB cT = (cT * aT' + cB * aB' * (1.0 - aT')) / (aT' + aB' * (1.0 - aT'))
            (~*~) :: Word8 -> Word8 -> Word8
            cB ~*~ cT = f2w $ w2f cB `ovl` w2f cT
            aO = f2w (aT' + aB' * (1.0 - aT'))
        in RGBAPixel (rB ~*~ rT) (gB ~*~ gT) (bB ~*~ bT) aO

它只是简单地复合底层和顶层,如下所示:

如果"底部"图层是纹理,则它将水平和垂直(通过wrap)循环以适合顶层的大小.

---

渲染地图需要的时间远远超过应有的时间.渲染地图为游戏自带的默认世界需要27分钟的-O3,尽管游戏本身可以清楚地在不到几毫秒的渲染每个单独的屏幕.(上面链接的较小的示例输出见上文需要67秒;也太长了.)

分析器(输出在这里)说该程序花费大约77%的时间compose.

减少这个似乎是一个很好的第一步.这似乎是一个非常简单的操作,但我无法找到一个本机函数friday,让我这样做.据说GHC应该擅长折叠所有的fromFunction东西,但我不知道发生了什么.或者包装是否超级慢？

这是完整的可编译代码.

Answer 1

正如我在评论中所述，我制作的 MCE 表现良好，并且不会产生任何有趣的输出：

module Main where
import qualified Vision.Primitive as Im
import Vision.Primitive.Shape
import qualified Vision.Image.Type as Im
import qualified Vision.Image.Class as Im
import Vision.Image.RGBA.Type (RGBA, RGBAPixel(..))
import Vision.Image.Storage.DevIL (load, save, Autodetect(..), StorageError, StorageImage(..))
import Vision.Image (convert)
import Data.Word
import System.Environment (getArgs)

main :: IO ()
main = do
  [input1,input2,output] <- getArgs
  io1 <- load Autodetect input1 :: IO (Either StorageError StorageImage)
  io2 <- load Autodetect input2 :: IO (Either StorageError StorageImage)
  case (io1,io2) of
    (Left err,_) -> error $ show err
    (_,Left err) -> error $ show err
    (Right i1, Right i2) -> go (convert i1) (convert i2) output
 where
  go i1 i2 output =
      do res <- save Autodetect output (compose i1 i2)
         case res of
          Nothing -> putStrLn "Done with compose"
          Just e  -> error (show (e :: StorageError))

-- Wrap an image to a given size.
wrap :: Im.Size -> RGBA -> RGBA
wrap s im =
    let Z :. h :. w = Im.manifestSize im
    in Im.fromFunction s $ \(Z :. y :. x) -> im Im.! Im.ix2 (y `mod` h) (x `mod` w)

-- Map a Word8 in [0, 255] to a Double in [0, 1].
w2f :: Word8 -> Double
w2f = (/255) . fromIntegral . fromEnum

-- Map a Double in [0, 1] to a Word8 in [0, 255].
f2w :: Double -> Word8
f2w = toEnum . round . (*255)

-- Compose two images into one. `bottom` is wrapped to `top`'s size.
compose :: RGBA -> RGBA -> RGBA
compose bottom top =
    let newSize = Im.manifestSize top
        bottom' = wrap newSize bottom
    in Im.fromFunction newSize $ \p ->
        let RGBAPixel rB gB bB aB = bottom' Im.! p
            RGBAPixel rT gT bT aT = top Im.! p
            aB' = w2f aB; aT' = w2f aT
            ovl :: Double -> Double -> Double
            ovl cB cT = (cT * aT' + cB * aB' * (1.0 - aT')) / (aT' + aB' * (1.0 - aT'))
            (~*~) :: Word8 -> Word8 -> Word8
            cB ~*~ cT = f2w $ w2f cB `ovl` w2f cT
            aO = f2w (aT' + aB' * (1.0 - aT'))
        in RGBAPixel (rB ~*~ rT) (gB ~*~ gT) (bB ~*~ bT) aO

此代码加载两个图像，应用您的合成操作，并保存生成的图像。这几乎立即发生：

% ghc -O2 so.hs && time ./so /tmp/lambda.jpg /tmp/lambda2.jpg /tmp/output.jpg && o /tmp/output.jpg
Done with compose
./so /tmp/lambda.jpg /tmp/lambda2.jpg /tmp/output.jpg  0.05s user 0.00s system 98% cpu 0.050 total

如果您有备用 MCE，请发布。你的完整代码对我来说太不简单了。