`friday`包非常慢

Question

我正在編寫一個Haskell程序，它從Knytt Stories世界文件中繪制大地圖 。 我使用friday包來制作圖像文件，我需要編寫我從spritesheets放在一起的許多圖形層。 現在，我使用自己的丑陋功能：

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，請發布。 你的完整代碼對我來說太微不足道了。