Il pacchetto `Friday` è molto lento

Question

Sto scrivendo un programma Haskell che disegna big maps dai file mondiali Knytt Stories. Io uso il pacchetto friday per creare file di immagine e ho bisogno di comporre i molti strati grafici che ho assemblato dagli spritesheets. In questo momento, io uso la mia funzione di brutto per questo:

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 

Semplicemente alpha-compositi uno strato di fondo e uno strato superiore, in questo modo:

Se il livello “basso” è una texture, sarà loopata orizzontalmente e verticalmente (da wrap) per adattarsi alle dimensioni del livello superiore.

---

Rendering di una mappa richiede molto, molto più tempo del dovuto. Il rendering della mappa per il mondo predefinito incluso nel gioco richiede 27 minuti allo -O3, anche se il gioco stesso può rendere chiaramente ogni schermata separata in meno di un paio di millisecondi. (L'uscita esempio più piccola ho linkato sopra vedi sopra richiede 67 secondi, anche troppo a lungo.)

Il profiler (uscita è here) dice che il programma spende circa il 77% del suo tempo in compose.

Questo taglio sembra un buon primo passo. Sembra un'operazione molto semplice, ma non riesco a trovare una funzione nativa in friday che mi consente di farlo. Presumibilmente GHC dovrebbe essere bravo a far crollare tutto il materiale fromFunction, ma non so cosa sta succedendo. O il pacchetto è semplicemente super lento?

Here’s the full, compileable code.

Answer 1

Come ho detto nel mio commento, il MCE ho fatto esegue bene e non cedere alcun output interessante:

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 

Questo codice carichi due immagini, si applica l'operazione di composizione, e salva l'immagine risultante. Questo succede quasi istantaneamente:

% 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 

Se si dispone di un MCE alternativo, si prega di postarlo. Il tuo codice completo era troppo non minimo per i miei occhi.