I'm trying to implement LZW compression in Haskell using Monads, here is my code so far with test cases:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
import Control.Monad.State
import Control.Monad.Writer
import Data.Char (chr, ord)
import Data.List (isPrefixOf, maximumBy)
import Data.Function
import Test.QuickCheck
type Dictionary = [String]
dictionary :: Dictionary
dictionary = [[chr x] | x <- [0..127]]
test_dictionary =
[ map ord (concat dictionary) == [0..127]
, all (\str -> length str == 1) dictionary
]
prefixes :: String -> Dictionary -> [(Int, String)]
prefixes str dict = [(x, dict!!x) | x <- [0..length dict - 1], isPrefixOf (dict!!x) str]
test_prefixes =
[ prefixes "" dictionary == []
, prefixes "appletree" [] == []
, prefixes "appletree" ["ap", "apple", "tree", "pear"] == [(0, "ap"), (1, "apple")]
, prefixes "babe" dictionary == [(98, "b")]
]
longest :: [(Int, String)] -> (Int, String)
longest prefs = maximumBy (compare `on` (\(x,y) -> length y)) prefs
test_longest =
[ longest [(30, "a"), (20, "abc"), (15, "ab")] == (20, "abc")
, longest [(30, "a"), (20, "abc"), (15, "abc")] == (15, "abc")
]
instance MonadState Dictionary ((->) Dictionary) where
get = \s -> s
munch :: MonadState Dictionary m => String -> m (Int, String, String)
munch str = do
dict <- get
let longst = longest (prefixes str dict)
return (fst longst, snd longst, [str!!x | x <- [length (snd longst)..length str - 1]])
test_munch =
[ evalState (munch "a") ["a"] == (0, "a", "")
, evalState (munch "appletree") ["a"] == (0, "a", "ppletree")
, evalState (munch "peach") ["a", "ba", "b"] == (1, "ba", "be")
]
instance MonadState m (StateT Dictionary ((->) m)) where
append :: MonadState Dictionary m => String -> String -> m ()
append s "" = return ()
append s w = do
dict <- get
let newWord = s ++ (take 1 w)
if (notElem newWord dict)
then do
put (dict++[newWord])
else return ()
test_append =
[ execState (append "a" "") [] == []
, execState (append "a" "") dictionary == dictionary
, execState (append "a" "bc") [] == ["ab"]
, execState (append "a" "bc") ["ab"] == ["ab"]
]
encode :: String -> WriterT [Int] (State Dictionary) ()
encode "" = return ()
encode w = do
dict <- get
let (a, b, c) = (munch w) dict
if length dict < 256
then do
tell [a]
put ((append b c) dict)
encode c
else return ()
test_encode =
[ evalState (execWriterT (encode "")) [] == []
, evalState (execWriterT (encode "aaa")) ["a"] == [0, 1]
, evalState (execWriterT (encode "aaaa")) ["a"] == [0, 1, 0]
, evalState (execWriterT (encode "aaaaa")) ["a"] == [0, 1, 1]
, evalState (execWriterT (encode "abababab")) ["a", "b"] == [0, 1, 2, 4, 1]
, evalState (execWriterT (encode "aaabbbccc")) dictionary
== [97, 128, 98, 130, 99, 132]
]
decode :: [Int] -> WriterT String (State Dictionary) ()
decode [] = return ()
decode [x] = do
dict <- get
tell (dict!!x)
decode (x:xs) = do
dict <- get
let f = dict!!x
let s = if(length dict > head xs)
then dict!!head xs
else f
tell f
put (append f s) dict
decode xs
test_decode =
[ evalState (execWriterT (decode [])) [] == []
, evalState (execWriterT (decode [0])) ["a"] == "a"
, evalState (execWriterT (decode [0, 1, 1, 0])) ["a", "b"] == "abba"
, evalState (execWriterT (decode [0, 1, 2, 0])) ["a", "b"] == "ababa"
, evalState (execWriterT (decode [0, 1, 2, 4, 1])) ["a", "b"] == "abababab"
, evalState (execWriterT (decode [97, 128, 98, 130, 99, 132])) dictionary
== "aaabbbccc"
]
compress :: String -> [Int]
compress w = evalState (execWriterT (encode w)) dictionary
test_compress =
[ compress "" == []
, compress "a" == [97]
, compress "aaa" == [97, 128]
, compress "aaabbbccc" == [97, 128, 98, 130, 99, 132]
]
decompress :: [Int] -> String
decompress list = evalState (execWriterT (decode list)) dictionary
test_decompress =
[ decompress [] == ""
, decompress [97] == "a"
, decompress [97, 128] == "aaa"
, decompress [97, 128, 98, 130, 99, 132] == "aaabbbccc"
]
prop_compressDecompress :: String -> Bool
prop_compressDecompress w = do
let tmp = [chr (div (ord x) 2) | x <- w]
decompress (compress tmp) == tmp
compressFile :: FilePath -> FilePath -> IO ()
compressFile source target = do
s <- readFile source
let compressed = compress s
let chars = [chr x | x <- compressed]
writeFile target chars
decompressFile :: FilePath -> FilePath -> IO ()
decompressFile source target = do
s <- readFile source
let code = [ord x | x <- s]
let decompressed = decompress code
writeFile target decompressed
allTests = [test_dictionary, test_prefixes, test_longest, test_munch, test_append
,test_encode
--, test_decode, test_compress, test_decompress
]
main = do
--quickCheck prop_compressDecompress
print (allTests, and (concat allTests))
With this code I get the following error (referring to the use of put in "encode" and "decode" functions) :
Main.hs@80:13-80:16 No instance for (MonadState () (StateT Dictionary Data.Functor.Identity.Identity)) arising from a use of put
I've tried to define this instance but the best I could achieve is a "functional dependencies conflict between instance declarations" error. I know there is more simple solutions without Monads but I have to use them, also the types of the functions are not to be modified.
Could you give me any help about what I'm doing wrong here?
You don't need to write any instances. You're simply using append and munch in a wrong way.
append has type MonadState Dictionary m => String -> String -> m ().
If f and s are strings, then append f s yields a state-modifying action that eventually returns a ().
put has type MonadState s m => s -> m (). put replaces the current state with the s argument.
In the light of this, put (append f s) dict makes little sense. You're supposed to supply put a single argument. And you don't have to do anything with dict there; a core point of using the State monad is that the state is left implicit, and there is no need to pass it around.
Also, append f s by itself already updates the state. So what you want here is simply append f s, instead of put (append x y) dict.
There's a similar error in encode with munch; it has a single String argument, so (munch w) dict is erroneous. Again, no need to touch dict. Also, because munch w yields a monadic result, you must bind the result with <- instead of let. So, you should replace let (a, b, c) = (much w dict) with (a, b, c) <- munch w.