Pakiet `Piątek` jest bardzo wolny

Question

Piszę program Haskell, który rysuje big maps z Knytt Stories plików światowych. Używam pakietu friday do tworzenia plików graficznych i muszę skomponować wiele warstw graficznych, które układam razem z arkuszy sprite. Teraz używam własne brzydkie funkcję to:

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 

To po prostu alfa-kompozytów dolną warstwę i górną warstwę, tak jak poniżej:

jeśli „dolny” warstwa jest teksturą, będzie zapętlona poziomo i pionowo (przez wrap), aby dopasować ją do rozmiaru warstwy górnej.

---

Renderowanie mapy zajmuje znacznie, znacznie dłużej niż powinno. Renderowanie mapy domyślnego świata, który przychodzi z grą, trwa 27 minut pod adresem -O3, mimo że sama gra może wyraźnie renderować każdy oddzielny ekran w czasie krótszym niż kilka milisekund. (Mniejsze przykładowe wyjście, które podałem powyżej powyżej, zajmuje 67 sekund, a także zbyt długo.)

Profiler (wyjście to here) mówi, że program spędza około 77% swojego czasu w compose.

Zmniejszenie tego poziomu wydaje się dobrym pierwszym krokiem. Wydaje się, że jest to bardzo prosta operacja, ale nie mogę znaleźć natywnej funkcji w friday, która pozwala mi to zrobić. Podobno GHC powinien być dobry w załamywaniu wszystkich rzeczy z fromFunction, ale nie wiem, co się dzieje. A może pakiet jest po prostu bardzo wolny?

Here’s the full, compileable code.

Answer 1

Jak stwierdzono w moim komentarzu, MCE zrobiłem wykonuje dobrze i nie daje żadnego ciekawy wynik:

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 

Ten kod ładuje dwa obrazy, stosuje swoją pracę komponować, i zapisuje wynikowy obraz. Zdarza się to niemal natychmiast:

% 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 

Jeśli masz alternatywny MCE, proszę to opublikować. Twój kompletny kod był zbyt nielimitowany dla moich oczu.