Частота символов

Question

Я пытаюсь найти частоту символов в файле, используя Haskell. Я хочу иметь возможность обрабатывать файлы размером ~ 500 МБ.

Что я пытался до сих пор

1. Это делает работу, но это немного медленно, как он разбирает файл 256 раз

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

2. Я также попытался с помощью 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

Вот реализация с использованием изменяемых, Unboxed векторов вместо конструкций более высокого уровня. Он также использует conduit для чтения файла, чтобы избежать ленивых операций ввода-вывода.

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.

EDIT: Я добавил одну из этих недостающих функций в 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

Это работает для меня на моем компьютере:

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 в два раза быстрее с HashMap, чем Map в этом случае. На моей машине, код, как письменными выполняется в 54 секунд, в то время как версия с использованием Map принимает 107.

Answer 3

@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, используя массив take 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 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