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 = 100 main = do f <- getArgs >>= return . head (arr,l) <- slurp f t0 <- getCPUTime arr' <- replicateM iter (start_encode f arr l) >>= return . head t1 <- getCPUTime printf "%.3f" $ (fromInteger (t1 - t0) :: Float) / (fromInteger 10 ^ 12 :: Float) dump (f++".haskell") arr' ((snd . bounds) arr') -------------------------------------------------------------------------------------- {-- start_encode takes a filename and produce the prefix to the uuencoded file and an array of word8:s that should be uuencoded --} start_encode :: String -> Buffer -> Int -> IO Buffer start_encode name arr read_size = do --1 prefix_string <- file_prefix name --2 liststring <- encode_body arr 0 read_size [prefix_string] --3 flatten liststring --4 file_prefix name = string_to_buffer ("begin 640 " ++ name ++ " \n") --5 {-- this function creates the suffix of the file backwards to make it easy to add this to the body of the file --} file_suffix = string_to_buffer " \nend" --6 {-- encode_body takes 45 characters at a time from the file and creates a uuencoded line represented as a buffer that is added to the accumulator. When there are less than 45 characters left the remaining charcters are encoded as the last line and the suffix is added before the accumulator is reversed. The return value is a string containing the uuencoded data and the suffix --} encode_body :: Buffer -> Int -> Int -> [Buffer] -> IO [Buffer] encode_body arr index limit acc = --7 if (limit - index) > 45 --8 then do linelist <- encode_line arr index (index+45) [] --9 buf <- make_line_buffer linelist 45 --10 encode_body arr (index+45) limit (buf:acc) --11 else do linelist <- encode_line arr index limit [] --12 buf <- make_line_buffer linelist (limit-index) --13 suffix_string <- file_suffix --14 return (reverse (suffix_string:(buf:acc))) --15 make_bytegroup :: Int -> Buffer -> Int -> IO (Int,Int,Int,Int) make_bytegroup 3 str index --16 | str `seq` index `seq` False = undefined --17 | otherwise = do --18 b0 <- str `unsafeRead` index >>= return . fromIntegral --19 b1 <- str `unsafeRead` (index+1) >>= return . fromIntegral --20 b2 <- str `unsafeRead` (index+2) >>= return . fromIntegral --21 let nb0 = ((shift b0 (-2))+32) --22 nb1 = ((((shift b0 4) .|. (shift b1 (-4))) .&. 63) +32) --23 nb2 = ((((shift b1 2) .|. (shift b2 (-6))) .&. 63) +32) --24 nb3 = (b2 .&. 63) +32 --25 in return $! (nb0, nb1, nb2, nb3) --26 make_bytegroup 2 str index --27 | str `seq` index `seq` False = undefined --28 | otherwise = do --29 b0 <- str `unsafeRead` index >>= return . fromIntegral --30 b1 <- str `unsafeRead` (index+1) >>= return . fromIntegral --31 let nb0 = (shift b0 (-2))+32 --32 nb1 = ((shift b0 4) .|. (shift b1 (-4)) .&. 63) +32 --33 nb2 = ((shift b1 2) .&. 63) +32 --34 nb3 = ord '=' --35 in return $! (nb0, nb1, nb2, nb3) --36 make_bytegroup 1 str index --37 | str `seq` index `seq` False = undefined --38 | otherwise = do --39 b0 <- str `unsafeRead` index >>= return . fromIntegral --40 let nb0 = (shift b0 (-2))+32 --41 nb1 = ((shift b0 4) .&. 63) +32 --42 nb2 = ord '=' --43 nb3 = ord '=' --44 in return $! (nb0, nb1, nb2, nb3) --45 encode_line :: Buffer -> Int -> Int -> [(Int,Int,Int,Int)] -> IO [(Int,Int,Int,Int)] encode_line arr index limit acc --46 | (limit-index) >= 3 = do --47 byte_group <- make_bytegroup 3 arr index --48 encode_line arr (index+3) limit (byte_group:acc) --49 | limit-index == 2 = do --50 byte_group <- make_bytegroup 2 arr index --51 return $! reverse (byte_group:acc) --52 | limit-index == 1 = do --53 byte_group <- make_bytegroup 1 arr index --54 return $! reverse (byte_group:acc) --55 | limit-index == 0 = --56 return $! reverse acc --57 make_line_buffer :: [(Int,Int,Int,Int)] -> Int -> IO Buffer make_line_buffer list0 n = do --58 arr <- newArray_ (0, ((length list0) * 4 + 1)) :: IO Buffer --59 unsafeWrite arr 0 $ fromIntegral $ (n+32) --60 let packList ((b1,b2,b3,b4):rest) ind = do --61 unsafeWrite arr ind $ fromIntegral $ b1 --62 unsafeWrite arr (ind+1) $ fromIntegral $ b2 --63 unsafeWrite arr (ind+2) $ fromIntegral $ b3 --64 unsafeWrite arr (ind+3) $ fromIntegral $ b4 --65 packList rest (ind+4) --66 packList [] ind = do --67 unsafeWrite arr ind $ fromIntegral $ (ord '\n') --68 packList list0 1 --69 return $! arr --70 ------------------------------------------------------------------------ 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 ------------------------------------------------------------------------- size array = let (0,stop) = bounds array in stop+1 copy_array:: Buffer -> Buffer -> [Int] -> Int -> IO Int copy_array inarray outarray (inind:inrest) outind = do byteval <- (inarray `unsafeRead` inind) unsafeWrite outarray outind $ byteval copy_array inarray outarray inrest (outind+1) copy_array inarray outarray [] outind = return $! outind flatten arraylist = do arr <- newArray_ (0, ((sum (map size arraylist)))) :: IO Buffer let do_flatten (smallarray:rest) ind = do nextind <- copy_array smallarray arr (indices smallarray) ind do_flatten rest nextind do_flatten [] ind = return arr do_flatten arraylist 0 string_to_buffer :: String -> IO Buffer string_to_buffer string = do arr <- newArray_ (0,((length string)-1)) let packList (b1:rest) ind = do unsafeWrite arr ind $ fromIntegral $ b1 packList rest (ind+1) packList [] ind = do dump ("testout."++(show (length string))) arr ((length string)) return $! arr packList (map ord string) 0