創建單色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在其第二個論證中是嚴格的。

因此，你得到溢出堆棧形式

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

的一個巨大的（大約50萬深爲2000×2000位圖像）的thunk。

一個簡單的治療 - 這還是相當低效 - 在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

直接填寫正確的大小分配的緩衝區。