haskell - 创建单色 PNG 图像时堆栈溢出

Question

我在 this page 上找到了一个使用 Haskell 编写 PNG 文件的小型库。 .我只是重新排列它，使其支持所有单色、灰度和 RGB 输出。

但是，似乎我在编写大型单色图像时总是出现堆栈溢出，但如果我使用灰度或 RGB 则不会。在此示例中，大小阈值大约为 2000:如果我将 width 设置为小于该值，则会生成图像，否则会发生堆栈溢出。

import Png

import qualified Data.ByteString.Lazy as B

width = 2000 :: Int

main = do
  let setG = [ [ (r + c) `mod` 256 | c <- [0..width]] | r <- [0..width]]
  let outputG = pngGrayscale setG
  putStrLn "Writing grayscale image..."
  B.writeFile "grayscale.png" outputG
  putStrLn "Done"

  let setR = [ [ (r `mod` 256, c `mod` 256, (r+c) `mod` 256) | c <- [0..width]] | r <- [0..width]]
  let outputR = pngRGB setR
  putStrLn "Writing RGB image..."
  B.writeFile "rgb.png" outputR
  putStrLn "Done"

  let setM = [ [ even (r + c) | c <- [0..width]] | r <- [0..width]]
  let outputM = pngMonochrome setM
  putStrLn "Writing monochrome image..."
  B.writeFile "monochrome.png" outputM
  putStrLn "done"

因为这三个函数 png* 之间唯一的显着差异似乎是对 bitpack* 的调用，我想这是罪魁祸首，但我不知道如何解决这个问题。

这是图书馆(原文可以找到here):

{-
A small library for creating monochrome PNG files.
This file is placed into the public domain.
Dependencies: Zlib.
-}
module Png (pngRGB, pngGrayscale, pngMonochrome) where
import Data.Array
import Data.Bits
import Data.List
import Data.Word
import qualified Codec.Compression.Zlib as Z
import qualified Data.ByteString.Lazy as B

import Control.DeepSeq (deepseq)

be8 :: Word8 -> B.ByteString
be8 x = B.singleton x

be32 :: Word32 -> B.ByteString
be32 x = B.pack [fromIntegral (x `shiftR` sh) | sh <- [24,16,8,0]]

pack :: String -> B.ByteString
pack xs = B.pack $ map (fromIntegral.fromEnum) xs

unpack :: B.ByteString -> String
unpack xs = map (toEnum.fromIntegral) (B.unpack xs)

hdr, iHDR, iDAT, iEND :: B.ByteString
hdr = pack "\137\80\78\71\13\10\26\10"
iHDR = pack "IHDR"
iDAT = pack "IDAT"
iEND = pack "IEND"

chunk :: B.ByteString -> B.ByteString -> [B.ByteString]
chunk tag xs = [be32 (fromIntegral $ B.length xs), dat, be32 (crc dat)]
    where dat = B.append tag xs

-- | Return a monochrome PNG file from a two dimensional bitmap
-- stored in a list of lines represented as a list of booleans.
pngMonochrome :: [[Bool]] -> B.ByteString
pngMonochrome dat = B.concat $ hdr : concat [ihdr, imgdat, iend]
    where height = fromIntegral $ length dat
          width = fromIntegral $ length (head dat)
          ihdr = chunk iHDR (B.concat [
                be32 width, be32 height, be8 1, be8 0, be8 0, be8 0, be8 0])
          imgdat = chunk iDAT (Z.compress imgbits)
          imgbits = B.concat $ map scanlineMonochrome dat
          iend = chunk iEND B.empty

scanlineMonochrome :: [Bool] -> B.ByteString
scanlineMonochrome dat = 0 `B.cons` bitpackMonochrome dat

bitpackMonochrome' :: [Bool] -> Word8 -> Word8 -> B.ByteString
bitpackMonochrome' [] n b = if b /= 0x80 then B.singleton n else B.empty
bitpackMonochrome' (x:xs) n b =
    if b == 1
        then v `B.cons` bitpackMonochrome' xs 0 0x80
        else bitpackMonochrome' xs v (b `shiftR` 1)
    where v = if x then n else n .|. b

bitpackMonochrome :: [Bool] -> B.ByteString
bitpackMonochrome xs = bitpackMonochrome' xs 0 0x80

crc :: B.ByteString -> Word32
crc xs = updateCrc 0xffffffff xs `xor` 0xffffffff

updateCrc :: Word32 -> B.ByteString -> Word32
updateCrc = B.foldl' crcStep

crcStep :: Word32 -> Word8 -> Word32
crcStep crc ch = (crcTab ! n) `xor` (crc `shiftR` 8)
    where n = fromIntegral (crc `xor` fromIntegral ch)

crcTab :: Array Word8 Word32
crcTab = listArray (0,255) $ flip map [0..255] (\n ->
    foldl' (\c k -> if c .&. 1 == 1
                      then 0xedb88320 `xor` (c `shiftR` 1)
                      else c `shiftR` 1) n [0..7])




white, black :: Int
white = 255
black = 0

-- | Produces a single grayscale bit given a percent black
gray :: Int -> Int
gray percent = 255 - floor (fromIntegral percent * 2.55)

-- | Return a grayscale PNG file from a two dimensional bitmap stored in a list
-- of lines represented as a list of 0-255 integer values.
pngGrayscale :: [[Int]] -> B.ByteString
pngGrayscale dat = B.concat $ hdr : concat [ihdr, imgdat, iend]
     where height = fromIntegral $ length dat
           width = fromIntegral $ length (head dat)
           ihdr = chunk iHDR $ B.concat
                     [ be32 width
                     , be32 height
                     , be8 8   -- bits per pixel
                     , be8 0   -- color type
                     , be8 0   -- compression method
                     , be8 0   -- filter method
                     , be8 0 ] -- interlace method
           imgdat = chunk iDAT (Z.compress imgbits)
           imgbits = B.concat $ map scanlineGrayscale dat
           iend = chunk iEND B.empty

scanlineGrayscale :: [Int] -> B.ByteString
scanlineGrayscale dat = B.pack (0 : map fromIntegral dat)






-- | Return a RGB PNG file from a two dimensional bitmap stored in a list
-- of lines represented as a list of triples of 0-255 integer values.
pngRGB :: [[(Int,Int,Int)]] -> B.ByteString
pngRGB dat = B.concat $ hdr : concat [ihdr, imgdat ,iend]
     where height = fromIntegral $ length dat
           width = fromIntegral $ length (head dat)
           ihdr = chunk iHDR $ B.concat
                     [ be32 height
                     , be32 width
                     , be8 8   -- bits per sample (8 for r, 8 for g, 8 for b)
                     , be8 2   -- color type (2=rgb)
                     , be8 0   -- compression method
                     , be8 0   -- filter method
                     , be8 0 ] -- interlace method
           imgdat = chunk iDAT (Z.compress imagedata)
           imagedata = B.concat $ map scanlineRGB dat
           iend = chunk iEND B.empty

scanlineRGB :: [(Int,Int,Int)] -> B.ByteString
scanlineRGB dat = B.pack (0 : (map fromIntegral $ concatMap (\(r,g,b) -> [r,g,b]) dat))

Answer 1

罪魁祸首是

bitpackMonochrome' :: [Bool] -> Word8 -> Word8 -> B.ByteString
bitpackMonochrome' [] n b = if b /= 0x80 then B.singleton n else B.empty
bitpackMonochrome' (x:xs) n b =
    if b == 1
        then v `B.cons` bitpackMonochrome' xs 0 0x80
        else bitpackMonochrome' xs v (b `shiftR` 1)
    where v = if x then n else n .|. b

它使用 B.cons 连接 ByteString。这无论如何都是相当低效的，而且 B.cons 在它的第二个参数中是严格的。

因此，你会得到一个巨大的(对于 2000×2000 位图来说大约有 50 万深)thunk 的形式

v1 `B.cons` (v2 `B.cons` (v3 ...)))

溢出堆栈。

一个简单的解决方法 - 仍然相当低效 - 是在 bitpackMonochrome' 中使用列表，因为 (:) 在其第二个参数中是惰性的，

bitpackMonochrome :: [Bool] -> B.ByteString
bitpackMonochrome xs = B.pack $ bitpackMonochrome' xs 0 0x80

bitpackMonochrome' :: [Bool] -> Word8 -> Word8 -> [Word8]
bitpackMonochrome' [] n b = if b /= 0x80 then [n] else []
bitpackMonochrome' (x:xs) n b =
    if b == 1
        then v : bitpackMonochrome' xs 0 0x80
        else bitpackMonochrome' xs v (b `shiftR` 1)
    where v = if x then n else n .|. b

和 B.pack 在 bitpackMonochrome 中。

这样，你就不会得到巨大的 thunk，因为 (:) 可以在它的第二个参数之前被评估。

一个更高效的版本会根据维度计算所需的大小并使用

create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString

甚至

unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString

从 Data.ByteString.Internal 直接填充正确大小的分配缓冲区。