import Control.Monad import Data.Char import Data.Array.IO import Data.Array.Base import Data.Bits import Data.Word import System import System.CPUTime import System.IO import Text.Printf iter :: Int iter = 100 main = do f <- getArgs >>= return . head (arr,l) <- slurp f t0 <- getCPUTime (name,arr') <- replicateM iter (start_decode arr) >>= return . head t1 <- getCPUTime printf "%.3f" $ (fromInteger (t1 - t0) :: Float) / (fromInteger 10 ^ 12 :: Float) dump name arr' ((snd . bounds) arr') --------------------------------------------------------------------------------------- start_decode::Buffer -> IO (String,Buffer) start_decode array = do --1 (name,newindex) <- get_this_filename array 10 [] --2 u <- array `unsafeRead` 6 >>= return . fromIntegral --3 g <- array `unsafeRead` 7 >>= return . fromIntegral --4 a <- array `unsafeRead` 8 >>= return . fromIntegral --5 32 <- array `unsafeRead` 9 >>= return . fromIntegral --6 res <- decode array newindex [] --7 return (name, res) --8 decode_line :: Buffer -> Int -> Int -> [Int] -> IO Buffer decode_line arr index limit acc --9 | arr `seq` index `seq` limit `seq` acc `seq` False = undefined --10 | ((limit-index) >= 4) = do --11 triplet <- build_byte_triplet arr index --12 decode_line arr (index+4) limit (triplet:acc) --13 | ((limit-index) == 3) = do --14 duo <- build_byte_duo arr index --15 to_buffer (reverse acc) (2,duo) --16 | ((limit-index) == 2) = do --17 byte <- build_byte arr index --18 to_buffer (reverse acc) (1,byte) --19 | ((limit-index) == 0) = do --20 to_buffer (reverse acc) (0,0) --21 to_buffer :: [Int] -> (Int,Int) -> IO Buffer to_buffer list0 (n,rest) = do --22 arr <- newArray_ (1, ((length list0) * 3 + n)) --23 let packList (triple:rest) ind = do --24 unsafeWrite arr ind $ fromIntegral $ (triple `shiftR` 16) .&. 255 --25 unsafeWrite arr (ind+1) $ fromIntegral $ (triple `shiftR` 8) .&. 255 --26 unsafeWrite arr (ind+2) $ fromIntegral $ triple .&. 255 --27 packList rest (ind+3) --28 packList [] ind = --29 case n of 0 -> return () --30 1 -> do unsafeWrite arr ind $ fromIntegral $ rest --31 2 -> do unsafeWrite arr ind $ fromIntegral $ --32 (rest `shiftR` 8) .&. 255 --33 unsafeWrite arr ind $ fromIntegral $ --34 rest .&. 255 --35 packList list0 0 --36 return $! arr --37 decode :: Buffer -> Int -> [Buffer] -> IO Buffer decode array index acc = do --40 count <- array `unsafeRead` index >>= return . fromIntegral --41 octets <- calc_octets count --42 limit <- return (nextindex + octets) --43 if octets == 0 --44 then flatten (reverse acc) --45 else do newline <- decode_line array nextindex limit [] --46 nextindex <- skip_to_newline array limit --47 decode array nextindex (newline:acc) --48 where nextindex = index+1 --49 skip_to_newline :: Buffer -> Int -> IO Int skip_to_newline array index --50 | array `seq` index `seq` False = undefined --51 | otherwise = do --52 b0 <- array `unsafeRead` index >>= return . fromIntegral --53 if b0 == 10 --54 then return (index+1) --55 else skip_to_newline array (index+1) --56 calc_octets val = do --57 return $! ((div (val-32) 3) * 4) + (extra_bytes (rem (val-32) 3)) --58 extra_bytes 0 = 0 --59 extra_bytes 1 = 2 --60 extra_bytes 2 = 3 --70 build_byte_triplet arr index = do --71 b0 <- arr `unsafeRead` index >>= return . fromIntegral --72 b1 <- arr `unsafeRead` (index+1) >>= return . fromIntegral --73 b2 <- arr `unsafeRead` (index+2) >>= return . fromIntegral --74 b3 <- arr `unsafeRead` (index+3) >>= return . fromIntegral --75 return $! (shift (b0-32) 18) .|. (shift (b1-32) 12) .|. --76 (shift (b2-32) 6) .|. (b3-32) --77 build_byte_duo arr index = do --78 b0 <- arr `unsafeRead` index >>= return . fromIntegral --79 b1 <- arr `unsafeRead` (index+1) >>= return . fromIntegral --80 b2 <- arr `unsafeRead` (index+2) >>= return . fromIntegral --81 return $! (shift (b0-32) 10) .|. (shift (b1-32) 4) .|. (shift (b2-32) (-2)) --82 build_byte arr index = do --83 b0 <- arr `unsafeRead` index >>= return . fromIntegral --84 b1 <- arr `unsafeRead` (index+1) >>= return . fromIntegral --85 return $! (shift (b0-32) 2) .|. (shift (b1-32) (-4)) --86 get_this_filename :: Buffer -> Int -> [Char] -> IO ([Char],Int) get_this_filename arr index acc = do --87 pchar <- (arr `unsafeRead` index) >>= return . fromIntegral --88 if chr pchar == '\n' --89 then return $! (reverse acc,(index+1)) --90 else get_this_filename arr (index+1) ((chr pchar):acc) --91 ----------------------------------------------------------------------------------------- size array = let (_,stop) = bounds array in stop copy_array:: Buffer -> Buffer -> [Int] -> Int -> IO Int copy_array outarray inarray (outind:outrest) inind = do byteval <- (inarray `unsafeRead` outind) unsafeWrite outarray inind $ byteval copy_array outarray inarray outrest (inind+1) copy_array outarray inarray [] inind = return $! inind flatten arraylist = do arr <- newArray_ (1, (sum (map size arraylist))) :: IO Buffer let do_flatten (smallarray:rest) ind = do nextind <- copy_array arr smallarray (indices smallarray) ind do_flatten rest nextind do_flatten [] ind = return arr do_flatten arraylist 1 ------------------------------------------------------------------------ type Buffer = IOUArray Int Word8 slurp :: FilePath -> IO (Buffer, Int) slurp f = do h <- openBinaryFile f ReadMode l <- hFileSize h arr <- newArray_ (0,fromIntegral l-1) :: IO Buffer hGetArray h arr (fromIntegral l) hClose h return (arr,fromIntegral l) dump :: FilePath -> Buffer -> Int -> IO () dump name arr l = do h <- openBinaryFile name WriteMode hPutArray h arr l hClose h