Быстрее SumSquareDifference в Haskell

Question

Я реализую алгоритм сжатия фрактальных изображений двоичных изображений в Haskell. Для этой цели мне нужно найти для заданного блока диапазона (под-изображения) ближайшее изображение в так называемом пуле доменов, списке списков изображений. Я сравниваю изображения, вычисляя суммарную квадратную разницу значений обоих их пикселей.

Я использую библиотеку Haskell Image Processing (HIP) для чтения и записи изображений.

compress :: Image VS X Bit -> Int -> [(Int, Int)]
compress img blockSize = zip dIndices tIndices
    where rImg = img
          dImg = downsample2 rImg
          rBlocks = (toBlocks rImg blockSize) :: [Image VS X Bit]
          dBlocks = (toBlocks dImg blockSize) :: [Image VS X Bit]
          dPool = (createDPool dBlocks) :: [[Image VS X Bit]]
          distanceLists = map (\x -> (map.map) (distance x) dPool) rBlocks
          dIndices = map (fst . getMinIndices) distanceLists
          tIndices = map (snd . getMinIndices) distanceLists


distance :: Image VS X Bit -> Image VS X Bit-> Int
distance x y = sumSquareDifference (toBinList x) (toBinList y)
    where toBinList = map (toNum . extractBitOfPixel) . concat . toLists

toLists :: MArray arr cs e => Image arr cs e -> [[Pixel cs e]]
toLists img = [[index img (i, j) | j <- [0..cols img -1]] | i <- [0.. rows img -1]]

extractBitOfPixel :: Pixel X Bit -> Bit
extractBitOfPixel (PixelX b) = b

sumSquareDifference :: [Int] -> [Int] -> Int
sumSquareDifference a b = sum $ zipWith (\x y -> (x-y)^2) a b

Производительность этого кода действительно плохая. Сжатие изображения 256x256 с размером блока 2 занимает около 5 минут, несмотря на компиляцию с -O2. Профилирование показывает мне, что большая часть времени выполнения тратится на функцию distance, особенно в sumSquareDifference, но и в toLists и toBinList:

       binaryCompressionSimple +RTS -p -RTS

    total time  =     1430.89 secs   (1430893 ticks @ 1000 us, 1 processor)
    total alloc = 609,573,757,744 bytes  (excludes profiling overheads)

COST CENTRE               MODULE    SRC                                        %time %alloc

sumSquareDifference       Main      binaryCompressionSimple.hs:87:1-63          30.9   28.3
toLists                   Main      binaryCompressionSimple.hs:66:1-90          20.3   47.0
distance.toBinList        Main      binaryCompressionSimple.hs:74:11-79         10.9   15.1
main                      Main      binaryCompressionSimple.hs:(14,1)-(24,21)    7.3    0.0
compress                  Main      binaryCompressionSimple.hs:(28,1)-(36,60)    6.9    0.0
distance                  Main      binaryCompressionSimple.hs:(71,1)-(74,79)    5.7    0.9
compress.distanceLists.\  Main      binaryCompressionSimple.hs:34:38-65          5.2    4.4
compress.distanceLists    Main      binaryCompressionSimple.hs:34:11-74          2.8    0.0
main.\                    Main      binaryCompressionSimple.hs:20:72-128         2.7    0.0
getMinIndices.getMinIndex Main      binaryCompressionSimple.hs:116:11-53         2.7    1.8
sumSquareDifference.\     Main      binaryCompressionSimple.hs:87:52-58          2.7    2.5

Есть ли способ повысить производительность?

Размер блока 2 означает сравнение 16384 блоков диапазона каждый с 131072 изображениями пула доменов, поэтому sumSquareDifference будет вызываться (16384*131072=)2147483648 раз и вычислять каждый раз суммарную квадратную разницу двух списков с длиной =4. Я понимаю, что это большое число, но разве код не должен быть быстрее (ленивая оценка списков)? Это проблема Haskell или проблема алгоритма?

Редактировать:

Мне удалось как минимум на треть повысить производительность, используя:

distance :: Image VS X Bit -> Image VS X Bit-> Int
distance x y
     | x == y = 0
     | otherwise = sumSquareDifference (toBinList x) (toBinList y)
    where toBinList = map (toNum . extractBitOfPixel) . concat . inlinedToLists

Изменить 2:

Мне удалось значительно увеличить производительность, создав dPool с функцией genDistanceList, который останавливает вычисление, как только будут найдены два одинаковых изображения:

genDistanceList :: [[Image VS X Bit]] -> Image VS X Bit -> [[Int]]
genDistanceList dPool rBlock = nestedTakeWhileInclusive (/= 0) $ (map.map) (distance rBlock) dPool

Answer 1

Абсолютно первое, что нужно попробовать - пропустить преобразование в списки:

{-# INLINE numIndex #-}
numIndex :: Image VS X Bit -> (Int, Int) -> Int
numIndex img pos = toNum . extractBitOfPixel $ index img pos

distance :: Image VS X Bit -> Image VS X Bit -> Int
distance a b = sum
    [ (numIndex a pos - numIndex b pos)^2
    | i <- [0 .. cols a-1]
    , j <- [0 .. rows a-1]
    , let pos = (i, j)
    ]

Поскольку вы не предоставили нам минимально воспроизводимый пример, невозможно сказать, какой эффект это окажет, если таковой имеется. Если вам нужен лучший совет, предоставьте более точные данные.

РЕДАКТИРОВАТЬ

Просматривая пикшу на предмет бедра, я подозреваю, что следующее будет еще лучше:

distance :: Image VS X Bit -> Image VS X Bit -> Int
distance a b = id
    . getX
    . fold (+)
    $ zipWith bitDistance a b

bitDistance :: Pixel X Bit -> Pixel X Bit -> Pixel X Int
bitDistance (PixelX a) (PixelX b) = PixelX (fromIntegral (a-b))
-- use (a-b)^2 when you switch to grayscale, but for Bit the squaring isn't needed

Здесь fold и zipWith предоставлены hipне base.