Question

我正在尝试使用 Haskell 查找文件中的字符频率。我希望能够处理大小约为500MB的文件。

到目前为止我一直在尝试

它完成了这项工作但是因为它解析文件256次而有点慢

calculateFrequency :: L.ByteString -> [(Word8, Int64)]
calculateFrequency f = foldl (\acc x -> (x, L.count x f):acc) [] [255, 254.. 0]

我也尝试过使用Data.Map，但程序内存耗尽（在ghc解释器中）。

import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M

calculateFrequency' :: L.ByteString -> [(Word8, Int64)]
calculateFrequency' xs = M.toList $ L.foldl' (\m word -> M.insertWith (+) word 1 m) (M.empty) xs

Answer 1

这是使用可变的，未装箱的向量而不是更高级别的构造的实现。它还使用conduit来读取文件以避免延迟I / O.

import           Control.Monad.IO.Class
import qualified Data.ByteString             as S
import           Data.Conduit
import           Data.Conduit.Binary         as CB
import qualified Data.Conduit.List           as CL
import qualified Data.Vector.Unboxed.Mutable as VM
import           Data.Word                   (Word8)

type Freq = VM.IOVector Int

newFreq :: MonadIO m => m Freq
newFreq = liftIO $ VM.replicate 256 0

printFreq :: MonadIO m => Freq -> m ()
printFreq freq =
    liftIO $ mapM_ go [0..255]
  where
    go i = do
        x <- VM.read freq i
        putStrLn $ show i ++ ": " ++ show x

addFreqWord8 :: MonadIO m => Freq -> Word8 -> m ()
addFreqWord8 f w = liftIO $ do
    let index = fromIntegral w
    oldCount <- VM.read f index
    VM.write f index (oldCount + 1)

addFreqBS :: MonadIO m => Freq -> S.ByteString -> m ()
addFreqBS f bs =
    loop (S.length bs - 1)
  where
    loop (-1) = return ()
    loop i = do
        addFreqWord8 f (S.index bs i)
        loop (i - 1)

-- | The main entry point.
main :: IO ()
main = do
    freq <- newFreq
    runResourceT
        $  sourceFile "random"
        $$ CL.mapM_ (addFreqBS freq)
    printFreq freq

我用500MB的随机数据运行这个并与@ josejuan的基于UArray的答案进行比较：

基于导管的/可变载体：1.006s
UArray：17.962s

我认为应该可以保持josejuan的高级方法的优雅，同时保持可变矢量实现的速度，但我还没有机会尝试实现像那呢。另请注意，对于一些通用的辅助函数（如Data.ByteString.mapM或Data.Conduit.Binary.mapM），实现可能会非常简单，而不会影响性能。

你也可以play with this implementation on FP Haskell Center。

编辑：我将其中一个缺失的函数添加到conduit并稍微清理了代码;它现在看起来如下：

import           Control.Monad.Trans.Class   (lift)
import           Data.ByteString             (ByteString)
import           Data.Conduit                (Consumer, ($$))
import qualified Data.Conduit.Binary         as CB
import qualified Data.Vector.Unboxed         as V
import qualified Data.Vector.Unboxed.Mutable as VM
import           System.IO                   (stdin)

freqSink :: Consumer ByteString IO (V.Vector Int)
freqSink = do
    freq <- lift $ VM.replicate 256 0
    CB.mapM_ $ \w -> do
        let index = fromIntegral w
        oldCount <- VM.read freq index
        VM.write freq index (oldCount + 1)
    lift $ V.freeze freq

main :: IO ()
main = (CB.sourceHandle stdin $$ freqSink) >>= print

功能的唯一区别在于如何打印频率。

Answer 2

@Alex答案很好但是，只有256个值（索引），数组应该更好

import qualified Data.ByteString.Lazy as L
import qualified Data.Array.Unboxed as A
import qualified Data.ByteString as B
import Data.Int
import Data.Word

fq :: L.ByteString -> A.UArray Word8 Int64
fq = A.accumArray (+) 0 (0, 255) . map (\c -> (c, 1)) . concat . map B.unpack . L.toChunks

main = L.getContents >>= print . fq

@alex code take（对于我的示例文件）24.81 segs，使用数组占用7.77个segs。

更新：

尽管Snoyman解决方案更好，但可以避免unpack的改进

fq :: L.ByteString -> A.UArray Word8 Int64
fq = A.accumArray (+) 0 (0, 255) . toCounterC . L.toChunks
     where toCounterC [] = []
           toCounterC (x:xs) = toCounter x (B.length x) xs
           toCounter  _ 0 xs = toCounterC xs
           toCounter  x i xs = (B.index x i', 1): toCounter x i' xs
                               where i' = i - 1

加速度提高约50％。

更新：

使用IOVector作为Snoyman是Conduit版本（实际上要快一点，但这是一个原始代码，更好地使用Conduit）

import           Data.Int
import           Data.Word
import           Control.Monad.IO.Class
import qualified Data.ByteString.Lazy          as L
import qualified Data.Array.Unboxed            as A
import qualified Data.ByteString               as B
import qualified Data.Vector.Unboxed.Mutable   as V

fq :: L.ByteString -> IO (V.IOVector Int64)
fq xs =
     do
       v <- V.replicate 256 0 :: IO (V.IOVector Int64)
       g v $ L.toChunks xs
       return v
     where g v = toCounterC
                 where toCounterC [] = return ()
                       toCounterC (x:xs) = toCounter x (B.length x) xs
                       toCounter  _ 0 xs = toCounterC xs
                       toCounter  x i xs = do
                                             let i' = i - 1
                                                 w  = fromIntegral $ B.index x i'
                                             c <- V.read v w
                                             V.write v w (c + 1)
                                             toCounter x i' xs

main = do
          v <- L.getContents >>= fq
          mapM_ (\i -> V.read v i >>= liftIO . putStr . (++", ") . show) [0..255]

Answer 3

这适用于我的电脑：

module Main where
import qualified Data.HashMap.Strict as M
import qualified Data.ByteString.Lazy as L
import Data.Word
import Data.Int

calculateFrequency :: L.ByteString -> [(Word8, Int64)]
calculateFrequency xs = M.toList $ L.foldl' (\m word -> M.insertWith (+) word 1 m) M.empty xs

main = do
    bs <- L.readFile "E:\\Steam\\SteamApps\\common\\Sid Meier's Civilization V\\Assets\\DLC\\DLC_Deluxe\\Behind the Scenes\\Behind the Scenes.wmv"
    print (calculateFrequency bs)

不会耗尽内存，甚至不会加载整个文件，但需要600mb +文件永远（大约一分钟）！我用ghc 7.6.3编译了这个。

我应该指出代码基本相同，除了严格的HashMap而不是懒惰的Map。

请注意，在这种情况下，insertWith的{{1}}速度是HashMap的两倍。在我的机器上，写入的代码在54秒内执行，而使用Map的版本需要107。

Answer 4

我的两分钱（使用STUArray）。无法将其与其他解决方案进行比较。有人可能愿意尝试......

module Main where

import Data.Array.ST (runSTUArray, newArray, readArray, writeArray)
import Data.Array.Unboxed (UArray)
import qualified Data.ByteString.Lazy as L (ByteString, unpack, getContents)
import Data.Word
import Data.Int
import Control.Monad (forM_)

calculateFrequency :: L.ByteString -> UArray Word8 Int64 
calculateFrequency bs = runSTUArray $ do
    a <- newArray (0, 255) 0
    forM_ (L.unpack bs) $ \i -> readArray a i >>= writeArray a i . succ
    return a

main = L.getContents >>= print . calculateFrequency

字符频率

4 个答案: